{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}

-- | @futhark pkg@
module Futhark.CLI.Pkg (main) where

import qualified Codec.Archive.Zip as Zip
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.State
import qualified Data.ByteString.Lazy as LBS
import Data.List (intercalate, isPrefixOf)
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Futhark.Pkg.Info
import Futhark.Pkg.Solve
import Futhark.Pkg.Types
import Futhark.Util (directoryContents, maxinum)
import Futhark.Util.Log
import Futhark.Util.Options
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import qualified System.FilePath.Posix as Posix
import System.IO
import Prelude

--- Installing packages

installInDir :: BuildList -> FilePath -> PkgM ()
installInDir :: BuildList -> FilePath -> PkgM ()
installInDir (BuildList Map Text SemVer
bl) FilePath
dir = do
  let putEntry :: FilePath -> FilePath -> Entry -> IO (Maybe FilePath)
putEntry FilePath
from_dir FilePath
pdir Entry
entry
        -- The archive may contain all kinds of other stuff that we don't want.
        | Bool -> Bool
not (FilePath -> FilePath -> Bool
isInPkgDir FilePath
from_dir (FilePath -> Bool) -> FilePath -> Bool
forall a b. (a -> b) -> a -> b
$ Entry -> FilePath
Zip.eRelativePath Entry
entry)
            Bool -> Bool -> Bool
|| FilePath -> Bool
hasTrailingPathSeparator (Entry -> FilePath
Zip.eRelativePath Entry
entry) =
          Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing
        | Bool
otherwise = do
          -- Since we are writing to paths indicated in a zipfile we
          -- downloaded from the wild Internet, we are going to be a
          -- little bit paranoid.  Specifically, we want to avoid
          -- writing outside of the 'lib/' directory.  We do this by
          -- bailing out if the path contains any '..' components.  We
          -- have to use System.FilePath.Posix, because the zip library
          -- claims to encode filepaths with '/' directory seperators no
          -- matter the host OS.
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath
".." FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FilePath -> [FilePath]
Posix.splitPath (Entry -> FilePath
Zip.eRelativePath Entry
entry)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            FilePath -> IO ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
              FilePath
"Zip archive for " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
pdir FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" contains suspicious path: "
                FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Entry -> FilePath
Zip.eRelativePath Entry
entry
          let f :: FilePath
f = FilePath
pdir FilePath -> FilePath -> FilePath
</> FilePath -> FilePath -> FilePath
makeRelative FilePath
from_dir (Entry -> FilePath
Zip.eRelativePath Entry
entry)
          Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeDirectory FilePath
f
          FilePath -> ByteString -> IO ()
LBS.writeFile FilePath
f (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Entry -> ByteString
Zip.fromEntry Entry
entry
          Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
f

      isInPkgDir :: FilePath -> FilePath -> Bool
isInPkgDir FilePath
from_dir FilePath
f =
        FilePath -> [FilePath]
Posix.splitPath FilePath
from_dir [FilePath] -> [FilePath] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath -> [FilePath]
Posix.splitPath FilePath
f

  [(Text, SemVer)] -> ((Text, SemVer) -> PkgM ()) -> PkgM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map Text SemVer -> [(Text, SemVer)]
forall k a. Map k a -> [(k, a)]
M.toList Map Text SemVer
bl) (((Text, SemVer) -> PkgM ()) -> PkgM ())
-> ((Text, SemVer) -> PkgM ()) -> PkgM ()
forall a b. (a -> b) -> a -> b
$ \(Text
p, SemVer
v) -> do
    PkgRevInfo PkgM
info <- Text -> SemVer -> PkgM (PkgRevInfo PkgM)
forall (m :: * -> *).
MonadPkgRegistry m =>
Text -> SemVer -> m (PkgRevInfo m)
lookupPackageRev Text
p SemVer
v
    Archive
a <- PkgRevInfo PkgM -> PkgM Archive
forall (m :: * -> *).
(MonadLogger m, MonadIO m, MonadFail m) =>
PkgRevInfo m -> m Archive
downloadZipball PkgRevInfo PkgM
info
    PkgManifest
m <- GetManifest PkgM -> PkgM PkgManifest
forall (m :: * -> *). GetManifest m -> m PkgManifest
getManifest (GetManifest PkgM -> PkgM PkgManifest)
-> GetManifest PkgM -> PkgM PkgManifest
forall a b. (a -> b) -> a -> b
$ PkgRevInfo PkgM -> GetManifest PkgM
forall (m :: * -> *). PkgRevInfo m -> GetManifest m
pkgRevGetManifest PkgRevInfo PkgM
info

    -- Compute the directory in the zipball that should contain the
    -- package files.
    let noPkgDir :: PkgM a
noPkgDir =
          FilePath -> PkgM a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> PkgM a) -> FilePath -> PkgM a
forall a b. (a -> b) -> a -> b
$
            FilePath
"futhark.pkg for " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack Text
p FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"-"
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack (SemVer -> Text
prettySemVer SemVer
v)
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" does not define a package path."
    FilePath
from_dir <- PkgM FilePath
-> (FilePath -> PkgM FilePath) -> Maybe FilePath -> PkgM FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PkgM FilePath
forall {a}. PkgM a
noPkgDir (FilePath -> PkgM FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> PkgM FilePath)
-> (FilePath -> FilePath) -> FilePath -> PkgM FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PkgRevInfo PkgM -> FilePath
forall (m :: * -> *). PkgRevInfo m -> FilePath
pkgRevZipballDir PkgRevInfo PkgM
info FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>)) (Maybe FilePath -> PkgM FilePath)
-> Maybe FilePath -> PkgM FilePath
forall a b. (a -> b) -> a -> b
$ PkgManifest -> Maybe FilePath
pkgDir PkgManifest
m

    -- The directory in the local file system that will contain the
    -- package files.
    let pdir :: FilePath
pdir = FilePath
dir FilePath -> FilePath -> FilePath
</> Text -> FilePath
T.unpack Text
p
    -- Remove any existing directory for this package.  This is a bit
    -- inefficient, as the likelihood that the old ``lib`` directory
    -- already contains the correct version is rather high.  We should
    -- have a way to recognise this situation, and not download the
    -- zipball in that case.
    IO () -> PkgM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PkgM ()) -> IO () -> PkgM ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removePathForcibly FilePath
