packages feed

shake 0.17.8 → 0.17.9

raw patch · 17 files changed

+151/−240 lines, 17 files

Files

CHANGES.txt view
@@ -1,5 +1,13 @@ Changelog for Shake (* = breaking change) +0.17.9, released 2019-05-01+    #675, allow --compact=yes|no|auto+    Make lintTrackAllow work after the lintTrackRead/Write+*   Merge successive Cwd declarations to cmd+    #671, change the file format to permit rsync of caches+    Speed up lint tracking+    #670, make cloud values more portable between machines+    #666, exceptions in --share-list, --share-remove are warnings 0.17.8, released 2019-04-02     Eliminate a corner case of losing exception messages     Make FSATrace available as a result type
shake.cabal view
@@ -1,7 +1,7 @@ cabal-version:      >= 1.18 build-type:         Simple name:               shake-version:            0.17.8+version:            0.17.9 license:            BSD3 license-file:       LICENSE category:           Development, Shake@@ -30,7 +30,7 @@     (e.g. compiler version). homepage:           https://shakebuild.com bug-reports:        https://github.com/ndmitchell/shake/issues-tested-with:        GHC==8.6.4, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3+tested-with:        GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3 extra-doc-files:     CHANGES.txt     README.md@@ -360,7 +360,6 @@         Development.Ninja.Lexer         Development.Ninja.Parse         Development.Ninja.Type-        Development.Rattle         Development.Shake         Development.Shake.Classes         Development.Shake.Command@@ -466,7 +465,6 @@         Test.Pool         Test.Progress         Test.Random-        Test.Rattle         Test.Rebuild         Test.Resources         Test.Self
− src/Development/Rattle.hs 
@@ -1,125 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, RecordWildCards, TupleSections #-}--module Development.Rattle(-    rattle,-    cmd,-    parallel,-    liftIO-    ) where--import Control.Monad.Trans.Reader-import Control.Monad.IO.Class-import Control.Monad.Extra-import System.IO.Error-import System.IO.Extra-import Control.Exception.Extra-import qualified Development.Shake.Command as C-import qualified Data.HashMap.Strict as Map-import Data.IORef-import System.Directory-import Data.List.Extra-import Data.Maybe-import Data.Time-import Data.Tuple.Extra---newtype Run a = Run {unRun :: ReaderT (IORef S) IO a}-    deriving (Functor, Applicative, Monad, MonadIO)--newtype T = T Int -- timestamps-    deriving (Enum,Eq,Ord,Show)--data S = S-    {timestamp :: T -- the timestamp I am on-    -- ,running :: [Args] -- things that are running now-    ,finished :: [(T, T, Cmd)] -- people who have finished-    ,history :: [Cmd] -- what I ran last time around-    } deriving Show--getTimestamp :: Run T-getTimestamp = do-    ref <- Run ask-    liftIO $ atomicModifyIORef' ref $ \s -> (s{timestamp = succ $ timestamp s}, timestamp s)--getHistory :: Run [Cmd]-getHistory = do-    ref <- Run ask-    liftIO $ history <$> readIORef ref--addExecuted :: (T, T, Cmd) -> Run ()-addExecuted x = do-    ref <- Run ask-    liftIO $ atomicModifyIORef' ref $ \s -> (s{finished = x : finished s}, ())--parallel :: [Run a] -> Run [a]-parallel = sequence--type Args = [String]--cmd :: Args -> Run ()-cmd args = do-    start <- getTimestamp-    history <- getHistory-    skip <- liftIO $ flip firstJustM history $ \cmd@Cmd{..} -> do-        let conds = (return $ args == cmdArgs) :-                    [(== time) <$> getModTime file | (file,time) <- cmdRead ++ cmdWrite]-        ifM (andM conds) (return $ Just cmd) (return Nothing)-    cmd <- case skip of-        Just cmd -> return cmd-        Nothing -> do-            liftIO $ putStrLn $ unwords $ "#" : args-            xs :: [C.FSATrace] <- liftIO $ C.cmd args-            let (reads, writes) = both (nubOrd . concat) $ unzip $ map fsaRW xs-            let f xs = liftIO $ forM xs $ \x -> (x,) <$> getModTime x-            -- explicitly add back in the program beacuse of https://github.com/jacereda/fsatrace/issues/19-            prog <- liftIO $ case args of-                prog:_ -> findExecutable prog-                _ -> return Nothing-            reads <- f $ maybeToList prog ++ reads-            writes <- f writes-            return $ Cmd args reads writes-    stop <- getTimestamp-    addExecuted (start, stop, cmd)---getModTime :: FilePath -> IO (Maybe UTCTime)-getModTime x = handleBool isDoesNotExistError (const $ return Nothing) (Just <$> getModificationTime x)--fsaRW :: C.FSATrace -> ([FilePath], [FilePath])-fsaRW (C.FSAWrite x) = ([], [x])-fsaRW (C.FSARead x) = ([x], [])-fsaRW (C.FSADelete x) = ([], [x])-fsaRW (C.FSAMove x y) = ([], [x,y])-fsaRW (C.FSAQuery x) = ([x], [])-fsaRW (C.FSATouch x) = ([], [x])--data Cmd = Cmd-    {cmdArgs :: Args-    ,cmdRead :: [(FilePath, Maybe UTCTime)]-    ,cmdWrite :: [(FilePath, Maybe UTCTime)]-    } deriving (Show, Read)----- | Given an Action to run, and a list of previous commands that got run, run it again-rattle :: Run a -> IO a-rattle act = do-    history <- ifM (doesFileExist ".rattle") (map read . lines <$> readFile' ".rattle") (return [])-    ref <- newIORef $ S (T 0) [] history-    res <- flip runReaderT ref $ unRun act-    cmds <- finished <$> readIORef ref-    checkHazards cmds-    writeFile ".rattle" $ unlines $ reverse $ map (show . thd3) cmds-    return res---- | You get a write/write hazard if two separate commands write to the same file.---   You get a read/write hazard if there was a read of a file before a write.-checkHazards :: [(T, T, Cmd)] -> IO ()-checkHazards xs = do-    let writeWrite = Map.filter (\args -> length args > 1) $ Map.fromListWith (++) [(fst x, [cmdArgs]) | (_,_,Cmd{..}) <- xs, x <- cmdWrite]-    unless (Map.null writeWrite) $-        fail $ "Write/write: " ++ show writeWrite--    let lastWrite = Map.fromList [(fst x, (end, cmdArgs)) | (_,end,Cmd{..}) <- xs, x <- cmdWrite]-    let readWrite = [x | (start,_,Cmd{..}) <- xs, x <- cmdRead, Just (t, args) <- [Map.lookup (fst x) lastWrite], t >= start, args /= cmdArgs]-    unless (null readWrite) $-        fail $ "Read/write: " ++ show readWrite
src/Development/Shake/Command.hs view
@@ -26,7 +26,7 @@ import Data.List.Extra import Data.Maybe import Data.Data-import Data.Semigroup (Semigroup)+import Data.Semigroup import System.Directory import qualified System.IO.Extra as IO import System.Environment@@ -40,6 +40,7 @@ import qualified Data.ByteString.Lazy.Char8 as LBS import General.Extra import General.Process+import Prelude  import Development.Shake.Internal.CmdOption import Development.Shake.Internal.Core.Action@@ -321,7 +322,7 @@             _ -> (False, False)      optEnv <- resolveEnv opts-    let optCwd = let x = last $ "" : [x | Cwd x <- opts] in if x == "" then Nothing else Just x+    let optCwd = mergeCwd [x | Cwd x <- opts]     let optStdin = flip mapMaybe opts $ \x -> case x of             Stdin x -> Just $ SrcString x             StdinBS x -> Just $ SrcBytes x@@ -386,6 +387,10 @@             else if null exceptionBuffer then intercalate " and " captured ++ " " ++ (if length captured == 1 then "was" else "were") ++ " empty"             else intercalate " and " captured ++ ":\n" ++ unlines (dropWhile null $ lines $ concat exceptionBuffer) ++mergeCwd :: [FilePath] -> Maybe FilePath+mergeCwd [] = Nothing+mergeCwd xs = Just $ foldl1 (</>) xs  -- | Apply all environment operations, to produce a new environment to use. resolveEnv :: [CmdOption] -> IO (Maybe [(String, String)])
src/Development/Shake/Internal/Args.hs view
@@ -218,10 +218,12 @@             when printDirectory $ do                 curdir <- getCurrentDirectory                 putWhenLn Normal $ "shake: In directory `" ++ curdir ++ "'"-            (shakeOpts, ui) <--                if Compact `elem` flagsExtra-                then second withThreadSlave <$> compactUI shakeOpts-                else return (shakeOpts, id)+            (shakeOpts, ui) <- do+                let compact = last $ No : [x | Compact x <- flagsExtra]+                use <- if compact == Auto then checkEscCodes else return $ compact == Yes+                if use+                    then second withThreadSlave <$> compactUI shakeOpts+                    else return (shakeOpts, id)             rules <- rules shakeOpts user files             ui $ case rules of                 Nothing -> return (False, shakeOpts, Right ())@@ -277,9 +279,11 @@            | Demo            | ShareList            | ShareRemove String-           | Compact+           | Compact Auto              deriving Eq +data Auto = Yes | No | Auto+    deriving Eq  escape :: Color -> String -> String escape color x = escForeground color ++ x ++ escNormal@@ -296,9 +300,9 @@ --    ,yes $ Option ""  ["cloud"] (reqArg "URL" $ \x s -> s{shakeCloud=shakeCloud s ++ [x]}) "HTTP server providing a cloud cache."     ,opts $ Option ""  ["color","colour"] (noArg $ \s -> s{shakeColor=True}) "Colorize the output."     ,opts $ Option ""  ["no-color","no-colour"] (noArg $ \s -> s{shakeColor=False}) "Don't colorize the output."-    ,extr $ Option ""  ["compact"] (noArg [Compact]) "Use a compact Bazel/Buck style output."+    ,extr $ Option ""  ["compact"] (optArgAuto "auto" "yes|no|auto" $ \x -> [Compact x]) "Use a compact Bazel/Buck style output."     ,opts $ Option "d" ["debug"] (optArg "FILE" $ \x s -> s{shakeVerbosity=Diagnostic, shakeOutput=outputDebug (shakeOutput s) x}) "Print lots of debugging information."-    ,extr  $ Option ""  ["demo"] (noArg [Demo]) "Run in demo mode."+    ,extr $ Option ""  ["demo"] (noArg [Demo]) "Run in demo mode."     ,opts $ Option ""  ["digest"] (noArg $ \s -> s{shakeChange=ChangeDigest}) "Files change when digest changes."     ,opts $ Option ""  ["digest-and"] (noArg $ \s -> s{shakeChange=ChangeModtimeAndDigest}) "Files change when modtime and digest change."     ,opts $ Option ""  ["digest-and-input"] (noArg $ \s -> s{shakeChange=ChangeModtimeAndDigestInput}) "Files change on modtime (and digest for inputs)."@@ -365,6 +369,12 @@         optArgInt mn flag a f = flip OptArg a $ maybe (Right (f Nothing)) $ \x -> case reads x of             [(i,"")] | i >= mn -> Right (f $ Just i)             _ -> Left $ "the `--" ++ flag ++ "' option requires a number, " ++ show mn ++ " or above"++        optArgAuto flag a f = flip OptArg a $ maybe (Right (f Yes)) $ \x -> case x of+            "yes" -> Right $ f Yes+            "no" -> Right $ f No+            "auto" -> Right $ f Auto+            _ -> Left $ "the `--" ++ flag ++ "' option requires yes|no|auto, but got " ++ show x          reqArgPair flag a f = flip ReqArg a $ \x -> case break (== '=') x of             (a,'=':b) -> Right $ f (a,b)
src/Development/Shake/Internal/CmdOption.hs view
@@ -7,6 +7,7 @@ -- | Options passed to 'command' or 'cmd' to control how processes are executed. data CmdOption     = Cwd FilePath -- ^ Change the current directory in the spawned process. By default uses this processes current directory.+                   --   Successive 'Cwd' options are joined together, to change into nested directories.     | Env [(String,String)] -- ^ Change the environment variables in the spawned process. By default uses this processes environment.     | AddEnv String String -- ^ Add an environment variable in the child process.     | RemEnv String -- ^ Remove an environment variable from the child process.
src/Development/Shake/Internal/Core/Action.hs view
@@ -36,6 +36,7 @@ import Numeric.Extra import General.Extra import qualified Data.HashMap.Strict as Map+import qualified Data.HashSet as Set  import Development.Shake.Classes import Development.Shake.Internal.Core.Monad@@ -268,19 +269,45 @@         let condition3 k = any ($ k) localTrackAllows         let condition4 = filter (\k -> not $ condition1 k || condition2 k || condition3 k) $ map newKey ks         unless (null condition4) $-            Action $ putRW l{localTrackUsed = condition4 ++ localTrackUsed}+            Action $ putRW l{localTrackRead = condition4 ++ localTrackRead}  +-- | Track that a key has been changed/written by the action preceding it when 'shakeLint' is active.+lintTrackWrite :: ShakeValue key => [key] -> Action ()+-- One of the following must be true:+-- 1) you are the one building this key (e.g. key == topStack)+-- 2) someone explicitly gave you permission with trackAllow+-- 3) this file is never known to the build system, at the end it is not in the database+lintTrackWrite ks = do+    Global{..} <- Action getRO+    when (isJust $ shakeLint globalOptions) $ do+        l@Local{..} <- Action getRW+        let top = topStack localStack++        let condition1 k = Just k == top+        let condition2 k = any ($ k) localTrackAllows+        let condition3 = filter (\k -> not $ condition1 k || condition2 k) $ map newKey ks+        unless (null condition3) $+            Action $ putRW l{localTrackWrite = condition3 ++ localTrackWrite}++ lintTrackFinished :: Action () lintTrackFinished = do     -- only called when isJust shakeLint     Global{..} <- Action getRO     Local{..} <- Action getRW     liftIO $ do+        let top = topStack localStack+        -- must apply the ignore at the end, because we might have merged in more ignores that+        -- apply to other branches+        let ignore k = any ($ k) localTrackAllows++        -- Read stuff         deps <- concatMapM (listDepends globalDatabase) localDepends+        let used = Set.filter (not . ignore) $ Set.fromList localTrackRead -        -- check 4a-        bad <- return $ localTrackUsed \\ deps+        -- check Read 4a+        bad <- return $ Set.toList $ used `Set.difference` Set.fromList deps         unless (null bad) $ do             let n = length bad             throwM $ errorStructured@@ -288,8 +315,8 @@                 [("Used", Just $ show x) | x <- bad]                 "" -        -- check 4b-        bad <- flip filterM localTrackUsed $ \k -> not . null <$> lookupDependencies globalDatabase k+        -- check Read 4b+        bad <- flip filterM (Set.toList used) $ \k -> not . null <$> lookupDependencies globalDatabase k         unless (null bad) $ do             let n = length bad             throwM $ errorStructured@@ -297,27 +324,14 @@                 [("Used", Just $ show x) | x <- bad]                 "" ---- | Track that a key has been changed/written by the action preceding it when 'shakeLint' is active.-lintTrackWrite :: ShakeValue key => [key] -> Action ()--- One of the following must be true:--- 1) you are the one building this key (e.g. key == topStack)--- 2) someone explicitly gave you permission with trackAllow--- 3) this file is never known to the build system, at the end it is not in the database-lintTrackWrite ks = do-    Global{..} <- Action getRO-    when (isJust $ shakeLint globalOptions) $ do-        Local{..} <- Action getRW-        let top = topStack localStack--        let condition1 k = Just k == top-        let condition2 k = any ($ k) localTrackAllows-        let condition3 = filter (\k -> not $ condition1 k || condition2 k) $ map newKey ks-        unless (null condition3) $-            liftIO $ atomicModifyIORef globalTrackAbsent $ \old -> ([(fromMaybe k top, k) | k <- condition3] ++ old, ())+        -- check Write 3+        bad <- return $ filter (not . ignore) $ Set.toList $ Set.fromList localTrackWrite+        unless (null bad) $+            liftIO $ atomicModifyIORef globalTrackAbsent $ \old -> ([(fromMaybe k top, k) | k <- bad] ++ old, ())  --- | Allow any matching key to violate the tracking rules.+-- | Allow any matching key recorded with 'lintTrackRead' or 'lintTrackWrite' in this action,+--   after this call, to violate the tracking rules. lintTrackAllow :: ShakeValue key => (key -> Bool) -> Action () lintTrackAllow (test :: key -> Bool) = do     Global{..} <- Action getRO
src/Development/Shake/Internal/Core/Types.hs view
@@ -418,7 +418,8 @@     ,localDiscount :: !Seconds -- ^ Time spend building dependencies (may be negative for parallel)     ,localTraces :: [Trace] -- ^ Traces, built in reverse     ,localTrackAllows :: [Key -> Bool] -- ^ Things that are allowed to be used-    ,localTrackUsed :: [Key] -- ^ Things that have been used+    ,localTrackRead :: [Key] -- ^ Calls to 'lintTrackRead'+    ,localTrackWrite :: [Key] -- ^ Calls to 'lintTrackWrite'     ,localProduces :: [(Bool, FilePath)] -- ^ Things this rule produces, True to check them     ,localHistory :: !Bool -- ^ Is it valid to cache the result     }@@ -427,7 +428,7 @@ addDiscount s l = l{localDiscount = s + localDiscount l}  newLocal :: Stack -> Verbosity -> Local-newLocal stack verb = Local stack (Ver 0) verb Nothing [] 0 [] [] [] [] True+newLocal stack verb = Local stack (Ver 0) verb Nothing [] 0 [] [] [] [] [] True  -- Clear all the local mutable variables localClearMutable :: Local -> Local@@ -449,7 +450,8 @@     ,localDiscount = sum $ map localDiscount $ root : xs     ,localTraces = mergeTracesRev (map localTraces xs) ++ localTraces root     ,localTrackAllows = localTrackAllows root ++ concatMap localTrackAllows xs-    ,localTrackUsed = localTrackUsed root ++ concatMap localTrackUsed xs+    ,localTrackRead = localTrackRead root ++ concatMap localTrackRead xs+    ,localTrackWrite = localTrackWrite root ++ concatMap localTrackWrite xs     ,localProduces = concatMap localProduces xs ++ localProduces root     ,localHistory = all localHistory $ root:xs     }
src/Development/Shake/Internal/History/Shared.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards, TupleSections #-}+{-# LANGUAGE RecordWildCards, ScopedTypeVariables, TupleSections #-}  module Development.Shake.Internal.History.Shared(     Shared, newShared,@@ -6,6 +6,7 @@     removeShared, listShared     ) where +import Control.Exception import Development.Shake.Internal.Value import Development.Shake.Internal.History.Types import Development.Shake.Internal.History.Symlink@@ -13,7 +14,7 @@ import Development.Shake.Classes import General.Binary import General.Extra-import General.Chunks+import Data.List import Control.Monad.Extra import System.Directory.Extra import System.FilePath@@ -81,44 +82,56 @@         getDepend x | (a, b) <- getExN x = (getOp binop a, getEx b)         getFile x | (b, a) <- binarySplit x = (getEx a, b) +hexed x = showHex (abs $ hash x) ""++-- | The path under which everything relating to a Key lives sharedFileDir :: Shared -> Key -> FilePath-sharedFileDir shared key = sharedRoot shared </> ".shake.cache" </> showHex (abs $ hash key) ""+sharedFileDir shared key = sharedRoot shared </> ".shake.cache" </> hexed key -loadSharedEntry :: Shared -> Key -> Ver -> Ver -> IO [Entry]-loadSharedEntry shared@Shared{..} key builtinVersion userVersion = do-    let file = sharedFileDir shared key </> "_key"-    b <- doesFileExist_ file-    if not b then return [] else do-        (items, slop) <- withFile file ReadMode $ \h ->-            readChunksDirect h maxBound-        unless (BS.null slop) $-            error $ "Corrupted key file, " ++ show file-        let eq Entry{..} = entryKey == key && entryGlobalVersion == globalVersion && entryBuiltinVersion == builtinVersion && entryUserVersion == userVersion-        return $ filter eq $ map (getEntry keyOp) items+-- | The list of files containing Entry values, given a result of 'sharedFileDir'+sharedFileKeys :: FilePath -> IO [FilePath]+sharedFileKeys dir = do+    b <- doesDirectoryExist_ $ dir </> "_key"+    if not b then return [] else listFiles $ dir </> "_key" +loadSharedEntry :: Shared -> Key -> Ver -> Ver -> IO [IO (Maybe Entry)]+loadSharedEntry shared@Shared{..} key builtinVersion userVersion =+    map f <$> sharedFileKeys (sharedFileDir shared key)+    where+        f file = do+            e@Entry{..} <- getEntry keyOp <$> BS.readFile file+            let valid = entryKey == key && entryGlobalVersion == globalVersion && entryBuiltinVersion == builtinVersion && entryUserVersion == userVersion+            return $ if valid then Just e else Nothing + -- | Given a way to get the identity, see if you can a stored cloud version lookupShared :: Shared -> (Key -> Wait Locked (Maybe BS_Identity)) -> Key -> Ver -> Ver -> Wait Locked (Maybe (BS_Store, [[Key]], IO ())) lookupShared shared ask key builtinVersion userVersion = do     ents <- liftIO $ loadSharedEntry shared key builtinVersion userVersion-    flip firstJustWaitUnordered ents $ \Entry{..} -> do-        -- use Nothing to indicate success, Just () to bail out early on mismatch-        let result x = if isJust x then Nothing else Just $ (entryResult, map (map fst) entryDepends, ) $ do-                let dir = sharedFileDir shared entryKey-                forM_ entryFiles $ \(file, hash) ->-                    copyFileLink (dir </> show hash) file-        result <$> firstJustM id-            [ firstJustWaitUnordered id-                [ test <$> ask k | (k, i1) <- kis-                , let test = maybe (Just ()) (\i2 -> if i1 == i2 then Nothing else Just ())]-            | kis <- entryDepends]+    flip firstJustWaitUnordered ents $ \act -> do+        me <- liftIO act+        case me of+            Nothing -> return Nothing+            Just Entry{..} -> do+                -- use Nothing to indicate success, Just () to bail out early on mismatch+                let result x = if isJust x then Nothing else Just $ (entryResult, map (map fst) entryDepends, ) $ do+                        let dir = sharedFileDir shared entryKey+                        forM_ entryFiles $ \(file, hash) ->+                            copyFileLink (dir </> show hash) file+                result <$> firstJustM id+                    [ firstJustWaitUnordered id+                        [ test <$> ask k | (k, i1) <- kis+                        , let test = maybe (Just ()) (\i2 -> if i1 == i2 then Nothing else Just ())]+                    | kis <- entryDepends]   saveSharedEntry :: Shared -> Entry -> IO () saveSharedEntry shared entry = do     let dir = sharedFileDir shared (entryKey entry)     createDirectoryRecursive dir-    withFile (dir </> "_key") AppendMode $ \h -> writeChunkDirect h $ putEntry (keyOp shared) entry+    let v = runBuilder $ putEntry (keyOp shared) entry+    createDirectoryRecursive $ dir </> "_key"+    BS.writeFile (dir </> "_key" </> hexed v) v     forM_ (entryFiles entry) $ \(file, hash) ->         unlessM (doesFileExist_ $ dir </> show hash) $             copyFileLink file (dir </> show hash)@@ -129,15 +142,14 @@     files <- mapM (\x -> (x,) <$> getFileHash (fileNameFromString x)) files     saveSharedEntry shared Entry{entryFiles = files, entryGlobalVersion = globalVersion shared, ..} - removeShared :: Shared -> (Key -> Bool) -> IO () removeShared Shared{..} test = do     dirs <- listDirectories $ sharedRoot </> ".shake.cache"     deleted <- forM dirs $ \dir -> do-        (items, _slop) <- withFile (dir </> "_key") ReadMode $ \h ->-            readChunksDirect h maxBound+        files <- sharedFileKeys dir         -- if any key matches, clean them all out-        let b = any (test . entryKey . getEntry keyOp) items+        b <- flip anyM files $ \file -> handleSynchronous (\e -> putStrLn ("Warning: " ++ show e) >> return False) $+            evaluate . test . entryKey . getEntry keyOp =<< BS.readFile file         when b $ removeDirectoryRecursive dir         return b     liftIO $ putStrLn $ "Deleted " ++ show (length (filter id deleted)) ++ " entries"@@ -147,10 +159,10 @@     dirs <- listDirectories $ sharedRoot </> ".shake.cache"     forM_ dirs $ \dir -> do         putStrLn $ "Directory: " ++ dir-        (items, _slop) <- withFile (dir </> "_key") ReadMode $ \h ->-            readChunksDirect h maxBound-        forM_ items $ \item -> do-            let Entry{..} = getEntry keyOp item-            putStrLn $ "  Key: " ++ show entryKey-            forM_ entryFiles $ \(file,_) ->-                putStrLn $ "    File: " ++ file+        keys <- sharedFileKeys dir+        forM_ keys $ \key ->+            handleSynchronous (\e -> putStrLn $ "Warning: " ++ show e) $ do+                Entry{..} <- getEntry keyOp <$> BS.readFile key+                putStrLn $ "  Key: " ++ show entryKey+                forM_ entryFiles $ \(file,_) ->+                    putStrLn $ "    File: " ++ file
src/Development/Shake/Internal/Rules/File.hs view
@@ -470,7 +470,7 @@ trackWrite :: [FilePath] -> Action () trackWrite = track lintTrackWrite --- | Allow accessing a file in this rule, ignoring any 'trackRead' \/ 'trackWrite' calls matching+-- | Allow accessing a file in this rule, ignoring any subsequent 'trackRead' \/ 'trackWrite' calls matching --   the pattern. trackAllow :: [FilePattern] -> Action () trackAllow ps = do
src/General/Chunks.hs view
@@ -3,8 +3,7 @@ module General.Chunks(     Chunks,     readChunk, readChunkMax, usingWriteChunks, writeChunk,-    restoreChunksBackup, usingChunks, resetChunksCompact, resetChunksCorrupt,-    readChunksDirect, writeChunkDirect+    restoreChunksBackup, usingChunks, resetChunksCompact, resetChunksCorrupt     ) where  import System.Time.Extra@@ -51,15 +50,6 @@         let count = fromIntegral $ min mx $ fst $ unsafeBinarySplit n         v <- BS.hGet h count         if BS.length v < count then slop (n `BS.append` v) else return $ Right v--readChunksDirect :: Handle -> Word32 -> IO ([BS.ByteString], BS.ByteString)-readChunksDirect h mx = do-    res <- readChunkDirect h mx-    case res of-        Left done -> return ([], done)-        Right x -> do-            (xs, done) <- readChunksDirect h mx-            return (x : xs, done)  writeChunkDirect :: Handle -> Builder -> IO () writeChunkDirect h x = bs `seq` BS.hPut h bs
src/General/Extra.hs view
@@ -14,10 +14,10 @@     isAsyncException,     showDurationSecs,     usingLineBuffering,-    doesFileExist_,+    doesFileExist_, doesDirectoryExist_,     usingNumCapabilities,     removeFile_, createDirectoryRecursive,-    catchIO, tryIO, handleIO,+    catchIO, tryIO, handleIO, handleSynchronous,     Located, Partial, callStackTop, callStackFull, withFrozenCallStack, callStackFromException,     Ver(..), makeVer,     QTypeRep(..),@@ -30,7 +30,6 @@ import System.Environment import Development.Shake.FilePath import Control.DeepSeq-import Numeric import General.Cleanup import Data.Typeable import System.IO.Extra@@ -222,6 +221,8 @@ handleIO :: (IOException -> IO a) -> IO a -> IO a handleIO = handle +handleSynchronous :: (SomeException -> IO a) -> IO a -> IO a+handleSynchronous = handleBool (not . isAsyncException)  --------------------------------------------------------------------- -- System.Directory@@ -229,6 +230,9 @@ doesFileExist_ :: FilePath -> IO Bool doesFileExist_ x = doesFileExist x `catchIO` \_ -> return False +doesDirectoryExist_ :: FilePath -> IO Bool+doesDirectoryExist_ x = doesDirectoryExist x `catchIO` \_ -> return False+ -- | Remove a file, but don't worry if it fails removeFile_ :: FilePath -> IO () removeFile_ x = removeFile x `catchIO` \_ -> return ()@@ -300,4 +304,10 @@     deriving (Eq,Hashable,NFData)  instance Show QTypeRep where-    show (QTypeRep x) = show x ++ " {" ++ showHex (abs $ hashWithSalt 0 x) "" ++ "}"+    -- Need to show enough so that different types with the same names don't clash+    -- But can't show too much or the history is not portable https://github.com/ndmitchell/shake/issues/670+    show (QTypeRep x) = f x+        where+            f x = ['(' | xs /= []] ++ (unwords $ g c : map f xs) ++ [')' | xs /= []]+                where (c, xs) = splitTyConApp x+            g x = tyConModule x ++ "." ++ tyConName x
src/Test.hs view
@@ -47,7 +47,6 @@ import qualified Test.Pool import qualified Test.Progress import qualified Test.Random-import qualified Test.Rattle import qualified Test.Rebuild import qualified Test.Deprioritize import qualified Test.Resources@@ -104,7 +103,6 @@     ,"pool" * Test.Pool.main     ,"progress" * Test.Progress.main     ,"random" * Test.Random.main-    ,"rattle" * Test.Rattle.main     ,"rebuild" * Test.Rebuild.main     ,"resources" * Test.Resources.main     ,"self" * Test.Self.main
src/Test/Command.hs view
@@ -6,6 +6,7 @@ import Development.Shake.FilePath import Control.Exception.Extra import System.Time.Extra+import General.Extra import Control.Monad.Extra import System.Directory import Test.Type@@ -76,7 +77,8 @@     "cwd" !> do         -- FIXME: Linux searches the Cwd argument for the file, Windows searches getCurrentDirectory         helper <- liftIO $ canonicalizePath $ "helper/shake_helper" <.> exe-        Stdout out <- cmd (Cwd "helper") helper "c"+        liftIO $ createDirectoryRecursive "helper/tests"+        Stdout out <- cmd (Cwd "helper/tests") (Cwd "..") helper "c"         let norm = fmap dropTrailingPathSeparator . canonicalizePath . trim         liftIO $ join $ liftM2 (===) (norm out) (norm "helper")
src/Test/Docs.hs view
@@ -22,11 +22,13 @@     let index = "dist/doc/html/shake/index.html"     let config = "dist/setup-config"     want ["Success.txt"]+    let trackIgnore = trackAllow ["dist/**"]      let needSource = need =<< getDirectoryFiles "." (map (shakeRoot </>)             ["src/Development/Shake.hs","src/Development/Shake//*.hs","src/Development/Ninja/*.hs","src/General//*.hs"])      config %> \_ -> do+        trackIgnore         need $ map (shakeRoot </>) ["shake.cabal","Setup.hs"]         -- Make Cabal and Stack play nicely         path <- getEnv "GHC_PACKAGE_PATH"@@ -42,12 +44,11 @@         copyFile' (shakeRoot </> "src/Paths.hs") "dist/build/shake/autogen/Paths_shake.hs"         writeFile' "dist/build/autogen/cabal_macros.h" ""         writeFile' "dist/build/shake/autogen/cabal_macros.h" ""-        trackAllow ["dist/**"]      index %> \_ -> do         need $ config : map (shakeRoot </>) ["shake.cabal","Setup.hs","README.md","CHANGES.txt","docs/Manual.md","docs/shake-progress.png"]         needSource-        trackAllow ["dist/**"]+        trackIgnore         dist <- liftIO $ canonicalizePath "dist"         cmd (RemEnv "GHC_PACKAGE_PATH") (Cwd shakeRoot) "runhaskell Setup.hs haddock" ["--builddir=" ++ dist] @@ -162,7 +163,7 @@         putNormal . ("Checking documentation for:\n" ++) =<< readFile' "Files.lst"         needModules         need ["Main.hs"]-        trackAllow ["dist/**"]+        trackIgnore         needSource         cmd_ "ghc -fno-code -ignore-package=hashmap" ["-idist/build/autogen","-i" ++ shakeRoot </> "src","Main.hs"]         writeFile' out ""
− src/Test/Rattle.hs 
@@ -1,15 +0,0 @@--module Test.Rattle(main) where--import Development.Rattle-import System.FilePattern.Directory-import Development.Shake.FilePath-import Control.Monad-import Test.Type--main = testSimple $ rattle $ do-    cs <- liftIO $ getDirectoryFiles "." [shakeRoot </> "src/Test/C/*.c"]-    let toO x = takeBaseName x <.> "o"-    forM_ cs $ \c -> cmd ["gcc","-o",toO c,"-c",c]-    cmd $ ["gcc","-o","Main" <.> exe] ++ map toO cs-    cmd ["./Main" <.> exe]
src/Test/Type.hs view
@@ -106,7 +106,7 @@             opts <- return $ if forward then forwardOptions opts else opts                 {shakeLint = Just t                 ,shakeLintInside = [cwd </> ".." </> ".."]-                ,shakeLintIgnore = map (cwd </>) [".cabal-sandbox//",".stack-work//"]}+                ,shakeLintIgnore = [".cabal-sandbox/**",".stack-work/**","../../.stack-work/**"]}             withArgs args $ do                 let optionsBuiltin = optionsEnumDesc                         [(Clean, "Clean before building.")