rattle 0.1 → 0.2
raw patch · 44 files changed
+4477/−479 lines, 44 filesdep +Cabaldep +asyncdep +cmdargsdep ~basedep ~extradep ~shakenew-component:exe:buildScriptnew-component:exe:pipelinenew-component:exe:rattle-benchmark
Dependencies added: Cabal, async, cmdargs, heaps, js-dgtable, js-flot, js-jquery, process, template-haskell, terminal-size, unix, utf8-string
Dependency ranges changed: base, extra, shake, time
Files
- CHANGES.txt +3/−0
- LICENSE +1/−1
- README.md +111/−13
- benchmark/Benchmark.hs +29/−0
- benchmark/Benchmark/Args.hs +40/−0
- benchmark/Benchmark/FSATrace.hs +29/−0
- benchmark/Benchmark/Intro.hs +68/−0
- benchmark/Benchmark/Micro.hs +60/−0
- benchmark/Benchmark/Redis.hs +56/−0
- benchmark/Benchmark/VsMake.hs +114/−0
- html/profile.html +210/−0
- html/rattle.js +670/−0
- pipeline/Pipeline.hs +27/−0
- rattle.cabal +180/−13
- src/Development/Rattle.hs +21/−30
- src/Development/Rattle/CmdOption.hs +31/−0
- src/Development/Rattle/Derived.hs +60/−0
- src/Development/Rattle/Hash.hs +112/−27
- src/Development/Rattle/Hazards.hs +103/−0
- src/Development/Rattle/Limit.hs +0/−72
- src/Development/Rattle/Options.hs +73/−0
- src/Development/Rattle/Profile.hs +275/−0
- src/Development/Rattle/Program.hs +56/−0
- src/Development/Rattle/Server.hs +241/−161
- src/Development/Rattle/Shared.hs +107/−40
- src/Development/Rattle/Types.hs +141/−28
- src/Development/Rattle/UI.hs +134/−0
- src/General/Bilist.hs +2/−0
- src/General/Binary.hs +223/−0
- src/General/EscCodes.hs +100/−0
- src/General/Extra.hs +68/−15
- src/General/FileInfo.hs +266/−0
- src/General/FileName.hs +86/−0
- src/General/Paths.hs +50/−0
- src/General/Pool.hs +161/−0
- src/General/Template.hs +61/−0
- src/General/Thread.hs +23/−36
- test/Test.hs +48/−43
- test/Test/BuildScript.hs +53/−0
- test/Test/Example/FSATrace.hs +44/−0
- test/Test/Example/Stack.hs +166/−0
- test/Test/Simple.hs +62/−0
- test/Test/Trace.hs +49/−0
- test/Test/Type.hs +63/−0
CHANGES.txt view
@@ -1,4 +1,7 @@ Changelog for Rattle (* = breaking change) +0.2, released 2020-05-27+ Significant development and optimisation+ Explicitly disable GHC 7.10, add tests for GHC 8.0 0.1, released 2019-04-17 Initial version, not ready for public use
LICENSE view
@@ -1,4 +1,4 @@-Copyright Neil Mitchell 2019.+Copyright Neil Mitchell 2019-2020. Licensed under either of:
README.md view
@@ -1,23 +1,25 @@ # Rattle [](https://hackage.haskell.org/package/rattle) [](https://www.stackage.org/package/rattle) [](https://travis-ci.org/ndmitchell/rattle) [](https://ci.appveyor.com/project/ndmitchell/rattle) -A very early prototype of a unique build system.+_{Fast, Correct, Simple, Unfinished} - Choose four._ -A forward based build system, where you can make calls to `cmd`. These are:+To write a Rattle build system you need to write a script that builds your code. No dependencies, no targets, just a straight-line script that builds your code. Rattle takes that script, and turns it into a build system: -1) Skipped if their inputs/outputs haven't changed-2) Have their outputs copied in if only the outputs have changed-3) Can be speculated in advance+1. Rattle skips commands if their inputs/outputs haven't changed.+2. Rattle copies outputs over if a command has been run before on the same inputs (potentially for a different user).+3. Rattle guesses what commands might be coming next, and speculates of them, to increase parallelism. -The innovation over something like Fabricate is that I have a notion-of hazards - if two rules write to the same file, or one writes after-another reads, I consider that a build hazard and throw an error - the-result is no longer consistent. For speculation, I just run commands-that look useful and don't look like they'll cause a hazard. If-speculation does cause a hazard, I give up and try again without-speculation.+The closest build system to Rattle is [Fabricate](https://github.com/brushtechnology/fabricate), which follows a similar approach, but only provides step 1. Rattle extends that to steps 2 and 3. -This build system fundamentally relies on tracing the files used by system commands, and currently uses the [`fsatrace`](https://github.com/jacereda/fsatrace) program to do so, which must be installed. As a consequence of the design, if `fsatrace` fails, then `rattle` won't work properly. Example reasons that `fsatrace` might fail include:+### Advantages +Rattle build systems are simple to write - just write commands to build your project. There is only one "Rattle" specific thing, and that's running a command, giving it a tiny API. Rattle build systems can delegate to other build systems quite happily -- if a dependency is built with `make`, just shell out to `make` -- no need to recreate the dependencies with Rattle. You don't need to think about dependencies, and because you aren't writing dependencies, there's no way to get them wrong.++### Disadvantages++The disadvantages of Rattle are that only system commands are skipped, so the zero build time might not be as quick as it could. Rattle also has to guess at useful commands to get parallelism, and that might go wrong.++Rattle fundamentally relies on tracing the files used by system commands, and currently uses the [`fsatrace`](https://github.com/jacereda/fsatrace) program to do so, which must be installed. As a consequence of the design, if `fsatrace` fails, then `rattle` won't work properly. Reasons that `fsatrace` might fail include:+ * If you use Go compiled binaries on Linux or Mac then it's unlikely to be traced, see [Issue 24](https://github.com/jacereda/fsatrace/issues/24). * If you a Mac OS X 1.10 or higher then system binaries that themselves invoke system binaries they won't be traced, unless you [disable System Integrity Protection](https://developer.apple.com/library/content/documentation/Security/Conceptual/System_Integrity_Protection_Guide/ConfiguringSystemIntegrityProtection/ConfiguringSystemIntegrityProtection.html) (which you do at your own risk). * If you use statically linked binaries on Linux they probably won't be traced.@@ -26,3 +28,99 @@ * [Bigbro](https://github.com/droundy/bigbro/) uses `ptrace` so works for Go binaries and statically linked binaries. * [traced-fs](https://github.com/jacereda/traced-fs) is an unfinished file system tracer that implements a user file system that would also work for Go binaries and static linking.+* [BuildXL](https://github.com/Microsoft/BuildXL/blob/master/Documentation/Specs/Sandboxing.md#macos-sandboxing) uses a Mac sandbox based on KAuth + TrustedBSD Mandatory Access Control (MAC).++### Relationship to Shake++Rattle was designed by the same author as the [Shake build system](https://shakebuild.com/). Rattle is named as [a follow-on](https://en.wikipedia.org/wiki/Shake,_Rattle_and_Roll) from Shake, but not a replacement -- Shake continues to be actively developed and is a much more mature system.++# Rattle User Manual / Paper++_The rest of this README serves as a dumping ground for things that will either go into a user manual or an academic paper (if one ever gets written). As a result, it is a bit of a mismatch, and on top of that it's very definitely not complete._++## Abstract++Most build systems are _backwards_ build systems, users define rules to produce targets. These systems have a lot of advantages -- they encode parallelism, they are compositional and the user can easily build any subtree of dependencies. However, they require manually specifying dependencies and all the state of an object must be encoded in its filename. The alternative, and poorly studied, _forwards_ build systems are structured very differently, which we argue produces simpler systems for the end user, at least at small to medium scale.++## Introduction++In a backwards build system (e.g. Shake, Bazel, Make) a rule to build a C file will probably look something like:++```+"*.o" %> \out -> do+ let src = out -<.> "c"+ need [src]+ cmd "gcc -c" src "-o" out+```++Taking a look at this rule, it has 4 lines:++1. First line, say how to build `.o` files.+2. Compute, from the `.o` filename alone, the `.c` source it corresponds to.+3. Add an explicit dependency on the `.c` file.+4. Specify the command and run it.++Of these steps, only step 4 is truely building things, the other steps are about providing the metadata for a backwards build system to operate. And furthermore, in a practical build system, we're likely to have to go further -- encoding optimisation level in the `.o` file, and depending on any headers that were used.++To describe it as a backwards build systems is apt. In all likelihood we will have had a `.c` file in mind, then we generate the `.o` file, then we go back to the `.c` file -- all a little odd. In contrast, a forward build system can be expressed more directly:++```+buildCSrc src = cmd "gcc -c" src "-o" (src -<.> "o")+```++We can talk about the `.c` file directly, so don't need to extra information back from the output. We don't need to add dependencies. We just specify the command line. Simple.++In the rest of this paper we describe how to construct a forward build system which is as powerful as a modern fully featured backward build system. There are trade offs, particularly at scale, which we describe and in some cases mitigate.++## The no-op forward build system++We believe forward build systems should be simple, so let's take the other extreme, and think about what a build system is in it's minimality. At an absolute minimum, it must list the commands to be run. For example, to build a C executable we might say:++```+gcc -c hello.c -o hello.o+gcc hello.o -o hello.exe+```++However, we've actually gone slightly further than just listing the commands, but supplied them in an order which satisfies the dependencies. We haven't mentioned the dependencies, but we have written the link command after the compile, which is an order that does satisfy them.++Some build systems are able to build without any ordering, by restarting and retrying commands. While an interesting area of research, we don't persue that path, but see David Roundry's system.++So, given this straight-line code that builds the program what are we missing relative to a build system?++1. Build systems don't rebuild commands whose inputs haven't changed.+2. Some build systems are able to download results from a shared store (e.g. cloud build systems).+3. Backwards build systems can extract parallelism.++In the next three sections we add back each of these aspects.++## Avoid rebuilds of things that haven't changed++Given a command, if you know what files it reads and writes, and none of those files have changed, you can skip running it providing that if it were deterministic it wouldn't be harmful. As an example, if the compiler produces a different object file each time, but it would be OK with not doing that, then you're fine. In practice this means that any command that isn't relied on to produce fresh entropy (the time, a GUID, a random number) is fine to skip subsequent times. Those commands that do produce fresh entropy are not well suited to a build system anyway, so aren't typically used in build systems.++This got solved by fabricate. You can use a system access tracer to watch what a process reads/writes, and have a database storing the command, previous reads/writes, and then skip it if the values haven't changed. This step is not complex.++However, it a build writes a file _twice_ in a run, or reads it then writes to it, the result will be that a subsequent rebuild will have stuff to do, as it won't end at a quiescent state. To detect that, we introduce the concept of hazards.++## Shared build cache++Given knowledge of the reads/writes of a command, it's not too hard to store them in a cloud, and satisfy commands not by rerunning them, but by copying their result from a shared cache. While this works beautifully in theory, in practice it leads to at least three separate problems which we solve.++### Relative build dirs++Often the current directory, or users profile directory, will be accessed by commands. These change either if the user has two working directories, or if they use different machines. We solve this by having a substitution table.++### Compound commands++Sometimes a command will produce something that is user specific, but the next step will make it not user specific. To fix that we add compound commands. You can do it with a shell script, using `pipeline`, or with TemplateHaskell blocks.++### Non-deterministic builds++We solve this by having `.rattle.hash` files which we substitute for reading.++## Generating parallelism++We use speculation and hazards to figure out if speculation went wrong.++## Relative simplicity++Compare Rattle to Shake. The interface to Rattle is basically "run this command", providing a vastly simpler API. In contast, Shake has a lot of API to learn and use.
+ benchmark/Benchmark.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE RecordWildCards #-}++module Benchmark(main) where++import Benchmark.Args+import qualified Benchmark.FSATrace+import qualified Benchmark.Redis+import qualified Benchmark.Micro+import qualified Benchmark.Intro+import Control.Monad+++benchmarks =+ ["fsatrace" * Benchmark.FSATrace.main+ ,"redis" * Benchmark.Redis.main+ ,"micro" * Benchmark.Micro.main+ ,"intro" * Benchmark.Intro.main+ ]+ where (*) = (,)+++main :: IO ()+main = do+ args@Args{..} <- getArguments+ when (null names) $+ error $ "Specify which benchmarks to run, from: " ++ show (map fst benchmarks)+ forM_ names $ \name -> do+ let Just m = lookup name benchmarks+ m args
+ benchmark/Benchmark/Args.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Benchmark.Args(+ Args(..), getArguments,+ elemOrNull, orNull,+ ) where++import System.Console.CmdArgs++data Args = Args+ {names :: [String] -- the benchmarks to run+ ,threads :: [Int] -- which thread numbers to use+ ,repeat_ :: Maybe Int+ ,step :: [String] -- which steps to run+ ,commits :: Maybe Int+ ,no_stderr :: Bool+ ,count :: Maybe Int+ }+ deriving Data++mode :: Mode (CmdArgs Args)+mode = cmdArgsMode $ Args+ {names = [] &= args+ ,threads = [] &= name "j"+ ,repeat_ = Nothing+ ,step = []+ ,commits = Nothing+ ,no_stderr = False+ ,count = Nothing+ }++getArguments :: IO Args+getArguments = cmdArgsRun mode+++elemOrNull :: Eq a => a -> [a] -> Bool+elemOrNull x xs = null xs || x `elem` xs++orNull :: [a] -> [a] -> [a]+orNull xs ys = if null xs then ys else xs
+ benchmark/Benchmark/FSATrace.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE RecordWildCards #-}++module Benchmark.FSATrace(main) where++import Benchmark.VsMake+import Development.Shake.Command+import Data.List.Extra+++main :: Args -> IO ()+main = vsMake VsMake{..}+ where+ broken = ["eafc609","ad2c880","70a3926","8f298b3","c56947b"]+ repo = "https://github.com/jacereda/fsatrace"+ master = "master"+ make = cmd "make"+ rattle = mempty+ generateVersion = 1++ generate :: IO String+ generate = do+ cmd_ "make clean" (EchoStdout False)+ Stdout xs <- cmd "make -j1"+ pure $+ replace "fsatrace.exe" "fsatrace_.exe" $+ replace "-MMD" "" xs++ clean :: IO ()+ clean = cmd_ "make clean" (EchoStdout False)
+ benchmark/Benchmark/Intro.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Benchmark.Intro(main) where++import Benchmark.Args+import System.IO.Extra+import Control.Monad.Extra+import System.Time.Extra+import Data.List.Extra+import System.Directory+import Development.Shake.Command+import Development.Rattle++++writeMain :: Int -> Int -> IO ()+writeMain real fake = writeFile "main.c" $ unlines+ ["#include <stdio.h>"+ ,"char* util();"+ ,"void main(){printf(\"%s" ++ replicate real ' ' ++ "\", util());}" ++ replicate fake ' ']++writeUtil :: Int -> Int -> IO ()+writeUtil real fake = writeFile "util.c" $ unlines+ ["char* util(){return \"test" ++ replicate real ' ' ++ "\";}" ++ replicate fake ' ']++main :: Args -> IO ()+main Args{..} = withTempDir $ \dir -> withCurrentDirectory dir $ do+ writeFile "gcc.sh" "sleep 1 && gcc $*"+ cmd_ "chmod +x gcc.sh"+ let commands =+ [("-o main.exe main.o util.o","main.exe: main.o util.o")+ ,("-c util.c","util.o: util.c")+ ,("-c main.c","main.o: main.c")+ ]++ writeFile "Makefile" $ unlines $ concat+ [[b,"\t./gcc.sh " ++ a] | (a,b) <- commands]+ let rattleCmds = reverse $ map ((++) "./gcc.sh " . fst) commands++ let clean = do+ whenM (doesDirectoryExist ".rattle") $+ removeDirectoryRecursive ".rattle"+ forM_ ["main.o","util.o","main.exe"] $ \x ->+ whenM (doesFileExist x) $+ removeFile x++ forM_ (threads `orNull` [1..4]) $ \j -> do+ let make = cmd_ "make" ["-j" ++ show j] (EchoStdout False)+ let opts = rattleOptions{rattleProcesses=j, rattleUI=Just RattleQuiet, rattleNamedDirs=[]}+ let rattle = rattleRun opts $ mapM_ (cmd Shell) rattleCmds++ forM_ [("make ",make),("rattle",rattle)] $ \(name,act) -> when (trim name `elemOrNull` step) $ do+ putStr $ name ++ " -j" ++ show j ++ ": "+ hFlush stdout+ clean+ writeMain 0 0+ writeUtil 0 0+ (t1, _) <- duration act+ (t2, _) <- duration act+ writeMain 0 1+ (t3, _) <- duration act+ writeMain 1 1+ (t4, _) <- duration act+ writeMain 2 1+ writeUtil 1 0+ (t5, _) <- duration act+ putStrLn $ unwords $ map showDuration [t1,t2,t3,t4,t5]
+ benchmark/Benchmark/Micro.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Benchmark.Micro(main) where++import Benchmark.Args+import System.Process+import System.IO.Extra+import Control.Monad+import Data.Maybe+import Data.List.Extra+import System.Time.Extra+import Numeric.Extra+import Development.Shake hiding (readFile', withTempDir)+import qualified Data.ByteString as BS+import Development.Rattle++main :: Args -> IO ()+main Args{..} = do+ let clean = "make clean"+ let run = "commands.txt"+ cmds <- map words . lines <$> readFile' run++ let benchmark lbl act = when (lbl `elemOrNull` step) $ do+ putStr $ lbl ++ ": "+ hFlush stdout+ let count = fromMaybe 5 repeat_+ -- ignore the slowest few times when taking the average+ let ignore = if count >= 5 then 2 else 0+ times <- replicateM count $ withTempDir $ \dir -> do+ cmd_ Shell clean (EchoStdout False)+ fst <$> duration (act dir)+ putStrLn $ unwords (map showDuration times) ++ " = " ++ showDuration (sum (dropEnd ignore $ sort times) / intToDouble (count-ignore))++ benchmark "make" $ const $+ cmd_ "make -j1" (EchoStdout False)++ benchmark "System.Process" $ const $+ forM_ cmds $ \(command:args) ->+ callProcess command args++ benchmark "shake.cmd" $ const $+ forM_ cmds cmd_++ benchmark "shake.cmd fsatrace" $ const $+ forM_ cmds $ \xs -> cmd_ $ "fsatrace" : "rwmdqt" : "fsatrace.out" : "--" : xs++ benchmark "shake.cmd traced" $ const $+ forM_ cmds $ \xs -> do+ _ :: [FSATrace BS.ByteString] <- cmd xs+ pure ()++ let opts dir = rattleOptions{rattleFiles=dir, rattleProcesses=1, rattleUI=Just RattleQuiet, rattleNamedDirs=[]}+ benchmark "rattle" $ \dir ->+ rattleRun (opts dir){rattleSpeculate=Nothing, rattleShare=False} $+ forM_ cmds cmd++ benchmark "rattle share" $ \dir ->+ rattleRun (opts dir) $+ forM_ cmds cmd
+ benchmark/Benchmark/Redis.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE RecordWildCards #-}++module Benchmark.Redis(main) where++import Benchmark.VsMake+import Development.Shake.Command+import Data.List.Extra+import System.FilePath+import System.Directory+++main :: Args -> IO ()+main = vsMake VsMake{..}+ where+ broken = []+ -- a clone of Redis so we get stable -N history+ -- Originally "https://github.com/antirez/redis"+ repo = "https://github.com/ndmitchell/redis"+ master = "unstable"+ generateVersion = 2++ generate :: IO String+ generate = do+ cmd_ "make distclean" (EchoStdout False)+ Stdout xs <- cmd "make MALLOC=libc V=1 -j1"+ root <- getCurrentDirectory+ pure $ unlines $ fromTrace root $ lines xs++ clean :: IO ()+ clean = cmd_ "make distclean" (EchoStdout False)++ -- should touch .make-prerequisites in src and deps directories to force it to recursively+ -- rebuild stuff+ make = cmd Shell "make MALLOC=libc"+ rattle = cmd Shell+++fromTrace :: FilePath -> [String] -> [String]+fromTrace root = f []+ where+ f cwds (x:xs)+ -- make[2]: Entering directory '/home/neil/redis-5.0.7/deps'+ | Just (_, x) <- "Entering directory '" `stripInfix` x+ , let cwd = makeRelative root $ takeWhile (/= '\'') x+ = f (cwd:cwds) xs++ -- make[3]: Leaving directory '/home/neil/redis-5.0.7/deps/lua/src'+ | "Leaving directory" `isInfixOf` x = f (tail cwds) xs++ | fst (word1 x) `elem` ["cc","ar"]+ , not $ " -MM " `isInfixOf` x -- the first line generates everyones deps+ , x <- replace " -MMD " " " x -- not required+ = (case cwds of c:_ -> "cd " ++ c ++ " && " ++ x; [] -> x) : f cwds xs++ | otherwise = f cwds xs+ f cwds [] = []
+ benchmark/Benchmark/VsMake.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE RecordWildCards #-}++module Benchmark.VsMake(+ VsMake(..), vsMake, Args,+ ) where++import Benchmark.Args+import System.Directory.Extra+import Development.Rattle+import Development.Shake.Command+import System.Time.Extra+import Control.Exception+import System.FilePath+import Data.List+import Data.IORef+import Data.Maybe+import System.IO.Extra+import Control.Monad.Extra+++data VsMake = VsMake+ {repo :: String+ ,generate :: IO String+ ,generateVersion :: Int+ ,clean :: IO ()+ ,broken :: [String]+ ,make :: CmdArgument+ ,rattle :: CmdArgument+ ,master :: String+ }+++gitCheckout :: VsMake -> Int -> IO String+gitCheckout VsMake{..} i = do+ Stdout x <- cmd "git reset --hard" ["origin/" ++ master ++ "~" ++ show i]+ -- HEAD is now at 41fbba1 Warning+ pure $ words x !! 4+++generateName :: VsMake -> String -> IO FilePath+generateName VsMake{..} commit = do+ tdir <- getTemporaryDirectory+ pure $ tdir </> takeBaseName repo ++ "." ++ commit ++ "." ++ show generateVersion ++ ".txt"+++timed :: IORef Seconds -> String -> Int -> Int -> IO () -> IO ()+timed ref msg j commit act = do+ (t, _) <- duration act+ appendFile "vsmake.log" $ intercalate "\t" [msg, show j, show commit, show t] ++ "\n"+ putStrLn $ msg ++ " " ++ show j ++ " (" ++ show commit ++ ") = " ++ showDuration t+ modifyIORef' ref (+ t)++vsMake :: VsMake -> Args -> IO ()+vsMake vs@VsMake{..} Args{..} = withTempDir $ \dir -> do+ let counted = maybe id take count+ let commitList = reverse [0..fromMaybe 10 commits]++ let checkout i act = do+ commit <- gitCheckout vs i+ when (commit `notElem` broken) $+ flip onException (putStrLn $ "AT COMMIT " ++ commit) $+ act commit+ let stderr = [EchoStderr False | no_stderr]++ withCurrentDirectory dir $ do+ -- don't pass a depth argument, or git changes the length of the shown commit hashes+ -- which messes up caching and broken hashes+ cmd_ "git clone" repo "."++ -- generate all the Rattle files+ when ("generate" `elemOrNull` step) $ do+ putStrLn "GENERATING RATTLE SCRIPTS"+ forM_ (counted commitList) $ \i -> do+ putChar '.' >> hFlush stdout+ checkout i $ \commit -> do+ file <- generateName vs commit+ unlessM (doesFileExist file) $ do+ res <- generate+ evaluate $ length res+ writeFile file res+ putStrLn ""+++ -- for different levels of parallelism+ replicateM_ (fromMaybe 1 repeat_) $+ forM_ (threads `orNull` [1..4]) $ \j -> do+ makeTime <- newIORef 0+ rattleTime <- newIORef 0++ -- first build with make+ when ("make" `elemOrNull` step) $ do+ putStrLn "BUILDING WITH MAKE"+ clean+ forM_ (counted $ commitList ++ [0]) $ \i ->+ checkout i $ \_ ->+ timed makeTime "make" j i $ cmd_ make ["-j" ++ show j] (EchoStdout False) stderr++ -- now with rattle+ when ("rattle" `elemOrNull` step) $ do+ putStrLn "BUILDING WITH RATTLE"+ clean+ whenM (doesDirectoryExist ".rattle") $+ removeDirectoryRecursive ".rattle"+ forM_ (counted $ commitList ++ [0]) $ \i ->+ checkout i $ \commit -> do+ file <- generateName vs commit+ cmds <- lines <$> readFile' file+ let opts = rattleOptions{rattleProcesses=j, rattleUI=Just RattleQuiet, rattleNamedDirs=[], rattleShare=False}+ timed rattleTime "rattle" j i $ rattleRun opts $ forM_ cmds $ cmd rattle stderr++ make <- readIORef makeTime+ rattle <- readIORef rattleTime+ putStrLn $ "TOTALS: make = " ++ showDuration make ++ ", rattle = " ++ showDuration rattle+ copyFile (dir </> "vsmake.log") "vsmake.log"
+ html/profile.html view
@@ -0,0 +1,210 @@+<!DOCTYPE html>+<html lang="en">+<head>++<meta charset="utf-8" />+<title>Shake report</title>++<!-- Profiling output -->+<script src="data/profile-data.js"></script>+<script src="data/metadata.js"></script>+<!-- Libraries -->+<script src="lib/jquery.js"></script>+<script src="lib/jquery.flot.js"></script>+<script src="lib/jquery.flot.stack.js"></script>+<script src="lib/jquery.dgtable.js"></script>+<!-- Functions for creating info from Shake builds -->+<script src="rattle.js"></script>++<style type="text/css">+body {font-family: sans-serif; font-size: 10pt; background-color: #e8e8e8;}+.data {font-size: 9pt; border-spacing: 0px; border-collapse: collapse;}+.data td {padding-left: 7px; padding-right: 7px;}+.header {font-weight: bold; background-color: #eee !important;}+.header td:hover {background-color: #ccc !important;}+.header td {border: 1px solid #ccc; cursor: pointer;}+.data tr:hover {background-color: #ddd !important; color: black !important;}+* {box-sizing: border-box;}+html, body, .fill {height: 100%; width:100%;}+table.fill {border-spacing: 0px;}+input:focus {border-color: rgb(77, 144, 254) !important; outline-width: 0px !important;}+.note {margin-left: 10px;}+.note, .note a {color: gray;}+a tt {color: #315273;}++.tabstrip a {+ border-radius: 4px 4px 0px 0px;+ border: 1px solid gray;+ padding: 4px 8px;+ box-sizing: border-box;+ cursor: pointer;+ white-space: nowrap;+ user-select: none;+ }+.tabstrip .bottom {+ padding: 4px 8px;+ border-bottom: 1px solid gray;+}+.tabstrip .active {+ border-top: 4px solid orange;+ border-bottom: 3px solid white;+ background-color: white;+}+.right { text-align: right; }+.dropdown {+ border:1px solid gray;+ background-color:white;+ white-space:nowrap;+ position:absolute;+ right:10px;+ padding-right:10px;+ box-shadow: 3px 3px 5px #ccc;+ z-index: 100;+}+.dropdown a tt {+ cursor: pointer;+ color: #1467bb !important;+}+.details a {+ cursor: pointer;+ color: #1467bb;+}++/* My overrides */+/* Make the colors and font size match better */+.dgtable-row:hover { background-color: #e8e8e8 !important; }+.dgtable-header-cell:hover { background-color: #ddd !important; }+.dgtable-header-cell { background-color: #eee !important; }+.dgtable-cell:last-child, .dgtable-header-cell:last-child { border-right: 1px solid #ccc; }++/* Make the header smaller */+.dgtable-header-row, .dgtable-header-cell { height: 22px !important; }+.dgtable-header-cell { padding: 2px 4px !important; }+.dgtable-header-cell, .dgtable-cell-preview.header { font-size: 9pt !important; }++/* Make the rows smaller */+.dgtable-row { height: 22px !important; }+.dgtable-row:first-child { height: 23px !important; }+.dgtable-cell { padding: 2px 4px !important; height: 22px !important; }+.dgtable-cell, .dgtable-cell-preview{ font-size: 9pt !important; }++.dgtable-wrapper * {+ box-sizing: border-box;+}+.dgtable-wrapper {+ border: solid 1px #ccc;+}+.dgtable {+ border-top: solid 1px #ccc;+ max-width: 100%;+ background-color: transparent;+}+.dgtable-header {+ max-width: 100%;+ overflow: hidden;+ background: #eee;+}+.dgtable-header-row {+ height: 26px;+}+.dgtable-header-cell {+ float: left;+ padding: 4px;+ height: 26px;+ border-left: solid 1px #ccc;+ background: #ddd;+ font-size: 13px;+ line-height: 16px;+ font-weight: bold;+ cursor: default;+ text-align: left;+}+.dgtable-header-cell:first-child {+ border-left: 0;+}+.dgtable-header-cell > div {+ border: 1px dashed transparent;+ white-space: nowrap;+ overflow-x: hidden;+ text-overflow: ellipsis;+}+.dgtable-header-cell.drag-over > div {+ border-color: #666;+ background: #bbb;+}+.dgtable-row {+ border-top: solid 1px #ccc;+ height: 28px;+}+.dgtable-row:first-child {+ border-top: 0;+ height: 29px;+}+.dgtable.virtual .dgtable-row {+ border-top: 0;+ border-bottom: solid 1px #ccc;+}+.dgtable-cell {+ float: left;+ padding: 4px 4px 4px;+ height: 28px;+ border-left: solid 1px #ccc;+ font-size: 16px;+ line-height: 19px;+}+.dgtable-cell > div {+ max-height: 100%;+ white-space: nowrap;+ overflow: hidden+}+.dgtable-cell:first-child {+ border-left: 0;+}+.dgtable-header-cell.sortable {+ cursor: pointer;+}+.dgtable-header-cell.sorted .sort-arrow {+ float: right;+ display: inline-block;+ width: 15px;+ height: 6px;+ margin: 5px 0 0 0;+ background: url("data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAsAAAAGCAMAAAAi7JTKAAAAIGNIUk0AAHolAACAgwAA+f8AAIDpAAB1MAAA6mAAADqYAAAXb5JfxUYAAAMAUExURQNOov///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAH52dxwAAAACdFJOU/8A5bcwSgAAAAlwSFlzAAALEwAACxMBAJqcGAAAAB9JREFUCB0FwQEBAAAAgJD8Px0VoFKgRKEIpRBUEAgMBlQAL3y6umEAAAAASUVORK5CYII=") no-repeat center center;+}++.dgtable-header-cell.sorted.desc .sort-arrow {+ background-image: url("data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAsAAAAGCAMAAAAi7JTKAAAAIGNIUk0AAHolAACAgwAA+f8AAIDpAAB1MAAA6mAAADqYAAAXb5JfxUYAAAMAUExURQNOov///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAH52dxwAAAACdFJOU/8A5bcwSgAAAAlwSFlzAAALEwAACxMBAJqcGAAAAB9JREFUCB0FwQEBAAAAgJD8Px2BQFBBKIUoFClQKkANBywAL6PcDsUAAAAASUVORK5CYII=");+}++.dgtable-cell-preview {+ font-size: 16px;+ line-height: 19px;+}++/* Making the cell preview show correct styling when previewing header cells */+.dgtable-cell-preview.header {+ font-size: 13px;+ line-height: 16px;+ font-weight: bold;+ text-align: left;+}++.dgtable-cell-preview.header > div {+ border: 1px dashed transparent;+}++.dgtable-cell-preview.header.sortable {+ cursor: pointer;+}++.dgtable-cell-preview.header.drag-over > div {+ border-color: #666;+ background: #bbb;+}+</style>++</head>+<body style="margin:0px;padding:0px;" onload="profileLoaded(profile)">+ Loading...+</body>+</html>
+ html/rattle.js view
@@ -0,0 +1,670 @@+"use strict";+function bindPlot(element, data, options) {+ const redraw = () => {+ if ($(element).is(":visible"))+ $.plot($(element), data.get(), options);+ };+ window.setTimeout(redraw, 1);+ $(window).on("resize", redraw);+ data.event(redraw);+}+function varLink(name) {+ return React.createElement("a", { href: "https://hackage.haskell.org/package/shake/docs/Development-Shake.html#v:" + name },+ React.createElement("tt", null, name));+}+function newTable(columns, data, sortColumn, sortDescend) {+ const f = (x) => ({ name: x.field, label: x.label, width: x.width, cellClasses: x.alignRight ? "right" : "" });+ const formatters = {};+ for (const c of columns)+ formatters[c.field] = c.show || ((x) => x);+ const table = new DGTable({+ adjustColumnWidthForSortArrow: false,+ cellFormatter: (val, colname) => formatters[colname](val),+ columns: columns.map(f),+ width: DGTable.Width.SCROLL+ });+ $(table.el).css("height", "100%");+ window.setTimeout(() => {+ table.render();+ table.tableHeightChanged();+ if (sortColumn)+ table.sort(sortColumn, sortDescend);+ table.setRows(data.get(), true);+ }, 1);+ let toRender = false;+ data.event(xs => {+ table.setRows(xs, true);+ if ($(table.el).is(":visible"))+ table.render();+ else+ toRender = true;+ });+ $(window).on("resize", () => {+ if ($(table.el).is(":visible")) {+ table.tableHeightChanged();+ if (toRender) {+ table.render();+ toRender = false;+ }+ }+ });+ return React.createElement("div", { style: "height:100%;width:100%;" }, table.el);+}+// These are global variables mutated/queried by query execution+let environmentAll; // All the profiles+let environmentThis; // The specific profile under test+let environmentGroup; // The group produced as a result+function group(x) {+ environmentGroup.push(x);+ return true;+}+function leaf() {+ return environmentThis.writers.length === 0;+}+function run(i) {+ if (i === undefined)+ return environmentThis.built;+ else+ return environmentThis.built === i;+}+function named(r, groupName) {+ if (r === undefined)+ return environmentThis.name;+ const res = execRegExp(r, environmentThis.name);+ if (res === null) {+ if (groupName === undefined)+ return false;+ else {+ group(groupName);+ return true;+ }+ }+ if (res.length !== 1) {+ for (let i = 1; i < res.length; i++)+ group(res[i]);+ }+ return true;+}+function profileLoaded(profileRaw) {+ $(document.body).empty().append(profileRoot(unraw(profileRaw)));+}+function unraw(xs) {+ const ans = xs.map((x, i) => ({+ index: i,+ name: x[0],+ execution: x[1],+ built: x[2],+ builtLast: x[3],+ changed: x[4],+ filesWritten: x[5],+ filesRead: x[6],+ readers: x[7],+ writers: x[8],+ hazards: x[9] // depends and rdepends that violate consistency+ }));+ return ans;+}+function profileRoot(profile) {+ const [s, search] = createSearch(profile);+ const t = createTabs([["Summary", () => reportSummary(profile)]+ // , ["Command plot", () => reportCmdPlot(profile)]+ // , ["Commands", () => reportCmdTable(profile, search)]+ ,+ ["Commands", () => reportRuleTable(profile, search)],+ ["Parallelizability", () => reportParallelism(profile)],+ ["Details", () => reportDetails(profile, search)]+ // , ["Why rebuild", () => reportRebuild(profile, search)]+ ]);+ return React.createElement("table", { class: "fill" },+ React.createElement("tr", null,+ React.createElement("td", { style: "padding-top: 8px; padding-bottom: 8px;" },+ React.createElement("a", { href: "https://github.com/ndmitchell/rattle", style: "font-size: 20px; text-decoration: none; color: #3131a7; font-weight: bold;" }, "Rattle profile report"),+ React.createElement("span", { style: "color:gray;white-space:pre;" },+ " - generated at ",+ generated,+ " by Rattle v",+ version))),+ React.createElement("tr", null,+ React.createElement("td", null, s)),+ React.createElement("tr", null,+ React.createElement("td", { height: "100%" }, t)));+}+function createTabs(xs) {+ const bodies = xs.map(x => {+ const el = React.createElement("div", { style: "padding:5px;width:100%;height:100%;min-width:150px;min-height:150px;overflow:auto;display:none;" });+ const upd = lazy(() => $(el).append(x[1]()));+ return pair(el, upd);+ });+ let lbls = [];+ const f = (i) => () => {+ bodies[i][1]();+ lbls.map((x, j) => $(x).toggleClass("active", i === j));+ bodies.map((x, j) => $(x[0]).toggle(i === j));+ $(window).trigger("resize");+ };+ lbls = xs.map((x, i) => React.createElement("a", { onclick: f(i) }, x[0]));+ f(0)();+ return React.createElement("table", { class: "fill" },+ React.createElement("tr", null,+ React.createElement("td", null,+ React.createElement("table", { width: "100%", style: "border-spacing:0px;" },+ React.createElement("tr", { class: "tabstrip" },+ React.createElement("td", { width: "20", class: "bottom" }, "\u00A0"),+ React.createElement("td", { style: "padding:0px;" }, lbls),+ React.createElement("td", { width: "100%", class: "bottom" }, "\u00A0"))))),+ React.createElement("tr", { height: "100%" },+ React.createElement("td", { style: "background-color:white;" }, bodies.map(fst))));+}+// A mapping from names (rule names or those matched from rule parts)+// to the indicies in profiles.+class Search {+ constructor(profile, mapping) {+ this.profile = profile;+ if (mapping !== undefined)+ this.mapping = mapping;+ else {+ this.mapping = {};+ for (const p of profile)+ this.mapping[p.name] = [p.index];+ }+ }+ forEachProfiles(f) {+ for (const s in this.mapping)+ f(this.mapping[s].map(i => this.profile[i]), s);+ }+ forEachProfile(f) {+ this.forEachProfiles((ps, group) => ps.forEach(p => f(p, group)));+ }+ mapProfiles(f) {+ const res = [];+ this.forEachProfiles((ps, group) => res.push(f(ps, group)));+ return res;+ }+ mapProfile(f) {+ const res = [];+ this.forEachProfile((p, group) => res.push(f(p, group)));+ return res;+ }+}+function createSearch(profile) {+ const caption = React.createElement("div", null,+ "Found ",+ profile.length,+ " entries, not filtered or grouped.");+ const input = React.createElement("input", { id: "search", type: "text", value: "", placeholder: "Filter and group", style: "width: 100%; font-size: 16px; border-radius: 8px; padding: 5px 10px; border: 2px solid #999;" });+ const res = new Prop(new Search(profile));+ $(input).on("change keyup paste", () => {+ const s = $(input).val();+ if (s === "") {+ res.set(new Search(profile));+ $(caption).text("Found " + profile.length + " entries, not filtered or grouped.");+ }+ else if (s.indexOf("(") === -1) {+ const mapping = {};+ let found = 0;+ for (const p of profile) {+ if (p.name.indexOf(s) !== -1) {+ found++;+ mapping[p.name] = [p.index];+ }+ }+ res.set(new Search(profile, mapping));+ $(caption).text("Substring filtered to " + found + " / " + profile.length + " entries, not grouped.");+ }+ else {+ let f;+ try {+ f = new Function("return " + s);+ }+ catch (e) {+ $(caption).text("Error compiling function, " + e);+ return;+ }+ const mapping = {};+ let groups = 0;+ let found = 0;+ environmentAll = profile;+ for (const p of profile) {+ environmentThis = p;+ environmentGroup = [];+ let bool;+ try {+ bool = f();+ }+ catch (e) {+ $(caption).text("Error running function, " + e);+ return;+ }+ if (bool) {+ found++;+ const name = environmentGroup.length === 0 ? p.name : environmentGroup.join(" ");+ if (name in mapping)+ mapping[name].push(p.index);+ else {+ groups++;+ mapping[name] = [p.index];+ }+ }+ }+ res.set(new Search(profile, mapping));+ $(caption).text("Function filtered to " + found + " / " + profile.length + " entries, " ++ (groups === found ? "not grouped." : groups + " groups."));+ }+ });+ const body = React.createElement("table", { width: "100%", style: "padding-bottom: 17px;" },+ React.createElement("tr", null,+ React.createElement("td", { width: "100%" }, input),+ React.createElement("td", { style: "padding-left:6px;padding-right: 6px;" }, searchHelp(input))),+ React.createElement("tr", null,+ React.createElement("td", null, caption)));+ return [body, res];+}+function searchHelp(input) {+ const examples = [["Only the last run", "run(0)"],+ ["Named 'Main'", "named(\"Main\")"],+ ["Group by file extension", "named(/(\\.[_0-9a-z]+)$/)"],+ ["No dependencies (an input)", "leaf()"],+ ["Didn't change when it last rebuilt", "unchanged()"],+ ["Ran 'gcc'", "command(\"gcc\")"]+ ];+ const f = (code) => () => {+ $(input).val((i, x) => x + (x === "" ? "" : " && ") + code);+ $(input).trigger("change");+ };+ const dropdown = React.createElement("div", { class: "dropdown", style: "display:none;" },+ React.createElement("ul", { style: "padding-left:30px;" }, examples.map(([desc, code]) => React.createElement("li", null,+ React.createElement("a", { onclick: f(code) },+ React.createElement("tt", null, code)),+ " ",+ React.createElement("span", { class: "note" }, desc)))));+ const arrow_down = React.createElement("span", { style: "vertical-align:middle;font-size:80%;" }, "\u25BC");+ const arrow_up = React.createElement("span", { style: "vertical-align:middle;font-size:80%;display:none;" }, "\u25B2");+ const show_inner = () => { $(dropdown).toggle(); $(arrow_up).toggle(); $(arrow_down).toggle(); };+ return React.createElement("div", null,+ React.createElement("button", { style: "white-space:nowrap;padding-top:5px;padding-bottom:5px;", onclick: show_inner },+ React.createElement("b", { style: "font-size:150%;vertical-align:middle;" }, "+"),+ "\u00A0 Filter and Group \u00A0",+ arrow_down,+ arrow_up),+ dropdown);+}+// Stuff that Shake generates and injects in+function untraced(p) {+ return 0;+}+/////////////////////////////////////////////////////////////////////+// BASIC UI TOOLKIT+class Prop {+ constructor(val) { this.val = val; this.callback = () => { return; }; }+ get() { return this.val; }+ set(val) {+ this.val = val;+ this.callback(val);+ }+ event(next) {+ const old = this.callback;+ this.callback = val => { old(val); next(val); };+ next(this.val);+ }+ map(f) {+ const res = new Prop(f(this.get()));+ this.event(a => res.set(f(a)));+ return res;+ }+}+jQuery.fn.enable = function (x) {+ // Set the values to enabled/disabled+ return this.each(function () {+ if (x)+ $(this).removeAttr("disabled");+ else+ $(this).attr("disabled", "disabled");+ });+};+/////////////////////////////////////////////////////////////////////+// BROWSER HELPER METHODS+// Given "?foo=bar&baz=1" returns {foo:"bar",baz:"1"}+function uriQueryParameters(s) {+ // From https://stackoverflow.com/questions/901115/get-querystring-values-with-jquery/3867610#3867610+ const params = {};+ const a = /\+/g; // Regex for replacing addition symbol with a space+ const r = /([^&=]+)=?([^&]*)/g;+ const d = (x) => decodeURIComponent(x.replace(a, " "));+ const q = s.substring(1);+ while (true) {+ const e = r.exec(q);+ if (!e)+ break;+ params[d(e[1])] = d(e[2]);+ }+ return params;+}+/////////////////////////////////////////////////////////////////////+// STRING FORMATTING+function showTime(x) {+ function digits(x) { const s = String(x); return s.length === 1 ? "0" + s : s; }+ if (x >= 3600) {+ x = Math.round(x / 60);+ return Math.floor(x / 60) + "h" + digits(x % 60) + "m";+ }+ else if (x >= 60) {+ x = Math.round(x);+ return Math.floor(x / 60) + "m" + digits(x % 60) + "s";+ }+ else+ return x.toFixed(2) + "s";+}+function showPerc(x) {+ return (x * 100).toFixed(2) + "%";+}+function showInt(x) {+ // From https://stackoverflow.com/questions/2901102/how-to-print-a-number-with-commas-as-thousands-separators-in-javascript+ // Show, with commas+ return x.toString().replace(/\B(?=(\d{3})+(?!\d))/g, ",");+}+function showRun(run) {+ return run === 0 ? "Latest run" : run + " run" + plural(run) + " ago";+}+function showBool(b) {+ return b === 1 ? "True" : "False";+}+function plural(n, not1 = "s", is1 = "") {+ return n === 1 ? is1 : not1;+}+/////////////////////////////////////////////////////////////////////+// MISC+function compareFst(a, b) {+ return a[0] - b[0];+}+function compareSnd(a, b) {+ return a[1] - b[1];+}+function compareSndRev(a, b) {+ return b[1] - a[1];+}+function pair(a, b) {+ return [a, b];+}+function triple(a, b, c) {+ return [a, b, c];+}+function fst([x, _]) {+ return x;+}+function snd([_, x]) {+ return x;+}+function execRegExp(r, s) {+ if (typeof r === "string")+ return s.indexOf(r) === -1 ? null : [];+ else+ return r.exec(s);+}+function cache(key, op) {+ const store = {};+ return k => {+ const s = key(k);+ if (!(s in store))+ store[s] = op(k);+ return store[s];+ };+}+function lazy(thunk) {+ let store = null;+ let done = false;+ return () => {+ if (!done) {+ store = thunk();+ done = true;+ }+ return store;+ };+}+Array.prototype.sum = function () {+ let res = 0;+ for (const x of this)+ res += x;+ return res;+};+Array.prototype.insertSorted = function (x, compare) {+ let start = 0;+ let stop = this.length - 1;+ let middle = 0;+ while (start <= stop) {+ middle = Math.floor((start + stop) / 2);+ if (compare(this[middle], x) > 0)+ stop = middle - 1;+ else+ start = middle + 1;+ }+ this.splice(start, 0, x);+ return this;+};+Array.prototype.concatLength = function () {+ let res = 0;+ for (const x of this)+ res += x.length;+ return res;+};+Array.prototype.sortOn = function (f) {+ return this.map(x => pair(f(x), x)).sort(compareFst).map(snd);+};+Array.prototype.last = function () {+ return this[this.length - 1];+};+Array.prototype.maximum = function (def) {+ if (this.length === 0)+ return def;+ let res = this[0];+ for (let i = 1; i < this.length; i++)+ res = Math.max(res, this[i]);+ return res;+};+Array.prototype.minimum = function (def) {+ if (this.length === 0)+ return def;+ let res = this[0];+ for (let i = 1; i < this.length; i++)+ res = Math.min(res, this[i]);+ return res;+};+// Use JSX with el instead of React.createElement+// Originally from https://gist.github.com/sergiodxa/a493c98b7884128081bb9a281952ef33+// our element factory+function createElement(type, props, ...children) {+ const element = document.createElement(type);+ for (const name in props || {}) {+ if (name.substr(0, 2) === "on")+ element.addEventListener(name.substr(2), props[name]);+ else+ element.setAttribute(name, props[name]);+ }+ for (const child of children.flat(10)) {+ const c = typeof child === "object" ? child : document.createTextNode(child.toString());+ element.appendChild(c);+ }+ return element;+}+// How .tsx gets desugared+const React = { createElement };+function showFile(p) {+ if (p[1]) {+ return React.createElement("li", null,+ React.createElement("b", null, p[0]));+ }+ else {+ return React.createElement("li", null, p[0]);+ }+}+function reportDetails(profile, search) {+ const result = React.createElement("div", { class: "details" });+ const self = new Prop(0);+ search.event(xs => self.set(xs.mapProfile((p, _) => p.index).maximum()));+ const f = (i) => React.createElement("a", { onclick: () => self.set(i) }, profile[i].name);+ self.event(i => {+ const p = profile[i];+ const content = React.createElement("ul", null,+ React.createElement("li", null,+ React.createElement("b", null, "Name:"),+ " ",+ p.name),+ React.createElement("li", null,+ React.createElement("b", null, "Built:"),+ " ",+ showRun(p.built)),+ React.createElement("li", null,+ React.createElement("b", null, "Built last run:"),+ " ",+ showBool(p.builtLast)),+ React.createElement("li", null,+ React.createElement("b", null, "Changed:"),+ " ",+ showBool(p.changed)),+ React.createElement("li", null,+ React.createElement("b", null, "Execution time:"),+ showTime(p.execution)),+ React.createElement("li", null,+ React.createElement("b", null, "Cmds that wrote files I read:"),+ React.createElement("ol", null, p.writers.map(d => React.createElement("li", null, f(d))))),+ React.createElement("li", null,+ React.createElement("b", null, "Cmds that read files I wrote:"),+ React.createElement("ul", null, p.readers.map(d => React.createElement("li", null, f(d))))),+ React.createElement("li", null,+ React.createElement("b", null, "Cmds that I have a hazard with:"),+ React.createElement("ul", null, p.hazards.map(d => React.createElement("li", null, f(d))))),+ React.createElement("li", null,+ React.createElement("b", null, "Files I wrote (bold files changed last run):"),+ React.createElement("ul", null, p.filesWritten.map(f => showFile(f)))),+ React.createElement("li", null,+ React.createElement("b", null, "Files I read (bold files changed last run):"),+ React.createElement("ul", null, p.filesRead.map(f => showFile(f)))));+ $(result).empty().append(content);+ });+ return result;+}+function reportParallelism(profile) {+ // now simulate for -j1 .. -j24+ const plotData = [{ label: "Realistic (based on current dependencies)", data: [], color: "#3131a7" },+ { label: "Ideal (if no dependencies and perfect speedup)", data: [], color: "green" },+ { label: "Gap", data: [], color: "orange" }+ ];+ let threads1;+ for (let threads = 1; threads <= 24; threads++) {+ const taken = simulateThreads(profile, threads)[0];+ if (threads === 1)+ threads1 = taken;+ plotData[0].data.push([threads, taken]);+ plotData[1].data.push([threads, threads1 / threads]);+ plotData[2].data.push([threads, Math.max(0, taken - (threads1 / threads))]);+ }+ const plot = React.createElement("div", { style: "width:100%; height:100%;" });+ bindPlot(plot, new Prop(plotData), {+ xaxis: { tickDecimals: 0 },+ yaxis: { min: 0, tickFormatter: showTime }+ });+ return React.createElement("table", { class: "fill" },+ React.createElement("tr", null,+ React.createElement("td", { style: "text-align:center;" },+ React.createElement("h2", null, "Time to build at different number of threads"))),+ React.createElement("tr", null,+ React.createElement("td", { height: "100%" }, plot)),+ React.createElement("tr", null,+ React.createElement("td", { style: "text-align:center;" }, "Number of threads available.")));+}+// Simulate running N threads over the profile, return:+// [total time take, point at which each entry kicked off]+function simulateThreads(profile, threads) {+ // How far are we through this simulation+ let timestamp = 0;+ // Who is currently running, with the highest seconds FIRST+ const running = [];+ const started = [];+ // Things that are done+ const ready = profile.filter(x => x.writers.length === 0);+ const waiting = profile.map(x => x.writers.concatLength()); // number I am waiting on before I am done+ function runningWait() {+ const [ind, time] = running.pop();+ timestamp = time;+ for (const d of profile[ind].readers) {+ waiting[d]--;+ if (waiting[d] === 0)+ ready.push(profile[d]);+ }+ }+ while (true) {+ // Queue up as many people as we can+ while (running.length < threads && ready.length > 0) {+ const p = ready.pop();+ started[p.index] = timestamp;+ running.insertSorted([p.index, timestamp + p.execution], compareSndRev);+ }+ if (running.length === 0) {+ if (waiting.maximum(0) > 0)+ throw new Error("Failed to run all tasks");+ return [timestamp, started];+ }+ runningWait();+ }+}+function reportRuleTable(profile, search) {+ const columns = [{ field: "name", label: "Name", width: 400 },+ { field: "count", label: "Count", width: 65, alignRight: true, show: showInt },+ { field: "leaf", label: "Leaf", width: 60, alignRight: true },+ { field: "run", label: "Run", width: 50, alignRight: true },+ { field: "time", label: "Time", width: 75, alignRight: true, show: showTime }+ ];+ return newTable(columns, search.map(s => ruleData(s)), "time", true);+}+function ruleData(search) {+ return search.mapProfiles((ps, name) => ({+ name,+ count: ps.length,+ leaf: ps.every(p => p.writers.length === 0),+ run: ps.map(p => p.built).minimum(),+ time: ps.map(p => p.execution).sum()+ }));+}+function reportSummary(profile) {+ let sumExecution = 0; // build time in total+ const countTrace = profile.length;+ // start both are -1 because the end command will have run in the previous step+ for (const p of profile) {+ sumExecution += p.execution;+ }+ return React.createElement("div", null,+ React.createElement("h2", null, "Totals"),+ React.createElement("ul", null,+ React.createElement("li", null,+ React.createElement("b", null, "Rules:"),+ " ",+ showInt(profile.length),+ " ",+ React.createElement("span", { class: "note" }, "number of commands."))),+ React.createElement("h2", null, "Performance"),+ React.createElement("ul", null,+ React.createElement("li", null,+ React.createElement("b", null, "Build time:"),+ " ",+ showTime(sumExecution),+ " ",+ React.createElement("span", { class: "note" }, "how long a complete build would take single threaded.")),+ React.createElement("li", null,+ React.createElement("b", null, "Speculative critical path:"),+ " ",+ showTime(speculativeCriticalPath(profile)),+ " ",+ React.createElement("span", { class: "note" }, "how long it would take on infinite CPUs."))));+}+function speculativeCriticalPath(profile) {+ const criticalPath = []; // the critical path to any element+ let maxCriticalPath = 0;+ for (const p of profile) {+ let cost = 0;+ for (const d of p.writers)+ cost = Math.max(cost, criticalPath[d]);+ cost += p.execution;+ maxCriticalPath = Math.max(cost, maxCriticalPath);+ criticalPath[p.index] = cost;+ }+ return maxCriticalPath;+}
+ pipeline/Pipeline.hs view
@@ -0,0 +1,27 @@++-- Run commands separated by+-- a ; b - do a, continue with b ignoring the escape code+-- a || b - do a, only do b if a fails+-- a && b - do a, only do b if a succeeds+-- there is no bracketing+module Pipeline(main) where++import Development.Shake.Command+import System.Environment+import System.Exit+++main :: IO ()+main = exitWith =<< run =<< getArgs+++isSpecial x = x `elem` [";", "&&", "||"]+++run :: [String] -> IO ExitCode+run xs | (a, op:b) <- break isSpecial xs = case op of+ ";" -> run a >> run b+ "&&" -> do a <- run a; if a == ExitSuccess then run b else pure a+ "||" -> do a <- run a; if a == ExitSuccess then pure a else run b+run [] = pure ExitSuccess+run (x:xs) = cmd x xs
rattle.cabal view
@@ -1,20 +1,20 @@ cabal-version: >= 1.18 build-type: Simple name: rattle-version: 0.1+version: 0.2 license: BSD3 x-license: BSD-3-Clause OR Apache-2.0 license-file: LICENSE category: Development author: Neil Mitchell <ndmitchell@gmail.com> maintainer: Neil Mitchell <ndmitchell@gmail.com>-copyright: Neil Mitchell 2019+copyright: Neil Mitchell 2019-2020 synopsis: Forward build system, with caching and speculation description: A forward build system like Fabrciate but with speculation and remote caching. homepage: https://github.com/ndmitchell/rattle#readme bug-reports: https://github.com/ndmitchell/rattle/issues-tested-with: GHC==8.6.4, GHC==8.4.4, GHC==8.2.2+tested-with: GHC==8.10.1, GHC==8.8.3, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2 extra-doc-files: CHANGES.txt README.md@@ -22,6 +22,9 @@ test/C/constants.c test/C/constants.h test/C/main.c+data-files:+ html/profile.html+ html/rattle.js source-repository head type: git@@ -31,42 +34,206 @@ default-language: Haskell2010 hs-source-dirs: src build-depends:- base >= 4.8 && < 5,+ async,+ base >= 4.10 && < 5, bytestring, cryptohash-sha256, deepseq >= 1.1, directory, extra >= 1.6.14, filepath,+ filepattern, hashable >= 1.1.2.3,- shake >= 0.17.8,+ shake >= 0.19,+ terminal-size,+ template-haskell, time, transformers >= 0.2,- unordered-containers >= 0.2.7+ unordered-containers >= 0.2.7,+ js-dgtable,+ js-flot,+ js-jquery,+ heaps,+ utf8-string >= 1.0.1.1 + if !os(windows)+ build-depends: unix >= 2.7.2.2+ exposed-modules: Development.Rattle other-modules:+ Development.Rattle.CmdOption+ Development.Rattle.Derived Development.Rattle.Hash- Development.Rattle.Limit+ Development.Rattle.Hazards+ Development.Rattle.Options+ Development.Rattle.Profile+ Development.Rattle.Program Development.Rattle.Server Development.Rattle.Shared Development.Rattle.Types+ Development.Rattle.UI General.Bilist+ General.Binary General.Extra General.Thread+ General.Paths+ General.Pool+ General.EscCodes+ General.Template+ Paths_rattle+ General.FileName+ General.FileInfo +executable pipeline+ default-language: Haskell2010+ main-is: pipeline/Pipeline.hs+ ghc-options: -main-is Pipeline.main -threaded+ build-depends:+ base >= 4.10 && < 5,+ shake >= 0.19++executable rattle-benchmark+ default-language: Haskell2010+ main-is: Benchmark.hs+ hs-source-dirs: benchmark+ ghc-options: -main-is Benchmark.main -threaded+ build-depends:+ base >= 4.10 && < 5,+ extra >= 1.6.14,+ rattle,+ process,+ bytestring,+ directory,+ filepath,+ cmdargs,+ shake >= 0.19+ other-modules:+ Benchmark.Args+ Benchmark.FSATrace+ Benchmark.Micro+ Benchmark.Redis+ Benchmark.Intro+ Benchmark.VsMake++executable buildScript+ default-language: Haskell2010+ hs-source-dirs: test, src+ main-is: Test/BuildScript.hs+ ghc-options: -main-is BuildScript.main -threaded -fwarn-unused-imports+ buildable: False+ build-depends:+ async,+ base >= 4.10 && < 5,+ bytestring,+ cryptohash-sha256,+ deepseq >= 1.1,+ directory,+ extra >= 1.6.14,+ filepath,+ filepattern,+ hashable >= 1.1.2.3,+ shake >= 0.19,+ time >= 1.9.1,+ transformers >= 0.2,+ terminal-size,+ template-haskell,+ unordered-containers >= 0.2.7,+ js-dgtable,+ js-flot,+ js-jquery,+ heaps,+ utf8-string >= 1.0.1.1++ if !os(windows)+ build-depends: unix >= 2.7.2.2++ other-modules:+ Development.Rattle+ Development.Rattle.CmdOption+ Development.Rattle.Derived+ Development.Rattle.Hash+ Development.Rattle.Hazards+ Development.Rattle.Options+ Development.Rattle.Profile+ Development.Rattle.Program+ Development.Rattle.Server+ Development.Rattle.Shared+ Development.Rattle.Types+ Development.Rattle.UI+ General.Bilist+ General.Binary+ General.Extra+ General.Thread+ General.Paths+ General.Pool+ General.EscCodes+ General.Template+ Paths_rattle+ General.FileName+ General.FileInfo+ test-suite rattle-test default-language: Haskell2010 type: exitcode-stdio-1.0- main-is: test/Test.hs- ghc-options: -main-is Test.main -rtsopts -with-rtsopts=-K1K -threaded+ hs-source-dirs: test, src+ main-is: Test.hs+ ghc-options: -main-is Test.main -rtsopts -threaded build-depends:- base >= 4.8 && < 5,+ async,+ base >= 4.10 && < 5,+ bytestring,+ Cabal >= 2.2,+ cryptohash-sha256,+ deepseq >= 1.1, directory,- extra,+ extra >= 1.6.14,+ filepath, filepattern,- rattle,- shake+ hashable >= 1.1.2.3,+ shake >= 0.19,+ time,+ transformers >= 0.2,+ terminal-size,+ template-haskell,+ unordered-containers >= 0.2.7,+ js-dgtable,+ js-flot,+ js-jquery,+ heaps,+ utf8-string >= 1.0.1.1++ if !os(windows)+ build-depends: unix >= 2.7.2.2++ other-modules:+ Development.Rattle+ Development.Rattle.CmdOption+ Development.Rattle.Derived+ Development.Rattle.Hash+ Development.Rattle.Hazards+ Development.Rattle.Options+ Development.Rattle.Profile+ Development.Rattle.Program+ Development.Rattle.Server+ Development.Rattle.Shared+ Development.Rattle.Types+ Development.Rattle.UI+ General.Bilist+ General.Binary+ General.Extra+ General.Thread+ General.Paths+ General.Pool+ General.EscCodes+ General.Template+ Paths_rattle+ Test.Example.FSATrace+ Test.Example.Stack+ Test.Simple+ Test.Trace+ Test.Type+ General.FileName+ General.FileInfo
src/Development/Rattle.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | General rules for writing consistent rattle build systems: --@@ -7,42 +6,34 @@ -- * Don't delete files that have been produced. Each command should make -- new files, not delete old files. module Development.Rattle(- rattle, Run,+ rattleRun, Run,+ rattleDump, Hazard,- RattleOptions(..), rattleOptions,- cmd,- parallel, forP,- liftIO+ RattleOptions(..), rattleOptions, RattleUI(..),+ cmd, CmdOption(..), CmdOption2(..), toCmdOption,+ module Development.Rattle.Derived,+ module Development.Rattle.Program,+ liftIO, writeProfile, graphData ) where import Control.Monad.Trans.Reader import Control.Monad.IO.Class+import Development.Shake.Command import Development.Rattle.Server-import General.Thread+import Development.Rattle.Derived+import Development.Rattle.Options+import Development.Rattle.CmdOption+import Development.Rattle.Shared+import Development.Rattle.Hazards+import Development.Rattle.Profile+import Development.Rattle.Program --- | Type of actions to run. Executed using 'rattle'.-newtype Run a = Run {fromRun :: ReaderT Rattle IO a}- deriving (Functor, Applicative, Monad, MonadIO)---- | Run a sequence of 'Run' actions in parallel. They will be run in parallel with no limit--- on simultaneous executions.-parallel :: [Run a] -> Run [a]-parallel xs = do- r <- Run ask- liftIO $ withThreadsList $ map (flip runReaderT r . fromRun) xs---- | Parallel version of 'forM'.-forP :: (a -> Run b) -> [a] -> Run [b]-forP f xs = parallel $ map f xs---- | Run a system command with the given arguments.-cmd :: [String] -> Run ()-cmd args = do- r <- Run ask- liftIO $ cmdRattle r args- -- | Given an Action to run, and a list of previous commands that got run, run it again-rattle :: RattleOptions -> Run a -> IO a-rattle opts (Run act) = withRattle opts $ \r ->+rattleRun :: RattleOptions -> Run a -> IO a+rattleRun opts (Run act) = withRattle opts $ \r -> runReaderT act r++-- | Dunmp the contents of a shared cache+rattleDump :: (String -> IO ()) -> FilePath -> IO ()+rattleDump = dump
+ src/Development/Rattle/CmdOption.hs view
@@ -0,0 +1,31 @@+++-- | Extra Cmd options as specified by Rattle.+-- They are stashed in AddEnv "#!RATTLE" options to get the nice interface+module Development.Rattle.CmdOption(+ CmdOption2(..),+ toCmdOption, fromCmdOption+ ) where++import Development.Shake.Command+import System.FilePattern++-- | A data type for additional rattle options+data CmdOption2+ = Ignored [FilePattern] -- Files that are ignored+ | HashNonDeterministic [FilePattern] -- Files that have non-det outputs, so hash the inputs+ | WriteFile FilePath+ deriving (Read, Show)+++instance IsCmdArgument CmdOption2 where+ toCmdArgument = toCmdArgument . toCmdOption++-- | Convert a new option into a standard one.+toCmdOption :: CmdOption2 -> CmdOption+toCmdOption = AddEnv "#!RATTLE" . show++-- | Convert a normal option into potentially a rattle one.+fromCmdOption :: CmdOption -> Either CmdOption CmdOption2+fromCmdOption (AddEnv "#!RATTLE" x) = Right $ read x+fromCmdOption x = Left x
+ src/Development/Rattle/Derived.hs view
@@ -0,0 +1,60 @@++-- | Helpers built on top of Rattle+module Development.Rattle.Derived(+ parallel, forP, forP_,+ withCmdOptions,+ memo, memoRec,+ cmdWriteFile,+ ) where++import Control.Concurrent.Async+import Control.Monad.Trans.Reader+import Control.Monad.IO.Class+import Control.Monad+import Control.Concurrent.Extra+import qualified Data.HashMap.Strict as Map+import Data.Hashable+import Development.Shake.Command+import Development.Rattle.Server+import Development.Rattle.CmdOption+++-- | Run a sequence of 'Run' actions in parallel. They will be run in parallel with no limit+-- on simultaneous executions.+parallel :: [Run a] -> Run [a]+parallel xs = do+ r <- Run ask+ liftIO $ mapConcurrently (flip runReaderT r . fromRun) xs++-- | Parallel version of 'forM'.+forP :: [a] -> (a -> Run b) -> Run [b]+forP xs f = parallel $ map f xs++-- | Parallel version of 'forM'.+forP_ :: [a] -> (a -> Run b) -> Run ()+forP_ xs f = void $ forP xs f+++cmdWriteFile :: FilePath -> String -> Run ()+cmdWriteFile file str = cmd (Traced $ "Writing file " ++ file) (WriteFile file) [str]+++-- | Apply specific options ot all nested Run values.+withCmdOptions :: [CmdOption] -> Run a -> Run a+withCmdOptions xs (Run act) = Run $ withReaderT (addCmdOptions xs) act++-- | Memoize an IO action+memo :: (Eq a, Hashable a, MonadIO m) => (a -> m b) -> m (a -> m b)+memo f = memoRec $ const f++-- | Memoize an IO action which is recursive+memoRec :: (Eq a, Hashable a, MonadIO m) => ((a -> m b) -> a -> m b) -> m (a -> m b)+memoRec f = do+ var <- liftIO $ newVar Map.empty+ let go x =+ join $ liftIO $ modifyVar var $ \mp -> case Map.lookup x mp of+ Just bar -> pure (mp, liftIO $ waitBarrier bar)+ Nothing -> do+ bar <- newBarrier+ pure (Map.insert x bar mp, do v <- f go x; liftIO $ signalBarrier bar v; pure v)+ pure go
src/Development/Rattle/Hash.hs view
@@ -1,72 +1,157 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Development.Rattle.Hash(- Hash, fromHash,- hashFile, hashString+ Hash(..), hashLength,+ hashFile, hashString, hashByteString, hashHash, hashHex,+ hashFileForward, toHashForward, fromHashForward,+ hashFileForwardIfStale, hashFileIfStale ) where import System.IO import Data.Hashable import qualified Crypto.Hash.SHA256 as SHA+import qualified Data.ByteString as BS8 import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.HashMap.Strict as Map-import Data.Time-import System.Directory-import Data.Char import System.IO.Unsafe-import System.IO.Error+import Data.Bits import Control.Monad.Extra-import Data.IORef-import Numeric+import Data.IORef.Extra+import General.Binary import Control.Exception.Extra import Control.DeepSeq+import General.FileName+import General.FileInfo +-- | A hash, exactly 32 bytes, may contain NUL or other funny characters+newtype Hash = Hash BS.ByteString+ deriving (NFData, Eq, Hashable) -newtype Hash = Hash String- deriving (NFData, Show, Read, Eq, Hashable)+hashLength :: Int+hashLength = 32 -fromHash :: Hash -> String-fromHash (Hash x) = x+instance BinaryEx Hash where+ getEx = Hash+ putEx (Hash x) = putEx x +instance Show Hash where+ show = hashHex+ mkHash :: BS.ByteString -> Hash-mkHash = Hash . concatMap (f . ord) . BS.unpack- where f i = ['0' | i < 16] ++ showHex i ""+mkHash = Hash +-- | Show a hash as hex characters+hashHex :: Hash -> String+hashHex (Hash x) = f $ BS8.unpack x+ where+ f (x:xs) = g (x `shiftR` 4) : g (x .&. 0xf) : f xs+ f [] = []+ g x = case x of+ 0 -> '0'+ 1 -> '1'+ 2 -> '2'+ 3 -> '3'+ 4 -> '4'+ 5 -> '5'+ 6 -> '6'+ 7 -> '7'+ 8 -> '8'+ 9 -> '9'+ 10 -> 'a'+ 11 -> 'b'+ 12 -> 'c'+ 13 -> 'd'+ 14 -> 'e'+ 15 -> 'f' -- Hashing lots of files is expensive, so we keep a cache {-# NOINLINE hashCache #-}-hashCache :: IORef (Map.HashMap FilePath (UTCTime, Hash))+hashCache :: IORef (Map.HashMap FileName (ModTime, Hash)) hashCache = unsafePerformIO $ newIORef Map.empty +toHashForward :: FileName -> Maybe FileName+toHashForward x = let b = fileNameToByteString x+ s = BS.pack ".rattle.hash" in+ if BS.isSuffixOf s b then Nothing+ else Just $ byteStringToFileName $ BS.append b s -getModTime :: FilePath -> IO (Maybe UTCTime)-getModTime x = handleBool isDoesNotExistError (const $ return Nothing) (Just <$> getModificationTime x)+fromHashForward :: FileName -> Maybe FileName+fromHashForward x = let b = fileNameToByteString x+ s = BS.pack ".rattle.hash" in+ byteStringToFileName <$> BS.stripSuffix s b +hashFileForwardIfStale :: FileName -> ModTime -> Hash -> IO (Maybe Hash)+hashFileForwardIfStale file mt h =+ case toHashForward file of+ Nothing -> hashFileIfStale file mt h+ Just file2 -> do+ b2 <- doesFileNameExist file2+ if not b2 then hashFileIfStale file mt h else do+ b <- doesFileNameExist file+ if not b then pure Nothing else hashFileIfStale file2 mt h -hashFile :: FilePath -> IO (Maybe Hash)+hashFileIfStale :: FileName -> ModTime -> Hash -> IO (Maybe Hash)+hashFileIfStale file mt h = do+ start <- getModTime file+ case start of+ Nothing -> pure Nothing+ Just start -> do+ mp <- readIORef hashCache+ case Map.lookup file mp of+ Just (time,hash) | time == start -> pure $ Just hash+ _ | start == mt -> do f start h; pure $ Just h+ _ -> do+ b <- doesFileNameExist file+ if not b then pure Nothing else do+ res <- withFile (fileNameToString file) ReadMode $ \h -> do+ chunks <- LBS.hGetContents h+ evaluate $ force $ mkHash $ SHA.finalize $ SHA.updates SHA.init $ LBS.toChunks chunks+ end <- getModTime file+ when (Just start == end) $+ f start res+ pure $ Just res+ where f start res = atomicModifyIORef'_ hashCache $ Map.insert file (start, res)++-- | If there is a forwarding hash, and this file exists, use the forwarding hash instead+hashFileForward :: FileName -> IO (Maybe (ModTime, Hash))+hashFileForward file =+ case toHashForward file of+ Nothing -> hashFile file+ Just file2 -> do+ b2 <- doesFileNameExist file2+ if not b2 then hashFile file else do+ b <- doesFileNameExist file+ if not b then pure Nothing else hashFile file2++hashFile :: FileName -> IO (Maybe (ModTime, Hash)) hashFile file = do start <- getModTime file case start of- Nothing -> return Nothing+ Nothing -> pure Nothing Just start -> do mp <- readIORef hashCache case Map.lookup file mp of- Just (time, hash) | time == start -> return $ Just hash+ Just (time, hash) | time == start -> pure $ Just (time, hash) _ -> do -- we can get a ModTime on a directory, but can't withFile it- b <- doesFileExist file- if not b then return Nothing else do- res <- withFile file ReadMode $ \h -> do+ b <- doesFileNameExist file+ if not b then pure Nothing else do+ res <- withFile (fileNameToString file) ReadMode $ \h -> do chunks <- LBS.hGetContents h evaluate $ force $ mkHash $ SHA.finalize $ SHA.updates SHA.init $ LBS.toChunks chunks end <- getModTime file when (Just start == end) $- atomicModifyIORef' hashCache $ \mp -> (Map.insert file (start, res) mp, ())- return $ Just res+ atomicModifyIORef'_ hashCache $ Map.insert file (start, res)+ pure $ Just (start, res) hashString :: String -> Hash--- we first 'show' the String to avoid having > 256 characters in it-hashString = mkHash . SHA.hash . BS.pack . show+hashString = hashByteString . BS.pack++hashByteString :: BS.ByteString -> Hash+hashByteString = mkHash . SHA.hash++hashHash :: Hash -> Hash+hashHash (Hash x) = mkHash $ SHA.hash x
+ src/Development/Rattle/Hazards.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE RecordWildCards #-}++module Development.Rattle.Hazards(+ Hazard(..), Recoverable(..),+ HazardSet, mergeHazardSet, newHazardSet, emptyHazardSet, seenHazardSet, addHazardSet,+ recoverableHazard, restartableHazard,+ ) where++import Development.Rattle.Types+import Control.Exception.Extra+import System.Time.Extra+import General.Extra+import Data.List+import Data.Tuple.Extra+import qualified Data.HashMap.Strict as Map+import General.FileName++data ReadOrWrite = Read | Write deriving (Show,Eq)++-- For Write, Seconds is the last possible time at which it was written+-- For Read, Seconds is the earliest possible time at which it was read+-- In both cases, Cmd is the thing that caused the read/write+newtype HazardSet = HazardSet (Map.HashMap FileName (ReadOrWrite, Seconds, Cmd))+ deriving Show+++-- | Type of exception thrown if there is a hazard when running the build system.+data Hazard+ = ReadWriteHazard FileName Cmd Cmd Recoverable+ | WriteWriteHazard FileName Cmd Cmd Recoverable+ deriving Show+instance Exception Hazard++data Recoverable = Recoverable | NonRecoverable | Restartable deriving (Show,Eq)++recoverableHazard :: Hazard -> Bool+recoverableHazard WriteWriteHazard{} = False+recoverableHazard (ReadWriteHazard _ _ _ r) = r == Recoverable++restartableHazard :: Hazard -> Bool+restartableHazard (WriteWriteHazard _ _ _ r) = r == Restartable+restartableHazard (ReadWriteHazard _ _ _ r) = r == Restartable++emptyHazardSet :: HazardSet+emptyHazardSet = HazardSet Map.empty++seenHazardSet :: FileName -> HazardSet -> Bool+seenHazardSet x (HazardSet mp) = x `Map.member` mp++newHazardSet :: Seconds -> Seconds -> Cmd -> Touch FileName -> HazardSet+newHazardSet start stop cmd Touch{..} = HazardSet $ Map.fromList $+ map (,(Write,stop ,cmd)) tWrite +++ map (,(Read ,start,cmd)) tRead++mergeHazardSet :: [Cmd] -> HazardSet -> HazardSet -> ([Hazard], HazardSet)+mergeHazardSet required (HazardSet h1) (HazardSet h2) =+ second HazardSet $ unionWithKeyEithers (mergeFileOps required) h1 h2++-- | addHazardSet a b c d e f == mergeHazardSet a b (newHazardSet c d e f)+addHazardSet :: [Cmd] -> HazardSet -> Seconds -> Seconds -> Cmd -> Touch FileName -> ([Hazard], HazardSet)+addHazardSet required (HazardSet h1) start stop cmd Touch{..} =+ second HazardSet $ insertWithKeyEithers (mergeFileOps required) h1 $+ map (,(Write,stop,cmd)) tWrite ++ map (,(Read,start,cmd)) tRead+++-- Very carefully written to include the commands+{- HLINT ignore mergeFileOps "Redundant if" -}+{- HLINT ignore mergeFileOps "Use infix" -}++-- r is required list; s is speculate list+mergeFileOps :: [Cmd] -> FileName -> (ReadOrWrite, Seconds, Cmd) -> (ReadOrWrite, Seconds, Cmd) -> Either Hazard (Maybe (ReadOrWrite, Seconds, Cmd))+mergeFileOps r x (Read, t1, cmd1) (Read, t2, cmd2)+ | t1 <= t2 = Right Nothing -- don't update the Map (an optimisation for the common case)+ | otherwise = Right $ Just (Read, t2, cmd2)+mergeFileOps r x (Write, t1, cmd1) (Write, t2, cmd2) = Left $ WriteWriteHazard x cmd1 cmd2 $+ -- if they both were required, we've got a problem+ if elem cmd1 r && elem cmd2 r then NonRecoverable+ -- if one (or both) were speculated, we might be able to restart and get over it+ else Restartable++mergeFileOps r x (Read, tR, cmdR) (Write, tW, cmdW)+ | tW < tR = -- write happened first+ -- if the write hasn't been demanded but the read has we've+ -- managed to read something that was speculated, which is bad+ if elem cmdR r && notElem cmdW r then hazard Restartable+ -- otherwise, everything is good+ else Right $ Just (Write, tW, cmdW)++ | otherwise = -- read happened first+ -- if the read was speculated, we can ignore it+ if notElem cmdR r then hazard Recoverable+ -- if the write was speculated, we can restart and hopefully it won't recur+ else if notElem cmdW r then hazard Restartable+ -- neither was speculated, but did we use speculation to reorder them?+ -- note the order seems backwards, because r is a snoc-list+ -- FIXME: We might have had them race because of parallelism, so this is optimistically restartable+ else if elemIndex cmdR r < elemIndex cmdW r then hazard Restartable+ -- the user wrote the read before the write+ else hazard NonRecoverable+ where+ hazard = Left . ReadWriteHazard x cmdW cmdR+mergeFileOps r x v1 v2 = mergeFileOps r x v2 v1 -- must be Write/Read, so match the other way around
− src/Development/Rattle/Limit.hs
@@ -1,72 +0,0 @@-{-# LANGUAGE TupleSections, LambdaCase #-}--module Development.Rattle.Limit(- Limit, newLimit, withLimit, withLimitMaybe,- ) where--import qualified General.Bilist as B-import Control.Exception-import Control.Monad-import Control.Concurrent.Extra---newtype Limit = Limit (Var S)--data S = Free !Int- | Queued (B.Bilist (IO ()))---newLimit :: Int -> IO Limit-newLimit i- | i < 1 = error $ "newLimit, argument must be >= 1, got " ++ show i- | otherwise = Limit <$> newVar (Free i)--data LS- = Wait -- I am waiting like normal, default state- | Fire -- I got asked to run- | Died -- I got an async exception--withLimit :: Limit -> IO a -> IO a-withLimit (Limit var) act = mask $ \unmask ->- join $ modifyVar var $ \x -> case x of- Free i | i >= 1 -> return $ (Free (i-1),) $- execute unmask- _ -> do- let q = case x of Queued q -> q; _ -> mempty- -- a real pain to deal with async exceptions while waiting- -- but I think this does it - although not very elegant- wait <- newBarrier- ls <- newVar Wait- let go = join $ modifyVar ls $ \x -> return $ case x of- Wait -> (Fire, signalBarrier wait ())- Died -> (Died, finished var)- return $ (Queued $ B.cons go q, ) $ do- unmask (waitBarrier wait) `onException` do- join $ modifyVar ls $ \x -> return $ case x of- Wait -> (Died, return ())- Fire -> (Fire, finished var)- execute unmask- where- execute unmask = do- res <- unmask act `onException` finished var- finished var- return res---withLimitMaybe :: Limit -> IO a -> IO (Maybe a)-withLimitMaybe (Limit var) act = mask $ \unmask ->- join $ modifyVar var $ \x -> case x of- Free i | i >= 1 -> return $ (Free (i-1),) $ do- res <- unmask act `onException` finished var- finished var- return $ Just res- _ -> return (x, return Nothing)---finished :: Var S -> IO ()-finished var = mask_ $- join $ modifyVar var $ \case- Free i -> return (Free (i+1), return ())- Queued q -> case B.uncons q of- Nothing -> return (Free 1, return ())- Just (q, qs) -> return (Queued qs, q)
+ src/Development/Rattle/Options.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE TupleSections #-}++module Development.Rattle.Options(+ RattleOptions(..), RattleUI(..), rattleOptions,+ rattleOptionsExplicit, shorten, expand+ ) where++import Control.Monad.Extra+import General.Extra+import Data.Ord+import System.FilePath+import System.Directory+import Development.Rattle.UI+import qualified Data.HashMap.Strict as Map+import qualified Development.Shake.Command as C+import Data.Maybe+import Data.List.Extra+import General.FileName+import qualified Data.ByteString.Char8 as BSC+import Data.Monoid+import Prelude+++-- | Basic options for configuring rattle.+data RattleOptions = RattleOptions+ {rattleFiles :: FilePath -- ^ Where all my shared files go+ ,rattleSpeculate :: Maybe String -- ^ Should I speculate? Under which key?+ ,rattleMachine :: String -- ^ Key to store run#+ ,rattleShare :: Bool -- ^ Should I share files from the cache+ ,rattleProcesses :: Int -- ^ Number of simulateous processes+ ,rattleCmdOptions :: [C.CmdOption] -- ^ Extra options added to every command line+ ,rattleNamedDirs :: [(String, FilePath)] -- ^ Named directories, e.g. (PWD, .)+ ,rattleUI :: Maybe RattleUI -- ^ Nothing for auto detect+ ,rattleForward :: Bool -- ^ Support forward style stuff+ } deriving Show+++-- | Default 'RattleOptions' value.+rattleOptions :: RattleOptions+rattleOptions = RattleOptions ".rattle" (Just "") "m1" True 0 [] [("PWD",".")] Nothing False+++rattleOptionsExplicit :: RattleOptions -> IO RattleOptions+rattleOptionsExplicit = fixProcessorCount >=> fixNamedDirs+ where+ fixProcessorCount o+ | rattleProcesses o /= 0 = pure o+ | otherwise = do p <- getProcessorCount; pure o{rattleProcesses=p}++ fixNamedDirs o = do+ xs <- sequence [(a,) . addTrailingPathSeparator <$> canonicalizePath b | (a,b) <- rattleNamedDirs o]+ -- sort so all prefixes come last, so we get the most specific match+ pure o{rattleNamedDirs = sortOn (Down . snd) xs}+++shorten :: [(String, String)] -> FileName -> FileName+shorten [] = id+shorten named = \x -> fromMaybe x $ firstJust (f x) named2+ where+ named2 = [(BSC.pack $ "$" ++ a ++ [pathSeparator], BSC.pack $ addTrailingPathSeparator b) | (a,b) <- named]+ f x (name,dir) = do rest <- BSC.stripPrefix dir $ fileNameToByteString x; pure $ byteStringToFileName $ name <> rest++expand :: [(String, String)] -> FileName -> FileName+expand [] = id+expand named = \x -> case BSC.uncons $ fileNameToByteString x of+ Just ('$', x)+ | (x1, x2) <- BSC.break isPathSeparator x+ , not $ BSC.null x2+ , Just v <- Map.lookup x1 named2+ -> byteStringToFileName $ v <> x2+ _ -> x+ where+ named2 = Map.fromList [(BSC.pack a, BSC.pack b) | (a,b) <- named]
+ src/Development/Rattle/Profile.hs view
@@ -0,0 +1,275 @@+{-# LANGUAGE ScopedTypeVariables, RecordWildCards, TupleSections #-}+{-# OPTIONS_GHC -w #-}++module Development.Rattle.Profile(+ constructGraph, Graph(..), dotStringOfGraph,+ graphData, writeProfile+ ) where++import Development.Rattle.Options+import Development.Rattle.Types+import Development.Rattle.Hash+import Development.Rattle.Hazards+import Development.Rattle.Shared+import Control.Monad+import Data.Maybe+import Data.List+import qualified Data.ByteString.Lazy.Char8 as LBS+import General.Template+import General.Paths+import qualified Data.HashMap.Strict as Map+import qualified Data.HashSet as Set+import System.Time.Extra+import Numeric.Extra+import General.FileName+import General.FileInfo+import Data.Tuple.Extra++-- edge is directed based on order cmd were listed in script+-- end1 was listed before end2. helps determine read/write hazards+data Edge = Edge {end1 :: (Cmd, [Trace (FileName, ModTime, Hash)])+ ,end2 :: (Cmd, [Trace (FileName, ModTime, Hash)])+ ,hazard :: Maybe Hazard+ }++data Graph = Graph {nodes :: [(Cmd, [Trace (FileName, ModTime, Hash)])]+ ,edges :: [Edge]+ }++instance Show Edge where+ show (Edge e1 e2 Nothing) = showCmd (fst e1) ++ " -> " ++ showCmd (fst e2)+ show (Edge e1 e2 (Just h)) = showCmd (fst e1) ++ " -> " ++ showCmd (fst e2) ++ " [ label=\"" ++ show h ++ "\" ];"++getCmdsTraces :: RattleOptions -> IO [(Cmd,[Trace (FileName, ModTime, Hash)])]+getCmdsTraces options@RattleOptions{..} = withShared rattleFiles True $ \shared -> do+ cmds <- maybe (pure []) (getSpeculate shared) rattleSpeculate+ fmap (takeWhile (not . null . snd)) $ forM cmds $ \x -> (x,) <$> getCmdTraces shared x++getLastRun :: RattleOptions -> IO (Maybe RunIndex)+getLastRun options@RattleOptions{..} = withShared rattleFiles True $ \shared ->+ lastRun shared rattleMachine++constructGraph :: RattleOptions -> IO Graph+constructGraph options@RattleOptions{..} = do+ cmdsWTraces <- getCmdsTraces options+ pure $ createGraph cmdsWTraces++-- | Given some options, produce various statistics.+graphData :: RattleOptions -> IO (Seconds,Seconds,Seconds)+graphData options = do+ cmdsWTraces <- getCmdsTraces options+ let graph = createGraph cmdsWTraces+ w = work graph+ s = spanGraph graph in+ pure (w,s,w / s)++-- | Generate a profile report given a file.+writeProfile :: RattleOptions -> FilePath -> IO ()+writeProfile options out = do+ graph <- constructGraph options+ runNum <- getLastRun options+ writeProfileInternal out graph runNum++writeProfileInternal :: FilePath -> Graph -> Maybe RunIndex -> IO ()+writeProfileInternal out g t = LBS.writeFile out =<< generateHTML g t++{- build graph using trace info+ Add an edge between 2 nodes if they both write the same file+ Add an edge between 2 nodes if one reads a file and another writes it -}+createGraph :: [(Cmd,[Trace (FileName, ModTime, Hash)])] -> Graph+createGraph xs = Graph xs $ g xs+ where g [] = []+ g (x:xs) = let edges = mapMaybe (createEdge x) xs in+ edges ++ g xs++-- assume p1 occurred before p2.+-- find the worst type of hazard if there is an edge+createEdge :: (Cmd,[Trace (FileName, ModTime, Hash)]) -> (Cmd,[Trace (FileName, ModTime, Hash)]) -> Maybe Edge+createEdge p1@(cmd1,ts) p2@(cmd2,ls) = -- first look for write write hazard then look for both read/write and write/read hazards+ case writeWriteHazard ts ls of+ Just fp -> Just $ Edge p1 p2 $ Just $ WriteWriteHazard fp cmd1 cmd2 NonRecoverable+ Nothing -> case readWriteHazard ts ls of+ Just fp -> Just $ Edge p1 p2 $ Just $ ReadWriteHazard fp cmd1 cmd2 NonRecoverable+ Nothing -> -- check for a non hazard edge+ case readWriteHazard ls ts of+ Just fp -> Just $ Edge p1 p2 Nothing -- regular edge+ Nothing -> Nothing -- no edge++-- Is there a writewrite edge?+writeWriteHazard :: [Trace (FileName, ModTime, Hash)] -> [Trace (FileName, ModTime, Hash)] -> Maybe FileName+writeWriteHazard = maybeHazard (tWrite . tTouch)++-- Is there a readwrite edge?+readWriteHazard :: [Trace (FileName, ModTime, Hash)] -> [Trace (FileName, ModTime, Hash)] -> Maybe FileName+readWriteHazard = maybeHazard (tRead . tTouch)++maybeHazard :: (Trace (FileName, ModTime, Hash) -> [(FileName, ModTime, Hash)]) -> [Trace (FileName, ModTime, Hash)] -> [Trace (FileName, ModTime, Hash)] -> Maybe FileName+maybeHazard _ [] ls = Nothing+maybeHazard _ ls [] = Nothing+maybeHazard f (t:ts) ls =+ case find (\y -> isJust $ memberWrites y ls) $ f t of+ Just (fp,_,_) -> Just fp+ Nothing -> maybeHazard f ts ls++memberWrites :: (FileName, ModTime, Hash) -> [Trace (FileName, ModTime, Hash)] -> Maybe FileName+memberWrites x [] = Nothing+memberWrites x@(fp,_,_) (y:ys) =+ case fmap (fp,) $ lookup3 fp $ tWrite $ tTouch y of+ Just (fp,_) -> Just fp+ Nothing -> memberWrites x ys++lookup3 :: (Eq a) => a -> [(a,b,c)] -> Maybe (b,c)+lookup3 _ [] = Nothing+lookup3 key ((x,y,z):xyzs)+ | key == x = Just (y,z)+ | otherwise = lookup3 key xyzs++-- todo fix+generateDotString :: Graph -> IO String+generateDotString (Graph ns xs) = pure $ "digraph " ++ "{\n" +++ showEdges xs +++ "\n}"++showEdges :: [Edge] -> String+showEdges = intercalate "\n" . map show++showCmd :: Cmd -> String+showCmd (Cmd _ _ args) = show $ showCmdHelper args++showCmdHelper :: [String] -> String+showCmdHelper = unwords++dotStringOfGraph :: RattleOptions -> IO String+dotStringOfGraph options = do+ edges <- constructGraph options+ generateDotString edges++graphRoots :: [(Cmd,[Trace (FileName, ModTime, Hash)])] -> [Edge] -> [(Cmd,[Trace (FileName, ModTime, Hash)])]+graphRoots = foldr (delete . end2)++graphLeaves :: [(Cmd,[Trace (FileName, ModTime, Hash)])] -> [Edge] -> [(Cmd,[Trace (FileName, ModTime, Hash)])]+graphLeaves = foldr (delete . end1)++firstTTime :: [Trace (FileName, ModTime, Hash)] -> Seconds+firstTTime [] = 0+firstTTime (x:_) = tStop x - tStart x++work :: Graph -> Seconds+work (Graph ns es) = sum $ map (firstTTime . snd) ns++spanGraph :: Graph -> Seconds+spanGraph (Graph ns es) =+ -- get roots and calculate span for each root; take max+ -- roots are the cmds that are only end1;+ -- probably want a hashset from cmd to edges+ let cmds = foldl' (\m (Edge e1 e2 h) -> Map.insertWith (++) e1 [e2] m) Map.empty es+ roots = graphRoots ns es in+ foldl' (\m c -> max m $ spanCmd c cmds) 0.0 roots++spanCmd :: (Cmd, [Trace (FileName, ModTime, Hash)]) -> Map.HashMap (Cmd, [Trace (FileName, ModTime, Hash)]) [(Cmd,[Trace (FileName, ModTime, Hash)])] -> Seconds+spanCmd cmd@(c,ts) cmds =+ case Map.lookup cmd cmds of+ Nothing -> firstTTime ts+ Just ls -> firstTTime ts + foldl (\m c -> max m $ spanCmd c cmds) 0.0 ls++parallelism :: Graph -> Seconds+parallelism g = work g / spanGraph g++generateHTML :: Graph -> Maybe RunIndex -> IO LBS.ByteString+generateHTML xs t = do+ report <- readDataFileHTML "profile.html"+ let f "data/profile-data.js" = pure $ LBS.pack $ "var profile =\n" ++ generateJSON xs t+ runTemplate f report++allWrites :: [Trace (FileName, ModTime, Hash)] -> [FileName]+allWrites [] = []+allWrites (x:xs) = Set.toList $ foldl' (\s (fp,_,_) -> Set.insert fp s) (Set.fromList $ allWrites xs) $ tWrite $ tTouch x++allReads :: [Trace (FileName, ModTime, Hash)] -> [FileName]+allReads [] = []+allReads (x:xs) = Set.toList $ foldl' (\s (fp,_,_) -> Set.insert fp s) (Set.fromList $ allReads xs) $ tRead $ tTouch x++changedFiles :: (Trace (FileName, ModTime, Hash) -> [(FileName, ModTime, Hash)]) -> [Trace (FileName, ModTime, Hash)] -> Maybe RunIndex -> Set.HashSet FileName+changedFiles _ _ Nothing = Set.empty+changedFiles _ [] _ = Set.empty+changedFiles f (x:xs) (Just t) = if t == tRun x+ then g x xs+ else Set.empty+ where g x [] = Set.fromList $ map fst3 $ f x+ g x (y:ys) = Set.map fst3 $ Set.difference (Set.fromList $ f x) (Set.fromList $ f y)++changedWrites :: [Trace (FileName, ModTime, Hash)] -> Maybe RunIndex -> Set.HashSet FileName+changedWrites = changedFiles (tWrite . tTouch)++changedReads :: [Trace (FileName, ModTime, Hash)] -> Maybe RunIndex -> Set.HashSet FileName+changedReads = changedFiles (tWrite . tTouch)++cmdIndex :: (Cmd,[Trace (FileName, ModTime, Hash)]) -> [(Cmd,[Trace (FileName, ModTime, Hash)])] -> Int+cmdIndex x cmds = fromMaybe (-1) $ elemIndex x cmds++{- Readers are cmds that read something this command wrote // they depend on this command+ writers are cmds that wrote something this command read // i depend on them+ hazards are cmds that wrote after a read or a write+-}+readersWritersHazards :: (Cmd,[Trace (FileName, ModTime, Hash)]) -> [(Cmd,[Trace (FileName, ModTime, Hash)])] -> [Edge] -> ([Int],[Int],[Int])+readersWritersHazards c cmds =+ foldl' (\(ls1,ls2,ls3) (Edge e1 e2 h) ->+ if c == e1+ then let i = cmdIndex e2 cmds in+ case h of -- check for reader that is not a hazard+ Nothing -> (i:ls1,ls2,ls3) -- no hazard+ Just _ -> (ls1,ls2,i:ls3) -- could be writewrite or readwrite; ignore type for now+ else if c == e2+ then let i = cmdIndex e1 cmds in+ case h of -- check for writer that is not a hazard+ Nothing -> (ls1,i:ls2,ls3) -- no hazard+ Just _ -> (ls1,ls2,i:ls3) -- could be writewrite or readwrite; ignore type for now+ else (ls1,ls2,ls3)) -- does not belong to this edge+ ([],[],[])++generateJSON :: Graph -> Maybe RunIndex -> String+generateJSON g@Graph{..} t = jsonListLines $ map (showCmdTrace nodes) nodes ++ [showRoot]+ where showCmdTrace cmds cmd@(cmdName,ts) =+ let (readers,writers,hazards) = readersWritersHazards cmd cmds edges+ cw = changedWrites ts t+ built = if null ts then 0 else case t of -- was this command run in the last run?+ Nothing -> 0+ (Just t) -> if tRun (head ts) == t then 1 else 0+ changed = if null cw then 0 else 1 -- did the output of this command change in the last run?+ p1 = map (\w -> if Set.member w cw+ then (w,1)+ else (w,0)) $ allWrites ts+ p2 = map (\r -> if Set.member r $ changedReads ts t+ then (r,1)+ else (r,0)) $ allReads ts in+ jsonList+ [showCmd cmdName+ ,showTime $ firstTTime ts -- max time of all traces+ ,show $ length ts -- number of times traced+ ,show built+ ,show changed+ ,jsonList $ map jsonPair p1 -- all files written during all traces+ ,jsonList $ map jsonPair p2 -- all files read during all traces+ ,show readers -- list of readers with no hazard; depend on me+ ,show writers -- list of writers with no hazard; depend on them+ ,show hazards] -- list of cmds this cmd has a hazard with+ showRoot = jsonList+ [show "root"+ ,showTime 0+ ,show (-1)+ ,show 1+ ,show 0+ ,"[]"+ ,"[]"+ ,"[]"+ ,show $ map (`cmdIndex` nodes) $ graphLeaves nodes edges+ ,"[]"]+ showTime x = if '.' `elem` y+ then dropWhileEnd (== '.') $ dropWhileEnd (== '0') y+ else y+ where y = showDP 4 x+++jsonListLines xs = "[" ++ intercalate "\n," xs ++ "\n]"+jsonList xs = "[" ++ intercalate "," xs ++ "]"+jsonPair (f,i) = "[" ++ show f ++ "," ++ show i ++ "]"
+ src/Development/Rattle/Program.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE RecordWildCards #-}++module Development.Rattle.Program(+ Program, newProgram, runProgram+ ) where++import Development.Rattle.Hash+import Development.Rattle.Server+import Development.Rattle.Derived+import Development.Shake.Command+import System.IO.Unsafe+import System.FilePath+import Language.Haskell.TH+import qualified Data.ByteString.Char8 as BS++-- | A program that can be run externally.+data Program a = Program+ {programDisplay :: a -> String+ ,programContents :: String+ ,programHash :: Hash+ }++-- | Create a new program which is based on a TH splice.+newProgram :: (Show a, Read a) => (a -> String) -> Q (TExp (a -> IO ())) -> Program a+newProgram display expr = Program display contents (hashString contents)+ where contents = unlines $ generate $ unsafePerformIO $ runQ expr++-- | Run a program.+runProgram :: Show a => Program a -> a -> Run ()+runProgram Program{..} x = do+ let Hash unhash = programHash+ let file = ".rattle/program/" </> BS.unpack unhash <.> "hs"+ cmdWriteFile file programContents+ cmd "runhaskell" file [show x]++generate :: TExp (a -> IO ()) -> [String]+generate expr =+ ["import System.Environment"+ ,"import System.IO"+ ,"import System.Directory"+ ,"import Development.Shake.Command"+ ,"import System.FilePath.Windows"+ ,"import Data.List as Data.OldList"+ ,"import System.IO.Extra"+ ,"import Data.Foldable"+ ,"import Data.Functor"+ ,"import System.Directory.Extra"+ ,"import GHC.List"+ ,"import Development.Shake.Command as Development.Shake.Internal.CmdOption"+ ,"import Data.List.Extra"+ ,"import GHC.Base"+ ,"import GHC.Classes"+ ,"main :: IO ()"+ ,"main = do [x] <- System.Environment.getArgs; body (read x)"+ ,"body = " ++ pprint (unType expr)+ ]
src/Development/Rattle/Server.hs view
@@ -1,68 +1,79 @@-{-# LANGUAGE ScopedTypeVariables, RecordWildCards, TupleSections, ViewPatterns, LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables, RecordWildCards, TupleSections, LambdaCase #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs, NamedFieldPuns #-} module Development.Rattle.Server(- RattleOptions(..), rattleOptions,- Rattle, withRattle,- Hazard,- cmdRattle+ Rattle, withRattle, Run(..),+ addCmdOptions ) where import Control.Monad.Extra-import Development.Rattle.Limit+import Control.Monad.Trans.Reader+import Control.Monad.IO.Class+import General.Pool import Development.Rattle.Types+import Development.Rattle.UI import Development.Rattle.Shared+import Development.Rattle.Options hiding (rattleOptions) -- want to avoid accidentally using default options! import Development.Rattle.Hash+import Development.Rattle.Hazards+import Development.Rattle.CmdOption import Control.Exception.Extra import Control.Concurrent.Extra import General.Extra+import Data.Either+import Data.Maybe+import System.Directory import System.FilePath-import qualified Data.ByteString.Char8 as BS+import System.FilePattern+import System.IO.Extra import System.IO.Unsafe(unsafeInterleaveIO) import qualified Development.Shake.Command as C import qualified Data.HashMap.Strict as Map import qualified Data.HashSet as Set import Data.IORef-import Data.Hashable import Data.List.Extra import Data.Tuple.Extra+import System.Time.Extra+import General.FileName+import General.FileInfo+import qualified Data.ByteString.UTF8 as UTF8+import qualified Data.ByteString.Char8 as BS +-- | Type of actions to run. Executed using 'rattle'.+newtype Run a = Run {fromRun :: ReaderT Rattle IO a}+ deriving (Functor, Applicative, Monad, MonadIO) --- | Basic options for configuring rattle.-data RattleOptions = RattleOptions- {rattleFiles :: FilePath -- ^ Where all my shared files go- ,rattleSpeculate :: Maybe String -- ^ Should I speculate? Under which key?- ,rattleShare :: Bool -- ^ Should I share files from the cache- ,rattleProcesses :: Int -- ^ Number of simulateous processes- } deriving Show+instance a ~ () => C.CmdArguments (Run a) where+ cmdArguments (C.CmdArgument x) = do+ let (opts, args) = partitionEithers x+ r <- Run ask+ liftIO $ cmdRattle r opts args --- | Default 'RattleOptions' value.-rattleOptions :: RattleOptions-rattleOptions = RattleOptions ".rattle" (Just "") True 8 -data ReadOrWrite = Read | Write deriving (Show,Eq) data S = S- {timestamp :: !T- -- ^ The current timestamp we are on- ,started :: Map.HashMap Cmd (NoShow (IO ()))+ {started :: Map.HashMap Cmd (NoShow (IO ())) -- ^ Things that have got to running - if you find a duplicate just run the IO -- to wait for it.- ,running :: [(T, Cmd, [Trace ()])]+ ,running :: [(Seconds, Cmd, Maybe (Touch FileName))] -- ^ Things currently running, with the time they started, -- and an amalgamation of their previous Trace (if we have any)- ,hazard :: Map.HashMap FilePath (ReadOrWrite, T, Cmd)+ ,hazard :: HazardSet -- ^ Things that have been read or written, at what time, and by which command -- Used to detect hazards. -- Read is recorded as soon as it can, Write as late as it can, as that increases hazards.- ,pending :: [(T, Cmd, Trace Hash)]+ ,pending :: [(Seconds, Cmd, Trace (FileName, ModTime, Hash))] -- ^ Things that have completed, and would like to get recorded, but have to wait -- to confirm they didn't cause hazards ,required :: [Cmd] -- ^ Things what were required by the user calling cmdRattle, not added due to speculation. -- Will be the 'speculate' list next time around.+ ,speculatable :: [(Cmd, Touch FileName)]+ -- ^ Things that were used in the last speculation with this name+ ,speculateNext :: Maybe Cmd+ -- ^ If I was to speculate, which would I do. A cached value computed from specutable, started, running and hazard } deriving Show - data Problem = Finished | Hazard Hazard@@ -71,204 +82,273 @@ throwProblem Finished = fail "Finished, but still trying to do stuff" throwProblem (Hazard h) = throwIO h --- | Type of exception thrown if there is a hazard when running the build system.-data Hazard- = ReadWriteHazard FilePath Cmd Cmd- | WriteWriteHazard FilePath Cmd Cmd- deriving Show-instance Exception Hazard-- data Rattle = Rattle {options :: RattleOptions- ,speculate :: [(Cmd, [Trace Hash])] -- ^ Things that were used in the last speculation with this name+ ,runIndex :: !RunIndex -- ^ Run# we are on ,state :: Var (Either Problem S)+ ,timer :: IO Seconds ,speculated :: IORef Bool- ,limit :: Limit+ ,speculatableWrites :: Set.HashSet FileName+ ,pool :: Pool+ ,ui :: UI ,shared :: Shared+ ,shortener :: FileName -> FileName } +addCmdOptions :: [C.CmdOption] -> Rattle -> Rattle+addCmdOptions new r@Rattle{options=o@RattleOptions{rattleCmdOptions=old}} =+ r{options = o{rattleCmdOptions = old ++ new}} + withRattle :: RattleOptions -> (Rattle -> IO a) -> IO a-withRattle options@RattleOptions{..} act = withShared rattleFiles $ \shared -> do- speculate <- maybe (return []) (getSpeculate shared) rattleSpeculate- speculate <- fmap (takeWhile (not . null . snd)) $ forM speculate $ \x -> (x,) <$> unsafeInterleaveIO (getCmdTraces shared x)- speculated <- newIORef False- let s0 = Right $ S t0 Map.empty [] Map.empty [] []- state <- newVar s0- limit <- newLimit rattleProcesses- let r = Rattle{..}- runSpeculate r+withRattle options@RattleOptions{..} act = withUI rattleUI (pure "Running") $ \ui -> withShared rattleFiles rattleShare $ \shared -> do+ options@RattleOptions{..} <- rattleOptionsExplicit options+ -- make sure we have a thread for the speculation too+ withNumCapabilities (rattleProcesses + 1) $ do - let saveSpeculate state =- whenJust rattleSpeculate $ \name ->- whenRightM (readVar state) $ \v ->- setSpeculate shared name $ reverse $ required v+ when (rattleProcesses > 1 && not rtsSupportsBoundThreads) $+ putStrLn "WARNING: Running with multiple threads but not compiled with -threaded" - -- first try and run it- ((act r <* saveSpeculate state) `finally` writeVar state (Left Finished)) `catch`- \(h :: Hazard) -> do+ let expander = expand rattleNamedDirs+ let shortener = shorten rattleNamedDirs+ speculatable <- if rattleProcesses <= 1 then pure [] else do+ speculatable <- maybe (pure []) (getSpeculate shared) rattleSpeculate+ fmap (takeWhile (not . null . snd)) $ -- don't speculate on things we have no traces for+ forM speculatable $ \x -> do+ traces <- unsafeInterleaveIO (getCmdTraces shared x)+ pure (x, normalizeTouch $ foldMap (fmap (expander . fst3) . tTouch) traces)+ let speculatableWrites = Set.fromList $ concatMap (tWrite . snd) speculatable+ speculated <- newIORef False++ runIndex <- nextRun shared rattleMachine+ timer <- offsetTime+ let s0 = S Map.empty [] emptyHazardSet [] [] speculatable Nothing+ state <- newVar $ Right $ ensureS s0++ let saveSpeculate state =+ whenJust rattleSpeculate $ \name ->+ whenRightM (readVar state) $ \v ->+ setSpeculate shared name $ reverse $ required v++ -- first try and run it+ let attempt1 = runPool True rattleProcesses $ \pool -> do+ let r = Rattle{..}+ runSpeculate r+ (act r <* saveSpeculate state) `finally` writeVar state (Left Finished)+ attempt1 `catch` \(h :: Hazard) -> do b <- readIORef speculated- if not b then throwIO h else do+ if not (recoverableHazard h || restartableHazard h) then throwIO h else do -- if we speculated, and we failed with a hazard, try again putStrLn "Warning: Speculation lead to a hazard, retrying without speculation" print h- state <- newVar s0- limit <- newLimit rattleProcesses- let r = Rattle{speculate=[], ..}- (act r <* saveSpeculate state) `finally` writeVar state (Left Finished)-+ state <- newVar $ Right s0{speculatable=[]}+ runPool True rattleProcesses $ \pool -> do+ let r = Rattle{..}+ (act r <* saveSpeculate state) `finally` writeVar state (Left Finished) +-- Kick off the speculation pool worker thread runSpeculate :: Rattle -> IO ()-runSpeculate rattle@Rattle{..} = void $ withLimitMaybe limit $ forkIO $- -- speculate on a process iff it is the first process in speculate that:- -- 1) we have some parallelism free- -- 2) it is the first eligible in the list- -- 3) not already been started- -- 4) no read/write conflicts with anything completed- -- 5) no read conflicts with anything running or any earlier speculation- join $ modifyVar state $ \s -> case s of- Right s | Just cmd <- nextSpeculate rattle s -> do- writeIORef speculated True- cmdRattleStarted rattle cmd s ["speculating"]- _ -> return (s, return ())+runSpeculate rattle@Rattle{..} = when (rattleProcesses options > 1) $+ addPool PoolSpeculate pool $ do+ run <- modifyS rattle $ \case+ s@S{speculateNext=Just cmd} -> do+ writeIORef speculated True+ cmdRattleStarted rattle cmd s ["speculative"]+ _ -> pure (Right Nothing, pure ())+ -- run the command but ignore all errors, if there are real errors+ -- whoever reruns them will bump into them+ ignore run +modifyS :: Rattle -> (S -> IO (Either Problem (Maybe S), IO a)) -> IO (IO a)+modifyS rattle@Rattle{..} act = modifyVar state $ \case+ Left e -> throwProblem e+ Right s -> do+ (res, cont) <- act s+ case res of+ Left e -> pure (Left e, cont)+ Right Nothing -> pure (Right s, cont)+ Right (Just s) -> pure (Right $ ensureS s, runSpeculate rattle >> cont) -nextSpeculate :: Rattle -> S -> Maybe Cmd-nextSpeculate Rattle{..} S{..}- | any (null . thd3) running = Nothing- | otherwise = step (addTrace (Set.empty, Set.empty) $ mconcat $ concatMap thd3 running) speculate+ensureS :: S -> S+ensureS = fillInNext . reduceSpeculate where- addTrace (r,w) Trace{..} = (f r tRead, f w tWrite)- where f set xs = Set.union set $ Set.fromList $ map fst xs+ -- often we drain the front of the speculatable list repeatedly, so do that once+ reduceSpeculate s = s{speculatable = dropWhile (\(c, _) -> c `Map.member` started s) $ speculatable s}+ fillInNext s = s{speculateNext = calculateSpeculateNext s} ++-- speculate on a process iff it is the first process in speculate that:+-- 1) we have some parallelism free+-- 2) it is the first eligible in the list+-- 3) not already been started+-- 4) no read/write conflicts with anything completed+-- 5) no read conflicts with anything running or any earlier speculation+calculateSpeculateNext :: S -> Maybe Cmd+calculateSpeculateNext S{speculatable, running, started, hazard}+ -- I have things to speculate, and I know exactly what is running+ | not $ null speculatable, Just xs <- mapM thd3 running = step (newTouchSet xs) speculatable+ | otherwise = Nothing+ where+ -- Note the TouchSet.tsWrite has been filtered to speculatableWrites+ -- which is sufficient because we only check values of tWrite from speculatable+ step :: TouchSet -> [(Cmd, Touch FileName)] -> Maybe Cmd step _ [] = Nothing step rw ((x,_):xs) | x `Map.member` started = step rw xs -- do not update the rw, since its already covered- step rw@(r, w) ((x, mconcat -> t@Trace{..}):xs)- | not $ any (\v -> v `Set.member` r || v `Set.member` w || v `Map.member` hazard) $ map fst tWrite+ step rw ((x, t@Touch{..}):xs)+ | not $ any (\v -> v `Set.member` tsRead rw || v `Set.member` tsWrite rw || seenHazardSet v hazard) tWrite -- if anyone I write has ever been read or written, or might be by an ongoing thing, that would be bad- , not $ any (`Set.member` w) $ map fst tRead+ , not $ any (`Set.member` tsWrite rw) tRead -- if anyone I read might be being written right now, that would be bad = Just x | otherwise- = step (addTrace rw t) xs+ = step (addTouchSet rw t) xs -cmdRattle :: Rattle -> [String] -> IO ()-cmdRattle rattle args = cmdRattleRequired rattle $ Cmd args+cmdRattle :: Rattle -> [C.CmdOption] -> [String] -> IO ()+cmdRattle rattle opts args = cmdRattleRequired rattle $ mkCmd (rattleCmdOptions (options rattle) ++ opts) args cmdRattleRequired :: Rattle -> Cmd -> IO ()-cmdRattleRequired rattle@Rattle{..} cmd = withLimit limit $ do- modifyVar_ state $ return . fmap (\s -> s{required = cmd : required s})+cmdRattleRequired rattle@Rattle{..} cmd = addPoolWait PoolRequired pool $ do+ modifyVar_ state $ pure . fmap (\s -> s{required = cmd : required s}) cmdRattleStart rattle cmd cmdRattleStart :: Rattle -> Cmd -> IO ()-cmdRattleStart rattle@Rattle{..} cmd = join $ modifyVar state $ \case- Left e -> throwProblem e- Right s -> cmdRattleStarted rattle cmd s []+cmdRattleStart rattle cmd = join $ modifyS rattle $ \s ->+ cmdRattleStarted rattle cmd s [] -cmdRattleStarted :: Rattle -> Cmd -> S -> [String] -> IO (Either Problem S, IO ())+cmdRattleStarted :: Rattle -> Cmd -> S -> [String] -> IO (Either Problem (Maybe S), IO ()) cmdRattleStarted rattle@Rattle{..} cmd s msgs = do- let start = timestamp s- s <- return s{timestamp = succ $ timestamp s}+ start <- timer case Map.lookup cmd (started s) of- Just (NoShow wait) -> return (Right s, wait)+ Just (NoShow wait) -> pure (Right Nothing, wait) Nothing -> do- hist <- unsafeInterleaveIO $ getCmdTraces shared cmd+ hist <- unsafeInterleaveIO $ map (fmap (\(f,mt,h) -> (expand (rattleNamedDirs options) f, mt, h))) <$> getCmdTraces shared cmd go <- once $ cmdRattleRun rattle cmd start hist msgs- s <- return s{running = (start, cmd, map void hist) : running s}- s <- return s{started = Map.insert cmd (NoShow go) $ started s}- return (Right s, runSpeculate rattle >> go >> runSpeculate rattle) + -- we only speculate on the very last one+ -- and we only care about reads which might be speculated as writes+ let trimReads t = t{tRead = filter (`Set.member` speculatableWrites) $ tRead t}+ let specHist = if null hist then Nothing else Just $ trimReads $ fmap fst3 $ tTouch $ last hist + s <- pure s{running = (start, cmd, specHist) : running s}+ s <- pure s{started = Map.insert cmd (NoShow go) $ started s}+ pure (Right $ Just s, go)++ -- either fetch it from the cache or run it)-cmdRattleRun :: Rattle -> Cmd -> T -> [Trace Hash] -> [String] -> IO ()-cmdRattleRun rattle@Rattle{..} cmd@(Cmd args) start hist msgs = do- hasher <- memoIO hashFile- let match (fp, h) = (== Just h) <$> hasher fp- histRead <- filterM (allM match . tRead) hist- histBoth <- filterM (allM match . tWrite) histRead+cmdRattleRun :: Rattle -> Cmd -> Seconds -> [Trace (FileName, ModTime, Hash)] -> [String] -> IO ()+cmdRattleRun rattle@Rattle{..} cmd@(Cmd _ opts args) startTimestamp hist msgs = do+ let forwardOpt = rattleForward options+ let match (fp, mt, h) = (== Just h) <$> (if forwardOpt then hashFileForwardIfStale else hashFileIfStale) fp mt h+ histRead <- filterM (allM match . tRead . tTouch) hist+ histBoth <- filterM (allM match . tWrite . tTouch) histRead case histBoth of t:_ -> -- we have something consistent at this point, no work to do -- technically we aren't writing to the tWrite part of the trace, but if we don't include that -- skipping can turn write/write hazards into read/write hazards- cmdRattleFinished rattle start cmd t False+ cmdRattleFinished rattle startTimestamp cmd t False [] -> do -- lets see if any histRead's are also available in the cache fetcher <- memoIO $ getFile shared- let fetch (fp, h) = do v <- fetcher h; case v of Nothing -> return Nothing; Just op -> return $ Just $ op fp+ let fetch (fp, mt, h) = do v <- fetcher h; case v of Nothing -> pure Nothing; Just op -> pure $ Just $ op fp download <- if not (rattleShare options)- then return Nothing- else firstJustM (\t -> fmap (t,) <$> allMaybeM fetch (tWrite t)) histRead+ then pure Nothing+ else firstJustM (\t -> fmap (t,) <$> allMaybeM fetch (tWrite $ tTouch t)) histRead case download of Just (t, download) -> do- display ["copying"]- sequence_ download- cmdRattleFinished rattle start cmd t False+ display ["copying"] $ sequence_ download+ cmdRattleFinished rattle startTimestamp cmd t False Nothing -> do- display []- t <- fsaTrace <$> C.cmd args- let skip x = "/dev/" `isPrefixOf` x || hasTrailingPathSeparator x- let f xs = mapMaybeM (\x -> fmap (x,) <$> hashFile x) $ filter (not . skip) $ map fst xs- t <- Trace <$> f (tRead t) <*> f (tWrite t)+ start <- timer+ (opts2, c) <- display [] $ cmdRattleRaw ui opts args+ stop <- timer+ touch <- fsaTrace c+ when forwardOpt $+ checkHashForwardConsistency touch+ let pats = matchMany [((), x) | Ignored xs <- opts2, x <- xs]+ --let hasTrailingPathSeparator x = if BS.null x then False else isPathSeparator $ BS.last x+ let hasTrailingPathSeparatorBS = maybe False (isPathSeparator . snd) . BS.unsnoc+ let skip x = BS.isPrefixOf slashDev (fileNameToByteString x) ||+ hasTrailingPathSeparatorBS (fileNameToByteString x) ||+ pats [((),fileNameToString x)] /= []+ let f hasher xs = mapMaybeM (\x -> fmap (\(mt,h) -> (x,mt,h)) <$> hasher x) $ filter (not . skip) xs+ touch <- Touch <$> f (if forwardOpt then hashFileForward else hashFile) (tRead touch) <*> f hashFile (tWrite touch)+ touch <- if forwardOpt then generateHashForwards cmd [x | HashNonDeterministic xs <- opts2, x <- xs] touch else pure touch when (rattleShare options) $- forM_ (tWrite t) $ \(fp, h) ->- setFile shared fp h ((== Just h) <$> hashFile fp)- cmdRattleFinished rattle start cmd t True+ forM_ (tWrite touch) $ \(fp, mt, h) ->+ setFile shared fp h ((== Just h) <$> hashFileIfStale fp mt h)+ cmdRattleFinished rattle startTimestamp cmd (Trace runIndex start stop touch) True where- display msgs2 = BS.putStrLn $ BS.pack $ unwords $ "#" : args ++ ["(" ++ unwords (msgs ++ msgs2) ++ ")" | not $ null $ msgs ++ msgs2]+ display :: [String] -> IO a -> IO a+ display msgs2 = addUI ui (headDef cmdline overrides) (unwords $ msgs ++ msgs2)+ overrides = [x | C.Traced x <- opts] ++ [x | C.UserCommand x <- opts]+ cmdline = unwords $ ["cd " ++ x ++ " &&" | C.Cwd x <- opts] ++ args --- | I finished running a command-cmdRattleFinished :: Rattle -> T -> Cmd -> Trace Hash -> Bool -> IO ()-cmdRattleFinished rattle@Rattle{..} start cmd trace@Trace{..} save = join $ modifyVar state $ \case- Left e -> throwProblem e- Right s -> do- -- update all the invariants- let stop = timestamp s- s <- return s{timestamp = succ $ timestamp s}- s <- return s{running = filter ((/= start) . fst3) $ running s}- s <- return s{pending = [(stop, cmd, trace) | save] ++ pending s}+slashDev :: BS.ByteString+slashDev = BS.pack "/dev/" - -- look for hazards- let newHazards = Map.fromList $ map ((,(Write,start,cmd)) . fst) tWrite ++- map ((,(Read ,stop ,cmd)) . fst) tRead- case unionWithKeyEithers mergeFileOps (hazard s) newHazards of- (ps@(p:_), _) -> return (Left $ Hazard p, print ps >> throwIO p)- ([], hazard2) -> do- s <- return s{hazard = hazard2}+cmdRattleRaw :: UI -> [C.CmdOption] -> [String] -> IO ([CmdOption2], [C.FSATrace BS.ByteString])+cmdRattleRaw ui opts args = do+ (opts, opts2) <- pure $ partitionEithers $ map fromCmdOption opts+ case [x | WriteFile x <- opts2] of+ [] -> do+ let optsUI = if isControlledUI ui then [C.EchoStdout False,C.EchoStderr False] else []+ res <- C.cmd (opts ++ optsUI) args+ pure (opts2, res)+ files -> do+ forM_ files $ \file -> do+ createDirectoryIfMissing True $ takeDirectory file+ writeFileUTF8 file $ concat args+ pure (opts2, map (C.FSAWrite . UTF8.fromString) files) - -- move people out of pending if they have survived long enough- let earliest = minimum $ succ stop : map fst3 (running s)- (safe, pending) <- return $ partition (\x -> fst3 x < earliest) $ pending s- s <- return s{pending = pending}- return (Right s, forM_ safe $ \(_,c,t) -> addCmdTrace shared c t)+checkHashForwardConsistency :: Touch FileName -> IO ()+checkHashForwardConsistency Touch{..} = do+ -- check that anyone who is writing forwarding hashes is writing the actual file+ let sources = mapMaybe fromHashForward tWrite+ let bad = sources \\ tWrite+ when (bad /= []) $+ fail $ "Wrote to the forwarding file, but not the source: " ++ show bad + -- and anyone writing to a file with a hash also updates it+ forwards <- filterM doesFileNameExist $ mapMaybe toHashForward tWrite+ let bad = forwards \\ tWrite+ when (bad /= []) $+ fail $ "Wrote to the source file which has a forwarding hash, but didn't touch the hash: " ++ show bad -mergeFileOps :: FilePath -> (ReadOrWrite, T, Cmd) -> (ReadOrWrite, T, Cmd) -> Either Hazard (ReadOrWrite, T, Cmd)-mergeFileOps x (Read, t1, cmd1) (Read, t2, cmd2) = Right (Read, min t1 t2, if t1 < t2 then cmd1 else cmd2)-mergeFileOps x (Write, t1, cmd1) (Write, t2, cmd2) = Left $ WriteWriteHazard x cmd1 cmd2-mergeFileOps x (Read, t1, cmd1) (Write, t2, cmd2)- | t1 <= t2 = Left $ ReadWriteHazard x cmd2 cmd1- | otherwise = Right (Write, t2, cmd2)-mergeFileOps x v1 v2 = mergeFileOps x v2 v1 -- must be Write/Read, so match the other way around +-- | If you have been asked to generate a forwarding hash for writes+generateHashForwards :: Cmd -> [FilePattern] -> Touch (FileName, ModTime, Hash) -> IO (Touch (FileName, ModTime, Hash))+generateHashForwards cmd ms t = do+ let match = matchMany $ map ((),) ms+ let (normal, forward) = partition (\(x, _, _) -> isJust (toHashForward x) && null (match [((), fileNameToString x)])) $ tWrite t+ let Hash hash = hashString $ show (cmd, tRead t, normal)+ let hhash = hashHash $ Hash hash+ forward <- forM forward $ \(x,mt,_) -> do+ let Just x2 = toHashForward x -- checked this is OK earlier+ BS.writeFile (fileNameToString x2) hash+ pure (x2, mt,hhash)+ pure t{tWrite = tWrite t ++ forward} -allMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe [b])-allMaybeM f [] = return $ Just []-allMaybeM f (x:xs) = do- y <- f x- case y of- Nothing -> return Nothing- Just y -> fmap (y:) <$> allMaybeM f xs+-- | I finished running a command+cmdRattleFinished :: Rattle -> Seconds -> Cmd -> Trace (FileName, ModTime, Hash) -> Bool -> IO ()+cmdRattleFinished rattle@Rattle{..} start cmd trace@Trace{..} save = join $ modifyS rattle $ \s -> do+ -- update all the invariants+ stop <- timer+ s <- pure s{running = filter ((/= start) . fst3) $ running s}+ s <- pure s{pending = [(stop, cmd, trace) | save] ++ pending s} + -- look for hazards+ -- push writes to the end, and reads to the start, because reads before writes is the problem+ case addHazardSet (required s) (hazard s) start stop cmd $ fmap fst3 tTouch of+ (ps@(p:_), _) -> pure (Left $ Hazard p, print ps >> throwIO p)+ ([], hazard2) -> do+ s <- pure s{hazard = hazard2} -unionWithKeyEithers :: (Eq k, Hashable k) => (k -> v -> v -> Either e v) -> Map.HashMap k v -> Map.HashMap k v -> ([e], Map.HashMap k v)-unionWithKeyEithers op lhs rhs = foldl' f ([], lhs) $ Map.toList rhs- where- f (es, mp) (k, v2) = case Map.lookup k mp of- Nothing -> (es, Map.insert k v2 mp)- Just v1 -> case op k v1 v2 of- Left e -> (e:es, mp)- Right v -> (es, Map.insert k v mp)+ -- move people out of pending if they have survived long enough+ maxTimestamp <- timer+ let earliest = minimum $ maxTimestamp : map fst3 (running s)+ (safe, pending) <- pure $ partition (\x -> fst3 x < earliest) $ pending s+ s <- pure s{pending = pending}+ pure (Right $ Just s, forM_ safe $ \(_,c,t) -> addCmdTrace shared c $ fmap (\(f,mt,h) -> (shortener f, mt,h)) t)
@@ -1,80 +1,147 @@-{-# LANGUAGE ViewPatterns #-} module Development.Rattle.Shared( Shared, withShared, getSpeculate, setSpeculate, getFile, setFile,- getCmdTraces, addCmdTrace+ getCmdTraces, addCmdTrace,+ nextRun, lastRun,+ dump ) where import General.Extra import Development.Rattle.Types import Development.Rattle.Hash+import General.FileName+import System.Directory.Extra import System.FilePath-import System.Directory import System.IO.Extra import Data.Maybe+import Data.List import Control.Monad.Extra-import Text.Read import Control.Concurrent.Extra+import qualified Data.ByteString as BS+import General.FileInfo+import General.Binary+import Data.Monoid+import Prelude +---------------------------------------------------------------------+-- PRIMITIVES -data Shared = Shared Lock FilePath+data Shared = Shared Lock FilePath Bool -withShared :: FilePath -> (Shared -> IO a) -> IO a-withShared dir act = do+withShared :: FilePath -> Bool -> (Shared -> IO a) -> IO a+withShared dir multiple act = do lock <- newLock createDirectoryRecursive dir- act $ Shared lock dir+ act $ Shared lock dir multiple -filename :: Hash -> String-filename (fromHash -> a:b:cs) = [a,b] </> cs+filenameHash :: Hash -> String+filenameHash str = let (a:b:cs) = hashHex str in [a,b] </> cs -getList :: (Show a, Read b) => String -> Shared -> a -> IO [b]-getList typ (Shared lock dir) name = withLock lock $ do- let file = dir </> typ </> filename (hashString $ show name)+filenameValue :: BinaryEx a => a -> String+filenameValue = filenameHash . hashByteString . runBuilder . putEx++getList :: (BinaryEx a, BinaryEx b) => String -> Shared -> a -> IO [b]+getList typ (Shared lock dir _) name = withLock lock $ do+ let file = dir </> typ </> filenameValue name b <- doesFileExist file- if not b then return [] else mapMaybe readMaybe . lines <$> readFileUTF8' file+ if not b then pure [] else map getEx . getExList <$> BS.readFile file -setList :: (Show a, Show b) => String -> IOMode -> Shared -> a -> [b] -> IO ()-setList typ mode (Shared lock dir) name vals = withLock lock $ do- let file = dir </> typ </> filename (hashString $ show name)+setList :: (Show a, BinaryEx a, BinaryEx b) => String -> IOMode -> Shared -> a -> [b] -> IO ()+setList typ mode (Shared lock dir multiple) name vals = withLock lock $ do+ let mode2 = if multiple then mode else WriteMode+ let file = dir </> typ </> filenameValue name createDirectoryRecursive $ takeDirectory file unlessM (doesFileExist $ file <.> "txt") $ writeFile (file <.> "txt") $ show name- withFile file mode $ \h -> do+ withFile file mode2 $ \h -> do hSetEncoding h utf8- hPutStr h $ unlines $ map show vals+ BS.hPutStr h $ runBuilder $ putExList $ map putEx vals +---------------------------------------------------------------------+-- SPECIAL SUPPORT FOR FILES +getFile :: Shared -> Hash -> IO (Maybe (FileName -> IO ()))+getFile (Shared lock dir _) hash = do+ let file = dir </> "files" </> filenameHash hash+ b <- doesFileExist file+ pure $ if not b then Nothing else Just $ \out -> do+ let x = fileNameToString out+ createDirectoryRecursive $ takeDirectory x+ copyFile file x++setFile :: Shared -> FileName -> Hash -> IO Bool -> IO ()+setFile (Shared lock dir _) source hash check = do+ let file = dir </> "files" </> filenameHash hash+ unlessM (doesFileExist file) $ withLock lock $ do+ createDirectoryRecursive $ takeDirectory file+ copyFile (fileNameToString source) (file <.> "tmp")+ good <- check+ if not good then+ removeFile $ file <.> "tmp"+ else+ renameFile (file <.> "tmp") file+++---------------------------------------------------------------------+-- TYPE SAFE WRAPPERS++nextRun :: Shared -> String -> IO RunIndex+nextRun share name = do+ t <- maybe runIndex0 nextRunIndex . listToMaybe <$> getList "run" share name+ setList "run" WriteMode share name [t]+ pure t++lastRun :: Shared -> String -> IO (Maybe RunIndex)+lastRun share name = listToMaybe <$> getList "run" share name+ getSpeculate :: Shared -> String -> IO [Cmd] getSpeculate = getList "speculate" setSpeculate :: Shared -> String -> [Cmd] -> IO () setSpeculate = setList "speculate" WriteMode -getCmdTraces :: Shared -> Cmd -> IO [Trace Hash]-getCmdTraces = getList "command"+-- Intermediate data type which puts spaces in the right places to get better+-- word orientated diffs when looking at the output in a text editor+data File = File FileName ModTime Hash+ deriving (Show) -addCmdTrace :: Shared -> Cmd -> Trace Hash -> IO ()-addCmdTrace share cmd t = setList "command" AppendMode share cmd [t]+instance BinaryEx File where+ getEx x = File (byteStringToFileName a) b (getEx c)+ where (b,ca) = binarySplit x+ (c,a) = BS.splitAt hashLength ca+ putEx (File a b c) = putExStorable b <> putEx c <> putEx (fileNameToByteString a) -getFile :: Shared -> Hash -> IO (Maybe (FilePath -> IO ()))-getFile (Shared lock dir) hash = do- let file = dir </> "files" </> filename hash- b <- doesFileExist file- return $ if not b then Nothing else Just $ copyFile file+-- First trace in list is earliest one; last is latest one.+getCmdTraces :: Shared -> Cmd -> IO [Trace (FileName, ModTime, Hash)]+getCmdTraces shared cmd = map (fmap fromFile) <$> getList "command" shared cmd+ where fromFile (File path mt x) = (path, mt, x) -setFile :: Shared -> FilePath -> Hash -> IO Bool -> IO ()-setFile (Shared lock dir) source hash check = do- let file = dir </> "files" </> filename hash- b <- doesFileExist file- unlessM (doesFileExist file) $ withLock lock $ do- createDirectoryRecursive $ takeDirectory file- copyFile source (file <.> "tmp")- good <- check- if not good then- removeFile $ file <.> "tmp"- else- renameFile (file <.> "tmp") file+addCmdTrace :: Shared -> Cmd -> Trace (FileName, ModTime, Hash) -> IO ()+addCmdTrace share cmd t = setList "command" AppendMode share cmd [fmap toFile t]+ where toFile (path, mt, x) = File path mt x+++---------------------------------------------------------------------+-- DUMPING++dumpList :: (String -> IO ()) -> FilePath -> String -> IO ()+dumpList out dir name = do+ out ""+ out $ "## " ++ name+ dirs <- listDirectories $ dir </> name+ forM_ dirs $ \x -> do+ files <- filter (".txt" `isSuffixOf`) <$> listFiles x+ forM_ files $ \file -> do+ out ""+ name <- readFileUTF8' file+ out $ "### " ++ name+ out =<< readFileUTF8' (dropExtension file)+++dump :: (String -> IO ()) -> FilePath -> IO ()+dump out dir = do+ out $ "# Rattle dump: " ++ dir+ mapM_ (dumpList out dir) ["run","speculate","command"]
src/Development/Rattle/Types.hs view
@@ -1,50 +1,163 @@-{-# LANGUAGE TupleSections, GeneralizedNewtypeDeriving, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveTraversable #-}+{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-}+{-# OPTIONS_GHC -Wno-orphans #-} module Development.Rattle.Types(- Trace(..), fsaTrace,- Cmd(..),- T, t0,+ Trace(..), Touch(..), fsaTrace, normalizeTouch,+ TouchSet, tsRead, tsWrite, newTouchSet, addTouchSet,+ Cmd(..), mkCmd,+ RunIndex, runIndex0, nextRunIndex, ) where import Data.Hashable import Data.List.Extra+import System.Directory+import System.Info.Extra+import Control.Monad+import General.Binary+import Data.Word import Development.Shake.Command import Data.Semigroup+import qualified Data.ByteString.UTF8 as UTF8+import qualified Data.ByteString as BS+import qualified Data.HashSet as Set+import GHC.Generics import Prelude+import System.Time.Extra+import General.FileName -newtype Cmd = Cmd [String]- deriving (Show, Read, Eq, Hashable)+-- record the hash as the first field+data Cmd = Cmd Int [CmdOption] [String]+ deriving Eq +instance Show Cmd where+ show (Cmd _ a b) = "Cmd " ++ show a ++ " " ++ show b++instance Hashable Cmd where+ hashWithSalt _ = hash+ hash (Cmd x _ _) = x++mkCmd :: [CmdOption] -> [String] -> Cmd+mkCmd a b = Cmd (hash (a,b)) a b++instance BinaryEx Cmd where+ getEx x = mkCmd (getEx a) (getEx b)+ where (a,b) = getExPair x+ putEx (Cmd _ a b) = putExPair (putEx a) (putEx b)++-- The common values for CmdOption are [], [Shell] and a few others - optimise those+instance BinaryEx [CmdOption] where+ getEx x+ | BS.null x = []+ | BS.length x == 1 = case getEx x :: Word8 of+ 0 -> [Shell]+ 1 -> [EchoStderr False]+ 2 -> [Shell,EchoStderr False]+ | otherwise = map read $ getEx x++ putEx [] = mempty+ putEx [Shell] = putEx (0 :: Word8)+ putEx [EchoStderr False] = putEx (1 :: Word8)+ putEx [Shell,EchoStderr False] = putEx (2 :: Word8)+ putEx xs = putEx $ map show xs++deriving instance Generic CmdOption+deriving instance Read CmdOption+instance Hashable CmdOption+ data Trace a = Trace- {tRead :: [(FilePath, a)]- ,tWrite :: [(FilePath, a)]- } deriving (Show, Read, Functor, Foldable, Traversable)+ {tRun :: {-# UNPACK #-} !RunIndex+ ,tStart :: {-# UNPACK #-} !Seconds+ ,tStop :: {-# UNPACK #-} !Seconds+ ,tTouch :: Touch a+ } deriving (Show, Functor, Foldable, Traversable, Eq) -instance Semigroup (Trace a) where- Trace r1 w1 <> Trace r2 w2 = Trace (r1++r2) (w1++w2)+instance BinaryEx a => BinaryEx (Trace a) where+ getEx x = Trace a b c $ getEx d+ where (a,b,c,d) = binarySplit3 x+ putEx (Trace a b c d) = putExStorable a <> putExStorable b <> putExStorable c <> putEx d -instance Monoid (Trace a) where- mempty = Trace [] []+data Touch a = Touch+ {tRead :: [a]+ ,tWrite :: [a]+ } deriving (Show, Functor, Foldable, Traversable, Eq)++instance BinaryEx a => BinaryEx (Touch a) where+ getEx x = Touch (map getEx $ getExList a) (map getEx $ getExList b)+ where [a,b] = getExList x+ putEx (Touch a b) = putExList [putExList $ map putEx a, putExList $ map putEx b]++instance Semigroup (Touch a) where+ Touch r1 w1 <> Touch r2 w2 = Touch (r1++r2) (w1++w2)++instance Monoid (Touch a) where+ mempty = Touch [] [] mappend = (<>)+ mconcat xs = Touch (concatMap tRead xs) (concatMap tWrite xs) +instance Hashable a => Hashable (Trace a) where+ hashWithSalt s (Trace a b c d) = hashWithSalt s (a,b,c,d) -fsaTrace :: [FSATrace] -> Trace ()-fsaTrace = nubTrace . mconcat . map f+instance Hashable a => Hashable (Touch a) where+ hashWithSalt s (Touch r w) = hashWithSalt s (r,w)++fsaTrace :: [FSATrace BS.ByteString] -> IO (Touch FileName)+-- We want to get normalized traces. On Linux, things come out normalized, and we just want to dedupe them+-- On Windows things come out as C:\windows\system32\KERNELBASE.dll instead of C:\Windows\System32\KernelBase.dll+-- so important to call (expensive) normalizeTouch+fsaTrace fs+ | isWindows =+ -- normalize twice because normalisation is cheap, but canonicalisation might be expensive+ fmap (normalizeTouch . fmap (byteStringToFileName . UTF8.fromString)) $+ canonicalizeTouch $+ fmap UTF8.toString $ normalizeTouch $ mconcatMap f fs+ | otherwise =+ -- We know the file names are already normalized from Shake so avoid a redundant conversion+ pure $ normalizeTouch $ byteStringToFileName <$> mconcatMap f fs where- g r w = Trace (map (,()) r) (map (,()) w)- f (FSAWrite x) = g [] [x]- f (FSARead x) = g [x] []- f (FSADelete x) = g [] [x]- f (FSAMove x y) = g [] [x,y]- f (FSAQuery x) = g [x] []- f (FSATouch x) = g [] [x]+ f (FSAWrite x) = Touch [] [x]+ f (FSARead x) = Touch [x] []+ f (FSADelete x) = Touch [] [x]+ f (FSAMove x y) = Touch [] [x,y]+ f (FSAQuery x) = Touch [x] []+ f (FSATouch x) = Touch [] [x] -nubTrace :: Ord a => Trace a -> Trace a-nubTrace (Trace a b) = Trace (nubOrd a \\ b) (nubOrd b)+normalizeTouch :: (Ord a, Hashable a) => Touch a -> Touch a+-- added 'sort' because HashSet uses the ordering of the hashes, which is confusing+-- and since we are sorting, try and avoid doing too much hash manipulation of the reads+normalizeTouch (Touch a b) = Touch (f $ sort a) (sort $ Set.toList b2)+ where+ b2 = Set.fromList b+ f (x1:x2:xs) | x1 == x2 = f (x1:xs)+ f (x:xs) | x `Set.member` b2 = f xs+ | otherwise = x : f xs+ f [] = [] +canonicalizeTouch :: Touch FilePath -> IO (Touch FilePath)+canonicalizeTouch (Touch a b) = Touch <$> mapM canonicalizePath a <*> mapM canonicalizePath b -newtype T = T Int -- timestamps- deriving (Enum,Eq,Ord,Show) -t0 :: T-t0 = T 0+-- For sets, Set.fromList is fastest if there are no dupes+-- Otherwise a Set.member/Set.insert is fastest+data TouchSet = TouchSet {tsRead :: Set.HashSet FileName, tsWrite :: Set.HashSet FileName}++newTouchSet :: [Touch FileName] -> TouchSet+newTouchSet [] = TouchSet Set.empty Set.empty+newTouchSet (Touch{..}:xs) = foldl' addTouchSet (TouchSet (Set.fromList tRead) (Set.fromList tWrite)) xs++addTouchSet :: TouchSet -> Touch FileName -> TouchSet+addTouchSet TouchSet{..} Touch{..} = TouchSet (f tsRead tRead) (f tsWrite tWrite)+ where f = foldl' (\mp k -> if Set.member k mp then mp else Set.insert k mp)+++-- | Which run we are in, monotonically increasing+newtype RunIndex = RunIndex Int+ deriving (Eq,Ord,Show,Storable,BinaryEx,Hashable)++runIndex0 :: RunIndex+runIndex0 = RunIndex 0++nextRunIndex :: RunIndex -> RunIndex+nextRunIndex (RunIndex i) = RunIndex $ i + 1
+ src/Development/Rattle/UI.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE Rank2Types #-}++module Development.Rattle.UI(+ UI, withUI, addUI, isControlledUI,+ RattleUI(..),+ ) where+++import System.Time.Extra+import Control.Exception+import Data.List.Extra+import qualified System.Console.Terminal.Size as Terminal+import Numeric.Extra+import General.EscCodes+import qualified Data.ByteString.Char8 as BS+import Data.IORef.Extra+import Control.Concurrent.Async+import Control.Monad.Extra+++-- | What UI should rattle show the user.+data RattleUI+ = -- | Show a series of lines for each command run+ RattleSerial+ | -- | Show a few lines that change as commands run+ RattleFancy+ | -- | Don't show commands+ RattleQuiet+ deriving Show++data S = S+ {sTraces :: [Maybe (String, String, Seconds)] -- ^ the traced items, in the order we display them, and relative start time+ ,sUnwind :: Int -- ^ Number of lines we used last time around+ }++emptyS :: S+emptyS = S [] 0++addTrace :: String -> String -> Seconds -> S -> S+addTrace msg1 msg2 time s = s{sTraces = f (msg1,msg2,time) $ sTraces s}+ where+ f v (Nothing:xs) = Just v:xs+ f v (x:xs) = x : f v xs+ f v [] = [Just v]++delTrace :: String -> String -> Seconds -> S -> S+delTrace msg1 msg2 time s = s{sTraces = f (msg1,msg2,time) $ sTraces s}+ where+ f v (Just x:xs) | x == v = Nothing:xs+ f v (x:xs) = x : f v xs+ f v [] = []+++display :: Int -> String -> Seconds -> S -> (S, String)+display width header time s = (s{sUnwind=length post}, escCursorUp (sUnwind s) ++ unlines (map pad post))+ where+ post = "" : (escForeground Green ++ "Status: " ++ header ++ escNormal) : map f (sTraces s)++ pad x = x ++ escClearLine+ f Nothing = " *"+ f (Just (s1,s2,t))+ | width - endN1 > 20 = " * " ++ take (width - endN1 - 4) s1 ++ end1+ | width - endN2 > 20 = " * " ++ take (width - endN2 - 4) s1 ++ end2+ | otherwise = take width $ " * " ++ s1+ where+ end1 = g (time - t) s2+ endN1 = length $ removeEscCodes end1++ end2 = g (time - t) ""+ endN2 = length $ removeEscCodes end2++ g i m | showDurationSecs i == "0s" = if null m then "" else "(" ++ m ++ ")"+ | i < 10 = " (" ++ s ++ ")"+ | otherwise = " (" ++ escForeground (if i > 20 then Red else Yellow) ++ s ++ escNormal ++ ")"+ where s = m ++ [' ' | m /= ""] ++ showDurationSecs i++data UI = UI Bool (forall a . String -> String -> IO a -> IO a)++addUI :: UI -> String -> String -> IO a -> IO a+addUI (UI _ x) = x++isControlledUI :: UI -> Bool+isControlledUI (UI x _) = x++showDurationSecs :: Seconds -> String+showDurationSecs = replace ".00s" "s" . showDuration . intToDouble . round+++-- | Run a compact UI, with the ShakeOptions modifier, combined with+withUI :: Maybe RattleUI -> IO String -> (UI -> IO a) -> IO a+withUI fancy header act = case fancy of+ Nothing ->+ {-+ b <- checkEscCodes+ if b then withUICompact header act else withUISerial act+ -}+ -- for now, let's default to serial+ withUISerial act+ Just RattleFancy -> do+ -- checking the escape codes may also enable them+ checkEscCodes+ withUICompact header act+ Just RattleSerial ->+ withUISerial act+ Just RattleQuiet ->+ withUIQuiet act++withUICompact :: IO String -> (UI -> IO a) -> IO a+withUICompact header act = do+ ref <- newIORef emptyS+ let tweak f = atomicModifyIORef_ ref f+ time <- offsetTime+ let tick = do+ h <- header+ t <- time+ w <- maybe 80 Terminal.width <$> Terminal.size+ mask_ $ putStr =<< atomicModifyIORef ref (display w h t)+ withAsync (forever (tick >> sleep 0.4) `finally` tick) $ \_ ->+ act $ UI True $ \s1 s2 act -> do+ t <- time+ bracket_+ (tweak $ addTrace s1 s2 t)+ (tweak $ delTrace s1 s2 t)+ act++withUISerial :: (UI -> IO a) -> IO a+withUISerial act =+ act $ UI False $ \msg1 msg2 act -> do+ BS.putStrLn $ BS.pack $ msg1 ++ if null msg2 then "" else " (" ++ msg2 ++ ")"+ act++withUIQuiet :: (UI -> IO a) -> IO a+withUIQuiet act =+ act $ UI False $ \_ _ act -> act
src/General/Bilist.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wno-unused-imports #-} -- Semigroup moved for GHC 8.8 -- | List type that supports O(1) amortized 'cons', 'snoc', 'uncons' and 'isEmpty'. module General.Bilist(@@ -5,6 +6,7 @@ ) where import Data.Semigroup (Semigroup(..))+import Prelude data Bilist a = Bilist [a] [a]
+ src/General/Binary.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, Rank2Types #-}++module General.Binary(+ binarySplit, binarySplit2, binarySplit3, unsafeBinarySplit,+ Builder(..), runBuilder, sizeBuilder,+ BinaryEx(..),+ Storable, putExStorable, getExStorable, putExStorableList, getExStorableList,+ putExList, getExList, putExN, getExN, putExPair, getExPair+ ) where++import Control.Monad+import Data.Word+import Data.List.Extra+import Data.Tuple.Extra+import Foreign.Storable+import Foreign.Ptr+import System.IO.Unsafe as U+import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as BS+import qualified Data.ByteString.Unsafe as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.UTF8 as UTF8+import Data.Semigroup+import Prelude+++---------------------------------------------------------------------+-- STORE TYPE++binarySplit :: forall a . Storable a => BS.ByteString -> (a, BS.ByteString)+binarySplit bs | BS.length bs < sizeOf (undefined :: a) = error "Reading from ByteString, insufficient left"+ | otherwise = unsafeBinarySplit bs++binarySplit2 :: forall a b . (Storable a, Storable b) => BS.ByteString -> (a, b, BS.ByteString)+binarySplit2 bs | BS.length bs < sizeOf (undefined :: a) + sizeOf (undefined :: b) = error "Reading from ByteString, insufficient left"+ | (a,bs) <- unsafeBinarySplit bs, (b,bs) <- unsafeBinarySplit bs = (a,b,bs)++binarySplit3 :: forall a b c . (Storable a, Storable b, Storable c) => BS.ByteString -> (a, b, c, BS.ByteString)+binarySplit3 bs | BS.length bs < sizeOf (undefined :: a) + sizeOf (undefined :: b) + sizeOf (undefined :: c) = error "Reading from ByteString, insufficient left"+ | (a,bs) <- unsafeBinarySplit bs, (b,bs) <- unsafeBinarySplit bs, (c,bs) <- unsafeBinarySplit bs = (a,b,c,bs)+++unsafeBinarySplit :: Storable a => BS.ByteString -> (a, BS.ByteString)+unsafeBinarySplit bs = (v, BS.unsafeDrop (sizeOf v) bs)+ where v = unsafePerformIO $ BS.unsafeUseAsCString bs $ \ptr -> peek (castPtr ptr)+++-- forM for zipWith+for2M_ :: Applicative m => [a] -> [b] -> (a -> b -> m c) -> m ()+for2M_ as bs f = zipWithM_ f as bs++---------------------------------------------------------------------+-- BINARY SERIALISATION++-- We can't use the Data.ByteString builder as that doesn't track the size of the chunk.+data Builder = Builder {-# UNPACK #-} !Int (forall a . Ptr a -> Int -> IO ())++sizeBuilder :: Builder -> Int+sizeBuilder (Builder i _) = i++runBuilder :: Builder -> BS.ByteString+runBuilder (Builder i f) = unsafePerformIO $ BS.create i $ \ptr -> f ptr 0++instance Semigroup Builder where+ (Builder x1 x2) <> (Builder y1 y2) = Builder (x1+y1) $ \p i -> do x2 p i; y2 p $ i+x1++instance Monoid Builder where+ mempty = Builder 0 $ \_ _ -> pure ()+ mappend = (<>)++-- | Methods for Binary serialisation that go directly between strict ByteString values.+-- When the Database is read each key/value will be loaded as a separate ByteString,+-- and for certain types (e.g. file rules) this may remain the preferred format for storing keys.+-- Optimised for performance.+class BinaryEx a where+ putEx :: a -> Builder+ getEx :: BS.ByteString -> a++instance BinaryEx BS.ByteString where+ putEx x = Builder n $ \ptr i -> BS.useAsCString x $ \bs -> BS.memcpy (ptr `plusPtr` i) (castPtr bs) (fromIntegral n)+ where n = BS.length x+ getEx = id++instance BinaryEx LBS.ByteString where+ putEx x = Builder (fromIntegral $ LBS.length x) $ \ptr i -> do+ let go _ [] = pure ()+ go i (x:xs) = do+ let n = BS.length x+ BS.useAsCString x $ \bs -> BS.memcpy (ptr `plusPtr` i) (castPtr bs) (fromIntegral n)+ go (i+n) xs+ go i $ LBS.toChunks x+ getEx = LBS.fromChunks . pure++instance BinaryEx [BS.ByteString] where+ -- Format:+ -- n :: Word32 - number of strings+ -- ns :: [Word32]{n} - length of each string+ -- contents of each string concatenated (sum ns bytes)+ putEx xs = Builder (4 + (n * 4) + sum ns) $ \p i -> do+ pokeByteOff p i (fromIntegral n :: Word32)+ for2M_ [4+i,8+i..] ns $ \i x -> pokeByteOff p i (fromIntegral x :: Word32)+ p <- pure $ p `plusPtr` (i + 4 + (n * 4))+ for2M_ (scanl (+) 0 ns) xs $ \i x -> BS.useAsCStringLen x $ \(bs, n) ->+ BS.memcpy (p `plusPtr` i) (castPtr bs) (fromIntegral n)+ where ns = map BS.length xs+ n = length ns++ getEx bs = unsafePerformIO $ BS.useAsCString bs $ \p -> do+ n <- fromIntegral <$> (peekByteOff p 0 :: IO Word32)+ ns :: [Word32] <- forM [1..fromIntegral n] $ \i -> peekByteOff p (i * 4)+ pure $ snd $ mapAccumL (\bs i -> swap $ BS.splitAt (fromIntegral i) bs) (BS.drop (4 + (n * 4)) bs) ns++instance BinaryEx () where+ putEx () = mempty+ getEx _ = ()++instance BinaryEx String where+ putEx = putEx . UTF8.fromString+ getEx = UTF8.toString++instance BinaryEx (Maybe String) where+ putEx Nothing = mempty+ putEx (Just xs) = putEx $ UTF8.fromString $ '\0' : xs+ getEx = fmap snd . uncons . UTF8.toString++instance BinaryEx [String] where+ putEx = putEx . map UTF8.fromString+ getEx = map UTF8.toString . getEx++instance BinaryEx (String, [String]) where+ putEx (a,bs) = putEx $ a:bs+ getEx x = let a:bs = getEx x in (a,bs)++instance BinaryEx Bool where+ putEx False = Builder 1 $ \ptr i -> pokeByteOff ptr i (0 :: Word8)+ putEx True = mempty+ getEx = BS.null++instance BinaryEx Word8 where+ putEx = putExStorable+ getEx = getExStorable++instance BinaryEx Word16 where+ putEx = putExStorable+ getEx = getExStorable++instance BinaryEx Word32 where+ putEx = putExStorable+ getEx = getExStorable++instance BinaryEx Int where+ putEx = putExStorable+ getEx = getExStorable++instance BinaryEx Float where+ putEx = putExStorable+ getEx = getExStorable+++putExStorable :: forall a . Storable a => a -> Builder+putExStorable x = Builder (sizeOf x) $ \p i -> pokeByteOff p i x++getExStorable :: forall a . Storable a => BS.ByteString -> a+getExStorable = \bs -> unsafePerformIO $ BS.useAsCStringLen bs $ \(p, size) ->+ if size /= n then error "size mismatch" else peek (castPtr p)+ where n = sizeOf (undefined :: a)+++putExStorableList :: forall a . Storable a => [a] -> Builder+putExStorableList xs = Builder (n * length xs) $ \ptr i ->+ for2M_ [i,i+n..] xs $ \i x -> pokeByteOff ptr i x+ where n = sizeOf (undefined :: a)++getExStorableList :: forall a . Storable a => BS.ByteString -> [a]+getExStorableList = \bs -> unsafePerformIO $ BS.useAsCStringLen bs $ \(p, size) ->+ let (d,m) = size `divMod` n in+ if m /= 0 then error "size mismatch" else forM [0..d-1] $ \i -> peekElemOff (castPtr p) i+ where n = sizeOf (undefined :: a)+++-- repeating:+-- Word32, length of BS+-- BS+putExList :: [Builder] -> Builder+putExList xs = Builder (sum $ map (\b -> sizeBuilder b + 4) xs) $ \p i -> do+ let go _ [] = pure ()+ go i (Builder n b:xs) = do+ pokeByteOff p i (fromIntegral n :: Word32)+ b p (i+4)+ go (i+4+n) xs+ go i xs++getExList :: BS.ByteString -> [BS.ByteString]+getExList bs+ | len == 0 = []+ | len >= 4+ , (n :: Word32, bs) <- unsafeBinarySplit bs+ , n <- fromIntegral n+ , (len - 4) >= n+ = BS.unsafeTake n bs : getExList (BS.unsafeDrop n bs)+ | otherwise = error "getList, corrupted binary"+ where len = BS.length bs++putExPair :: Builder -> Builder -> Builder+putExPair a b = putExN a <> b++getExPair :: BS.ByteString -> (BS.ByteString, BS.ByteString)+getExPair = getExN++putExN :: Builder -> Builder+putExN (Builder n old) = Builder (n+4) $ \p i -> do+ pokeByteOff p i (fromIntegral n :: Word32)+ old p $ i+4++getExN :: BS.ByteString -> (BS.ByteString, BS.ByteString)+getExN bs+ | len >= 4+ , (n :: Word32, bs) <- unsafeBinarySplit bs+ , n <- fromIntegral n+ , (len - 4) >= n+ = (BS.unsafeTake n bs, BS.unsafeDrop n bs)+ | otherwise = error "getList, corrupted binary"+ where len = BS.length bs
+ src/General/EscCodes.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE CPP #-}++-- | Working with escape sequences+module General.EscCodes(+ Color(..),+ checkEscCodes,+ removeEscCodes,+ escWindowTitle,+ escCursorUp,+ escClearLine,+ escForeground,+ escNormal+ ) where++import Data.Char+import Data.List.Extra+import System.IO+import System.Environment+import System.IO.Unsafe++#ifdef mingw32_HOST_OS+import Data.Word+import Data.Bits+import Foreign.Ptr+import Foreign.Storable+import Foreign.Marshal.Alloc+#endif++checkEscCodes :: IO Bool+checkEscCodes = pure checkEscCodesOnce++{-# NOINLINE checkEscCodesOnce #-}+checkEscCodesOnce :: Bool+checkEscCodesOnce = unsafePerformIO $ do+ hdl <- hIsTerminalDevice stdout+ env <- maybe False (/= "dumb") <$> lookupEnv "TERM"+ if hdl && env then pure True else+#ifdef mingw32_HOST_OS+ checkEscCodesWindows+#else+ pure False+#endif++#ifdef mingw32_HOST_OS++#ifdef x86_64_HOST_ARCH+#define CALLCONV ccall+#else+#define CALLCONV stdcall+#endif++foreign import CALLCONV unsafe "Windows.h GetStdHandle" c_GetStdHandle :: Word32 -> IO (Ptr ())+foreign import CALLCONV unsafe "Windows.h GetConsoleMode" c_GetConsoleModule :: Ptr () -> Ptr Word32 -> IO Bool+foreign import CALLCONV unsafe "Windows.h SetConsoleMode" c_SetConsoleMode :: Ptr () -> Word32 -> IO Bool++c_STD_OUTPUT_HANDLE = 4294967285 :: Word32 -- (-11) for some reason+c_ENABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0004 :: Word32+++-- | Try and get the handle attributes, if they are all satisifed, return True.+-- If they aren't, try and set it to emulated mode.+checkEscCodesWindows :: IO Bool+checkEscCodesWindows = do+ h <- c_GetStdHandle c_STD_OUTPUT_HANDLE+ -- might return INVALID_HANDLE_VALUE, but then the next step will happily fail+ mode <- alloca $ \v -> do+ b <- c_GetConsoleModule h v+ if b then Just <$> peek v else pure Nothing+ case mode of+ Nothing -> pure False+ Just mode -> do+ let modeNew = mode .|. c_ENABLE_VIRTUAL_TERMINAL_PROCESSING+ if mode == modeNew then pure True else do+ c_SetConsoleMode h modeNew+#endif++removeEscCodes :: String -> String+removeEscCodes ('\ESC':'[':xs) = removeEscCodes $ drop1 $ dropWhile (not . isAlpha) xs+removeEscCodes (x:xs) = x : removeEscCodes xs+removeEscCodes [] = []+++escWindowTitle :: String -> String+escWindowTitle x = "\ESC]0;" ++ x ++ "\BEL"++escCursorUp :: Int -> String+escCursorUp i = "\ESC[" ++ show i ++ "A"++escClearLine :: String+escClearLine = "\ESC[K"+++data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White+ deriving (Show,Enum)++escForeground :: Color -> String+escForeground x = "\ESC[" ++ show (30 + fromEnum x) ++ "m"++escNormal :: String+escNormal = "\ESC[0m"
src/General/Extra.hs view
@@ -1,10 +1,11 @@ module General.Extra(- whenLeft,- whenRightM,- createDirectoryRecursive,+ whenRightM, allMaybeM,+ createDirectoryRecursive, doesFileExist_, NoShow(..),- memoIO+ memoIO, catchIO,+ getProcessorCount,+ unionWithKeyEithers, insertWithKeyEithers ) where import Control.Exception.Extra@@ -12,9 +13,16 @@ import Data.IORef import qualified Data.HashMap.Strict as Map import Data.Hashable-import Control.Monad+import Control.Monad.Extra+import System.IO.Unsafe+import Control.Concurrent+import System.Environment+import Data.List+import System.IO.Extra+import GHC.Conc(getNumProcessors) + --------------------------------------------------------------------- -- Prelude @@ -26,12 +34,23 @@ -- Control.Monad whenRightM :: Monad m => m (Either l r) -> (r -> m ()) -> m ()-whenRightM x act = either (const $ return ()) act =<< x+whenRightM x act = eitherM (const $ pure ()) act x +allMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe [b])+allMaybeM f [] = pure $ Just []+allMaybeM f (x:xs) = do+ y <- f x+ case y of+ Nothing -> pure Nothing+ Just y -> fmap (y:) <$> allMaybeM f xs + --------------------------------------------------------------------- -- Control.Exception +catchIO :: IO a -> (IOException -> IO a) -> IO a+catchIO = catch+ tryIO :: IO a -> IO (Either IOException a) tryIO = try @@ -39,6 +58,9 @@ --------------------------------------------------------------------- -- System.Directory +doesFileExist_ :: FilePath -> IO Bool+doesFileExist_ x = doesFileExist x `catchIO` \_ -> pure False+ -- | Like @createDirectoryIfMissing True@ but faster, as it avoids -- any work in the common case the directory already exists. createDirectoryRecursive :: FilePath -> IO ()@@ -48,22 +70,53 @@ ------------------------------------------------------------------------ Data.Either--whenLeft :: Applicative m => Either a b -> (a -> m ()) -> m ()-whenLeft x f = either f (const $ pure ()) x------------------------------------------------------------------------ -- Data.Memo memoIO :: (Hashable k, Eq k) => (k -> IO v) -> IO (k -> IO v) memoIO f = do ref <- newIORef Map.empty- return $ \k -> do+ pure $ \k -> do mp <- readIORef ref case Map.lookup k mp of- Just v -> return v+ Just v -> pure v Nothing -> do v <- f k atomicModifyIORef ref $ \mp -> (Map.insert k v mp, v)+++---------------------------------------------------------------------+-- System.Info++-- Copied from Shake+{-# NOINLINE getProcessorCount #-}+getProcessorCount :: IO Int+-- unsafePefromIO so we cache the result and only compute it once+getProcessorCount = let res = unsafePerformIO act in pure res+ where+ act =+ if rtsSupportsBoundThreads then+ fromIntegral <$> getNumProcessors+ else do+ env <- lookupEnv "NUMBER_OF_PROCESSORS"+ case env of+ Just s | [(i,"")] <- reads s -> pure i+ _ -> do+ src <- readFile' "/proc/cpuinfo" `catchIO` \_ -> pure ""+ pure $! max 1 $ length [() | x <- lines src, "processor" `isPrefixOf` x]+++---------------------------------------------------------------------+-- Data.HashMap++unionWithKeyEithers :: (Eq k, Hashable k) => (k -> v -> v -> Either e (Maybe v)) -> Map.HashMap k v -> Map.HashMap k v -> ([e], Map.HashMap k v)+unionWithKeyEithers op lhs = insertWithKeyEithers op lhs . Map.toList++insertWithKeyEithers :: (Eq k, Hashable k) => (k -> v -> v -> Either e (Maybe v)) -> Map.HashMap k v -> [(k,v)] -> ([e], Map.HashMap k v)+insertWithKeyEithers op lhs = foldl' f ([], lhs)+ where+ f (es, mp) (k, v2) = case Map.lookup k mp of+ Nothing -> (es, Map.insert k v2 mp)+ Just v1 -> case op k v1 v2 of+ Left e -> (e:es, mp)+ Right Nothing -> (es, mp)+ Right (Just v) -> (es, Map.insert k v mp)
+ src/General/FileInfo.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, CPP #-}++-- copied from ndmitchell/shake/src/Development/Shake/Interal/FileInfo.hs commit 645c99b+module General.FileInfo(+ noFileHash, isNoFileHash,+ FileSize, ModTime, FileHash,+ getFileHash, getFileInfo, doesFileNameExist, getModTime+ ) where++#ifndef MIN_VERSION_unix+#define MIN_VERSION_unix(a,b,c) 0+#endif++#ifndef MIN_VERSION_time+#define MIN_VERSION_time(a,b,c) 0+#endif+++import Data.Hashable+import Control.Exception.Extra+import Development.Shake.Classes+import General.FileName+import qualified Data.ByteString.Lazy.Internal as LBS (defaultChunkSize)+import Data.List.Extra+import Data.Word+import Numeric+import System.IO+import Foreign++#if defined(PORTABLE)+import System.IO.Error+import System.Directory+import Data.Time++#elif defined(mingw32_HOST_OS)+import Data.Char+import Control.Monad+import qualified Data.ByteString.Char8 as BS+import Foreign.C.String++#else++#if MIN_VERSION_time(1,9,1)+import Data.Time.Clock+import Data.Fixed+#endif++import GHC.IO.Exception+import System.IO.Error+import System.Posix.Files.ByteString+#endif++-- A piece of file information, where 0 and 1 are special (see fileInfo* functions)+newtype FileInfo a = FileInfo Word32+ deriving (Typeable,Hashable,Binary,Storable,NFData)++noFileHash :: FileHash+noFileHash = FileInfo 1 -- Equal to nothing++isNoFileHash :: FileHash -> Bool+isNoFileHash (FileInfo i) = i == 1++fileInfo :: Word32 -> FileInfo a+fileInfo a = FileInfo $ if a > maxBound - 2 then a else a + 2++instance Show (FileInfo a) where+ show (FileInfo x)+ | x == 0 = "EQ"+ | x == 1 = "NEQ"+ | otherwise = "0x" ++ upper (showHex (x-2) "")++instance Eq (FileInfo a) where+ FileInfo a == FileInfo b+ | a == 0 || b == 0 = True+ | a == 1 || b == 1 = False+ | otherwise = a == b++data FileInfoHash; type FileHash = FileInfo FileInfoHash+data FileInfoMod; type ModTime = FileInfo FileInfoMod+data FileInfoSize; type FileSize = FileInfo FileInfoSize++getFileHash :: FileName -> IO FileHash+getFileHash x = withFile (fileNameToString x) ReadMode $ \h ->+ allocaBytes LBS.defaultChunkSize $ \ptr ->+ go h ptr (hash ())+ where+ go h ptr salt = do+ n <- hGetBufSome h ptr LBS.defaultChunkSize+ if n == 0 then+ pure $! fileInfo $ fromIntegral salt+ else+ go h ptr =<< hashPtrWithSalt ptr n salt++++-- If the result isn't strict then we are referencing a much bigger structure,+-- and it causes a space leak I don't really understand on Linux when running+-- the 'tar' test, followed by the 'benchmark' test.+-- See this blog post: https://neilmitchell.blogspot.co.uk/2015/09/three-space-leaks.html+result :: Word32 -> Word32 -> IO (Maybe (ModTime, FileSize))+result x y = do+ x <- evaluate $ fileInfo x+ y <- evaluate $ fileInfo y+ pure $ Just (x, y)++doesFileNameExist :: FileName -> IO Bool++#if defined(PORTABLE)+-- Portable fallback+doesFileNameExist = doesFileExist . fileNameToString++#elif defined(mingw32_HOST_OS)++doesFileNameExist x = BS.useAsCString (fileNameToByteString x) $ \file ->+ alloca_WIN32_FILE_ATTRIBUTE_DATA $ \fad -> do+ res <- c_GetFileAttributesExA file 0 fad+ let peek = do+ code <- peekFileAttributes fad+ pure $ not $ testBit code 4+ if res then+ peek+ else if BS.any (>= chr 0x80) (fileNameToByteString x) then withCWString (fileNameToString x) $ \file -> do+ res <- c_GetFileAttributesExW file 0 fad+ if res then peek else pure False+ else+ pure False++#else+-- Unix version+doesFileNameExist x = handleBool isDoesNotExistError' (const $ pure False) $ do+ s <- getFileStatus $ fileNameToByteString x+ if isDirectory s then+ pure False+ else+ pure True+ where+ isDoesNotExistError' e =+ isDoesNotExistError e || ioeGetErrorType e == InappropriateType+#endif++-- doesn't error if directory+getModTime :: FileName -> IO (Maybe ModTime)++#if defined(PORTABLE)+-- Portable fallback+getModTime x = handleBool isDoesNotExistError (const $ pure Nothing) $ do+ let file = fileNameToString x+ time <- getModificationTime file+ y <- evaluate $ fileInfo $ extractFileTime time+ pure $ Just y++#elif defined(mingw32_HOST_OS)+-- Directly against the Win32 API, twice as fast as the portable version+getModTime x = BS.useAsCString (fileNameToByteString x) $ \file ->+ alloca_WIN32_FILE_ATTRIBUTE_DATA $ \fad -> do+ res <- c_GetFileAttributesExA file 0 fad+ let peek = do+ code <- peekFileAttributes fad+ join $ liftM (\y -> do+ x <- evaluate $ fileInfo y+ pure $ Just x) $ peekLastWriteTimeLow fad+ if res then+ peek+ else if BS.any (>= chr 0x80) (fileNameToByteString x) then withCWString (fileNameToString x) $ \file -> do+ res <- c_GetFileAttributesExW file 0 fad+ if res then peek else pure Nothing+ else+ pure Nothing++#else+-- Unix version+getModTime x = handleBool isDoesNotExistError' (const $ pure Nothing) $ do+ s <- getFileStatus $ fileNameToByteString x+ y <- evaluate $ fileInfo $ extractFileTime s+ pure $ Just y+ where+ isDoesNotExistError' e =+ isDoesNotExistError e || ioeGetErrorType e == InappropriateType+#endif+++getFileInfo :: FileName -> IO (Maybe (ModTime, FileSize))++#if defined(PORTABLE)+-- Portable fallback+getFileInfo x = handleBool isDoesNotExistError (const $ pure Nothing) $ do+ let file = fileNameToString x+ time <- getModificationTime file+ size <- withFile file ReadMode hFileSize+ result (extractFileTime time) (fromIntegral size)++extractFileTime :: UTCTime -> Word32+extractFileTime = floor . fromRational . toRational . utctDayTime+++#elif defined(mingw32_HOST_OS)+-- Directly against the Win32 API, twice as fast as the portable version+getFileInfo x = BS.useAsCString (fileNameToByteString x) $ \file ->+ alloca_WIN32_FILE_ATTRIBUTE_DATA $ \fad -> do+ res <- c_GetFileAttributesExA file 0 fad+ let peek = do+ code <- peekFileAttributes fad+ if testBit code 4 then+ error $ "Build system error - expected a file, got a directory " ++ fileNameToString x+ else+ join $ liftM2 result (peekLastWriteTimeLow fad) (peekFileSizeLow fad)+ if res then+ peek+ else if BS.any (>= chr 0x80) (fileNameToByteString x) then withCWString (fileNameToString x) $ \file -> do+ res <- c_GetFileAttributesExW file 0 fad+ if res then peek else pure Nothing+ else+ pure Nothing++#ifdef x86_64_HOST_ARCH+#define CALLCONV ccall+#else+#define CALLCONV stdcall+#endif++foreign import CALLCONV unsafe "Windows.h GetFileAttributesExA" c_GetFileAttributesExA :: CString -> Int32 -> Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Bool+foreign import CALLCONV unsafe "Windows.h GetFileAttributesExW" c_GetFileAttributesExW :: CWString -> Int32 -> Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Bool++data WIN32_FILE_ATTRIBUTE_DATA++alloca_WIN32_FILE_ATTRIBUTE_DATA :: (Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO a) -> IO a+alloca_WIN32_FILE_ATTRIBUTE_DATA act = allocaBytes size_WIN32_FILE_ATTRIBUTE_DATA act+ where size_WIN32_FILE_ATTRIBUTE_DATA = 36++peekFileAttributes :: Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Word32+peekFileAttributes p = peekByteOff p index_WIN32_FILE_ATTRIBUTE_DATA_dwFileAttributes+ where index_WIN32_FILE_ATTRIBUTE_DATA_dwFileAttributes = 0++peekLastWriteTimeLow :: Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Word32+peekLastWriteTimeLow p = peekByteOff p index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime+ where index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime = 20++peekFileSizeLow :: Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Word32+peekFileSizeLow p = peekByteOff p index_WIN32_FILE_ATTRIBUTE_DATA_nFileSizeLow+ where index_WIN32_FILE_ATTRIBUTE_DATA_nFileSizeLow = 32+++#else+-- Unix version+getFileInfo x = handleBool isDoesNotExistError' (const $ pure Nothing) $ do+ s <- getFileStatus $ fileNameToByteString x+ if isDirectory s then+ error $ "Build system error - expected a file, got a directory " ++ fileNameToString x+ else+ result (extractFileTime s) (fromIntegral $ fileSize s)+ where+ isDoesNotExistError' e =+ isDoesNotExistError e || ioeGetErrorType e == InappropriateType++extractFileTime :: FileStatus -> Word32+#if MIN_VERSION_unix(2,6,0)+#if MIN_VERSION_time(1,9,1)+extractFileTime = fromInteger . (\(MkFixed x) -> x) . nominalDiffTimeToSeconds . modificationTimeHiRes+#else+extractFileTime x = ceiling $ modificationTimeHiRes x * 1e4+#endif+#else+extractFileTime x = fromIntegral $ fromEnum $ modificationTime x+#endif++#endif
+ src/General/FileName.hs view
@@ -0,0 +1,86 @@++-- copied from ndmitchell/shake/src/Development/Shake/Internal/FileName.hs commit 8a96542+module General.FileName(+ FileName,+ fileNameFromString, fileNameFromByteString,+ fileNameToString, fileNameToByteString,+ byteStringToFileName+ ) where++import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.UTF8 as UTF8+import Development.Shake.Classes+import qualified System.FilePath as Native+import System.Info.Extra+import Data.List++---------------------------------------------------------------------+-- FileName newtype++-- | The hash of the filename, and the UTF8 ByteString+data FileName = FileName Int !BS.ByteString+ deriving Eq++instance NFData FileName where+ rnf FileName{} = ()++instance Ord FileName where+ compare (FileName _ a) (FileName _ b) = compare a b++instance Hashable FileName where+ hashWithSalt _ = hash+ hash (FileName x _) = x++instance Show FileName where+ show = fileNameToString++fileNameToString :: FileName -> FilePath+fileNameToString = UTF8.toString . fileNameToByteString++fileNameToByteString :: FileName -> BS.ByteString+fileNameToByteString (FileName _ x) = x++fileNameFromString :: FilePath -> FileName+fileNameFromString = fileNameFromByteString . UTF8.fromString++fileNameFromByteString :: BS.ByteString -> FileName+fileNameFromByteString = byteStringToFileName . filepathNormalise++-- don't normalise+byteStringToFileName :: BS.ByteString -> FileName+byteStringToFileName x = FileName (hash x) x++---------------------------------------------------------------------+-- NORMALISATION++-- | Equivalent to @toStandard . normaliseEx@ from "Development.Shake.FilePath".+filepathNormalise :: BS.ByteString -> BS.ByteString+filepathNormalise xs+ | isWindows, Just (a,xs) <- BS.uncons xs, sep a, Just (b,_) <- BS.uncons xs, sep b = '/' `BS.cons` f xs+ | otherwise = f xs+ where+ sep = Native.isPathSeparator+ f o = deslash o $ BS.concat $ (slash:) $ intersperse slash $ reverse $ (BS.empty:) $ g 0 $ reverse $ split o++ deslash o x+ | x == slash = case (pre,pos) of+ (True,True) -> slash+ (True,False) -> BS.pack "/."+ (False,True) -> BS.pack "./"+ (False,False) -> dot+ | otherwise = (if pre then id else BS.tail) $ (if pos then id else BS.init) x+ where pre = not (BS.null o) && sep (BS.head o)+ pos = not (BS.null o) && sep (BS.last o)++ g i [] = replicate i dotDot+ g i (x:xs) | BS.null x = g i xs+ g i (x:xs) | x == dotDot = g (i+1) xs+ g i (x:xs) | x == dot = g i xs+ g 0 (x:xs) = x : g 0 xs+ g i (_:xs) = g (i-1) xs -- equivalent to eliminating ../x++ split = BS.splitWith sep++dotDot = BS.pack ".."+dot = BS.singleton '.'+slash = BS.singleton '/'
+ src/General/Paths.hs view
@@ -0,0 +1,50 @@++-- | The information from Paths_rattle cleaned up+module General.Paths(+ rattleVersionString,+ initDataDirectory,+ readDataFileHTML+ ) where++import Paths_rattle+import Control.Exception+import Control.Monad.Extra+import Data.Version+import System.Directory+import System.FilePath+import System.IO.Unsafe+import System.Environment+import General.Extra+import qualified Data.ByteString.Lazy as LBS+++rattleVersionString :: String+rattleVersionString = showVersion version+++-- We want getDataFileName to be relative to the current directory on program startup,+-- even if we issue a change directory command. Therefore, first call caches, future ones read.+{-# NOINLINE dataDirs #-}+dataDirs :: [String]+dataDirs = unsafePerformIO $ do+ datdir <- getDataDir+ exedir <- takeDirectory <$> getExecutablePath `catchIO` \_ -> pure ""+ curdir <- getCurrentDirectory+ pure $ [datdir] ++ [exedir | exedir /= ""] ++ [curdir]++-- | The data files may be located relative to the current directory, if so cache it in advance.+initDataDirectory :: IO ()+initDataDirectory = void $ evaluate dataDirs+++getDataFile :: FilePath -> IO FilePath+getDataFile file = do+ let poss = map (</> file) dataDirs+ res <- filterM doesFileExist_ poss+ case res of+ [] -> fail $ unlines $ ("Could not find data file " ++ file ++ ", looked in:") : map (" " ++) poss+ x:_ -> pure x+++readDataFileHTML :: FilePath -> IO LBS.ByteString+readDataFileHTML file = LBS.readFile =<< getDataFile ("html" </> file)
+ src/General/Pool.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE TupleSections #-}++-- | Thread pool implementation. The three names correspond to the following+-- priority levels (highest to lowest):+--+-- * 'addPoolException' - things that probably result in a build error,+-- so kick them off quickly.+--+-- * 'addPoolResume' - things that started, blocked, and may have open+-- resources in their closure.+--+-- * 'addPoolStart' - rules that haven't yet started.+--+-- * 'addPoolBatch' - rules that might batch if other rules start first.+module General.Pool(+ Pool, runPool,+ addPool, addPoolWait, PoolPriority(..),+ ) where++import Control.Concurrent.Extra+import General.Thread+import System.Time.Extra+import Control.Exception.Extra+import Control.Monad.Extra+import qualified Data.Heap as Heap+import qualified Data.HashSet as Set+import Data.IORef.Extra+++false = False++---------------------------------------------------------------------+-- THREAD POOL++{-+Must keep a list of active threads, so can raise exceptions in a timely manner+If any worker throws an exception, must signal to all the other workers+-}++data S = S+ {alive :: !Bool -- True until there's an exception, after which don't spawn more tasks+ ,threads :: !(Set.HashSet Thread) -- IMPORTANT: Must be strict or we leak thread stacks+ ,threadsLimit :: {-# UNPACK #-} !Int -- user supplied thread limit, Set.size threads <= threadsLimit+ ,threadsCount :: {-# UNPACK #-} !Int -- Set.size threads, but in O(1)+ ,threadsMax :: {-# UNPACK #-} !Int -- high water mark of Set.size threads (accounting only)+ ,threadsSum :: {-# UNPACK #-} !Int -- number of threads we have been through (accounting only)+ ,rand :: IO Int -- operation to give us the next random Int+ ,todo :: !(Heap.Heap (Heap.Entry (PoolPriority, Int) (IO ()))) -- operations waiting a thread+ }+++emptyS :: Int -> Bool -> IO S+emptyS n deterministic = do+ rand <- do+ ref <- newIORef 0+ -- no need to be thread-safe - if two threads race they were basically the same time anyway+ pure $ do i <- readIORef ref; writeIORef' ref (i+1); pure i+ pure $ S True Set.empty n 0 0 0 rand Heap.empty+++data Pool = Pool+ !(Var S) -- Current state, 'alive' = False to say we are aborting+ !(Barrier (Either SomeException S)) -- Barrier to signal that we are finished+++withPool :: Pool -> (S -> IO (S, IO ())) -> IO ()+withPool (Pool var _) f = join $ modifyVar var $ \s ->+ if alive s then f s else pure (s, pure ())++withPool_ :: Pool -> (S -> IO S) -> IO ()+withPool_ pool act = withPool pool $ fmap (, pure()) . act+++worker :: Pool -> IO ()+worker pool = withPool pool $ \s -> pure $ case Heap.uncons $ todo s of+ Nothing -> (s, pure ())+ Just (Heap.Entry _ now, todo2) -> (s{todo = todo2}, now >> worker pool)++-- | Given a pool, and a function that breaks the S invariants, restore them.+-- They are only allowed to touch threadsLimit or todo.+-- Assumes only requires spawning a most one job (e.g. can't increase the pool by more than one at a time)+step :: Pool -> (S -> IO S) -> IO ()+-- mask_ is so we don't spawn and not record it+step pool@(Pool _ done) op = uninterruptibleMask_ $ withPool_ pool $ \s -> do+ s <- op s+ -- evaluate s+ -- BS.putStrLn $ BS.pack $ show ("Pool of " , threadsLimit s, threadsCount s)+ case Heap.uncons $ todo s of+ Just (Heap.Entry _ now, todo2) | threadsCount s < threadsLimit s -> do+ -- spawn a new worker+ t <- newThreadFinally (now >> worker pool) $ \t res ->+ case res of+ -- just cause someone gets an exception, doesn't mean we die now+ Left e | false -> withPool_ pool $ \s -> do+ signalBarrier done $ Left e+ pure (remThread t s){alive = False}+ _ ->+ step pool $ pure . remThread t+ pure (addThread t s){todo = todo2}+ -- rattle doesn't terminate when we run out of threads+ Nothing | false, threadsCount s == 0 -> do+ signalBarrier done $ Right s+ pure s{alive = False}+ _ -> pure s+ where+ addThread t s = s{threads = Set.insert t $ threads s, threadsCount = threadsCount s + 1+ ,threadsSum = threadsSum s + 1, threadsMax = threadsMax s `max` (threadsCount s + 1)}+ remThread t s = s{threads = Set.delete t $ threads s, threadsCount = threadsCount s - 1}+++-- | Add a new task to the pool. See the top of the module for the relative ordering+-- and semantics.+addPool :: PoolPriority -> Pool -> IO a -> IO ()+addPool priority pool act = step pool $ \s -> do+ i <- rand s+ pure s{todo = Heap.insert (Heap.Entry (priority, i) $ void act) $ todo s}+++-- | Somewhat dubious. Safe if the waiter gets killed if the pool gets torn down, which we assume happens.+addPoolWait :: PoolPriority -> Pool -> IO a -> IO a+addPoolWait priority pool act = do+ bar <- newBarrier+ addPool priority pool $ uninterruptibleMask $ \unmask ->+ signalBarrier bar =<< try_ (unmask act)+ res <- waitBarrier bar+ either throwIO pure res+++data PoolPriority+ = PoolRequired+ | PoolSpeculate+ deriving (Eq,Ord)++-- | Run all the tasks in the pool on the given number of works.+-- If any thread throws an exception, the exception will be reraised.+runPool :: Bool -> Int -> (Pool -> IO a) -> IO a -- run all tasks in the pool+runPool deterministic n act = do+ s <- newVar =<< emptyS n deterministic+ done <- newBarrier+ let pool = Pool s done++ -- if someone kills our thread, make sure we kill our child threads+ let cleanup =+ join $ modifyVar s $ \s -> pure (s{alive=False}, stopThreads $ Set.toList $ threads s)++ let ghc10793 = do+ -- if this thread dies because it is blocked on an MVar there's a chance we have+ -- a better error in the done barrier, and GHC raised the exception wrongly, see:+ -- https://ghc.haskell.org/trac/ghc/ticket/10793+ sleep 1 -- give it a little bit of time for the finally to run+ -- no big deal, since the blocked indefinitely takes a while to fire anyway+ res <- waitBarrierMaybe done+ case res of+ Just (Left e) -> throwIO e+ _ -> throwIO BlockedIndefinitelyOnMVar+ flip finally cleanup $ handle (\BlockedIndefinitelyOnMVar -> ghc10793) $+ -- changes from Shake+ -- being in the pool doesn't consume a pool resource+ act pool+ -- we don't want for the pool to go quiet before continue, just as soon as the action dies+ -- so we remove the alive = False status
+ src/General/Template.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE ViewPatterns #-}++-- | A simplistic templating engine, used for generating profiling reports.+module General.Template(runTemplate) where++import System.FilePath.Posix+import Control.Exception.Extra+import Data.Char+import Data.Time+import System.IO.Unsafe+import General.Paths+import qualified Data.ByteString.Lazy.Char8 as LBS+import qualified Language.Javascript.DGTable as DGTable+import qualified Language.Javascript.Flot as Flot+import qualified Language.Javascript.JQuery as JQuery+++libraries =+ [("jquery.js", JQuery.file)+ ,("jquery.dgtable.js", DGTable.file)+ ,("jquery.flot.js", Flot.file Flot.Flot)+ ,("jquery.flot.stack.js", Flot.file Flot.FlotStack)+ ]+++-- | Template Engine. Perform the following replacements on a line basis:+--+-- * <script src="foo"></script> ==> <script>[[foo]]</script>+--+-- * <link href="foo" rel="stylesheet" type="text/css" /> ==> <style type="text/css">[[foo]]</style>+runTemplate :: (FilePath -> IO LBS.ByteString) -> LBS.ByteString -> IO LBS.ByteString+runTemplate ask = lbsMapLinesIO f+ where+ link = LBS.pack "<link href=\""+ script = LBS.pack "<script src=\""++ f x | Just file <- LBS.stripPrefix script y = do res <- grab file; pure $ LBS.pack "<script>\n" `LBS.append` res `LBS.append` LBS.pack "\n</script>"+ | Just file <- LBS.stripPrefix link y = do res <- grab file; pure $ LBS.pack "<style type=\"text/css\">\n" `LBS.append` res `LBS.append` LBS.pack "\n</style>"+ | otherwise = pure x+ where+ y = LBS.dropWhile isSpace x+ grab = asker . takeWhile (/= '\"') . LBS.unpack++ asker o@(splitFileName -> ("lib/",x)) = case lookup x libraries of+ Just act -> LBS.readFile =<< act+ Nothing -> errorIO $ "Template library, unknown library: " ++ o+ asker "rattle.js" = readDataFileHTML "rattle.js"+ asker "data/metadata.js" = do+ time <- getCurrentTime+ pure $ LBS.pack $+ "var version = " ++ show rattleVersionString +++ "\nvar generated = " ++ show (formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S")) time)+ asker x = ask x++-- Perform a mapM on each line and put the result back together again+lbsMapLinesIO :: (LBS.ByteString -> IO LBS.ByteString) -> LBS.ByteString -> IO LBS.ByteString+-- If we do the obvious @fmap LBS.unlines . mapM f@ then all the monadic actions are run on all the lines+-- before it starts producing the lazy result, killing streaming and having more stack usage.+-- The real solution (albeit with too many dependencies for something small) is a streaming library,+-- but a little bit of unsafePerformIO does the trick too.+lbsMapLinesIO f = pure . LBS.unlines . map (unsafePerformIO . f) . LBS.lines
src/General/Thread.hs view
@@ -1,47 +1,34 @@-{-# LANGUAGE ScopedTypeVariables #-} -- | A bit like 'Fence', but not thread safe and optimised for avoiding taking the fence module General.Thread(- withThreadsList,+ Thread, newThreadFinally, stopThreads ) where +import Data.Hashable import Control.Concurrent.Extra import Control.Exception-import General.Extra-import Control.Monad.Extra +data Thread = Thread ThreadId (Barrier ()) --- Run both actions. If either throws an exception, both threads--- are killed and an exception reraised.--- Not called much, so simplicity over performance (2 threads).-withThreadsBoth :: IO a -> IO b -> IO (a, b)-withThreadsBoth act1 act2 = do- bar1 <- newBarrier- bar2 <- newBarrier- parent <- myThreadId- ignore <- newVar False- mask $ \unmask -> do- t1 <- forkIOWithUnmask $ \unmask -> do- res1 :: Either SomeException a <- try $ unmask act1- unlessM (readVar ignore) $ whenLeft res1 $ throwTo parent- signalBarrier bar1 res1- t2 <- forkIOWithUnmask $ \unmask -> do- res2 :: Either SomeException b <- try $ unmask act2- unlessM (readVar ignore) $ whenLeft res2 $ throwTo parent- signalBarrier bar2 res2- res :: Either SomeException (a,b) <- try $ unmask $ do- Right v1 <- waitBarrier bar1- Right v2 <- waitBarrier bar2- return (v1,v2)- writeVar ignore True- killThread t1- forkIO $ killThread t2- waitBarrier bar1- waitBarrier bar2- either throwIO return res+instance Eq Thread where+ Thread a _ == Thread b _ = a == b +instance Hashable Thread where+ hashWithSalt salt (Thread a _) = hashWithSalt salt a -withThreadsList :: [IO a] -> IO [a]-withThreadsList [] = return []-withThreadsList [x] = (:[]) <$> x-withThreadsList (x:xs) = uncurry (:) <$> withThreadsBoth x (withThreadsList xs)++-- | The inner thread is unmasked even if you started masked.+newThreadFinally :: IO a -> (Thread -> Either SomeException a -> IO ()) -> IO Thread+newThreadFinally act cleanup = do+ bar <- newBarrier+ t <- mask_ $ forkIOWithUnmask $ \unmask -> flip finally (signalBarrier bar ()) $ do+ res <- try $ unmask act+ me <- myThreadId+ cleanup (Thread me bar) res+ pure $ Thread t bar++stopThreads :: [Thread] -> IO ()+stopThreads threads = do+ -- if a thread is in a masked action, killing it may take some time, so kill them in parallel+ bars <- sequence [do forkIO $ killThread t; pure bar | Thread t bar <- threads]+ mapM_ waitBarrier bars
test/Test.hs view
@@ -1,52 +1,57 @@-{-# LANGUAGE ScopedTypeVariables #-} module Test(main) where -import Development.Rattle-import System.FilePattern.Directory-import Development.Shake.FilePath-import Control.Exception+import Control.Monad+import Data.Char+import Data.List import System.Directory-import System.Info.Extra-import Control.Monad.Extra---withOutput :: (FilePath -> IO a) -> IO a-withOutput act = do- ignoreIO $ removeDirectoryRecursive "output"- createDirectoryIfMissing True "output"- withCurrentDirectory "output" $ act ".."--ignoreIO :: IO () -> IO ()-ignoreIO act = catch act $ \(_ :: IOException) -> return ()+import System.Environment+import System.Exit+import System.IO+import System.FilePath+import General.Paths+import Development.Rattle +import qualified Test.Example.FSATrace+import qualified Test.Example.Stack+import qualified Test.Simple+import qualified Test.Trace --- Don't run on Mac because of https://github.com/jacereda/fsatrace/issues/25-main = unless isMac $ withOutput $ \root -> do- let wipe = mapM (ignoreIO . removeFile) =<< getDirectoryFiles "." ["*"]- cs <- liftIO $ getDirectoryFiles "." [root </> "test/C/*.c"]- let toO x = takeBaseName x <.> "o"- let build = do- forM_ cs $ \c -> cmd ["gcc","-o",toO c,"-c",c]- cmd $ ["gcc","-o","Main" <.> exe] ++ map toO cs- cmd ["./Main" <.> exe]+tests = let (*) = (,) in+ ["trace" * Test.Trace.main+ ,"simple" * Test.Simple.main+ ,"fsatrace" * Test.Example.FSATrace.main+ ,"stack" * Test.Example.Stack.main+ ,"dump" * dump+ ] - putStrLn "Build 1: Expect everything"- rattle rattleOptions build- putStrLn "Build 2: Expect nothing"- rattle rattleOptions build- wipe- putStrLn "Build 3: Expect cached (some speculation)"- rattle rattleOptions build+main = do+ initDataDirectory+ args <- getArgs+ case args of+ [] ->+ forM_ tests $ \(name, act) -> do+ putStrLn $ "\n# Test " ++ name+ runAct name act+ name:args+ | Just act <- lookup (dropWhileEnd isDigit name) tests -> do+ putStrLn $ "\n# Test " ++ name+ withArgs args $ runAct name act+ _ -> do+ putStrLn $ "Unknown arguments, expected one of\n " ++ unwords (map fst tests)+ exitFailure+ where+ runAct name act = do+ let dir = "output" </> name+ createDirectoryIfMissing True dir+ withCurrentDirectory dir act - putStrLn "Build 4: Read/write hazard"- handle (\(h :: Hazard) -> print h) $ do- rattle rattleOptions{rattleSpeculate=Nothing} $ do- cmd ["./Main" <.> exe]- cmd $ ["gcc","-o","Main" <.> exe] ++ reverse (map toO cs)- putStrLn "Hoped it failed, but doesn't always"- -- fail "Expected a hazard"-- putStrLn "Build 5: Rebuild after"- rattle rattleOptions build+dump :: IO ()+dump = do+ xs <- getArgs+ forM_ xs $ \x -> do+ withCurrentDirectory ".." $+ withFile (x </> "dump.rattle") WriteMode $ \h ->+ rattleDump (hPutStrLn h) $ x </> ".rattle"+ putStrLn $ "Dump written to " ++ x </> "dump.rattle"
+ test/Test/BuildScript.hs view
@@ -0,0 +1,53 @@++module BuildScript(main) where++import Development.Rattle+import Data.List.Extra+import System.Environment+import Control.Monad++-- Takes as arguments a file and the number of threads to run with+-- File is of the following format++-- dir: directory-following-command-executes-from+-- cmd (cmd is terminated by a newline if the line does not end with '\')++-- ( this might need to be changed for windows)+++localOptions :: Int -> RattleOptions+localOptions j = RattleOptions ".rattle" (Just "") "m1" True j [] [("PWD", ".")] Nothing False++shcCmd :: String -> FilePath -> Run ()+shcCmd c d = cmd (Cwd d) ["sh", "-c", c]++-- bare bones parsing+toCmds :: String -> [(String, FilePath)]+toCmds = f . lines+ where f [] = []+ f xs = let (p,ys) = getCmd xs in+ p : f ys+ h [] = ([],[])+ -- get cmd line+ h (x:xs)+ | isSuffixOf "\\" $ trim x =+ let (ls1,r) = h xs in+ (x:ls1,r)+ | otherwise = ([trim x],xs)+ getCmd [] = (("", "."),[])+ getCmd (x:xs) =+ -- first get dir; then get cmd+ let (y, zs) = h xs in+ ((unlines y, getDir x), zs)+ getDir str = case stripPrefix "dir: " str of+ Nothing -> error $ "Expected line beginning with 'dir: ' got: " ++ str+ Just d -> d++-- takes a single file as an argument and a number of threads+main :: IO ()+main = do+ [file,j] <- getArgs+ file <- readFile file+ let cmds = toCmds file+ rattleRun (localOptions $ read j) $+ forM_ cmds $ uncurry shcCmd
+ test/Test/Example/FSATrace.hs view
@@ -0,0 +1,44 @@++-- | Try replicating the build scripts of fsatrace from:+-- https://github.com/jacereda/fsatrace/blob/master/Makefile+-- (note the two unix.mk and win.mk files)+--+-- We don't deal with the 32bit Windows build since our CI doesn't have a 32bit compiler+module Test.Example.FSATrace(main) where++import System.Info.Extra+import Development.Rattle+import Development.Shake.FilePath+import Test.Type+++main :: IO ()+main = testGit "https://github.com/jacereda/fsatrace" $ do+ let plat = if isWindows then "win" else "unix"++ let srcs = ["src/fsatrace.c", "src/"++plat++"/proc.c", "src/"++plat++"/shm.c"] +++ if isWindows then ["src/win/inject.c","src/win/dbg.c"] else []+ let sosrcs = ["src/unix/fsatraceso.c","src/emit.c","src/unix/shm.c","src/unix/proc.c"]+ let dllsrcs = map ("src/win/" ++) (words "fsatracedll.c inject.c patch.c hooks.c shm.c handle.c utf8.c dbg.c") ++ ["src/emit.c"]++ let cflags = "-g -std=c99 -Wall -O2 -fomit-frame-pointer -fno-stack-protector -MMD -DIS32=0"+ let cppflags | isWindows = "-D_WIN32_WINNT=0x600 -isysteminclude/ddk"+ | otherwise = "-D_GNU_SOURCE -D_DEFAULT_SOURCE=1"++ let ldflags = [] :: [String]+ let ldlibs = if isWindows then "-lntdll -lpsapi" else "-ldl -lrt"+ let ldobjs = ["CRT_noglob.o" | isWindows && False]++ forP_ (srcs ++ if isWindows then dllsrcs else sosrcs) $ \x ->+ cmd "gcc -c" ["-fPIC" | not isWindows] cppflags cflags x "-o" (x -<.> "o")+ let os = map (-<.> "o")++ -- we use the leading _'s on fsatrace stuff so it doesn't conflict with the version+ -- we are using to do tracing ourselves++ if isWindows then+ cmd "gcc -shared" ldflags (os dllsrcs) "-o _fsatrace64.dll" ldlibs+ else+ cmd "gcc -shared" ldflags (os sosrcs) "-o _fsatrace.so" ldlibs++ cmd "gcc" ldflags ldobjs (os srcs) ldlibs "-o" ("_fsatrace" <.> exe)
+ test/Test/Example/Stack.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Try performing a Stack-like install.+module Test.Example.Stack(main) where++import Development.Rattle+import Development.Shake.FilePath+import System.IO.Extra+import System.Info.Extra+import Language.Haskell.TH+import qualified Data.ByteString as BS+import qualified Development.Shake.Command as C+import Data.Maybe+import Control.Monad.Extra+import System.Environment+import System.Directory.Extra+import Data.List.Extra+import qualified Data.HashMap.Strict as Map++-- Cabal packages+import Distribution.PackageDescription.Parsec+import Distribution.Types.CondTree+import Distribution.Types.GenericPackageDescription+import Distribution.Types.Dependency+import Distribution.Types.PackageName(unPackageName)+++type PackageName = String+type PackageVersion = String++haskell :: (Read a, Show a) => String -> Q (TExp (a -> IO ())) -> (a -> Run ())+haskell name act v = do+ e <- liftIO $ runQ act+ let file = name <.> "hs"+ liftIO $ unlessM (doesFileExist file) $+ liftIO $ writeFile (name <.> "hs") $ unlines+ ["import System.Environment"+ ,"import System.IO"+ ,"import System.Directory"+ ,"import Development.Shake.Command"+ ,"import System.FilePath.Windows"+ ,"import System.FilePath.Posix"+ ,"import Data.List as Data.OldList"+ ,"import System.IO.Extra"+ ,"import Data.Foldable"+ ,"import Data.Functor"+ ,"import System.Directory.Extra"+ ,"import GHC.List"+ ,"import Development.Shake.Command as Development.Shake.Internal.CmdOption"+ ,"import System.Directory.Extra as System.Directory.Internal.Common"+ ,"import Data.List.Extra"+ ,"import GHC.Base"+ ,"import GHC.Classes"+ ,"main :: IO ()"+ ,"main = do [x] <- System.Environment.getArgs; body (read x)"+ ,"body = " ++ pprint (unType e)+ ]+ cmd "runhaskell -package=base -package=ghc-prim" file (show v)+++main :: IO ()+-- Unfortunately 8.8.1 and 8.8.2 are broken when loading Cabal+main = unless isWindows $ do+ args <- getArgs+ unsetEnv "GHC_PACKAGE_PATH"+ tdir <- canonicalizePath =<< getTemporaryDirectory+ let ignore = ["**/hackage-security-lock", "**/package.cache.lock", tdir ++ "/**"]+ rattleRun rattleOptions{rattleCmdOptions=[toCmdOption $ Ignored ignore], rattleForward=True} $+ stack "nightly-2019-09-29" $ args ++ ["cereal" | null args]++{-+haskell :: a -> Q (TExp (a -> IO ())) -> Run ()+haskell arg act = do+-}++cabalUnpack = haskell "unpack" [|| \dir -> do+ removePathForcibly dir+ C.cmd "cabal unpack" dir+ ||]++cabalBuild = haskell "build" [|| \(dir, name) -> do+ C.cmd_ (Cwd dir) "cabal v1-build" ("lib:" ++ name)+ xs <- filter (\x -> takeExtension x == ".conf") <$> listFiles (dir </> "dist/package.conf.inplace")+ pwd <- getCurrentDirectory+ forM_ xs $ \x -> do+ src <- readFileUTF8' x+ writeFileUTF8 x $ replace (addTrailingPathSeparator pwd) "" src+ C.cmd "ghc-pkg recache" ("--package-db=" ++ dir </> "dist/package.conf.inplace")+ ||]+++installPackage :: (PackageName -> Run (Maybe PackageVersion)) -> FilePath -> [String] -> PackageName -> PackageVersion -> Run ()+installPackage dep config flags name version = do+ let dir = name ++ "-" ++ version++ cabalUnpack dir++ -- cmd "pipeline rm -rf" dir "&& cabal unpack" dir++ depends <- liftIO $ cabalDepends $ dir </> name <.> "cabal"+ depends <- pure $ delete name $ nubSort depends+ dependsVer <- forP depends dep+ cmd (Cwd dir) "cabal v1-configure" flags+ "--disable-library-profiling --disable-optimisation"+ ["--package-db=../" ++ n ++ "-" ++ v ++ "/dist/package.conf.inplace" | (n, Just v) <- zip depends dependsVer]++ cabalBuild (dir, name)+ -- cmd (Cwd dir) "cabal v1-build" ("lib:" ++ name)+++extraConfigureFlags :: IO [String]+extraConfigureFlags = do+ -- Cabal create dist/setup-config during configure+ -- That serialises a LocalBuildInfo, which with withPrograms contains ConfiguredProgram+ -- The ConfiguredProgram contains programMonitorFiles which ends up containing a list of all directories the binary+ -- _might_ be in. Unfortunately, Cabal puts the current directory in that list.+ -- However, if we pass --with-hscolour=... then it doesn't bother looking for the program, so programMonitorFiles is+ -- empty and thus doesn't change between computers.+ let progs = ["hscolour","alex","happy","ghc","cpphs","doctest"]+ flip mapMaybeM progs $ \prog -> do+ location <- findExecutable prog+ -- WARNING: If this returns Nothing (because you don't have doctest installed, for instance)+ -- your cache will not be stable.+ pure $ fmap (\x -> "--with-" ++ prog ++ "=" ++ x) location+++stack :: String -> [PackageName] -> Run ()+stack resolver packages = do+ let config = resolver <.> "config"+ -- Shell below is to hack around an fsatrace issue+ cmd Shell "curl -sSL" ("https://www.stackage.org/" ++ resolver ++ "/cabal.config") "-o" config+ versions <- liftIO $ readResolver config+ flags <- liftIO extraConfigureFlags+ let askVersion x = fromMaybe (error $ "Don't know version for " ++ show x) $ Map.lookup x versions+ needPkg <- memoRec $ \needPkg name -> do+ let v = askVersion name+ whenJust v $ installPackage needPkg config flags name+ pure v+ forP_ packages needPkg+++readResolver :: FilePath -> IO (Map.HashMap PackageName (Maybe PackageVersion))+readResolver file = do+ src <- words <$> readFileUTF8' file+ -- base and bytestring are here because of https://github.com/commercialhaskell/stackage/issues/4862+ pure $ Map.fromList $ ("integer-simple",Nothing) : ("base",Nothing) : ("bytestring",Nothing) : f src+ where+ f (x:('=':'=':y):zs) = (x,Just $ dropWhileEnd (== ',') y) : f zs+ f (x:"installed,":zs) = (x,Nothing) : f zs+ f (_:xs) = f xs+ f [] = []+++cabalDepends :: FilePath -> IO [PackageName]+cabalDepends file = do+ bs <- BS.readFile file+ pure $ case parseGenericPackageDescriptionMaybe bs of+ Just x -> map (unPackageName . depPkgName) $ concatMap treeConstraints $+ -- we only build the library, but configure requires all the executables to+ -- have their dependencies available+ maybeToList (void <$> condLibrary x) ++ map (void . snd) (condExecutables x)+ _ -> pure []++treeConstraints :: CondTree a [b] c -> [b]+treeConstraints (CondNode _ b cs) = b ++ concatMap branch cs+ where branch (CondBranch _ t f) = treeConstraints t ++ maybe [] treeConstraints f
+ test/Test/Simple.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Simple(main) where++import Test.Type+import Development.Rattle+import System.FilePattern.Directory+import Development.Shake.FilePath+import Control.Exception+import System.Directory+import System.Info.Extra+import Control.Monad.Extra+++-- Don't run on Mac because of https://github.com/jacereda/fsatrace/issues/25+main = unless isMac $ do+ let wipe = mapM (ignoreIO . removeFile) =<< getDirectoryFiles "." ["*"]+ cs <- liftIO $ getDirectoryFiles "." [root </> "test/C/*.c"]+ let toO x = takeBaseName x <.> "o"+ let build = do+ forM_ cs $ \c -> cmd "gcc -o" [toO c, "-c", c]+ cmd "gcc -o" ["Main" <.> exe] (map toO cs)+ cmd ["./Main" <.> exe]++ putStrLn "Build 1: Expect everything"+ rattleRun rattleOptions build+ putStrLn "Getting profiling data"+ writeProfile rattleOptions $ root ++ "/report.html"+ (w,s,p) <- graphData rattleOptions+ putStrLn $ "Work: " ++ show w+ putStrLn $ "Span: " ++ show s+ putStrLn $ "Parallelism: " ++ show p+ putStrLn "Build 2: Expect 1 thing"+ ignoreIO $ cmd ["sh", "-c", "echo '//comment' >> " ++ root ++ "/test/C/constants.c"]+ rattleRun rattleOptions build+ putStrLn "Build 2.5: Expect nothing"+ rattleRun rattleOptions build+ wipe+ putStrLn "Build 3: Expect cached (some speculation)"+ rattleRun rattleOptions build+++ putStrLn "Build 4: Read/write hazard"+ handle (\(h :: Hazard) -> print h) $ do+ rattleRun rattleOptions{rattleSpeculate=Nothing} $ do+ cmd ["./Main" <.> exe]+ cmd "gcc -o" ["Main" <.> exe] (reverse $ map toO cs)+ putStrLn "Hoped it failed, but doesn't always"+ -- fail "Expected a hazard"++ putStrLn "Build 5: Rebuild after"+ rattleRun rattleOptions build++ putStrLn "Build 6: Rebuild from a different directory"+ createDirectoryIfMissing True "inner"+ withCurrentDirectory "inner" $+ rattleRun rattleOptions $ withCmdOptions [Cwd ".."] build+ putStrLn "Build 7: Cause Restartable hazard"+ rattleRun rattleOptions $+ forM_ cs $ \c -> cmd "touch" c -- count as a write+ putStrLn "Should cause restartable hazard"+ rattleRun rattleOptions build
+ test/Test/Trace.hs view
@@ -0,0 +1,49 @@++module Test.Trace(main) where++import Control.Monad+import Data.List.Extra+import Test.Type+import Development.Shake.Command+import System.Directory+import System.FilePath+++check got want = do+ want <- mapM canonicalizePath want+ nubOrd got `intersect` want === want++traceWrite :: [FSATrace FilePath] -> [FilePath] -> IO ()+traceWrite ts = check [t | FSAWrite t <- ts]++traceRead :: [FSATrace FilePath] -> [FilePath] -> IO ()+traceRead ts = check [t | FSARead t <- ts]+++main =+ forM_ [Nothing, Just Shell] $ \opts -> do+ putStrLn "Check GCC works"+ writeFile "helloworld.h" "#include <stdio.h>\n"+ writeFile "helloworld.c" $ unlines+ ["#include \"helloworld.h\""+ ,"int main(){"+ ," printf(\"Hello World!\\n\");"+ ," return 0;"+ ,"}"+ ]++ xs <- cmd opts "gcc -c helloworld.c"+ traceRead xs ["helloworld.c","helloworld.h"]+ traceWrite xs ["helloworld.o"]++ xs <- cmd opts "gcc helloworld.o -o helloworld.exe"+ traceRead xs ["helloworld.o"]+ traceWrite xs ["helloworld.exe"]++ xs <- cmd opts $ "." </> "helloworld.exe"+ traceRead xs ["helloworld.exe"]++ putStrLn "Check curl works"+ -- Require the Shell below because of https://github.com/jacereda/fsatrace/issues/28+ xs <- cmd opts Shell "curl -sSL http://example.com/ -o example.txt"+ traceWrite xs ["example.txt"]
+ test/Test/Type.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Type(+ root,+ ignoreIO,+ assertWithin,+ (===),+ meetup,+ testGit+ ) where++import Development.Rattle+import Development.Shake.Command+import System.Time.Extra+import Control.Monad+import Control.Concurrent.QSemN+import Control.Exception.Extra+import System.Directory+++root :: FilePath+root = "../.."++ignoreIO :: IO () -> IO ()+ignoreIO act = catch act $ \(_ :: IOException) -> pure ()+++assertWithin :: Seconds -> IO a -> IO a+assertWithin n act = do+ t <- timeout n act+ case t of+ Nothing -> assertFail $ "Expected to complete within " ++ show n ++ " seconds, but did not"+ Just v -> pure v++assertFail :: String -> IO a+assertFail msg = errorIO $ "ASSERTION FAILED: " ++ msg++assertBool :: Bool -> String -> IO ()+assertBool b msg = unless b $ assertFail msg++infix 4 ===++(===) :: (Show a, Eq a) => a -> a -> IO ()+a === b = assertBool (a == b) $ "failed in ===\nLHS: " ++ show a ++ "\nRHS: " ++ show b+++-- | The action blocks until N people have reached, then everyone unblocks+meetup :: Int -> IO (IO ())+meetup n = do+ sem <- newQSemN 0+ pure $ do+ signalQSemN sem 1+ waitQSemN sem n+ signalQSemN sem n+++testGit :: String -> Run () -> IO ()+testGit url run = do+ b <- doesDirectoryExist ".git"+ if b then cmd "git fetch" else cmd_ "git clone" url "."+ forM_ [10,9..0] $ \i -> do+ cmd_ "git reset --hard" ["origin/master~" ++ show i]+ rattleRun rattleOptions run