pdir
    IO () -> PkgM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PkgM ()) -> IO () -> PkgM ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
pdir

    [FilePath]
written <-
      [Maybe FilePath] -> [FilePath]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe FilePath] -> [FilePath])
-> PkgM [Maybe FilePath] -> PkgM [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [Maybe FilePath] -> PkgM [Maybe FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((Entry -> IO (Maybe FilePath)) -> [Entry] -> IO [Maybe FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FilePath -> FilePath -> Entry -> IO (Maybe FilePath)
putEntry FilePath
from_dir FilePath
pdir) ([Entry] -> IO [Maybe FilePath]) -> [Entry] -> IO [Maybe FilePath]
forall a b. (a -> b) -> a -> b
$ Archive -> [Entry]
Zip.zEntries Archive
a)

    Bool -> PkgM () -> PkgM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
written) (PkgM () -> PkgM ()) -> PkgM () -> PkgM ()
forall a b. (a -> b) -> a -> b
$
      FilePath -> PkgM ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> PkgM ()) -> FilePath -> PkgM ()
forall a b. (a -> b) -> a -> b
$
        FilePath
"Zip archive for package " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack Text
p
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" does not contain any files in "
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
from_dir

libDir, libNewDir, libOldDir :: FilePath
(FilePath
libDir, FilePath
libNewDir, FilePath
libOldDir) = (FilePath
"lib", FilePath
"lib~new", FilePath
"lib~old")

-- | Install the packages listed in the build list in the @lib@
-- directory of the current working directory.  Since we are touching
-- the file system, we are going to be very paranoid.  In particular,
-- we want to avoid corrupting the @lib@ directory if something fails
-- along the way.
--
-- The procedure is as follows:
--
-- 1) Create a directory @lib~new@.  Delete an existing @lib~new@ if
-- necessary.
--
-- 2) Populate @lib~new@ based on the build list.
--
-- 3) Rename @lib@ to @lib~old@.  Delete an existing @lib~old@ if
-- necessary.
--
-- 4) Rename @lib~new@ to @lib@
--
-- 5) If the current package has package path @p@, move @lib~old/p@ to
-- @lib~new/p@.
--
-- 6) Delete @lib~old@.
--
-- Since POSIX at least guarantees atomic renames, the only place this
-- can fail is between steps 3, 4, and 5.  In that case, at least the
-- @lib~old@ will still exist and can be put back by the user.
installBuildList :: Maybe PkgPath -> BuildList -> PkgM ()
installBuildList :: Maybe Text -> BuildList -> PkgM ()
installBuildList Maybe Text
p BuildList
bl = do
  Bool
libdir_exists <- IO Bool -> PkgM Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> PkgM Bool) -> IO Bool -> PkgM Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesDirectoryExist FilePath
libDir

  -- 1
  IO () -> PkgM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PkgM ()) -> IO () -> PkgM ()
forall a b. (a -> b) -> a -> b
$ do
    FilePath -> IO ()
removePathForcibly FilePath
libNewDir
    Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
False FilePath
libNewDir

  -- 2
  BuildList -> FilePath -> PkgM ()
installInDir BuildList
bl FilePath
libNewDir

  -- 3
  Bool -> PkgM () -> PkgM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
libdir_exists (PkgM () -> PkgM ()) -> PkgM () -> PkgM ()
forall a b. (a -> b) -> a -> b
$
    IO () -> PkgM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PkgM ()) -> IO () -> PkgM ()
forall a b. (a -> b) -> a -> b
$ do
      FilePath -> IO ()
removePathForcibly FilePath
libOldDir
      FilePath -> FilePath -> IO ()
renameDirectory FilePath
libDir FilePath
libOldDir

  -- 4
  IO () -> PkgM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PkgM ()) -> IO () -> PkgM ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
renameDirectory FilePath
libNewDir FilePath
libDir

  -- 5
  case Text -> FilePath
pkgPathFilePath (Text -> FilePath) -> Maybe Text -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
p of
    Just FilePath
pfp | Bool
libdir_exists -> IO () -> PkgM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PkgM ()) -> IO () -> PkgM ()
forall a b. (a -> b) -> a -> b
$ do
      Bool
pkgdir_exists <- FilePath -> IO Bool
doesDirectoryExist (FilePath -> IO Bool) -> FilePath -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath
libOldDir FilePath -> FilePath -> FilePath
</> FilePath
pfp
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
pkgdir_exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        -- Ensure the parent directories exist so that we can move the
        -- package directory directly.
        Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeDirectory (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
libDir FilePath -> FilePath -> FilePath
</> FilePath
pfp
        FilePath -> FilePath -> IO ()
renameDirectory (FilePath
libOldDir FilePath -> FilePath -> FilePath
</> FilePath
pfp) (FilePath
libDir FilePath -> FilePath -> FilePath
</> FilePath
pfp)
    Maybe FilePath
_ -> () -> PkgM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  -- 6
  Bool -> PkgM () -> PkgM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
libdir_exists (PkgM () -> PkgM ()) -> PkgM () -> PkgM ()
forall a b. (a -> b) -> a -> b
$ IO () -> PkgM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PkgM ()) -> IO () -> PkgM ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removePathForcibly FilePath
libOldDir

getPkgManifest :: PkgM PkgManifest
getPkgManifest :: PkgM PkgManifest
getPkgManifest = do
  Bool
file_exists <- IO Bool -> PkgM Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> PkgM Bool) -> IO Bool -> PkgM Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
futharkPkg
  Bool
dir_exists <- IO Bool -> PkgM Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> PkgM Bool) -> IO Bool -> PkgM Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesDirectoryExist FilePath
futharkPkg

  case (Bool
file_exists, Bool
dir_exists) of
    (Bool
True, Bool
_) -> IO PkgManifest -> PkgM PkgManifest
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PkgManifest -> PkgM PkgManifest)
-> IO PkgManifest -> PkgM PkgManifest
forall a b. (a -> b) -> a -> b
$ FilePath -> IO PkgManifest
parsePkgManifestFromFile FilePath
futharkPkg
    (Bool
_, Bool
True) ->
      FilePath -> PkgM PkgManifest
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> PkgM PkgManifest) -> FilePath -> PkgM PkgManifest
forall a b. (a -> b) -> a -> b
$
        FilePath
