dib (empty) → 0.5.0

raw patch · 14 files changed

+1606/−0 lines, 14 filesdep +basedep +bytestringdep +cerealsetup-changed

Dependencies added: base, bytestring, cereal, containers, digest, directory, filepath, mtl, process, text, time

Files

LICENSE +20/−0
Main.hs +228/−0
Setup.hs +2/−0
dib.cabal +34/−0
src/Dib.hs +465/−0
src/Dib/Builders/C.hs +265/−0
src/Dib/Builders/Copy.hs +35/−0
src/Dib/Builders/Simple.hs +49/−0
src/Dib/Gatherers.hs +141/−0
src/Dib/Scanners/CDepScanner.hs +152/−0
src/Dib/Stage.hs +18/−0
src/Dib/Target.hs +48/−0
src/Dib/Types.hs +131/−0
src/Dib/Util.hs +18/−0

+ LICENSE view

@@ -0,0 +1,20 @@+Copyright (c) 2010-2016 Brett Lajzer++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.+

+ Main.hs view

@@ -0,0 +1,228 @@+-- Copyright (c) 2010-2016 Brett Lajzer+-- See LICENSE for license information.++-- | This is the command-line executable "dib". Since Dib proper is a+-- library, one doesn't need this, but it makes dealing with build+-- scripts quite a bit easier.+module Main where++import Paths_dib (version)+import GHC.IO.Exception+import Control.Monad+import Data.Maybe+import Data.Time.Clock.POSIX+import Data.Version (showVersion)+import System.Process (system)+import qualified System.Directory as D+import System.Environment (getArgs)+import System.FilePath as F+import System.Info+import System.IO++unixExe :: String+unixExe = ".dib/dib"++windowsExe :: String+windowsExe = ".dib/dib.exe"++correctExe :: String+correctExe = if os == "mingw32" then windowsExe else unixExe++correctExtension :: String+correctExtension = if os == "mingw32" then ".exe" else ""++-- | Location to copy the dib.hs script to and rename it. Get around+-- an issue with building on Windows.+tmpDibScript :: String+tmpDibScript = "dib-tmp.hs"++-- | The file that stores the timestamp for dib.hs+timestampFile :: String+timestampFile = ".dib/timestamp"++-- | The file that stores the version of the dib library+versionFile :: String+versionFile = ".dib/version"++-- | The command line for building dib.hs+buildString :: String+buildString = "ghc -o dib" ++ correctExtension ++ " -O2 -XOverloadedStrings -rtsopts -threaded -outputdir . " ++ tmpDibScript++-- | A basic dib script. This is the script saved when running "dib init"+defaultScript :: String+defaultScript = "\+  \module Main where\n\n\+  \import Dib\n\+  \import qualified Data.Text as T\n\n\+  \targets = []\n\n\+  \main = dib targets\n"++compilerToConfig :: String -> String+compilerToConfig "gcc" = "defaultGCCConfig"+compilerToConfig "g++" = "defaultGXXConfig"+compilerToConfig "clang" = "defaultClangConfig"+compilerToConfig template = error $ "Error: unknown template \"" ++ template ++ "\""++-- | Makes a C Builder. Takes a name and source directory.+cBuilderScript :: String -> String -> String -> String+cBuilderScript name compiler srcDir = "\+  \module Main where\n\n\+  \import Dib\n\+  \import Dib.Builders.C\n\+  \import qualified Data.Text as T\n\n"+  ++ "projectInfo = " ++ compilerToConfig compiler ++ " {\n"+  ++ "  outputName = \"" ++ name ++ "\",\n"+  ++ "  targetName = \"" ++ name ++ "\",\n"+  ++ "  srcDir = \"" ++ srcDir ++ "\",\n"+  ++ "  compileFlags = \"\",\n"+  ++ "  linkFlags = \"\",\n"+  ++ "  outputLocation = ObjAndBinDirs \"obj\" \".\",\n"+  ++ "  includeDirs = [\"" ++ srcDir ++ "\"]\n"+  ++ "}\n\n"+  ++ "project = makeCTarget projectInfo\n\+  \clean = makeCleanTarget projectInfo\n\n\+  \targets = [project, clean]\n\n\+  \main = dib targets"++-- | Recurses up the file path until it finds a directory with a dib.hs in it+-- Once it finds a dib.hs, it returns the path.+findDib :: FilePath -> IO (Maybe FilePath)+findDib lastPath = do+  let dibPath = lastPath </> "dib.hs"+  hasDib <- D.doesFileExist dibPath+  if hasDib then+      return $ Just dibPath+    else do+      curPath <- D.canonicalizePath $ lastPath </> ".."+      if curPath /= lastPath then+          findDib curPath+        else+          return Nothing++-- | Recurses up the file path until it finds a directory with a dib.hs in it+-- Once it finds a dib.hs, it builds and runs it.+findAndRunDib :: String -> IO ExitCode+findAndRunDib args = do+    curPath <- D.getCurrentDirectory+    dibPath <- findDib curPath+    if isJust dibPath then do+        D.setCurrentDirectory $ F.dropFileName $ fromJust dibPath+        retVal <- buildAndRunDib args+        D.setCurrentDirectory curPath+        return retVal+      else do+        putStrLn "Error: can't find dib.hs."+        putStrLn "Suggestion: use 'dib --init ...' to create one."+        putStrLn "  Empty Project: 'dib --init empty'"+        putStrLn "  C Project: 'dib --init c <projectName> (gcc|g++|clang) <srcDir>'"+        return (ExitFailure 255)++getDibCalendarTimeStr :: IO String+getDibCalendarTimeStr = do+  modTime <- D.getModificationTime "dib.hs"+  let calTime = (fromIntegral.fromEnum.utcTimeToPOSIXSeconds) modTime :: Integer+  return $ show calTime++checkDibTimestamps :: IO Bool+checkDibTimestamps = do+  dibUnixExists <- D.doesFileExist unixExe+  dibWinExists <- D.doesFileExist windowsExe+  if dibUnixExists || dibWinExists then do+      calTimeStr <- getDibCalendarTimeStr+      storedCalTime <- getStoredCalTime+      storedVersion <- getStoredVersion+      let versionStr = showVersion version+      return $ calTimeStr /= storedCalTime || versionStr /= storedVersion+    else+      return True++getStoredCalTime :: IO String+getStoredCalTime = getStoredTokenFileContents timestampFile++getStoredVersion :: IO String+getStoredVersion = getStoredTokenFileContents versionFile++getStoredTokenFileContents :: String -> IO String+getStoredTokenFileContents f = do+  fileExists <- D.doesFileExist f+  if fileExists then do+      file <- openFile f ReadMode+      tokenStr <- hGetLine file+      hClose file+      return tokenStr+    else+      return ""++processExitCode :: ExitCode -> IO ()+processExitCode (ExitSuccess) = return ()+processExitCode (ExitFailure n) = error $ "Error " ++ show n ++ " building dib.hs."++rebuild :: Bool -> IO ()+rebuild needToRebuild =+  when needToRebuild $+   do D.copyFile "dib.hs" $ ".dib/" ++ tmpDibScript+      D.setCurrentDirectory ".dib"+      exitCode <- system buildString+      D.setCurrentDirectory ".."+      processExitCode exitCode+      +      calTimeStr <- getDibCalendarTimeStr+      tsFile <- openFile timestampFile WriteMode+      hPutStr tsFile calTimeStr+      hClose tsFile+      +      let versionStr = showVersion version+      verFile <- openFile versionFile WriteMode+      hPutStr verFile versionStr+      hClose verFile ++requoteArg :: String -> String+requoteArg arg = requoteArgInternal arg False+  where+    requoteArgInternal ('=':xs) False = '=' : '\"' : requoteArgInternal xs True+    requoteArgInternal [] True = "\""+    requoteArgInternal [] False = []+    requoteArgInternal (x:xs) e = x : requoteArgInternal xs e++buildAndRunDib :: String -> IO ExitCode+buildAndRunDib args = do+  D.createDirectoryIfMissing False ".dib"+  needToRebuild <- checkDibTimestamps+  rebuild needToRebuild+  system $ correctExe ++ " +RTS -N -RTS " ++ args++shouldHandleInit :: [String] -> Bool+shouldHandleInit args = not (null args) && head args == "--init"++argsToBuildScript :: [String] -> String+argsToBuildScript ["c", name, compiler, srcDir] = cBuilderScript name compiler srcDir+argsToBuildScript ["empty"] = defaultScript+argsToBuildScript [] = defaultScript+argsToBuildScript _ = error "Error: Unknown template name."++handleInit :: [String] -> IO Bool+handleInit args =+  if shouldHandleInit args then do+      dibInCurDir <- D.doesFileExist "dib.hs"+      if dibInCurDir then+          error "Error: dib.hs already exists in current directory."+        else do+          curPath <- D.getCurrentDirectory+          dibPath <- findDib curPath+          let initPrefix = if isNothing dibPath then "" else "Warning: dib.hs exists in a parent directory, are you sure you want to do this?\n"+          let buildScript = argsToBuildScript $ tail args+          putStrLn $ initPrefix ++ "Initializing dib.hs..."+          withFile "dib.hs" WriteMode (\h -> hPutStr h buildScript >> return True)+    else+      return False++main :: IO ExitCode+main = do+    hSetBuffering stdout LineBuffering+    hSetBuffering stderr LineBuffering+    args <- getArgs+    inited <- handleInit args+    if inited then+        return ExitSuccess+      else+        findAndRunDib (unwords $ map requoteArg args)

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain

