module Futhark.CLI.Pkg (main) where
import Codec.Archive.Zip qualified as Zip
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.State
import Data.ByteString.Lazy qualified as LBS
import Data.List (intercalate, isPrefixOf)
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.FilePath.Posix qualified as Posix
import System.IO
import Prelude
installInDir :: BuildList -> FilePath -> PkgM ()
installInDir :: BuildList -> String -> PkgM ()
installInDir (BuildList Map Text SemVer
bl) String
dir = do
let putEntry :: String -> String -> Entry -> IO (Maybe String)
putEntry String
from_dir String
pdir Entry
entry
| Bool -> Bool
not (String -> String -> Bool
isInPkgDir String
from_dir forall a b. (a -> b) -> a -> b
$ Entry -> String
Zip.eRelativePath Entry
entry)
Bool -> Bool -> Bool
|| String -> Bool
hasTrailingPathSeparator (Entry -> String
Zip.eRelativePath Entry
entry) =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
| Bool
otherwise = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
".." forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String -> [String]
Posix.splitPath (Entry -> String
Zip.eRelativePath Entry
entry)) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
String
"Zip archive for "
forall a. Semigroup a => a -> a -> a
<> String
pdir
forall a. Semigroup a => a -> a -> a
<> String
" contains suspicious path: "
forall a. Semigroup a => a -> a -> a
<> Entry -> String
Zip.eRelativePath Entry
entry
let f :: String
f = String
pdir String -> String -> String
</> String -> String -> String
makeRelative String
from_dir (Entry -> String
Zip.eRelativePath Entry
entry)
Bool -> String -> IO ()
createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ String -> String
takeDirectory String
f
String -> ByteString -> IO ()
LBS.writeFile String
f forall a b. (a -> b) -> a -> b
$ Entry -> ByteString
Zip.fromEntry Entry
entry
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just String
f
isInPkgDir :: String -> String -> Bool
isInPkgDir String
from_dir String
f =
String -> [String]
Posix.splitPath String
from_dir forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String -> [String]
Posix.splitPath String
f
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 =>
Text -> SemVer -> m (PkgRevInfo m)
lookupPackageRev Text
p SemVer
v
Archive
a <- forall (m :: * -> *).
(MonadLogger m, MonadIO m, MonadFail m) =>
PkgRevInfo m -> m Archive
downloadZipball PkgRevInfo PkgM
info
PkgManifest
m <- forall (m :: * -> *). GetManifest m -> m PkgManifest
getManifest forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). PkgRevInfo m -> GetManifest m
pkgRevGetManifest PkgRevInfo PkgM
info
let noPkgDir :: PkgM a
noPkgDir =
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
String
"futhark.pkg for "
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
p
forall a. [a] -> [a] -> [a]
++ String
"-"
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (SemVer -> Text
prettySemVer SemVer
v)
forall a. [a] -> [a] -> [a]
++ String
" does not define a package path."
String
from_dir <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {a}. PkgM a
noPkgDir (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (m :: * -> *). PkgRevInfo m -> String
pkgRevZipballDir PkgRevInfo PkgM
info <>)) forall a b. (a -> b) -> a -> b
$ PkgManifest -> Maybe String
pkgDir PkgManifest
m
let pdir :: String
pdir = String
dir 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
$ String -> IO ()
removePathForcibly String
pdir
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
pdir
[String]
written <-
forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> String -> Entry -> IO (Maybe String)
putEntry String
from_dir String
pdir) forall a b. (a -> b) -> a -> b
$ Archive -> [Entry]
Zip.zEntries Archive
a)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
written) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
String
"Zip archive for package "
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
p
forall a. [a] -> [a] -> [a]
++ String
" does not contain any files in "
forall a. [a] -> [a] -> [a]
++ String
from_dir
libDir, libNewDir, libOldDir :: FilePath
(String
libDir, String
libNewDir, String
libOldDir) = (String
"lib", String
"lib~new", String
"lib~old")
installBuildList :: Maybe PkgPath -> BuildList -> PkgM ()
installBuildList :: Maybe Text -> BuildList -> PkgM ()
installBuildList 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
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
BuildList -> String -> PkgM ()
installInDir BuildList
bl String
libNewDir
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
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
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
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 ()
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
newtype PkgConfig = PkgConfig {PkgConfig -> Bool
pkgVerbose :: Bool}
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
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 a b. (a -> b) -> a -> b
$
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 =>
PkgRevDeps -> m BuildList
solveDeps 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 a b. (a -> b) -> a -> b
$
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 =>
PkgRevDeps -> m BuildList
solveDeps forall a b. (a -> b) -> a -> b
$ PkgManifest -> PkgRevDeps
pkgRevDeps PkgManifest
m
Maybe Text -> BuildList -> PkgM ()
installBuildList (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. PkgConfig -> PkgM a -> IO a
runPkgM PkgConfig
cfg forall a b. (a -> b) -> a -> b
$ Text -> SemVer -> PkgM ()
doAdd' (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. PkgConfig -> PkgM a -> IO a
runPkgM PkgConfig
cfg forall a b. (a -> b) -> a -> b
$
Text -> SemVer -> PkgM ()
doAdd' (String -> Text
T.pack String
p) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). MonadPkgRegistry m => Text -> m SemVer
lookupNewestRev (String -> Text
T.pack String
p)
[String]
_ -> forall a. Maybe a
Nothing
where
doAdd' :: Text -> SemVer -> PkgM ()
doAdd' Text
p SemVer
v = do
PkgManifest
m <- PkgM PkgManifest
getPkgManifest
BuildList
_ <- forall (m :: * -> *).
MonadPkgRegistry m =>
PkgRevDeps -> m BuildList
solveDeps 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
PkgRevInfo PkgM
p_info <- 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
(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 a b. (a -> b) -> a -> b
$
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 => Required -> m Required
upgrade)) 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 :: Required -> m Required
upgrade Required
req = do
SemVer
v <- forall (m :: * -> *). MonadPkgRegistry m => Text -> m SemVer
lookupNewestRev 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 =>
Text -> SemVer -> m (PkgRevInfo m)
lookupPackageRev (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. PkgConfig -> PkgM a -> IO a
runPkgM PkgConfig
cfg forall a b. (a -> b) -> a -> b
$ Text -> PkgM ()
doVersions' forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
p
[String]
_ -> forall a. Maybe a
Nothing
where
doVersions' :: Text -> PkgM ()
doVersions' =
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 => Text -> m (PkgInfo m)
lookupPackage
main :: String -> [String] -> IO ()
main :: String -> [String] -> IO ()
main String
prog [String]
args = do
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 a b. (a -> b) -> a -> b
$
[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