diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,9 @@ Changelog for Shake (* = breaking change) +0.18.5, released 2020-02-02 + Use uninterruptibleMask_ to ensure all cleanup happens robustly + #742, make the Chrome profile only include the last run + #740, make CmdArgument an instance of IsCmdArgument 0.18.4, released 2019-12-15 #734, add Forward.cacheActionWith #734, make forward fail if shakeLintInside is empty diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Neil Mitchell 2011-2019. +Copyright Neil Mitchell 2011-2020. All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/shake.cabal b/shake.cabal --- a/shake.cabal +++ b/shake.cabal @@ -1,13 +1,13 @@ cabal-version: >= 1.18 build-type: Simple name: shake -version: 0.18.4 +version: 0.18.5 license: BSD3 license-file: LICENSE category: Development, Shake author: Neil Mitchell maintainer: Neil Mitchell -copyright: Neil Mitchell 2011-2019 +copyright: Neil Mitchell 2011-2020 synopsis: Build system library, like Make, but more accurate dependencies. description: Shake is a Haskell library for writing build systems - designed as a 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 @@ -625,7 +625,7 @@ type a :-> t = a --- | Execute a system command. Before running 'cmd' make sure you 'Development.Shake.need' any files +-- | Build or execute a system command. Before using 'cmd' to run a command, make sure you 'Development.Shake.need' any files -- that are used by the command. -- -- * @String@ arguments are treated as a list of whitespace separated arguments. @@ -634,6 +634,8 @@ -- -- * 'CmdOption' arguments are used as options. -- +-- * 'CmdArgument' arguments, which can be built by 'cmd' itself, are spliced into the containing command. +-- -- Typically only string literals should be passed as @String@ arguments. When using variables -- prefer @[myvar]@ so that if @myvar@ contains spaces they are properly escaped. -- @@ -655,6 +657,9 @@ -- ('Exit' c, 'Stderr' err) <- 'cmd' \"gcc -c myfile.c\" -- run a command, recording the exit code and error output -- 'Stdout' out <- 'cmd' \"gcc -MM myfile.c\" -- run a command, recording the output -- 'cmd' ('Cwd' \"generated\") \"gcc -c\" [myfile] :: 'Action' () -- run a command in a directory +-- +-- let gccCommand = 'cmd' \"gcc -c\" :: 'CmdArgument' -- build a sub-command. 'cmd' can return 'CmdArgument' values as well as execute commands +-- cmd ('Cwd' \"generated\") gccCommand [myfile] -- splice that command into a greater command -- @ -- -- If you use 'cmd' inside a @do@ block and do not use the result, you may get a compile-time error about being @@ -704,6 +709,7 @@ instance IsCmdArgument [String] where toCmdArgument = CmdArgument . map Right instance IsCmdArgument CmdOption where toCmdArgument = CmdArgument . return . Left instance IsCmdArgument [CmdOption] where toCmdArgument = CmdArgument . map Left +instance IsCmdArgument CmdArgument where toCmdArgument = id instance IsCmdArgument a => IsCmdArgument (Maybe a) where toCmdArgument = maybe mempty toCmdArgument diff --git a/src/Development/Shake/Internal/Demo.hs b/src/Development/Shake/Internal/Demo.hs --- a/src/Development/Shake/Internal/Demo.hs +++ b/src/Development/Shake/Internal/Demo.hs @@ -38,7 +38,7 @@ require shakeLib "% You don't have the 'shake' library installed with GHC, which is required to run the demo." require hasManual "% You don't have the Shake data files installed, which are required to run the demo." - empty <- not . any (not . all (== '.')) <$> getDirectoryContents "." + empty <- all (all (== '.')) <$> getDirectoryContents "." dir <- if empty then getCurrentDirectory else do home <- getHomeDirectory dir <- getDirectoryContents home diff --git a/src/Development/Shake/Internal/Profile.hs b/src/Development/Shake/Internal/Profile.hs --- a/src/Development/Shake/Internal/Profile.hs +++ b/src/Development/Shake/Internal/Profile.hs @@ -94,7 +94,6 @@ {prfCommand :: String, prfStart :: Double, prfStop :: Double} prfTime ProfileTrace{..} = prfStop - prfStart - -- | Generates an report given some build system profiling data. writeProfile :: FilePath -> Database -> IO () writeProfile out db = writeProfileInternal out =<< toReport db @@ -138,9 +137,10 @@ generateTrace :: [ProfileEntry] -> String generateTrace xs = jsonListLines $ - showEntries 0 [y{prfCommand=prfName x} | x <- xs, y <- prfTraces x] ++ - showEntries 1 (concatMap prfTraces xs) + showEntries 0 [y{prfCommand=prfName x} | x <- onlyLast, y <- prfTraces x] ++ + showEntries 1 (concatMap prfTraces onlyLast) where + onlyLast = filter (\x -> prfBuilt x == 0) xs showEntries pid xs = map (showEntry pid) $ snd $ mapAccumL alloc [] $ sortOn prfStart xs alloc :: [ProfileTrace] -> ProfileTrace -> ([ProfileTrace], (Int, ProfileTrace)) diff --git a/src/General/Chunks.hs b/src/General/Chunks.hs --- a/src/General/Chunks.hs +++ b/src/General/Chunks.hs @@ -62,7 +62,7 @@ -- Make sure all exceptions happen on the caller, so we don't have to move exceptions back -- Make sure we only write on one thread, otherwise async exceptions can cause partial writes usingWriteChunks cleanup Chunks{..} = do - h <- allocate cleanup (takeMVar chunksHandle) (putMVar chunksHandle) + h <- allocate cleanup (takeMVar chunksHandle) (putMVar chunksHandle) chan <- newChan -- operations to perform on the file kick <- newEmptyMVar -- kicked whenever something is written died <- newBarrier -- has the writing thread finished diff --git a/src/General/Cleanup.hs b/src/General/Cleanup.hs --- a/src/General/Cleanup.hs +++ b/src/General/Cleanup.hs @@ -33,7 +33,11 @@ newCleanup :: IO (Cleanup, IO ()) newCleanup = do ref <- newIORef $ S 0 Map.empty - let clean = mask_ $ do + -- important to use uninterruptibleMask_ otherwise in things like allocateThread + -- we might end up being interrupted and failing to close down the thread + -- e.g. see https://github.com/digital-asset/ghcide/issues/381 + -- note that packages like safe-exceptions also use uninterruptibleMask_ + let clean = uninterruptibleMask_ $ do items <- atomicModifyIORef' ref $ \s -> (s{items=Map.empty}, items s) mapM_ snd $ sortOn (negate . fst) $ Map.toList items return (Cleanup ref, clean) @@ -47,7 +51,7 @@ unprotect (ReleaseKey ref i) = atomicModifyIORef' ref $ \s -> (s{items = Map.delete i $ items s}, ()) release :: ReleaseKey -> IO () -release (ReleaseKey ref i) = mask_ $ do +release (ReleaseKey ref i) = uninterruptibleMask_ $ do undo <- atomicModifyIORef' ref $ \s -> (s{items = Map.delete i $ items s}, Map.lookup i $ items s) fromMaybe (return ()) undo diff --git a/src/Test/Cleanup.hs b/src/Test/Cleanup.hs --- a/src/Test/Cleanup.hs +++ b/src/Test/Cleanup.hs @@ -39,7 +39,7 @@ do -- cleanup actions are masked https://github.com/snoyberg/conduit/issues/144 let checkMasked name = do ms <- getMaskingState - unless (ms == MaskedInterruptible) $ + unless (ms == MaskedUninterruptible) $ error $ show (name, ms) withCleanup $ \cleanup -> do register cleanup (checkMasked "release") >>= release diff --git a/src/Test/Command.hs b/src/Test/Command.hs --- a/src/Test/Command.hs +++ b/src/Test/Command.hs @@ -71,8 +71,8 @@ "failure" !> do (Exit e, Stdout (), Stderr ()) <- cmd helper "oo ee x" when (e == ExitSuccess) $ error "/= ExitSuccess" - liftIO $ assertException ["BAD"] $ cmd helper "oo eBAD x" (EchoStdout False) (EchoStderr False) - liftIO $ assertException ["MORE"] $ cmd helper "oMORE eBAD x" (WithStdout True) (WithStderr False) (EchoStdout False) (EchoStderr False) + liftIO $ assertException ["BAD"] $ cmd_ helper "oo eBAD x" (EchoStdout False) (EchoStderr False) + liftIO $ assertException ["MORE"] $ cmd_ helper "oMORE eBAD x" (WithStdout True) (WithStderr False) (EchoStdout False) (EchoStderr False) "throws" ~> cmd Shell "not_a_process foo" diff --git a/src/Test/Database.hs b/src/Test/Database.hs --- a/src/Test/Database.hs +++ b/src/Test/Database.hs @@ -5,6 +5,7 @@ import Control.Exception.Extra import Control.Monad import Data.List +import Data.IORef import Development.Shake import Development.Shake.Database import Development.Shake.FilePath @@ -64,12 +65,38 @@ assertBool ("currently running" `isInfixOf` results) "Contains 'currently using'" close - assertException ["already closed"] $ void $ shakeRunDatabase db [] + assertException ["already closed"] $ shakeRunDatabase db [] shakeRunAfter opts after assertBoolIO (not <$> IO.doesFileExist "log.txt") "Log must be deleted" errs <- shakeWithDatabase opts{shakeStaunch=True, shakeVerbosity=Silent} rules $ \db -> do - assertException ["Error when running"] $ void $ shakeRunDatabase db [need ["foo.err","bar.err"]] + assertException ["Error when running"] $ shakeRunDatabase db [need ["foo.err","bar.err"]] shakeErrorsDatabase db sort (map fst errs) === ["bar.err","foo.err"] + + -- check the progress thread gets killed properly on normal cleanup + ref <- newIORef 0 + opts <- return opts{shakeProgress = const $ bracket_ (modifyIORef ref succ) (modifyIORef ref succ) $ sleep 100} + (open, close) <- shakeOpenDatabase opts rules + db <- open + ([12], after) <- shakeRunDatabase db [need ["a.out"] >> liftIO (modifyIORef ref succ) >> return 12] + (=== 3) =<< readIORef ref -- success if it all shuts down cleanly + + -- and on an exception + writeIORef ref 0 + assertException ["terminate"] $ shakeRunDatabase db [liftIO (modifyIORef ref succ) >> fail "terminate"] + (=== 3) =<< readIORef ref + + -- and on an external exception + writeIORef ref 0 + bar <- newBarrier; bar2 <- newBarrier + t <- flip forkFinally (signalBarrier bar2) $ void $ shakeRunDatabase db $ return $ do + liftIO $ modifyIORef ref succ + liftIO $ signalBarrier bar () + need ["sleep"] + waitBarrier bar + sleep 0.1 + killThread t + waitBarrier bar2 + (=== 3) =<< readIORef ref diff --git a/src/Test/Docs.hs b/src/Test/Docs.hs --- a/src/Test/Docs.hs +++ b/src/Test/Docs.hs @@ -99,6 +99,7 @@ ,"import Data.Maybe" ,"import Data.Monoid" ,"import Development.Shake hiding ((*>))" + ,"import Development.Shake.Command" ,"import Development.Shake.Classes" ,"import Development.Shake.Database" ,"import Development.Shake.Rule" diff --git a/src/Test/Progress.hs b/src/Test/Progress.hs --- a/src/Test/Progress.hs +++ b/src/Test/Progress.hs @@ -46,7 +46,7 @@ xs <- progEx 2 $ 100:map (*2) [10,9..1] drop 5 xs === [6,5..1] xs <- progEx 1 [10,9,100,8,7,6,5,4,3,2,1] - assertBool (all (<= 1.5) $ map abs $ zipWith (-) (drop 5 xs) [6,5..1]) "Close" + assertBool (all ((<= 1.5) . abs) $ zipWith (-) (drop 5 xs) [6,5..1]) "Close" -- if no progress is made, don't keep the time going up xs <- prog [10,9,8,7,7,7,7,7] diff --git a/src/Test/Resources.hs b/src/Test/Resources.hs --- a/src/Test/Resources.hs +++ b/src/Test/Resources.hs @@ -74,5 +74,5 @@ (s, _) <- duration $ build [flags,"throttle","--no-report","--clean"] -- the 0.1s cap is a guess at an upper bound for how long everything else should take -- and should be raised on slower machines - assertBool (s >= 1.4 && s < 1.6) $ - "Bad throttling, expected to take 1.4s + computation time (cap of 0.2s), took " ++ show s ++ "s" + assertBool (s >= 1.4 && s < 1.8) $ + "Bad throttling, expected to take 1.4s + computation time (cap of 0.4s), took " ++ show s ++ "s" diff --git a/src/Test/Type.hs b/src/Test/Type.hs --- a/src/Test/Type.hs +++ b/src/Test/Type.hs @@ -210,7 +210,7 @@ assertContentsUnordered :: FilePath -> [String] -> IO () assertContentsUnordered file xs = assertContentsOn (unlines . sort . lines) file (unlines xs) -assertExceptionAfter :: (String -> String) -> [String] -> IO () -> IO () +assertExceptionAfter :: (String -> String) -> [String] -> IO a -> IO () assertExceptionAfter tweak parts act = do res <- try_ act case res of @@ -218,7 +218,7 @@ assertBool (p `isInfixOf` s) $ "Incorrect exception, missing part:\nGOT: " ++ s ++ "\nWANTED: " ++ p Right _ -> error $ "Expected an exception containing " ++ show parts ++ ", but succeeded" -assertException :: [String] -> IO () -> IO () +assertException :: [String] -> IO a -> IO () assertException = assertExceptionAfter id defaultTest :: ([String] -> IO ()) -> IO ()