+ dib.cabal view

@@ -0,0 +1,34 @@+name:           dib+version:        0.5.0+cabal-version:  >= 1.6+category:		Development+build-type:     Simple+license:        MIT+license-file:	LICENSE+author:         Brett Lajzer+maintainer:	    Brett Lajzer+synopsis: A simple, forward build system.+description: Dib is a simple, forward build system consisting of a library and a driver application. Build scripts are written in Haskell instead of a bespoke language.++source-repository head+  type: git+  location: https://github.com/blajzer/dib.git++source-repository this+  type: git+  location: https://github.com/blajzer/dib.git+  tag: 0.5.0++library+  build-depends:   base >= 4.4 && < 4.10, text, containers, mtl, directory, time, process, filepath, cereal, bytestring, digest+  ghc-options:     -Wall+  hs-source-dirs:  src+  exposed-modules: Dib, Dib.Gatherers, Dib.Stage, Dib.Target, Dib.Types, Dib.Scanners.CDepScanner, Dib.Builders.C, Dib.Builders.Copy, Dib.Builders.Simple, Dib.Util+  extensions:      OverloadedStrings++executable dib+  build-depends:   base >= 4.4 && < 4.10, containers, mtl, time, directory, filepath+  ghc-options:     -Wall+  hs-source-dirs:  .+  main-is:         Main.hs+

+ src/Dib.hs view

