dib 0.7.1 → 0.7.2
raw patch · 7 files changed
+349/−211 lines, 7 filesdep +ansi-terminaldep ~basePVP ok
version bump matches the API change (PVP)
Dependencies added: ansi-terminal
Dependency ranges changed: base
API changes (from Hackage documentation)
Files
- dib.cabal +8/−6
- src/Dib.hs +238/−132
- src/Dib/Builders/C.hs +50/−39
- src/Dib/Builders/Copy.hs +12/−8
- src/Dib/Builders/Simple.hs +12/−8
- src/Dib/Scanners/CDepScanner.hs +16/−15
- src/Dib/Types.hs +13/−3
dib.cabal view
@@ -1,6 +1,6 @@ name: dib-version: 0.7.1-cabal-version: >= 1.6+version: 0.7.2+cabal-version: >= 1.10 category: Development build-type: Simple license: MIT@@ -17,17 +17,19 @@ source-repository this type: git location: https://github.com/blajzer/dib.git- tag: 0.7.1+ tag: 0.7.2 library- build-depends: base >= 4.4 && < 4.11, text, containers, mtl, directory, time, process, filepath, cereal, bytestring, digest+ build-depends: base >= 4.8 && < 4.11, text, containers, mtl, directory, time, process, filepath, cereal, bytestring, digest, ansi-terminal 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+ default-extensions: OverloadedStrings+ default-language: Haskell2010 executable dib- build-depends: base >= 4.4 && < 4.11, containers, mtl, time, directory, filepath+ build-depends: base >= 4.8 && < 4.11, containers, mtl, time, directory, filepath, process ghc-options: -Wall hs-source-dirs: . main-is: Main.hs+ default-language: Haskell2010
src/Dib.hs view
@@ -111,8 +111,10 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified GHC.Conc as GHC+import qualified System.Console.ANSI as ANSI import qualified System.Directory as D import qualified System.Environment as Env+import Data.Either import Data.Maybe import Data.Time.Clock import Data.Time.Clock.POSIX@@ -123,7 +125,7 @@ databaseFile = ".dib/dibdb" databaseVersion :: Integer-databaseVersion = 3+databaseVersion = 5 -- | The function that should be called to dispatch the build. Takes a list -- of the top-level (root) 'Target's.@@ -135,39 +137,50 @@ numProcs <- GHC.getNumProcessors -- Validate that we have at least one target- if null targets then putStrLn "ERROR: Invalid configuration, no targets defined." else do-- let allTargets = gatherAllTargets targets-- -- Validate targets- let targetErrors = validateTargets allTargets- if isJust targetErrors then putStrLn $ "ERROR: Invalid targets:\n" ++ fromJust targetErrors else do-- let buildArgs = parseArgs args allTargets numProcs- let selectedTarget = buildTarget buildArgs- let theTarget = L.find (\(Target name _ _ _ _) -> name == selectedTarget) allTargets+ if null targets+ then printError "ERROR: Invalid configuration, no targets defined."+ else do+ -- Validate targets+ let allTargets = gatherAllTargets targets+ let targetErrors = validateTargets allTargets+ if isJust targetErrors+ then printError $ "ERROR: Invalid targets:\n" ++ fromJust targetErrors+ else do+ let buildArgs = parseArgs args allTargets numProcs+ let selectedTarget = buildTarget buildArgs+ let theTarget = L.find (\(Target name _ _ _ _) -> name == selectedTarget) allTargets - -- Validate that we're trying to build something that exists- if isNothing theTarget then putStrLn $ "ERROR: Invalid target specified: \"" ++ T.unpack selectedTarget ++ "\"" else do+ -- Validate that we're trying to build something that exists+ if isNothing theTarget+ then printError $ "ERROR: Invalid target specified: \"" ++ T.unpack selectedTarget ++ "\""+ else do+ -- load the database+ dbLoadStart <- getCurrentTime+ (tdb, cdb, tcdb) <- loadDatabase+ dbLoadEnd <- getCurrentTime - -- load the database- dbLoadStart <- getCurrentTime- (tdb, cdb, tcdb) <- loadDatabase- dbLoadEnd <- getCurrentTime+ -- run the build+ startTime <- getCurrentTime+ let buildState = BuildState buildArgs selectedTarget tdb cdb tcdb Set.empty Map.empty+ (_, s) <- runBuild (runTarget $ fromJust theTarget) buildState+ endTime <- getCurrentTime - -- run the build- startTime <- getCurrentTime- (_, s) <- runBuild (runTarget (fromJust theTarget)) (BuildState buildArgs selectedTarget tdb cdb tcdb Set.empty Map.empty)- endTime <- getCurrentTime+ -- save the database+ dbSaveStart <- getCurrentTime+ saveDatabase (getTargetTimestampDB s) (getChecksumDB s) (getTargetChecksumDB s)+ dbSaveEnd <- getCurrentTime - -- save the database- dbSaveStart <- getCurrentTime- saveDatabase (getTargetTimestampDB s) (getChecksumDB s) (getTargetChecksumDB s)- dbSaveEnd <- getCurrentTime+ -- output build stats+ ANSI.setSGR [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Black]+ putStrLn $ "DB load/save took " ++ show (diffUTCTime dbLoadEnd dbLoadStart) ++ "/" ++ show (diffUTCTime dbSaveEnd dbSaveStart) ++ " seconds."+ putStrLn $ "Build took " ++ show (diffUTCTime endTime startTime) ++ " seconds."+ ANSI.setSGR [ANSI.Reset] - -- output build stats- putStrLn $ "DB load/save took " ++ show (diffUTCTime dbLoadEnd dbLoadStart) ++ "/" ++ show (diffUTCTime dbSaveEnd dbSaveStart) ++ " seconds."- putStrLn $ "Build took " ++ show (diffUTCTime endTime startTime) ++ " seconds."+printError :: String -> IO ()+printError errorStr = do+ ANSI.setSGR [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Red]+ putStrLn errorStr+ ANSI.setSGR [ANSI.Reset] gatherAllTargetsInternal :: [Target] -> Set.Set Target -> Set.Set Target gatherAllTargetsInternal (t:ts) s =@@ -233,10 +246,8 @@ makeArgDictLookupFuncChecked arg defVal validValues dict = let partialResult = makeArgDictLookupFunc arg defVal dict result = L.find (== partialResult) validValues- in maybe (Left $ "ERROR: invalid value \"" ++ partialResult ++ "\" for argument \"" ++ arg ++ "\". Expected one of: [" ++ L.intercalate ", " validValues ++ "]") Right result--printSeparator :: IO ()-printSeparator = putStrLn "============================================================"+ errorString = Left $ "ERROR: invalid value \"" ++ partialResult ++ "\" for argument \"" ++ arg ++ "\". Expected one of: [" ++ L.intercalate ", " validValues ++ "]"+ in maybe errorString Right result runBuild :: BuildM a -> BuildState -> IO (a, BuildState) runBuild m = runStateT (runBuildImpl m)@@ -300,14 +311,14 @@ 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+partitionMappings :: T.Text -> T.Text -> [SrcTransform] -> [T.Text] -> Bool -> BuildM ([SrcTransform], [SrcTransform])+partitionMappings targetName stageName files extraDeps force = do+ buildState <- get+ extraDepsChanged <- liftIO $ haveExtraDepsChanged (getTimestampDB buildState) targetName stageName extraDeps if force || extraDepsChanged then return (files, []) else do- shouldBuild <- liftIO $ mapM (shouldBuildMapping (getTimestampDB s) (getChecksumDB s)) files+ shouldBuild <- liftIO $ mapM (shouldBuildMapping (getTimestampDB buildState) (getChecksumDB buildState)) files let paired = zip shouldBuild files let (a, b) = L.partition fst paired return (map snd a, map snd b)@@ -315,39 +326,84 @@ (<||>) :: IO Bool -> IO Bool -> IO Bool (<||>) = liftM2 (||) --- function for filtering FileMappings based on them already being taken care of+-- Function for filtering FileMappings based on them already being up-to-date 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)+shouldBuildMapping t c src@(OneToOne s d) = hasSrcChanged t src [s] <||> hasChecksumChanged c [s] [d] <||> fmap not (D.doesFileExist $ T.unpack d)+shouldBuildMapping t c src@(OneToMany s ds) = hasSrcChanged t src [s] <||> hasChecksumChanged c [s] ds <||> fmap (not.and) (mapM (D.doesFileExist.T.unpack) ds)+shouldBuildMapping t c src@(ManyToOne ss d) = hasSrcChanged t src ss <||> hasChecksumChanged c ss [d] <||> fmap not (D.doesFileExist $ T.unpack d)+shouldBuildMapping t c src@(ManyToMany ss ds) = hasSrcChanged t src 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+hashText :: T.Text -> Word32+hashText t = Hash.crc32 $ TE.encodeUtf8 t +hashTransform :: SrcTransform -> [Word32]+hashTransform (OneToOne s d) = [hashText $ T.concat [s, "^^^^", d]]+hashTransform (OneToMany s ds) = [hashText $ T.concat $ s : "^^^^" : L.intersperse ":" ds]+hashTransform (ManyToOne ss d) = map (\s -> hashText $ T.concat [s, "^^^^", d]) ss+hashTransform (ManyToMany ss ds) =+ let destMux = L.intersperse ":" ds+ in map (\s -> hashText $ T.concat $ s : "^^^^" : destMux) ss++hashExtraDeps :: T.Text -> T.Text -> [T.Text] -> [Word32]+hashExtraDeps targetName stageName extraDeps =+ let destName = T.concat [targetName, "^:^", stageName]+ in map (\s -> hashText $ T.concat [s, "^^^^", destName]) extraDeps++hasSrcChanged :: TimestampDB -> SrcTransform -> [T.Text] -> IO Bool+hasSrcChanged tdb transform files =+ let filesInMap = zip files $ map (`Map.lookup` tdb) $ hashTransform transform+ checkTimeStamps acc (file, Nothing) = D.doesFileExist (T.unpack file) >>= (\e -> return $ acc || e)+ checkTimeStamps acc (file, Just s) = getTimestamp file >>= (\t -> return $ acc || (t /= s))+ in foldM checkTimeStamps False filesInMap++haveExtraDepsChanged :: TimestampDB -> T.Text -> T.Text -> [T.Text] -> IO Bool+haveExtraDepsChanged tdb targetName stageName extraDeps =+ let filesInMap = zip extraDeps $ map (`Map.lookup` tdb) $ hashExtraDeps targetName stageName extraDeps+ checkTimeStamps acc (file, Nothing) = do+ doesExist <- D.doesFileExist $ T.unpack file+ if doesExist+ then return True+ else do+ ANSI.setSGR [ANSI.SetConsoleIntensity ANSI.BoldIntensity, ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Black, ANSI.SetColor ANSI.Background ANSI.Vivid ANSI.Yellow]+ putStr $ "WARNING:"+ ANSI.setSGR [ANSI.Reset]+ putStrLn $ " Missing extra dependency \"" ++ T.unpack file ++ "\", check build configuration."+ return acc+ checkTimeStamps b (file, Just s) = do+ timestamp <- getTimestamp file+ let result = b || (timestamp /= s)+ if timestamp == 0+ then do+ ANSI.setSGR [ANSI.SetConsoleIntensity ANSI.BoldIntensity, ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Black, ANSI.SetColor ANSI.Background ANSI.Vivid ANSI.Yellow]+ putStr $ "WARNING:"+ ANSI.setSGR [ANSI.Reset]+ putStrLn $ " Missing extra dependency \"" ++ T.unpack file ++ "\", check build configuration."+ return result+ else+ return result+ in foldM checkTimeStamps False filesInMap+ getTimestamp :: T.Text -> IO Integer-getTimestamp f = do- let unpackedFileName = T.unpack f+getTimestamp file = do+ let unpackedFileName = T.unpack file doesExist <- D.doesFileExist unpackedFileName- if doesExist then D.getModificationTime unpackedFileName >>= extractSeconds else return 0- where extractSeconds s = return $ (fromIntegral.fromEnum.utcTimeToPOSIXSeconds) s+ if doesExist+ then do+ modificationTime <- D.getModificationTime unpackedFileName+ return $ (fromIntegral.fromEnum.utcTimeToPOSIXSeconds) modificationTime+ else+ return 0 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+ return $ Map.lookup key cdb /= Just cs -getChecksumPair :: [T.Text] -> [T.Text] -> (T.Text, Word32)+getChecksumPair :: [T.Text] -> [T.Text] -> (Word32, Word32) getChecksumPair s d = let joinedSrc = T.concat $ L.intersperse ":" s joinedDest = T.concat $ L.intersperse ":" d- in (joinedDest, Hash.crc32 (TE.encodeUtf8 joinedSrc))+ in (hashText joinedDest, hashText joinedSrc) buildFoldFunc :: StageResults -> Target -> BuildM StageResults buildFoldFunc l@(Left _) _ = return l@@ -360,107 +416,159 @@ put $ putCurrentTargetName newBuildState oldTargetName return result -isRight :: Either a b -> Bool-isRight (Right _) = True-isRight _ = False- runTarget :: Target -> BuildM StageResults runTarget t@(Target name _ deps _ _) = do buildState <- get let outdatedTargets = filter (not.targetIsUpToDate buildState) deps depStatus <- foldM buildFoldFunc (Right []) outdatedTargets- if isRight depStatus then do- result <- runTargetInternal t- writePendingDBUpdates- return result+ if isRight depStatus then+ runTargetInternal t else buildFailFunc depStatus name buildFailFunc :: StageResults -> T.Text -> BuildM StageResults buildFailFunc (Left err) name = do- liftIO printSeparator- liftIO $ putStr $ "ERROR: Error building target \"" ++ T.unpack name ++ "\": "- liftIO $ putStrLn $ T.unpack err+ liftIO $ do+ ANSI.setSGR [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.White]+ putStrLn "============================================================"+ ANSI.setSGR [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Red]+ putStrLn $ "ERROR: Error building target \"" ++ T.unpack name ++ "\": "+ ANSI.setSGR [ANSI.Reset]+ putStrLn $ T.unpack err return $ Left "" buildFailFunc (Right _) _ = return $ Left "" runTargetInternal :: Target -> BuildM StageResults-runTargetInternal t@(Target name hashFunc _ stages gatherers) = do+runTargetInternal target@(Target name hashFunc _ stages gatherers) = do buildState <- get let tcdb = getTargetChecksumDB buildState- let checksum = hashFunc t+ let checksum = hashFunc target let forceRebuild = checksum /= Map.findWithDefault 0 name tcdb++ -- Gather input files and initialize a bunch of one-to-one mappings for them gatheredFiles <- liftIO $ runGatherers gatherers let srcTransforms = map (flip OneToOne "") gatheredFiles- liftIO $ putStrLn $ "==== Target: \"" ++ T.unpack name ++ "\""- stageResult <- foldM stageFoldFunc (Right srcTransforms) $ zip stages $ repeat forceRebuild- if isRight stageResult then targetSuccessFunc t else buildFailFunc stageResult name + -- Fold over stages, effectively running the build+ liftIO $ do+ ANSI.setSGR [ANSI.SetConsoleIntensity ANSI.BoldIntensity, ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Blue]+ putStr "==== Target: "+ ANSI.setSGR [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.White]+ putStrLn $ T.unpack name+ ANSI.setSGR [ANSI.Reset]+ stageResult <- foldM (stageFoldFunc name) (Right srcTransforms) $ zip stages $ repeat forceRebuild++ -- Update target checksum to prevent future, forced builds+ currentBuildState <- get+ let updatedChecksums = Map.insert name checksum $ getTargetChecksumDB currentBuildState+ put $ putTargetChecksumDB currentBuildState updatedChecksums++ -- Run success or failure function based on the build result+ if isRight stageResult then targetSuccessFunc target else buildFailFunc stageResult name+ targetSuccessFunc :: Target -> BuildM StageResults-targetSuccessFunc t@(Target name hashFunc _ _ _) = do+targetSuccessFunc target@(Target name _ _ _ _) = 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 ""+ let updatedTargets = Set.insert target $ getUpToDateTargets buildState+ put $ putUpToDateTargets buildState updatedTargets+ liftIO $ do+ ANSI.setSGR [ANSI.SetConsoleIntensity ANSI.BoldIntensity, ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Green]+ putStr "Successfully built target: "+ ANSI.setSGR [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.White]+ putStrLn $ T.unpack name+ putStrLn ""+ ANSI.setSGR [ANSI.Reset] return $ Right [] -stageFoldFunc :: StageResults -> (Stage, Bool) -> BuildM StageResults-stageFoldFunc (Right t) (s, force) = runStage s force t-stageFoldFunc l@(Left _) _ = return l+stageFoldFunc :: T.Text -> StageResults -> (Stage, Bool) -> BuildM StageResults+stageFoldFunc targetName (Right t) (stage, force) = runStage targetName stage force t+stageFoldFunc _ l@(Left _) _ = return l -workerThreadFunc :: (SrcTransform -> IO StageResult) -> MVar [SrcTransform] -> MVar (StageResults, [BuildM ()]) -> MVar (StageResults, [BuildM ()]) -> MVar Int -> IO ()-workerThreadFunc sf q r f c = do- queue <- takeMVar q+-- Type synonyms for readability+type BuildQueue = MVar [SrcTransform]+type ResultAccumulator = MVar (StageResults, [BuildM ()])+type ActiveThreadCount = MVar Int++-- dib's internal processing is handlded through a work-stealing queue.+-- A number of threads are spawned, each running this function.+-- Each thread will pull the queue out and attempt to peel off a transform to build+-- then append the result to the result accumulator.+--+-- When the queue runs out, the threads will shut themselves down until there's only+-- one thread left. The last thread will move the result accumulator to the final result MVar.+--+-- The stageHelper function is waiting for the final result to contain something+-- so it can continue with the build.+workerThreadFunc :: StageFunc -> BuildQueue -> ResultAccumulator -> ResultAccumulator -> ActiveThreadCount -> IO ()+workerThreadFunc stageFunc buildQueue resultAccumulator finalResult threadCount = do+ queue <- takeMVar buildQueue if null queue then do- putMVar q queue- count <- takeMVar c+ putMVar buildQueue queue+ count <- takeMVar threadCount let newCount = count - 1 if newCount == 0 then do- putMVar c newCount- finalResult <- readMVar r- putMVar f finalResult+ putMVar threadCount newCount+ result <- readMVar resultAccumulator+ putMVar finalResult result return () else do- putMVar c newCount+ putMVar threadCount newCount return () else do let workItem = head queue- putMVar q (tail queue)- taskResult <- sf workItem+ putMVar buildQueue (tail queue)+ taskResult <- stageFunc workItem let dbThunk = updateDatabase taskResult workItem- resultAcc <- takeMVar r+ result <- takeMVar resultAccumulator let combine left@(Left _) _ = left combine (Right ml) (Right v) = Right (v : ml) combine (Right _) (Left v) = Left v- let newResultAcc = (\(res, thunks) -> (combine res taskResult, dbThunk : thunks)) resultAcc- putMVar r newResultAcc- workerThreadFunc sf q r f c+ let newResult = (\(res, thunks) -> (combine res taskResult, dbThunk : thunks)) result+ putMVar resultAccumulator newResult+ workerThreadFunc stageFunc buildQueue resultAccumulator finalResult threadCount -stageHelper :: (SrcTransform -> IO StageResult) -> Int -> [SrcTransform] -> StageResults -> BuildM StageResults-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+stageHelper :: StageFunc -> Int -> [SrcTransform] -> StageResults -> BuildM StageResults+stageHelper stageFunc threadCount stageInput previousResult =+ if null stageInput then+ return previousResult else do- liftIO $ replicateM_ m (workerThreadFunc f queueMVar resultMVar finalResultMVar threadCountMVar)+ -- Create control variables that will hold all of the data the workers use.+ finalResultMVar <- liftIO newEmptyMVar+ resultMVar <- liftIO $ newMVar (previousResult, []) -- (overall result, database thunks)+ queueMVar <- liftIO $ newMVar stageInput+ threadCountMVar <- liftIO $ newMVar threadCount++ -- Dispatch worker threads and wait on the final result+ liftIO $ replicateM_ threadCount (workerThreadFunc stageFunc queueMVar resultMVar finalResultMVar threadCountMVar) result <- liftIO $ takeMVar finalResultMVar++ -- Issue the pending database updates. These occur here because workers live in IO, not BuildM. sequence_ $ snd result return $ fst result -runStage :: Stage -> Bool -> [SrcTransform] -> BuildM StageResults-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 (Right $ map transferUpToDateTarget upToDateTargets)- updateDatabaseExtraDeps result extraDeps+runStage :: T.Text -> Stage -> Bool -> [SrcTransform] -> BuildM StageResults+runStage targetName stage@(Stage name _ _ extraDeps stageFunc) force mappings = do+ liftIO $ do+ ANSI.setSGR [ANSI.SetConsoleIntensity ANSI.BoldIntensity, ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Magenta]+ putStr $ "== Stage: "+ ANSI.setSGR [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.White]+ putStrLn $ T.unpack name+ ANSI.setSGR [ANSI.Reset] + -- do dependency scanning and partition the mappings into ones that+ -- need building versus up-to-date mappings.+ depScannedFiles <- liftIO $ processMappings stage mappings+ (targetsToBuild, upToDateTargets) <- partitionMappings targetName name depScannedFiles extraDeps force+ let initialResult = Right $ map transferUpToDateTarget upToDateTargets++ -- run the stage+ buildState <- get+ result <- stageHelper stageFunc (getMaxBuildJobs buildState) targetsToBuild initialResult++ -- write pending database entries+ writePendingDBUpdates+ updateDatabaseExtraDeps targetName name result extraDeps+ -- These might not be quite correct. I guessed at what made sense. transferUpToDateTarget :: SrcTransform -> SrcTransform transferUpToDateTarget (OneToOne _ d) = OneToOne d ""@@ -469,23 +577,21 @@ 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+processMappings (Stage _ inputTransformer depScanner _ _) mappings = mapM depScanner $ inputTransformer mappings updateDatabase :: Either l r -> SrcTransform -> BuildM () updateDatabase (Left _) _ = return ()-updateDatabase (Right _) (OneToOne s d) = updateDatabaseHelper [s] [d]-updateDatabase (Right _) (OneToMany s ds) = updateDatabaseHelper [s] ds-updateDatabase (Right _) (ManyToOne ss d) = updateDatabaseHelper ss [d]-updateDatabase (Right _) (ManyToMany ss ds) = updateDatabaseHelper ss ds+updateDatabase (Right _) src@(OneToOne s d) = updateDatabaseHelper src [s] [d]+updateDatabase (Right _) src@(OneToMany s ds) = updateDatabaseHelper src [s] ds+updateDatabase (Right _) src@(ManyToOne ss d) = updateDatabaseHelper src ss [d]+updateDatabase (Right _) src@(ManyToMany ss ds) = updateDatabaseHelper src ss ds -updateDatabaseHelper :: [T.Text] -> [T.Text] -> BuildM ()-updateDatabaseHelper srcFiles destFiles = do+updateDatabaseHelper :: SrcTransform -> [T.Text] -> [T.Text] -> BuildM ()+updateDatabaseHelper transform srcFiles destFiles = do buildstate <- get let pdbu = getPendingDBUpdates buildstate timestamps <- liftIO $ mapM getTimestamp srcFiles- let filteredResults = filter (\(_, v) -> v /= 0) $ zip srcFiles timestamps+ let filteredResults = filter (\(_, v) -> v /= 0) $ zip (hashTransform transform) 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@@ -493,15 +599,15 @@ put $ putChecksumDB (putPendingDBUpdates buildstate updatedPDBU) updatedCDB return () -updateDatabaseExtraDeps :: StageResults -> [T.Text] -> BuildM StageResults-updateDatabaseExtraDeps result@(Left _) _ = return result-updateDatabaseExtraDeps result@(Right _) deps = do+updateDatabaseExtraDeps :: T.Text -> T.Text -> StageResults -> [T.Text] -> BuildM StageResults+updateDatabaseExtraDeps _ _ result@(Left _) _ = return result+updateDatabaseExtraDeps targetName stageName result@(Right _) deps = do buildstate <- get- let pdbu = getPendingDBUpdates buildstate+ let tdb = getTimestampDB 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+ let filteredResults = filter (\(_, v) -> v /= 0) $ zip (hashExtraDeps targetName stageName deps) timestamps+ let updatedTDB = L.foldl' (\m (k, v) -> Map.insert k v m) tdb filteredResults+ put $ putTimestampDB buildstate updatedTDB return result writePendingDBUpdates :: BuildM ()
src/Dib/Builders/C.hs view
@@ -30,6 +30,7 @@ import qualified Data.Digest.CRC32 as Hash import qualified Data.Text as T import qualified Data.Text.Encoding as TE+import qualified System.Console.ANSI as ANSI -- | The record type that is used to pass configuration info for the C builder. data CTargetInfo = CTargetInfo {@@ -79,7 +80,7 @@ -- | Given a 'CTargetInfo' and a 'Target', produces a checksum cTargetHash :: CTargetInfo -> Target -> Word32 cTargetHash info _ =- let textHash = TE.encodeUtf8 $ T.intercalate "^" [+ Hash.crc32 $ TE.encodeUtf8 $ T.intercalate "^" [ "srcDir", srcDir info, "compiler",@@ -116,8 +117,6 @@ 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@@ -181,24 +180,24 @@ } massageFilePath :: T.Text -> T.Text-massageFilePath p = T.replace "\\" "_" $ T.replace "/" "_" p+massageFilePath path = T.replace "\\" "_" $ T.replace "/" "_" path remapObjFile :: BuildLocation -> T.Text -> T.Text-remapObjFile InPlace f = f-remapObjFile (BuildDir d) f = d `T.snoc` F.pathSeparator <> massageFilePath f-remapObjFile (ObjAndBinDirs d _) f = d `T.snoc` F.pathSeparator <> massageFilePath f+remapObjFile InPlace file = file+remapObjFile (BuildDir dir) file = dir `T.snoc` F.pathSeparator <> massageFilePath file+remapObjFile (ObjAndBinDirs objDir _) file = objDir `T.snoc` F.pathSeparator <> massageFilePath file remapBinFile :: BuildLocation -> T.Text -> T.Text-remapBinFile InPlace f = f-remapBinFile (BuildDir d) f = d `T.snoc` F.pathSeparator <> f-remapBinFile (ObjAndBinDirs _ d) f = d `T.snoc` F.pathSeparator <> f+remapBinFile InPlace file = file+remapBinFile (BuildDir dir) file = dir `T.snoc` F.pathSeparator <> file+remapBinFile (ObjAndBinDirs _ binDir) file = binDir `T.snoc` F.pathSeparator <> file -- | 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 (BuildDir dir) = D.createDirectoryIfMissing True (T.unpack dir)+ helper (ObjAndBinDirs objDir binDir) = D.createDirectoryIfMissing True (T.unpack objDir) >> D.createDirectoryIfMissing True (T.unpack binDir) helper (outputLocation info) return () @@ -206,36 +205,45 @@ excludeFiles excl file = L.any (`T.isSuffixOf` file) excl getCorrectCompileFlags :: CTargetInfo -> T.Text -> T.Text-getCorrectCompileFlags info s = if ".c" `T.isSuffixOf` s then cCompileFlags info else cxxCompileFlags info+getCorrectCompileFlags info source = if ".c" `T.isSuffixOf` source then cCompileFlags info else cxxCompileFlags info -- | Given a 'CTargetInfo', produces a 'Target' makeCTarget :: CTargetInfo -> Target makeCTarget info = let includeDirString = includeOption info <> T.intercalate (" " <> includeOption info) (includeDirs info)- makeBuildString s t = T.unpack $ T.concat [compiler info, " ", inFileOption info, " ", s, " ", outFileOption info, " ", t, " ", includeDirString, " ", commonCompileFlags info, " ", getCorrectCompileFlags info s]- 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]+ makeBuildString source target = T.unpack $ T.concat [compiler info, " ", inFileOption info, " ", source, " ", outFileOption info, " ", target, " ", includeDirString, " ", commonCompileFlags info, " ", getCorrectCompileFlags info source]+ makeLinkString sources target = T.unpack $ T.concat [linker info, " ", T.unwords sources, " ", outFileOption info, " ", target, " ", linkFlags info]+ makeArchiveString sources target = T.unpack $ T.concat [archiver info, " ", archiverFlags info, " ", target, " ", T.unwords sources] - buildCmd (ManyToOne ss t) = do- let sourceFile = head ss- let buildString = makeBuildString sourceFile t- putStrLn $ "Building: " ++ T.unpack sourceFile+ buildCmd (ManyToOne sources target) = do+ let sourceFile = head sources+ let buildString = makeBuildString sourceFile target+ ANSI.setSGR [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.White]+ putStr "Building: "+ ANSI.setSGR [ANSI.Reset]+ putStrLn $ T.unpack sourceFile exitCode <- system buildString- handleExitCode exitCode t buildString+ handleExitCode exitCode target buildString buildCmd _ = return $ Left "Unhandled SrcTransform." - linkCmd (ManyToOne ss t) = do- let linkString = makeLinkString ss t- putStrLn $ "Linking: " ++ T.unpack t+ linkCmd (ManyToOne sources target) = do+ let linkString = makeLinkString sources target+ ANSI.setSGR [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.White]+ putStr "Linking: "+ ANSI.setSGR [ANSI.Reset]+ putStrLn $ T.unpack target exitCode <- system linkString- handleExitCode exitCode t linkString+ handleExitCode exitCode target linkString linkCmd _ = return $ Left "Unhandled SrcTransform." - archiveCmd (ManyToOne ss t) = do- let archiveString = makeArchiveString ss t- putStrLn $ "Archiving: " ++ T.unpack t+ archiveCmd (ManyToOne sources target) = do+ let archiveString = makeArchiveString sources target+ ANSI.setSGR [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.White]+ putStr "Archiving: "+ ANSI.setSGR [ANSI.Reset]+ putStrLn $ T.unpack target exitCode <- system archiveString- handleExitCode exitCode t archiveString+ handleExitCode exitCode target archiveString archiveCmd _ = return $ Left "Unhandled SrcTransform." buildDirGatherer = makeCommandGatherer $ makeBuildDirs info@@ -245,29 +253,32 @@ 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.dropWhileEnd (/='.') l <> newExt+changeExt newExt buildLoc (OneToOne input _) = OneToOne input $ remapObjFile buildLoc $ T.dropWhileEnd (/='.') input <> newExt changeExt _ _ _ = undefined combineTransforms :: T.Text -> [SrcTransform] -> [SrcTransform]-combineTransforms t st = [ManyToOne sources t]- where sources = foldl' (\l (OneToOne s _) -> l ++ [s]) [] st+combineTransforms target transforms = [ManyToOne (L.sort sources) target]+ where sources = foldl' (\acc (OneToOne input _) -> acc ++ [input]) [] transforms -- | 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)+ let cleanCmd (OneToOne input _) = do+ ANSI.setSGR [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.White]+ putStr "Removing: "+ ANSI.setSGR [ANSI.Reset]+ putStrLn $ T.unpack input+ D.removeFile (T.unpack input) return $ Right $ OneToOne "" "" cleanCmd _ = error "Should never hit this." objDir InPlace = srcDir info- objDir (BuildDir d) = d- objDir (ObjAndBinDirs d _) = d+ objDir (BuildDir dir) = dir+ objDir (ObjAndBinDirs objDir _) = objDir programFile InPlace = outputName info- programFile (BuildDir d) = d `T.snoc` F.pathSeparator <> outputName info- programFile (ObjAndBinDirs _ d) = d `T.snoc` F.pathSeparator <> outputName info+ programFile (BuildDir dir) = dir `T.snoc` F.pathSeparator <> outputName info+ programFile (ObjAndBinDirs _ binDir) = binDir `T.snoc` F.pathSeparator <> outputName info cleanStage = Stage "clean" id return [] cleanCmd objectGatherer = makeFileTreeGatherer (objDir $ outputLocation info) (matchExtension ".o")
src/Dib/Builders/Copy.hs view
@@ -10,26 +10,30 @@ import Dib.Types import qualified Data.Text as T+import qualified System.Console.ANSI as ANSI import qualified System.Directory as D import System.FilePath as P copyFunc :: SrcTransform -> IO StageResult-copyFunc (OneToOne s t) = do- let unpackedTarget = T.unpack t- let unpackedSource = T.unpack s+copyFunc (OneToOne source target) = do+ let unpackedTarget = T.unpack target+ let unpackedSource = T.unpack source D.createDirectoryIfMissing True $ takeDirectory unpackedTarget- putStrLn $ "Copying: " ++ unpackedSource ++ " -> " ++ unpackedTarget+ ANSI.setSGR [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.White]+ putStr "Copying: "+ ANSI.setSGR [ANSI.Reset]+ putStrLn $ unpackedSource ++ " -> " ++ unpackedTarget D.copyFile unpackedSource unpackedTarget- return $ Right (OneToOne t "")+ return $ Right (OneToOne target "") copyFunc _ = return $ Left "Unexpected SrcTransform" remapFile :: String -> String -> SrcTransform -> SrcTransform-remapFile src dest (OneToOne s _) = OneToOne s $ T.pack $ dest </> makeRelative src (T.unpack s)+remapFile src dest (OneToOne source _) = OneToOne source $ T.pack $ dest </> makeRelative src (T.unpack source) 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 =+makeCopyTarget name src dest filterFunc 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]+ in Target name (const 0) [] [stage] [makeFileTreeGatherer src filterFunc]
src/Dib/Builders/Simple.hs view
@@ -13,23 +13,27 @@ import Dib.Util import qualified Data.Text as T+import qualified System.Console.ANSI as ANSI import qualified System.Directory as D import System.Process (system) import System.FilePath as P buildFunc :: (String -> String -> String) -> SrcTransform -> IO StageResult-buildFunc func (OneToOne s t) = do- let unpackedTarget = T.unpack t- let unpackedSource = T.unpack s+buildFunc func (OneToOne source target) = do+ let unpackedTarget = T.unpack target+ let unpackedSource = T.unpack source D.createDirectoryIfMissing True $ takeDirectory unpackedTarget- putStrLn $ "Building: " ++ unpackedSource ++ " -> " ++ unpackedTarget+ ANSI.setSGR [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.White]+ putStr "Building: "+ ANSI.setSGR [ANSI.Reset]+ putStrLn $ unpackedSource ++ " -> " ++ unpackedTarget let buildCmd = func unpackedSource unpackedTarget exitCode <- system buildCmd- handleExitCode exitCode t buildCmd+ handleExitCode exitCode target buildCmd buildFunc _ _ = return $ Left "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 src dest ext (OneToOne source _) = OneToOne source $ T.pack $ dest </> makeRelative src (T.unpack (changeExt source ext)) remapFile _ _ _ _ = error "Unhandled SrcTransform" changeExt :: T.Text -> T.Text -> T.Text@@ -39,6 +43,6 @@ -- 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 =+makeSimpleTarget name src dest ext filterFunc 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]+ in Target name (const 0) [] [stage] [makeFileTreeGatherer src filterFunc]
src/Dib/Scanners/CDepScanner.hs view
@@ -9,6 +9,7 @@ ) where import Dib.Types+import qualified Data.List as L import qualified Data.Set as S import qualified Data.Text as T import qualified System.Directory as Dir@@ -112,41 +113,41 @@ spider :: forall (m :: * -> *).(MonadIO m, MonadState ParseState m) => String -> m () spider file = do- s <- get- paths <- filterM (includeFilter $ currentDeps s) $ possibleFilenames file (searchPaths s)+ state <- get+ paths <- filterM (includeFilter $ currentDeps state) $ possibleFilenames file (searchPaths state) spiderHelper paths return () where- includeFilter deps f = do- exists <- liftIO $ Dir.doesFileExist f- return $ exists && not (S.member (pathToDependency f) deps)+ includeFilter deps file = do+ exists <- liftIO $ Dir.doesFileExist file+ return $ exists && not (S.member (pathToDependency file) 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) }+ contents <- liftIO $ readFile file+ let deps = gatherDependencies contents+ state <- get+ put $ state {currentDeps = S.insert (pathToDependency file) (currentDeps state) } 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+ contents <- liftIO $ readFile file+ let deps = gatherDependencies contents 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))+ (_, state) <- runStateT (runDepGatherer $ spiderLauncher file) PS {currentDeps=S.empty, searchPaths=[F.dropFileName file, "."] ++ includeDirs }+ return $ L.sort $ map (T.pack.getPathFromDep) (S.toList (currentDeps state)) -- | 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 includeDirs (OneToOne input output) = getDepsForFile includeDirs (T.unpack input) >>= \deps -> return $ ManyToOne (input:deps) output+cDepScanner includeDirs (OneToMany input output) = getDepsForFile includeDirs (T.unpack input) >>= \deps -> return $ ManyToMany (input:deps) output cDepScanner _ _ = error "Unimplemented. Implement this if it is a valid relationship."
src/Dib/Types.hs view
@@ -18,18 +18,28 @@ import Data.Word -- | Type wrapper for the timestamp database.-type TimestampDB = Map.Map T.Text Integer+-- Maps checksums to timestamps.+type TimestampDB = Map.Map Word32 Integer+ -- | Type wrapper for the target timestamp database.+-- Maps target names to timestamp databases type TargetTimestampDB = Map.Map T.Text TimestampDB+ -- | Type wrapper for the checksum database.-type ChecksumDB = Map.Map T.Text Word32+-- Maps checksum of muxed destination string to checksum of muxed source string+type ChecksumDB = Map.Map Word32 Word32+ -- | Type wrapper for the target checksum database.+-- Maps target name to target-specific checksum 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 PendingDBUpdates = Map.Map Word32 Integer+ -- | Type wrapper for the dictionary of arguments that are extracted from the -- command line. type ArgDict = Map.Map String String