futharkPkg
          FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" exists, but it is a directory!  What in Odin's beard..."
    (Bool, Bool)
_ -> IO PkgManifest -> PkgM PkgManifest
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PkgManifest -> PkgM PkgManifest)
-> IO PkgManifest -> PkgM PkgManifest
forall a b. (a -> b) -> a -> b
$ do
      Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
futharkPkg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" not found - pretending it's empty."
      PkgManifest -> IO PkgManifest
forall (m :: * -> *) a. Monad m => a -> m a
return (PkgManifest -> IO PkgManifest) -> PkgManifest -> IO PkgManifest
forall a b. (a -> b) -> a -> b
$ Maybe Text -> PkgManifest
newPkgManifest Maybe Text
forall a. Maybe a
Nothing

putPkgManifest :: PkgManifest -> PkgM ()
putPkgManifest :: PkgManifest -> PkgM ()
putPkgManifest = IO () -> PkgM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PkgM ())
-> (PkgManifest -> IO ()) -> PkgManifest -> PkgM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text -> IO ()
T.writeFile FilePath
futharkPkg (Text -> IO ()) -> (PkgManifest -> Text) -> PkgManifest -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PkgManifest -> Text
prettyPkgManifest

--- The CLI

newtype PkgConfig = PkgConfig {PkgConfig -> Bool
pkgVerbose :: Bool}

-- | The monad in which futhark-pkg runs.
newtype PkgM a = PkgM {forall a.
PkgM a -> ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) a
unPkgM :: ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) a}
  deriving ((forall a b. (a -> b) -> PkgM a -> PkgM b)
-> (forall a b. a -> PkgM b -> PkgM a) -> Functor PkgM
forall a b. a -> PkgM b -> PkgM a
forall a b. (a -> b) -> PkgM a -> PkgM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> PkgM b -> PkgM a
$c<$ :: forall a b. a -> PkgM b -> PkgM a
fmap :: forall a b. (a -> b) -> PkgM a -> PkgM b
$cfmap :: forall a b. (a -> b) -> PkgM a -> PkgM b
Functor, Functor PkgM
Functor PkgM
-> (forall a. a -> PkgM a)
-> (forall a b. PkgM (a -> b) -> PkgM a -> PkgM b)
-> (forall a b c. (a -> b -> c) -> PkgM a -> PkgM b -> PkgM c)
-> (forall a b. PkgM a -> PkgM b -> PkgM b)
-> (forall a b. PkgM a -> PkgM b -> PkgM a)
-> Applicative PkgM
forall a. a -> PkgM a
forall a b. PkgM a -> PkgM b -> PkgM a
forall a b. PkgM a -> PkgM b -> PkgM b
forall a b. PkgM (a -> b) -> PkgM a -> PkgM b
forall a b c. (a -> b -> c) -> PkgM a -> PkgM b -> PkgM c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. PkgM a -> PkgM b -> PkgM a
$c<* :: forall a b. PkgM a -> PkgM b -> PkgM a
*> :: forall a b. PkgM a -> PkgM b -> PkgM b
$c*> :: forall a b. PkgM a -> PkgM b -> PkgM b
liftA2 :: forall a b c. (a -> b -> c) -> PkgM a -> PkgM b -> PkgM c
$cliftA2 :: forall a b c. (a -> b -> c) -> PkgM a -> PkgM b -> PkgM c
<*> :: forall a b. PkgM (a -> b) -> PkgM a -> PkgM b
$c<*> :: forall a b. PkgM (a -> b) -> PkgM a -> PkgM b
pure :: forall a. a -> PkgM a
$cpure :: forall a. a -> PkgM a
Applicative, Monad PkgM
Monad PkgM -> (forall a. IO a -> PkgM a) -> MonadIO PkgM
forall a. IO a -> PkgM a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> PkgM a
$cliftIO :: forall a. IO a -> PkgM a
MonadIO, MonadReader PkgConfig)

instance Monad PkgM where
  PkgM ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) a
m >>= :: forall a b. PkgM a -> (a -> PkgM b) -> PkgM b
>>= a -> PkgM b
f = ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) b -> PkgM b
forall a.
ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) a -> PkgM a
PkgM (ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) b -> PkgM b)
-> ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) b -> PkgM b
forall a b. (a -> b) -> a -> b
$ ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) a
m ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) a
-> (a -> ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) b)
-> ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PkgM b -> ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) b
forall a.
PkgM a -> ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) a
unPkgM (PkgM b -> ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) b)
-> (a -> PkgM b)
-> a
-> ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> PkgM b
f
  return :: forall a. a -> PkgM a
return = ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) a -> PkgM a
forall a.
ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) a -> PkgM a
PkgM (ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) a -> PkgM a)
-> (a -> ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) a)
-> a
-> PkgM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return

instance MonadFail PkgM where
  fail :: forall a. FilePath -> PkgM a
fail FilePath
s = IO a -> PkgM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> PkgM a) -> IO a -> PkgM a
forall a b. (a -> b) -> a -> b
$ do
    FilePath
prog <- IO FilePath
getProgName
    FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
prog FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
s
    IO a
forall a. IO a
exitFailure

instance MonadPkgRegistry PkgM where
  putPkgRegistry :: PkgRegistry PkgM -> PkgM ()
putPkgRegistry = ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) () -> PkgM ()
forall a.
ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) a -> PkgM a
PkgM (ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) () -> PkgM ())
-> (PkgRegistry PkgM
    -> ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) ())
-> PkgRegistry PkgM
-> PkgM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PkgRegistry PkgM
-> ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put
  getPkgRegistry :: PkgM (PkgRegistry PkgM)
getPkgRegistry = ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) (PkgRegistry PkgM)
-> PkgM (PkgRegistry PkgM)
forall a.
ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) a -> PkgM a
PkgM ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) (PkgRegistry PkgM)
forall s (m :: * -> *). MonadState s m => m s
get

instance MonadLogger PkgM where
  addLog :: Log -> PkgM ()
addLog Log
l = do
    Bool
verbose <- (PkgConfig -> Bool) -> PkgM Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PkgConfig -> Bool
pkgVerbose
    Bool -> PkgM () -> PkgM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (PkgM () -> PkgM ()) -> PkgM () -> PkgM ()
