ATS.hs

{-# LANGUAGE OverloadedStrings #-}

module Distribution.ATS ( cleanATSCabal
                        , atsUserHooks
                        , atsLibUserHooks
                        , fetchDependencies
                        -- * Types
                        , ATSVersion
                        , ATSDependency (..)
                        -- * Libraries
                        , libgmp
                        , intinf
                        , atsPrelude
                        , atsContrib
                        -- * Functions involving the compiler
                        , fetchCompiler
                        , setupCompiler
                        , packageCompiler
                        ) where

import qualified Codec.Archive.Tar                    as Tar
import           Codec.Compression.GZip               (decompress)
import           Control.Concurrent.ParallelIO.Global
import           Control.Monad
import           Data.Bool
import qualified Data.Dependency                      as Dep
import           Data.List                            (intercalate)
import           Distribution.ATS.Compiler
import           Distribution.PackageDescription
import           Distribution.Simple
import           Distribution.Simple.LocalBuildInfo
import           Distribution.Simple.Setup
import           Network.HTTP.Client                  hiding (decompress)
import           Network.HTTP.Client.TLS              (tlsManagerSettings)
import           System.Directory

-- | ATS library version to use, e.g. @[0,3,8]@ for @0.3.8@.
type ATSVersion = [Integer]

data ATSDependency = ATSDependency { _libName  :: String -- ^ Library name
                                   , _filepath :: FilePath -- ^ Directory to unpack library into
                                   , _url      :: String -- ^ URL of tarball containing ATS library.
                                   }

maybeCleanBuild :: LocalBuildInfo -> IO ()
maybeCleanBuild li =
    let cf = configConfigurationsFlags (configFlags li) in

    unless ((mkFlagName "development", True) `elem` cf) $
        putStrLn "Cleaning up ATS dependencies..." >>
        cleanATSCabal

fetchCompiler' :: IO ()
fetchCompiler' = fetchCompiler (Just "ats-deps") (Dep.Version [0,3,9])

setupCompiler' :: IO ()
setupCompiler' = setupCompiler (Just "ats-deps") (Dep.Version [0,3,9])

-- | This generates user hooks for a Cabal distribution that has some ATS
-- library dependencies. For an example of its use, see the @Setup.hs@ of
-- [fast-arithmetic](https://hackage.haskell.org/package/fast-arithmetic)
atsUserHooks :: [ATSDependency] -> UserHooks
atsUserHooks deps = simpleUserHooks { preConf = \_ _ -> fetchDependencies deps >> pure emptyHookedBuildInfo
                                    , postBuild = \_ _ _ -> maybeCleanBuild
                                    }

-- | Same as 'atsUserHooks', but installs @atslib@ as well.
atsLibUserHooks :: [ATSDependency] -> UserHooks
atsLibUserHooks deps = simpleUserHooks { preConf = \_ _ -> mconcat [ fetchCompiler', setupCompiler', fetchDependencies deps ] >> pure emptyHookedBuildInfo
                                       , postBuild = \_ _ _ -> maybeCleanBuild
                                       }
-- TODO custom directory?
cleanATSCabal :: IO ()
cleanATSCabal = do
    b <- doesDirectoryExist "ats-deps"
    bool (pure ()) (removeDirectoryRecursive "ats-deps") b

vString :: ATSVersion -> String
vString = intercalate "." . fmap show

atsContrib :: ATSVersion -> ATSDependency
atsContrib v = ATSDependency ("ats2-postiats-" ++ vs ++ "-contrib") "ats-deps/contrib" ("https://downloads.sourceforge.net/project/ats2-lang/ats2-lang/ats2-postiats-" ++ vs ++ "/ATS2-Postiats-contrib-" ++ vs ++ ".tgz")
    where vs = vString v

-- | GMP bindings for ATS
libgmp :: ATSDependency
libgmp = ATSDependency "atscntrb-libgmp-1.0.4" "ats-deps/contrib/atscntrb-libgmp" "https://registry.npmjs.org/atscntrb-libgmp/-/atscntrb-libgmp-1.0.4.tgz"

-- | Arbitrary-precision arithmetic library for ATS
intinf :: ATSDependency
intinf = ATSDependency "atscntrb-hs-intinf-1.0.6" "ats-deps/contrib/atscntrb-hx-intinf" "https://registry.npmjs.org/atscntrb-hx-intinf/-/atscntrb-hx-intinf-1.0.6.tgz"

-- | ATS prelude
atsPrelude :: ATSVersion -> ATSDependency
atsPrelude v = ATSDependency ("ats2-postiats-" ++ vs ++ "-prelude") "ats-deps/prelude" ("https://downloads.sourceforge.net/project/ats2-lang/ats2-lang/ats2-postiats-" ++ vs ++ "/ATS2-Postiats-include-" ++ vs ++ ".tgz")
    where vs = vString v

fetchDependencies :: [ATSDependency] -> IO ()
fetchDependencies = (>> stopGlobalPool) . parallel_ . fmap fetchDependency

fetchDependency :: ATSDependency -> IO ()
fetchDependency (ATSDependency libNameATS dirName url) = do

    needsSetup <- not <$> doesFileExist (dirName ++ "/unpacked")

    when needsSetup $ do

        let doing str = putStrLn (str ++ " library " ++ libNameATS ++ "...")
        doing "Fetching"
        manager <- newManager tlsManagerSettings
        initialRequest <- parseRequest url
        response <- responseBody <$> httpLbs (initialRequest { method = "GET" }) manager

        doing "Unpacking"
        Tar.unpack dirName . Tar.read . decompress $ response

        doing "Setting up"
        writeFile (dirName ++ "/unpacked") ""
        needsMove <- doesDirectoryExist (dirName ++ "/package")
        when needsMove $ do
            renameDirectory (dirName ++ "/package") "tempdir"
            removeDirectoryRecursive dirName
            renameDirectory "tempdir" dirName