{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Language.ATS.Package.Compiler
( fetchCompiler
, setupCompiler
, cleanAll
, SetupScript
) where
import qualified Archive.Compression as Archive
import Codec.Compression.GZip (decompress)
import Control.Monad
import Data.Dependency
import Data.FileEmbed
import qualified Development.Shake.Check as Check
import Network.HTTP.Client hiding (decompress)
import Quaalude
libatsCfg :: String
libatsCfg :: String
libatsCfg = $(embedStringFile ("dhall" </> "atslib.dhall"))
compilerUnpackDir :: Version -> IO FilePath
compilerUnpackDir :: Version -> IO String
compilerUnpackDir Version
v = String -> IO String
makeAbsolute (String -> IO String) -> IO String -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO String
dir
where dir :: IO String
dir = String -> IO String
getAppUserDataDirectory (String
"atspkg" String -> String -> String
</> String
vs)
vs :: String
vs = Version -> String
forall a. Show a => a -> String
show Version
v
compilerDir :: Version -> IO FilePath
compilerDir :: Version -> IO String
compilerDir Version
v = String -> IO String
makeAbsolute (String -> IO String) -> IO String -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO String
dir
where dir :: IO String
dir = String -> IO String
getAppUserDataDirectory (String
"atspkg" String -> String -> String
</> String
vs String -> String -> String
</> String
"ATS2-Postiats-gmp-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
vs)
vs :: String
vs = Version -> String
forall a. Show a => a -> String
show Version
v
pkgUrl :: Version -> String
pkgUrl :: Version -> String
pkgUrl Version
v =
let vs :: String
vs = Version -> String
forall a. Show a => a -> String
show Version
v
in String
"http://ats-lang.sourceforge.net/IMPLEMENT/Postiats/ATS2-Postiats-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
gmp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
vs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".tgz"
where gmp :: String
gmp = if Version
v Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Natural] -> Version
Version [Natural
0,Natural
4,Natural
0] then String
"gmp-" else String
""
withCompiler :: String -> Version -> IO ()
withCompiler :: String -> Version -> IO ()
withCompiler String
s Version
v = String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" compiler v" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Show a => a -> String
show Version
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"..."
fetchCompiler :: Version -> IO ()
fetchCompiler :: Version -> IO ()
fetchCompiler Version
v = do
String
cd <- Version -> IO String
compilerUnpackDir Version
v
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
cd
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 -> Version -> IO ()
withCompiler String
"Fetching" Version
v
Manager
manager <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
Request
initialRequest <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest (String -> IO Request) -> String -> IO Request
forall a b. (a -> b) -> a -> b
$ Version -> String
pkgUrl Version
v
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 -> Version -> IO ()
withCompiler String
"Unpacking" Version
v
String -> ByteString -> IO ()
Archive.unpackToDir String
cd (ByteString -> ByteString
decompress ByteString
response)
make :: Verbosity -> Version -> FilePath -> IO ()
make :: Verbosity -> Version -> String -> IO ()
make Verbosity
v' Version
v String
cd =
String -> Version -> IO ()
withCompiler String
"Building" Version
v IO () -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
Verbosity -> CreateProcess -> IO ()
silentCreateProcess Verbosity
v' ((String -> [String] -> CreateProcess
proc String
makeExe []) { cwd :: Maybe String
cwd = String -> Maybe String
forall a. a -> Maybe a
Just String
cd })
type SetupScript = Maybe String
-> String
-> FilePath
-> IO ()
libInstall :: SetupScript -> FilePath -> String -> IO ()
libInstall :: SetupScript -> String -> String -> IO ()
libInstall SetupScript
atslibSetup String
cd String
triple =
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String
triple String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"musl") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
[ String -> IO ()
putStrLn String
"Installing cross libraries..."
, String -> String -> IO ()
writeFile (String
cd String -> String -> String
</> String
"atspkg.dhall") String
libatsCfg
, SetupScript
atslibSetup (String -> Maybe String
forall a. a -> Maybe a
Just String
triple) String
"atslib" String
cd
]
install :: Verbosity
-> Maybe String
-> SetupScript
-> Version
-> FilePath
-> IO ()
install :: Verbosity
-> Maybe String -> SetupScript -> Version -> String -> IO ()
install Verbosity
v' Maybe String
tgt' SetupScript
als Version
v String
cd =
String -> Version -> IO ()
withCompiler String
"Installing" Version
v IO () -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
String -> IO ()
makeExecutable (String
cd String -> String -> String
</> String
"install-sh") IO () -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
Verbosity -> CreateProcess -> IO ()
silentCreateProcess Verbosity
v' ((String -> [String] -> CreateProcess
proc String
makeExe [String
"install"]) { cwd :: Maybe String
cwd = String -> Maybe String
forall a. a -> Maybe a
Just String
cd }) IO () -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
IO () -> (String -> IO ()) -> Maybe String -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ()
forall a. Monoid a => a
mempty (SetupScript -> String -> String -> IO ()
libInstall SetupScript
als String
cd) Maybe String
tgt'
configure :: Verbosity -> FilePath -> Version -> FilePath -> IO ()
configure :: Verbosity -> String -> Version -> String -> IO ()
configure Verbosity
v' String
configurePath Version
v String
cd = do
String -> Version -> IO ()
withCompiler String
"Configuring" Version
v
String -> IO ()
makeExecutable String
configurePath
Bool
autoconf <- IO Bool
forall (m :: * -> *). MonadIO m => m Bool
Check.autoconf
Bool
automake <- IO Bool
forall (m :: * -> *). MonadIO m => m Bool
Check.automake
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
autoconf Bool -> Bool -> Bool
&& Bool
automake) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> IO ()
makeExecutable (String
cd String -> String -> String
</> String
"autogen.sh") IO () -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
Verbosity -> CreateProcess -> IO ()
silentCreateProcess Verbosity
v' ((String -> [String] -> CreateProcess
proc (String
cd String -> String -> String
</> String
"autogen.sh") []) { cwd :: Maybe String
cwd = String -> Maybe String
forall a. a -> Maybe a
Just String
cd })
Verbosity -> CreateProcess -> IO ()
silentCreateProcess Verbosity
v' ((String -> [String] -> CreateProcess
proc String
configurePath [String
"--prefix", String
cd]) { cwd :: Maybe String
cwd = String -> Maybe String
forall a. a -> Maybe a
Just String
cd })
setupCompiler :: Verbosity -> SetupScript -> Maybe FilePath -> Version -> IO ()
setupCompiler :: Verbosity -> SetupScript -> Maybe String -> Version -> IO ()
setupCompiler Verbosity
v' SetupScript
als Maybe String
tgt' Version
v = do
String
cd <- Version -> IO String
compilerDir Version
v
[Version -> String -> IO ()] -> Version -> String -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t (a -> b -> f ()) -> a -> b -> f ()
biaxe [Verbosity -> String -> Version -> String -> IO ()
configure Verbosity
v' (String
cd String -> String -> String
</> String
"configure"), Verbosity -> Version -> String -> IO ()
make Verbosity
v', Verbosity
-> Maybe String -> SetupScript -> Version -> String -> IO ()
install Verbosity
v' Maybe String
tgt' SetupScript
als] Version
v String
cd
cleanAll :: IO ()
cleanAll :: IO ()
cleanAll = do
String
d <- String -> IO String
getAppUserDataDirectory String
"atspkg"
Bool
b <- String -> IO Bool
doesDirectoryExist String
d
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
putStrLn String
"Cleaning everything..."
String -> IO ()
removeDirectoryRecursive String
d