Skip to content

Instantly share code, notes, and snippets.

@oconnore oconnore/Build.hs
Created Jul 16, 2015

Embed
What would you like to do?
Haskell build
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Main where
import Control.Exception
import Control.Failure
import Control.Applicative
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.State
import Data.Either
import Data.Foldable
import Data.IORef
import Data.Maybe
import Data.Monoid
import Data.Text as T (Text, pack, unpack, intercalate, concat, splitOn)
import Data.Typeable
import Data.Yaml.Config (Config, keys, load, subconfig, lookup, KeyError)
import Development.Shake
import Development.Shake.Command
import Development.Shake.FilePath
import Development.Shake.Util
import Prelude hiding (lookup, concat)
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as Set
import qualified System.Directory as SDir
import System.Info
import System.IO
import System.Process
configPath = "./build.yml"
data ConfigurationException = ConfigurationException {
configExcMsg :: String
} deriving (Eq, Show, Read, Typeable)
instance Exception ConfigurationException where
hsExcluded conf = Set.fromList $ fmap (normaliseEx . \x -> (-<.>) x "o") $
fromMaybe [] $ do
excl <- (lookup "excluded" conf :: Maybe [FilePath])
return excl
main :: IO ()
main = do
config <- load configPath
-- Grab some initial config variables
let ( ghc
, clang
, dlltool
, makeFileConf
, compilation
, profiling
, profilingMain
, cfiles
, ads
, linking
, testing
, testingC
) = fromMaybe (error "Configuration lookup failed") $ (,,,,,,,,,,,)
<$> lookup "haskell_compiler" config
<*> lookup "cc_compiler" config
<*> lookup "dlltool" config
<*> subnconfig ["stages", "makefile"] config
<*> subnconfig ["stages", "compilation"] config
<*> subnconfig ["stages", "profiled"] config
<*> subnconfig ["stages", "profiling"] config
<*> subnconfig ["stages", "cfiles"] config
<*> subnconfig ["stages", "ads"] config
<*> subnconfig ["stages", "linking"] config
<*> subnconfig ["stages", "testing"] config
<*> subnconfig ["stages", "testingC"] config
cwd <- (return . normalise) =<< SDir.getCurrentDirectory
let excludedComp = hsExcluded compilation
let excludedProf = hsExcluded profiling
makefile <- newIORef Nothing
let c2hsBin = do
path <- cabalDir config
let c2hsExec = lookup "c2hs" config :: Maybe String
case c2hsExec of
Just x -> return $ joinPath [unpack path, normalise "../bin", x] <.> exe
Nothing -> throw $ ConfigurationException "No c2hs option found in build.yml"
shakeArgs shakeOptions{shakeFiles="./build/",
shakeProgress=progressSimple,
shakeThreads=0} $ do
want ["./ControlAPI" <.> "dll"]
phony "clean" $ do
putNormal $ "Cleaning files."
liftIO $ do
removeFiles "build/" ["//*.make", "//*.make.bak", "runprof.exe", "runtests.exe"]
removeFiles "./" ["ControlAPI.dll*"]
mapM_ (\x -> try $ SDir.removeDirectoryRecursive $ normalise x :: IO (Either SomeException ()))
["build/c", "build/ads", "build/dll", "build/prof", "build/testing"]
let installIndicator = "build/tmp/install_deps.txt"
installIndicator %> \out -> do
let cmdLine = "cabal install --only-dependencies --enable-library-profiling" :: String
((cmd cmdLine) :: Action ())
liftIO $ openFile installIndicator AppendMode >>= hClose
return ()
phony "install-deps" $ do
liftIO $ try $ SDir.removeFile installIndicator :: Action (Either SomeException ())
need [installIndicator]
phony "test" $ do
let exec = "./build/runtests" <.> exe
need [exec]
(cmd $ exec ++ " +RTS -N2") :: Action ()
return ()
phony "profile" $ do
let exec = "./build/runprof" <.> exe
need [exec]
(cmd $ exec ++ " +RTS -N4 -h -pa") :: Action ()
return ()
let dropPrefix prefix file = rep dropDirectory1 (lnd prefix) file
where lnd = length . splitDirectories
dropPrefixAddExt prefix ext file =
dropPrefix prefix $ file -<.> ext
callGhc = (\options stage c -> do
runMaybeT $ do
outputdir <- toMaybeT $ lookup "outputdir" stage
compWd <- toMaybeT $ lookup "cwd" stage
let includes = fmap (pack . normaliseEx) $ fromMaybe [] $ lookup "includes" stage
let incArg = intercalate " " $ includes
let packages = fromMaybe [] $ lookup "packages" stage
let packArg = intercalate " -package " $ [""] ++ packages
let args = fromMaybe "" $ lookup "args" stage
let linkPath = fromMaybe "" $
lookup "linkPath" stage >>=
return . (\x -> T.concat ["-L", T.pack $ normaliseEx x])
let links = fromMaybe "" $
(lookup "link" stage :: Maybe [Text]) >>=
return . (\x -> T.intercalate " " $ fmap (\y -> T.concat ["-l", y]) x)
let output = fromMaybe "" $ do
out <- lookup "output" stage
return $ T.concat ["-o ", pack $ normaliseEx out]
lift $ ((cmd (Cwd compWd) $ unpack $
intercalate " " $ [
ghc
, if c then "-c" else ""
, args , packArg, incArg
, "-outputdir", pack $ normalise outputdir
, output
] ++
options
++ [
linkPath
, links
]) :: Action ())
return ()) :: [Text] -> Config -> Bool -> Action ()
callClang = (\target out options stage c -> do
runMaybeT $ do
outputdir <- toMaybeT $ lookup "outputdir" stage
args <- toMaybeT $ lookup "args" stage
compWd <- toMaybeT $ lookup "cwd" stage
lift $ ((command_ [Cwd compWd] (normalise clang)
(L.concat [
[if c then "-c" else ""]
, fmap T.unpack $ T.splitOn " " args
, [T.unpack target]
, ["-o"]
, [normaliseEx $ joinPath [T.unpack outputdir, takeFileName $ T.unpack out]]
, fmap T.unpack options
])) :: Action ())
return ()) :: Text -> Text -> [Text] -> Config -> Bool -> Action ()
matchExts pref patts file = matchPrefix && matchExtension
where matchPrefix = (pref ?== file)
matchExtension = or (fmap (flip (?==) file) patts)
ensureMakefileParsed config var main prefix makef =
liftIO (readIORef makefile) >>= \m -> do
case m of
Just jm -> return jm
Nothing -> do
buildDependencies config makefile main "src/" prefix makef
liftIO (readIORef makefile >>= return . fromJust)
buildManyTest prefix extensions out =
if matchExts (prefix ++ "//*") (fmap ("//*" ++) extensions) out then
Just results
else Nothing
where results = [out -<.> ext | ext <- extensions]
buildHaskell sources prefix conf =
buildManyTest prefix [".hi", ".o"] &?> \out -> do
let ofile = fromJust $ L.find ((==) ".o" . takeExtension) out
let hifile = fromJust $ L.find ((==) ".hi" . takeExtension) out
let dir = sources
let makef = fromMaybe (error "No makefile specified") $ lookup "make" conf :: String
x <- ensureMakefileParsed config makefile main prefix makef
case M.lookup (normalise ofile) x of
Just deps -> do
cabal <- liftIO (cabalPath (config :: Config))
case L.find (matchExts "src//*" ["//*.hs"]) deps of
Just c -> do
need $ deps ++ [c]
callGhc ([pack c, cabal]) conf True
Nothing -> putNormal $ "Not building file " ++ ofile ++
", couldn't find *.hs in " ++ (show deps)
Nothing -> do
putNormal $ "Not building file " ++ ofile ++
", couldn't find " ++ (normalise ofile) ++ " in " ++
(show $ M.keys x)
return ()
buildC = \sources prefix ->
prefix ++ "//*.o" %> \out -> do
let cpp = dropPrefixAddExt prefix "c" out
need $ [joinPath [sources, cpp]]
callGhc [pack cpp] cfiles True
buildCC = \sources prefix ->
prefix ++ "//*.o" %> \out -> do
let cpp = dropPrefixAddExt prefix "cpp" out
need $ [joinPath [sources, cpp]]
callClang (pack cpp) (pack out) [] ads True
in do
buildHaskell "src/" "build/dll" compilation
buildHaskell "src/" "build/prof" profiling
buildHaskell "src/" "build/testing" testingC
buildC "src/" "build/c"
buildCC "src/Ads/" "build/ads"
"build/*.make" %> \out -> do
let main =
case takeFileName out of
"maindll.make" -> Just "ControlAPI.hs"
"test.make" -> Just "Test/KTSTests.hs"
"prof.make" -> Just "Test/Profiling/Main.hs"
_ -> Nothing
forM_ main $ \x -> runMaybeT $ do
lift $ do
chs <- getDirectoryFiles "src/" ["//*.chs"]
need ["src/" </> x -<.> "hs" | x <- chs]
deps <- MaybeT . return =<< liftIO (buildMakefile config "makefile" x out)
cwd <- toMaybeT $ lookup "cwd" makeFileConf
lift $ needed $ fmap (cwd </>) deps
"build/*/*.def" %> \out -> do
x <- case takeDirectory (dropDirectory1 out) of
"dll" -> return $ Just (linking, "build/maindll.make", "ControlAPI.dll",
"ControlAPI.hs", "build/dll")
"prof" -> return $ Just (profilingMain, "build/prof.make", "ControlAPI.dll",
"ControlAPI.hs", "build/prof")
_ -> return Nothing
let buildOfiles (k, v) lis = L.filter ((==) ".o" . takeExtension) (k : v) ++ lis
case x of
Just (conf, makef, dll, main, prefix) -> do
x <- ensureMakefileParsed conf makefile main prefix makef
cFiles <- getDirectoryFiles "src/CFiles" ["//*.c"]
adsFiles <- getDirectoryFiles "src/Ads" ["//*.cpp"]
let files = foldr buildOfiles [] (M.toList x)
let cdeps = L.concat [
[normalise $ "./build/c/CFiles" </> c -<.> "o" | c <- cFiles]
, [normalise $ "./build/ads/" </> c -<.> "o" | c <- adsFiles]
]
need $ [x -<.> "hi" | x <- files] ++ cdeps
command_ [] dlltool ([
"-z", out
, "-D", dll
, "--export-all-symbols"
] ++ files ++ cdeps)
Nothing -> return ()
-- For c2hs code
"//*.hs" %> \out -> do
let cpp = out -<.> "chs"
liftIO (SDir.doesFileExist cpp) >>= \b -> if b then do
let dir = takeDirectory out
hFiles <- getDirectoryFiles dir ["//*.h"]
removeFilesAfter (takeDirectory out) ["//*.chi", "//*.chs.h"]
let deps = filter (not . (?==) "//*.*.h") $
fmap normaliseEx $ [cpp] ++ [dir </> c | c <- hFiles]
need $ deps
bin <- liftIO $ c2hsBin
(cmd bin [cpp]) :: Action ()
return ()
else return ()
let buildDll output conf out main mkName dlltool = do
need [mkName]
mapM_ (need . \x -> [x]) dlltool
cur <- liftIO $ SDir.getCurrentDirectory
buildDependencies config makefile
main "src/" output mkName
m <- liftIO $ readIORef makefile
target <- liftIO $ SDir.makeRelativeToCurrentDirectory $
normalise $ joinPath [cur, output </> unpack main -<.> "o"]
m <- liftIO $ readIORef makefile >>= return . fromJust
cFiles <- getDirectoryFiles "src/" ["//*.c"]
adsFiles <- getDirectoryFiles "src/Ads/" ["//*.cpp", "//*.cc"]
let deps = fromMaybe [] $ M.lookup target m
transitive = Set.toList . Set.fromList $ foldr (\k c -> k : (L.concat [c,
foldr (\x l -> if matchExts "build//*" ["//*.o", "//*.hi"] x then (x -<.> "o"):l else l)
[] (fromMaybe [] $ M.lookup k m)])) [] (M.keys m)
ofiles = L.concat [
[normalise $ "./build/c/" </> c -<.> "o" | c <- cFiles]
, [normalise $ "./build/ads/" </> c -<.> "o" | c <- adsFiles]
]
in do
need $ L.concat [[target -<.> "o"], fmap (-<.> "o") transitive, ofiles]
cabal <- liftIO $ cabalPath config
callGhc (L.concat [
[cabal]
, [pack $ normalise $ "build/c" </> c -<.> "o" | c <- cFiles]
, [pack $ normalise $ "build/ads" </> c -<.> "o" | c <- adsFiles]
, [pack $ normalise $ c -<.> "o" | c <- transitive]
, fmap pack $ catMaybes [dlltool]
]) conf False
return ()
in do
("build/runprof" <.> exe) %> \out -> do
buildDll "build/prof/" profilingMain out
"Test/Profiling/Main.hs"
"build/prof.make"
(Just "build/prof/dll.def")
("build/runtests" <.> exe) %> \out -> do
buildDll "build/testing/" testing out
"Test/KTSTests.hs"
"build/test.make"
Nothing
("ControlAPI" <.> "dll") %> \out -> do
buildDll "build/dll/" linking out
"ControlAPI.hs"
"build/maindll.make"
(Just "build/dll/dll.def")
toMaybeT :: Monad m => Maybe a -> MaybeT m a
toMaybeT Nothing = MaybeT $ return Nothing
toMaybeT (Just y) = return y
rep :: (a -> a) -> Int -> a -> a
rep f c s
| c > 0 = rep f (c - 1) (f s)
| otherwise = s
subnconfig :: [Text] -> Config -> Maybe Config
subnconfig (s:sn) c =
let sub = subconfig s c :: Either KeyError Config in
case sub of
Left msg -> Nothing
Right x -> subnconfig sn x
subnconfig [] c = Just c
cabalDir config =
do
let cabalPathExec = lookup "cabalPath" config :: Maybe String
if isJust cabalPathExec then do
(_, out, _, _) <- createProcess (shell $ fromJust cabalPathExec){std_out = CreatePipe}
cabalPathSp <- hGetContents $ fromJust out
return $ (splitOn (if os == "linux" then ":" else ";") $ pack cabalPathSp) !! 0
else throw $ ConfigurationException "No cabalPath option found in build.yml"
cabalPath config = (cabalDir config >>=
return . (\cabalPath -> intercalate " " ["-package-db", cabalPath]))
commonAncestor :: FilePath -> FilePath -> Maybe FilePath
commonAncestor a b =
if all isAbsolute [a, b] && takeDrive a == takeDrive b then
Just $ rec a b
else Nothing
where
rec a b =
if length a < length b then iter a b
else iter b a
iter a b =
if a == b then a
else rec a (takeDirectory b)
relPath :: FilePath -> FilePath -> Maybe FilePath
relPath fp base =
let fp' = normalise fp
base' = normalise base in
case commonAncestor fp' base' of
Just ca ->
let ca' = addTrailingPathSeparator ca
backtrack = take (pathcount 0 fp' - pathcount 0 ca') $ repeat ".."
keep = normalise $ drop (length ca') fp in
Just $ joinPath [normalise $ unpack (intercalate "/" backtrack), keep]
Nothing -> Nothing
where pathcount j i =
case i of
"." -> j
"/" -> j + 1
e | not (isDrive e) -> pathcount (j + 1) (takeDirectory i)
_ -> j + 1
buildMakefile :: Config -> Text -> FilePath -> FilePath -> IO (Maybe [FilePath])
buildMakefile config stage file gen = runMaybeT $ do
mstage <- toMaybeT $ subnconfig ["stages", stage] config
cur <- liftIO SDir.getCurrentDirectory
compWd <- toMaybeT (lookup "cwd" mstage) >>= return . normalise
comp <- toMaybeT $ lookup "haskell_compiler" config
outputDir <- toMaybeT $ lookup "outputdir" mstage
let args = fromMaybe "" $ lookup "args" mstage
cabal <- liftIO $ cabalPath config
relp <- toMaybeT $ relPath (joinPath [cur, normalise outputDir, normalise gen])
(joinPath [cur, compWd])
() <- lift (cmd (Cwd compWd) $ unpack $
intercalate " " $ [
comp
, cabal
, args
, "-dep-makefile", pack relp
, pack $ normaliseEx file
])
let dest = joinPath [outputDir, gen] in liftIO $ do
(readFile dest) >>=
return
. foldr (\(k, vs) lis -> filter (\x -> takeExtension x == ".hs") vs ++ lis) []
. parseMakefile
buildDependencies config ref main srcdir outdir mkName = do
cur <- liftIO $ SDir.getCurrentDirectory
let mkf = normaliseEx $ joinPath [cur, mkName]
liftIO $ do
mk <- (readFile mkf) >>= return . parseMakefile
cur <- SDir.getCurrentDirectory
m <- foldrM (\(key, values) res -> do
nkey <-
SDir.makeRelativeToCurrentDirectory $
if isRelative key then
normalise $ joinPath [cur, outdir, key]
else key
nvals <- foldrM (\v col ->
if isRelative v then
let rep pth add =
(:) <$> SDir.makeRelativeToCurrentDirectory (
(normalise $ joinPath [cur, pth, add]))
<*> pure col in
case takeExtension v of
".o" -> rep outdir v
".hi" -> rep outdir v
".hi-boot" -> rep outdir v
".hs" -> rep srcdir v
_ -> pure col
else pure col) [] values
case M.lookup nkey res of
Just exist -> return $ M.insert nkey (nvals ++ exist) res
Nothing -> return $ M.insert nkey nvals res) M.empty mk
-- Pass the makefile to all rules
writeIORef ref $ Just m
-- EOF
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.