{-# LANGUAGE OverloadedStrings #-}

module Language.ATS.Package.Dependency ( -- * Functions
                                         fetchDeps
                                       , buildHelper
                                       -- * Types
                                       , 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 -- ^ Shake verbosity
          -> CCompiler -- ^ C compiler to use
          -> Maybe String -- ^ Args
          -> [IO ()] -- ^ Setup steps that can be performed concurrently
          -> [(String, ATSConstraint)] -- ^ ATS dependencies
          -> [(String, ATSConstraint)] -- ^ C Dependencies
          -> [(String, ATSConstraint)] -- ^ ATS build dependencies
          -> FilePath -- ^ Path to configuration file
          -> SetupScript -- ^ How to install an ATS library
          -> Bool -- ^ Whether to perform setup anyhow.
          -> 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

        -- Set up actions
        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'

        -- Fetch all packages & build compiler
        [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 -- FIXME parallel'

        (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 -- ^ C compiler to use
      -> ATSDependency -- ^ ATSDependency itself
      -> 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
    -- let f = Tar.unpack dirName . Tar.read . 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