forall a b. (a -> b) -> a -> b
$ IO () -> PkgM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PkgM ()) -> IO () -> PkgM ()
forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Log -> Text
toText Log
l

runPkgM :: PkgConfig -> PkgM a -> IO a
runPkgM :: forall a. PkgConfig -> PkgM a -> IO a
runPkgM PkgConfig
cfg (PkgM ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) a
m) = StateT (PkgRegistry PkgM) IO a -> PkgRegistry PkgM -> IO a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) a
-> PkgConfig -> StateT (PkgRegistry PkgM) IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) a
m PkgConfig
cfg) PkgRegistry PkgM
forall a. Monoid a => a
mempty

cmdMain ::
  String ->
  ([String] -> PkgConfig -> Maybe (IO ())) ->
  String ->
  [String] ->
  IO ()
cmdMain :: FilePath
-> ([FilePath] -> PkgConfig -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
cmdMain = PkgConfig
-> [FunOptDescr PkgConfig]
-> FilePath
-> ([FilePath] -> PkgConfig -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
forall cfg.
cfg
-> [FunOptDescr cfg]
-> FilePath
-> ([FilePath] -> cfg -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
mainWithOptions (Bool -> PkgConfig
PkgConfig Bool
False) [FunOptDescr PkgConfig]
forall {a}. [OptDescr (Either a (PkgConfig -> PkgConfig))]
options
  where
    options :: [OptDescr (Either a (PkgConfig -> PkgConfig))]
options =
      [ FilePath
-> [FilePath]
-> ArgDescr (Either a (PkgConfig -> PkgConfig))
-> FilePath
-> OptDescr (Either a (PkgConfig -> PkgConfig))
forall a.
FilePath -> [FilePath] -> ArgDescr a -> FilePath -> OptDescr a
Option
          FilePath
"v"
          [FilePath
"verbose"]
          (Either a (PkgConfig -> PkgConfig)
-> ArgDescr (Either a (PkgConfig -> PkgConfig))
forall a. a -> ArgDescr a
NoArg (Either a (PkgConfig -> PkgConfig)
 -> ArgDescr (Either a (PkgConfig -> PkgConfig)))
-> Either a (PkgConfig -> PkgConfig)
-> ArgDescr (Either a (PkgConfig -> PkgConfig))
forall a b. (a -> b) -> a -> b
$ (PkgConfig -> PkgConfig) -> Either a (PkgConfig -> PkgConfig)
forall a b. b -> Either a b
Right ((PkgConfig -> PkgConfig) -> Either a (PkgConfig -> PkgConfig))
-> (PkgConfig -> PkgConfig) -> Either a (PkgConfig -> PkgConfig)
forall a b. (a -> b) -> a -> b
$ \PkgConfig
cfg -> PkgConfig
cfg {pkgVerbose :: Bool
pkgVerbose = Bool
True})
          FilePath
"Write running diagnostics to stderr."
      ]

doFmt :: String -> [String] -> IO ()
doFmt :: FilePath -> [FilePath] -> IO ()
doFmt = ()
-> [FunOptDescr ()]
-> FilePath
-> ([FilePath] -> () -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
forall cfg.
cfg
-> [FunOptDescr cfg]
-> FilePath
-> ([FilePath] -> cfg -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
mainWithOptions () [] FilePath
"" (([FilePath] -> () -> Maybe (IO ()))
 -> FilePath -> [FilePath] -> IO ())
-> ([FilePath] -> () -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
forall a b. (a -> b) -> a -> b
$ \[FilePath]
args () ->
  case [FilePath]
args of
    [] -> IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ do
      PkgManifest
m <- FilePath -> IO PkgManifest
parsePkgManifestFromFile FilePath
futharkPkg
      FilePath -> Text -> IO ()
T.writeFile FilePath
futharkPkg (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ PkgManifest -> Text
prettyPkgManifest PkgManifest
m
    [FilePath]
_ -> Maybe (IO ())
forall a. Maybe a
Nothing

doCheck :: String -> [String] -> IO ()
doCheck :: FilePath -> [FilePath] -> IO ()
doCheck = FilePath
-> ([FilePath] -> PkgConfig -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
cmdMain FilePath
"check" (([FilePath] -> PkgConfig -> Maybe (IO ()))
 -> FilePath -> [FilePath] -> IO ())
-> ([FilePath] -> PkgConfig -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
forall a b. (a -> b) -> a -> b
$ \[FilePath]
args PkgConfig
cfg ->
  case [FilePath]
args of
    [] -> IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$
      PkgConfig -> PkgM () -> IO ()
forall a. PkgConfig -> PkgM a -> IO a
runPkgM PkgConfig
cfg (PkgM () -> IO ()) -> PkgM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        PkgManifest
m <- PkgM PkgManifest
getPkgManifest
        BuildList
bl <- PkgRevDeps -> PkgM BuildList
forall (m :: * -> *).
MonadPkgRegistry m =>
PkgRevDeps -> m BuildList
solveDeps (PkgRevDeps -> PkgM BuildList) -> PkgRevDeps -> PkgM BuildList
forall a b. (a -> b) -> a -> b
$ PkgManifest -> PkgRevDeps
pkgRevDeps PkgManifest
m

        IO () -> PkgM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PkgM ()) -> IO () -> PkgM ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn Text
"Dependencies chosen:"
        IO () -> PkgM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PkgM ()) -> IO () -> PkgM ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ BuildList -> Text
prettyBuildList BuildList
bl

        case Commented (Maybe Text) -> Maybe Text
forall a. Commented a -> a
commented (Commented (Maybe Text) -> Maybe Text)
-> Commented (Maybe Text) -> Maybe Text
forall a b. (a -> b) -> a -> b
$ PkgManifest -> Commented (Maybe Text)
manifestPkgPath PkgManifest
m of
          Maybe Text
Nothing -> () -> PkgM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Just Text
p -> do
            let pdir :: FilePath
pdir = FilePath
"lib" FilePath -> FilePath -> FilePath
</> Text -> FilePath
T.unpack Text
p

            Bool
pdir_exists <- IO Bool -> PkgM Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> PkgM Bool) -> IO Bool -> PkgM Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesDirectoryExist FilePath
pdir

            Bool -> PkgM () -> PkgM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
pdir_exists (PkgM () -> PkgM ()) -> PkgM () -> PkgM ()
forall a b. (a -> b) -> a -> b
$
              IO () -> PkgM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PkgM ()) -> IO () -> PkgM ()
forall a b. (a -> b) -> a -> b
$ do
                Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Problem: the directory " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
pdir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" does not exist."
                IO ()
forall a. IO a
exitFailure

            Bool
anything <-
              IO Bool -> PkgM Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> PkgM Bool) -> IO Bool -> PkgM Bool
forall a b. (a -> b) -> a -> b
$
                (FilePath -> Bool) -> [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".fut") (FilePath -> Bool) -> (FilePath -> FilePath) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
takeExtension)
                  ([FilePath] -> Bool) -> IO [FilePath] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
directoryContents (FilePath
"lib" FilePath -> FilePath -> FilePath
</> Text -> FilePath
T.unpack Text
p)
            Bool -> PkgM () -> PkgM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
anything (PkgM () -> PkgM ()) -> PkgM () -> PkgM ()
forall a b. (a -> b) -> a -> b
$
              IO () -> PkgM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PkgM ()) -> IO () -> PkgM ()
forall a b. (a -> b) -> a -> b
$ do
                Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Problem: the directory " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
pdir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" does not contain any .fut files."
                IO ()
forall a. IO a
exitFailure
    [FilePath]
_ -> Maybe (IO ())
forall a. Maybe a
Nothing

doSync :: String -> [String] -> IO ()
doSync :: FilePath -> [FilePath] -> IO ()
doSync = FilePath
-> ([FilePath] -> PkgConfig -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
cmdMain FilePath
"" (([FilePath] -> PkgConfig -> Maybe (IO ()))
 -> FilePath -> [FilePath] -> IO ())
-> ([FilePath] -> PkgConfig -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
forall a b. (a -> b) -> a -> b
$ \[FilePath]
args PkgConfig
cfg ->
  case [FilePath]
args of
    [] -> IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$
      PkgConfig -> PkgM () -> IO ()
forall a. PkgConfig -> PkgM a -> IO a
runPkgM PkgConfig
cfg (PkgM () -> IO ()) -> PkgM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        PkgManifest
m <- PkgM PkgManifest
getPkgManifest
        BuildList
bl <- PkgRevDeps -> PkgM BuildList
forall (m :: * -> *).
MonadPkgRegistry m =>
PkgRevDeps -> m BuildList
solveDeps (PkgRevDeps -> PkgM BuildList) -> PkgRevDeps -> PkgM BuildList
forall a b. (a -> b) -> a -> b
$ PkgManifest -> PkgRevDeps
pkgRevDeps PkgManifest
m
        Maybe Text -> BuildList -> PkgM ()
installBuildList (Commented (Maybe Text) -> Maybe Text
forall a. Commented a -> a
commented (Commented (Maybe Text) -> Maybe Text)
-> Commented (Maybe Text) -> Maybe Text
forall a b. (a -> b) -> a -> b
$ PkgManifest -> Commented (Maybe Text)
manifestPkgPath PkgManifest
m) BuildList
bl
    [FilePath]
_ -> Maybe (IO ())
forall a. Maybe a
Nothing

doAdd :: String -> [String] -> IO ()
doAdd :: FilePath -> [FilePath] -> IO ()
doAdd = FilePath
-> ([FilePath] -> PkgConfig -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
cmdMain FilePath
"PKGPATH" (([FilePath] -> PkgConfig -> Maybe (IO ()))
 -> FilePath -> [FilePath] -> IO ())
-> ([FilePath] -> PkgConfig -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
forall a b. (a -> b) -> a -> b
$ \[FilePath]
args PkgConfig
cfg ->
  case [FilePath]
args of
    [FilePath
p, FilePath
v] | Right SemVer
v' <- Text -> Either (ParseErrorBundle Text Void) SemVer
parseVersion (Text -> Either (ParseErrorBundle Text Void) SemVer)
-> Text -> Either (ParseErrorBundle Text Void) SemVer
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
v -> IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ PkgConfig -> PkgM () -> IO ()
forall a. PkgConfig -> PkgM a -> IO a
runPkgM PkgConfig
cfg (PkgM () -> IO ()) -> PkgM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> SemVer -> PkgM ()
doAdd' (FilePath -> Text
T.pack FilePath
p) SemVer
v'
    [FilePath
p] ->
      IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$
        PkgConfig -> PkgM () -> IO ()
forall a. PkgConfig -> PkgM a -> IO a
runPkgM PkgConfig
cfg (PkgM () -> IO ()) -> PkgM () -> IO ()
forall a b. (a -> b) -> a -> b
$
          -- Look up the newest revision of the package.
          Text -> SemVer -> PkgM ()
doAdd' (FilePath -> Text
T.pack FilePath
p) (SemVer -> PkgM ()) -> PkgM SemVer -> PkgM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> PkgM SemVer
forall (m :: * -> *). MonadPkgRegistry m => Text -> m SemVer
lookupNewestRev (FilePath -> Text
T.pack FilePath
p)
    [FilePath]
_ -> Maybe (IO ())
forall a. Maybe a
Nothing
  where
    doAdd' :: Text -> SemVer -> PkgM ()
doAdd' Text
p SemVer
v = do
      PkgManifest
m <- PkgM PkgManifest
getPkgManifest

      -- See if this package (and its dependencies) even exists.  We
      -- do this by running the solver with the dependencies already
      -- in the manifest, plus this new one.  The Monoid instance for
      -- PkgRevDeps is left-biased, so we are careful to use the new
      -- version for this package.
      BuildList
_ <- PkgRevDeps -> PkgM BuildList
forall (m :: * -> *).
MonadPkgRegistry m =>
PkgRevDeps -> m BuildList
solveDeps (PkgRevDeps -> PkgM BuildList) -> PkgRevDeps -> PkgM BuildList
forall a b. (a -> b) -> a -> b
$ Map Text (SemVer, Maybe Text) -> PkgRevDeps
PkgRevDeps (Text -> (SemVer, Maybe Text) -> Map Text (SemVer, Maybe Text)
forall k a. k -> a -> Map k a
M.singleton Text
p (SemVer
v, Maybe Text
forall a. Maybe a
Nothing)) PkgRevDeps -> PkgRevDeps -> PkgRevDeps
forall a. Semigroup a => a -> a -> a
<> PkgManifest -> PkgRevDeps
pkgRevDeps PkgManifest
m

      -- We either replace any existing occurence of package 'p', or
      -- we add a new one.
      PkgRevInfo PkgM
p_info <- Text -> SemVer -> PkgM (PkgRevInfo PkgM)
forall (m :: * -> *).
MonadPkgRegistry m =>
Text -> SemVer -> m (PkgRevInfo m)
lookupPackageRev Text
p SemVer
v
      let hash :: Maybe Text
hash = case (SemVer -> Word
_svMajor SemVer
v, SemVer -> Word
_svMinor SemVer
v, SemVer -> Word
_svPatch SemVer
v) of
            -- We do not perform hash-pinning for
            -- (0,0,0)-versions, because these already embed a
            -- specific revision ID into their version number.
            (Word
0, Word
0, Word
0) -> Maybe Text
forall a. Maybe a
Nothing
            (Word, Word, Word)
_ -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ PkgRevInfo PkgM -> Text
forall (m :: * -> *). PkgRevInfo m -> Text
pkgRevCommit PkgRevInfo PkgM
p_info
          req :: Required
req = Text -> SemVer -> Maybe Text -> Required
Required Text
p SemVer
v Maybe Text
hash
          (PkgManifest
m', Maybe Required
prev_r) = Required -> PkgManifest -> (PkgManifest, Maybe Required)
addRequiredToManifest Required
req PkgManifest
m

      case Maybe Required
prev_r of
        Just Required
prev_r'
          | Required -> SemVer
requiredPkgRev Required
prev_r' SemVer -> SemVer -> Bool
forall a. Eq a => a -> a -> Bool
== SemVer
v ->
            IO () -> PkgM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PkgM ()) -> IO () -> PkgM ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Package already at version " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SemVer -> Text
prettySemVer SemVer
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"; nothing to do."
          | Bool
otherwise ->
            IO () -> PkgM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PkgM ()) -> IO () -> PkgM ()
forall a b. (a -> b) -> a -> b
$
              Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
                Text
"Replaced " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SemVer -> Text
prettySemVer (Required -> SemVer
requiredPkgRev Required
prev_r')
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" => "
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SemVer -> Text
prettySemVer SemVer
v
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
        Maybe Required
Nothing ->
          IO () -> PkgM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PkgM ()) -> IO () -> PkgM ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Added new required package " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SemVer -> Text
prettySemVer SemVer
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
      PkgManifest -> PkgM ()
putPkgManifest PkgManifest
m'
      IO () -> PkgM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PkgM ()) -> IO () -> PkgM ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn Text
"Remember to run 'futhark pkg sync'."

doRemove :: String -> [String] -> IO ()
doRemove :: FilePath -> [FilePath] -> IO ()
doRemove = FilePath
-> ([FilePath] -> PkgConfig -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
cmdMain FilePath
"PKGPATH" (([FilePath] -> PkgConfig -> Maybe (IO ()))
 -> FilePath -> [FilePath] -> IO ())
-> ([FilePath] -> PkgConfig -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
forall a b. (a -> b) -> a -> b
$ \[FilePath]
args PkgConfig
cfg ->
  case [FilePath]
args of
    [FilePath
p] -> IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ PkgConfig -> PkgM () -> IO ()
forall a. PkgConfig -> PkgM a -> IO a
runPkgM PkgConfig
cfg (PkgM () -> IO ()) -> PkgM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> PkgM ()
doRemove' (Text -> PkgM ()) -> Text -> PkgM ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
p
    [FilePath]
_ -> Maybe (IO ())
forall a. Maybe a
Nothing
  where
    doRemove' :: Text -> PkgM ()
doRemove' Text
p = do
      PkgManifest
m <- PkgM PkgManifest
getPkgManifest
      case Text -> PkgManifest -> Maybe (PkgManifest, Required)
removeRequiredFromManifest Text
p PkgManifest
m of
        Maybe (PkgManifest, Required)
Nothing -> IO () -> PkgM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PkgM ()) -> IO () -> PkgM ()
forall a b. (a -> b) -> a -> b
$ do
          Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"No package " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" found in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
futharkPkg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
          IO ()
forall a. IO a
exitFailure
        Just (PkgManifest
m', Required
r) -> do
          PkgManifest -> PkgM ()
putPkgManifest PkgManifest
m'
          IO () -> PkgM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PkgM ()) -> IO () -> PkgM ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Removed " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SemVer -> Text
prettySemVer (Required -> SemVer
requiredPkgRev Required
r) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."

doInit :: String -> [String] -> IO ()
doInit :: FilePath -> [FilePath] -> IO ()
doInit = FilePath
-> ([FilePath] -> PkgConfig -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
cmdMain FilePath
"PKGPATH" (([FilePath] -> PkgConfig -> Maybe (IO ()))
 -> FilePath -> [FilePath] -> IO ())
-> ([FilePath] -> PkgConfig -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
forall a b. (a -> b) -> a -> b
$ \[FilePath]
args PkgConfig
cfg ->
  case [FilePath]
args of
    [FilePath
p] -> IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ PkgConfig -> PkgM () -> IO ()
forall a. PkgConfig -> PkgM a -> IO a
runPkgM PkgConfig
cfg (PkgM () -> IO ()) -> PkgM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> PkgM ()
doCreate' (Text -> PkgM ()) -> Text -> PkgM ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
p
    [FilePath]
_ -> Maybe (IO ())
forall a. Maybe a
Nothing
  where
    doCreate' :: Text -> PkgM ()
doCreate' Text
p = do
      Bool
exists <- IO Bool -> PkgM Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> PkgM Bool) -> IO Bool -> PkgM Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Bool
(||) (Bool -> Bool -> Bool) -> IO Bool -> IO (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Bool
doesFileExist FilePath
futharkPkg IO (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> IO Bool
doesDirectoryExist FilePath
futharkPkg
      Bool -> PkgM () -> PkgM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (PkgM () -> PkgM ()) -> PkgM () -> PkgM ()
forall a b. (a -> b) -> a -> b
$
        IO () -> PkgM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PkgM ()) -> IO () -> PkgM ()
forall a b. (a -> b) -> a -> b
$ do
          Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
futharkPkg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" already exists."
          IO ()
forall a. IO a
exitFailure

      IO () -> PkgM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PkgM ()) -> IO () -> PkgM ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"lib" FilePath -> FilePath -> FilePath
</> Text -> FilePath
T.unpack Text
p
      IO () -> PkgM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PkgM ()) -> IO () -> PkgM ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Created directory " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (FilePath
"lib" FilePath -> FilePath -> FilePath
</> Text -> FilePath
T.unpack Text
p) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."

      PkgManifest -> PkgM ()
