packages feed

shake 0.15.2 → 0.15.3

raw patch · 12 files changed

+119/−82 lines, 12 filesdep ~extradep ~process

Dependency ranges changed: extra, process

Files

CHANGES.txt view
@@ -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
shake.cabal view
@@ -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)
src/Development/Shake/Core.hs view
@@ -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
src/Development/Shake/Errors.hs view
@@ -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
src/Development/Shake/Resource.hs view
@@ -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.     }
src/Development/Shake/Storage.hs view
@@ -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
src/General/Extra.hs view
@@ -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
src/Run.hs view
@@ -14,7 +14,6 @@ import System.Console.GetOpt import System.Process import System.Exit-import General.Extra   main :: IO ()
src/Test/Basic.hs view
@@ -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
src/Test/Docs.hs view
@@ -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] ++
src/Test/Errors.hs view
@@ -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
src/Test/Type.hs view
@@ -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"