ATS.hs

{-# LANGUAGE OverloadedStrings #-}

module Distribution.ATS ( cleanATSCabal
                        , atsUserHooks
                        , fetchDependencies
                        -- * Types
                        , ATSVersion
                        , ATSDependency (..)
                        -- * Libraries
                        , libgmp
                        , intinf
                        , atsPrelude
                        ) where

import qualified Codec.Archive.Tar                    as Tar
import           Codec.Compression.GZip               (decompress)
import           Control.Concurrent.ParallelIO.Global
import           Control.Monad
import           Data.List                            (intercalate)
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

-- | 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
                                    }

cleanATSCabal :: IO ()
cleanATSCabal = removeDirectoryRecursive "ats-deps"

-- | 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"

-- https://registry.npmjs.org/ats-postiats-include/-/ats-postiats-include-1.0.0.tgz

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

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

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

    needsSetup <- not <$> doesDirectoryExist dirName

    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"
        needsMove <- doesDirectoryExist (dirName ++ "/package")
        when needsMove $ do
            renameDirectory (dirName ++ "/package") "tempdir"
            removeDirectoryRecursive dirName
            renameDirectory "tempdir" dirName