putPkgManifest (PkgManifest -> PkgM ()) -> PkgManifest -> PkgM ()
forall a b. (a -> b) -> a -> b
$ Maybe Text -> PkgManifest
newPkgManifest (Maybe Text -> PkgManifest) -> Maybe Text -> PkgManifest
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
p
      IO () -> PkgM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PkgM ()) -> IO () -> PkgM ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Wrote " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
futharkPkg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."

doUpgrade :: String -> [String] -> IO ()
doUpgrade :: FilePath -> [FilePath] -> IO ()
doUpgrade = FilePath
-> ([FilePath] -> PkgConfig -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
cmdMain FilePath
"" (([FilePath] -> PkgConfig -> Maybe (IO ()))
 -> FilePath -> [FilePath] -> IO ())
-> ([FilePath] -> PkgConfig -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
forall a b. (a -> b) -> a -> b
$ \[FilePath]
args PkgConfig
cfg ->
  case [FilePath]
args of
    [] -> IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$
      PkgConfig -> PkgM () -> IO ()
forall a. PkgConfig -> PkgM a -> IO a
runPkgM PkgConfig
cfg (PkgM () -> IO ()) -> PkgM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        PkgManifest
m <- PkgM PkgManifest
getPkgManifest
        Commented [Either Text Required]
rs <- ([Either Text Required] -> PkgM [Either Text Required])
-> Commented [Either Text Required]
-> PkgM (Commented [Either Text Required])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Either Text Required -> PkgM (Either Text Required))
-> [Either Text Required] -> PkgM [Either Text Required]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Required -> PkgM Required)
-> Either Text Required -> PkgM (Either Text Required)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Required -> PkgM Required
forall {m :: * -> *}. MonadPkgRegistry m => Required -> m Required
upgrade)) (Commented [Either Text Required]
 -> PkgM (Commented [Either Text Required]))
