packages feed

dib 0.6.1 → 0.7.0

raw patch · 13 files changed

+151/−113 lines, 13 files

Files

LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2010-2016 Brett Lajzer+Copyright (c) 2010-2018 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
Main.hs view
@@ -1,4 +1,4 @@--- Copyright (c) 2010-2016 Brett Lajzer+-- Copyright (c) 2010-2018 Brett Lajzer -- See LICENSE for license information.  -- | This is the command-line executable "dib". Since Dib proper is a@@ -167,16 +167,16 @@       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 +      hClose verFile  requoteArg :: String -> String requoteArg arg = requoteArgInternal arg False@@ -191,7 +191,7 @@   D.createDirectoryIfMissing False ".dib"   needToRebuild <- checkDibTimestamps   rebuild needToRebuild-  let quotes = if os =="mingw32" then "\"\"" else "" +  let quotes = if os =="mingw32" then "\"\"" else ""   system $ quotes ++ correctExe ++ quotes ++ " +RTS -N -RTS " ++ args  shouldHandleInit :: [String] -> Bool
dib.cabal view
@@ -1,5 +1,5 @@ name:           dib-version:        0.6.1+version:        0.7.0 cabal-version:  >= 1.6 category:		Development build-type:     Simple@@ -17,7 +17,7 @@ source-repository this   type: git   location: https://github.com/blajzer/dib.git-  tag: 0.6.1+  tag: 0.7.0  library   build-depends:   base >= 4.4 && < 4.10, text, containers, mtl, directory, time, process, filepath, cereal, bytestring, digest@@ -31,4 +31,3 @@   ghc-options:     -Wall   hs-source-dirs:  .   main-is:         Main.hs-
src/Dib.hs view
@@ -1,4 +1,4 @@--- Copyright (c) 2010-2016 Brett Lajzer+-- Copyright (c) 2010-2018 Brett Lajzer -- See LICENSE for license information.  -- | = Introduction@@ -43,14 +43,14 @@ -- -- An example of using the C Builder to build an executable called "myProject" with -- its source code in the "src/" directory is as follows:--- +-- -- @ -- module Main where--- +-- -- import Dib -- import Dib.Builders.C -- import qualified Data.Text as T--- +-- -- projectInfo = defaultGCCConfig { --   outputName = "myProject", --   targetName = "myProject",@@ -60,17 +60,17 @@ --   outputLocation = ObjAndBinDirs "obj" ".", --   includeDirs = ["src"] -- }--- +-- -- project = makeCTarget projectInfo -- clean = makeCleanTarget projectInfo--- +-- -- targets = [project, clean]--- +-- -- main = dib targets -- @--- --- This was generated with @dib --init c myProject gcc src@.  --+-- This was generated with @dib --init c myProject gcc src@.+-- -- 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@@ -92,7 +92,8 @@   dib,   getArgDict,   addEnvToDict,-  makeArgDictLookupFunc+  makeArgDictLookupFunc,+  makeArgDictLookupFuncChecked   ) where  import Dib.Gatherers@@ -132,29 +133,41 @@   hSetBuffering stderr LineBuffering   args <- Env.getArgs   numProcs <- GHC.getNumProcessors++  -- Validate that we have at least one target+  if targets == [] then putStrLn $ "ERROR: Invalid configuration, no targets defined." else do+   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+  -- Validate targets+  let targetErrors = validateTargets allTargets+  if isJust targetErrors then putStrLn $ "ERROR: Invalid targets:\n" ++ fromJust targetErrors else do -      dbSaveStart <- getCurrentTime-      saveDatabase (getTargetTimestampDB s) (getChecksumDB s) (getTargetChecksumDB s)-      dbSaveEnd <- getCurrentTime+  -- Validate that we're trying to build something that exists+  if isNothing theTarget then putStrLn $ "ERROR: Invalid target specified: \"" ++ T.unpack selectedTarget ++ "\"" else do -      putStrLn $ "DB load/save took " ++ show (diffUTCTime dbLoadEnd dbLoadStart) ++ "/" ++ show (diffUTCTime dbSaveEnd dbSaveStart) ++ " seconds."-      putStrLn $ "Build took " ++ show (diffUTCTime endTime startTime) ++ " seconds."-      return ()+  -- load the database+  dbLoadStart <- getCurrentTime+  (tdb, cdb, tcdb) <- loadDatabase+  dbLoadEnd <- 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++  -- 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."+ 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)@@ -167,6 +180,12 @@       targetsMinusInitial = L.filter (\x -> x /= head t) allTargets   in head t : targetsMinusInitial +validateTargets :: [Target] -> Maybe String+validateTargets ts =+  let targetErrors = L.foldl' (\acc t -> acc ++ validate t) "" ts+      validate (Target name _ _ stages gatherers) = if length stages > 0 && length gatherers == 0 then (T.unpack name) ++ ": target requires at least one gatherer since it specifies at least one stage.\n" else ""+  in if targetErrors == "" then Nothing else Just targetErrors+ extractVarsFromArgs :: [String] -> ArgDict extractVarsFromArgs args = L.foldl' extractVarsFromArgsInternal Map.empty $ map (L.break (== '=')) args   where@@ -205,6 +224,19 @@ makeArgDictLookupFunc :: String -> String -> ArgDict -> String makeArgDictLookupFunc arg defVal dict = fromMaybe defVal $ Map.lookup arg dict +-- | 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, and+-- checking success against a list of valid values.+-- Returns an error string on Left, and success string on Right.+makeArgDictLookupFuncChecked :: String -> String -> [String] -> ArgDict -> Either String String+makeArgDictLookupFuncChecked arg defVal validValues dict =+    let partialResult = makeArgDictLookupFunc arg defVal dict+        result = L.find (== partialResult) validValues+    in if isJust result then+        Right $ fromJust result+      else+        Left $ "ERROR: invalid value \"" ++ partialResult ++ "\" for argument \"" ++ arg ++ "\". Expected one of: [" ++ L.intercalate  ", " validValues ++ "]"+ printSeparator :: IO () printSeparator = putStrLn "============================================================" @@ -319,8 +351,9 @@       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+buildFoldFunc :: StageResults -> Target -> BuildM StageResults+buildFoldFunc l@(Left _) _ = return l+buildFoldFunc (Right _) t@(Target name _ _ _ _) = do   buildState <- get   let oldTargetName = getCurrentTargetName buildState   put $ putCurrentTargetName buildState name@@ -329,33 +362,31 @@   put $ putCurrentTargetName newBuildState oldTargetName   return result -buildFoldFunc r@(Right _) _ = return r--isLeft :: Either a b -> Bool-isLeft (Left _) = True-isLeft _ = False+isRight :: Either a b -> Bool+isRight (Right _) = True+isRight _ = False -runTarget :: Target -> BuildM (Either [SrcTransform] T.Text)+runTarget :: Target -> BuildM StageResults 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+  depStatus <- foldM buildFoldFunc (Right []) outdatedTargets+  if isRight 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+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-  return $ Right ""-buildFailFunc (Left _) _ = return $ Right ""+  return $ Left ""+buildFailFunc (Right _) _ = return $ Left "" -runTargetInternal :: Target -> BuildM (Either [SrcTransform] T.Text)+runTargetInternal :: Target -> BuildM StageResults runTargetInternal t@(Target name hashFunc _ stages gatherers) = do   buildState <- get   let tcdb = getTargetChecksumDB buildState@@ -364,10 +395,10 @@   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+  stageResult <- foldM stageFoldFunc (Right srcTransforms) $ zip stages $ repeat forceRebuild+  if isRight stageResult then targetSuccessFunc t else buildFailFunc stageResult name -targetSuccessFunc :: Target -> BuildM (Either [SrcTransform] T.Text)+targetSuccessFunc :: Target -> BuildM StageResults targetSuccessFunc t@(Target name hashFunc _ _ _) = do   buildState <- get   let updatedTargets = Set.insert t $ getUpToDateTargets buildState@@ -375,13 +406,13 @@   put $ putTargetChecksumDB (putUpToDateTargets buildState updatedTargets) updatedChecksums   liftIO $ putStrLn $ "Successfully built target \"" ++ T.unpack name ++ "\""   liftIO $ putStrLn ""-  return $ Left []+  return $ Right [] -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+stageFoldFunc :: StageResults -> (Stage, Bool) -> BuildM StageResults+stageFoldFunc (Right t) (s, force) = runStage s force t+stageFoldFunc l@(Left _) _ = return l -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 :: (SrcTransform -> IO StageResult) -> MVar [SrcTransform] -> MVar (StageResults, [BuildM ()]) -> MVar (StageResults, [BuildM ()]) -> MVar Int -> IO () workerThreadFunc sf q r f c = do   queue <- takeMVar q   if null queue then do@@ -402,14 +433,14 @@       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 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 -stageHelper :: (SrcTransform -> IO (Either SrcTransform T.Text)) -> Int -> [SrcTransform] -> Either [SrcTransform] T.Text -> BuildM (Either [SrcTransform] T.Text)+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)@@ -423,13 +454,13 @@       sequence_ $ snd result       return $ fst result -runStage :: Stage -> Bool -> [SrcTransform] -> BuildM (Either [SrcTransform] T.Text)+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 (Left $ map transferUpToDateTarget upToDateTargets)+  result <- stageHelper f (getMaxBuildJobs bs) targetsToBuild (Right $ map transferUpToDateTarget upToDateTargets)   updateDatabaseExtraDeps result extraDeps  -- These might not be quite correct. I guessed at what made sense.@@ -445,11 +476,11 @@   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+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  updateDatabaseHelper :: [T.Text] -> [T.Text] -> BuildM () updateDatabaseHelper srcFiles destFiles = do@@ -464,9 +495,9 @@   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+updateDatabaseExtraDeps :: StageResults -> [T.Text] -> BuildM StageResults+updateDatabaseExtraDeps result@(Left _) _ = return result+updateDatabaseExtraDeps result@(Right _) deps = do   buildstate <- get   let pdbu = getPendingDBUpdates buildstate   timestamps <- liftIO $ mapM getTimestamp deps
src/Dib/Builders/C.hs view
@@ -1,4 +1,4 @@--- Copyright (c) 2010-2016 Brett Lajzer+-- Copyright (c) 2010-2018 Brett Lajzer -- See LICENSE for license information.  -- | A builder for C/C++ code.@@ -17,9 +17,11 @@ import Dib.Gatherers import Dib.Target import Dib.Types+import Dib.Util import Dib.Scanners.CDepScanner  import Data.List as L+import Data.Monoid import Data.Word import System.Process (system) import System.Directory as D@@ -184,13 +186,13 @@  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+remapObjFile (BuildDir d) f = d `T.snoc` F.pathSeparator <> massageFilePath f+remapObjFile (ObjAndBinDirs d _) f = d `T.snoc` F.pathSeparator <> 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+remapBinFile (BuildDir d) f = d `T.snoc` F.pathSeparator <> f+remapBinFile (ObjAndBinDirs _ d) f = d `T.snoc` F.pathSeparator <> f  -- | Given a 'CTargetInfo', will make the directories required to build the project. makeBuildDirs :: CTargetInfo -> IO ()@@ -210,7 +212,7 @@ -- | 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)+  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]@@ -221,21 +223,21 @@         putStrLn $ "Building: " ++ T.unpack sourceFile         exitCode <- system buildString         handleExitCode exitCode t buildString-      buildCmd _ = return $ Right "Unhandled SrcTransform."+      buildCmd _ = return $ Left "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."+      linkCmd _ = return $ Left "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."+      archiveCmd _ = return $ Left "Unhandled SrcTransform."        buildDirGatherer = makeCommandGatherer $ makeBuildDirs info       cppStage = Stage "compile" (map (changeExt "o" (outputLocation info))) (cDepScanner (map T.unpack $ includeDirs info)) (extraCompileDeps info) buildCmd@@ -244,13 +246,9 @@   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 newExt b (OneToOne l _) = OneToOne l $ remapObjFile b $ (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@@ -261,7 +259,7 @@   let cleanCmd (OneToOne s _) = do         putStrLn $ "removing: " ++ T.unpack s         D.removeFile (T.unpack s)-        return $ Left $ OneToOne "" ""+        return $ Right $ OneToOne "" ""       cleanCmd _ = error "Should never hit this."        objDir InPlace = srcDir info@@ -269,10 +267,10 @@       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+      programFile (BuildDir d) = d `T.snoc` F.pathSeparator <> outputName info+      programFile (ObjAndBinDirs _ d) = d `T.snoc` F.pathSeparator <> 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]+  in Target ("clean-" <> targetName info) (const 0) [] [cleanStage] [objectGatherer, programGatherer]
src/Dib/Builders/Copy.hs view
@@ -1,4 +1,4 @@--- Copyright (c) 2010-2016 Brett Lajzer+-- Copyright (c) 2010-2018 Brett Lajzer -- See LICENSE for license information.  -- | A trivial builder that copies a directory tree from one location to another.@@ -13,15 +13,15 @@ import qualified System.Directory as D import System.FilePath as P -copyFunc :: SrcTransform -> IO (Either SrcTransform T.Text)+copyFunc :: SrcTransform -> IO StageResult 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"+  return $ Right (OneToOne t "")+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)
src/Dib/Builders/Simple.hs view
@@ -1,4 +1,4 @@--- Copyright (c) 2010-2016 Brett Lajzer+-- Copyright (c) 2010-2018 Brett Lajzer -- See LICENSE for license information.  -- | The Simple builder allows you to execute a 'OneToOne' trasformation@@ -10,6 +10,7 @@  import Dib.Gatherers import Dib.Types+import Dib.Util  import qualified Data.Text as T import qualified System.Directory as D@@ -17,7 +18,7 @@ import System.Exit import System.FilePath as P -buildFunc :: (String -> String -> String) -> SrcTransform -> IO (Either SrcTransform T.Text)+buildFunc :: (String -> String -> String) -> SrcTransform -> IO StageResult buildFunc func (OneToOne s t) = do   let unpackedTarget = T.unpack t   let unpackedSource = T.unpack s@@ -26,7 +27,7 @@   let buildCmd = func unpackedSource unpackedTarget   exitCode <- system buildCmd   handleExitCode exitCode t buildCmd-buildFunc _ _ = return $ Right "Unexpected SrcTransform"+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))@@ -34,11 +35,6 @@  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,
src/Dib/Gatherers.hs view
@@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}--- Copyright (c) 2010-2016 Brett Lajzer+-- Copyright (c) 2010-2018 Brett Lajzer -- See LICENSE for license information.  -- | Module that exposes all of the various 'GatherStrategy' types and functions
src/Dib/Scanners/CDepScanner.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, ExistentialQuantification, KindSignatures, FlexibleContexts #-}--- Copyright (c) 2010-2016 Brett Lajzer+-- Copyright (c) 2010-2018 Brett Lajzer -- See LICENSE for license information.  -- | C dependency scanner. Runs a stripped-down pre-processor to scan for@@ -13,7 +13,7 @@ import qualified Data.Text as T import qualified System.Directory as Dir import qualified System.FilePath as F-import Control.Applicative+import Control.Applicative() import Control.Monad.State.Lazy  data Dependency = Dependency String String@@ -150,4 +150,3 @@ 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
@@ -1,4 +1,4 @@--- Copyright (c) 2010-2016 Brett Lajzer+-- Copyright (c) 2010-2018 Brett Lajzer -- See LICENSE for license information.  -- | Module exposing the 'Stage' type and related type wrappers, along with a@@ -15,4 +15,4 @@  -- | A stage that does nothing and just passes the 'SrcTransform's through. emptyStage :: Stage-emptyStage = Stage "empty" id return [] (return.Left)+emptyStage = Stage "empty" id return [] (return.Right)
src/Dib/Target.hs view
@@ -1,4 +1,4 @@--- Copyright (c) 2010-2016 Brett Lajzer+-- Copyright (c) 2010-2018 Brett Lajzer -- See LICENSE for license information.  -- | Module that exposes the 'Target' data type and a handful of convenience functions
src/Dib/Types.hs view
@@ -2,14 +2,14 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide, prune #-} --- Copyright (c) 2010-2016 Brett Lajzer+-- Copyright (c) 2010-2018 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.Applicative+import Control.Applicative() import Control.Monad.State as S import qualified Data.Map as Map import qualified Data.Serialize as Serialize@@ -70,9 +70,14 @@ -- a 'SrcTransform' with dependencies included in the input. type DepScanner = (SrcTransform -> IO SrcTransform) +-- | Type wrapper for the result of a 'StageFunc'.+-- Left indicates an error while Right indicates success.+type StageResult = Either T.Text SrcTransform+type StageResults = Either T.Text [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 StageFunc = (SrcTransform -> IO StageResult)  -- | Type describing a build stage. -- Takes a name, an 'InputTransformer', 'DepScanner', additional dependencies, and the builder function.
src/Dib/Util.hs view
@@ -1,12 +1,17 @@--- Copyright (c) 2010-2016 Brett Lajzer+-- Copyright (c) 2010-2018 Brett Lajzer -- See LICENSE for license information.  -- | Module containing utility functions and common functionality. module Dib.Util (-  getSubDirectories+  getSubDirectories,+  handleExitCode   ) where +import Dib.Types++import System.Exit (ExitCode(ExitSuccess, ExitFailure)) import Control.Monad+import qualified Data.Text as T import qualified System.Directory as D  -- | Given a directory, returns the list of subdirectories.@@ -16,3 +21,8 @@   let filteredDirs = filter (\x -> x /= "." && x /= "..") contents   dirs <- filterM (\(x, _) -> D.doesDirectoryExist x) $ zip (map (root ++) filteredDirs) filteredDirs   return $ map snd dirs++-- | A utility function for handling 'ExitCode's in 'StageFunction's.+handleExitCode :: ExitCode -> T.Text -> String -> IO StageResult+handleExitCode ExitSuccess t _ = return $ Right $ OneToOne t ""+handleExitCode (ExitFailure _) _ e = return $ Left $ T.pack (show e)