diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,9 @@ Changelog for Shake +0.16.4, released 2018-04-04 + #185, add addOracleCache which doesn't always rerun + #576, remove incorrect Cabal description + #575, print --help message at Quiet verbosity or above 0.16.3, released 2018-02-23 Allow reading data files from next to the executable #566, require extra-1.6.1 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,19 +1,19 @@ # Shake [![Hackage version](https://img.shields.io/hackage/v/shake.svg?label=Hackage)](https://hackage.haskell.org/package/shake) [![Stackage version](https://www.stackage.org/package/shake/badge/lts?label=Stackage)](https://www.stackage.org/package/shake) [![Linux Build Status](https://img.shields.io/travis/ndmitchell/shake.svg?label=Linux%20build)](https://travis-ci.org/ndmitchell/shake) [![Windows Build Status](https://img.shields.io/appveyor/ci/ndmitchell/shake.svg?label=Windows%20build)](https://ci.appveyor.com/project/ndmitchell/shake) -Shake is a tool for writing build systems - an alternative to make, Scons, Ant etc. Shake has been used commercially for over five years, running thousands of builds per day. The website for Shake users is at [shakebuild.com](http://shakebuild.com). +Shake is a tool for writing build systems - an alternative to make, Scons, Ant etc. Shake has been used commercially for over five years, running thousands of builds per day. The website for Shake users is at [shakebuild.com](https://shakebuild.com). #### Documentation -* **Why use Shake?** Shake lets you write large robust build systems, which deal properly with generated source files and run quickly. If you are writing a custom build system of any moderate size (more than a few rules) you should use Shake. The advantages over other build systems are detailed in the document [Why choose Shake?](http://shakebuild.com/why). -* **How do I use Shake?** Shake is a Haskell library that you use to define your rules. The [Shake manual](http://shakebuild.com/manual) provides a walk through of a small but realistic example, assuming no Haskell knowledge. -* [Generated documentation](http://hackage.haskell.org/packages/archive/shake/latest/doc/html/Development-Shake.html) for all functions, includes lots of examples. -* [Blog posts](http://neilmitchell.blogspot.co.uk/search/label/shake) detailing ongoing development work. -* [Academic paper](http://ndmitchell.com/downloads/paper-shake_before_building-10_sep_2012.pdf) on the underlying principles behind Shake. +* **Why use Shake?** Shake lets you write large robust build systems, which deal properly with generated source files and run quickly. If you are writing a custom build system of any moderate size (more than a few rules) you should use Shake. The advantages over other build systems are detailed in the document [Why choose Shake?](https://shakebuild.com/why). +* **How do I use Shake?** Shake is a Haskell library that you use to define your rules. The [Shake manual](https://shakebuild.com/manual) provides a walk through of a small but realistic example, assuming no Haskell knowledge. +* [Generated documentation](https://hackage.haskell.org/packages/archive/shake/latest/doc/html/Development-Shake.html) for all functions, includes lots of examples. +* [Blog posts](https://neilmitchell.blogspot.co.uk/search/label/shake) detailing ongoing development work. +* [Academic paper](https://ndmitchell.com/downloads/paper-shake_before_building-10_sep_2012.pdf) on the underlying principles behind Shake. #### Other links -* [Download the Haskell package](http://hackage.haskell.org/package/shake) from Hackage and install it using Cabal. +* [Download the Haskell package](https://hackage.haskell.org/package/shake) from Hackage and install it using Cabal. * [Mailing list](https://groups.google.com/forum/?fromgroups#!forum/shake-build-system) for any questions/bugs/thoughts on Shake. If you need more information and aren't sure where to start, use the mailing list. -* [Questions](http://stackoverflow.com/questions/tagged/shake-build-system) can be asked on StackOverflow with the tag `shake-build-system`. +* [Questions](https://stackoverflow.com/questions/tagged/shake-build-system) can be asked on StackOverflow with the tag `shake-build-system`. -Is your company using Shake? Write something public (even just a [tweet to `@ndm_haskell`](https://twitter.com/ndm_haskell)) and I'll include a link [on the website](http://shakebuild.com/#who-uses-shake). +Is your company using Shake? Write something public (even just a [tweet to `@ndm_haskell`](https://twitter.com/ndm_haskell)) and I'll include a link [on the website](https://shakebuild.com/#who-uses-shake). diff --git a/docs/Manual.md b/docs/Manual.md --- a/docs/Manual.md +++ b/docs/Manual.md @@ -35,9 +35,9 @@ To run the example above: -1. Install the [Haskell Stack](http://haskellstack.org/), which provides a Haskell compiler and package manager. -3. Type `stack install shake`, to build and install Shake and all its dependencies. -4. Type `stack exec -- shake --demo`, which will create a directory containing a sample project, the above Shake script (named `Build.hs`), and execute it (which can be done by `runhaskell Build.hs`). For more details see a [trace of `shake --demo`](Demo.md). +1. Install the [Haskell Stack](https://haskellstack.org/), which provides a Haskell compiler and package manager. +2. Type `stack install shake`, to build and install Shake and all its dependencies. +3. Type `stack exec -- shake --demo`, which will create a directory containing a sample project, the above Shake script (named `Build.hs`), and execute it (which can be done by `runhaskell Build.hs`). For more details see a [trace of `shake --demo`](Demo.md). ## Basic syntax @@ -284,7 +284,7 @@ mkdir -p _shake ghc --make Build.hs -rtsopts -threaded -with-rtsopts=-I0 -outputdir=_shake -o _shake/build && _shake/build "$@" -This script creates a folder named `_shake` for the build system objects to live in, then runs `ghc --make Build.hs` to produce `_shake/build`, then executes `_shake/build` with all arguments it was given. The `-with-rtsopts` flag instructs the Haskell compiler to disable "idle garbage collection", making more CPU available for the commands you are running, as [explained here](http://stackoverflow.com/questions/34588057/why-does-shake-recommend-disabling-idle-garbage-collection/). +This script creates a folder named `_shake` for the build system objects to live in, then runs `ghc --make Build.hs` to produce `_shake/build`, then executes `_shake/build` with all arguments it was given. The `-with-rtsopts` flag instructs the Haskell compiler to disable "idle garbage collection", making more CPU available for the commands you are running, as [explained here](https://stackoverflow.com/questions/34588057/why-does-shake-recommend-disabling-idle-garbage-collection/). Now you can run a build by simply typing `stack exec ./build.sh` on Linux, or `stack exec build.bat` on Windows. On Linux you may want to alias `build` to `stack exec ./build.sh`. For the rest of this document we will assume `build` runs the build system. @@ -420,7 +420,7 @@ _Depend on the build source:_ One approach is to depend on the build system source in each of the rules, then if _any_ rules change, _everything_ will rebuild. While this option is safe, it may cause a significant number of redundant rebuilds. As a restricted version of this technique, for a generated file you can include a dependency on the generator source and use `writeFileChanged`. If the generator changes it will rerun, but typically only a few generated files will change, so little is rebuilt. -_Use a version stamp:_ There is a field named `shakeVersion` in the `ShakeOptions` record. If the build system changes in a significant and incompatible way, you can change this field to force a full rebuild. If you want all rules to depend on all rules, you can put a hash of the build system source in the version field, as [described here](http://stackoverflow.com/questions/18532552/shake-how-to-reliably-automatically-force-rebuild-when-my-rules-change-becomi/18532553#18532553). +_Use a version stamp:_ There is a field named `shakeVersion` in the `ShakeOptions` record. If the build system changes in a significant and incompatible way, you can change this field to force a full rebuild. If you want all rules to depend on all rules, you can put a hash of the build system source in the version field, as [described here](https://stackoverflow.com/questions/18532552/shake-how-to-reliably-automatically-force-rebuild-when-my-rules-change-becomi/18532553#18532553). ## The Haskell Zone diff --git a/html/shake.js b/html/shake.js --- a/html/shake.js +++ b/html/shake.js @@ -465,7 +465,7 @@ "use strict"; function initProgress() { $(function () { - $(".version").html("Generated by Shake " + version + "."); + $(".version").html("Generated by Shake " + version + "."); $("#output").html(""); for (var _i = 0; _i < progress.length; _i++) { var x = progress[_i]; @@ -731,7 +731,7 @@ for (var i = 0; i < res.length; i++) s_2 += "
  • " + res[i] + "
    • "; s_2 += ""; - s_2 += "

    Generated by Shake " + version + ".

    "; + s_2 += "

    Generated by Shake " + version + ".

    "; $("#output").html(s_2); break; case "cmd-plot": @@ -849,7 +849,7 @@ $(this).attr("href", href).attr("target", "_blank")[0].setAttribute("onclick", onclick); }); $("a.shake").each(function () { - var href = "http://hackage.haskell.org/packages/archive/shake/latest/doc/html/Development-Shake.html#v:" + + var href = "https://hackage.haskell.org/packages/archive/shake/latest/doc/html/Development-Shake.html#v:" + $(this).text().replace("'", "-39-"); $(this).attr("href", href).attr("target", "_blank"); }); 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.16.3 +version: 0.16.4 license: BSD3 license-file: LICENSE category: Development, Shake @@ -12,10 +12,9 @@ description: Shake is a Haskell library for writing build systems - designed as a replacement for @make@. See "Development.Shake" for an introduction, - including an example. Further examples are included in the Cabal tarball, - under the @Examples@ directory. The homepage contains links to a user + including an example. The homepage contains links to a user manual, an academic paper and further information: - + . To use Shake the user writes a Haskell program that imports "Development.Shake", defines some build rules, and calls @@ -29,9 +28,9 @@ Shake also provides more accurate dependency tracking, including seamless support for generated files, and dependencies on system information (e.g. compiler version). -homepage: http://shakebuild.com +homepage: https://shakebuild.com bug-reports: https://github.com/ndmitchell/shake/issues -tested-with: GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 +tested-with: GHC==8.4.1, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 extra-doc-files: CHANGES.txt README.md diff --git a/src/Development/Shake.hs b/src/Development/Shake.hs --- a/src/Development/Shake.hs +++ b/src/Development/Shake.hs @@ -31,14 +31,14 @@ -- To find out more: -- -- * The user manual contains a longer example and background information on how to use Shake --- . +-- . -- --- * The home page has links to additional information , including +-- * The home page has links to additional information , including -- a mailing list. -- -- * The theory behind Shake is described in an ICFP 2012 paper, --- . --- The forms a short overview of Shake . +-- . +-- The forms a short overview of Shake . module Development.Shake( -- * Writing a build system -- $writing @@ -89,7 +89,7 @@ -- * Environment rules getEnv, getEnvWithDefault, -- * Oracle rules - ShakeValue, RuleResult, addOracle, askOracle, + ShakeValue, RuleResult, addOracle, addOracleCache, askOracle, -- * Special rules alwaysRerun, -- * Resources @@ -168,9 +168,9 @@ -- * @-rtsopts@: Allow the setting of further GHC options at runtime. -- -- * @-I0@: Disable idle garbage collection, to avoid frequent unnecessary garbage collection, see --- . +-- . -- --- * With GHC 7.6 and before, omit @-threaded@: +-- * With GHC 7.6 and before, omit @-threaded@: -- can cause a race condition in build systems that write files then read them. Omitting @-threaded@ will -- still allow your 'cmd' actions to run in parallel, so most build systems will still run in parallel. -- 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 @@ -138,7 +138,7 @@ let putWhenLn v msg = putWhen v $ msg ++ "\n" let showHelp = do progName <- getProgName - putWhen Normal $ unlines $ ("Usage: " ++ progName ++ " [options] [target] ...") : "Options:" : showOptDescr opts + putWhen Quiet $ unlines $ ("Usage: " ++ progName ++ " [options] [target] ...") : "Options:" : showOptDescr opts when (errs /= []) $ do putWhen Quiet $ unlines $ map ("shake: " ++) $ filter (not . null) $ lines $ unlines errs 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards, ScopedTypeVariables, ConstraintKinds #-} +{-# LANGUAGE RecordWildCards, NamedFieldPuns, ScopedTypeVariables, ConstraintKinds #-} module Development.Shake.Internal.Core.Action( runAction, actionOnException, actionFinally, @@ -38,14 +38,25 @@ runAction :: Global -> Local -> Action a -> Capture (Either SomeException a) runAction g l (Action x) = runRAW g l x +-- | Apply a modification, run an action, then run an undo action after. +-- Doesn't actually require exception handling because we don't have the ability to catch exceptions to the user. +actionBracket :: (Local -> (Local, Local -> Local)) -> Action a -> Action a +actionBracket f m = Action $ do + s <- getRW + let (s2,undo) = f s + putRW s2 + res <- fromAction m + modifyRW undo + return res + --------------------------------------------------------------------- -- EXCEPTION HANDLING actionBoom :: Bool -> Action a -> IO b -> Action a actionBoom runOnSuccess act clean = do - cleanup <- Action $ getsRO globalCleanup - undo <- liftIO $ addCleanup cleanup $ void clean + Global{..} <- Action getRO + undo <- liftIO $ addCleanup globalCleanup $ void clean -- important to mask_ the undo/clean combo so either both happen or neither res <- Action $ catchRAW (fromAction act) $ \e -> liftIO (mask_ $ undo >> clean) >> throwRAW e liftIO $ mask_ $ undo >> when runOnSuccess (void clean) @@ -65,14 +76,14 @@ -- | Get the initial 'ShakeOptions', these will not change during the build process. getShakeOptions :: Action ShakeOptions -getShakeOptions = Action $ getsRO globalOptions +getShakeOptions = Action $ globalOptions <$> getRO -- | Get the current 'Progress' structure, as would be returned by 'shakeProgress'. getProgress :: Action Progress getProgress = do - res <- Action $ getsRO globalProgress - liftIO res + Global{..} <- Action getRO + liftIO globalProgress -- | Specify an action to be run after the database has been closed, if building completes successfully. runAfter :: IO () -> Action () @@ -113,15 +124,15 @@ -- 'putLoud' \/ 'putNormal' \/ 'putQuiet', which ensures multiple messages are -- not interleaved. The verbosity can be modified locally by 'withVerbosity'. getVerbosity :: Action Verbosity -getVerbosity = Action $ getsRW localVerbosity +getVerbosity = Action $ localVerbosity <$> getRW -- | Run an action with a particular verbosity level. -- Will not update the 'shakeVerbosity' returned by 'getShakeOptions' and will -- not have any impact on 'Diagnostic' tracing. withVerbosity :: Verbosity -> Action a -> Action a -withVerbosity new = Action . unmodifyRW f . fromAction - where f s0 = (s0{localVerbosity=new}, \s -> s{localVerbosity=localVerbosity s0}) +withVerbosity new = actionBracket $ \s0 -> + (s0{localVerbosity=new}, \s -> s{localVerbosity=localVerbosity s0}) -- | Run an action with 'Quiet' verbosity, in particular messages produced by 'traced' @@ -142,8 +153,8 @@ blockApply = applyBlockedBy . Just applyBlockedBy :: Maybe String -> Action a -> Action a -applyBlockedBy reason = Action . unmodifyRW f . fromAction - where f s0 = (s0{localBlockApply=reason}, \s -> s{localBlockApply=localBlockApply s0}) +applyBlockedBy reason = actionBracket $ \s0 -> + (s0{localBlockApply=reason}, \s -> s{localBlockApply=localBlockApply s0}) --------------------------------------------------------------------- @@ -163,9 +174,9 @@ traced :: String -> IO a -> Action a traced msg act = do Global{..} <- Action getRO - stack <- Action $ getsRW localStack + Local{localStack} <- Action getRW start <- liftIO globalTimestamp - putNormal $ "# " ++ msg ++ " (for " ++ showTopStack stack ++ ")" + putNormal $ "# " ++ msg ++ " (for " ++ showTopStack localStack ++ ")" res <- liftIO act stop <- liftIO globalTimestamp let trace = newTrace msg start stop diff --git a/src/Development/Shake/Internal/Core/Monad.hs b/src/Development/Shake/Internal/Core/Monad.hs --- a/src/Development/Shake/Internal/Core/Monad.hs +++ b/src/Development/Shake/Internal/Core/Monad.hs @@ -1,19 +1,16 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GADTs, ScopedTypeVariables #-} module Development.Shake.Internal.Core.Monad( RAW, Capture, runRAW, - getRO, getRW, getsRO, getsRW, putRW, modifyRW, - withRO, withRW, + getRO, getRW, putRW, modifyRW, catchRAW, tryRAW, throwRAW, - unmodifyRW, captureRAW, + captureRAW, ) where import Control.Exception.Extra import Control.Monad.IO.Class -import Control.Monad.Trans.Cont -import Control.Monad.Trans.Reader -import Data.IORef +import Data.IORef.Extra import Control.Applicative import Control.Monad import Prelude @@ -23,18 +20,40 @@ #endif -data S ro rw = S - {handler :: IORef (SomeException -> IO ()) - ,ro :: ro - ,rww :: IORef rw -- Read/Write Writeable var (rww) - } +data RAW ro rw a where + Fmap :: (a -> b) -> RAW ro rw a -> RAW ro rw b + Pure :: a -> RAW ro rw a + Ap :: RAW ro rw (a -> b) -> RAW ro rw a -> RAW ro rw b + Next :: RAW ro rw a -> RAW ro rw b -> RAW ro rw b + Bind :: RAW ro rw a -> (a -> RAW ro rw b) -> RAW ro rw b + LiftIO :: IO a -> RAW ro rw a + GetRO :: RAW ro rw ro + GetRW :: RAW ro rw rw + PutRW :: !rw -> RAW ro rw () + ModifyRW :: (rw -> rw) -> RAW ro rw () + CaptureRAW :: Capture (Either SomeException a) -> RAW ro rw a + CatchRAW :: RAW ro rw a -> (SomeException -> RAW ro rw a) -> RAW ro rw a -newtype RAW ro rw a = RAW {fromRAW :: ReaderT (S ro rw) (ContT () IO) a} - deriving (Functor, Applicative, Monad, MonadIO +instance Functor (RAW ro rw) where + fmap = Fmap + +instance Applicative (RAW ro rw) where + pure = Pure + (*>) = Next + (<*>) = Ap + +instance Monad (RAW ro rw) where + return = pure + (>>) = (*>) + (>>=) = Bind + +instance MonadIO (RAW ro rw) where + liftIO = LiftIO + #if __GLASGOW_HASKELL__ >= 800 - , MonadFail +instance MonadFail (RAW ro rw) where + fail = liftIO . Control.Monad.Fail.fail #endif - ) type Capture a = (a -> IO ()) -> IO () @@ -42,62 +61,69 @@ -- | Run and then call a continuation. runRAW :: ro -> rw -> RAW ro rw a -> Capture (Either SomeException a) runRAW ro rw m k = do - rww <- newIORef rw + rw <- newIORef rw handler <- newIORef $ k . Left - -- see https://ghc.haskell.org/trac/ghc/ticket/11555 - fromRAW m `runReaderT` S handler ro rww `runContT` (k . Right) + goRAW handler ro rw m (k . Right) `catch_` \e -> ($ e) =<< readIORef handler +goRAW :: forall ro rw a . IORef (SomeException -> IO ()) -> ro -> IORef rw -> RAW ro rw a -> Capture a +goRAW handler ro rw = go + where + go :: RAW ro rw b -> Capture b + go x k = case x of + Fmap f a -> go a $ \v -> k $ f v + Pure a -> k a + Ap f x -> go f $ \f -> go x $ \v -> k $ f v + Bind a b -> go a $ \a -> go (b a) k + Next a b -> go a $ \_ -> go b k + LiftIO x -> k =<< x + GetRO -> k ro + GetRW -> k =<< readIORef rw + PutRW x -> writeIORef rw x >> k () + ModifyRW f -> modifyIORef' rw f >> k () + + CatchRAW m hdl -> do + old <- readIORef handler + writeIORef handler $ \e -> do + writeIORef handler old + go (hdl e) k `catch_` + \e -> ($ e) =<< readIORef handler + go m $ \x -> writeIORef handler old >> k x + + CaptureRAW f -> do + old <- readIORef handler + writeIORef handler throwIO + f $ \x -> case x of + Left e -> old e + Right v -> do + writeIORef handler old + k v `catch_` \e -> ($ e) =<< readIORef handler + writeIORef handler throwIO + + --------------------------------------------------------------------- -- STANDARD getRO :: RAW ro rw ro -getRO = RAW $ asks ro +getRO = GetRO getRW :: RAW ro rw rw -getRW = RAW $ liftIO . readIORef =<< asks rww - -getsRO :: (ro -> a) -> RAW ro rw a -getsRO f = fmap f getRO - -getsRW :: (rw -> a) -> RAW ro rw a -getsRW f = fmap f getRW +getRW = GetRW -- | Strict version putRW :: rw -> RAW ro rw () -putRW rw = rw `seq` RAW $ liftIO . flip writeIORef rw =<< asks rww - -withRAW :: (S ro rw -> S ro2 rw2) -> RAW ro2 rw2 a -> RAW ro rw a -withRAW f m = RAW $ withReaderT f $ fromRAW m +putRW = PutRW modifyRW :: (rw -> rw) -> RAW ro rw () -modifyRW f = do x <- getRW; putRW $ f x - -withRO :: (ro -> ro2) -> RAW ro2 rw a -> RAW ro rw a -withRO f = withRAW $ \s -> s{ro=f $ ro s} - -withRW :: (rw -> rw2) -> RAW ro rw2 a -> RAW ro rw a -withRW f m = do - rw <- getRW - rww <- liftIO $ newIORef $ f rw - withRAW (\s -> s{rww=rww}) m +modifyRW = ModifyRW --------------------------------------------------------------------- -- EXCEPTIONS catchRAW :: RAW ro rw a -> (SomeException -> RAW ro rw a) -> RAW ro rw a -catchRAW m hdl = RAW $ ReaderT $ \s -> ContT $ \k -> do - old <- readIORef $ handler s - writeIORef (handler s) $ \e -> do - writeIORef (handler s) old - fromRAW (hdl e) `runReaderT` s `runContT` k `catch_` - \e -> ($ e) =<< readIORef (handler s) - fromRAW m `runReaderT` s `runContT` \v -> do - writeIORef (handler s) old - k v - +catchRAW = CatchRAW tryRAW :: RAW ro rw a -> RAW ro rw (Either SomeException a) tryRAW m = catchRAW (fmap Right m) (return . Left) @@ -107,27 +133,9 @@ --------------------------------------------------------------------- --- WEIRD STUFF - --- | Apply a modification, run an action, then undo the changes after. -unmodifyRW :: (rw -> (rw, rw -> rw)) -> RAW ro rw a -> RAW ro rw a -unmodifyRW f m = do - (s2,undo) <- fmap f getRW - putRW s2 - res <- m - modifyRW undo - return res - +-- CONTINUATIONS -- | Capture a continuation. The continuation should be called at most once. -- Calling the same continuation, multiple times, in parallel, results in incorrect behaviour. captureRAW :: Capture (Either SomeException a) -> RAW ro rw a -captureRAW f = RAW $ ReaderT $ \s -> ContT $ \k -> do - old <- readIORef (handler s) - writeIORef (handler s) throwIO - f $ \x -> case x of - Left e -> old e - Right v -> do - writeIORef (handler s) old - k v `catch_` \e -> ($ e) =<< readIORef (handler s) - writeIORef (handler s) throwIO +captureRAW = CaptureRAW diff --git a/src/Development/Shake/Internal/Core/Rules.hs b/src/Development/Shake/Internal/Core/Rules.hs --- a/src/Development/Shake/Internal/Core/Rules.hs +++ b/src/Development/Shake/Internal/Core/Rules.hs @@ -53,8 +53,8 @@ getUserRules = f where f :: forall a . Typeable a => Action (UserRule a) f = do - userRules <- Action $ getsRO globalUserRules - return $ case Map.lookup (typeRep (Proxy :: Proxy a)) userRules of + Global{..} <- Action getRO + return $ case Map.lookup (typeRep (Proxy :: Proxy a)) globalUserRules of Nothing -> Unordered [] Just (UserRule_ r) -> fromJust $ cast r diff --git a/src/Development/Shake/Internal/Core/Run.hs b/src/Development/Shake/Internal/Core/Run.hs --- a/src/Development/Shake/Internal/Core/Run.hs +++ b/src/Development/Shake/Internal/Core/Run.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards, ScopedTypeVariables, PatternGuards #-} +{-# LANGUAGE RecordWildCards, NamedFieldPuns, ScopedTypeVariables, PatternGuards #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} @@ -202,8 +202,8 @@ let tk = typeRep (Proxy :: Proxy key) tv = typeRep (Proxy :: Proxy value) Global{..} <- Action getRO - block <- Action $ getsRW localBlockApply - whenJust block $ liftIO . errorNoApply tk (show <$> listToMaybe ks) + Local{localBlockApply} <- Action getRW + whenJust localBlockApply $ liftIO . errorNoApply tk (show <$> listToMaybe ks) case Map.lookup tk globalRules of Nothing -> liftIO $ errorNoRuleToBuildType tk (show <$> listToMaybe ks) (Just tv) Just BuiltinRule{builtinResult=tv2} | tv /= tv2 -> errorInternal $ "result type does not match, " ++ show tv ++ " vs " ++ show tv2 @@ -214,8 +214,8 @@ applyKeyValue [] = return [] applyKeyValue ks = do global@Global{..} <- Action getRO - stack <- Action $ getsRW localStack - (dur, dep, vs) <- Action $ captureRAW $ build globalPool globalDatabase (BuildKey $ runKey global) stack ks + Local{localStack} <- Action getRW + (dur, dep, vs) <- Action $ captureRAW $ build globalPool globalDatabase (BuildKey $ runKey global) localStack ks Action $ modifyRW $ \s -> s{localDiscount=localDiscount s + dur, localDepends=dep : localDepends s} return vs @@ -312,10 +312,10 @@ (res,offset) <- case res of Just res -> return (res, 0) Nothing -> do - pool <- Action $ getsRO globalPool + Global{..} <- Action getRO offset <- liftIO offsetTime Action $ captureRAW $ \k -> waitFence bar $ \v -> - addPoolResume pool $ do offset <- liftIO offset; k $ Right (v,offset) + addPoolResume globalPool $ do offset <- liftIO offset; k $ Right (v,offset) case res of Left err -> Action $ throwRAW err Right (deps,v) -> do @@ -324,14 +324,14 @@ Nothing -> do bar <- newFence return $ (,) (Map.insert key bar mp) $ do - pre <- Action $ getsRW localDepends + Local{localDepends=pre} <- Action getRW res <- Action $ tryRAW $ fromAction $ act key case res of Left err -> do liftIO $ signalFence bar $ Left err Action $ throwRAW err Right v -> do - post <- Action $ getsRW localDepends + Local{localDepends=post} <- Action getRW let deps = take (length post - length pre) post liftIO $ signalFence bar $ Right (deps, v) return v @@ -392,7 +392,7 @@ -- A more general version of 'orderOnly'. orderOnlyAction :: Action a -> Action a orderOnlyAction act = Action $ do - pre <- getsRW localDepends + Local{localDepends=pre} <- getRW res <- fromAction act modifyRW $ \s -> s{localDepends=pre} return res 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 @@ -91,10 +91,10 @@ putStrLn "\n% Demo complete - all the examples can be run from:" putStrLn $ "% " ++ dir - putStrLn "% For more info see http://shakebuild.com" + putStrLn "% For more info see https://shakebuild.com" when (isJust ninja) $ do putStrLn "\n% PS. Shake can also execute Ninja build files" - putStrLn "% For more info see http://shakebuild.com/ninja" + putStrLn "% For more info see https://shakebuild.com/ninja" diff --git a/src/Development/Shake/Internal/Derived.hs b/src/Development/Shake/Internal/Derived.hs --- a/src/Development/Shake/Internal/Derived.hs +++ b/src/Development/Shake/Internal/Derived.hs @@ -234,7 +234,7 @@ -- google <- 'Development.Shake.newThrottle' \"Google\" 1 5 -- \"*.url\" 'Development.Shake.%>' \\out -> do -- 'Development.Shake.withResource' google 1 $ --- 'Development.Shake.cmd' \"wget\" [\"http:\/\/google.com?q=\" ++ 'Development.Shake.FilePath.takeBaseName' out] \"-O\" [out] +-- 'Development.Shake.cmd' \"wget\" [\"https:\/\/google.com?q=\" ++ 'Development.Shake.FilePath.takeBaseName' out] \"-O\" [out] -- @ -- -- Now we will wait at least 5 seconds after querying Google before performing another query. If Google change the rules to @@ -248,7 +248,7 @@ -- google <- 'Development.Shake.newThrottle' \"Google\" 1 5 -- \"*.url\" 'Development.Shake.%>' \\out -> do -- 'Development.Shake.withResource' google 1 $ return () --- 'Development.Shake.cmd' \"wget\" [\"http:\/\/google.com?q=\" ++ 'Development.Shake.FilePath.takeBaseName' out] \"-O\" [out] +-- 'Development.Shake.cmd' \"wget\" [\"https:\/\/google.com?q=\" ++ 'Development.Shake.FilePath.takeBaseName' out] \"-O\" [out] -- @ -- -- However, the rule may not continue running immediately after 'Development.Shake.withResource' completes, so while @@ -270,9 +270,10 @@ f ((r,xs):rs) = withResource r (sum xs) $ f rs --- | Given an action on a key, produce a cached version that will execute the action at most once per key. +-- | Given an action on a key, produce a cached version that will execute the action at most once per key per run. -- Using the cached result will still result include any dependencies that the action requires. -- Each call to 'newCache' creates a separate cache that is independent of all other calls to 'newCache'. +-- The operations will not be cached between runs and nothing will be persisted to the Shake database. -- -- This function is useful when creating files that store intermediate values, -- to avoid the overhead of repeatedly reading from disk, particularly if the file requires expensive parsing. diff --git a/src/Development/Shake/Internal/FileInfo.hs b/src/Development/Shake/Internal/FileInfo.hs --- a/src/Development/Shake/Internal/FileInfo.hs +++ b/src/Development/Shake/Internal/FileInfo.hs @@ -74,7 +74,7 @@ -- If the result isn't strict then we are referencing a much bigger structure, -- and it causes a space leak I don't really understand on Linux when running -- the 'tar' test, followed by the 'benchmark' test. --- See this blog post: http://neilmitchell.blogspot.co.uk/2015/09/three-space-leaks.html +-- See this blog post: https://neilmitchell.blogspot.co.uk/2015/09/three-space-leaks.html result :: Word32 -> Word32 -> IO (Maybe (ModTime, FileSize)) result x y = do x <- evaluate $ fileInfo x diff --git a/src/Development/Shake/Internal/Progress.hs b/src/Development/Shake/Internal/Progress.hs --- a/src/Development/Shake/Internal/Progress.hs +++ b/src/Development/Shake/Internal/Progress.hs @@ -88,7 +88,7 @@ --------------------------------------------------------------------- -- MEALY TYPE - for writing the progress functions --- See +-- See -- | A machine that takes inputs and produces outputs newtype Mealy i a = Mealy {runMealy :: i -> (a, Mealy i a)} diff --git a/src/Development/Shake/Internal/Rules/Oracle.hs b/src/Development/Shake/Internal/Rules/Oracle.hs --- a/src/Development/Shake/Internal/Rules/Oracle.hs +++ b/src/Development/Shake/Internal/Rules/Oracle.hs @@ -2,7 +2,7 @@ {-# LANGUAGE TypeFamilies, ConstraintKinds #-} module Development.Shake.Internal.Rules.Oracle( - addOracle, askOracle + addOracle, addOracleCache, askOracle ) where import Development.Shake.Internal.Core.Run @@ -27,6 +27,30 @@ type instance RuleResult (OracleQ a) = OracleA (RuleResult a) +addOracleRaw :: (RuleResult q ~ a, ShakeValue q, ShakeValue a) => Bool -> (q -> Action a) -> Rules (q -> Action a) +addOracleRaw cache act = do + -- rebuild is automatic for oracles, skip just means we don't rebuild + opts <- getShakeOptionsRules + let skip = shakeRebuildApply opts "" == RebuildLater + + addBuiltinRule noLint $ \(OracleQ q) old changed -> case old of + Just old | skip || (cache && not changed) -> + return $ RunResult ChangedNothing old $ decode' old + _ -> do + new <- OracleA <$> act q + return $ RunResult + (if fmap decode' old == Just new then ChangedRecomputeSame else ChangedRecomputeDiff) + (encode' new) + new + return askOracle + where + encode' :: Binary a => a -> BS.ByteString + encode' = BS.concat . LBS.toChunks . encode + + decode' :: Binary a => BS.ByteString -> a + decode' = decode . LBS.fromChunks . return + + -- | Add extra information which rules can depend on. -- An oracle is a function from a question type @q@, to an answer type @a@. -- As an example, we can define an oracle allowing you to depend on the current version of GHC: @@ -82,30 +106,26 @@ -- Using these definitions, any rule depending on the version of @shake@ -- should call @getPkgVersion $ GhcPkgVersion \"shake\"@ to rebuild when @shake@ is upgraded. addOracle :: (RuleResult q ~ a, ShakeValue q, ShakeValue a) => (q -> Action a) -> Rules (q -> Action a) -addOracle act = do - -- rebuild is automatic for oracles, skip just means we don't rebuild - opts <- getShakeOptionsRules - let skip = shakeRebuildApply opts "" == RebuildLater - - addBuiltinRule noLint $ \(OracleQ q) old _ -> case old of - Just old | skip -> - return $ RunResult ChangedNothing old $ decode' old - _ -> do - new <- OracleA <$> act q - return $ RunResult - (if fmap decode' old == Just new then ChangedRecomputeSame else ChangedRecomputeDiff) - (encode' new) - new - return askOracle - where - encode' :: Binary a => a -> BS.ByteString - encode' = BS.concat . LBS.toChunks . encode +addOracle = addOracleRaw False - decode' :: Binary a => BS.ByteString -> a - decode' = decode . LBS.fromChunks . return +-- | A combination of 'addOracle' and 'newCache' - an action that only runs when its dependencies change, +-- whose result is stored in the database. +-- +-- * Does the information need recomputing every time? e.g. looking up stuff in the environment? +-- If so, use 'addOracle' instead. +-- +-- * Is the action mostly deserisalising some file? If so, use 'newCache'. +-- +-- * Is the operation expensive computation from other results? If so, use 'addOracleCache'. +-- +-- An alternative to using 'addOracleCache' is introducing an intermediate file containing the result, +-- which requires less storage in the Shake database and can be inspected by existing file-system viewing +-- tools. +addOracleCache ::(RuleResult q ~ a, ShakeValue q, ShakeValue a) => (q -> Action a) -> Rules (q -> Action a) +addOracleCache = addOracleRaw True --- | Get information previously added with 'addOracle'. The question/answer types must match those provided --- to 'addOracle'. +-- | Get information previously added with 'addOracle' or 'addOracleCache'. +-- The question/answer types must match those provided previously. askOracle :: (RuleResult q ~ a, ShakeValue q, ShakeValue a) => q -> Action a askOracle question = do OracleA answer <- apply1 $ OracleQ question; return answer diff --git a/src/General/Ids.hs b/src/General/Ids.hs --- a/src/General/Ids.hs +++ b/src/General/Ids.hs @@ -89,7 +89,7 @@ S{..} <- readIORef ref -- execute in O(1) stack - -- see http://neilmitchell.blogspot.co.uk/2015/09/making-sequencemapm-for-io-take-o1-stack.html + -- see https://neilmitchell.blogspot.co.uk/2015/09/making-sequencemapm-for-io-take-o1-stack.html let index r i | i >= used = [] index r i | IO io <- readArray values i = case io r of (# r, Nothing #) -> index r (i+1) diff --git a/src/Test/Docs.hs b/src/Test/Docs.hs --- a/src/Test/Docs.hs +++ b/src/Test/Docs.hs @@ -35,7 +35,13 @@ cmd_ (RemEnv "GHC_PACKAGE_PATH") (Cwd root) "runhaskell Setup.hs configure" ["--builddir=" ++ dist,"--user"] -- package-db is very sensitive, see #267 - ["--package-db=" ++ x | x <- maybe [] (filter (`notElem` [".",""]) . splitSearchPath) path] + -- note that the reverse ensures the behaviour is consistent between the flags and the env variable + ["--package-db=" ++ x | x <- maybe [] (reverse . filter (`notElem` [".",""]) . splitSearchPath) path] + -- Paths_shake is only created by "Setup build" (which we want to skip), and required by "Setup haddock", so we fake it + copyFile' (root "src/Paths.hs") "dist/build/autogen/Paths_shake.hs" + copyFile' (root "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 @@ -45,9 +51,6 @@ dist <- liftIO $ canonicalizePath "dist" cmd (Cwd root) "runhaskell Setup.hs haddock" ["--builddir=" ++ dist] - "Paths_shake.hs" %> \out -> - copyFile' (root "src/Paths.hs") out - "Part_*.hs" %> \out -> do need [root "src/Test/Docs.hs"] -- so much of the generator is in this module let noR = filter (/= '\r') @@ -82,7 +85,7 @@ ,"import System.Console.GetOpt" ,"import System.Directory(setCurrentDirectory)" ,"import qualified System.Directory" - ,"import System.Environment(lookupEnv)" + ,"import System.Environment(lookupEnv, getEnvironment)" ,"import System.Process" ,"import System.Exit" ,"import Control.Applicative" @@ -126,11 +129,10 @@ ,"var = undefined" ,"str = \"\""] ++ rest - liftIO $ putStrLn =<< readFile out "Files.lst" %> \out -> do need [root "src/Test/Docs.hs"] -- so much of the generator is in this module - need [index,"Paths_shake.hs"] + need [index] filesHs <- getDirectoryFiles "dist/doc/html/shake" ["Development-*.html"] filesMd <- getDirectoryFiles (root "docs") ["*.md"] writeFileChanged out $ unlines $ @@ -148,9 +150,10 @@ "Success.txt" %> \out -> do putNormal . ("Checking documentation for:\n" ++) =<< readFile' "Files.lst" needModules - need ["Main.hs", "Paths_shake.hs"] + need ["Main.hs"] + trackAllow ["dist//*"] needSource - cmd_ "ghc -fno-code -ignore-package=hashmap " ["-i.","-i" ++ root "src","Main.hs"] + cmd_ "ghc -fno-code -ignore-package=hashmap " ["-idist/build/autogen","-i" ++ root "src","Main.hs"] writeFile' out "" @@ -306,7 +309,7 @@ isProgram :: String -> Bool isProgram (words -> x:xs) = x `elem` programs && all (\x -> isCmdFlag x || isFilePath x || all isAlpha x || x == "&&") xs - where programs = words "excel gcc cl make ghc cabal distcc build tar git fsatrace ninja touch pwd runhaskell rot13 main shake stack rm cat sed sh apt-get build-multiple" + where programs = words "excel gcc cl make ghc ghci cabal distcc build tar git fsatrace ninja touch pwd runhaskell rot13 main shake stack rm cat sed sh apt-get build-multiple" -- | Should a fragment be whitelisted and not checked whitelist :: String -> Bool diff --git a/src/Test/Monad.hs b/src/Test/Monad.hs --- a/src/Test/Monad.hs +++ b/src/Test/Monad.hs @@ -23,38 +23,37 @@ test build = do let conv x = either (Left . fromException) Right x :: Either (Maybe ArithException) Int - let dump ro rw = do liftIO . (=== ro) =<< getRO; liftIO . (=== rw) =<< getRW + let dump rw = liftIO . (=== rw) =<< getRW -- test the basics plus exception handling run 1 "test" $ do - dump 1 "test" + dump "test" putRW "more" - dump 1 "more" - res <- tryRAW $ withRO (+3) $ do - dump 4 "more" - withRW (++ "x") $ - dump 4 "morex" - dump 4 "more" + dump "more" + res <- tryRAW $ do + dump "more" + modifyRW (++ "x") + dump "morex" return 100 liftIO $ conv res === Right 100 - dump 1 "more" + dump "morex" putRW "new" - dump 1 "new" - res <- tryRAW $ withRO (+2) $ do - dump 3 "new" - withRW (++ "x") $ do - dump 3 "newx" - throwRAW Overflow + dump "new" + res <- tryRAW $ do + dump "new" + modifyRW (++ "z") + dump "newz" + throwRAW Overflow error "Should not have reached here" return 9 liftIO $ conv res === Left (Just Overflow) - dump 1 "new" + dump "newz" catchRAW (catchRAW (throwRAW Overflow) $ \_ -> modifyRW (++ "x")) $ \_ -> modifyRW (++ "y") - dump 1 "newx" + dump "newzx" catchRAW (catchRAW (throwRAW Overflow) $ \e -> modifyRW (++ "x") >> throwRAW e) $ \_ -> modifyRW (++ "y") - dump 1 "newxxy" + dump "newzxxy" -- test capture run 1 "test" $ do diff --git a/src/Test/Oracle.hs b/src/Test/Oracle.hs --- a/src/Test/Oracle.hs +++ b/src/Test/Oracle.hs @@ -12,7 +12,10 @@ import Test.Type hiding (RandomType) import qualified Test.Type as T import Control.Monad +import Data.Functor +import Prelude + -- These are instances we'll compute over type instance RuleResult String = String type instance RuleResult Int = String @@ -20,6 +23,10 @@ type instance RuleResult Bool = Bool -- test results don't have to be a boolean +newtype FileLen = FileLen FilePath + deriving (Eq,Show,NFData,Typeable,Hashable,Binary) +type instance RuleResult FileLen = Int + newtype RandomType = RandomType (BinarySentinel String) deriving (Eq,Show,NFData,Typeable,Hashable,Binary) @@ -51,6 +58,14 @@ add "unit" () add "int" (0 :: Int) + addOracleCache $ \(FileLen file) -> do + liftIO $ appendFile ".log" "#" + length <$> readFile' file + "cache_out.txt" %> \out -> do + o <- askOracle (FileLen "cache_in.txt") + liftIO $ appendFile ".log" "!" + writeFile' out $ show o + test build = do build ["clean"] @@ -73,6 +88,21 @@ build ["--def=string=test","string.txt"] assertContents "string.txt" "test" assertContents ".log" ".." + + writeFile ".log" "" + writeFile "cache_in.txt" "aaa" + build ["cache_out.txt","--sleep"] + assertContents "cache_out.txt" "3" + assertContents ".log" "#!" + writeFile "cache_in.txt" "zzz" + build ["cache_out.txt","--sleep"] + build ["cache_out.txt","--sleep"] + assertContents "cache_out.txt" "3" + assertContents ".log" "#!#" + writeFile "cache_in.txt" "zzzz" + build ["cache_out.txt","--sleep"] + assertContents "cache_out.txt" "4" + assertContents ".log" "#!##!" -- check error messages are good let errors args err = assertException [err] $ build $ "--quiet" : args