-> Commented [Either Text Required]
-> PkgM (Commented [Either Text Required])
forall a b. (a -> b) -> a -> b
$ PkgManifest -> Commented [Either Text Required]
manifestRequire PkgManifest
m
        PkgManifest -> PkgM ()
putPkgManifest PkgManifest
m {manifestRequire :: Commented [Either Text Required]
manifestRequire = Commented [Either Text Required]
rs}
        if Commented [Either Text Required]
rs Commented [Either Text Required]
-> Commented [Either Text Required] -> Bool
forall a. Eq a => a -> a -> Bool
== PkgManifest -> Commented [Either Text Required]
manifestRequire PkgManifest
m
          then IO () -> PkgM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PkgM ()) -> IO () -> PkgM ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn Text
"Nothing to upgrade."
          else IO () -> PkgM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PkgM ()) -> IO () -> PkgM ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn Text
"Remember to run 'futhark pkg sync'."
    [FilePath]
_ -> Maybe (IO ())
forall a. Maybe a
Nothing
  where
    upgrade :: Required -> m Required
upgrade Required
req = do
      SemVer
v <- Text -> m SemVer
forall (m :: * -> *). MonadPkgRegistry m => Text -> m SemVer
lookupNewestRev (Text -> m SemVer) -> Text -> m SemVer
forall a b. (a -> b) -> a -> b
$ Required -> Text
requiredPkg Required
req
      Text
