Haskell build

Build.hs

{-# 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