{-# LANGUAGE OverloadedStrings #-}
module Language.ATS.Package.Dependency (
fetchDeps
, buildHelper
, SetupScript
) where
import qualified Archive.Compression as Archive
import Codec.Archive.Zip (ZipOption (..), extractFilesFromArchive, toArchive)
import qualified Codec.Compression.GZip as Gzip
import qualified Codec.Compression.Lzma as Lzma
import Control.Concurrent.ParallelIO.Global
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Text.Lazy as TL
import Development.Shake.ATS
import Language.ATS.Package.Build.C
import Language.ATS.Package.Compiler (SetupScript)
import Language.ATS.Package.Config
import Language.ATS.Package.Error
import Language.ATS.Package.PackageSet
import Language.ATS.Package.Type
import Quaalude
getTgt :: CCompiler -> Maybe String
getTgt :: CCompiler -> Maybe String
getTgt (GCC Maybe String
x Maybe String
_) = Maybe String
x
getTgt (GHC Maybe String
x Maybe String
_) = Maybe String
x
getTgt CCompiler
_ = Maybe String
forall a. Maybe a
Nothing
fetchDeps :: Verbosity
-> CCompiler
-> Maybe String
-> [IO ()]
-> [(String, ATSConstraint)]
-> [(String, ATSConstraint)]
-> [(String, ATSConstraint)]
-> FilePath
-> SetupScript
-> Bool
-> IO ()
fetchDeps :: Verbosity
-> CCompiler
-> Maybe String
-> [IO ()]
-> [(String, ATSConstraint)]
-> [(String, ATSConstraint)]
-> [(String, ATSConstraint)]
-> String
-> SetupScript
-> Bool
-> IO ()
fetchDeps Verbosity
v CCompiler
cc' Maybe String
mStr [IO ()]
setup' [(String, ATSConstraint)]
deps [(String, ATSConstraint)]
cdeps [(String, ATSConstraint)]
atsBld String
cfgPath SetupScript
als Bool
b' =
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(String, ATSConstraint)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, ATSConstraint)]
deps Bool -> Bool -> Bool
&& [(String, ATSConstraint)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, ATSConstraint)]
cdeps Bool -> Bool -> Bool
&& [(String, ATSConstraint)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, ATSConstraint)]
atsBld Bool -> Bool -> Bool
&& Bool
b' Bool -> Bool -> Bool
&& Bool
False) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
putStrLn String
"Resolving dependencies..."
String
pkgSet <- Text -> String
unpack (Text -> String) -> (ByteString -> Text) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserConfig -> Text
defaultPkgs (UserConfig -> Text)
-> (ByteString -> UserConfig) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> UserConfig
forall a. Binary a => ByteString -> a
decode (ByteString -> String) -> IO ByteString -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BSL.readFile String
cfgPath
[[ATSDependency]]
deps' <- String
-> DepSelector
-> Maybe String
-> String
-> [(String, ATSConstraint)]
-> IO [[ATSDependency]]
setBuildPlan String
"ats" DepSelector
libDeps Maybe String
mStr String
pkgSet [(String, ATSConstraint)]
deps
[[ATSDependency]]
atsDeps' <- String
-> DepSelector
-> Maybe String
-> String
-> [(String, ATSConstraint)]
-> IO [[ATSDependency]]
setBuildPlan String
"atsbld" DepSelector
libBldDeps Maybe String
mStr String
pkgSet [(String, ATSConstraint)]
atsBld
[[ATSDependency]]
cdeps' <- String
-> DepSelector
-> Maybe String
-> String
-> [(String, ATSConstraint)]
-> IO [[ATSDependency]]
setBuildPlan String
"c" DepSelector
libDeps Maybe String
mStr String
pkgSet [(String, ATSConstraint)]
cdeps
String
d <- (String -> String -> String
</> String
"lib/") (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CCompiler -> IO String
cpkgHome CCompiler
cc'
let tgt' :: Maybe String
tgt' = CCompiler -> Maybe String
getTgt CCompiler
cc'
libs' :: [IO ()]
libs' = (ATSDependency -> IO ()) -> [ATSDependency] -> [IO ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> ATSDependency -> IO ()
buildHelper Bool
False) ([[ATSDependency]] -> [ATSDependency]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join [[ATSDependency]]
deps')
unpacked :: [[ATSDependency]]
unpacked = (ATSDependency -> ATSDependency)
-> [ATSDependency] -> [ATSDependency]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ASetter ATSDependency ATSDependency Text Text
-> (Text -> Text) -> ATSDependency -> ATSDependency
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter ATSDependency ATSDependency Text Text
Lens' ATSDependency Text
dirLens (String -> Text
pack String
d Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)) ([ATSDependency] -> [ATSDependency])
-> [[ATSDependency]] -> [[ATSDependency]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[ATSDependency]]
cdeps'
clibs :: [IO ()]
clibs = (ATSDependency -> IO ()) -> [ATSDependency] -> [IO ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> ATSDependency -> IO ()
buildHelper Bool
False) ([[ATSDependency]] -> [ATSDependency]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join [[ATSDependency]]
unpacked)
atsLibs :: [IO ()]
atsLibs = (ATSDependency -> IO ()) -> [ATSDependency] -> [IO ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> ATSDependency -> IO ()
buildHelper Bool
False) ([[ATSDependency]] -> [ATSDependency]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join [[ATSDependency]]
atsDeps')
cBuild :: [IO ()]
cBuild = (ATSDependency -> IO ()) -> [ATSDependency] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Verbosity -> CCompiler -> ATSDependency -> IO ()
setup Verbosity
v CCompiler
cc') ([ATSDependency] -> IO ()) -> [[ATSDependency]] -> [IO ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([[ATSDependency]] -> [[ATSDependency]]
forall a. [[a]] -> [[a]]
transpose ([[ATSDependency]] -> [[ATSDependency]])
-> ([[ATSDependency]] -> [[ATSDependency]])
-> [[ATSDependency]]
-> [[ATSDependency]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([ATSDependency] -> [ATSDependency])
-> [[ATSDependency]] -> [[ATSDependency]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ATSDependency] -> [ATSDependency]
forall a. [a] -> [a]
reverse) [[ATSDependency]]
unpacked
atsBuild :: [IO ()]
atsBuild = (ATSDependency -> IO ()) -> [ATSDependency] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (SetupScript -> Maybe String -> ATSDependency -> IO ()
atsPkgSetup SetupScript
als Maybe String
tgt') ([ATSDependency] -> IO ()) -> [[ATSDependency]] -> [IO ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([[ATSDependency]] -> [[ATSDependency]]
forall a. [[a]] -> [[a]]
transpose ([[ATSDependency]] -> [[ATSDependency]])
-> ([[ATSDependency]] -> [[ATSDependency]])
-> [[ATSDependency]]
-> [[ATSDependency]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([ATSDependency] -> [ATSDependency])
-> [[ATSDependency]] -> [[ATSDependency]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ATSDependency] -> [ATSDependency]
forall a. [a] -> [a]
reverse) [[ATSDependency]]
atsDeps'
[IO ()] -> IO ()
parallel' ([IO ()] -> IO ()) -> [IO ()] -> IO ()
forall a b. (a -> b) -> a -> b
$ [[IO ()]] -> [IO ()]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join [ [IO ()]
setup', [IO ()]
libs', [IO ()]
clibs, [IO ()]
atsLibs ]
let tagBuild :: String -> t (IO a) -> IO ()
tagBuild String
str t (IO a)
bld =
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (t (IO a) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t (IO a)
bld) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> IO ()
putStrLn ([String] -> String
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [String
"Building ", String
str, String
" dependencies..."]) IO () -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
t (IO a) -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ t (IO a)
bld
(String -> [IO ()] -> IO ()) -> [String] -> [[IO ()]] -> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ String -> [IO ()] -> IO ()
forall (t :: * -> *) a. Foldable t => String -> t (IO a) -> IO ()
tagBuild [ String
"C", String
"ATS" ] [ [IO ()]
cBuild, [IO ()]
atsBuild ]
parallel' :: [IO ()] -> IO ()
parallel' :: [IO ()] -> IO ()
parallel' = [IO ()] -> IO ()
forall a. [IO a] -> IO ()
parallel_ ([IO ()] -> IO ()) -> ([IO ()] -> [IO ()]) -> [IO ()] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IO () -> IO ()) -> [IO ()] -> [IO ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IO () -> IO ()
forall a. IO a -> IO a
extraWorkerWhileBlocked
atsPkgSetup :: SetupScript
-> Maybe String
-> ATSDependency
-> IO ()
atsPkgSetup :: SetupScript -> Maybe String -> ATSDependency -> IO ()
atsPkgSetup SetupScript
als Maybe String
tgt' (ATSDependency Text
lib' Text
dirName' Text
_ Maybe Text
_ Version
_ [LibDep]
_ [LibDep]
_ [LibDep]
_ [Text]
_) = do
String
lib'' <- (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
lib') (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CCompiler -> IO String
cpkgHome (Maybe String -> Maybe String -> CCompiler
GCC Maybe String
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing)
Bool
b <- String -> IO Bool
doesFileExist String
lib''
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
SetupScript
als Maybe String
tgt' (Text -> String
unpack Text
lib') (Text -> String
unpack Text
dirName')
String -> String -> IO ()
writeFile String
lib'' String
""
setup :: Verbosity
-> CCompiler
-> ATSDependency
-> IO ()
setup :: Verbosity -> CCompiler -> ATSDependency -> IO ()
setup Verbosity
v' CCompiler
cc' (ATSDependency Text
lib' Text
dirName' Text
_ Maybe Text
_ Version
v [LibDep]
_ [LibDep]
_ [LibDep]
_ [Text]
_) = do
String
lib'' <- (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Version -> String
forall a. Show a => a -> String
show Version
v) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
</> Text -> String
unpack Text
lib') (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CCompiler -> IO String
cpkgHome CCompiler
cc'
Bool
b <- String -> IO Bool
doesFileExist String
lib''
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Verbosity -> CCompiler -> String -> String -> IO ()
clibSetup Verbosity
v' CCompiler
cc' (Text -> String
unpack Text
lib') (Text -> String
unpack Text
dirName')
String -> String -> IO ()
writeFile String
lib'' String
""
getCompressor :: Text -> IO (ByteString -> ByteString)
getCompressor :: Text -> IO (ByteString -> ByteString)
getCompressor Text
s
| Text
".tar.gz" Text -> Text -> Bool
`TL.isSuffixOf` Text
s Bool -> Bool -> Bool
|| Text
".tgz" Text -> Text -> Bool
`TL.isSuffixOf` Text
s = (ByteString -> ByteString) -> IO (ByteString -> ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString -> ByteString
Gzip.decompress
| Text
".tar" Text -> Text -> Bool
`TL.isSuffixOf` Text
s = (ByteString -> ByteString) -> IO (ByteString -> ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString -> ByteString
forall a. a -> a
id
| Text
".tar.xz" Text -> Text -> Bool
`TL.isSuffixOf` Text
s = (ByteString -> ByteString) -> IO (ByteString -> ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString -> ByteString
Lzma.decompress
| Bool
otherwise = String -> IO (ByteString -> ByteString)
forall a. String -> IO a
unrecognized (Text -> String
unpack Text
s)
tarResponse :: Text -> FilePath -> ByteString -> IO ()
tarResponse :: Text -> String -> ByteString -> IO ()
tarResponse Text
url' String
dirName ByteString
response = do
ByteString -> ByteString
compress <- Text -> IO (ByteString -> ByteString)
getCompressor Text
url'
let f :: ByteString -> IO ()
f = String -> ByteString -> IO ()
Archive.unpackToDir String
dirName (ByteString -> IO ())
-> (ByteString -> ByteString) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
compress
ByteString -> IO ()
f ByteString
response
zipResponse :: FilePath -> ByteString -> IO ()
zipResponse :: String -> ByteString -> IO ()
zipResponse String
dirName ByteString
response = do
let options :: ZipOption
options = String -> ZipOption
OptDestination String
dirName
[ZipOption] -> Archive -> IO ()
extractFilesFromArchive [ZipOption
options] (ByteString -> Archive
toArchive ByteString
response)
buildHelper :: Bool -> ATSDependency -> IO ()
buildHelper :: Bool -> ATSDependency -> IO ()
buildHelper Bool
b (ATSDependency Text
lib' Text
dirName' Text
url'' Maybe Text
_ Version
_ [LibDep]
_ [LibDep]
_ [LibDep]
_ [Text]
_) = do
let (String
lib, String
dirName, String
url') = (Text
lib', Text
dirName', Text
url'') (Text, Text, Text)
-> ((Text, Text, Text) -> (String, String, String))
-> (String, String, String)
forall a b. a -> (a -> b) -> b
& (Text -> Identity String)
-> (Text, Text, Text) -> Identity (String, String, String)
forall s t a b. Each s t a b => Traversal s t a b
each ((Text -> Identity String)
-> (Text, Text, Text) -> Identity (String, String, String))
-> (Text -> String)
-> (Text, Text, Text)
-> (String, String, String)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Text -> String
unpack
isLib :: String
isLib = String -> String -> Bool -> String
forall a. a -> a -> Bool -> a
bool String
"" String
"library " Bool
b
Bool
needsSetup <- Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Bool
doesDirectoryExist (String
dirName String -> String -> String
forall a. [a] -> [a] -> [a]
++ if Bool
b then String
"/atspkg.dhall" else String
"")
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needsSetup (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
putStrLn (String
"Fetching " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
isLib String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lib String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"...")
Manager
manager <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
Request
initialRequest <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
url'
ByteString
response <- Response ByteString -> ByteString
forall body. Response body -> body
responseBody (Response ByteString -> ByteString)
-> IO (Response ByteString) -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> Manager -> IO (Response ByteString)
httpLbs (Request
initialRequest { method :: Method
method = Method
"GET" }) Manager
manager
String -> IO ()
putStrLn (String
"Unpacking " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
isLib String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lib String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"...")
if Text
"zip" Text -> Text -> Bool
`TL.isSuffixOf` Text
url'' then
String -> ByteString -> IO ()
zipResponse String
dirName ByteString
response
else Text -> String -> ByteString -> IO ()
tarResponse Text
url'' String
dirName ByteString
response
Bool
needsMove <- String -> IO Bool
doesDirectoryExist (String
dirName String -> String -> String
</> String
"package")
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needsMove (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
String -> String -> IO ()
renameDirectory (String
dirName String -> String -> String
</> String
"package") String
"tempdir"
String -> IO ()
removeDirectoryRecursive String
dirName
String -> String -> IO ()
renameDirectory String
"tempdir" String
dirName