h <- PkgRevInfo m -> Text
forall (m :: * -> *). PkgRevInfo m -> Text
pkgRevCommit (PkgRevInfo m -> Text) -> m (PkgRevInfo m) -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> SemVer -> m (PkgRevInfo m)
forall (m :: * -> *).
MonadPkgRegistry m =>
Text -> SemVer -> m (PkgRevInfo m)
lookupPackageRev (Required -> Text
requiredPkg Required
req) SemVer
v

      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SemVer
v SemVer -> SemVer -> Bool
forall a. Eq a => a -> a -> Bool
/= Required -> SemVer
requiredPkgRev Required
req) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
          Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
            Text
"Upgraded " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Required -> Text
requiredPkg Required
req Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SemVer -> Text
prettySemVer (Required -> SemVer
requiredPkgRev Required
req)
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" => "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SemVer -> Text
prettySemVer SemVer
v
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."

      Required -> m Required
forall (m :: * -> *) a. Monad m => a -> m a
return
        Required
req
          { requiredPkgRev :: SemVer
requiredPkgRev = SemVer
v,
            requiredHash :: Maybe Text
requiredHash = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
h
          }

doVersions :: String -> [String] -> IO ()
doVersions :: FilePath -> [FilePath] -> IO ()
doVersions = FilePath
-> ([FilePath] -> PkgConfig -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
cmdMain FilePath
"PKGPATH" (([FilePath] -> PkgConfig -> Maybe (IO ()))
 -> FilePath -> [FilePath] -> IO ())
-> ([FilePath] -> PkgConfig -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
forall a b. (a -> b) -> a -> b
$ \[FilePath]
args PkgConfig
cfg ->
  case [FilePath]
args of
    [FilePath
p] -> IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ PkgConfig -> PkgM () -> IO ()
forall a. PkgConfig -> PkgM a -> IO a
runPkgM PkgConfig
cfg (PkgM () -> IO ()) -> PkgM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> PkgM ()
doVersions' (Text -> PkgM ()) -> Text -> PkgM ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
p
    [FilePath]
_ -> Maybe (IO ())
forall a. Maybe a
Nothing
  where
    doVersions' :: Text -> PkgM ()
doVersions' =
      (SemVer -> PkgM ()) -> [SemVer] -> PkgM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO () -> PkgM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PkgM ()) -> (SemVer -> IO ()) -> SemVer -> PkgM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
T.putStrLn (Text -> IO ()) -> (SemVer -> Text) -> SemVer -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SemVer -> Text
prettySemVer) ([SemVer] -> PkgM ())
-> (PkgInfo PkgM -> [SemVer]) -> PkgInfo PkgM -> PkgM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map SemVer (PkgRevInfo PkgM) -> [SemVer]
forall k a. Map k a -> [k]
M.keys (Map SemVer (PkgRevInfo PkgM) -> [SemVer])
-> (PkgInfo PkgM -> Map SemVer (PkgRevInfo PkgM))
-> PkgInfo PkgM
-> [SemVer]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PkgInfo PkgM -> Map SemVer (PkgRevInfo PkgM)
forall (m :: * -> *). PkgInfo m -> Map SemVer (PkgRevInfo m)
pkgVersions
        (PkgInfo PkgM -> PkgM ())
