module Development.Shake.ATS (
cgen
, cgenPretty
, cleanATS
, atsBin
, atsLex
, patsHome
, Version (..)
) where
import Control.Monad
import Control.Monad.IO.Class
import Data.Either (fromRight)
import Data.Maybe (fromMaybe)
import Data.Semigroup (Semigroup (..))
import qualified Data.Text.Lazy as TL
import Development.Shake
import Development.Shake.FilePath
import Language.ATS
import System.Directory (copyFile, createDirectoryIfMissing)
import System.Exit (ExitCode (ExitSuccess))
newtype Version = Version [Integer]
instance Show Version where
show (Version []) = ""
show (Version [x]) = show x
show (Version (x:xs)) = show x ++ "." ++ show (Version xs)
patsHome :: Version -> Action String
patsHome v = fromMaybe "/usr/local/lib/ats2-postiats-0.3.9" <$> mh
where mh = fmap (++ ("/.atspkg/" ++ show v ++ "/")) <$> getEnv "HOME"
atsCommand :: CmdResult r => Version -> Version -> String -> String -> Action r
atsCommand v v' sourceFile out = do
h <- patsHome v'
let home = h ++ "lib/ats2-postiats-" ++ show v
let atsArgs = [EchoStderr False, AddEnv "PATSHOME" home]
patsc = "patsopt"
command atsArgs patsc ["--output", out, "-dd", sourceFile, "-cc"]
gcFlag :: Bool -> String
gcFlag False = "-DATS_MEMALLOC_LIBC"
gcFlag True = "-DATS_MEMALLOC_GCBDW"
copySources :: Version -> Version -> [FilePath] -> Action ()
copySources v v' sources =
forM_ sources $ \dep -> do
h <- patsHome v'
let home = h ++ "lib/ats2-postiats-" ++ show v
liftIO $ createDirectoryIfMissing True (home ++ "/" ++ takeDirectory dep)
liftIO $ copyFile dep (home ++ "/" ++ dep)
atsBin :: Version
-> Version
-> Bool
-> [String]
-> String
-> String
-> Rules ()
atsBin v v' gc libs sourceFile out =
out %> \_ -> do
sources <- transitiveDeps [sourceFile]
h <- patsHome v'
let home = h ++ "lib/ats2-postiats-" ++ show v
need sources
copySources v v' sources
cmd_ ["mkdir", "-p", dropDirectory1 out]
path <- fromMaybe "" <$> getEnv "PATH"
let toLibs = fmap ("-l" <>)
command
[EchoStderr False, AddEnv "PATSHOME" home, AddEnv "PATH" (home ++ "/bin:" ++ path), AddEnv "PATSHOMELOCS" "./.atspkg/contrib"]
(home ++ "/bin/patscc")
([sourceFile, "-atsccomp", "gcc -flto -I" ++ h ++ "/ccomp/runtime/ -I" ++ h, gcFlag gc, "-o", out, "-cleanaft", "-O2", "-mtune=native", "-flto"] <> toLibs libs)
atsLex :: Rules ()
atsLex =
"*.dats" %> \out -> do
lats <- liftIO $ readFile (out -<.> "lats")
(Stdout contents) <- command [Stdin lats] "atslex" []
liftIO $ writeFile out contents
cleanATS :: Rules ()
cleanATS =
"clean" ~> do
removeFilesAfter "." ["//*.c", "//tags"]
removeFilesAfter ".atspkg" ["//*"]
removeFilesAfter "ats-deps" ["//*"]
handleSource :: Version -> Version -> FilePath -> Action ()
handleSource v v' sourceFile = do
sources <- transitiveDeps [sourceFile]
need sources
copySources v v' sources
cgen :: Version
-> Version
-> FilePath
-> Rules ()
cgen v v' dir =
"//*.c" %> \out -> do
let sourceFile = dir ++ "/" ++ (dropDirectory1 out -<.> "dats")
handleSource v v' sourceFile
atsCommand v v' sourceFile out
fixDir :: FilePath -> String -> String
fixDir p =
TL.unpack
. TL.replace (TL.pack "./") (TL.pack $ p ++ "/")
. TL.replace (TL.pack "../") (TL.pack $ joinPath (init $ splitPath p) ++ "/")
. TL.replace (TL.pack "$PATSHOMELOCS") (TL.pack ".atspkg/contrib")
. TL.replace (TL.pack "\\\n") mempty
. TL.pack
trim :: String -> String
trim = init . drop 1
transitiveDeps :: [FilePath] -> Action [FilePath]
transitiveDeps [] = pure []
transitiveDeps ps = fmap join $ forM ps $ \p -> do
contents <- liftIO $ readFile p
let ats = fromRight mempty . parseATS . lexATS $ contents
let dir = takeDirectory p
deps <- filterM doesFileExist $ fixDir dir . trim <$> getDependencies ats
deps' <- transitiveDeps deps
pure $ (p:deps) ++ deps'
cgenPretty :: Version
-> Version
-> FilePath
-> Rules ()
cgenPretty v v' dir =
"//*.c" %> \out -> do
let sourceFile = dir ++ "/" ++ (dropDirectory1 out -<.> "dats")
handleSource v v' sourceFile
(Exit c, Stderr err) :: (Exit, Stderr String) <- atsCommand v v' sourceFile out
cmd_ [Stdin err] Shell "pats-filter"
if c /= ExitSuccess
then error "patscc failure"
else pure ()