@@ -0,0 +1,465 @@+-- Copyright (c) 2010-2016 Brett Lajzer+-- See LICENSE for license information.++-- | = Introduction+-- Dib is a light-weight, forward build system embedded in Haskell.+-- Dib represents the build products as a chain of operations starting at the input.+-- Reverse build systems such as Make and Jam instead attempt to figure out the+-- operations to perform starting at the desired output and tracing back through+-- a set of rules to find the correct input file. Dib has no such notion of "rules"+-- and the general thought process for writing a build script answers the question+-- "I have these files, how do I build them into the thing I want?", versus a reverse+-- build system which answers (recursively) "I want this product, what files do I+-- need to use as input?".+--+-- = Concepts+-- * 'Target' - The most granluar unit of a build. Represents a desired outcome:+--   e.g. an executable, a folder of files, etc... Contains 'Stage's, which do+--   the actual work. Somewhat unfortunately, a 'Target'\'s name is its only identifier+--   in the cache database, so debug/release and multiplatform 'Target' variants+--   should be named accordingly to prevent full-rebuilds when switching between them.+-- * 'Stage' - A portion of a pipeline for transforming input data into output data.+--   These separate major portions of a pipeline: e.g. building source code into+--   object files, linking object files into an executable, copying some data into place.+--   'Target's can have multiple 'Stage's, which are executed in sequence, the output+--   of one is used as the input to the next.+-- * 'Gatherer' - Used to generate the initial input 'SrcTransform's for the first+--   'Stage' of a 'Target'.+-- * 'SrcTransform' - Represents a mapping from input to output. Comes in four varieties:+--   'OneToOne', 'OneToMany', 'ManyToOne', 'ManyToMany'. Some examples: compiling a+--   C source file into an object file initially begins as a 'OneToOne', but is converted+--   into a 'ManyToOne' through dependency scanning (adding the dependencies to the input+--   exploits the internal timestamp database for free). Copying files from one location to+--   another would just be a simple 'OneToOne'. A tool that takes in one file and+--   generates a bunch of output files would use 'OneToMany'.+--+-- = Getting Started+-- Dib is both a library and an executable. The executable exists to cause a rebuild+-- of the build script whenever it changes, and also as a convenience for invoking both+-- the build and execution correctly. It's recommended that it be used for everything+-- except extraordinary use cases. It can also generate an initial build script+-- through the use of @dib --init@. Run the dib executable with no options for more+-- information on the available templates.+--+-- The most trivial, do nothing build script looks like the following:+--+-- @+-- module Main where+-- import Dib+--+-- targets = []+-- main = dib targets+-- @+--+-- A build script is expected to declare the available 'Target's and then pass them+-- to the 'dib' function. Only the top-level 'Target's need to be passed to 'dib';+-- it will scrape out the dependencies from there. The first 'Target' in the list+-- is the default 'Target' to build if the dib executable is called with no arguments.+--+-- == Additional Information+-- Arguments can be passed on the command line to the dib executable. These can be+-- retrieved in the build with 'getArgDict'. The user is also free to use environment variables+-- as parameter input.+--+-- The invocation might look like the following: @dib <target> <key>=<value> <key>=<value> ...@.+-- Please note that there are no spaces between the keys and values. Quoted strings are+-- untested and unlikely to work correctly.  The 'Target' is optional, and can appear+-- anywhere in the command. If no 'Target' is specified, the default will be used.+--+--+module Dib (+  SrcTransform(OneToOne, OneToMany, ManyToOne, ManyToMany),+  dib,+  getArgDict,+  addEnvToDict,+  makeArgDictLookupFunc+  ) where++import Dib.Gatherers+import Dib.Target+import Dib.Types+import Control.Concurrent+import Control.Monad+import Control.Monad.State as S+import qualified Data.ByteString as B+import qualified Data.Digest.CRC32 as Hash+import qualified Data.List as L+import qualified Data.Map as Map+import qualified Data.Serialize as Serialize+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified GHC.Conc as GHC+import qualified System.Directory as D+import qualified System.Environment as Env+import Data.Maybe+import Data.Time.Clock+import Data.Time.Clock.POSIX+import Data.Word+import System.IO++databaseFile :: String+databaseFile = ".dib/dibdb"++databaseVersion :: Integer+databaseVersion = 3++-- | The function that should be called to dispatch the build. Takes a list+-- of the top-level (root) 'Target's.+dib :: [Target] -> IO ()+dib targets = do+  hSetBuffering stdout LineBuffering+  hSetBuffering stderr LineBuffering+  args <- Env.getArgs+  numProcs <- GHC.getNumProcessors+  let allTargets = gatherAllTargets targets+  let buildArgs = parseArgs args allTargets numProcs+  let selectedTarget = buildTarget buildArgs+  let theTarget = L.find (\(Target name _ _ _ _) -> name == selectedTarget) allTargets+  if isNothing theTarget+    then putStrLn $ "ERROR: Invalid target specified: \"" ++ T.unpack selectedTarget ++ "\"" else+    do+      dbLoadStart <- getCurrentTime+      (tdb, cdb, tcdb) <- loadDatabase+      dbLoadEnd <- getCurrentTime++      startTime <- getCurrentTime+      (_, s) <- runBuild (runTarget (fromJust theTarget)) (BuildState buildArgs selectedTarget tdb cdb tcdb Set.empty Map.empty)+      endTime <- getCurrentTime++      dbSaveStart <- getCurrentTime+      saveDatabase (getTargetTimestampDB s) (getChecksumDB s) (getTargetChecksumDB s)+      dbSaveEnd <- getCurrentTime++      putStrLn $ "DB load/save took " ++ show (diffUTCTime dbLoadEnd dbLoadStart) ++ "/" ++ show (diffUTCTime dbSaveEnd dbSaveStart) ++ " seconds."+      putStrLn $ "Build took " ++ show (diffUTCTime endTime startTime) ++ " seconds."+      return ()++gatherAllTargetsInternal :: [Target] -> Set.Set Target -> Set.Set Target+gatherAllTargetsInternal (t:ts) s =+  let (recurse, newSet) = if Set.notMember t s then (True, Set.insert t s) else (False, s)+  in if recurse then gatherAllTargetsInternal ts (gatherAllTargetsInternal (getDependencies t) newSet) else gatherAllTargetsInternal ts newSet+gatherAllTargetsInternal [] s = s++gatherAllTargets :: [Target] -> [Target]+gatherAllTargets t =+  let allTargets = Set.toList $ gatherAllTargetsInternal t Set.empty+      targetsMinusInitial = L.filter (\x -> x /= head t) allTargets+  in head t : targetsMinusInitial++extractVarsFromArgs :: [String] -> ArgDict+extractVarsFromArgs args = L.foldl' extractVarsFromArgsInternal Map.empty $ map (L.break (== '=')) args+  where+    extractVarsFromArgsInternal e (_, []) = e+    extractVarsFromArgsInternal e (a, _:bs) = Map.insert a bs e++-- | Returns the argument dictionary.+getArgDict :: IO ArgDict+getArgDict = do+  args <- Env.getArgs+  return $ extractVarsFromArgs args++-- | Adds all of the variables in the execution environment into the+-- argument dictionary. Allows for make-like variable passing.+addEnvToDict :: ArgDict -> [(String, String)] -> IO ArgDict+addEnvToDict m vars = do+  env <- Env.getEnvironment+  let valuesToAdd = map (\(x, y) -> (x, fromMaybe y $ L.lookup x env)) vars+  return $ L.foldl' (\a (x, y) -> Map.insert x y a) m valuesToAdd++removeVarsFromArgs :: [String] -> [String]+removeVarsFromArgs args = L.foldl' removeVarsFromArgsInternal [] $ map (L.break (== '=')) args+  where+    removeVarsFromArgsInternal e (t, []) = e ++ [t]+    removeVarsFromArgsInternal e (_, _:_) = e++parseArgs :: [String] -> [Target] -> Int -> BuildArgs+parseArgs args targets numJobs =+  let cleanArgs = removeVarsFromArgs args+      argsLen = length cleanArgs+      target = if argsLen > 0 then T.pack.head $ cleanArgs else T.pack.show.head $ targets+  in BuildArgs { buildTarget = target, maxBuildJobs = numJobs }++-- | Makes a function that can be used to look up a value in the argument+-- dictionary, returning a default value if the argument does not exist.+makeArgDictLookupFunc :: String -> String -> ArgDict -> String+makeArgDictLookupFunc arg defVal dict = fromMaybe defVal $ Map.lookup arg dict++printSeparator :: IO ()+printSeparator = putStrLn "============================================================"++runBuild :: BuildM a -> BuildState -> IO (a, BuildState)+runBuild m = runStateT (runBuildImpl m)++loadDatabase :: IO (TargetTimestampDB, ChecksumDB, TargetChecksumDB)+loadDatabase = do fileExists <- D.doesFileExist databaseFile+                  fileContents <- if fileExists then B.readFile databaseFile else return B.empty+                  return.handleEither $ Serialize.decode fileContents+                  where handleEither (Left _) = (Map.empty, Map.empty, Map.empty)+                        handleEither (Right (v, t, c, tc)) = if v == databaseVersion then (t, c, tc) else (Map.empty, Map.empty, Map.empty)++saveDatabase :: TargetTimestampDB -> ChecksumDB -> TargetChecksumDB -> IO ()+saveDatabase tdb cdb tcdb = B.writeFile databaseFile $ Serialize.encode (databaseVersion, tdb, cdb, tcdb)++getCurrentTargetName :: BuildState -> T.Text+getCurrentTargetName (BuildState _ t _ _ _ _ _) = t++putCurrentTargetName :: BuildState -> T.Text -> BuildState+putCurrentTargetName (BuildState a _ tdb cdb tcdb ts p) t = BuildState a t tdb cdb tcdb ts p++getTargetTimestampDB :: BuildState -> TargetTimestampDB+getTargetTimestampDB (BuildState _ _ tdb _ _ _ _) = tdb++-- | Returns the 'TimestampDB' from the 'BuildState'+getTimestampDB :: BuildState -> TimestampDB+getTimestampDB (BuildState _ t tdb _ _ _ _) = Map.findWithDefault Map.empty t tdb++-- | Puts the 'TimestampDB' back into the 'BuildState'+putTimestampDB :: BuildState -> TimestampDB -> BuildState+putTimestampDB (BuildState a t ftdb cdb tcdb ts p) tdb = BuildState a t (Map.insert t tdb ftdb) cdb tcdb ts p++getChecksumDB :: BuildState -> ChecksumDB+getChecksumDB (BuildState _ _ _ cdb _ _ _) = cdb++putChecksumDB :: BuildState -> ChecksumDB -> BuildState+putChecksumDB (BuildState a t tdb _ tcdb ts p) cdb = BuildState a t tdb cdb tcdb ts p++getTargetChecksumDB :: BuildState -> TargetChecksumDB+getTargetChecksumDB (BuildState _ _ _ _ tcdb _ _) = tcdb++putTargetChecksumDB :: BuildState -> TargetChecksumDB -> BuildState+putTargetChecksumDB (BuildState a t tdb cdb _ ts p) tcdb = BuildState a t tdb cdb tcdb ts p++getUpToDateTargets :: BuildState -> UpToDateTargets+getUpToDateTargets (BuildState _ _ _ _ _ ts _) = ts++putUpToDateTargets :: BuildState -> UpToDateTargets -> BuildState+putUpToDateTargets (BuildState a t tdb cdb tcdb _ p) ts = BuildState a t tdb cdb tcdb ts p++getPendingDBUpdates :: BuildState -> PendingDBUpdates+getPendingDBUpdates (BuildState _ _ _ _ _ _ p) = p++putPendingDBUpdates :: BuildState -> PendingDBUpdates -> BuildState+putPendingDBUpdates (BuildState a t tdb cdb tcdb ts _) = BuildState a t tdb cdb tcdb ts++getMaxBuildJobs :: BuildState -> Int+getMaxBuildJobs (BuildState a _ _ _ _ _ _) = maxBuildJobs a++-- | Returns whether or not a target is up to date, based on the current build state.+targetIsUpToDate :: BuildState -> Target -> Bool+targetIsUpToDate (BuildState _ _ _ _ _ s _) t = Set.member t s++-- | Partitions out up-to-date mappings+partitionMappings :: [SrcTransform] -> [T.Text] -> Bool -> BuildM ([SrcTransform], [SrcTransform])+partitionMappings files extraDeps force = do+  s <- get+  extraDepsChanged <- liftIO $ hasSrcChanged (getTimestampDB s) extraDeps+  if force || extraDepsChanged then+      return (files, [])+    else do+      shouldBuild <- liftIO $ mapM (shouldBuildMapping (getTimestampDB s) (getChecksumDB s)) files+      let paired = zip shouldBuild files+      let (a, b) = L.partition fst paired+      return (map snd a, map snd b)++(<||>) :: IO Bool -> IO Bool -> IO Bool+(<||>) = liftM2 (||)++-- function for filtering FileMappings based on them already being taken care of+shouldBuildMapping :: TimestampDB -> ChecksumDB -> SrcTransform -> IO Bool+shouldBuildMapping t c (OneToOne s d) = hasSrcChanged t [s] <||> hasChecksumChanged c [s] [d] <||> fmap not (D.doesFileExist $ T.unpack d)+shouldBuildMapping t c (OneToMany s ds) = hasSrcChanged t [s] <||> hasChecksumChanged c [s] ds  <||> fmap (not.and) (mapM (D.doesFileExist.T.unpack) ds)+shouldBuildMapping t c (ManyToOne ss d) = hasSrcChanged t ss <||> hasChecksumChanged c ss [d]  <||> fmap not (D.doesFileExist $ T.unpack d)+shouldBuildMapping t c (ManyToMany ss ds) = hasSrcChanged t ss <||> hasChecksumChanged c ss ds  <||> fmap (not.and) (mapM (D.doesFileExist.T.unpack) ds)++hasSrcChanged :: TimestampDB -> [T.Text] -> IO Bool+hasSrcChanged m f = let filesInMap = zip f $ map (`Map.lookup` m) f+                        checkTimeStamps _ (_, Nothing) = return True+                        checkTimeStamps b (file, Just s) = getTimestamp file >>= (\t -> return $ b || (t /= s))+                    in foldM checkTimeStamps False filesInMap++getTimestamp :: T.Text -> IO Integer+getTimestamp f = do+  let unpackedFileName = T.unpack f+  doesExist <- D.doesFileExist unpackedFileName+  if doesExist then D.getModificationTime unpackedFileName >>= extractSeconds else return 0+  where extractSeconds s = return $ (fromIntegral.fromEnum.utcTimeToPOSIXSeconds) s++hasChecksumChanged :: ChecksumDB -> [T.Text] -> [T.Text] -> IO Bool+hasChecksumChanged cdb s d = do+  let (key, cs) = getChecksumPair s d+  let mapVal = Map.lookup key cdb+  return $ compareChecksums mapVal cs+  where compareChecksums (Just mcs) ccs = mcs /= ccs+        compareChecksums Nothing _ = True++getChecksumPair :: [T.Text] -> [T.Text] -> (T.Text, Word32)+getChecksumPair s d =+  let joinedSrc = T.concat $ L.intersperse ":" s+      joinedDest = T.concat $ L.intersperse ":" d+  in (joinedDest, Hash.crc32 (TE.encodeUtf8 joinedSrc))++buildFoldFunc :: Either [SrcTransform] T.Text -> Target -> BuildM (Either [SrcTransform] T.Text)+buildFoldFunc (Left _) t@(Target name _ _ _ _) = do+  buildState <- get+  let oldTargetName = getCurrentTargetName buildState+  put $ putCurrentTargetName buildState name+  result <- runTarget t+  newBuildState <- get+  put $ putCurrentTargetName newBuildState oldTargetName+  return result++buildFoldFunc r@(Right _) _ = return r++isLeft :: Either a b -> Bool+isLeft (Left _) = True+isLeft _ = False++runTarget :: Target -> BuildM (Either [SrcTransform] T.Text)+runTarget t@(Target name _ deps _ _) = do+  buildState <- get+  let outdatedTargets = filter (not.targetIsUpToDate buildState) deps+  depStatus <- foldM buildFoldFunc (Left []) outdatedTargets+  if isLeft depStatus then do+      result <- runTargetInternal t+      writePendingDBUpdates+      return result+    else+      buildFailFunc depStatus name++buildFailFunc :: Either [SrcTransform] T.Text -> T.Text -> BuildM (Either [SrcTransform] T.Text)+buildFailFunc (Right err) name = do+  liftIO printSeparator+  liftIO $ putStr $ "ERROR: Error building target \"" ++ T.unpack name ++ "\": "+  liftIO $ putStrLn $ T.unpack err+  return $ Right ""+buildFailFunc (Left _) _ = return $ Right ""++runTargetInternal :: Target -> BuildM (Either [SrcTransform] T.Text)+runTargetInternal t@(Target name hashFunc _ stages gatherers) = do+  buildState <- get+  let tcdb = getTargetChecksumDB buildState+  let checksum = hashFunc t+  let forceRebuild = checksum /= Map.findWithDefault 0 name tcdb+  gatheredFiles <- liftIO $ runGatherers gatherers+  let srcTransforms = map (flip OneToOne "") gatheredFiles+  liftIO $ putStrLn $ "==== Target: \"" ++ T.unpack name ++ "\""+  stageResult <- foldM stageFoldFunc (Left srcTransforms) $ zip stages $ repeat forceRebuild+  if isLeft stageResult then targetSuccessFunc t else buildFailFunc stageResult name++targetSuccessFunc :: Target -> BuildM (Either [SrcTransform] T.Text)+targetSuccessFunc t@(Target name hashFunc _ _ _) = do+  buildState <- get+  let updatedTargets = Set.insert t $ getUpToDateTargets buildState+  let updatedChecksums = Map.insert name (hashFunc t) $ getTargetChecksumDB buildState+  put $ putTargetChecksumDB (putUpToDateTargets buildState updatedTargets) updatedChecksums+  liftIO $ putStrLn $ "Successfully built target \"" ++ T.unpack name ++ "\""+  liftIO $ putStrLn ""+  return $ Left []++stageFoldFunc :: Either [SrcTransform] T.Text -> (Stage, Bool) -> BuildM (Either [SrcTransform] T.Text)+stageFoldFunc (Left t) (s, force) = runStage s force t+stageFoldFunc r@(Right _) _ = return r++workerThreadFunc :: (SrcTransform -> IO (Either SrcTransform T.Text)) -> MVar [SrcTransform] -> MVar (Either [SrcTransform] T.Text, [BuildM ()]) -> MVar (Either [SrcTransform] T.Text, [BuildM ()]) -> MVar Int -> IO ()+workerThreadFunc sf q r f c = do+  queue <- takeMVar q+  if null queue then do+      putMVar q queue+      count <- takeMVar c+      let newCount = count - 1+      if newCount == 0 then do+          putMVar c newCount+          finalResult <- readMVar r+          putMVar f finalResult+          return ()+        else do+          putMVar c newCount+          return ()+    else do+      let workItem = head queue+      putMVar q (tail queue)+      taskResult <- sf workItem+      let dbThunk = updateDatabase taskResult workItem+      resultAcc <- takeMVar r+      let combine right@(Right _) _ = right+          combine (Left ml) (Left v) = Left (v : ml)+          combine (Left _) (Right v) = Right v+      let newResultAcc = (\(res, thunks) -> (combine res taskResult, dbThunk : thunks)) resultAcc+      putMVar r newResultAcc+      workerThreadFunc sf q r f c++stageHelper :: (SrcTransform -> IO (Either SrcTransform T.Text)) -> Int -> [SrcTransform] -> Either [SrcTransform] T.Text -> BuildM (Either [SrcTransform] T.Text)+stageHelper f m i r = do+  finalResultMVar <- liftIO newEmptyMVar+  resultMVar <- liftIO $ newMVar (r, []) -- (overall result, database thunks)+  queueMVar <- liftIO $ newMVar i+  threadCountMVar <- liftIO $ newMVar m+  if null i then+      return r+    else do+      liftIO $ replicateM_ m (workerThreadFunc f queueMVar resultMVar finalResultMVar threadCountMVar)+      result <- liftIO $ takeMVar finalResultMVar+      sequence_ $ snd result+      return $ fst result++runStage :: Stage -> Bool -> [SrcTransform] -> BuildM (Either [SrcTransform] T.Text)+runStage s@(Stage name _ _ extraDeps f) force m = do+  liftIO $ putStrLn $ "-- Stage: \"" ++ T.unpack name ++ "\""+  depScannedFiles <- liftIO $ processMappings s m+  (targetsToBuild, upToDateTargets) <- partitionMappings depScannedFiles extraDeps force+  bs <- get+  result <- stageHelper f (getMaxBuildJobs bs) targetsToBuild (Left $ map transferUpToDateTarget upToDateTargets)+  updateDatabaseExtraDeps result extraDeps++-- These might not be quite correct. I guessed at what made sense.+transferUpToDateTarget :: SrcTransform -> SrcTransform+transferUpToDateTarget (OneToOne _ d) = OneToOne d ""+transferUpToDateTarget (OneToMany _ ds) = ManyToOne ds ""+transferUpToDateTarget (ManyToOne _ d) = OneToOne d ""+transferUpToDateTarget (ManyToMany _ ds) = ManyToOne ds ""++processMappings :: Stage -> [SrcTransform] -> IO [SrcTransform]+processMappings (Stage _ t d _ _) m = do+  let transMap = t m --transform input-only mappings into input -> output mappings+  mapM d transMap++updateDatabase :: Either l r -> SrcTransform -> BuildM ()+updateDatabase (Right _) _ = return ()+updateDatabase (Left _) (OneToOne s d) = updateDatabaseHelper [s] [d]+updateDatabase (Left _) (OneToMany s ds) = updateDatabaseHelper [s] ds+updateDatabase (Left _) (ManyToOne ss d) = updateDatabaseHelper ss [d]+updateDatabase (Left _) (ManyToMany ss ds) = updateDatabaseHelper ss ds++updateDatabaseHelper :: [T.Text] -> [T.Text] -> BuildM ()+updateDatabaseHelper srcFiles destFiles = do+  buildstate <- get+  let pdbu = getPendingDBUpdates buildstate+  timestamps <- liftIO $ mapM getTimestamp srcFiles+  let filteredResults = filter (\(_, v) -> v /= 0) $ zip srcFiles timestamps+  let updatedPDBU = L.foldl' (\m (k, v) -> Map.insert k v m) pdbu filteredResults+  let cdb = getChecksumDB buildstate+  let (key, cs) = getChecksumPair srcFiles destFiles+  let updatedCDB = Map.insert key cs cdb+  put $ putChecksumDB (putPendingDBUpdates buildstate updatedPDBU) updatedCDB+  return ()++updateDatabaseExtraDeps :: Either [SrcTransform] T.Text -> [T.Text] -> BuildM (Either [SrcTransform] T.Text)+updateDatabaseExtraDeps result@(Right _) _ = return result+updateDatabaseExtraDeps result@(Left _) deps = do+  buildstate <- get+  let pdbu = getPendingDBUpdates buildstate+  timestamps <- liftIO $ mapM getTimestamp deps+  let filteredResults = filter (\(_, v) -> v /= 0) $ zip deps timestamps+  let updatedPDBU = L.foldl' (\m (k, v) -> Map.insert k v m) pdbu filteredResults+  put $ putPendingDBUpdates buildstate updatedPDBU+  return result++writePendingDBUpdates :: BuildM ()+writePendingDBUpdates = do+  buildstate <- get+  let tdb = getTimestampDB buildstate+  let pdbu = getPendingDBUpdates buildstate+  let updatedTDB = Map.union pdbu tdb+  put $ putPendingDBUpdates (putTimestampDB buildstate updatedTDB) Map.empty+  return ()

