diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -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 diff --git a/shake.cabal b/shake.cabal --- a/shake.cabal +++ b/shake.cabal @@ -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 diff --git a/src/Development/Rattle.hs b/src/Development/Rattle.hs deleted file mode 100644 --- a/src/Development/Rattle.hs +++ /dev/null @@ -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 diff --git a/src/Development/Shake/Command.hs b/src/Development/Shake/Command.hs --- a/src/Development/Shake/Command.hs +++ b/src/Development/Shake/Command.hs @@ -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)]) diff --git a/src/Development/Shake/Internal/Args.hs b/src/Development/Shake/Internal/Args.hs --- a/src/Development/Shake/Internal/Args.hs +++ b/src/Development/Shake/Internal/Args.hs @@ -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) diff --git a/src/Development/Shake/Internal/CmdOption.hs b/src/Development/Shake/Internal/CmdOption.hs --- a/src/Development/Shake/Internal/CmdOption.hs +++ b/src/Development/Shake/Internal/CmdOption.hs @@ -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. diff --git a/src/Development/Shake/Internal/Core/Action.hs b/src/Development/Shake/Internal/Core/Action.hs --- a/src/Development/Shake/Internal/Core/Action.hs +++ b/src/Development/Shake/Internal/Core/Action.hs @@ -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 diff --git a/src/Development/Shake/Internal/Core/Types.hs b/src/Development/Shake/Internal/Core/Types.hs --- a/src/Development/Shake/Internal/Core/Types.hs +++ b/src/Development/Shake/Internal/Core/Types.hs @@ -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 } diff --git a/src/Development/Shake/Internal/History/Shared.hs b/src/Development/Shake/Internal/History/Shared.hs --- a/src/Development/Shake/Internal/History/Shared.hs +++ b/src/Development/Shake/Internal/History/Shared.hs @@ -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 diff --git a/src/Development/Shake/Internal/Rules/File.hs b/src/Development/Shake/Internal/Rules/File.hs --- a/src/Development/Shake/Internal/Rules/File.hs +++ b/src/Development/Shake/Internal/Rules/File.hs @@ -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 diff --git a/src/General/Chunks.hs b/src/General/Chunks.hs --- a/src/General/Chunks.hs +++ b/src/General/Chunks.hs @@ -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 diff --git a/src/General/Extra.hs b/src/General/Extra.hs --- a/src/General/Extra.hs +++ b/src/General/Extra.hs @@ -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 diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -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 diff --git a/src/Test/Command.hs b/src/Test/Command.hs --- a/src/Test/Command.hs +++ b/src/Test/Command.hs @@ -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") diff --git a/src/Test/Docs.hs b/src/Test/Docs.hs --- a/src/Test/Docs.hs +++ b/src/Test/Docs.hs @@ -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 "" diff --git a/src/Test/Rattle.hs b/src/Test/Rattle.hs deleted file mode 100644 --- a/src/Test/Rattle.hs +++ /dev/null @@ -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] diff --git a/src/Test/Type.hs b/src/Test/Type.hs --- a/src/Test/Type.hs +++ b/src/Test/Type.hs @@ -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.")