From 0153b003e5c8f398ade6acf4a379d6469825070e Mon Sep 17 00:00:00 2001
From: Pepe Iborra <pepeiborra@gmail.com>
Date: Sat, 13 Mar 2021 08:28:05 +0000
Subject: [PATCH 01/13] staged builtin rules

---
 shake.cabal                                   |  2 +
 src/Development/Shake/Internal/Core/Build.hs  | 65 ++++++++++---------
 .../Shake/Internal/Core/Database.hs           |  8 +--
 src/Development/Shake/Internal/Core/Rules.hs  | 21 ++++--
 src/Development/Shake/Internal/Core/Types.hs  | 18 ++++-
 src/Development/Shake/Internal/Rules/File.hs  |  2 +-
 src/Development/Shake/Internal/Rules/Files.hs |  2 +-
 src/Development/Shake/Rule.hs                 |  5 +-
 8 files changed, 79 insertions(+), 44 deletions(-)

diff --git a/shake.cabal b/shake.cabal
index 55bed35b8..e0f7b3cb8 100644
--- a/shake.cabal
+++ b/shake.cabal
@@ -88,6 +88,7 @@ library
         base >= 4.9,
         binary,
         bytestring,
+        concurrent-extra,
         deepseq >= 1.1,
         directory >= 1.2.7.0,
         extra >= 1.6.19,
@@ -214,6 +215,7 @@ executable shake
         base == 4.*,
         binary,
         bytestring,
+        concurrent-extra,
         deepseq >= 1.1,
         directory,
         extra >= 1.6.19,
diff --git a/src/Development/Shake/Internal/Core/Build.hs b/src/Development/Shake/Internal/Core/Build.hs
index cab866b3a..3a037980d 100644
--- a/src/Development/Shake/Internal/Core/Build.hs
+++ b/src/Development/Shake/Internal/Core/Build.hs
@@ -36,6 +36,8 @@ import Data.Maybe
 import Data.List.Extra
 import Data.Either.Extra
 import System.Time.Extra
+import Data.Function
+import Control.Exception.Extra (try_)
 
 
 ---------------------------------------------------------------------
@@ -102,7 +104,7 @@ buildOne global@Global{..} stack database i k r = case addStack i k stack of
     Right stack -> Later $ \continue -> do
         setIdKeyStatus global database i k (Running (NoShow continue) r)
         let go = buildRunMode global stack database r
-        fromLater go $ \mode -> liftIO $ addPool PoolStart globalPool $
+        fromLater go $ \mode -> liftIO $ -- addPool PoolStart globalPool $
             runKey global stack k r mode $ \res -> do
                 runLocked database $ do
                     let val = fmap runValue res
@@ -194,35 +196,38 @@ runKey global@Global{globalOptions=ShakeOptions{..},..} stack k r mode continue
 
     let s = (newLocal stack shakeVerbosity){localBuiltinVersion = builtinVersion}
     time <- offsetTime
