summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorTom Smeding <tom@tomsmeding.com>2021-07-11 17:56:34 +0200
committerTom Smeding <tom@tomsmeding.com>2021-07-11 17:56:34 +0200
commitf57e800a1d1a8e9f2bed34428f7f58a375f178fb (patch)
tree7164b0a9bcf03703a6a7f44f5fa04e5847d876e5
parent317f1e27688a082926f39ec897f5a38d01a07ce7 (diff)
WIP splitting of Target module and towards parallel buildsHEADmaster
-rw-r--r--Coolbal/Cluster.hs3
-rw-r--r--Coolbal/DataVersionTag.hs22
-rw-r--r--Coolbal/EnvBinary.hs75
-rw-r--r--Coolbal/Log.hs21
-rw-r--r--Coolbal/MakeParse.hs52
-rw-r--r--Coolbal/Options.hs29
-rw-r--r--Coolbal/Process.hs25
-rw-r--r--Coolbal/Target.hs175
-rw-r--r--Coolbal/Target/Class.hs47
-rw-r--r--Coolbal/Target/Executable.hs254
-rw-r--r--Coolbal/Target/Executable/Make.hs48
-rw-r--r--Coolbal/Target/Utils.hs72
-rw-r--r--Coolbal/Verbosity.hs9
-rw-r--r--Main.hs57
-rw-r--r--coolbal.cabal16
15 files changed, 663 insertions, 242 deletions
diff --git a/Coolbal/Cluster.hs b/Coolbal/Cluster.hs
new file mode 100644
index 0000000..1cdc019
--- /dev/null
+++ b/Coolbal/Cluster.hs
@@ -0,0 +1,3 @@
+module Coolbal.Cluster where
+
+
diff --git a/Coolbal/DataVersionTag.hs b/Coolbal/DataVersionTag.hs
new file mode 100644
index 0000000..a994e90
--- /dev/null
+++ b/Coolbal/DataVersionTag.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+module Coolbal.DataVersionTag where
+
+import Data.Binary
+import GHC.TypeNats
+
+
+data DataVersionTag (n :: Nat) = DataVersionTag
+ deriving (Show, Eq, Ord)
+
+instance (KnownNat n, n <= 255) => Binary (DataVersionTag n) where
+ put v = putWord8 (fromIntegral (natVal v))
+ get = do
+ b <- getWord8
+ let result = DataVersionTag :: DataVersionTag n
+ if b == fromIntegral (natVal result)
+ then return result
+ else fail ("DataVersionTag: read version " ++ show b ++ ", application expects version " ++ show (natVal result))
diff --git a/Coolbal/EnvBinary.hs b/Coolbal/EnvBinary.hs
new file mode 100644
index 0000000..1e3f225
--- /dev/null
+++ b/Coolbal/EnvBinary.hs
@@ -0,0 +1,75 @@
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Coolbal.EnvBinary where
+
+import Data.Binary (get)
+import Data.Binary.Get (Get, runGet)
+import Data.Binary.Put (Put, runPut)
+import Data.ByteString.Lazy (ByteString)
+import qualified Data.ByteString.Lazy as BS
+import Data.Proxy
+import GHC.Generics
+
+
+class EnvBinary e a | a -> e where
+ envget :: e -> Get a
+ envput :: a -> Put
+
+ default envget :: (Generic a, GEnvBinary e (Rep a)) => e -> Get a
+ envget env = to <$> genvget env
+
+ default envput :: (Generic a, GEnvBinary e (Rep a)) => a -> Put
+ envput = genvput (Proxy @e) . from
+
+instance EnvBinary e a => EnvBinary e [a] where
+ envget env = get >>= getMany id
+ where
+ getMany :: ([a] -> [a]) -> Int -> Get [a]
+ getMany build 0 = return (build [])
+ getMany build i = do
+ x <- envget env
+ x `seq` getMany ((x:) . build) (i-1)
+
+ envput = undefined
+
+encode :: EnvBinary e a => a -> ByteString
+encode = runPut . envput
+
+decode :: EnvBinary e a => e -> ByteString -> a
+decode env = runGet (envget env)
+
+encodeFile :: EnvBinary e a => FilePath -> a -> IO ()
+encodeFile f = BS.writeFile f . encode
+
+-- TODO: This is inefficient! See the actual implementation of decodeFile in 'Data.Binary'.
+decodeFile :: EnvBinary e a => e -> FilePath -> IO a
+decodeFile env f = decode env <$> BS.readFile f
+
+-- TODO: This can very well be implemented for :+: but I just haven't done that
+-- yet. Perhaps to do something cool where an n-way disjunction uses only
+-- log2(n) bits to encode the choice.
+class GEnvBinary e r where
+ genvget :: e -> Get (r x)
+ genvput :: proxy e -> r x -> Put
+
+instance GEnvBinary e c => GEnvBinary e (D1 meta c) where
+ genvget e = M1 <$> genvget e
+ genvput pr = genvput pr . unM1
+
+instance GEnvBinary e s => GEnvBinary e (C1 meta s) where
+ genvget e = M1 <$> genvget e
+ genvput pr = genvput pr . unM1
+
+instance GEnvBinary e f => GEnvBinary e (S1 meta f) where
+ genvget e = M1 <$> genvget e
+ genvput pr = genvput pr . unM1
+
+instance EnvBinary e t => GEnvBinary e (Rec0 t) where
+ genvget e = K1 <$> envget e
+ genvput _ = envput . unK1
diff --git a/Coolbal/Log.hs b/Coolbal/Log.hs
new file mode 100644
index 0000000..d09ad7b
--- /dev/null
+++ b/Coolbal/Log.hs
@@ -0,0 +1,21 @@
+module Coolbal.Log (
+ logw,
+ logVerbose,
+) where
+
+import System.IO (hPutStrLn, stderr)
+
+import Coolbal.Options
+
+
+logw :: Flags -> Verbosity -> String -> String -> IO ()
+logw Flags{fVerbosity=verb} level key line
+ | verb >= level = doLog key line
+ | otherwise = return ()
+
+logVerbose :: Flags -> String -> String -> IO ()
+logVerbose flags key line = logw flags Verbose key line
+
+doLog :: String -> String -> IO ()
+doLog key line =
+ hPutStrLn stderr ("[coolbal:" ++ key ++ "] " ++ line)
diff --git a/Coolbal/MakeParse.hs b/Coolbal/MakeParse.hs
new file mode 100644
index 0000000..efe75e1
--- /dev/null
+++ b/Coolbal/MakeParse.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ViewPatterns #-}
+module Coolbal.MakeParse (
+ parseGHCmake,
+) where
+
+import Data.Char (isSpace)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Maybe (catMaybes)
+import System.FilePath ((</>), makeRelative, takeExtension, dropExtension)
+
+
+-- | Parse output of @ghc -M@ to give a module dependency graph.
+-- @projdir@ should be the canonical path of the project root directory;
+-- @builddir@ should be a relative path from @projdir@ to the build directory.
+parseGHCmake :: FilePath -> FilePath -> String -> Either String (Map [String] [[String]])
+parseGHCmake projdir builddir output = do
+ rules <- sequence (catMaybes (map (parseRule projdir builddir) (lines output)))
+ return (Map.fromListWith (++) (map (\case Node k -> (k, []) ; Rule k v -> (k, [v])) rules))
+
+data Rule = Node [String] | Rule [String] [String]
+ deriving (Show)
+
+parseRule :: FilePath -> FilePath -> String -> Maybe (Either String Rule)
+parseRule _ _ ('#' : _) = Nothing
+parseRule projdir builddir line =
+ case splitOn1 ':' line of
+ Just (lhs, rhs) ->
+ let lhs' = dropWhile (== '/') (makeRelative (projdir </> builddir) (strip lhs))
+ rhs' = makeRelative builddir (strip rhs)
+ in case takeExtension rhs' of
+ ".hi" -> Just (Right (Rule (toModule lhs') (toModule rhs')))
+ ".hs" -> Just (Right (Node (toModule lhs')))
+ _ -> errmsg
+ _ -> errmsg
+ where
+ errmsg = Just (Left ("Cannot parse -M line: " ++ show line))
+ toModule = splitOn '/' . dropExtension
+
+strip :: String -> String
+strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse
+
+splitOn1 :: Eq a => a -> [a] -> Maybe ([a], [a])
+splitOn1 x xs = case span (/= x) xs of
+ (pre, _ : post) -> Just (pre, post)
+ _ -> Nothing
+
+splitOn :: Eq a => a -> [a] -> [[a]]
+splitOn x xs = case span (/= x) xs of
+ (pre, _ : post) -> pre : splitOn x post
+ (pre, []) -> [pre]
diff --git a/Coolbal/Options.hs b/Coolbal/Options.hs
index 7901386..bd3fdd3 100644
--- a/Coolbal/Options.hs
+++ b/Coolbal/Options.hs
@@ -1,14 +1,29 @@
module Coolbal.Options (
Options(..),
+ Flags(..),
+ Command(..),
BuildOptions(..),
RunOptions(..),
optionParser,
+
+ -- * Re-exports
+ Verbosity(..),
) where
import Options.Applicative
+import Coolbal.Verbosity
+
+
+data Options = Options Flags Command
+ deriving (Show)
+
+data Flags = Flags
+ { fVerbosity :: Verbosity
+ }
+ deriving (Show)
-data Options
+data Command
= Build BuildOptions
| Rebuild BuildOptions
| Clean
@@ -35,7 +50,17 @@ optionParser =
\result.")
root :: Parser Options
-root =
+root = Options <$> parseFlags <*> parseCommand
+
+parseFlags :: Parser Flags
+parseFlags = Flags
+ <$> intToVerbosity . length <$> many
+ (flag' () (long "verbose"
+ <> short 'v'
+ <> help "Verbosity (pass multiple times to increase level)"))
+
+parseCommand :: Parser Command
+parseCommand =
hsubparser (
command "build" (info (Build <$> buildOptions)
(progDesc "Build the project"))
diff --git a/Coolbal/Process.hs b/Coolbal/Process.hs
new file mode 100644
index 0000000..8b4576c
--- /dev/null
+++ b/Coolbal/Process.hs
@@ -0,0 +1,25 @@
+module Coolbal.Process where
+
+import System.Exit (ExitCode(..))
+import System.Process
+import System.IO (hGetContents)
+
+import Coolbal.Log
+import Coolbal.Options
+
+
+runCommand :: Flags -> String -> [String] -> IO ExitCode
+runCommand flags cmd args = do
+ logVerbose flags "cmd" $ "Running command: " ++ showCommandForUser cmd args
+ (_, _, _, ph) <- createProcess (proc cmd args)
+ waitForProcess ph
+
+readCommand :: Flags -> String -> [String] -> IO (Either ExitCode String)
+readCommand flags cmd args = do
+ logVerbose flags "cmd" $ "Running command: " ++ showCommandForUser cmd args
+ (_, Just handle, _, ph) <- createProcess (proc cmd args) { std_out = CreatePipe }
+ output <- hGetContents handle
+ code <- waitForProcess ph
+ case code of
+ ExitSuccess -> return (Right output)
+ ExitFailure _ -> return (Left code)
diff --git a/Coolbal/Target.hs b/Coolbal/Target.hs
index 68ac043..ae938fd 100644
--- a/Coolbal/Target.hs
+++ b/Coolbal/Target.hs
@@ -1,185 +1,24 @@
+{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
module Coolbal.Target (
- IsTarget(..),
AnyTarget(..),
- ExeTarget(..),
useAnyTarget,
) where
-import Data.Binary (Binary)
-import Data.Char (ord)
-import Data.List (intercalate)
-import Data.Time.Clock (UTCTime)
import GHC.Generics (Generic)
-import Numeric (showHex)
-import System.Directory (createDirectoryIfMissing, doesFileExist, getModificationTime, removeDirectoryRecursive)
-import System.Exit (ExitCode(..), die, exitWith)
-import System.FilePath ((</>))
-import System.IO.Error (catchIOError)
-import System.Process (rawSystem)
-import Coolbal.Util
+import Coolbal.EnvBinary
+import Coolbal.Target.Class
+import Coolbal.Target.Executable
-class IsTarget a where
- -- | The name of the target.
- targetName :: a -> String
-
- -- | The name of the target, qualified with a cabal-style prefix indicating the kind of target.
- targetNameQualified :: a -> String
-
- -- | The name of the target, qualified with a cabal-style prefix indicating
- -- the kind of target, except that the ':' is rendered as a '-'.
- targetNameQualifiedFilename :: a -> FilePath
- targetNameQualifiedFilename tg = case break (== ':') (targetNameQualified tg) of
- (pre, ':' : post) -> pre ++ '-' : post
- _ -> error "targetNameQualifiedFilename: unexpected form of targetNameQualified"
-
- -- | Check whether the target must be recompiled due to changes on disk.
- -- Argument is the root directory of the project.
- targetCheckOld :: FilePath -> a -> IO Bool
-
- -- | Recompile the target. Argument is the root directory of the project.
- targetBuild :: FilePath -> a -> IO ()
-
- -- | If the target is an executable target, return an IO action that runs
- -- the executable with the specified arguments. The 'FilePath' is the root
- -- directory of the project.
- targetExecute :: a -> Maybe (FilePath -> [String] -> IO ())
-
- -- | Remove the build artifacts for this target.
- targetRemoveBuildArtifacts :: FilePath -> a -> IO ()
-
data AnyTarget = AnyTargetExe ExeTarget
deriving (Show, Generic)
-instance Binary AnyTarget
+instance EnvBinary RestoreEnv AnyTarget
-useAnyTarget :: (forall a. (Show a, Binary a, IsTarget a) => a -> r) -> AnyTarget -> r
+useAnyTarget :: (forall a. (Show a, IsTarget a) => a -> r) -> AnyTarget -> r
useAnyTarget f (AnyTargetExe x) = f x
-
-data ExeTarget = ExeTarget
- { exeTargetName :: String
- -- ^ Target name, and name of output executable file
- , exeTargetPkgDbDir :: FilePath
- -- ^ Absolute path to the package.db directory
- , exeTargetDeps :: [String]
- -- ^ Package identifiers of dependencies (for -package-id flags)
- , exeTargetLanguage :: String
- -- ^ Haskell language (e.g. Haskell2010)
- , exeTargetMain :: FilePath
- -- ^ Main file
- , exeTargetSrcDirs :: [FilePath]
- -- ^ Source directories
- , exeTargetModules :: [[String]]
- -- ^ Other modules in the target
- , exeTargetFlags :: [String]
- -- ^ User-specified compiler flags
- }
- deriving (Show, Generic)
-
-instance Binary ExeTarget
-
-instance IsTarget ExeTarget where
- targetName = exeTargetName
- targetNameQualified e = "exe:" ++ targetName e
-
- targetCheckOld projdir tg = do
- mbinTm <- maybeModificationTime (projdir </> "dist-coolbal/bin" </> escapeFileName (exeTargetName tg))
- case mbinTm of
- Just binTm -> do
- anyNewerThan binTm (findFile' (exeTargetSrcDirs tg) (exeTargetMain tg)
- : [findSourceFile' (exeTargetSrcDirs tg) m | m <- exeTargetModules tg])
- Nothing ->
- return True
-
- targetBuild projdir tg = do
- let buildDir = projdir </> "dist-coolbal/build"
- </> escapeFileName (targetNameQualifiedFilename tg)
- binDir = projdir </> "dist-coolbal/bin"
- binName = binDir </> escapeFileName (exeTargetName tg)
- createDirectoryIfMissing True binDir
- rawSystem "ghc" (concat
- [["--make", "-static"]
- ,concat [[flag, buildDir]
- | flag <- ["-outputdir", "-odir", "-hidir", "-stubdir"]]
- ,["-i" ++ dir | dir <- exeTargetSrcDirs tg]
- ,["-hide-all-packages", "-Wmissing-home-modules", "-no-user-package-db"]
- ,["-package-db", exeTargetPkgDbDir tg]
- ,concat [["-package-id", dep] | dep <- exeTargetDeps tg]
- ,["-X" ++ exeTargetLanguage tg]
- ,[exeTargetMain tg]
- ,map (intercalate ".") (exeTargetModules tg)
- ,["-o", binName]
- ,exeTargetFlags tg])
- >>= checkExitCode
-
- targetExecute tg = Just $ \projdir args -> do
- let filename = escapeFileName (exeTargetName tg)
- rawSystem (projdir </> "dist-coolbal/bin" </> filename) args
- >>= exitWith
-
- targetRemoveBuildArtifacts projdir tg =
- removeDirectoryRecursive
- (projdir </> "dist-coolbal/build"
- </> escapeFileName (targetNameQualifiedFilename tg))
-
-checkExitCode :: ExitCode -> IO ()
-checkExitCode ExitSuccess = return ()
-checkExitCode c@(ExitFailure _) = exitWith c
-
-escapeFileName :: String -> FilePath
-escapeFileName =
- -- NTFS/POSIX not allows: 0x00-0x1F 0x7F- : / " * < > ? \ |
- -- We use ! as an escape character, and hence disallow that too.
- genericEscapeString
- (\c -> let n = ord c
- in n <= 0x1F || n >= 0x7F || c `elem` ":/\"*<>?\\|!")
- (\c -> case (c, ord c) of
- ('!', _) -> "!!"
- (_, n) | n <= 0xFF -> '!' : leftPad 2 '0' (showHex n "")
- | n <= 0xFFFF -> '!' : 'u' : leftPad 4 '0' (showHex n "")
- | n <= 0xFFFFFF -> '!' : 'U' : leftPad 6 '0' (showHex n "")
- | otherwise -> error "Super-high unicode?")
- where
- leftPad n c s = replicate (max 0 (n - length s)) c ++ s
-
-maybeModificationTime' :: FilePath -> IO UTCTime
-maybeModificationTime' path = maybeModificationTime path >>= \case
- Just tm -> return tm
- Nothing -> die ("File not found: '" ++ path ++ "'")
-
-maybeModificationTime :: FilePath -> IO (Maybe UTCTime)
-maybeModificationTime path =
- catchIOError (Just <$> getModificationTime path) (\_ -> return Nothing)
-
-findSourceFile' :: [FilePath] -> [String] -> IO FilePath
-findSourceFile' ds m = findSourceFile ds m >>= \case
- Just fp -> return fp
- Nothing -> die ("Module not found in source directories: " ++ intercalate "." m)
-
-findSourceFile :: [FilePath] -> [String] -> IO (Maybe FilePath)
-findSourceFile dirs modname = findFile dirs (foldr (</>) "" modname ++ ".hs")
-
-findFile' :: [FilePath] -> FilePath -> IO FilePath
-findFile' ds fname = findFile ds fname >>= \case
- Just fp -> return fp
- Nothing -> die ("File not found in source directories: '" ++ fname ++ "'")
-
-findFile :: [FilePath] -> FilePath -> IO (Maybe FilePath)
-findFile [] _ = return Nothing
-findFile (dir:ds) fname = do
- ok <- doesFileExist (dir </> fname)
- if ok then return (Just (dir </> fname))
- else findFile ds fname
-
-anyNewerThan :: UTCTime -> [IO FilePath] -> IO Bool
-anyNewerThan _ [] = return False
-anyNewerThan reftm (fp:fps) = do
- fp' <- fp
- tm <- maybeModificationTime' fp'
- if tm > reftm
- then return True
- else anyNewerThan reftm fps
diff --git a/Coolbal/Target/Class.hs b/Coolbal/Target/Class.hs
new file mode 100644
index 0000000..ea966d6
--- /dev/null
+++ b/Coolbal/Target/Class.hs
@@ -0,0 +1,47 @@
+module Coolbal.Target.Class where
+
+import Coolbal.Options (Flags)
+
+
+class IsTarget a where
+ -- | The name of the target.
+ targetName :: a -> String
+
+ -- | The cabal-style prefix indicating the kind of target (e.g. 'exe' for an executable target).
+ targetPrefix :: a -> String
+
+ -- | The name of the target, qualified with a cabal-style prefix indicating the kind of target.
+ targetNameQualified :: a -> String
+ targetNameQualified tg = buildQualifiedName (targetPrefix tg) (targetName tg)
+
+ -- | The name of the target, qualified with a cabal-style prefix indicating
+ -- the kind of target, except that the ':' is rendered as a '-'.
+ targetNameQualifiedFilename :: a -> FilePath
+ targetNameQualifiedFilename = qualifiedToQualifiedFilename . targetNameQualified
+
+ -- | Check whether the target must be recompiled due to changes on disk.
+ -- Argument is the root directory of the project.
+ targetCheckOld :: FilePath -> a -> IO Bool
+
+ -- | Recompile the target.
+ targetBuild :: Flags -> a -> IO ()
+
+ -- | If the target is an executable target, return an IO action that runs
+ -- the executable with the specified arguments. The 'FilePath' is the root
+ -- directory of the project.
+ targetExecute :: Flags -> a -> Maybe ([String] -> IO ())
+
+ -- | Remove the build artifacts for this target.
+ targetRemoveBuildArtifacts :: FilePath -> a -> IO ()
+
+data RestoreEnv = RestoreEnv
+ { reProjDir :: FilePath }
+
+qualifiedToQualifiedFilename :: String -> FilePath
+qualifiedToQualifiedFilename qual =
+ case break (== ':') qual of
+ (pre, ':' : post) -> pre ++ '-' : post
+ _ -> error "qualifiedToQualifiedFilename: unexpected form of targetNameQualified"
+
+buildQualifiedName :: String -> String -> String
+buildQualifiedName prefix name = prefix ++ ":" ++ name
diff --git a/Coolbal/Target/Executable.hs b/Coolbal/Target/Executable.hs
index 725b057..0f856c6 100644
--- a/Coolbal/Target/Executable.hs
+++ b/Coolbal/Target/Executable.hs
@@ -1,42 +1,212 @@
-module Coolbal.Target.Executable (makeExeTarget) where
-
-import Data.List (find)
-import Distribution.Compiler (perCompilerFlavorToList, CompilerFlavor(GHC))
-import qualified Distribution.ModuleName as Module
-import Distribution.Types.BuildInfo (BuildInfo(..))
-import Distribution.Types.Executable (Executable(..))
-import Distribution.Types.ExecutableScope (ExecutableScope(ExecutablePublic))
-import Distribution.Types.UnqualComponentName (unUnqualComponentName)
-import Language.Haskell.Extension (knownLanguages)
-
-import Coolbal.CabalPlan
-import Coolbal.Directory
-import Coolbal.Target
-
-
-makeExeTarget :: Executable -> CabalPlan -> Maybe ExeTarget
-makeExeTarget exe plan
- | exeScope exe == ExecutablePublic
- , let bi = buildInfo exe
- , buildable bi
- , all (null . ($ bi)) [asmSources, cmmSources, cSources, cxxSources, jsSources]
- , all (null . ($ bi)) [virtualModules, autogenModules]
- , null (defaultExtensions bi)
- , all (null . ($ bi)) [extraLibs, extraBundledLibs]
- , let name = unUnqualComponentName (exeName exe)
- , Just planpkg@Configured{} <- find ((== name) . ppName) (planPackages plan)
- , Just language <- defaultLanguage bi
- , True <- language `elem` knownLanguages
- , Just flags <- lookup GHC (perCompilerFlavorToList (options bi))
- , Just deps <- ppDepends planpkg
- = Just (ExeTarget
- { exeTargetName = unUnqualComponentName (exeName exe)
- , exeTargetPkgDbDir = currentHomeDirectory ++ "/.cabal/store/" ++ planCompiler plan ++ "/package.db"
- , exeTargetDeps = deps
- , exeTargetLanguage = show language
- , exeTargetMain = modulePath exe
- , exeTargetSrcDirs = hsSourceDirs bi
- , exeTargetModules = map Module.components (otherModules bi)
- , exeTargetFlags = flags
- })
- | otherwise = Nothing
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+module Coolbal.Target.Executable where
+
+import Control.DeepSeq (deepseq)
+import Data.Binary
+import Data.List (intercalate)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import GHC.Generics (Generic)
+import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
+import System.Exit (die, exitWith)
+import System.FilePath ((</>), makeRelative)
+import System.IO.Error (catchIOError)
+import System.IO.Temp
+
+import Coolbal.Options (Flags)
+import Coolbal.DataVersionTag
+import Coolbal.EnvBinary
+import Coolbal.Log
+import Coolbal.MakeParse
+import Coolbal.Process
+import Coolbal.Target.Class
+import Coolbal.Target.Utils
+
+
+data ExeTarget = ExeTarget
+ { etName :: String
+ -- ^ Target name, and name of output executable file
+ , etPkgDbDir :: FilePath
+ -- ^ Absolute path to the package.db directory
+ , etDeps :: [String]
+ -- ^ Package identifiers of dependencies (for -package-id flags)
+ , etLanguage :: String
+ -- ^ Haskell language (e.g. Haskell2010)
+ , etMain :: FilePath
+ -- ^ Main file
+ , etSrcDirs :: [FilePath]
+ -- ^ Source directories
+ , etFlags :: [String]
+ -- ^ User-specified compiler flags
+ , etModGraph :: Map [String] [[String]]
+ -- ^ Dependency graph of other modules in the target
+
+ , etModules :: [[String]]
+ -- ^ List of other modules in the target
+ , etProjDir :: FilePath
+ -- ^ Project root directory (absolute path)
+ , etBuildDir :: FilePath
+ -- ^ Build directory (absolute path)
+ , etBinDir :: FilePath
+ -- ^ Binary target directory (absolute path)
+ , etBinFile :: FilePath
+ -- ^ Target executable file path (absolute path)
+ , etBaseFlags :: [String]
+ -- ^ Base flags for GHC (excluding --make, module/file list, -c/-o)
+ }
+ deriving (Show)
+
+data ExeTargetStore' mods = ExeTargetStore
+ { _etsVersionTag :: DataVersionTag 1
+ , etsName :: String
+ -- ^ Target name, and name of output executable file
+ , etsPkgDbDir :: FilePath
+ -- ^ Absolute path to the package.db directory
+ , etsDeps :: [String]
+ -- ^ Package identifiers of dependencies (for -package-id flags)
+ , etsLanguage :: String
+ -- ^ Haskell language (e.g. Haskell2010)
+ , etsMain :: FilePath
+ -- ^ Main file
+ , etsSrcDirs :: [FilePath]
+ -- ^ Source directories
+ , etsFlags :: [String]
+ -- ^ User-specified compiler flags
+ , etsModules :: mods
+ -- ^ Dependency graph of other modules in the target
+ }
+
+type ExeTargetStorePre = ExeTargetStore' [[String]]
+type ExeTargetStore = ExeTargetStore' (Map [String] [[String]])
+
+deriving instance Generic ExeTargetStore
+
+instance Binary ExeTargetStore
+
+instance EnvBinary RestoreEnv ExeTarget where
+ envget renv = elaborateExeTarget renv <$> get
+ envput = put . unelabExeTarget
+
+elaborateExeTargetWithEBS :: ExeBuildSetup -> ExeTargetStore -> ExeTarget
+elaborateExeTargetWithEBS ebs tg = ExeTarget
+ { etName = etsName tg
+ , etPkgDbDir = etsPkgDbDir tg
+ , etDeps = etsDeps tg
+ , etLanguage = etsLanguage tg
+ , etMain = etsMain tg
+ , etSrcDirs = etsSrcDirs tg
+ , etFlags = etsFlags tg
+ , etModGraph = etsModules tg
+
+ , etModules = Map.keys (etsModules tg)
+ , etProjDir = ebsProjDir ebs
+ , etBuildDir = ebsBuildDir ebs
+ , etBinDir = ebsBinDir ebs
+ , etBinFile = ebsBinFile ebs
+ , etBaseFlags = ebsBaseFlags ebs
+ }
+
+elaborateExeTarget :: RestoreEnv -> ExeTargetStore -> ExeTarget
+elaborateExeTarget RestoreEnv{reProjDir=projdir} tg =
+ let ebs = exeBuildSetup projdir (tg { etsModules = Map.keys (etsModules tg) })
+ in elaborateExeTargetWithEBS ebs tg
+
+unelabExeTarget :: ExeTarget -> ExeTargetStore
+unelabExeTarget tg = ExeTargetStore
+ { _etsVersionTag = DataVersionTag
+ , etsName = etName tg
+ , etsPkgDbDir = etPkgDbDir tg
+ , etsDeps = etDeps tg
+ , etsLanguage = etLanguage tg
+ , etsMain = etMain tg
+ , etsSrcDirs = etSrcDirs tg
+ , etsFlags = etFlags tg
+ , etsModules = etModGraph tg
+ }
+
+instance IsTarget ExeTarget where
+ targetName = etName
+ targetPrefix _ = "exe"
+
+ targetCheckOld projdir tg = do
+ mbinTm <- maybeModificationTime (projdir </> "dist-coolbal/bin" </> escapeFileName (etName tg))
+ case mbinTm of
+ Just binTm -> do
+ anyNewerThan binTm (findFile' (etSrcDirs tg) (etMain tg)
+ : [findSourceFile' (etSrcDirs tg) m | m <- etModules tg])
+ Nothing ->
+ return True
+
+ targetBuild flags tg = do
+ createDirectoryIfMissing True (etBinDir tg)
+ -- To build only a single module instead of the whole executable: remove etMain and add only the right module of etModules; add -c; remove -o.
+ runCommand flags "ghc" (concat
+ [["--make"]
+ ,etBaseFlags tg
+ ,[etMain tg]
+ ,map (intercalate ".") (etModules tg)
+ ,["-o", etBinFile tg]])
+ >>= checkExitCode
+
+ targetExecute flags tg = Just $ \args -> do
+ let filename = escapeFileName (etName tg)
+ runCommand flags (etProjDir tg </> "dist-coolbal/bin" </> filename) args
+ >>= exitWith
+
+ targetRemoveBuildArtifacts projdir tg =
+ removeDirectoryRecursive
+ (projdir </> "dist-coolbal/build"
+ </> escapeFileName (targetNameQualifiedFilename tg))
+ `catchIOError` (\_ -> return ())
+
+data ExeBuildSetup = ExeBuildSetup
+ { ebsProjDir :: FilePath
+ , ebsBuildDir :: FilePath
+ , ebsBinDir :: FilePath
+ , ebsBinFile :: FilePath
+ , ebsBaseFlags :: [String]
+ }
+
+exeBuildSetup :: FilePath -> ExeTargetStorePre -> ExeBuildSetup
+exeBuildSetup projdir tg =
+ let buildDir = projdir </> "dist-coolbal/build"
+ </> escapeFileName (buildQualifiedName "exe" (etsName tg))
+ binDir = projdir </> "dist-coolbal/bin"
+ in ExeBuildSetup
+ { ebsProjDir = projdir
+ , ebsBuildDir = buildDir
+ , ebsBinDir = binDir
+ , ebsBinFile = binDir </> escapeFileName (etsName tg)
+ , ebsBaseFlags = concat
+ [["-static"]
+ ,concat [[flag, buildDir]
+ | flag <- ["-outputdir", "-odir", "-hidir", "-stubdir"]]
+ ,["-i" ++ dir | dir <- etsSrcDirs tg]
+ ,["-hide-all-packages", "-Wmissing-home-modules", "-no-user-package-db"]
+ ,["-package-db", etsPkgDbDir tg]
+ ,concat [["-package-id", dep] | dep <- etsDeps tg]
+ ,["-X" ++ etsLanguage tg]
+ ,etsFlags tg]
+ }
+
+exeDepGraph :: Flags -> ExeTargetStorePre -> ExeBuildSetup -> IO (Map [String] [[String]])
+exeDepGraph flags tg ebs = do
+ output <- withSystemTempDirectory "coolbal-make" $ \tmpdir -> do
+ let fname = tmpdir </> "Makefile"
+ runCommand flags "ghc" (concat
+ [ebsBaseFlags ebs
+ ,[etsMain tg]
+ ,map (intercalate ".") (etsModules tg)
+ ,["-M", "-dep-suffix", "", "-dep-makefile", fname]])
+ >>= checkExitCode
+ output <- readFile fname
+ output `deepseq` return output
+ case parseGHCmake (ebsProjDir ebs) (makeRelative (ebsProjDir ebs) (ebsBuildDir ebs)) output of
+ Left err -> die err
+ Right m -> logVerbose flags "depgraph:graph" (show m) >> return m
diff --git a/Coolbal/Target/Executable/Make.hs b/Coolbal/Target/Executable/Make.hs
new file mode 100644
index 0000000..5bbb80e
--- /dev/null
+++ b/Coolbal/Target/Executable/Make.hs
@@ -0,0 +1,48 @@
+module Coolbal.Target.Executable.Make (makeExeTarget) where
+
+import Data.List (find)
+import Distribution.Compiler (perCompilerFlavorToList, CompilerFlavor(GHC))
+import qualified Distribution.ModuleName as Module
+import Distribution.Types.BuildInfo (BuildInfo(..))
+import Distribution.Types.Executable (Executable(..))
+import Distribution.Types.ExecutableScope (ExecutableScope(ExecutablePublic))
+import Distribution.Types.UnqualComponentName (unUnqualComponentName)
+import Language.Haskell.Extension (knownLanguages)
+
+import Coolbal.CabalPlan
+import Coolbal.DataVersionTag
+import Coolbal.Directory
+import Coolbal.Options (Flags)
+import Coolbal.Target.Executable
+
+
+makeExeTarget :: Flags -> FilePath -> Executable -> CabalPlan -> IO (Maybe ExeTarget)
+makeExeTarget flags projdir exe plan
+ | exeScope exe == ExecutablePublic
+ , let bi = buildInfo exe
+ , buildable bi
+ , all (null . ($ bi)) [asmSources, cmmSources, cSources, cxxSources, jsSources]
+ , all (null . ($ bi)) [virtualModules, autogenModules]
+ , null (defaultExtensions bi)
+ , all (null . ($ bi)) [extraLibs, extraBundledLibs]
+ , let name = unUnqualComponentName (exeName exe)
+ , Just planpkg <- find ((== name) . ppName) (planPackages plan)
+ , Just language <- defaultLanguage bi
+ , True <- language `elem` knownLanguages
+ , Just ghcFlags <- lookup GHC (perCompilerFlavorToList (options bi))
+ , Just deps <- ppDepends planpkg
+ = do let ets = ExeTargetStore
+ { _etsVersionTag = DataVersionTag
+ , etsName = unUnqualComponentName (exeName exe)
+ , etsPkgDbDir = currentHomeDirectory ++ "/.cabal/store/" ++ planCompiler plan ++ "/package.db"
+ , etsDeps = deps
+ , etsLanguage = show language
+ , etsMain = modulePath exe
+ , etsSrcDirs = hsSourceDirs bi
+ , etsModules = map Module.components (otherModules bi)
+ , etsFlags = ghcFlags
+ }
+ ebs = exeBuildSetup projdir ets
+ depgraph <- exeDepGraph flags ets ebs
+ return (Just (elaborateExeTargetWithEBS ebs (ets { etsModules = depgraph })))
+ | otherwise = return Nothing
diff --git a/Coolbal/Target/Utils.hs b/Coolbal/Target/Utils.hs
new file mode 100644
index 0000000..432a8a8
--- /dev/null
+++ b/Coolbal/Target/Utils.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE LambdaCase #-}
+module Coolbal.Target.Utils where
+
+import Data.Char (ord)
+import Data.List (intercalate)
+import Data.Time.Clock (UTCTime)
+import Numeric (showHex)
+import System.Directory (doesFileExist, getModificationTime)
+import System.Exit (ExitCode(..), die, exitWith)
+import System.FilePath ((</>))
+import System.IO.Error (catchIOError)
+
+import Coolbal.Util
+
+
+checkExitCode :: ExitCode -> IO ()
+checkExitCode ExitSuccess = return ()
+checkExitCode c@(ExitFailure _) = exitWith c
+
+escapeFileName :: String -> FilePath
+escapeFileName =
+ -- NTFS/POSIX not allows: 0x00-0x1F 0x7F- : / " * < > ? \ |
+ -- We use ! as an escape character, and hence disallow that too.
+ genericEscapeString
+ (\c -> let n = ord c
+ in n <= 0x1F || n >= 0x7F || c `elem` ":/\"*<>?\\|!")
+ (\c -> case (c, ord c) of
+ ('!', _) -> "!!"
+ (_, n) | n <= 0xFF -> '!' : leftPad 2 '0' (showHex n "")
+ | n <= 0xFFFF -> '!' : 'u' : leftPad 4 '0' (showHex n "")
+ | n <= 0xFFFFFF -> '!' : 'U' : leftPad 6 '0' (showHex n "")
+ | otherwise -> error "Super-high unicode?")
+ where
+ leftPad n c s = replicate (max 0 (n - length s)) c ++ s
+
+maybeModificationTime' :: FilePath -> IO UTCTime
+maybeModificationTime' path = maybeModificationTime path >>= \case
+ Just tm -> return tm
+ Nothing -> die ("File not found: '" ++ path ++ "'")
+
+maybeModificationTime :: FilePath -> IO (Maybe UTCTime)
+maybeModificationTime path =
+ catchIOError (Just <$> getModificationTime path) (\_ -> return Nothing)
+
+findSourceFile' :: [FilePath] -> [String] -> IO FilePath
+findSourceFile' ds m = findSourceFile ds m >>= \case
+ Just fp -> return fp
+ Nothing -> die ("Module not found in source directories: " ++ intercalate "." m)
+
+findSourceFile :: [FilePath] -> [String] -> IO (Maybe FilePath)
+findSourceFile dirs modname = findFile dirs (foldr (</>) "" modname ++ ".hs")
+
+findFile' :: [FilePath] -> FilePath -> IO FilePath
+findFile' ds fname = findFile ds fname >>= \case
+ Just fp -> return fp
+ Nothing -> die ("File not found in source directories: '" ++ fname ++ "'")
+
+findFile :: [FilePath] -> FilePath -> IO (Maybe FilePath)
+findFile [] _ = return Nothing
+findFile (dir:ds) fname = do
+ ok <- doesFileExist (dir </> fname)
+ if ok then return (Just (dir </> fname))
+ else findFile ds fname
+
+anyNewerThan :: UTCTime -> [IO FilePath] -> IO Bool
+anyNewerThan _ [] = return False
+anyNewerThan reftm (fp:fps) = do
+ fp' <- fp
+ tm <- maybeModificationTime' fp'
+ if tm > reftm
+ then return True
+ else anyNewerThan reftm fps
diff --git a/Coolbal/Verbosity.hs b/Coolbal/Verbosity.hs
new file mode 100644
index 0000000..e9b6cac
--- /dev/null
+++ b/Coolbal/Verbosity.hs
@@ -0,0 +1,9 @@
+module Coolbal.Verbosity where
+
+
+data Verbosity = Quiet | Verbose
+ deriving (Show, Eq, Ord)
+
+intToVerbosity :: Int -> Verbosity
+intToVerbosity n | n <= 0 = Quiet
+intToVerbosity _ = Verbose
diff --git a/Main.hs b/Main.hs
index 463a33b..3d2cf7a 100644
--- a/Main.hs
+++ b/Main.hs
@@ -2,7 +2,6 @@
module Main where
import Control.Monad (forM_, when)
-import qualified Data.Binary as B
import Data.Function (on)
import Data.List (intercalate, groupBy, sortBy)
import Data.Maybe (catMaybes, fromJust, isJust)
@@ -18,10 +17,12 @@ import System.IO (hPutStrLn, stderr)
import Coolbal.CabalPlan
import Coolbal.Configure (configure)
+import qualified Coolbal.EnvBinary as B
import Coolbal.FindRoot
import Coolbal.Options
import Coolbal.Target
-import Coolbal.Target.Executable (makeExeTarget)
+import Coolbal.Target.Class
+import Coolbal.Target.Executable.Make (makeExeTarget)
checkCompatibleSpec :: PackageDescription -> IO ()
@@ -30,21 +31,21 @@ checkCompatibleSpec pd
| not (null (PD.setupBuildInfo pd)) = die "Custom setup build info unsupported"
| otherwise = return ()
-compatibleTargets :: PackageDescription -> CabalPlan -> [AnyTarget]
-compatibleTargets pd plan =
- catMaybes (map (\e -> AnyTargetExe <$> makeExeTarget e plan) (PD.executables pd))
+compatibleTargets :: Flags -> FilePath -> PackageDescription -> CabalPlan -> IO [AnyTarget]
+compatibleTargets flags projdir pd plan =
+ catMaybes <$> mapM (\e -> fmap AnyTargetExe <$> makeExeTarget flags projdir e plan) (PD.executables pd)
parseCabalPlan' :: FoundCabalSpec -> IO CabalPlan
parseCabalPlan' foundSpec =
parseCabalPlan (foundcsRootDir foundSpec </> "dist-newstyle/cache/plan.json")
- >>= \case NotFound -> die "Cabal plan.json not found; make sure to run 'cabal build' beforehand"
+ >>= \case NotFound -> die "Cabal plan.json not found; make sure to run 'cabal configure' beforehand"
ParseError e -> die ("Error when parsing Cabal plan.json: " ++ e)
Parsed plan -> return plan
readCachedTargets :: (AnyTarget -> Bool) -> IO (FilePath, [AnyTarget], [(String, [AnyTarget])])
readCachedTargets predicate = do
FoundRootDir rootdir <- findDist
- allTargets <- B.decodeFile (rootdir </> "dist-coolbal/targets.bin")
+ allTargets <- B.decodeFile (RestoreEnv { reProjDir = rootdir }) (rootdir </> "dist-coolbal/targets.bin")
let targets = filter predicate allTargets
targetsForName = map ((,) <$> fst . head <*> map snd)
$ groupBy ((==) `on` fst)
@@ -61,15 +62,15 @@ targetsToBuild targetsForName name =
Just [t] -> return [t]
Just _ -> die ("Ambiguous target name: '" ++ name ++ "'")
-doConfigure :: IO ()
-doConfigure = do
+doConfigure :: Flags -> IO ()
+doConfigure flags= do
foundSpec <- findCabalSpec
pd <- configure (foundcsCabal foundSpec)
checkCompatibleSpec pd
plan <- parseCabalPlan' foundSpec
-- print pd
- let targets = compatibleTargets pd plan
- names = map (useAnyTarget (\t -> targetName t ++ " (" ++ targetNameQualified t ++ ")")) targets
+ targets <- compatibleTargets flags (foundcsRootDir foundSpec) pd plan
+ let names = map (useAnyTarget (\t -> targetName t ++ " (" ++ targetNameQualified t ++ ")")) targets
hPutStrLn stderr ("Supported targets: " ++ intercalate ", " names)
createDirectoryIfMissing True (foundcsRootDir foundSpec </> "dist-coolbal")
@@ -80,32 +81,32 @@ doClean = do
foundSpec <- findCabalSpec
removeDirectoryRecursive (foundcsRootDir foundSpec </> "dist-coolbal")
-doBuild :: BuildOptions -> IO ()
-doBuild (BuildOptions mtarget) = do
+doBuild :: Flags -> BuildOptions -> IO ()
+doBuild flags (BuildOptions mtarget) = do
(rootdir, targets, targetsForName) <- readCachedTargets (const True)
toBuild <- maybe (return targets) (targetsToBuild targetsForName) mtarget
forM_ toBuild $ useAnyTarget $ \tg -> do
old <- targetCheckOld rootdir tg
- when old $ targetBuild rootdir tg
+ when old $ targetBuild flags tg
-doRebuild :: BuildOptions -> IO ()
-doRebuild (BuildOptions mtarget) = do
+doRebuild :: Flags -> BuildOptions -> IO ()
+doRebuild flags (BuildOptions mtarget) = do
(rootdir, targets, targetsForName) <- readCachedTargets (const True)
toBuild <- maybe (return targets) (targetsToBuild targetsForName) mtarget
forM_ toBuild $ useAnyTarget $ \tg -> do
targetRemoveBuildArtifacts rootdir tg
- targetBuild rootdir tg
+ targetBuild flags tg
-doRun :: RunOptions -> IO ()
-doRun (RunOptions mtarget args) = do
- (rootdir, targets, targetsForName) <- readCachedTargets (isJust . useAnyTarget targetExecute)
+doRun :: Flags -> RunOptions -> IO ()
+doRun flags (RunOptions mtarget args) = do
+ (rootdir, targets, targetsForName) <- readCachedTargets (isJust . useAnyTarget (targetExecute flags))
toBuild <- maybe (return targets) (targetsToBuild targetsForName) mtarget
case toBuild of
[tg] -> do
useAnyTarget (\tg' -> do old <- targetCheckOld rootdir tg'
- when old $ targetBuild rootdir tg'
+ when old $ targetBuild flags tg'
-- when (not old) $ putStrLn "Up to date"
- fromJust (targetExecute tg') rootdir args)
+ fromJust (targetExecute flags tg') args)
tg
_ -> do
@@ -113,10 +114,10 @@ doRun (RunOptions mtarget args) = do
main :: IO ()
main = do
- options <- execParser optionParser
- case options of
- Configure -> doConfigure
+ Options flags command <- execParser optionParser
+ case command of
+ Configure -> doConfigure flags
Clean -> doClean
- Build opts -> doBuild opts
- Rebuild opts -> doRebuild opts
- Run opts -> doRun opts
+ Build opts -> doBuild flags opts
+ Rebuild opts -> doRebuild flags opts
+ Run opts -> doRun flags opts
diff --git a/coolbal.cabal b/coolbal.cabal
index 70e6c46..954e889 100644
--- a/coolbal.cabal
+++ b/coolbal.cabal
@@ -11,13 +11,23 @@ executable coolbal
main-is: Main.hs
other-modules:
Coolbal.CabalPlan
+ Coolbal.Cluster
Coolbal.Configure
+ Coolbal.DataVersionTag
Coolbal.Directory
+ Coolbal.EnvBinary
Coolbal.FindRoot
+ Coolbal.Log
+ Coolbal.MakeParse
Coolbal.Options
+ Coolbal.Process
Coolbal.Target
+ Coolbal.Target.Class
Coolbal.Target.Executable
+ Coolbal.Target.Executable.Make
+ Coolbal.Target.Utils
Coolbal.Util
+ Coolbal.Verbosity
build-depends: base >= 4.13 && < 4.15,
Cabal >= 3.2.1.0 && < 3.3.0.0,
bytestring >= 0.10.12 && < 0.11,
@@ -29,8 +39,10 @@ executable coolbal
byteslice,
array-chunks,
optparse-applicative >= 0.16.1.0 && < 0.17,
- time
- -- containers >= 0.6.2.1 && < 0.7
+ time,
+ containers >= 0.6.2.1 && < 0.7,
+ temporary >= 1.3 && < 1.4,
+ deepseq >= 1.4.4 && < 1.5
-- mtl >= 2.2.2 && < 2.3,
-- parsec >= 3.1.14.0 && < 3.2,
-- stm >= 2.5.0.0 && < 2.6,