shake 0.15.8 → 0.15.9

raw patch · 13 files changed

+77/−57 lines, 13 files

Files

• CHANGES.txt +4/−0
• docs/Manual.md +1/−1
• shake.cabal +2/−1
• src/Development/Shake/Command.hs +2/−0
• src/Development/Shake/Database.hs +38/−29
• src/Development/Shake/FilePattern.hs +1/−1
• src/Development/Shake/Pool.hs +22/−20
• src/Development/Shake/Rules/Directory.hs +1/−0
• src/Development/Shake/Rules/File.hs +1/−1
• src/Development/Shake/Types.hs +1/−1
• src/General/Process.hs +2/−1
• src/Test/Docs.hs +1/−1
• src/Test/Tup.hs +1/−1

@@ -1,5 +1,9 @@ Changelog for Shake +0.15.9+    Documentation tweaks+    Optimise the thread pool+    Fix progress output through wget 0.15.8     Extra base bounds to rule out building on GHC 7.4 0.15.7

@@ -288,7 +288,7 @@  This script creates a folder named `_shake` for the build system objects to live in, then runs `ghc --make Build.hs` to produce `_shake/build`, then executes `_shake/build` with all arguments it was given. The `-with-rtsopts` flag instructs the Haskell compiler to disable "idle garbage collection", making more CPU available for the commands you are running, as [explained here](http://stackoverflow.com/questions/34588057/why-does-shake-recommend-disabling-idle-garbage-collection/). -Now you can run a build by simply typing `./build.sh` on Linux, or `build` on Windows. On Linux you may want to alias `build` to `./build.sh`. For the rest of this document we will assume `build` runs the build system.+Now you can run a build by simply typing `stack exec ./build.sh` on Linux, or `stack exec build.bat` on Windows. On Linux you may want to alias `build` to `stack exec ./build.sh`. For the rest of this document we will assume `build` runs the build system.  _Warning:_ You should not use the `-threaded` for GHC 7.6 or below because of a [GHC bug](https://ghc.haskell.org/trac/ghc/ticket/7646). If you do turn on `-threaded`, you should include `-qg -qb` in `-with-rtsopts`.  

@@ -1,7 +1,7 @@ cabal-version:      >= 1.10 build-type:         Simple name:               shake-version:            0.15.8+version:            0.15.9 license:            BSD3 license-file:       LICENSE category:           Development, Shake@@ -232,6 +232,7 @@         Development.Shake.Profile         Development.Shake.Progress         Development.Shake.Resource+        Development.Shake.Rule         Development.Shake.Rules.Directory         Development.Shake.Rules.File         Development.Shake.Rules.Files

@@ -410,6 +410,7 @@ --   suitable for user diagnostics, but not for direct execution. newtype CmdLine = CmdLine {fromCmdLine :: String} +-- | The allowable 'String'-like values that can be captured. class CmdString a where cmdString :: (Str, Str -> a) instance CmdString () where cmdString = (Unit, \Unit -> ()) instance CmdString String where cmdString = (Str "", \(Str x) -> x)@@ -560,6 +561,7 @@ cmd :: CmdArguments args => args :-> Action r cmd = cmdArguments [] +-- | The arguments to 'cmd' - see 'cmd' for examples and semantics. class CmdArguments t where cmdArguments :: [Either CmdOption String] -> t instance (Arg a, CmdArguments r) => CmdArguments (a -> r) where     cmdArguments xs x = cmdArguments $ xs ++ arg x

@@ -81,38 +81,41 @@ --------------------------------------------------------------------- -- CENTRAL TYPES -data Trace = Trace BS Float Float -- (message, start, end)+data Trace = Trace BS Float Float -- ^ (message, start, end)     deriving Show  instance NFData Trace where     rnf (Trace a b c) = rnf a `seq` rnf b `seq` rnf c +type StatusDB = IORef (Map Id (Key, Status))+type InternDB = IORef (Intern Key)+ -- | Invariant: The database does not have any cycles where a Key depends on itself data Database = Database     {lock :: Lock-    ,intern :: IORef (Intern Key)-    ,status :: IORef (Map Id (Key, Status))+    ,intern :: InternDB+    ,status :: StatusDB     ,step :: Step     ,journal :: Id -> (Key, Status {- Loaded or Missing -}) -> IO ()-    ,diagnostic :: String -> IO () -- logging function+    ,diagnostic :: String -> IO () -- ^ logging function     ,assume :: Maybe Assume     }  data Status-    = Ready Result -- I have a value-    | Error SomeException -- I have been run and raised an error-    | Loaded Result -- Loaded from the database-    | Waiting Pending (Maybe Result) -- Currently checking if I am valid or building-    | Missing -- I am only here because I got into the Intern table+    = Ready Result -- ^ I have a value+    | Error SomeException -- ^ I have been run and raised an error+    | Loaded Result -- ^ Loaded from the database+    | Waiting Pending (Maybe Result) -- ^ Currently checking if I am valid or building+    | Missing -- ^ I am only here because I got into the Intern table       deriving Show  data Result = Result-    {result :: Value -- the result associated with the Key-    ,built :: {-# UNPACK #-} !Step -- when it was actually run-    ,changed :: {-# UNPACK #-} !Step -- the step for deciding if it's valid-    ,depends :: [[Id]] -- dependencies (outer list is a strict ordered series, inner list is parallel)-    ,execution :: {-# UNPACK #-} !Float -- how long it took when it was last run (seconds)-    ,traces :: [Trace] -- a trace of the expensive operations (start/end in seconds since beginning of run)+    {result :: Value -- ^ the result associated with the Key+    ,built :: {-# UNPACK #-} !Step -- ^ when it was actually run+    ,changed :: {-# UNPACK #-} !Step -- ^ the step for deciding if it's valid+    ,depends :: [[Id]] -- ^ dependencies (don't run them early)+    ,execution :: {-# UNPACK #-} !Float -- ^ how long it took when it was last run (seconds)+    ,traces :: [Trace] -- ^ a trace of the expensive operations (start/end in seconds since beginning of run)     } deriving Show  @@ -146,9 +149,9 @@ runWaiting :: Waiting -> IO () runWaiting (Waiting (Pending p) _) = join $ readIORef p --- Wait for a set of actions to complete--- If the action returns True, the function will not be called again--- If the first argument is True, the thing is ended+-- | Wait for a set of actions to complete.+--   If the action returns True, the function will not be called again.+--   If the first argument is True, the thing is ended. waitFor :: [(a, Waiting)] -> (Bool -> a -> IO Bool) -> IO () waitFor ws@(_:_) act = do     todo <- newIORef $ length ws@@ -183,19 +186,25 @@     }  +internKey :: InternDB -> StatusDB -> Key -> IO Id+internKey intern status k = do+    is <- readIORef intern+    case Intern.lookup k is of+        Just i -> return i+        Nothing -> do+            (is, i) <- return $ Intern.add k is+            writeIORef' intern is+            modifyIORef' status $ Map.insert i (k,Missing)+            return i++queryKey :: StatusDB -> Id -> IO (Maybe (Key, Status))+queryKey status i = Map.lookup i <$> readIORef status+ -- | Return either an exception (crash), or (how much time you spent waiting, the value) build :: Pool -> Database -> Ops -> Stack -> [Key] -> Capture (Either SomeException (Seconds,Depends,[Value])) build pool database@Database{..} Ops{..} stack ks continue =     join $ withLock lock $ do-        is <- forM ks $ \k -> do-            is <- readIORef intern-            case Intern.lookup k is of-                Just i -> return i-                Nothing -> do-                    (is, i) <- return $ Intern.add k is-                    writeIORef' intern is-                    modifyIORef' status $ Map.insert i (k,Missing)-                    return i+        is <- forM ks $ internKey intern status          whenJust (checkStack is stack) $ \bad -> do             -- everything else gets thrown via Left and can be Staunch'd@@ -245,8 +254,8 @@          reduce :: Stack -> Id -> IO Status         reduce stack i = do-            s <- readIORef status-            case Map.lookup i s of+            s <- queryKey status i+            case s of                 Nothing -> err $ "interned value missing from database, " ++ show i                 Just (k, Missing) -> run stack i k Nothing                 Just (k, Loaded r) -> do

@@ -207,7 +207,7 @@ --   but @file.h@ and @dir\/file.c@ don't. -- -- * @\/\/*.c@ matches all @.c@ files anywhere on the filesystem,----  so @file.c@, @dir\/file.c@, @dir1\/dir2\/file.c@ and @/path/to/file.c@ all match,+--   so @file.c@, @dir\/file.c@, @dir1\/dir2\/file.c@ and @\/path\/to\/file.c@ all match, --   but @file.h@ and @dir\/file.h@ don't. -- -- * @dir\/*\/*@ matches all files one level below @dir@, so @dir\/one\/file.c@ and

@@ -7,7 +7,6 @@     ) where  import Control.Concurrent.Extra-import Development.Shake.Errors import System.Time.Extra import Control.Exception import Control.Monad@@ -24,25 +23,27 @@ type NonDet a = IO a  -- Left = deterministic list, Right = non-deterministic tree-data Queue a = Queue [a] (Either [a] (Maybe (Tree a)))+data Queue a = Queue [a] (Either [a] (Tree a))  newQueue :: Bool -> Queue a-newQueue deterministic = Queue [] $ if deterministic then Left [] else Right Nothing+newQueue deterministic = Queue [] $ if deterministic then Left [] else Right emptyTree  enqueuePriority :: a -> Queue a -> Queue a enqueuePriority x (Queue p t) = Queue (x:p) t  enqueue :: a -> Queue a -> Queue a enqueue x (Queue p (Left xs)) = Queue p $ Left $ x:xs-enqueue x (Queue p (Right Nothing)) = Queue p $ Right $ Just $ singleTree x-enqueue x (Queue p (Right (Just t))) = Queue p $ Right $ Just $ insertTree x t+enqueue x (Queue p (Right t)) = Queue p $ Right $ insertTree x t -dequeue :: Queue a -> Maybe (NonDet (a, Queue a))-dequeue (Queue (p:ps) t) = Just $ return (p, Queue ps t)-dequeue (Queue [] (Left (x:xs))) = Just $ return (x, Queue [] $ Left xs)-dequeue (Queue [] (Left [])) = Nothing-dequeue (Queue [] (Right (Just t))) = Just $ do bs <- randomIO; (x,t) <- return $ removeTree bs t; return (x, Queue [] $ Right t)-dequeue (Queue [] (Right Nothing)) = Nothing+dequeue :: Queue a -> NonDet (Maybe (a, Queue a))+dequeue (Queue (p:ps) t) = return $ Just (p, Queue ps t)+dequeue (Queue [] (Left (x:xs))) = return $ Just (x, Queue [] $ Left xs)+dequeue (Queue [] (Left [])) = return Nothing+dequeue (Queue [] (Right t)) = do+    bs <- randomIO+    return $ case removeTree bs t of+        Nothing -> Nothing+        Just (x,t) -> Just (x, Queue [] $ Right t)   ---------------------------------------------------------------------@@ -51,19 +52,20 @@ -- A tree where removal is random. Nodes are stored at indicies 0..n-1 data Tree a = Tree {-# UNPACK #-} !Int (Map.HashMap Int a) -singleTree :: a -> Tree a-singleTree x = Tree 1 $ Map.singleton 0 x +emptyTree :: Tree a+emptyTree = Tree 0 Map.empty+ insertTree :: a -> Tree a -> Tree a insertTree x (Tree n mp) = Tree (n+1) $ Map.insert n x mp  -- Remove an item at random, put the n-1 item to go in it's place-removeTree :: Int -> Tree a -> (a, Maybe (Tree a))+removeTree :: Int -> Tree a -> Maybe (a, Tree a) removeTree rnd (Tree n mp)-        | n == 0 = err "removeTree, tree is empty"-        | n == 1 = (mp Map.! 0, Nothing)-        | i == n-1 = (mp Map.! i, Just $ Tree (n-1) $ Map.delete i mp)-        | otherwise = (mp Map.! i, Just $ Tree (n-1) $ Map.insert i (mp Map.! (n-1)) $ Map.delete (n-1) mp)+        | n == 0 = Nothing+        | n == 1 = Just (mp Map.! 0, emptyTree)+        | i == n-1 = Just (mp Map.! i, Tree (n-1) $ Map.delete i mp)+        | otherwise = Just (mp Map.! i, Tree (n-1) $ Map.insert i (mp Map.! (n-1)) $ Map.delete (n-1) mp)     where         i = abs rnd `mod` n @@ -97,7 +99,7 @@ worker pool@(Pool var done) = do     let onVar act = modifyVar var $ maybe (return (Nothing, return ())) act     join $ onVar $ \s -> do-        res <- maybe (return Nothing) (fmap Just) $ dequeue $ todo s+        res <- dequeue $ todo s         case res of             Nothing -> return (Just s, return ())             Just (now, todo2) -> return (Just s{todo = todo2}, now >> worker pool)@@ -110,7 +112,7 @@     let onVar act = modifyVar_ var $ maybe (return Nothing) act     onVar $ \s -> do         s <- op s-        res <- maybe (return Nothing) (fmap Just) $ dequeue $ todo s+        res <- dequeue $ todo s         case res of             Just (now, todo2) | Set.size (threads s) < threadsLimit s -> do                 -- spawn a new worker

@@ -228,6 +228,7 @@ -- | Get the directories in a directory, not including @.@ or @..@. --   All directories are relative to the argument directory. The result is tracked as a --   dependency, and if it changes the rule will rerun in subsequent builds.+--   The rules about creating entries described in 'getDirectoryFiles' also apply here. -- -- > getDirectoryDirs "/Users" -- >    -- Return all directories in the /Users directory

@@ -237,7 +237,7 @@ -- | Infix operator alias for 'phony', for sake of consistency with normal --   rules. (~>) :: String -> Action () -> Rules ()-(~>) = phony +(~>) = phony   -- | Define a rule to build files. If the first argument returns 'True' for a given file,

@@ -111,7 +111,7 @@     ,shakeLintInside :: [FilePath]         -- ^ Directories in which the files will be tracked by the linter.     ,shakeLintIgnore :: [FilePattern]-        -- ^ File patterns which are ignored from linter tracking, a bit like calling 'trackAllow' in every rule.+        -- ^ File patterns which are ignored from linter tracking, a bit like calling 'Development.Shake.trackAllow' in every rule.     ,shakeCommandOptions :: [CmdOption]         -- ^ Defaults to @[]@. Additional options to be passed to all command invocations.     ,shakeFlush :: Maybe Double

@@ -163,7 +163,8 @@                 let streams = [(outh, stdout, poStdout) | Just outh <- [outh], CreatePipe <- [std_out cp]] ++                               [(errh, stderr, poStderr) | Just errh <- [errh], CreatePipe <- [std_err cp]]                 wait <- forM streams $ \(h, hh, dest) -> do-                    let isTied = not $ poStdout `disjoint` poStderr+                    -- no point tying the streams together if one is being streamed directly+                    let isTied = not (poStdout `disjoint` poStderr) && length streams == 2                     let isBinary = not $ any isDestString dest && not (any isDestBytes dest)                     when isTied $ hSetBuffering h LineBuffering                     when (DestEcho `elem` dest) $ do

@@ -68,7 +68,7 @@             ,"import System.Time.Extra"             ,"import Data.Maybe"             ,"import Data.Monoid"-            ,"import Development.Shake hiding ((*>))"+            ,"import Development.Shake hiding ((*>),trackAllow)"             ,"import Development.Shake.Classes"             ,"import Development.Shake.Rule hiding (trackAllow)"             ,"import Development.Shake.Util"

@@ -17,7 +17,7 @@      action $ do         keys <- getConfigKeys-        need [x -<.> exe | x <- keys, takeExtension x == ".exe"]+        need [obj $ x -<.> exe | x <- keys, takeExtension x == ".exe"]      let objects dir key = do             let f x | takeExtension x == ".c" = obj $ dir </> x -<.> "o"