-    runAction global s (do
-        res <- builtinRun k (fmap result r) mode
-        liftIO $ evaluate $ rnf res
-
-        -- completed, now track anything required afterwards
-        when (runChanged res `elem` [ChangedRecomputeSame,ChangedRecomputeDiff]) $ do
-            -- if the users code didn't run you don't have to check anything (we assume builtin rules are correct)
-            globalRuleFinished k
-            producesCheck
-
-        Action $ fmap (res,) getRW) $ \case
-            Left e ->
-                continue . Left . toException =<< shakeException global stack e
-            Right (RunResult{..}, Local{..})
-                | runChanged == ChangedNothing || runChanged == ChangedStore, Just r <- r ->
-                    continue $ Right $ RunResult runChanged runStore (r{result = mkResult runValue runStore})
-                | otherwise -> do
-                    dur <- time
-                    let (cr, c) | Just r <- r, runChanged == ChangedRecomputeSame = (ChangedRecomputeSame, changed r)
-                                | otherwise = (ChangedRecomputeDiff, globalStep)
-                    continue $ Right $ RunResult cr runStore Result
-                        {result = mkResult runValue runStore
-                        ,changed = c
-                        ,built = globalStep
-                        ,depends = flattenDepends localDepends
-                        ,execution = doubleToFloat $ dur - localDiscount
-                        ,traces = flattenTraces localTraces}
-            where
-                mkResult value store = (value, if globalOneShot then BS.empty else store)
+    let followUp = \case
+                Left e ->
+                    continue . Left . toException =<< shakeException global stack e
+                Right (RunResult{..}, Local{..})
+                    | runChanged == ChangedNothing || runChanged == ChangedStore, Just r <- r ->
+                        continue $ Right $ RunResult runChanged runStore (r{result = mkResult runValue runStore})
+                    | otherwise -> do
+                        dur <- time
+                        let (cr, c) | Just r <- r, runChanged == ChangedRecomputeSame = (ChangedRecomputeSame, changed r)
+                                    | otherwise = (ChangedRecomputeDiff, globalStep)
+                        continue $ Right $ RunResult cr runStore Result
+                            {result = mkResult runValue runStore
+                            ,changed = c
+                            ,built = globalStep
+                            ,depends = flattenDepends localDepends
+                            ,execution = doubleToFloat $ dur - localDiscount
+                            ,traces = flattenTraces localTraces}
+                where
+                    mkResult value store = (value, if globalOneShot then BS.empty else store)
+    runAction global s (builtinRun k (fmap result r) mode >>= \x -> Action ((x,) <$> getRW)) $ \case
+        Left e -> continue . Left . toException =<< shakeException global stack e
+        Right (BuiltinRunChangedNothing done, s') ->
+            followUp (Right (RunResult ChangedNothing (result $ fromJust r) done,s'))
+        Right (BuiltinRunMore more, _) -> addPool PoolStart globalPool $ runAction global s (do
+            res <- more
+            liftIO $ evaluate $ rnf res
+            -- completed, now track anything required afterwards
+            when (runChanged res `elem` [ChangedRecomputeSame,ChangedRecomputeDiff]) $ do
+                -- if the users code didn't run you don't have to check anything (we assume builtin rules are correct)
+                globalRuleFinished k
+                producesCheck
+            Action $ fmap (res,) getRW) followUp
 
 ---------------------------------------------------------------------
 -- USER key/value WRAPPERS
diff --git a/src/Development/Shake/Internal/Core/Database.hs b/src/Development/Shake/Internal/Core/Database.hs
index ea2ac603a..4043dfc37 100644
--- a/src/Development/Shake/Internal/Core/Database.hs
+++ b/src/Development/Shake/Internal/Core/Database.hs
@@ -14,7 +14,7 @@ import General.Intern(Id, Intern)
 import Development.Shake.Classes
 import qualified Data.HashMap.Strict as Map
 import qualified General.Intern as Intern
-import Control.Concurrent.Extra
+import Control.Concurrent.RLock as RLock
 import Control.Monad.IO.Class
 import qualified General.Ids as Ids
 import Control.Monad.Fail
@@ -25,7 +25,7 @@ newtype Locked a = Locked (IO a)
     deriving (Functor, Applicative, Monad, MonadIO, MonadFail)
 
 runLocked :: DatabasePoly k v -> Locked b -> IO b
-runLocked db (Locked act) = withLock (lock db) act
+runLocked db (Locked act) = RLock.with (lock db) act
 
 
 -- | Invariant: The database does not have any cycles where a Key depends on itself.
@@ -33,7 +33,7 @@ runLocked db (Locked act) = withLock (lock db) act
 --   There may be dangling Id's as a result of version changes.
 --   Lock is used to prevent any torn updates
 data DatabasePoly k v = Database
-    {lock :: Lock
+    {lock :: RLock
     ,intern :: IORef (Intern k) -- ^ Key |-> Id mapping
     ,status :: Ids.Ids (k, v) -- ^ Id |-> (Key, Status) mapping
     ,journal :: Id -> k -> v -> IO () -- ^ Record all changes to status
@@ -50,7 +50,7 @@ createDatabase
 createDatabase status journal vDefault = do
     xs <- Ids.toList status
     intern <- newIORef $ Intern.fromList [(k, i) | (i, (k,_)) <- xs]
-    lock <- newLock
+    lock <- RLock.new
     pure Database{..}
 
 
diff --git a/src/Development/Shake/Internal/Core/Rules.hs b/src/Development/Shake/Internal/Core/Rules.hs
index f19c57b4a..3852a00c1 100644
--- a/src/Development/Shake/Internal/Core/Rules.hs
+++ b/src/Development/Shake/Internal/Core/Rules.hs
@@ -6,7 +6,7 @@
 
 module Development.Shake.Internal.Core.Rules(
     Rules, SRules(..), runRules,
-    RuleResult, addBuiltinRule, addBuiltinRuleEx,
+    RuleResult, addBuiltinRule, addBuiltinRuleStaged, addBuiltinRuleEx,
     noLint, noIdentity,
     getShakeOptionsRules,
     getUserRuleInternal, getUserRuleOne, getUserRuleList, getUserRuleMaybe,
@@ -47,6 +47,7 @@ import Development.Shake.Internal.Core.Monad
 import Development.Shake.Internal.Value
 import Development.Shake.Internal.Options
 import Development.Shake.Internal.Errors
+import Data.Bifunctor (bimap)
 
 
 ---------------------------------------------------------------------
@@ -238,19 +239,29 @@ type family RuleResult key -- = value
 --
 --   For a worked example of writing a rule see <https://tech-blog.capital-match.com/posts/5-upgrading-shake.html>.
 addBuiltinRule
+    :: (RuleResult key ~ value, ShakeValue key, Typeable value, NFData value, Show value, Partial)
+    => BuiltinLint key value -> BuiltinIdentity key value -> BuiltinRun' key value -> Rules ()
+addBuiltinRule lint check run = addBuiltinRuleStaged lint check (builtinRun' run)
+
+addBuiltinRuleStaged
     :: (RuleResult key ~ value, ShakeValue key, Typeable value, NFData value, Show value, Partial)
     => BuiltinLint key value -> BuiltinIdentity key value -> BuiltinRun key value -> Rules ()
-addBuiltinRule = withFrozenCallStack $ addBuiltinRuleInternal $ BinaryOp
+addBuiltinRuleStaged = withFrozenCallStack $ addBuiltinRuleInternal $ BinaryOp
     (putEx . Bin.toLazyByteString . execPut . put)
     (runGet get . LBS.fromChunks . pure)
 
 addBuiltinRuleEx
     :: (RuleResult key ~ value, ShakeValue key, BinaryEx key, Typeable value, NFData value, Show value, Partial)
-    => BuiltinLint key value -> BuiltinIdentity key value -> BuiltinRun key value -> Rules ()
-addBuiltinRuleEx = addBuiltinRuleInternal $ BinaryOp putEx getEx
-
+    => BuiltinLint key value -> BuiltinIdentity key value -> BuiltinRun' key value -> Rules ()
+addBuiltinRuleEx = addBuiltinRuleInternal' $ BinaryOp putEx getEx
 
 -- | Unexpected version of 'addBuiltinRule', which also lets me set the 'BinaryOp'.
+addBuiltinRuleInternal'
+    :: (RuleResult key ~ value, ShakeValue key, Typeable value, NFData value, Show value, Partial)
+    => BinaryOp key -> BuiltinLint key value -> BuiltinIdentity key value -> BuiltinRun' key value -> Rules ()
+addBuiltinRuleInternal' binary lint check run =
+    addBuiltinRuleInternal binary lint check (builtinRun' run)
+
 addBuiltinRuleInternal
     :: (RuleResult key ~ value, ShakeValue key, Typeable value, NFData value, Show value, Partial)
     => BinaryOp key -> BuiltinLint key value -> BuiltinIdentity key value -> BuiltinRun key value -> Rules ()
diff --git a/src/Development/Shake/Internal/Core/Types.hs b/src/Development/Shake/Internal/Core/Types.hs
index 59250dc46..3881559b4 100755
--- a/src/Development/Shake/Internal/Core/Types.hs
+++ b/src/Development/Shake/Internal/Core/Types.hs
@@ -1,8 +1,10 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, DeriveDataTypeable, ViewPatterns #-}
 {-# LANGUAGE ExistentialQuantification, DeriveFunctor, RecordWildCards, FlexibleInstances #-}
 
+{-# LANGUAGE RankNTypes #-}
 module Development.Shake.Internal.Core.Types(
-    BuiltinRun, BuiltinLint, BuiltinIdentity,
+    BuiltinRun, BuiltinRun', BuiltinLint, BuiltinIdentity,
+    BuiltinRunResult(..), builtinRun',
     RunMode(..), RunResult(..), RunChanged(..),
     UserRule(..), UserRuleVersioned(..), userRuleSize,
     BuiltinRule(..), Global(..), Local(..), Action(..), runAction, addDiscount,
@@ -351,11 +353,25 @@ enumerateDepends d = f d []
 --
 -- * @newValue@, the result that 'Development.Shake.Rule.apply' will return when asked for the given @key@.
 type BuiltinRun key value
+    = key
+    -> Maybe BS.ByteString
+    -> RunMode
+    -> Action(BuiltinRunResult value)
+
+data BuiltinRunResult value
+    = BuiltinRunChangedNothing !value
+    | BuiltinRunMore !(Action (RunResult value))
+  deriving Functor
+
+type BuiltinRun' key value
     = key
     -> Maybe BS.ByteString
     -> RunMode
     -> Action (RunResult value)
 
+builtinRun' :: BuiltinRun' k v -> BuiltinRun k v
+builtinRun' run k bs m = pure $ BuiltinRunMore $ run k bs m
+
 -- | The action performed by @--lint@ for a given @key@/@value@ pair.
 --   At the end of the build the lint action will be called for each @key@ that was built this run,
 --   passing the @value@ it produced. Return 'Nothing' to indicate the value has not changed and
diff --git a/src/Development/Shake/Internal/Rules/File.hs b/src/Development/Shake/Internal/Rules/File.hs
index 3946ee2f5..d187407af 100644
--- a/src/Development/Shake/Internal/Rules/File.hs
+++ b/src/Development/Shake/Internal/Rules/File.hs
@@ -205,7 +205,7 @@ ruleIdentity _ = \k v -> case answer v of
     Just (FileA _ size hash) -> Just $ runBuilder $ putExStorable size <> putExStorable hash
     Nothing -> Nothing
 
-ruleRun :: ShakeOptions -> (FilePath -> Rebuild) -> BuiltinRun FileQ FileR
+ruleRun :: ShakeOptions -> (FilePath -> Rebuild) -> BuiltinRun' FileQ FileR
 ruleRun opts@ShakeOptions{..} rebuildFlags o@(FileQ (fileNameToString -> xStr)) oldBin@(fmap getEx -> old :: Maybe Answer) mode = do
     -- for One, rebuild makes perfect sense
     -- for Forward, we expect the child will have already rebuilt - Rebuild just lets us deal with code changes
diff --git a/src/Development/Shake/Internal/Rules/Files.hs b/src/Development/Shake/Internal/Rules/Files.hs
index a490578d8..82a2bce21 100644
--- a/src/Development/Shake/Internal/Rules/Files.hs
+++ b/src/Development/Shake/Internal/Rules/Files.hs
@@ -89,7 +89,7 @@ ruleIdentity _ = \_ (FilesA files) ->
 
 
 
-ruleRun :: ShakeOptions -> (FilePath -> Rebuild) -> BuiltinRun FilesQ FilesA
+ruleRun :: ShakeOptions -> (FilePath -> Rebuild) -> BuiltinRun' FilesQ FilesA
 ruleRun opts rebuildFlags k o@(fmap getEx -> old :: Maybe Result) mode = do
     let r = map (rebuildFlags . fileNameToString . fromFileQ) $ fromFilesQ k
 
diff --git a/src/Development/Shake/Rule.hs b/src/Development/Shake/Rule.hs
index ed4e6337c..9c71f1151 100644
--- a/src/Development/Shake/Rule.hs
+++ b/src/Development/Shake/Rule.hs
@@ -16,8 +16,9 @@ module Development.Shake.Rule(
 
     -- * Defining builtin rules
     -- | Functions and types for defining new types of Shake rules.
-    addBuiltinRule,
-    BuiltinLint, noLint, BuiltinIdentity, noIdentity, BuiltinRun, RunMode(..), RunChanged(..), RunResult(..),
+    addBuiltinRule, addBuiltinRuleStaged,
+    BuiltinLint, noLint, BuiltinIdentity, noIdentity,
+    BuiltinRun, BuiltinRunResult(..), RunMode(..), RunChanged(..), RunResult(..),
     -- * Calling builtin rules
     -- | Wrappers around calling Shake rules. In general these should be specialised to a builtin rule.
     apply, apply1,

From e538c9dbddff70894e65e959c213acfea7b45ecd Mon Sep 17 00:00:00 2001
From: Pepe Iborra <pepeiborra@gmail.com>
Date: Sat, 13 Mar 2021 16:48:20 +0000
Subject: [PATCH 02/13] fix missing dependency

---
 shake.cabal | 1 +
 1 file changed, 1 insertion(+)

diff --git a/shake.cabal b/shake.cabal
index e0f7b3cb8..48626a043 100644
--- a/shake.cabal
+++ b/shake.cabal
@@ -339,6 +339,7 @@ test-suite shake-test
         base == 4.*,
         binary,
         bytestring,
+        concurrent-extra,
         deepseq >= 1.1,
         directory,
         extra >= 1.6.19,

From c6059804130a73c8b60102ac756fc98c64725783 Mon Sep 17 00:00:00 2001
From: Pepe Iborra <pepeiborra@gmail.com>
Date: Sat, 13 Mar 2021 18:28:52 +0000
Subject: [PATCH 03/13] backwards compat. and tests

---
 src/Development/Shake/Internal/Core/Rules.hs  | 12 ++++++------
 src/Development/Shake/Internal/Core/Types.hs  |  8 ++++----
 src/Development/Shake/Internal/Rules/File.hs  |  2 +-
 src/Development/Shake/Internal/Rules/Files.hs |  2 +-
 src/Test/Self.hs                              |  2 +-
 5 files changed, 13 insertions(+), 13 deletions(-)

diff --git a/src/Development/Shake/Internal/Core/Rules.hs b/src/Development/Shake/Internal/Core/Rules.hs
index 3852a00c1..bc5338558 100644
--- a/src/Development/Shake/Internal/Core/Rules.hs
+++ b/src/Development/Shake/Internal/Core/Rules.hs
@@ -240,32 +240,32 @@ type family RuleResult key -- = value
 --   For a worked example of writing a rule see <https://tech-blog.capital-match.com/posts/5-upgrading-shake.html>.
 addBuiltinRule
     :: (RuleResult key ~ value, ShakeValue key, Typeable value, NFData value, Show value, Partial)
-    => BuiltinLint key value -> BuiltinIdentity key value -> BuiltinRun' key value -> Rules ()
+    => BuiltinLint key value -> BuiltinIdentity key value -> BuiltinRun key value -> Rules ()
 addBuiltinRule lint check run = addBuiltinRuleStaged lint check (builtinRun' run)
 
 addBuiltinRuleStaged
     :: (RuleResult key ~ value, ShakeValue key, Typeable value, NFData value, Show value, Partial)
-    => BuiltinLint key value -> BuiltinIdentity key value -> BuiltinRun key value -> Rules ()
+    => BuiltinLint key value -> BuiltinIdentity key value -> BuiltinRun' key value -> Rules ()
 addBuiltinRuleStaged = withFrozenCallStack $ addBuiltinRuleInternal $ BinaryOp
     (putEx . Bin.toLazyByteString . execPut . put)
     (runGet get . LBS.fromChunks . pure)
 
 addBuiltinRuleEx
     :: (RuleResult key ~ value, ShakeValue key, BinaryEx key, Typeable value, NFData value, Show value, Partial)
-    => BuiltinLint key value -> BuiltinIdentity key value -> BuiltinRun' key value -> Rules ()
+    => BuiltinLint key value -> BuiltinIdentity key value -> BuiltinRun key value -> Rules ()
 addBuiltinRuleEx = addBuiltinRuleInternal' $ BinaryOp putEx getEx
 
 -- | Unexpected version of 'addBuiltinRule', which also lets me set the 'BinaryOp'.
 addBuiltinRuleInternal'
     :: (RuleResult key ~ value, ShakeValue key, Typeable value, NFData value, Show value, Partial)
-    => BinaryOp key -> BuiltinLint key value -> BuiltinIdentity key value -> BuiltinRun' key value -> Rules ()
+    => BinaryOp key -> BuiltinLint key value -> BuiltinIdentity key value -> BuiltinRun key value -> Rules ()
 addBuiltinRuleInternal' binary lint check run =
     addBuiltinRuleInternal binary lint check (builtinRun' run)
 
 addBuiltinRuleInternal
     :: (RuleResult key ~ value, ShakeValue key, Typeable value, NFData value, Show value, Partial)
-    => BinaryOp key -> BuiltinLint key value -> BuiltinIdentity key value -> BuiltinRun key value -> Rules ()
-addBuiltinRuleInternal binary lint check (run :: BuiltinRun key value) = do
+    => BinaryOp key -> BuiltinLint key value -> BuiltinIdentity key value -> BuiltinRun' key value -> Rules ()
+addBuiltinRuleInternal binary lint check (run :: BuiltinRun' key value) = do
     let k = Proxy :: Proxy key
     let lint_ k v = lint (fromKey k) (fromValue v)
     let check_ k v = check (fromKey k) (fromValue v)
diff --git a/src/Development/Shake/Internal/Core/Types.hs b/src/Development/Shake/Internal/Core/Types.hs
index 3881559b4..808d0d8c3 100755
--- a/src/Development/Shake/Internal/Core/Types.hs
+++ b/src/Development/Shake/Internal/Core/Types.hs
@@ -352,7 +352,7 @@ enumerateDepends d = f d []
 -- * @newStore@, the new value to store in the database, which will be passed in next time as @oldStore@.
 --
 -- * @newValue@, the result that 'Development.Shake.Rule.apply' will return when asked for the given @key@.
-type BuiltinRun key value
+type BuiltinRun' key value
     = key
     -> Maybe BS.ByteString
     -> RunMode
@@ -363,13 +363,13 @@ data BuiltinRunResult value
     | BuiltinRunMore !(Action (RunResult value))
   deriving Functor
 
-type BuiltinRun' key value
+type BuiltinRun key value
     = key
     -> Maybe BS.ByteString
     -> RunMode
     -> Action (RunResult value)
 
-builtinRun' :: BuiltinRun' k v -> BuiltinRun k v
+builtinRun' :: BuiltinRun k v -> BuiltinRun' k v
 builtinRun' run k bs m = pure $ BuiltinRunMore $ run k bs m
 
 -- | The action performed by @--lint@ for a given @key@/@value@ pair.
@@ -394,7 +394,7 @@ type BuiltinIdentity key value = key -> value -> Maybe BS.ByteString
 data BuiltinRule = BuiltinRule
     {builtinLint :: BuiltinLint Key Value
     ,builtinIdentity :: BuiltinIdentity Key Value
-    ,builtinRun :: BuiltinRun Key Value
+    ,builtinRun :: BuiltinRun' Key Value
     ,builtinKey :: BinaryOp Key
     ,builtinVersion :: Ver
     ,builtinLocation :: String
diff --git a/src/Development/Shake/Internal/Rules/File.hs b/src/Development/Shake/Internal/Rules/File.hs
index d187407af..3946ee2f5 100644
--- a/src/Development/Shake/Internal/Rules/File.hs
+++ b/src/Development/Shake/Internal/Rules/File.hs
@@ -205,7 +205,7 @@ ruleIdentity _ = \k v -> case answer v of
     Just (FileA _ size hash) -> Just $ runBuilder $ putExStorable size <> putExStorable hash
     Nothing -> Nothing
 
-ruleRun :: ShakeOptions -> (FilePath -> Rebuild) -> BuiltinRun' FileQ FileR
+ruleRun :: ShakeOptions -> (FilePath -> Rebuild) -> BuiltinRun FileQ FileR
 ruleRun opts@ShakeOptions{..} rebuildFlags o@(FileQ (fileNameToString -> xStr)) oldBin@(fmap getEx -> old :: Maybe Answer) mode = do
     -- for One, rebuild makes perfect sense
     -- for Forward, we expect the child will have already rebuilt - Rebuild just lets us deal with code changes
diff --git a/src/Development/Shake/Internal/Rules/Files.hs b/src/Development/Shake/Internal/Rules/Files.hs
index 82a2bce21..a490578d8 100644
--- a/src/Development/Shake/Internal/Rules/Files.hs
+++ b/src/Development/Shake/Internal/Rules/Files.hs
@@ -89,7 +89,7 @@ ruleIdentity _ = \_ (FilesA files) ->
 
 
 
-ruleRun :: ShakeOptions -> (FilePath -> Rebuild) -> BuiltinRun' FilesQ FilesA
+ruleRun :: ShakeOptions -> (FilePath -> Rebuild) -> BuiltinRun FilesQ FilesA
 ruleRun opts rebuildFlags k o@(fmap getEx -> old :: Maybe Result) mode = do
     let r = map (rebuildFlags . fileNameToString . fromFileQ) $ fromFilesQ k
 
diff --git a/src/Test/Self.hs b/src/Test/Self.hs
index 642dbde97..7aed83a74 100644
--- a/src/Test/Self.hs
+++ b/src/Test/Self.hs
@@ -86,7 +86,7 @@ cabalBuildDepends :: String -> [String]
 cabalBuildDepends _ = packages ++ ["unix" | os /= "mingw32"]
 
 packages = words
-    ("base transformers binary unordered-containers hashable heaps time bytestring primitive " ++
+    ("base transformers binary concurrency-extra unordered-containers hashable heaps time bytestring primitive " ++
      "filepath directory process deepseq random utf8-string extra js-dgtable js-jquery js-flot filepattern") ++
     ["old-time" | compilerVersion < makeVersion [7,6]] ++
     ["semigroups" | compilerVersion < makeVersion [8,0]]

From 3bc67763e0821430fc18af16c8d1c979bfa0f780 Mon Sep 17 00:00:00 2001
From: Pepe Iborra <pepeiborra@gmail.com>
Date: Sat, 13 Mar 2021 20:45:07 +0000
Subject: [PATCH 04/13] restrict the outer stage to IO

---
 src/Development/Shake/Internal/Core/Build.hs | 9 +++++----
 src/Development/Shake/Internal/Core/Types.hs | 2 +-
 2 files changed, 6 insertions(+), 5 deletions(-)

diff --git a/src/Development/Shake/Internal/Core/Build.hs b/src/Development/Shake/Internal/Core/Build.hs
index 3a037980d..ec211ee3d 100644
--- a/src/Development/Shake/Internal/Core/Build.hs
+++ b/src/Development/Shake/Internal/Core/Build.hs
@@ -215,11 +215,12 @@ runKey global@Global{globalOptions=ShakeOptions{..},..} stack k r mode continue
                             ,traces = flattenTraces localTraces}
                 where
                     mkResult value store = (value, if globalOneShot then BS.empty else store)
-    runAction global s (builtinRun k (fmap result r) mode >>= \x -> Action ((x,) <$> getRW)) $ \case
+    stage1 <- try $ builtinRun k (fmap result r) mode
+    case stage1 of
         Left e -> continue . Left . toException =<< shakeException global stack e
-        Right (BuiltinRunChangedNothing done, s') ->
-            followUp (Right (RunResult ChangedNothing (result $ fromJust r) done,s'))
-        Right (BuiltinRunMore more, _) -> addPool PoolStart globalPool $ runAction global s (do
+        Right (BuiltinRunChangedNothing done) ->
+            followUp (Right (RunResult ChangedNothing (result $ fromJust r) done, s))
+        Right (BuiltinRunMore more) -> addPool PoolStart globalPool $ runAction global s (do
             res <- more
             liftIO $ evaluate $ rnf res
             -- completed, now track anything required afterwards
diff --git a/src/Development/Shake/Internal/Core/Types.hs b/src/Development/Shake/Internal/Core/Types.hs
index 808d0d8c3..c9c49da96 100755
--- a/src/Development/Shake/Internal/Core/Types.hs
+++ b/src/Development/Shake/Internal/Core/Types.hs
@@ -356,7 +356,7 @@ type BuiltinRun' key value
     = key
     -> Maybe BS.ByteString
     -> RunMode
-    -> Action(BuiltinRunResult value)
+    -> IO (BuiltinRunResult value)
 
 data BuiltinRunResult value
     = BuiltinRunChangedNothing !value

From 15d164b555f805c28c9116f6c60b37b585cc5aae Mon Sep 17 00:00:00 2001
From: Pepe Iborra <pepeiborra@gmail.com>
Date: Sat, 13 Mar 2021 22:19:44 +0000
Subject: [PATCH 05/13] remove commented out code

---
 src/Development/Shake/Internal/Core/Build.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/Development/Shake/Internal/Core/Build.hs b/src/Development/Shake/Internal/Core/Build.hs
index ec211ee3d..59adeccc8 100644
--- a/src/Development/Shake/Internal/Core/Build.hs
+++ b/src/Development/Shake/Internal/Core/Build.hs
@@ -104,8 +104,8 @@ buildOne global@Global{..} stack database i k r = case addStack i k stack of
     Right stack -> Later $ \continue -> do
         setIdKeyStatus global database i k (Running (NoShow continue) r)
         let go = buildRunMode global stack database r
-        fromLater go $ \mode -> liftIO $ -- addPool PoolStart globalPool $
-            runKey global stack k r mode $ \res -> do
+        fromLater go $ \mode -> liftIO $
+            runKey global stack k r mode $ \res -> mask_ $ do
                 runLocked database $ do
                     let val = fmap runValue res
                     res <- liftIO $ getKeyValueFromId database i

From 0d7424eb74aaebfc73412523f938591d11325cb0 Mon Sep 17 00:00:00 2001
From: Pepe Iborra <pepeiborra@gmail.com>
Date: Sat, 13 Mar 2021 22:20:33 +0000
Subject: [PATCH 06/13] fix typo

---
 src/Test/Self.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Test/Self.hs b/src/Test/Self.hs
index 7aed83a74..cb6761c48 100644
--- a/src/Test/Self.hs
+++ b/src/Test/Self.hs
@@ -86,7 +86,7 @@ cabalBuildDepends :: String -> [String]
 cabalBuildDepends _ = packages ++ ["unix" | os /= "mingw32"]
 
 packages = words
-    ("base transformers binary concurrency-extra unordered-containers hashable heaps time bytestring primitive " ++
+    ("base transformers binary concurrent-extra unordered-containers hashable heaps time bytestring primitive " ++
      "filepath directory process deepseq random utf8-string extra js-dgtable js-jquery js-flot filepattern") ++
     ["old-time" | compilerVersion < makeVersion [7,6]] ++
     ["semigroups" | compilerVersion < makeVersion [8,0]]

From 264b4faf58b62aa2b50821e2a26c6bbd239e2216 Mon Sep 17 00:00:00 2001
From: Pepe Iborra <pepeiborra@gmail.com>
Date: Sun, 14 Mar 2021 07:20:17 +0000
Subject: [PATCH 07/13] undo redundant import

---
 src/Development/Shake/Internal/Core/Rules.hs | 1 -
 1 file changed, 1 deletion(-)

diff --git a/src/Development/Shake/Internal/Core/Rules.hs b/src/Development/Shake/Internal/Core/Rules.hs
index bc5338558..f6fcf7666 100644
--- a/src/Development/Shake/Internal/Core/Rules.hs
+++ b/src/Development/Shake/Internal/Core/Rules.hs
@@ -47,7 +47,6 @@ import Development.Shake.Internal.Core.Monad
 import Development.Shake.Internal.Value
 import Development.Shake.Internal.Options
 import Development.Shake.Internal.Errors
-import Data.Bifunctor (bimap)
 
 
 ---------------------------------------------------------------------

From b5cc0d960dfc309ce7e1739956d04881b3921969 Mon Sep 17 00:00:00 2001
From: Pepe Iborra <pepeiborra@gmail.com>
Date: Sun, 14 Mar 2021 08:03:42 +0000
Subject: [PATCH 08/13] Define a reentrant lock

The RLock implementation in concurrent-extra is broken

https://github.com/basvandijk/concurrent-extra/issues/20
---
 shake.cabal                                   |  9 ++--
 .../Shake/Internal/Core/Database.hs           |  2 +-
 src/General/RLock.hs                          | 47 +++++++++++++++++++
 src/Test/Self.hs                              |  2 +-
 4 files changed, 55 insertions(+), 5 deletions(-)
 create mode 100644 src/General/RLock.hs

diff --git a/shake.cabal b/shake.cabal
index 48626a043..f59897b85 100644
--- a/shake.cabal
+++ b/shake.cabal
@@ -88,7 +88,6 @@ library
         base >= 4.9,
         binary,
         bytestring,
-        concurrent-extra,
         deepseq >= 1.1,
         directory >= 1.2.7.0,
         extra >= 1.6.19,
@@ -102,6 +101,7 @@ library
         primitive,
         process >= 1.1,
         random,
+        stm,
         time,
         transformers >= 0.2,
         unordered-containers >= 0.2.7,
@@ -198,6 +198,7 @@ library
         General.Makefile
         General.Pool
         General.Process
+        General.RLock
         General.Template
         General.Thread
         General.Timing
@@ -215,7 +216,6 @@ executable shake
         base == 4.*,
         binary,
         bytestring,
-        concurrent-extra,
         deepseq >= 1.1,
         directory,
         extra >= 1.6.19,
@@ -229,6 +229,7 @@ executable shake
         primitive,
         process >= 1.1,
         random,
+        stm,
         time,
         transformers >= 0.2,
         unordered-containers >= 0.2.7,
@@ -320,6 +321,7 @@ executable shake
         General.Makefile
         General.Pool
         General.Process
+        General.RLock
         General.Template
         General.Thread
         General.Timing
@@ -339,7 +341,6 @@ test-suite shake-test
         base == 4.*,
         binary,
         bytestring,
-        concurrent-extra,
         deepseq >= 1.1,
         directory,
         extra >= 1.6.19,
@@ -354,6 +355,7 @@ test-suite shake-test
         process >= 1.1,
         QuickCheck >= 2.0,
         random,
+        stm,
         time,
         transformers >= 0.2,
         unordered-containers >= 0.2.7,
@@ -449,6 +451,7 @@ test-suite shake-test
         General.Makefile
         General.Pool
         General.Process
+        General.RLock
         General.Template
         General.Thread
         General.Timing
diff --git a/src/Development/Shake/Internal/Core/Database.hs b/src/Development/Shake/Internal/Core/Database.hs
index 4043dfc37..2f040ed70 100644
--- a/src/Development/Shake/Internal/Core/Database.hs
+++ b/src/Development/Shake/Internal/Core/Database.hs
@@ -14,7 +14,7 @@ import General.Intern(Id, Intern)
 import Development.Shake.Classes
 import qualified Data.HashMap.Strict as Map
 import qualified General.Intern as Intern
-import Control.Concurrent.RLock as RLock
+import General.RLock as RLock
 import Control.Monad.IO.Class
 import qualified General.Ids as Ids
 import Control.Monad.Fail
diff --git a/src/General/RLock.hs b/src/General/RLock.hs
new file mode 100644
index 000000000..cf575496a
--- /dev/null
+++ b/src/General/RLock.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE LambdaCase #-}
+module General.RLock (RLock, new, acquire, release, with) where
+
+import Control.Applicative
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Exception
+
+-- | A reentrant lock inspired by the one in the concurrent-extra package, to
+--   work around https://github.com/basvandijk/concurrent-extra/issues/20
+--   This implementation uses a single 'TVar' and therefore it is not *fair*
+newtype RLock = RLock {rlock :: TVar State}
+
+data State
+  = Locked !ThreadId !Int
+  | Unlocked
+
+new :: IO RLock
+new = RLock <$> newTVarIO Unlocked
+
+acquire :: RLock -> IO ()
+acquire (RLock tv) = do
+  tid <- myThreadId
+  atomically $ do
+    readTVar tv >>= \case
+      Locked tid' n
+        | tid == tid' ->
+            writeTVar tv $! Locked tid' (n+1)
+        | otherwise -> retry
+      Unlocked ->
+          writeTVar tv $! Locked tid 1
+
+release :: RLock -> IO ()
+release (RLock tv) = do
+  tid <- myThreadId
+  atomically $ do
+    readTVar tv >>= \case
+      Locked tid' n
+        | tid == tid' ->
+          writeTVar tv $! if n == 1 then Unlocked else Locked tid (n-1)
+        | otherwise ->
+          error "This thread does not hold the lock"
+      Unlocked ->
+        error "The lock is not held"
+
+with :: RLock -> IO a -> IO a
+with = liftA2 bracket_ acquire release
diff --git a/src/Test/Self.hs b/src/Test/Self.hs
index cb6761c48..642dbde97 100644
--- a/src/Test/Self.hs
+++ b/src/Test/Self.hs
@@ -86,7 +86,7 @@ cabalBuildDepends :: String -> [String]
 cabalBuildDepends _ = packages ++ ["unix" | os /= "mingw32"]
 
 packages = words
-    ("base transformers binary concurrent-extra unordered-containers hashable heaps time bytestring primitive " ++
+    ("base transformers binary unordered-containers hashable heaps time bytestring primitive " ++
      "filepath directory process deepseq random utf8-string extra js-dgtable js-jquery js-flot filepattern") ++
     ["old-time" | compilerVersion < makeVersion [7,6]] ++
     ["semigroups" | compilerVersion < makeVersion [8,0]]

From 7dadd2b1ed907f879c9429f22a435913cc6c7712 Mon Sep 17 00:00:00 2001
From: Pepe Iborra <pepeiborra@gmail.com>
Date: Sun, 14 Mar 2021 08:10:30 +0000
Subject: [PATCH 09/13] Fix not used warning

---
 src/General/RLock.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/General/RLock.hs b/src/General/RLock.hs
index cf575496a..a4e6e52a6 100644
--- a/src/General/RLock.hs
+++ b/src/General/RLock.hs
@@ -9,7 +9,7 @@ import Control.Exception
 -- | A reentrant lock inspired by the one in the concurrent-extra package, to
 --   work around https://github.com/basvandijk/concurrent-extra/issues/20
 --   This implementation uses a single 'TVar' and therefore it is not *fair*
-newtype RLock = RLock {rlock :: TVar State}
+newtype RLock = RLock {_rlock :: TVar State}
 
 data State
   = Locked !ThreadId !Int

From 8fdbcfdbadaf23c7bff7fa6ed1ec7e296bc5ee92 Mon Sep 17 00:00:00 2001
From: Pepe Iborra <pepeiborra@gmail.com>
Date: Sun, 14 Mar 2021 08:19:29 +0000
Subject: [PATCH 10/13] Fix redundant imports

---
 src/Development/Shake/Internal/Core/Build.hs | 2 --
 1 file changed, 2 deletions(-)

diff --git a/src/Development/Shake/Internal/Core/Build.hs b/src/Development/Shake/Internal/Core/Build.hs
index 59adeccc8..9f87156dc 100644
--- a/src/Development/Shake/Internal/Core/Build.hs
+++ b/src/Development/Shake/Internal/Core/Build.hs
@@ -36,8 +36,6 @@ import Data.Maybe
 import Data.List.Extra
 import Data.Either.Extra
 import System.Time.Extra
-import Data.Function
-import Control.Exception.Extra (try_)
 
 
 ---------------------------------------------------------------------

From d50fa80ce186677aa70ccd1771b02d938b8cfcb2 Mon Sep 17 00:00:00 2001
From: Pepe Iborra <pepeiborra@gmail.com>
Date: Sun, 14 Mar 2021 17:35:41 +0000
Subject: [PATCH 11/13] refactor runKey to return a Wait instead of a plain
 Capture

It is possible to return Now for rules that do not have a second stage
---
 src/Development/Shake/Internal/Core/Build.hs | 26 ++++++++++----------
 1 file changed, 13 insertions(+), 13 deletions(-)

diff --git a/src/Development/Shake/Internal/Core/Build.hs b/src/Development/Shake/Internal/Core/Build.hs
index 9f87156dc..f8fe028e8 100644
--- a/src/Development/Shake/Internal/Core/Build.hs
+++ b/src/Development/Shake/Internal/Core/Build.hs
@@ -103,7 +103,7 @@ buildOne global@Global{..} stack database i k r = case addStack i k stack of
         setIdKeyStatus global database i k (Running (NoShow continue) r)
         let go = buildRunMode global stack database r
         fromLater go $ \mode -> liftIO $
-            runKey global stack k r mode $ \res -> mask_ $ do
+            fromLater(runKey global stack k r mode) $ \res -> mask_ $ do
                 runLocked database $ do
                     let val = fmap runValue res
                     res <- liftIO $ getKeyValueFromId database i
@@ -184,27 +184,27 @@ runKey
     -> Key -- The key to build
     -> Maybe (Result BS.ByteString) -- A previous result, or Nothing if never been built before
     -> RunMode -- True if any of the children were dirty
-    -> Capture (Either SomeException (RunResult (Result (Value, BS_Store))))
+    -> Wait IO (Either SomeException (RunResult (Result (Value, BS_Store))))
         -- Either an error, or a (the produced files, the result).
-runKey global@Global{globalOptions=ShakeOptions{..},..} stack k r mode continue = do
+runKey global@Global{globalOptions=ShakeOptions{..},..} stack k r mode = do
     let tk = typeKey k
     BuiltinRule{..} <- case Map.lookup tk globalRules of
         Nothing -> throwM $ errorNoRuleToBuildType tk (Just $ show k) Nothing
         Just r -> pure r
 
     let s = (newLocal stack shakeVerbosity){localBuiltinVersion = builtinVersion}
-    time <- offsetTime
+    time <- liftIO offsetTime
     let followUp = \case
                 Left e ->
-                    continue . Left . toException =<< shakeException global stack e
+                    Left . toException <$> shakeException global stack e
                 Right (RunResult{..}, Local{..})
                     | runChanged == ChangedNothing || runChanged == ChangedStore, Just r <- r ->
-                        continue $ Right $ RunResult runChanged runStore (r{result = mkResult runValue runStore})
+                        return $ Right $ RunResult runChanged runStore (r{result = mkResult runValue runStore})
                     | otherwise -> do
-                        dur <- time
+                        dur <- liftIO time
                         let (cr, c) | Just r <- r, runChanged == ChangedRecomputeSame = (ChangedRecomputeSame, changed r)
                                     | otherwise = (ChangedRecomputeDiff, globalStep)
-                        continue $ Right $ RunResult cr runStore Result
+                        return $ Right $ RunResult cr runStore Result
                             {result = mkResult runValue runStore
                             ,changed = c
                             ,built = globalStep
@@ -213,12 +213,12 @@ runKey global@Global{globalOptions=ShakeOptions{..},..} stack k r mode continue
                             ,traces = flattenTraces localTraces}
                 where
                     mkResult value store = (value, if globalOneShot then BS.empty else store)
-    stage1 <- try $ builtinRun k (fmap result r) mode
+    stage1 <- liftIO $ try $ builtinRun k (fmap result r) mode
     case stage1 of
-        Left e -> continue . Left . toException =<< shakeException global stack e
+        Left e -> Now . Left . toException =<< liftIO (shakeException global stack e)
         Right (BuiltinRunChangedNothing done) ->
-            followUp (Right (RunResult ChangedNothing (result $ fromJust r) done, s))
-        Right (BuiltinRunMore more) -> addPool PoolStart globalPool $ runAction global s (do
+            liftIO $ followUp (Right (RunResult ChangedNothing (result $ fromJust r) done, s))
+        Right (BuiltinRunMore more) -> Later $ \continue -> liftIO $ addPool PoolStart globalPool $ runAction global s (do
             res <- more
             liftIO $ evaluate $ rnf res
             -- completed, now track anything required afterwards
@@ -226,7 +226,7 @@ runKey global@Global{globalOptions=ShakeOptions{..},..} stack k r mode continue
                 -- if the users code didn't run you don't have to check anything (we assume builtin rules are correct)
                 globalRuleFinished k
                 producesCheck
-            Action $ fmap (res,) getRW) followUp
+            Action $ fmap (res,) getRW) (followUp >=> continue)
 
 ---------------------------------------------------------------------
 -- USER key/value WRAPPERS

From 8e446f132a8007a2b9728e28cd540f63b2c27806 Mon Sep 17 00:00:00 2001
From: Pepe Iborra <pepeiborra@gmail.com>
Date: Sun, 14 Mar 2021 19:23:50 +0000
Subject: [PATCH 12/13] use pure

---
 src/Development/Shake/Internal/Core/Build.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/Development/Shake/Internal/Core/Build.hs b/src/Development/Shake/Internal/Core/Build.hs
index f8fe028e8..150450e8b 100644
--- a/src/Development/Shake/Internal/Core/Build.hs
+++ b/src/Development/Shake/Internal/Core/Build.hs
@@ -199,12 +199,12 @@ runKey global@Global{globalOptions=ShakeOptions{..},..} stack k r mode = do
                     Left . toException <$> shakeException global stack e
                 Right (RunResult{..}, Local{..})
                     | runChanged == ChangedNothing || runChanged == ChangedStore, Just r <- r ->
-                        return $ Right $ RunResult runChanged runStore (r{result = mkResult runValue runStore})
+                        pure $ Right $ RunResult runChanged runStore (r{result = mkResult runValue runStore})
                     | otherwise -> do
                         dur <- liftIO time
                         let (cr, c) | Just r <- r, runChanged == ChangedRecomputeSame = (ChangedRecomputeSame, changed r)
                                     | otherwise = (ChangedRecomputeDiff, globalStep)
-                        return $ Right $ RunResult cr runStore Result
+                        pure $ Right $ RunResult cr runStore Result
                             {result = mkResult runValue runStore
                             ,changed = c
                             ,built = globalStep

From a47a99daff93cd182dfc05992e8c1baaaf102ee3 Mon Sep 17 00:00:00 2001
From: Pepe Iborra <pepeiborra@gmail.com>
Date: Sat, 22 May 2021 10:09:11 +0100
Subject: [PATCH 13/13] Much more efficient reentrant lock

---
 src/General/RLock.hs | 30 +++++++++++-------------------
 1 file changed, 11 insertions(+), 19 deletions(-)

diff --git a/src/General/RLock.hs b/src/General/RLock.hs
index a4e6e52a6..2ef331c52 100644
--- a/src/General/RLock.hs
+++ b/src/General/RLock.hs
@@ -12,36 +12,28 @@ import Control.Exception
 newtype RLock = RLock {_rlock :: TVar State}
 
 data State
-  = Locked !ThreadId !Int
+  = Locked !ThreadId
   | Unlocked
 
 new :: IO RLock
 new = RLock <$> newTVarIO Unlocked
 
-acquire :: RLock -> IO ()
+acquire :: RLock -> IO Bool
 acquire (RLock tv) = do
   tid <- myThreadId
   atomically $ do
     readTVar tv >>= \case
-      Locked tid' n
+      Locked tid'
         | tid == tid' ->
-            writeTVar tv $! Locked tid' (n+1)
+            return False
         | otherwise -> retry
-      Unlocked ->
-          writeTVar tv $! Locked tid 1
+      Unlocked -> do
+          writeTVar tv $! Locked tid
+          return True
 
-release :: RLock -> IO ()
-release (RLock tv) = do
-  tid <- myThreadId
-  atomically $ do
-    readTVar tv >>= \case
-      Locked tid' n
-        | tid == tid' ->
-          writeTVar tv $! if n == 1 then Unlocked else Locked tid (n-1)
-        | otherwise ->
-          error "This thread does not hold the lock"
-      Unlocked ->
-        error "The lock is not held"
+release :: RLock -> Bool -> IO ()
+release (RLock tv) True  = atomically $ writeTVar tv Unlocked
+release _          False = return ()
 
 with :: RLock -> IO a -> IO a
-with = liftA2 bracket_ acquire release
+with rl act = bracket (acquire rl) (release rl) (const act)