diff --git a/Development/Shake/Core.hs b/Development/Shake/Core.hs --- a/Development/Shake/Core.hs +++ b/Development/Shake/Core.hs @@ -39,6 +39,7 @@ data ShakeOptions = ShakeOptions {shakeFiles :: FilePath -- ^ Where shall I store the database and journal files (defaults to @.shake@). ,shakeThreads :: Int -- ^ What is the maximum number of rules I should run in parallel (defaults to @1@). + -- To enable parallelism you may need to compile with @-threaded@. ,shakeVersion :: Int -- ^ What is the version of your build system, increment to force a complete rebuild (defaults to @1@). ,shakeVerbosity :: Verbosity -- ^ What messages to print out (defaults to 'Normal'). ,shakeStaunch :: Bool -- ^ Operate in staunch mode, where building continues even after errors (defaults to 'False'). diff --git a/Development/Shake/Database.hs b/Development/Shake/Database.hs --- a/Development/Shake/Database.hs +++ b/Development/Shake/Database.hs @@ -212,6 +212,8 @@ isReady Ready{} = True isReady _ = False + atom x = let s = show x in if ' ' `elem` s then "(" ++ s ++ ")" else s + -- Rules for each eval* function -- * Must NOT lock -- * Must have an equal return to what is stored in the db at that point @@ -241,7 +243,9 @@ join $ readIORef pend return ans case ans of - Ready r -> appendJournal journal k r -- leave the DB lock before appending + Ready r -> do + logger $ "result " ++ atom k ++ " = " ++ atom (value r) + appendJournal journal k r -- leave the DB lock before appending _ -> return () k #= Building (Pending pend) r @@ -253,6 +257,7 @@ Nothing -> evalB stack k Nothing Just (Loaded r) -> do b <- valid k (value r) + logger $ "valid " ++ show b ++ " for " ++ atom k ++ " " ++ atom (value r) if not b then evalB stack k $ Just r else checkREDCB stack k r (depends r) Just res -> return res @@ -353,27 +358,35 @@ jfile = filename <.> "journal" lock <- newLock + logger $ "readDatabase " ++ dbfile (step, status) <- readDatabase dbfile version step <- return $ incStep step b <- doesFileExist jfile (status,step) <- if not b then return (status,step) else do + logger $ "replayJournal " ++ jfile status <- replayJournal jfile version status removeFile_ jfile -- the journal potentially things at the current step, so increment my step writeDatabase dbfile version step status + logger $ "rewriteDatabase " ++ jfile return (status, incStep step) status <- newIORef status journal <- openJournal jfile version + logger "openDatabase complete" return Database{..} closeDatabase :: Database -> IO () closeDatabase Database{..} = do status <- readIORef status - writeDatabase (filename <.> "database") version step status + let dbfile = filename <.> "database" + logger $ "writeDatabase " ++ dbfile + writeDatabase dbfile version step status + logger $ "closeJournal" closeJournal journal + logger "closeDatabase complete" writeDatabase :: FilePath -> Int -> Step -> Map Key Status -> IO () diff --git a/Development/Shake/Derived.hs b/Development/Shake/Derived.hs --- a/Development/Shake/Derived.hs +++ b/Development/Shake/Derived.hs @@ -26,7 +26,7 @@ -- | Execute a system command, returning @(stdout,stderr)@. -- This function will raise an error if the exit code is non-zero. --- Before running 'systemOutput'' make sure you 'need' any required files. +-- Before running 'systemOutput' make sure you 'need' any required files. systemOutput :: FilePath -> [String] -> Action (String, String) systemOutput path args = do let path2 = toNative path diff --git a/Examples/C/Main.hs b/Examples/C/Main.hs new file mode 100644 --- /dev/null +++ b/Examples/C/Main.hs @@ -0,0 +1,28 @@ + +module Examples.C.Main(main) where + +import Development.Shake +import Development.Shake.FilePath +import Examples.Util + +main = shaken noTest $ \args obj -> do + let src = "Examples/C" + want [obj "Main.exe"] + + obj "Main.exe" *> \out -> do + cs <- getDirectoryFiles src "*.c" + let os = map (obj . flip replaceExtension "o") cs + need os + system' "gcc" $ ["-o",out] ++ os + + obj "*.o" *> \out -> do + let c = src takeBaseName out <.> "c" + need [c] + headers <- cIncludes c + need $ map (() src . takeFileName) headers + system' "gcc" ["-o",out,"-c",c] + +cIncludes :: FilePath -> Action [FilePath] +cIncludes x = do + (stdout,_) <- systemOutput "gcc" ["-MM",x] + return $ drop 2 $ words stdout diff --git a/Examples/Self/Main.hs b/Examples/Self/Main.hs --- a/Examples/Self/Main.hs +++ b/Examples/Self/Main.hs @@ -74,4 +74,4 @@ cabalBuildDepends :: String -> [String] cabalBuildDepends _ = words $ "base transformers binary unordered-containers hashable time old-time bytestring " ++ - "filepath directory process deepseq" + "filepath directory process deepseq random" diff --git a/Examples/Util.hs b/Examples/Util.hs --- a/Examples/Util.hs +++ b/Examples/Util.hs @@ -9,6 +9,7 @@ import Data.List import System.Directory as IO import System.Environment +import System.Random shaken @@ -37,6 +38,13 @@ when b $ renameFile tempfile dbfile shake shakeOptions{shakeFiles=out, shakeLint=True} $ rules args (out++) -} + + "perturb":args -> forever $ do + del <- removeFilesRandom out + threads <- randomRIO (1,4) + putStrLn $ "## TESTING PERTURBATION (" ++ show del ++ " files, " ++ show threads ++ " threads)" + shake shakeOptions{shakeFiles=out, shakeThreads=threads, shakeVerbosity=Quiet} $ rules args (out++) + args -> do (flags,args) <- return $ partition ("-" `isPrefixOf`) args let f o x = let x2 = dropWhile (== '-') x in case lookup x2 flagList of @@ -93,4 +101,33 @@ -- | Sleep long enough for the modification time resolution to catch up sleepFileTime :: IO () sleepFileTime = sleep 1 + + +removeFilesRandom :: FilePath -> IO Int +removeFilesRandom x = do + files <- getDirectoryContentsRecursive x + n <- randomRIO (0,length files) + rs <- replicateM (length files) (randomIO :: IO Double) + mapM_ (removeFile . snd) $ sort $ zip rs files + return n + + +getDirectoryContentsRecursive :: FilePath -> IO [FilePath] +getDirectoryContentsRecursive dir = do + xs <- IO.getDirectoryContents dir + (dirs,files) <- partitionM doesDirectoryExist [dir x | x <- xs, not $ isBadDir x] + rest <- concatMapM getDirectoryContentsRecursive dirs + return $ files++rest + where + isBadDir x = "." `isPrefixOf` x || "_" `isPrefixOf` x + +partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a]) +partitionM f [] = return ([], []) +partitionM f (x:xs) = do + res <- f x + (as,bs) <- partitionM f xs + return ([x|res]++as, [x|not res]++bs) + +concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] +concatMapM f = liftM concat . mapM f diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -7,6 +7,7 @@ import Examples.Util(flags) import qualified Examples.Tar.Main as Tar import qualified Examples.Self.Main as Self +import qualified Examples.C.Main as C import qualified Examples.Test.Basic1 as Basic1 import qualified Examples.Test.Directory as Directory import qualified Examples.Test.Errors as Errors @@ -18,7 +19,7 @@ fakes = ["clean" * clean, "test" * test] where (*) = (,) -mains = ["tar" * Tar.main, "self" * Self.main +mains = ["tar" * Tar.main, "self" * Self.main, "c" * C.main ,"basic1" * Basic1.main, "directory" * Directory.main, "errors" * Errors.main ,"filepath" * FilePath.main, "files" * Files.main, "pool" * Pool.main] where (*) = (,) diff --git a/shake.cabal b/shake.cabal --- a/shake.cabal +++ b/shake.cabal @@ -1,7 +1,7 @@ cabal-version: >= 1.6 build-type: Simple name: shake -version: 0.2 +version: 0.2.1 license: BSD3 license-file: LICENSE category: Development @@ -87,6 +87,8 @@ executable shake main-is: Main.hs + build-depends: + random if flag(testprog) buildable: True else @@ -94,11 +96,12 @@ other-modules: Examples.Util + Examples.C.Main Examples.Self.Main + Examples.Tar.Main Examples.Test.Basic1 Examples.Test.Directory Examples.Test.Errors Examples.Test.FilePath Examples.Test.Files Examples.Test.Pool - Examples.Tar.Main