{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
{-# LANGUAGE RecordWildCards #-}
module Development.Shake.ATS (
atsBin
, cgen
, genATS
, atsLex
, cabalForeign
, hsAts
, cleanATS
, getSubdirs
, ccToDir
, withPF
, patscc
, patsopt
, ForeignCabal (..)
, ATSTarget (..)
, ATSToolConfig (..)
, CCompiler (..)
, ArtifactType (..)
, ATSGen (..)
, HATSGen (..)
, Solver (..)
) where
import Control.Arrow
import Control.Monad
import Control.Monad.IO.Class
import Data.Bool (bool)
import Data.Either (fromRight)
import Data.Foldable
import Data.Maybe (fromMaybe)
import Data.Semigroup (Semigroup (..))
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import qualified Data.Text.Lazy as TL
import Development.Shake hiding (doesFileExist, getEnv)
import Development.Shake.ATS.Environment
import Development.Shake.ATS.Rules
import Development.Shake.ATS.Type
import Development.Shake.C hiding (GHC)
import qualified Development.Shake.C as C
import Development.Shake.Cabal
import Development.Shake.FilePath
import Development.Shake.Version
import Language.ATS
import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
import System.Environment (getEnv)
import System.Exit (ExitCode (ExitSuccess))
atsCommand :: CmdResult r => ATSToolConfig
-> String
-> String
-> Action r
atsCommand tc sourceFile out = do
path <- liftIO $ getEnv "PATH"
let env = patsEnv tc path
patsc = patsopt tc
f = case _solver tc of
Ignore -> ("--constraint-ignore":)
_ -> id
(<*)
(command env patsc (f ["--output", out, "-dd", sourceFile, "-cc"] ++ _patsFlags tc))
(liftIO $ deleteLine out)
deleteLine :: FilePath -> IO ()
deleteLine fp = TIO.writeFile fp . del =<< TIO.readFile fp
where del = T.unlines . fmap snd . filter p . zip [(1::Int)..] . T.lines
p = (4 /=) . fst
withPF :: Action (Exit, Stderr String, Stdout String)
-> Action (Exit, Stderr String, Stdout String)
withPF act = do
ret@(Exit c, Stderr err, Stdout _) <- act :: Action (Exit, Stderr String, Stdout String)
cmd_ [Stdin err] Shell "pats-filter"
if c /= ExitSuccess
then error "patsopt failure"
else pure ret
gcFlag :: Bool -> String
gcFlag False = "-DATS_MEMALLOC_LIBC"
gcFlag True = "-DATS_MEMALLOC_GCBDW"
copySources :: ATSToolConfig -> [FilePath] -> Action ()
copySources ATSToolConfig{..} sources =
forM_ sources $ \dep -> do
liftIO $ createDirectoryIfMissing True (_patsHome </> takeDirectory dep)
liftIO $ copyFile dep (_patsHome </> dep)
makeCFlags :: [String]
-> [ForeignCabal]
-> String
-> Bool
-> [String]
makeCFlags ss fc ghcV' b = gcFlag' : (hsExtra <> ss) where
gcFlag' = bool ("-optc" <>) id noHs $ gcFlag b
hsExtra = bool (["--make", "-I.", "-odir", ".atspkg", "-no-hs-main", "-package-db", "~/.cabal/store/ghc-" ++ ghcV' </> "package.db/"] ++ packageDbs) mempty noHs
noHs = null fc
packageDbs = (\x -> ["-package-db", x </> "dist-newstyle" </> "packagedb" </> "ghc-" ++ ghcV']) =<< libToDirs fc
libToDirs :: [ForeignCabal] -> [String]
libToDirs = fmap (takeDirectory . TL.unpack . h)
where h (ForeignCabal mpr cf _) = fromMaybe cf mpr
patscc :: ATSToolConfig -> String
patscc = patsTool "patscc"
patsopt :: ATSToolConfig -> String
patsopt = patsTool "patsopt"
patsTool :: String -> ATSToolConfig -> String
patsTool tool tc = _patsHome tc ++ "/bin/" ++ tool
cconfig :: MonadIO m => ATSToolConfig -> [String] -> Bool -> [String] -> m CConfig
cconfig tc libs' gc' extras = do
let h = _patsHome tc
cc' = _cc tc
f = bool id ("atslib":) (_linkATSLib tc)
h' <- pkgHome cc'
let libs'' = f $ bool libs' ("gc" : libs') gc'
pure $ CConfig [h </> "ccomp" </> "runtime", h, h' </> "include", ".atspkg" </> "contrib"] libs'' [h' </> "lib", _patsHome tc </> "ccomp" </> "atslib" </> "lib"] extras (_linkStatic tc)
patsEnv :: ATSToolConfig -> FilePath -> [CmdOption]
patsEnv cfg path = EchoStderr False :
zipWith AddEnv
["PATSHOME", "PATH", "PATSHOMELOCS"]
[_patsHome cfg, _patsHome cfg </> "bin:" ++ path, _patsHomeLocs cfg ]
atsToC :: FilePath -> FilePath
atsToC = (-<.> "c") . ((".atspkg" </> "c") </>)
ghcV :: HsCompiler -> [ForeignCabal] -> Action String
ghcV (GHC _ suff) hsLibs' = maybe def' (fmap (drop 1)) (pure <$> suff) where
def' = case hsLibs' of
[] -> pure undefined
_ -> quietly ghcVersion
ghcV _ _ = pure undefined
doLib :: ArtifactType -> Rules () -> Rules ()
doLib Executable = pure mempty
doLib _ = id
hsAts :: ATSGen -> Rules ()
hsAts (ATSGen x y z) = genATS x y z
satsGen :: HATSGen -> Rules ()
satsGen (HATSGen x y) = genLinks x y
ccToHsc :: CCompiler -> HsCompiler
ccToHsc (C.GHC pref suff) = GHC pref suff
ccToHsc _ = GHC Nothing Nothing
atsBin :: ATSTarget -> Rules ()
atsBin ATSTarget{..} = do
traverse_ satsGen _linkTargets
traverse_ hsAts _genTargets
traverse_ (cabalForeign (ccToHsc $ _cc _toolConfig)) _hsLibs
let cTargets = atsToC <$> _src
let h Executable = id
h StaticLibrary = fmap (-<.> "o")
h SharedLibrary = fmap (-<.> "o")
g Executable = binaryA
g StaticLibrary = staticLibA
g SharedLibrary = sharedLibA
h' = h _tgtType
cconfig' <- cconfig _toolConfig _libs _gc (makeCFlags _cFlags mempty (pure undefined) _gc)
let atsGen = (hatsFile <$> _linkTargets) <> (_atsTarget <$> _genTargets)
atsExtras = _otherDeps <> (TL.unpack . objectFile <$> _hsLibs)
zipWithM_ (cgen _toolConfig atsExtras atsGen) _src cTargets
doLib _tgtType (zipWithM_ (objectFileR (_cc _toolConfig) cconfig') cTargets (h' cTargets))
_binTarget %> \_ -> do
need (h' cTargets)
ghcV' <- ghcV (ccToHsc $ _cc _toolConfig) _hsLibs
cconfig'' <- cconfig _toolConfig _libs _gc (makeCFlags _cFlags _hsLibs ghcV' _gc)
unit $ g _tgtType (_cc _toolConfig) (h' cTargets) _binTarget cconfig''
bool (pure ()) (stripA _binTarget (_cc _toolConfig)) _strip
cgen :: ATSToolConfig
-> [FilePath]
-> [FilePath]
-> FilePath
-> FilePattern
-> Rules ()
cgen toolConfig' extras atsGens atsSrc cFiles =
cFiles %> \out -> do
need extras
sources <- transitiveDeps atsGens [atsSrc]
need sources
copySources toolConfig' sources
atsCommand toolConfig' atsSrc out
trim :: String -> String
trim = init . drop 1
maybeError :: (MonadIO m) => FilePath -> Either ATSError b -> m ()
maybeError _ Right{} = pure ()
maybeError p (Left y) = warnErr p y
transitiveDeps :: (MonadIO m) => [FilePath] -> [FilePath] -> m [FilePath]
transitiveDeps _ [] = pure []
transitiveDeps gen ps = fmap fold $ forM ps $ \p -> if p `elem` gen then pure mempty else do
contents <- liftIO $ readFile p
let (ats, err) = (fromRight mempty &&& id) . parseM $ contents
maybeError p err
let dir = takeDirectory p
deps <- filterM (\f -> ((f `elem` gen) ||) <$> (liftIO . doesFileExist) f) $ fixDir dir . trim <$> getDependencies ats
deps' <- transitiveDeps gen deps
pure $ (p:deps) ++ deps'