diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,10 @@ Changelog for Shake +0.15.3 + #254, in staunch mode, print out all exceptions + Require extra-1.3 + #259, discount time waiting for a resource in profiles + #252, have the docs test configure not in dist 0.15.2 #248, add another example of using cmd #245, initial support for fsatrace lint checking diff --git a/shake.cabal b/shake.cabal --- a/shake.cabal +++ b/shake.cabal @@ -1,7 +1,7 @@ cabal-version: >= 1.10 build-type: Simple name: shake -version: 0.15.2 +version: 0.15.3 license: BSD3 license-file: LICENSE category: Development, Shake @@ -100,7 +100,7 @@ js-jquery, js-flot, transformers >= 0.2, - extra >= 1.1, + extra >= 1.3, deepseq >= 1.1 if flag(portable) @@ -188,7 +188,7 @@ js-jquery, js-flot, transformers >= 0.2, - extra >= 0.7, + extra >= 1.3, deepseq >= 1.1 if flag(portable) @@ -231,7 +231,7 @@ js-flot, transformers >= 0.2, deepseq >= 1.1, - extra >= 0.7, + extra >= 1.3, QuickCheck >= 2.0 if flag(portable) diff --git a/src/Development/Shake/Core.hs b/src/Development/Shake/Core.hs --- a/src/Development/Shake/Core.hs +++ b/src/Development/Shake/Core.hs @@ -172,10 +172,10 @@ data ARule m = forall key value . Rule key value => ARule (key -> Maybe (m value)) -ruleKey :: Rule key value => (key -> Maybe (m value)) -> key +ruleKey :: (key -> Maybe (m value)) -> key ruleKey = err "ruleKey" -ruleValue :: Rule key value => (key -> Maybe (m value)) -> value +ruleValue :: (key -> Maybe (m value)) -> value ruleValue = err "ruleValue" @@ -404,17 +404,13 @@ let diagnostic = if shakeVerbosity >= Diagnostic then outputLocked Diagnostic . ("% "++) else const $ return () let output v = outputLocked v . abbreviate shakeAbbreviations - except <- newIORef (Nothing :: Maybe (String, SomeException)) - let staunch act | not shakeStaunch = void act - | otherwise = do - res <- try act - case res of - Left err -> do - let named = maybe "" (abbreviate shakeAbbreviations . shakeExceptionTarget) . fromException - atomicModifyIORef except $ \v -> (Just $ fromMaybe (named err, err) v, ()) - let msg = show err ++ "Continuing due to staunch mode, this error will be repeated later" - when (shakeVerbosity >= Quiet) $ output Quiet msg - Right _ -> return () + except <- newIORef (Nothing :: Maybe (String, ShakeException)) + let raiseError err + | not shakeStaunch = throwIO err + | otherwise = do + let named = abbreviate shakeAbbreviations . shakeExceptionTarget + atomicModifyIORef except $ \v -> (Just $ fromMaybe (named err, err) v, ()) + -- no need to print exceptions here, they get printed when they are wrapped lint <- if isNothing shakeLint then return $ const $ return () else do dir <- getCurrentDirectory @@ -451,7 +447,10 @@ let s0 = Global database pool cleanup start ruleinfo output opts diagnostic lint after absent let s1 = Local emptyStack shakeVerbosity Nothing [] 0 [] [] [] forM_ (actions rs) $ \act -> do - addPool pool $ runAction s0 s1 act $ \x -> staunch $ either throwIO return x + addPool pool $ runAction s0 s1 act $ \x -> case x of + Left e -> raiseError =<< shakeException s0 (return ["Top-level action/want"]) e + Right x -> return x + maybe (return ()) (throwIO . snd) =<< readIORef except when (null $ actions rs) $ do when (shakeVerbosity >= Normal) $ output Normal "Warning: No want/action statements, nothing to do" @@ -476,7 +475,6 @@ when (shakeVerbosity >= Normal) $ output Normal $ "Writing live list to " ++ file (if file == "-" then putStr else writeFile file) $ unlines liveFiles - maybe (return ()) (throwIO . snd) =<< readIORef except sequence_ . reverse =<< readIORef after @@ -496,15 +494,6 @@ f (x:xs) = x : f xs -wrapStack :: IO [String] -> IO a -> IO a -wrapStack stk act = catch_ act $ \(SomeException e) -> case cast e of - Just s@ShakeException{} -> throwIO s - Nothing -> do - stk <- stk - if null stk then throwIO e - else throwIO $ ShakeException (last stk) stk $ SomeException e - - runAction :: Global -> Local -> Action a -> Capture (Either SomeException a) runAction g l (Action x) k = runRAW g l x k @@ -552,7 +541,7 @@ when (shakeLint globalOptions == Just LintTracker) trackCheckUsed Action $ fmap ((,) res) getRW) $ \x -> case x of - Left e -> (continue =<<) $ try $ wrapStack (showStack globalDatabase stack) $ throwIO e + Left e -> continue . Left . toException =<< shakeException global (showStack globalDatabase stack) e Right (res, Local{..}) -> do dur <- time globalLint $ "after building " ++ top @@ -565,6 +554,20 @@ return vs +-- | Turn a normal exception into a ShakeException, giving it a stack and printing it out if in staunch mode. +-- If the exception is already a ShakeException (e.g. it's a child of ours who failed and we are rethrowing) +-- then do nothing with it. +shakeException :: Global -> IO [String] -> SomeException -> IO ShakeException +shakeException Global{globalOptions=ShakeOptions{..},..} stk e@(SomeException inner) = case cast inner of + Just e@ShakeException{} -> return e + Nothing -> do + stk <- stk + e <- return $ ShakeException (last $ "Unknown call stack" : stk) stk e + when (shakeStaunch && shakeVerbosity >= Quiet) $ + globalOutput Quiet $ show e ++ "Continuing due to staunch mode" + return e + + -- | Apply a single rule, equivalent to calling 'apply' with a singleton list. Where possible, -- use 'apply' to allow parallelism. apply1 :: Rule key value => key -> Action value @@ -815,10 +818,13 @@ withResource r i act = do Global{..} <- Action getRO liftIO $ globalDiagnostic $ show r ++ " waiting to acquire " ++ show i - Action $ captureRAW $ \continue -> acquireResource r globalPool i $ do - globalDiagnostic $ show r ++ " acquired " ++ show i - continue $ Right () - res <- Action $ tryRAW $ fromAction $ blockApply ("Within withResource using " ++ show r) act + offset <- liftIO $ offsetTime + Action $ captureRAW $ \continue -> acquireResource r globalPool i $ continue $ Right () + res <- Action $ tryRAW $ fromAction $ blockApply ("Within withResource using " ++ show r) $ do + offset <- liftIO offset + liftIO $ globalDiagnostic $ show r ++ " acquired " ++ show i ++ " in " ++ showDuration offset + Action $ modifyRW $ \s -> s{localDiscount = localDiscount s + offset} + act liftIO $ releaseResource r globalPool i liftIO $ globalDiagnostic $ show r ++ " released " ++ show i Action $ either throwRAW return res diff --git a/src/Development/Shake/Errors.hs b/src/Development/Shake/Errors.hs --- a/src/Development/Shake/Errors.hs +++ b/src/Development/Shake/Errors.hs @@ -9,10 +9,9 @@ ) where import Data.Tuple.Extra -import Control.Exception +import Control.Exception.Extra import Data.Typeable import Data.List -import General.Extra err :: String -> a diff --git a/src/Development/Shake/Resource.hs b/src/Development/Shake/Resource.hs --- a/src/Development/Shake/Resource.hs +++ b/src/Development/Shake/Resource.hs @@ -46,8 +46,7 @@ ,resourceShow :: String -- ^ String used for Show ,acquireResource :: Pool -> Int -> IO () -> IO () - -- ^ Acquire the resource and call the function. Passes 'False' to indicate you have acquired with no blocking, - -- or 'True' to say there was waiting and you must not do significant computation on that thread. + -- ^ Acquire the resource and call the function. ,releaseResource :: Pool -> Int -> IO () -- ^ You should only ever releaseResource that you obtained with acquireResource. } diff --git a/src/Development/Shake/Storage.hs b/src/Development/Shake/Storage.hs --- a/src/Development/Shake/Storage.hs +++ b/src/Development/Shake/Storage.hs @@ -54,7 +54,7 @@ withStorage - :: (Show w, Show k, Show v, Eq w, Eq k, Hashable k + :: (Show k, Show v, Eq w, Eq k, Hashable k ,Binary w, BinaryWith w k, BinaryWith w v) => ShakeOptions -- ^ Storage options -> (String -> IO ()) -- ^ Logging function diff --git a/src/General/Extra.hs b/src/General/Extra.hs --- a/src/General/Extra.hs +++ b/src/General/Extra.hs @@ -5,7 +5,6 @@ randomElem, showQuote, withs, - errorIO, ) where import Control.Exception.Extra @@ -20,9 +19,6 @@ import Foreign.C.Types #endif - -errorIO :: String -> IO a -errorIO = throwIO . ErrorCall --------------------------------------------------------------------- -- Data.List diff --git a/src/Run.hs b/src/Run.hs --- a/src/Run.hs +++ b/src/Run.hs @@ -14,7 +14,6 @@ import System.Console.GetOpt import System.Process import System.Exit -import General.Extra main :: IO () diff --git a/src/Test/Basic.hs b/src/Test/Basic.hs --- a/src/Test/Basic.hs +++ b/src/Test/Basic.hs @@ -53,6 +53,10 @@ need ["dummy"] liftIO $ appendFile out "1" + r <- newResource "sleepresource" 1 + phony "sleep1" $ withResource r 1 $ cmd Shell "sleep 1" + phony "sleep2" $ withResource r 1 $ cmd Shell "sleep 1" + r <- newResource ".log file" 1 let trace x = withResource r 1 $ liftIO $ appendFile (obj ".log") x obj "*.par" %> \out -> do diff --git a/src/Test/Docs.hs b/src/Test/Docs.hs --- a/src/Test/Docs.hs +++ b/src/Test/Docs.hs @@ -5,32 +5,31 @@ import Development.Shake import Development.Shake.FilePath import Test.Type -import Control.Monad import Data.Char import Data.List.Extra import Data.Maybe -import System.Directory -import System.Exit main = shaken noTest $ \args obj -> do - let index = "dist/doc/html/shake/index.html" + let index = obj "dist/doc/html/shake/index.html" + let config = obj "dist/setup-config" want [obj "Success.txt"] want $ map (\x -> fromMaybe (obj x) $ stripPrefix "!" x) args let needSource = need =<< getDirectoryFiles "." ["src/Development/Shake.hs","src/Development/Shake//*.hs","src/Development/Ninja/*.hs","src/General//*.hs"] + config %> \_ -> do + need ["shake.cabal"] + unit $ cmd "runhaskell Setup.hs configure" ["--builddir=" ++ obj "dist","--user"] + trackAllow [obj "dist//*"] + index %> \_ -> do + need [config,"shake.cabal"] needSource need ["shake.cabal"] - trackAllow ["dist//*"] - res <- liftIO $ findExecutable "cabal" - if isJust res then cmd "cabal haddock" else do - Exit exit <- cmd "runhaskell Setup.hs haddock" - when (exit /= ExitSuccess) $ do - () <- cmd "runhaskell Setup.hs configure" - cmd "runhaskell Setup.hs haddock" + trackAllow [obj "dist//*"] + cmd "runhaskell Setup.hs haddock" ["--builddir=" ++ obj "dist"] obj "Paths_shake.hs" %> \out -> do copyFile' "src/Paths.hs" out @@ -41,7 +40,7 @@ src <- if "_md" `isSuffixOf` takeBaseName out then fmap (findCodeMarkdown . lines . noR) $ readFile' $ "docs/" ++ drop 5 (reverse (drop 3 $ reverse $ takeBaseName out)) ++ ".md" else - fmap (findCodeHaddock . noR) $ readFile' $ "dist/doc/html/shake/" ++ replace "_" "-" (drop 5 $ takeBaseName out) ++ ".html" + fmap (findCodeHaddock . noR) $ readFile' $ obj $ "dist/doc/html/shake/" ++ replace "_" "-" (drop 5 $ takeBaseName out) ++ ".html" let f i (Stmt x) | any whitelist x = [] | otherwise = restmt i $ map undefDots $ trims x f i (Expr x) | takeWhile (not . isSpace) x `elem` types = ["type Expr_" ++ show i ++ " = " ++ x] @@ -104,7 +103,7 @@ obj "Files.lst" %> \out -> do need ["src/Test/Docs.hs"] -- so much of the generator is in this module need [index,obj "Paths_shake.hs"] - filesHs <- getDirectoryFiles "dist/doc/html/shake" ["Development-*.html"] + filesHs <- getDirectoryFiles (obj "dist/doc/html/shake") ["Development-*.html"] filesMd <- getDirectoryFiles "docs" ["*.md"] writeFileChanged out $ unlines $ ["Part_" ++ replace "-" "_" (takeBaseName x) | x <- filesHs, not $ "-Classes.html" `isSuffixOf` x] ++ diff --git a/src/Test/Errors.hs b/src/Test/Errors.hs --- a/src/Test/Errors.hs +++ b/src/Test/Errors.hs @@ -4,6 +4,7 @@ import Development.Shake import Development.Shake.FilePath import Test.Type +import Data.List import Control.Monad import Control.Concurrent import Control.Exception.Extra hiding (assert) @@ -11,9 +12,7 @@ import qualified System.IO.Extra as IO -main = shaken test $ \args obj -> do - want $ map obj args - +main = shaken2 test $ \args obj -> do obj "norule" %> \_ -> need [obj "norule_isavailable"] @@ -85,60 +84,75 @@ return file liftIO $ assertMissing file + phony "fail1" $ fail "die1" + phony "fail2" $ fail "die2" + when ("die" `elem` args) $ action $ error "death error" + + test build obj = do let crash args parts = assertException parts (build $ "--quiet" : args) build ["clean"] build ["--sleep"] writeFile (obj "chain.1") "x" - build ["chain.3","--sleep"] + build ["$chain.3","--sleep"] writeFile (obj "chain.1") "err" - crash ["chain.3"] ["err_chain"] + crash ["$chain.3"] ["err_chain"] - crash ["norule"] ["norule_isavailable"] - crash ["failcreate"] ["failcreate"] - crash ["failcreates"] ["failcreates"] - crash ["recursive"] ["recursive"] - crash ["systemcmd"] ["systemcmd","random_missing_command"] - crash ["stack1"] ["stack1","stack2","stack3","crash"] + crash ["$norule"] ["norule_isavailable"] + crash ["$failcreate"] ["failcreate"] + crash ["$failcreates"] ["failcreates"] + crash ["$recursive"] ["recursive"] + crash ["$systemcmd"] ["systemcmd","random_missing_command"] + crash ["$stack1"] ["stack1","stack2","stack3","crash"] b <- IO.doesFileExist $ obj "staunch1" when b $ removeFile $ obj "staunch1" - crash ["staunch1","staunch2","-j2"] ["crash"] + crash ["$staunch1","$staunch2","-j2"] ["crash"] b <- IO.doesFileExist $ obj "staunch1" assert (not b) "File should not exist, should have crashed first" - crash ["staunch1","staunch2","-j2","--keep-going","--silent"] ["crash"] + crash ["$staunch1","$staunch2","-j2","--keep-going","--silent"] ["crash"] b <- IO.doesFileExist $ obj "staunch1" assert b "File should exist, staunch should have let it be created" - crash ["finally1"] ["die"] + crash ["$finally1"] ["die"] assertContents (obj "finally1") "1" - build ["finally2"] + build ["$finally2"] assertContents (obj "finally2") "1" - crash ["exception1"] ["die"] + crash ["$exception1"] ["die"] assertContents (obj "exception1") "1" - build ["exception2"] + build ["$exception2"] assertContents (obj "exception2") "0" forM_ ["finally3","finally4"] $ \name -> do - t <- forkIO $ ignore $ build [name,"--exception"] + t <- forkIO $ ignore $ build ['$':name,"--exception"] retry 10 $ sleep 0.1 >> assertContents (obj name) "0" throwTo t (IndexOutOfBounds "test") retry 10 $ sleep 0.1 >> assertContents (obj name) "1" - crash ["resource"] ["cannot currently call apply","withResource","resource_name"] + crash ["$resource"] ["cannot currently call apply","withResource","resource_name"] - build ["overlap.foo"] + build ["$overlap.foo"] assertContents (obj "overlap.foo") "overlap.*" - build ["overlap.txt"] + build ["$overlap.txt"] assertContents (obj "overlap.txt") "overlap.txt" - crash ["overlap.txx"] ["key matches multiple rules","overlap.txx"] - build ["alternative.foo","alternative.txt"] + crash ["$overlap.txx"] ["key matches multiple rules","overlap.txx"] + build ["$alternative.foo","$alternative.txt"] assertContents (obj "alternative.foo") "alternative.*" assertContents (obj "alternative.txt") "alternative.txt" - crash ["tempfile"] ["tempfile-died"] + crash ["$tempfile"] ["tempfile-died"] src <- readFile $ obj "tempfile" assertMissing src - build ["tempdir"] + build ["$tempdir"] + + crash ["!die"] ["Shake","action","death error"] + + putStrLn "## BUILD errors" + (out,_) <- IO.captureOutput $ build [] + assert ("nothing to do" `isInfixOf` out) $ "Expected 'nothing to do', but got: " ++ out + + putStrLn "## BUILD errors fail1 fail2 -k -j2" + (out,_) <- IO.captureOutput $ try_ $ build ["fail1","fail2","-k","-j2",""] + assert ("die1" `isInfixOf` out && "die2" `isInfixOf` out) $ "Expected 'die1' and 'die2', but got: " ++ out diff --git a/src/Test/Type.hs b/src/Test/Type.hs --- a/src/Test/Type.hs +++ b/src/Test/Type.hs @@ -71,7 +71,23 @@ ,shakeReport = ["output/" ++ name ++ "/report.html"] ,shakeLint = Just $ if tracker then LintTracker else LintBasic }) - (rules files obj) + -- if you have passed sleep, supress the "no errors" warning + (do rules files obj; when ("--sleep" `elem` args) $ action $ return ()) + + +shaken2 + :: (([String] -> IO ()) -> (String -> String) -> IO ()) + -> ([String] -> (String -> String) -> Rules ()) + -> IO () + -> IO () +shaken2 test rules sleeper = shaken test rules2 sleeper + where + rules2 args obj = do + (objd,args) <- return $ partition ("$" `isPrefixOf`) args + (spec,phon) <- return $ partition ("!" `isPrefixOf`) args + want $ phon ++ map (obj . tail) objd + rules (map tail spec) obj + hasTracker :: IO Bool hasTracker = isJust <$> if isWindows then findExecutable "tracker.exe" else lookupEnv "FSAT"