+ src/Dib/Builders/C.hs view

@@ -0,0 +1,265 @@+-- Copyright (c) 2010-2016 Brett Lajzer+-- See LICENSE for license information.++-- | A builder for C/C++ code.+module Dib.Builders.C (+  CTargetInfo(CTargetInfo, outputName, targetName, srcDir, outputLocation, compiler, linker, archiver, inFileOption, outFileOption, compileFlags, linkFlags, archiverFlags, includeDirs, extraCompileDeps, extraLinkDeps, exclusions, staticLibrary),+  BuildLocation(InPlace, BuildDir, ObjAndBinDirs),+  makeCTarget,+  makeCleanTarget,+  makeBuildDirs,+  emptyConfig,+  defaultGCCConfig,+  defaultGXXConfig,+  defaultClangConfig+  ) where++import Dib.Gatherers+import Dib.Target+import Dib.Types+import Dib.Scanners.CDepScanner++import Data.List as L+import Data.Word+import System.Process (system)+import System.Directory as D+import System.Exit+import System.FilePath as F++import qualified Data.Digest.CRC32 as Hash+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE++-- | The record type that is used to pass configuration info for the C builder.+data CTargetInfo = CTargetInfo {+  -- | The name of the output file.+  outputName :: T.Text,+  -- | The name of the 'Target'. Should be unique among all 'Target's in a given build.+  targetName :: T.Text,+  -- | The directory containing the source for this target.+  srcDir :: T.Text,+  -- | A 'BuildLocation' that defines where the object and executable files go.+  outputLocation :: BuildLocation,+  -- | The compiler executable.+  compiler :: T.Text,+  -- | The linker executable.+  linker :: T.Text,+  -- | The archiver executable.+  archiver :: T.Text,+  -- | The command line option for the input file.+  inFileOption :: T.Text,+  -- | The command line option for the output file.+  outFileOption :: T.Text,+  -- | The compiler's include option+  includeOption :: T.Text,+  -- | Compiler flags.+  compileFlags :: T.Text,+  -- | Linker flags.+  linkFlags :: T.Text,+  -- | Archiver flags.+  archiverFlags :: T.Text,+  -- | A list of directories where include files can be found. Used for+  -- dependency scanning and automatically appended to the compile line.+  includeDirs :: [T.Text],+  -- | Extra compilation dependencies.+  extraCompileDeps :: [T.Text],+  -- | Extra linking dependencies.+  extraLinkDeps :: [T.Text],+  -- | Files to exclude from the build.+  exclusions :: [T.Text],+  -- | Whether or not to build a static lib (using the archiver)+  staticLibrary :: Bool+  }++-- | Given a 'CTargetInfo' and a 'Target', produces a checksum+cTargetHash :: CTargetInfo -> Target -> Word32+cTargetHash info _ =+  let textHash = TE.encodeUtf8 $ T.intercalate "^" [+        "srcDir",+        srcDir info,+        "compiler",+        compiler info,+        "linker",+        linker info,+        "archiver",+        archiver info,+        "inFileOption",+        inFileOption info,+        "outFileOption",+        outFileOption info,+        "includeOption",+        includeOption info,+        "compileFlags",+        compileFlags info,+        "linkFlags",+        linkFlags info,+        "archiverFlags",+        archiverFlags info,+        "includeDirs",+        T.intercalate "^^" $ includeDirs info,+        "extraCompileDeps",+        T.intercalate "^^" $ extraCompileDeps info,+        "extraLinkDeps",+        T.intercalate "^^" $ extraLinkDeps info,+        "exclusions",+        T.intercalate "^^" $ exclusions info,+        "staticLibrary",+        if staticLibrary info then "True" else "False"+        ]++  in Hash.crc32 textHash++-- | The data type for specifying where built files end up.+data BuildLocation =+  -- | Specifies that object files will end up adjacent to their source files+  -- and the executable will be in the same directory as the dib.hs file.+  InPlace+  -- | Specifies that the object files and executable will go in a certain directory.+  | BuildDir T.Text+  -- | Specifies that the object files will go in the first directory and the+  -- executable in the second directory.+  | ObjAndBinDirs T.Text T.Text++-- | An empty configuration.+emptyConfig :: CTargetInfo+emptyConfig = CTargetInfo {+  outputName = "",+  targetName = "",+  srcDir = "",+  outputLocation = InPlace,+  compiler = "",+  linker = "",+  archiver = "",+  inFileOption = "",+  outFileOption = "",+  includeOption = "",+  compileFlags = "",+  linkFlags = "",+  archiverFlags = "",+  includeDirs = [],+  extraCompileDeps = [],+  extraLinkDeps = [],+  exclusions = [],+  staticLibrary = False+  }++-- | A default configuration for gcc.+defaultGCCConfig :: CTargetInfo+defaultGCCConfig = emptyConfig {+  compiler = "gcc",+  linker = "gcc",+  archiver = "ar",+  inFileOption = "-c",+  outFileOption = "-o",+  includeOption = "-I",+  archiverFlags = "rs"+  }++-- | A default configuration for g++.+defaultGXXConfig :: CTargetInfo+defaultGXXConfig = defaultGCCConfig {+  compiler = "g++",+  linker = "g++"+  }++-- | A default configuration for clang.+defaultClangConfig :: CTargetInfo+defaultClangConfig = defaultGCCConfig {+  compiler = "clang",+  linker = "clang"+  }++massageFilePath :: T.Text -> T.Text+massageFilePath p = T.replace "\\" "_" $ T.replace "/" "_" p++remapObjFile :: BuildLocation -> T.Text -> T.Text+remapObjFile InPlace f = f+remapObjFile (BuildDir d) f = d `T.snoc` F.pathSeparator `T.append` massageFilePath f+remapObjFile (ObjAndBinDirs d _) f = d `T.snoc` F.pathSeparator `T.append` massageFilePath f++remapBinFile :: BuildLocation -> T.Text -> T.Text+remapBinFile InPlace f = f+remapBinFile (BuildDir d) f = d `T.snoc` F.pathSeparator `T.append` f+remapBinFile (ObjAndBinDirs _ d) f = d `T.snoc` F.pathSeparator `T.append` f++-- | Given a 'CTargetInfo', will make the directories required to build the project.+makeBuildDirs :: CTargetInfo -> IO ()+makeBuildDirs info = do+  let helper InPlace = return ()+      helper (BuildDir d) = D.createDirectoryIfMissing True (T.unpack d)+      helper (ObjAndBinDirs d d2) = D.createDirectoryIfMissing True (T.unpack d) >> D.createDirectoryIfMissing True (T.unpack d2)+  helper (outputLocation info)+  return ()++excludeFiles :: [T.Text] -> T.Text -> Bool+excludeFiles excl file = L.any (`T.isSuffixOf` file) excl++-- | Given a 'CTargetInfo', produces a 'Target'+makeCTarget :: CTargetInfo -> Target+makeCTarget info =+  let includeDirString = includeOption info `T.append` T.intercalate (" " `T.append` includeOption info) (includeDirs info)+      makeBuildString s t = T.unpack $ T.concat [compiler info, " ", inFileOption info, " ", s, " ", outFileOption info, " ", t, " ", includeDirString, " ", compileFlags info]+      makeLinkString ss t = T.unpack $ T.concat [linker info, " ", T.unwords ss, " ", outFileOption info, " ", t, " ", linkFlags info]+      makeArchiveString ss t = T.unpack $ T.concat [archiver info, " ", archiverFlags info, " ", t, " ", T.unwords ss]++      buildCmd (ManyToOne ss t) = do+        let sourceFile = head ss+        let buildString = makeBuildString sourceFile t+        putStrLn $ "Building: " ++ T.unpack sourceFile+        exitCode <- system buildString+        handleExitCode exitCode t buildString+      buildCmd _ = return $ Right "Unhandled SrcTransform."++      linkCmd (ManyToOne ss t) = do+        let linkString = makeLinkString ss t+        putStrLn $ "Linking: " ++ T.unpack t+        exitCode <- system linkString+        handleExitCode exitCode t linkString+      linkCmd _ = return $ Right "Unhandled SrcTransform."++      archiveCmd (ManyToOne ss t) = do+        let archiveString = makeArchiveString ss t+        putStrLn $ "Archiving: " ++ T.unpack t+        exitCode <- system archiveString+        handleExitCode exitCode t archiveString+      archiveCmd _ = return $ Right "Unhandled SrcTransform."++      buildDirGatherer = makeCommandGatherer $ makeBuildDirs info+      cppStage = Stage "compile" (map (changeExt "o" (outputLocation info))) (cDepScanner (map T.unpack $ includeDirs info)) (extraCompileDeps info) buildCmd+      linkStage = Stage "link" (combineTransforms (remapBinFile (outputLocation info) $ outputName info)) return (extraLinkDeps info) linkCmd+      archiveStage = Stage "archive" (combineTransforms (remapBinFile (outputLocation info) $ outputName info)) return [] archiveCmd+  in Target (targetName info) (cTargetHash info) [] [cppStage, if staticLibrary info then archiveStage else linkStage] [buildDirGatherer, makeFileTreeGatherer (srcDir info) (matchExtensionsExcluded [".cpp", ".c"] [excludeFiles $ exclusions info])]++changeExt :: T.Text -> BuildLocation -> SrcTransform -> SrcTransform+changeExt newExt b (OneToOne l _) = OneToOne l $ remapObjFile b $ T.append (T.dropWhileEnd (/='.') l) newExt+changeExt _ _ _ = undefined++handleExitCode :: ExitCode -> T.Text -> String -> IO (Either SrcTransform T.Text)+handleExitCode ExitSuccess t _ = return $ Left $ OneToOne t ""+handleExitCode (ExitFailure _) _ e = return $ Right $ T.pack (show e)++combineTransforms :: T.Text -> [SrcTransform] -> [SrcTransform]+combineTransforms t st = [ManyToOne sources t]+  where sources = foldl' (\l (OneToOne s _) -> l ++ [s]) [] st++-- | Given a 'CTargetInfo', produces a 'Target' that will clean the project.+makeCleanTarget :: CTargetInfo -> Target+makeCleanTarget info =+  let cleanCmd (OneToOne s _) = do+        putStrLn $ "removing: " ++ T.unpack s+        D.removeFile (T.unpack s)+        return $ Left $ OneToOne "" ""+      cleanCmd _ = error "Should never hit this."++      objDir InPlace = srcDir info+      objDir (BuildDir d) = d+      objDir (ObjAndBinDirs d _) = d++      programFile InPlace = outputName info+      programFile (BuildDir d) = d `T.snoc` F.pathSeparator `T.append` outputName info+      programFile (ObjAndBinDirs _ d) = d `T.snoc` F.pathSeparator `T.append` outputName info++      cleanStage = Stage "clean" id return [] cleanCmd+      objectGatherer = makeFileTreeGatherer (objDir $ outputLocation info) (matchExtension ".o")+      programGatherer = makeSingleFileGatherer (programFile $ outputLocation info)+  in Target ("clean-" `T.append` targetName info) (const 0) [] [cleanStage] [objectGatherer, programGatherer]

+ src/Dib/Builders/Copy.hs view

@@ -0,0 +1,35 @@+-- Copyright (c) 2010-2016 Brett Lajzer+-- See LICENSE for license information.++-- | A trivial builder that copies a directory tree from one location to another.+module Dib.Builders.Copy (+  makeCopyTarget+  ) where++import Dib.Gatherers+import Dib.Types++import qualified Data.Text as T+import qualified System.Directory as D+import System.FilePath as P++copyFunc :: SrcTransform -> IO (Either SrcTransform T.Text)+copyFunc (OneToOne s t) = do+  let unpackedTarget = T.unpack t+  let unpackedSource = T.unpack s+  D.createDirectoryIfMissing True $ takeDirectory unpackedTarget+  putStrLn $ "Copying: " ++ unpackedSource ++ " -> " ++ unpackedTarget+  D.copyFile unpackedSource unpackedTarget+  return $ Left (OneToOne t "")+copyFunc _ = return $ Right "Unexpected SrcTransform"++remapFile :: String -> String -> SrcTransform -> SrcTransform+remapFile src dest (OneToOne s _) = OneToOne s $ T.pack $ dest </> makeRelative src (T.unpack s)+remapFile _ _ _ = error "Unhandled SrcTransform"++-- | The 'makeCopyTarget' function makes a target that copies a directory tree.+-- It takes a name, a source directory, destination directory, and gather filter.+makeCopyTarget :: T.Text -> T.Text -> T.Text -> FilterFunc -> [T.Text] -> Target+makeCopyTarget name src dest f extraDeps =+  let stage = Stage "copy" (map $ remapFile (T.unpack src) (T.unpack dest)) return extraDeps copyFunc+  in Target name (const 0) [] [stage] [makeFileTreeGatherer src f]

+ src/Dib/Builders/Simple.hs view

@@ -0,0 +1,49 @@+-- Copyright (c) 2010-2016 Brett Lajzer+-- See LICENSE for license information.++-- | The Simple builder allows you to execute a 'OneToOne' trasformation+-- given a function that generates a command line from the source and+-- target files.+module Dib.Builders.Simple (+  makeSimpleTarget+  ) where++import Dib.Gatherers+import Dib.Types++import qualified Data.Text as T+import qualified System.Directory as D+import System.Process (system)+import System.Exit+import System.FilePath as P++buildFunc :: (String -> String -> String) -> SrcTransform -> IO (Either SrcTransform T.Text)+buildFunc func (OneToOne s t) = do+  let unpackedTarget = T.unpack t+  let unpackedSource = T.unpack s+  D.createDirectoryIfMissing True $ takeDirectory unpackedTarget+  putStrLn $ "Building: " ++ unpackedSource ++ " -> " ++ unpackedTarget+  let buildCmd = func unpackedSource unpackedTarget+  exitCode <- system buildCmd+  handleExitCode exitCode t buildCmd+buildFunc _ _ = return $ Right "Unexpected SrcTransform"++remapFile :: String -> String -> T.Text -> SrcTransform -> SrcTransform+remapFile src dest ext (OneToOne s _) = OneToOne s $ T.pack $ dest </> makeRelative src (T.unpack (changeExt s ext))+remapFile _ _ _ _ = error "Unhandled SrcTransform"++changeExt :: T.Text -> T.Text -> T.Text+changeExt path = T.append (T.dropWhileEnd (/='.') path)++--TODO: move to a utility module and factor out of C builder+handleExitCode :: ExitCode -> T.Text -> String -> IO (Either SrcTransform T.Text)+handleExitCode ExitSuccess t _ = return $ Left $ OneToOne t ""+handleExitCode (ExitFailure _) _ e = return $ Right $ T.pack (show e)++-- | The 'makeSimpleTarget' function generates a target.+-- It takes a name, source directory, destination directory, destination extension,+-- gather filter, and a function to build the command line.+makeSimpleTarget :: T.Text -> T.Text -> T.Text -> T.Text -> FilterFunc -> [T.Text] -> (String -> String -> String) -> Target+makeSimpleTarget name src dest ext f extraDeps buildCmdBuilder =+  let stage = Stage name (map $ remapFile (T.unpack src) (T.unpack dest) ext) return extraDeps (buildFunc buildCmdBuilder)+  in Target name (const 0) [] [stage] [makeFileTreeGatherer src f]

+ src/Dib/Gatherers.hs view

@@ -0,0 +1,141 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- Copyright (c) 2010-2016 Brett Lajzer+-- See LICENSE for license information.++-- | Module that exposes all of the various 'GatherStrategy' types and functions+-- for dealing with them.+module Dib.Gatherers(+  SingleFileGatherer(),+  DirectoryGatherer(),+  FileTreeGatherer(),+  Gatherer(),+  CommandGatherer(),+  wrapGatherStrategy,+  runGatherers,+  makeSingleFileGatherer,+  makeDirectoryGatherer,+  makeFileTreeGatherer,+  makeCommandGatherer,+  matchAll,+  matchExtension,+  matchExtensionExcluded,+  matchExtensions,+  matchExtensionsExcluded+  )where++import Control.Monad+import Dib.Types+import Data.List+import qualified Data.Text as T+import qualified System.Directory as D+import System.FilePath++instance GatherStrategy SingleFileGatherer where+  gather = singleFileGatherFunc++instance GatherStrategy DirectoryGatherer where+  gather = directoryGathererFunc++instance GatherStrategy FileTreeGatherer where+  gather = fileTreeGatherFunc++instance GatherStrategy CommandGatherer where+  gather = commandGatherFunc++-- | Runs a list of 'Gatherer's and returns the concatenation of their output.+runGatherers :: [Gatherer] -> IO [T.Text]+runGatherers gs = mapM (\(Gatherer s) -> gather s) gs >>= \x -> foldM (\a b -> return (a ++ b)) [] x++-- | Convenience function to turn a 'GatherStrategy' into a 'Gatherer'.+wrapGatherStrategy :: GatherStrategy s => s -> Gatherer+wrapGatherStrategy = Gatherer++-- | Constructs a 'Gatherer' that returns a single file.+makeSingleFileGatherer :: T.Text -> Gatherer+makeSingleFileGatherer = wrapGatherStrategy.SingleFileGatherer++-- | Constructs a 'Gatherer' that returns all files in a directory (but not its+-- subdirectories) that match a given filter.+makeDirectoryGatherer :: T.Text -> FilterFunc -> Gatherer+makeDirectoryGatherer d = wrapGatherStrategy.DirectoryGatherer d++-- | Constructs a 'Gatherer' that returns all files in a directory tree that+-- match a given filter.+makeFileTreeGatherer :: T.Text -> FilterFunc -> Gatherer+makeFileTreeGatherer d = wrapGatherStrategy.FileTreeGatherer d++-- | Constructs a 'Gatherer' that runs an arbitrary 'IO' action.+makeCommandGatherer :: IO () -> Gatherer+makeCommandGatherer = wrapGatherStrategy.CommandGatherer++singleFileGatherFunc :: SingleFileGatherer -> IO [T.Text]+singleFileGatherFunc (SingleFileGatherer f) = do+  exists <- D.doesFileExist $ T.unpack f+  return [f | exists]++directoryGathererFunc :: DirectoryGatherer -> IO [T.Text]+directoryGathererFunc (DirectoryGatherer d f) = do+  let unpackedDir = T.unpack d+  contents <- D.getDirectoryContents unpackedDir+  filtContents <- mapM filePathDeterminer $ fixFilePaths unpackedDir $ filePathFilter contents+  let (_, files) = directorySplitter filtContents+  return $ filter f $ map T.pack files++fileTreeGatherFunc :: FileTreeGatherer -> IO [T.Text]+fileTreeGatherFunc (FileTreeGatherer d f) = do+  files <- rGetFilesInDir $ T.unpack d+  return $ filter f $ map T.pack files++commandGatherFunc :: CommandGatherer -> IO [T.Text]+commandGatherFunc (CommandGatherer f) = do+  f+  return []++-- functions to handle recursively spidering a directory+filePathDeterminer :: FilePath -> IO (FilePath, Bool)+filePathDeterminer f = D.doesDirectoryExist f >>= \d -> return (f, d)++filePathFilter :: [FilePath] -> [FilePath]+filePathFilter = filter noSpecialOrHiddenDirs+    where noSpecialOrHiddenDirs (x:_) = x /= '.'+          noSpecialOrHiddenDirs [] = False++directorySplitter :: [(FilePath, Bool)] -> ([FilePath], [FilePath])+directorySplitter = foldl' splitter ([], [])+    where splitter (d, f) (path, dir) = if dir then (d ++ [path], f) else (d, f ++ [path])++fixFilePaths :: FilePath -> [FilePath] -> [FilePath]+fixFilePaths root = map (root </>)++-- | Recursively gets all files in the given directory and its subdirectories.+rGetFilesInDir :: FilePath -> IO [FilePath]+rGetFilesInDir dir = do+    contents <- D.getDirectoryContents dir+    filtContents <- mapM filePathDeterminer $ fixFilePaths dir $ filePathFilter contents+    let (dirs, files) = directorySplitter filtContents+    spideredDirs <- mapM rGetFilesInDir dirs+    return $ concat spideredDirs ++ files++-- | Filter function that returns all files.+matchAll :: FilterFunc+matchAll _ = True++-- | Filter function that returns files with a given extension.+matchExtension :: T.Text -> FilterFunc+matchExtension = T.isSuffixOf++-- | Filter function that returns files that match any of a list of extensions.+matchExtensions :: [T.Text] -> FilterFunc+matchExtensions exts file = foldl' foldFunc False exts+  where foldFunc True _ = True+        foldFunc False e = e `T.isSuffixOf` file++-- | Filter function that returns files with a given extension that don't match exclusion rules.+matchExtensionExcluded :: T.Text -> [T.Text -> Bool] -> FilterFunc+matchExtensionExcluded ext rules file = T.isSuffixOf ext file && (not.or $ map (\r -> r file) rules)++-- | Filter function that returns files that match any of a list of extensions, but don't match the exclusion rules.+matchExtensionsExcluded :: [T.Text] -> [T.Text -> Bool] -> FilterFunc+matchExtensionsExcluded exts rules file = foldl' foldFunc False exts+  where foldFunc True _ = True+        foldFunc False e = (e `T.isSuffixOf` file) && (not.or $ map (\r -> r file) rules)

+ src/Dib/Scanners/CDepScanner.hs view

@@ -0,0 +1,152 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, ExistentialQuantification, KindSignatures, FlexibleContexts #-}+-- Copyright (c) 2010-2016 Brett Lajzer+-- See LICENSE for license information.++-- | C dependency scanner. Runs a stripped-down pre-processor to scan for+-- include files (recursively).+module Dib.Scanners.CDepScanner (+  cDepScanner+  ) where++import Dib.Types+import qualified Data.Set as S+import qualified Data.Text as T+import qualified System.Directory as Dir+import qualified System.FilePath as F+import Control.Monad.State.Lazy++data Dependency = Dependency String String+  deriving (Show)++instance Eq Dependency where+  (Dependency f1 _) == (Dependency f2 _) = f1 == f2++instance Ord Dependency where+  compare (Dependency f1 _) (Dependency f2 _) = compare f1 f2++getPathFromDep :: Dependency -> String+getPathFromDep (Dependency _ path) = path++--    already read includes, list of include paths+data ParseState = PS {+  currentDeps :: S.Set Dependency,+  searchPaths :: [String] }+  deriving (Show)++newtype DepGatherer a = DepGatherer {+  runDepGatherer :: StateT ParseState IO a+  } deriving (Functor, Applicative, Monad, MonadIO, MonadState ParseState)++removeCR :: String -> String+removeCR = filter (/= '\r')++removeLeadingWS :: String -> String+removeLeadingWS = dropWhile (\x -> x == ' ' || x == '\t')++removeBlockComment :: String -> String+removeBlockComment ('*':'/':xs) = removeComments xs+removeBlockComment (_:xs) = removeBlockComment xs+removeBlockComment [] = error "Unterminated block comment."++removeLineComment :: String -> String+removeLineComment ('\n':xs) = removeComments xs+removeLineComment (_:xs) = removeLineComment xs+removeLineComment [] = []++processCharLiteral :: String -> String+processCharLiteral ('\\':x:'\'':xs) = '\\' : x : '\'' : removeComments xs+processCharLiteral (x:'\'':xs) = x : '\'' : removeComments xs+processCharLiteral (x:xs) = x : removeComments xs+processCharLiteral [] = []++processStringLiteral :: String -> String+processStringLiteral ('\\':'"':xs) = '\\' : '"' : processStringLiteral xs+processStringLiteral ('"':xs) = '"' : removeComments xs+processStringLiteral (x:xs) = x : processStringLiteral xs+processStringLiteral [] = error "Unterminated string literal."++processDirective :: String -> String+processDirective ('\\':'\n':xs) = '\\' : '\n' : processDirective xs+processDirective ('\n':xs) = '\n' : removeComments xs+processDirective (x:xs) = x : processDirective xs+processDirective [] = []++removeComments :: String -> String+removeComments ('#':xs) = '#' : processDirective xs+removeComments ('/':'*':xs) = removeBlockComment xs+removeComments ('/':'/':xs) = removeLineComment xs+removeComments ('\'':xs) = '\'' : processCharLiteral xs+removeComments ('"':xs) = '"' : processStringLiteral xs+removeComments (x:xs) = x : removeComments xs+removeComments [] = []++filterBlank :: [String] -> [String]+filterBlank = filter (\x -> x /= "\n" && x /= [])++extractIncludes :: [String] -> [String]+extractIncludes = filter (\x -> "#include" == takeWhile (/= ' ') x)++dequoteInclude :: String -> String+dequoteInclude s =+  let endPortion = dropWhile (\x -> x /= '\"' && x /= '<') s+      endLen = length endPortion+  in if endLen > 0 then takeWhile (\x -> x /= '\"' && x /= '>') $ tail endPortion else []++-- intial pass, removes comments and leading whitespace, then filters out extra lines+pass1 :: String -> [String]+pass1 s = filterBlank $ map removeLeadingWS $ lines $ removeComments (removeCR s)++-- second pass, cleans up includes+pass2 :: [String] -> [String]+pass2 l = filterBlank $ map dequoteInclude $ extractIncludes l++gatherDependencies :: String -> [String]+gatherDependencies = pass2.pass1++possibleFilenames :: FilePath -> [FilePath] -> [FilePath]+possibleFilenames file = map (\p -> F.normalise $ F.combine p file)++pathToDependency :: FilePath -> Dependency+pathToDependency path = Dependency (F.takeFileName path) path++spider :: forall (m :: * -> *).(MonadIO m, MonadState ParseState m) => String -> m ()+spider file = do+  s <- get+  paths <- filterM (includeFilter $ currentDeps s) $ possibleFilenames file (searchPaths s)+  spiderHelper paths+  return ()+    where+      includeFilter deps f = do+        exists <- liftIO $ Dir.doesFileExist f+        return $ exists && not (S.member (pathToDependency f) deps)++spiderHelper :: forall (m :: * -> *).(MonadIO m, MonadState ParseState m) => [FilePath] -> m ()+spiderHelper [] =  return ()+spiderHelper (file:_) = do+  c <- liftIO $ readFile file+  let deps = gatherDependencies c+  s <- get+  put $ s {currentDeps = S.insert (pathToDependency file) (currentDeps s) }+  mapM_ spider deps+  return ()++spiderLauncher :: forall (m :: * -> *).(MonadIO m, MonadState ParseState m) => FilePath -> m ()+spiderLauncher file = do+  c <- liftIO $ readFile file+  let deps = gatherDependencies c+  mapM_ spider deps+  return ()++getDepsForFile :: [FilePath] -> FilePath -> IO [T.Text]+getDepsForFile includeDirs file = do+  (_, s) <- runStateT (runDepGatherer $ spiderLauncher file) PS {currentDeps=S.empty, searchPaths=[F.dropFileName file, "."] ++ includeDirs }+  return $ map (T.pack.getPathFromDep) (S.toList (currentDeps s))++-- | Takes in a list of include directories, extra dependencies, a 'SrcTransform',+-- and returns a new 'SrcTransform' with the dependencies injected into the source+-- side.+cDepScanner :: [FilePath] -> SrcTransform -> IO SrcTransform+cDepScanner includeDirs (OneToOne i o) = getDepsForFile includeDirs (T.unpack i) >>= \d -> return $ ManyToOne (i:d) o+cDepScanner includeDirs (OneToMany i o) = getDepsForFile includeDirs (T.unpack i) >>= \d -> return $ ManyToMany (i:d) o+cDepScanner _ _ = error "Unimplemented. Implement this if it is a valid relationship."+

+ src/Dib/Stage.hs view

@@ -0,0 +1,18 @@+-- Copyright (c) 2010-2016 Brett Lajzer+-- See LICENSE for license information.++-- | Module exposing the 'Stage' type and related type wrappers, along with a+-- convenience 'emptyStage'.+module Dib.Stage(+  Stage(Stage),+  InputTransformer,+  DepScanner,+  StageFunc,+  emptyStage+  ) where++import Dib.Types++-- | A stage that does nothing and just passes the 'SrcTransform's through.+emptyStage :: Stage+emptyStage = Stage "empty" id return [] (return.Left)

+ src/Dib/Target.hs view

@@ -0,0 +1,48 @@+-- Copyright (c) 2010-2016 Brett Lajzer+-- See LICENSE for license information.++-- | Module that exposes the 'Target' data type and a handful of convenience functions+-- for dealing with 'Target's.+module Dib.Target(+  Target(Target),+  addDependency,+  addDependencies,+  getDependencies,+  makePhonyTarget,+  makeCommandTarget,+  targetDepChecksum+  ) where++import Dib.Types+import Dib.Gatherers++import Data.Word++import qualified Data.Digest.CRC32 as Hash+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE++-- | Adds a dependency on another 'Target'.+addDependency :: Target -> Target -> Target+addDependency (Target name checksum deps stages gatherers) newDep = Target name checksum (newDep : deps) stages gatherers++-- | Adds a dependency on a list of 'Target's.+addDependencies :: Target -> [Target] -> Target+addDependencies (Target name checksum deps stages gatherers) newDeps = Target name checksum (newDeps ++ deps) stages gatherers++-- | Gets dependencies of a 'Target'.+getDependencies :: Target -> [Target]+getDependencies (Target _ _ deps _ _) = deps++-- | Makes a 'Target' that doesn't build anything but can be used as a meta+-- 'Target', i.e. the "all" target in make.+makePhonyTarget :: T.Text -> [Target] -> Target+makePhonyTarget name deps = Target name (const 0) deps [] []++-- | Makes a 'Target' that runs an arbitrary 'IO' action.+makeCommandTarget :: T.Text -> [Target] -> IO () -> Target+makeCommandTarget name deps command = Target name (const 0) deps [] [makeCommandGatherer command]++-- | Computes a checksum from the direct dependencies of a target+targetDepChecksum :: Target -> Word32+targetDepChecksum (Target _ _ deps _ _) = Hash.crc32 $ TE.encodeUtf8 $ T.intercalate "^" $ map (\(Target n _ _ _ _) -> n) deps

+ src/Dib/Types.hs view

@@ -0,0 +1,131 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, ExistentialQuantification, OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_HADDOCK hide, prune #-}++-- Copyright (c) 2010-2016 Brett Lajzer+-- See LICENSE for license information.++-- | Various types used in dib. Due to certain circumstances, this module does+-- not export any of these types directly; other modules do.+module Dib.Types where++import Control.Monad.State as S+import qualified Data.Map as Map+import qualified Data.Serialize as Serialize+import qualified Data.Set as Set+import qualified Data.Text as T+import Data.Word++-- | Type wrapper for the timestamp database.+type TimestampDB = Map.Map T.Text Integer+-- | Type wrapper for the target timestamp database.+type TargetTimestampDB = Map.Map T.Text TimestampDB+-- | Type wrapper for the checksum database.+type ChecksumDB = Map.Map T.Text Word32+-- | Type wrapper for the target checksum database.+type TargetChecksumDB = Map.Map T.Text Word32+-- | Type wrapper for the set of currently up-to-date 'Target's.+type UpToDateTargets = Set.Set Target+-- | Type wrapper for the list of database updates that will happen after+-- a successful 'Target' build.+type PendingDBUpdates = Map.Map T.Text Integer+-- | Type wrapper for the dictionary of arguments that are extracted from the+-- command line.+type ArgDict = Map.Map String String++-- | Internal type that contains information state used by the build.+data BuildState = BuildState BuildArgs T.Text TargetTimestampDB ChecksumDB TargetChecksumDB UpToDateTargets PendingDBUpdates++-- | Configuration arguments used by the build+data BuildArgs = BuildArgs {+  -- | The target to build.+  buildTarget :: T.Text,+  -- | The maximum number of build jobs to spawn.+  maxBuildJobs :: Int+  }++-- | Newtype wrapper for the build monad transformer stack.+newtype BuildM a = BuildMImpl {+  runBuildImpl :: S.StateT BuildState IO a+  } deriving (Functor, Applicative, Monad, MonadIO, MonadState BuildState)++-- | Data type for expressing mapping of input files to output files+data SrcTransform =+  -- | One input to one output file.+  OneToOne T.Text T.Text+  -- | One input file to many output files.+  | OneToMany T.Text [T.Text]+  -- | Many input files to one output file.+  | ManyToOne [T.Text] T.Text+  -- | Many input to many output files.+  | ManyToMany [T.Text] [T.Text]+  deriving (Show)++-- | Type wrapper for functions transforming a list of 'SrcTransform's into a+-- list of 'SrcTransform's suitable for passing into the 'DepScanner'.+type InputTransformer = ([SrcTransform] -> [SrcTransform])++-- | Type wrapper for a function that takes a 'SrcTransform' and produces+-- a 'SrcTransform' with dependencies included in the input.+type DepScanner = (SrcTransform -> IO SrcTransform)++-- | Type wrapper for a function that given a 'SrcTransform', produces either+-- a 'SrcTransform' containing the output files in the input, or an error.+type StageFunc = (SrcTransform -> IO (Either SrcTransform T.Text))++-- | Type describing a build stage.+-- Takes a name, an 'InputTransformer', 'DepScanner', additional dependencies, and the builder function.+data Stage = Stage T.Text InputTransformer DepScanner [T.Text] StageFunc++-- | Type wrapper for a function that given a Target produces a checksum.+type ChecksumFunc = (Target -> Word32)++-- | Describes a build target.+-- Takes a name, checksum function, list of dependencies, list of 'Stage's, and a list of 'Gatherer's.+data Target = Target T.Text ChecksumFunc [Target] [Stage] [Gatherer]++instance Show Target where+  show (Target t _ _ _ _) = T.unpack t++instance Eq Stage where+  (==) (Stage n _ _ _ _) (Stage n2 _ _ _ _) = n Prelude.== n2++instance Eq Target where+  (==) (Target n _ _ _ _) (Target n2 _ _ _ _) = n Prelude.== n2++instance Ord Target where+  compare (Target n _ _ _ _) (Target n2 _ _ _ _) = compare n n2++-- | Typeclass representing data types that can be used to collect files+-- for input into a target.+class GatherStrategy a where+  -- | Function that, given the strategy, will produce a list of file paths.+  gather :: a -> IO [T.Text]++-- | Existential data type for wrapping 'GatherStrategy's so they can be used+-- as a uniform type.+data Gatherer = forall s . GatherStrategy s => Gatherer s++-- | Type wrapper for a function to determine if a file should be returned by+-- a 'Gatherer'.+type FilterFunc = (T.Text -> Bool)++-- | 'Gatherer' that will return exactly one file.+data SingleFileGatherer = SingleFileGatherer T.Text++-- | 'Gatherer' that will return all files in a given directory (but not its+-- subdirectories) that pass the filter.+data DirectoryGatherer = DirectoryGatherer T.Text FilterFunc++-- | 'Gatherer' that will return all files in a given directory tree that pass+-- the filter.+data FileTreeGatherer = FileTreeGatherer T.Text FilterFunc++-- | 'Gatherer' that will run a command and return an empty list.+-- Useful for making clean 'Target's. Use sparingly.+data CommandGatherer = CommandGatherer (IO ())++-- Horrible.+instance Serialize.Serialize T.Text where+  put s = Serialize.putListOf Serialize.put $ T.unpack s+  get = T.pack <$> Serialize.getListOf Serialize.get

+ src/Dib/Util.hs view

@@ -0,0 +1,18 @@+-- Copyright (c) 2010-2016 Brett Lajzer+-- See LICENSE for license information.++-- | Module containing utility functions and common functionality.+module Dib.Util (+  getSubDirectories+  ) where++import Control.Monad+import qualified System.Directory as D++-- | Given a directory, returns the list of subdirectories.+getSubDirectories :: FilePath -> IO [FilePath]+getSubDirectories root = do+  contents <- D.getDirectoryContents root+  let filteredDirs = filter (\x -> x /= "." && x /= "..") contents+  dirs <- filterM (\(x, _) -> D.doesDirectoryExist x) $ zip (map (root ++) filteredDirs) filteredDirs+  return $ map snd dirs