diff options
| -rw-r--r-- | Coolbal/Cluster.hs | 3 | ||||
| -rw-r--r-- | Coolbal/DataVersionTag.hs | 22 | ||||
| -rw-r--r-- | Coolbal/EnvBinary.hs | 75 | ||||
| -rw-r--r-- | Coolbal/Log.hs | 21 | ||||
| -rw-r--r-- | Coolbal/MakeParse.hs | 52 | ||||
| -rw-r--r-- | Coolbal/Options.hs | 29 | ||||
| -rw-r--r-- | Coolbal/Process.hs | 25 | ||||
| -rw-r--r-- | Coolbal/Target.hs | 175 | ||||
| -rw-r--r-- | Coolbal/Target/Class.hs | 47 | ||||
| -rw-r--r-- | Coolbal/Target/Executable.hs | 254 | ||||
| -rw-r--r-- | Coolbal/Target/Executable/Make.hs | 48 | ||||
| -rw-r--r-- | Coolbal/Target/Utils.hs | 72 | ||||
| -rw-r--r-- | Coolbal/Verbosity.hs | 9 | ||||
| -rw-r--r-- | Main.hs | 57 | ||||
| -rw-r--r-- | coolbal.cabal | 16 |
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 @@ -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, |