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

import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.State
import Data.List (intercalate)
import Data.Map qualified as M
import Data.Maybe
import Data.Monoid
import Data.Text qualified as T
import Data.Text.IO qualified 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 System.IO
import System.IO.Temp (withSystemTempDirectory)
import Prelude

--- Installing packages

installInDir :: CacheDir -> BuildList -> FilePath -> PkgM ()
installInDir :: CacheDir -> BuildList -> String -> PkgM ()
installInDir CacheDir
cachedir (BuildList Map Text SemVer
bl) String
dir =
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [(k, a)]
M.toList Map Text SemVer
bl) forall a b. (a -> b) -> a -> b
$ \(Text
p, SemVer
v) -> do
    PkgRevInfo PkgM
info <- forall (m :: * -> *).
MonadPkgRegistry m =>
CacheDir -> Text -> SemVer -> m (PkgRevInfo m)
lookupPackageRev CacheDir
cachedir Text
p SemVer
v
    (String
filedir, [String]
files) <- forall (m :: * -> *). GetFiles m -> m (String, [String])
getFiles forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). PkgRevInfo m -> GetFiles m
pkgGetFiles PkgRevInfo PkgM
info

    -- The directory in the local file system that will contain the
    -- package files.
    let pdir :: String
pdir = String
dir String -> String -> String
</> Text -> String
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.
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
removePathForcibly String
pdir

    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
files forall a b. (a -> b) -> a -> b
$ \String
file -> do
      let from :: String
from = String
filedir String -> String -> String
</> String
file
          to :: String
to = String
pdir String -> String -> String
</> String
file
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ String -> String
takeDirectory String
to
      forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg forall a b. (a -> b) -> a -> b
$ String
"Copying " forall a. Semigroup a => a -> a -> a
<> String
from forall a. Semigroup a => a -> a -> a
<> String
"\n" forall a. Semigroup a => a -> a -> a
<> String
"to      " forall a. Semigroup a => a -> a -> a
<> String
to
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
copyFile String
from String
to

libDir, libNewDir, libOldDir :: FilePath
(String
libDir, String
libNewDir, String
libOldDir) = (String
"lib", String
"lib~new", String
"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 :: CacheDir -> Maybe PkgPath -> BuildList -> PkgM ()
installBuildList :: CacheDir -> Maybe Text -> BuildList -> PkgM ()
installBuildList CacheDir
cachedir Maybe Text
p BuildList
bl = do
  Bool
libdir_exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesDirectoryExist String
libDir

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

  -- 2
  CacheDir -> BuildList -> String -> PkgM ()
installInDir CacheDir
cachedir BuildList
bl String
libNewDir

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

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

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

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

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

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

putPkgManifest :: PkgManifest -> PkgM ()
putPkgManifest :: PkgManifest -> PkgM ()
putPkgManifest = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text -> IO ()
T.writeFile String
futharkPkg 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 -> 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
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
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 = forall a.
ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) a -> PkgM a
PkgM forall a b. (a -> b) -> a -> b
$ ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a.
PkgM a -> ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) a
unPkgM forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> PkgM b
f

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

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

instance MonadLogger PkgM where
  addLog :: Log -> PkgM ()
addLog Log
l = do
    Bool
verbose <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PkgConfig -> Bool
pkgVerbose
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr 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) = forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) a
m PkgConfig
cfg) forall a. Monoid a => a
mempty

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

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

withCacheDir :: (CacheDir -> IO a) -> IO a
withCacheDir :: forall a. (CacheDir -> IO a) -> IO a
withCacheDir CacheDir -> IO a
f = forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> m a) -> m a
withSystemTempDirectory String
"futhark-pkg" forall a b. (a -> b) -> a -> b
$ CacheDir -> IO a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CacheDir
CacheDir

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

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

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

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

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

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

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