-> (Text -> PkgM (PkgInfo PkgM)) -> Text -> PkgM ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Text -> PkgM (PkgInfo PkgM)
forall (m :: * -> *). MonadPkgRegistry m => Text -> m (PkgInfo m)
lookupPackage

-- | Run @futhark pkg@.
main :: String -> [String] -> IO ()
main :: FilePath -> [FilePath] -> IO ()
main FilePath
prog [FilePath]
args = do
  -- Avoid Git asking for credentials.  We prefer failure.
  IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
setEnv FilePath
"GIT_TERMINAL_PROMPT" FilePath
"0"

  let commands :: [(FilePath, (FilePath -> [FilePath] -> IO (), Text))]
commands =
        [ ( FilePath
"add",
            (FilePath -> [FilePath] -> IO ()
doAdd, Text
"Add another required package to futhark.pkg.")
          ),
          ( FilePath
"check",
            (FilePath -> [FilePath] -> IO ()
doCheck, Text
"Check that futhark.pkg is satisfiable.")
          ),
          ( FilePath
"init",
            (FilePath -> [FilePath] -> IO ()
doInit, Text
"Create a new futhark.pkg and a lib/ skeleton.")
          ),
          ( FilePath
"fmt",
            (FilePath -> [FilePath] -> IO ()
doFmt, Text
"Reformat futhark.pkg.")
          ),
          ( FilePath
"sync",
            (FilePath -> [FilePath] -> IO ()
doSync, Text
"Populate lib/ as specified by futhark.pkg.")
          ),
          ( FilePath
"remove",
            (FilePath -> [FilePath] -> IO ()
doRemove, Text
"Remove a required package from futhark.pkg.")
          ),
          ( FilePath
"upgrade",
            (FilePath -> [FilePath] -> IO ()
doUpgrade, Text
"Upgrade all packages to newest versions.")
          ),
          ( FilePath
"versions",
            (FilePath -> [FilePath] -> IO ()
doVersions, Text
"List available versions for a package.")
          )
        ]
      usage :: FilePath
usage = FilePath
"options... <" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"|" (((FilePath, (FilePath -> [FilePath] -> IO (), Text)) -> FilePath)
-> [(FilePath, (FilePath -> [FilePath] -> IO (), Text))]
-> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, (FilePath -> [FilePath] -> IO (), Text)) -> FilePath
forall a b. (a, b) -> a
fst [(FilePath, (FilePath -> [FilePath] -> IO (), Text))]
commands) FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
">"
  case [FilePath]
args of
    FilePath
cmd : [FilePath]
args'
      | Just (FilePath -> [FilePath] -> IO ()
m, Text
_) <- FilePath
-> [(FilePath, (FilePath -> [FilePath] -> IO (), Text))]
-> Maybe (FilePath -> [FilePath] -> IO (), Text)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
cmd [(FilePath, (FilePath -> [FilePath] -> IO (), Text))]
commands ->
        FilePath -> [FilePath] -> IO ()
m ([FilePath] -> FilePath
unwords [FilePath
prog, FilePath
cmd]) [FilePath]
args'
    [FilePath]
_ -> do
      let bad :: p -> () -> Maybe (IO b)
bad p
_ () = IO b -> Maybe (IO b)
forall a. a -> Maybe a
Just (IO b -> Maybe (IO b)) -> IO b -> Maybe (IO b)
forall a b. (a -> b) -> a -> b
$ do
            let k :: Int
k = [Int] -> Int
forall a (f :: * -> *). (Num a, Ord a, Foldable f) => f a -> a
maxinum (((FilePath, (FilePath -> [FilePath] -> IO (), Text)) -> Int)
-> [(FilePath, (FilePath -> [FilePath] -> IO (), Text))] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (FilePath -> Int)
-> ((FilePath, (FilePath -> [FilePath] -> IO (), Text))
    -> FilePath)
-> (FilePath, (FilePath -> [FilePath] -> IO (), Text))
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath, (FilePath -> [FilePath] -> IO (), Text)) -> FilePath
forall a b. (a, b) -> a
fst) [(FilePath, (FilePath -> [FilePath] -> IO (), Text))]
commands) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3
            Text -> IO b
forall {b}. Text -> IO b
usageMsg (Text -> IO b) -> Text -> IO b
forall a b. (a -> b) -> a -> b
$
              [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
                [Text
"<command> ...:", Text
"", Text
"Commands:"]
                  [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [ Text
"   " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
cmd Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Int -> Char -> FilePath
forall a. Int -> a -> [a]
replicate (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
cmd) Char
' ') Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
desc
                       | (FilePath
cmd, (FilePath -> [FilePath] -> IO ()
_, Text
desc)) <- [(FilePath, (FilePath -> [FilePath] -> IO (), Text))]
commands
                     ]

      ()
-> [FunOptDescr ()]
-> FilePath
-> ([FilePath] -> () -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
forall cfg.
cfg
-> [FunOptDescr cfg]
-> FilePath
-> ([FilePath] -> cfg -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
mainWithOptions () [] FilePath
usage [FilePath] -> () -> Maybe (IO ())
forall {p} {b}. p -> () -> Maybe (IO b)
bad FilePath
prog [FilePath]
args
  where
    usageMsg :: Text -> IO b
usageMsg Text
s = do
      Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Usage: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
prog Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" [--version] [--help] " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s
      IO b
forall a. IO a
exitFailure