{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}

-- | This module contains functions for installing the @patscc@ compiler. It
-- also includes functions for building @libatslib@.
module Language.ATS.Package.Compiler
    -- ( packageCompiler
    ( fetchCompiler
    , setupCompiler
    , cleanAll
    -- * Types
    , 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
""
        -- in "https://cytranet.dl.sourceforge.net/project/ats2-lang/ats2-lang/ats2-postiats-" ++ vs ++ "/ATS2-Postiats-" ++ gmp ++ vs ++ ".tgz"

-- | Make a tarball from a directory containing the compiler.
-- packageCompiler :: FilePath -> IO ()
-- packageCompiler directory = do
    -- files <- find (pure True) (pure True) directory
    -- bytes <- fmap Tar.write . Tar.pack directory $ fmap (drop $ length (directory :: String) + 1) files
    -- BS.writeFile (directory ++ ".tar.gz") (compress bytes)

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 -- ^ Optional target triple
                 -> String -- ^ Library name
                 -> FilePath -- ^ File path
                 -> 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