doAdd :: String -> [String] -> IO ()
doAdd :: String -> [String] -> IO ()
doAdd = String
-> ([String] -> PkgConfig -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
cmdMain String
"PKGPATH" forall a b. (a -> b) -> a -> b
$ \[String]
args PkgConfig
cfg ->
  case [String]
args of
    [String
p, String
v]
      | Right SemVer
v' <- Text -> Either (ParseErrorBundle Text Void) SemVer
parseVersion forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
v ->
          forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. (CacheDir -> IO a) -> IO a
withCacheDir forall a b. (a -> b) -> a -> b
$ \CacheDir
cachedir ->
            forall a. PkgConfig -> PkgM a -> IO a
runPkgM PkgConfig
cfg forall a b. (a -> b) -> a -> b
$ CacheDir -> Text -> SemVer -> PkgM ()
doAdd' CacheDir
cachedir (String -> Text
T.pack String
p) SemVer
v'
    [String
p] ->
      forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. (CacheDir -> IO a) -> IO a
withCacheDir forall a b. (a -> b) -> a -> b
$ \CacheDir
cachedir ->
        forall a. PkgConfig -> PkgM a -> IO a
runPkgM PkgConfig
cfg forall a b. (a -> b) -> a -> b
$
          -- Look up the newest revision of the package.
          CacheDir -> Text -> SemVer -> PkgM ()
doAdd' CacheDir
cachedir (String -> Text
T.pack String
p) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadPkgRegistry m =>
CacheDir -> Text -> m SemVer
lookupNewestRev CacheDir
cachedir (String -> Text
T.pack String
p)
    [String]
_ -> forall a. Maybe a
Nothing
  where
    doAdd' :: CacheDir -> Text -> SemVer -> PkgM ()
doAdd' CacheDir
cachedir 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
_ <- forall (m :: * -> *).
MonadPkgRegistry m =>
CacheDir -> PkgRevDeps -> m BuildList
solveDeps CacheDir
cachedir forall a b. (a -> b) -> a -> b
$ Map Text (SemVer, Maybe Text) -> PkgRevDeps
PkgRevDeps (forall k a. k -> a -> Map k a
M.singleton Text
p (SemVer
v, forall a. Maybe a
Nothing)) 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 <- forall (m :: * -> *).
MonadPkgRegistry m =>
CacheDir -> Text -> SemVer -> m (PkgRevInfo m)
lookupPackageRev CacheDir
cachedir 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) -> forall a. Maybe a
Nothing
            (Word, Word, Word)
_ -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ 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' forall a. Eq a => a -> a -> Bool
== SemVer
v ->
              forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ Text
"Package already at version " forall a. Semigroup a => a -> a -> a
<> SemVer -> Text
prettySemVer SemVer
v forall a. Semigroup a => a -> a -> a
<> Text
"; nothing to do."
          | Bool
otherwise ->
              forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
                Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$
                  Text
"Replaced "
                    forall a. Semigroup a => a -> a -> a
<> Text
p
                    forall a. Semigroup a => a -> a -> a
<> Text
" "
                    forall a. Semigroup a => a -> a -> a
<> SemVer -> Text
prettySemVer (Required -> SemVer
requiredPkgRev Required
prev_r')
                    forall a. Semigroup a => a -> a -> a
<> Text
" => "
                    forall a. Semigroup a => a -> a -> a
<> SemVer -> Text
prettySemVer SemVer
v
                    forall a. Semigroup a => a -> a -> a
<> Text
"."
        Maybe Required
Nothing ->
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ Text
"Added new required package " forall a. Semigroup a => a -> a -> a
<> Text
p forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> SemVer -> Text
prettySemVer SemVer
v forall a. Semigroup a => a -> a -> a
<> Text
"."
      PkgManifest -> PkgM ()
putPkgManifest PkgManifest
m'
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn Text
"Remember to run 'futhark pkg sync'."

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

doInit :: String -> [String] -> IO ()
doInit :: String -> [String] -> IO ()
doInit = String
-> ([String] -> PkgConfig -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
cmdMain String
"PKGPATH" forall a b. (a -> b) -> a -> b
$ \[String]
args PkgConfig
cfg ->
  case [String]
args of
    [String
p] -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. PkgConfig -> PkgM a -> IO a
runPkgM PkgConfig
cfg forall a b. (a -> b) -> a -> b
$ Text -> PkgM ()
doCreate' forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
p
    [String]
_ -> forall a. Maybe a
Nothing
  where
    validPkgPath :: Text -> Bool
validPkgPath Text
p =
      Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
".", String
".."]) forall a b. (a -> b) -> a -> b
$ String -> [String]
splitDirectories forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
p

    doCreate' :: Text -> PkgM ()
doCreate' Text
p = do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
validPkgPath Text
p) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ Text
"Not a valid package path: " forall a. Semigroup a => a -> a -> a
<> Text
p
        Text -> IO ()
T.putStrLn Text
"Note: package paths are usually URIs."
        Text -> IO ()
T.putStrLn Text
"Note: 'futhark init' is only needed when creating a package, not to use packages."
        forall a. IO a
exitFailure

      Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Bool
(||) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Bool
doesFileExist String
futharkPkg forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO Bool
doesDirectoryExist String
futharkPkg
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
          Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
futharkPkg forall a. Semigroup a => a -> a -> a
<> Text
" already exists."
          forall a. IO a
exitFailure

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

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

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

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

      forall (f :: * -> *) a. Applicative f => a -> f a
pure
        Required
req
          { requiredPkgRev :: SemVer
requiredPkgRev = SemVer
v,
            requiredHash :: Maybe Text
requiredHash = forall a. a -> Maybe a
Just Text
h
          }

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

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

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

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