build 0.0.1.1 → 1.0

raw patch · 21 files changed

+429/−545 lines, 21 filesdep ~algebraic-graphsdep ~containersdep ~extraPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: algebraic-graphs, containers, extra, filepath, mtl, random, transformers

API changes (from Hackage documentation)

Files

• README.md +5/−4
• build.cabal +14/−16
• src/Build.hs +4/−21
• src/Build/Multi.hs +5/−8
• src/Build/Rebuilder.hs +81/−53
• src/Build/Scheduler.hs +115/−89
• src/Build/SelfTracking.hs +21/−20
• src/Build/System.hs +26/−20
• src/Build/Task.hs +18/−25
• src/Build/Task/Applicative.hs +1/−3
• src/Build/Task/Depend.hs +0/−44
• src/Build/Task/Functor.hs +1/−3
• src/Build/Task/Monad.hs +24/−14
• src/Build/Task/MonadPlus.hs +9/−8
• src/Build/Task/Typed.hs +1/−1
• src/Build/Task/Wrapped.hs +0/−68
• src/Build/Trace.hs +50/−79
• src/Build/Utilities.hs +1/−26
• test/Examples.hs +36/−29
• test/Main.hs +10/−8
• test/Spreadsheet.hs +7/−6

@@ -13,13 +13,14 @@ * Run `stack test` to execute all the provided build systems on a very simple example. * Run `stack haddock` to generate HTML documentation of all the interfaces. * Read the code, particularly [System.hs](src/Build/System.hs) which is the concrete implementation of-  all build systems. Following the imports (or the Haddock documentation) will lead you to all the-  consistuent parts.+  all build systems. Following the imports (or the+  [Haddock documentation](https://hackage.haskell.org/package/build)) will lead you to all the+  constituent parts.  ## Further Activities -There aren't really any. The code served as a proving ground for ideas, and it's existence both allows-confirmation that our conclusions are valid, and opportunity to cheaply conduct further experiments. However,+There aren't really any. The code served as a proving ground for ideas, and its existence both allows+confirmation that our conclusions are valid, and opportunity to cheaply conduct further experiments. Although the code is a useful adjoint to the paper, it is not essential to it (other than we wouldn't have been able to discover what we did without an executable specification). 

@@ -1,5 +1,5 @@ name:                build-version:             0.0.1.1+version:             1.0 synopsis:            Build systems a la carte homepage:            https://github.com/snowleopard/build license:             MIT@@ -12,7 +12,7 @@ extra-source-files:  README.md description:         A library for experimenting with build systems and                      incremental computation frameworks, based on the ideas-                     presented in the ICFP 2018 paper "Build systems a la carte".+                     presented in the ICFP 2018 paper "Build Systems a la Carte". cabal-version:       >=1.10  source-repository head@@ -29,23 +29,21 @@                         Build.Store,                         Build.Task,                         Build.Task.Applicative,-                        Build.Task.Depend,                         Build.Task.Functor,                         Build.Task.Monad,                         Build.Task.MonadPlus,                         Build.Task.Typed,-                        Build.Task.Wrapped,                         Build.Trace,                         Build.System   other-modules:        Build.Utilities-  build-depends:        algebraic-graphs >= 0.1.1,-                        base             >= 4.7 && < 5,-                        containers       >= 0.5.7.1,-                        extra            >= 1.5.3,-                        filepath         >= 1.4.1.0,-                        mtl              >= 2.2.1,-                        random           >= 1.1,-                        transformers     >= 0.5.2.0+  build-depends:        algebraic-graphs >= 0.1.1   && < 0.2,+                        base             >= 4.7     && < 5,+                        containers       >= 0.5.7.1 && < 0.6,+                        extra            >= 1.5.3   && < 1.7,+                        filepath         >= 1.4.1.0 && < 1.5,+                        mtl              >= 2.2.1   && < 2.3,+                        random           >= 1.1     && < 1.2,+                        transformers     >= 0.5.2.0 && < 0.6   default-language:     Haskell2010   GHC-options:          -Wall                         -fno-warn-name-shadowing@@ -62,10 +60,10 @@                         Spreadsheet     build-depends:      build,                         base         >= 4.7     && < 5,-                        extra        >= 1.5.3,-                        containers   >= 0.5.7.1,-                        mtl          >= 2.2.1,-                        transformers >= 0.5.2.0+                        containers   >= 0.5.7.1 && < 0.6,+                        extra        >= 1.5.3   && < 1.7,+                        mtl          >= 2.2.1   && < 2.3,+                        transformers >= 0.5.2.0 && < 0.6     default-language:   Haskell2010     GHC-options:        -Wall                         -fno-warn-name-shadowing

@@ -1,17 +1,14 @@-{-# LANGUAGE ConstraintKinds, RankNTypes, TypeApplications #-}- -- | Build systems and the properties they should ensure. module Build (     -- * Build     Build,      -- * Properties-    correct, correctBuild, idempotent+    correctBuild     ) where  import Build.Task import Build.Task.Monad-import Build.Task.Wrapped import Build.Store import Build.Utilities @@ -29,21 +26,7 @@ correctBuild :: (Ord k, Eq v) => Tasks Monad k v -> Store i k v -> Store i k v -> k -> Bool correctBuild tasks store result = all correct . reachable deps   where-    deps = maybe [] (\t -> snd $ track (unwrap @Monad t) (flip getValue result)) . tasks+    deps = maybe [] (\task -> snd $ trackPure task (flip getValue result)) . tasks     correct k = case tasks k of-        Nothing -> getValue k result == getValue k store-        Just t  -> getValue k result == compute (unwrap @Monad t) (flip getValue result)---- | Given a @build@ and @tasks@, check that @build@ produces a correct result--- for any initial store and a target key.-correct :: (Ord k, Eq v) => Build Monad i k v -> Tasks Monad k v -> Bool-correct build tasks = forall $ \(key, store) ->-    correctBuild tasks store (build tasks key store) key---- | Check that a build system is /idempotent/, i.e. running it once or twice in--- a row leads to the same resulting 'Store'.-idempotent :: Eq v => Build Monad i k v -> Tasks Monad k v -> Bool-idempotent build tasks = forall $ \(key, store1) ->-    let store2 = build tasks key store1-        store3 = build tasks key store2-    in forall $ \k -> getValue k store2 == getValue k store3+        Nothing   -> getValue k result == getValue k store+        Just task -> getValue k result == compute task result

@@ -1,8 +1,5 @@-{-# LANGUAGE RankNTypes #-}---- | Given a build system that can work with single keys, generalise that to one--- that deals with multiple keys at a time.-module Build.Multi (multi) where+-- | Support for multiple-output tasks.+module Build.Multi (Partition, multi) where  import Data.Maybe import Build.Task@@ -15,12 +12,12 @@ -- * @forall i \in ks . f i == ks@ type Partition k = k -> [k] --- | Given a build rule where you can build some combinations of multiple rules,--- use a partition to enable building lots of multiple rule subsets.+-- | Given a task description with individual multiple-output keys, compute its+-- "closure" supporting all possible combinations of keys. multi :: Eq k => Partition k -> Tasks Applicative [k] [v] -> Tasks Applicative [k] [v] multi partition tasks keys     | k:_ <- keys, partition k == keys = tasks keys-    | otherwise = Just $ \fetch ->+    | otherwise = Just $ Task $ \fetch ->         sequenceA [ select k <$> fetch (partition k) | k <- keys ]   where     select k = fromMaybe (error msg) . lookup k . zip (partition k)

@@ -1,18 +1,21 @@-{-# LANGUAGE ConstraintKinds, RankNTypes, TupleSections #-}+{-# LANGUAGE TupleSections #-}  -- | Rebuilders take care of deciding whether a key needs to be rebuild and -- running the corresponding task if need be. module Build.Rebuilder (-    Rebuilder, perpetualRebuilder,+    Rebuilder, adaptRebuilder, perpetualRebuilder,     modTimeRebuilder, Time, MakeInfo,-    approximationRebuilder, DependencyApproximation (..), ApproximationInfo,+    dirtyBitRebuilder, dirtyBitRebuilderWithCleanUp,+    approximateRebuilder, ApproximateDependencies, ApproximationInfo,     vtRebuilder, stRebuilder, ctRebuilder, dctRebuilder     ) where  import Control.Monad.State import Data.Map (Map)+import Data.Set (Set)  import qualified Data.Map as Map+import qualified Data.Set as Set  import Build.Store import Build.Task@@ -25,94 +28,119 @@ -- rebuilding a key if it is up to date. type Rebuilder c i k v = k -> v -> Task c k v -> Task (MonadState i) k v +-- | Get an applicative rebuilder out of a monadic one.+adaptRebuilder :: Rebuilder Monad i k v -> Rebuilder Applicative i k v+adaptRebuilder rebuilder key value task = rebuilder key value $ Task $ run task+ -- | Always rebuilds the key. perpetualRebuilder :: Rebuilder Monad () k v-perpetualRebuilder _key _value task = task+perpetualRebuilder _key _value task = Task $ run task  ------------------------------------- Make ------------------------------------- type Time = Integer-type MakeInfo k = (Map k Time, Time)+type MakeInfo k = (Time, Map k Time)  -- | This rebuilder uses modification time to decide whether a key is dirty and -- needs to be rebuilt. Used by Make. modTimeRebuilder :: Ord k => Rebuilder Applicative (MakeInfo k) k v-modTimeRebuilder key value task fetch = do-    (modTime, now) <- get-    let dirty = case Map.lookup key modTime of+modTimeRebuilder key value task = Task $ \fetch -> do+    (now, modTimes) <- get+    let dirty = case Map.lookup key modTimes of             Nothing -> True-            time -> any (\d -> Map.lookup d modTime > time) (dependencies task)+            time -> any (\d -> Map.lookup d modTimes > time) (dependencies task)     if not dirty     then return value     else do-        put (Map.insert key now modTime, now + 1)-        task fetch+        put (now + 1, Map.insert key now modTimes)+        run task fetch ---------------------------- Dependency approximation ----------------------------data DependencyApproximation k = SubsetOf [k] | Unknown+----------------------------------- Dirty bit ----------------------------------+-- | If the key is dirty, rebuild it. Used by Excel.+dirtyBitRebuilder :: Rebuilder Monad (k -> Bool) k v+dirtyBitRebuilder key value task = Task $ \fetch -> do+    isDirty <- get+    if isDirty key then run task fetch else return value -type ApproximationInfo k = (k -> Bool, k -> DependencyApproximation k)+-- | If the key is dirty, rebuild it and clear the dirty bit. Used by Excel.+dirtyBitRebuilderWithCleanUp :: Ord k => Rebuilder Monad (Set k) k v+dirtyBitRebuilderWithCleanUp key value task = Task $ \fetch -> do+    isDirty <- get+    if key `Set.notMember` isDirty then return value else do+        put (Set.delete key isDirty)+        run task fetch +--------------------------- Approximate dependencies ---------------------------+-- | If there is an entry for a key, it is an conservative approximation of its+-- dependencies. Otherwise, we have no reasonable approximation and assume the+-- key is always dirty (e.g. it uses an INDIRECT reference).+type ApproximateDependencies k = Map k [k]++-- | A set of dirty keys and information about dependencies.+type ApproximationInfo k = (Set k, ApproximateDependencies k)+ -- | This rebuilders uses approximate dependencies to decide whether a key--- needs to be rebuilt. Used by Excel.-approximationRebuilder :: Ord k => Rebuilder Monad (ApproximationInfo k) k v-approximationRebuilder key value task fetch = do-    (isDirty, deps) <- get-    let dirty = isDirty key || case deps key of SubsetOf ks -> any isDirty ks-                                                Unknown     -> True+-- needs to be rebuilt.+approximateRebuilder :: (Ord k, Eq v) => Rebuilder Monad (ApproximationInfo k) k v+approximateRebuilder key value task = Task $ \fetch -> do+    (dirtyKeys, deps) <- get+    let dirty = key `Set.member` dirtyKeys ||+                case Map.lookup key deps of Nothing -> True+                                            Just ks -> any (`Set.member` dirtyKeys) ks     if not dirty     then return value     else do-        put (\k -> k == key || isDirty k, deps)-        task fetch+        newValue <- run task fetch+        when (value /= newValue) $ put (Set.insert key dirtyKeys, deps)+        return newValue  ------------------------------- Verifying traces ------------------------------- -- | This rebuilder relies on verifying traces. vtRebuilder :: (Eq k, Hashable v) => Rebuilder Monad (VT k v) k v-vtRebuilder key value task fetch = do-    vt <- get-    dirty <- not <$> verifyVT key value (fmap hash . fetch) vt-    if not dirty+vtRebuilder key value task = Task $ \fetch -> do+    upToDate <- verifyVT key (hash value) (fmap hash . fetch) =<< get+    if upToDate     then return value     else do-        (newValue, deps) <- trackM task fetch-        put =<< recordVT key newValue deps (fmap hash . fetch) =<< get+        (newValue, deps) <- track task fetch+        modify $ recordVT key (hash newValue) [ (k, hash v) | (k, v) <- deps ]         return newValue  ------------------------------ Constructive traces ----------------------------- -- | This rebuilder relies on constructive traces. ctRebuilder :: (Eq k, Hashable v) => Rebuilder Monad (CT k v) k v-ctRebuilder key value task fetch = do-    ct <- get-    maybeCachedValue <- constructCT key value (fmap hash . fetch) ct-    case maybeCachedValue of-        Just cachedValue -> return cachedValue-        Nothing -> do-            (newValue, deps) <- trackM task fetch-            put =<< recordCT key newValue deps (fmap hash . fetch) =<< get+ctRebuilder key value task = Task $ \fetch -> do+    cachedValues <- constructCT key (fmap hash . fetch) =<< get+    if value `elem` cachedValues+    then return value -- The current value has been verified, let's keep it+    else case cachedValues of+        (cachedValue:_) -> return cachedValue -- Any cached value will do+        _ -> do -- No cached values, need to run the task+            (newValue, deps) <- track task fetch+            modify $ recordCT key newValue [ (k, hash v) | (k, v) <- deps ]             return newValue ------------------------ Deterministic constructive traces ------------------------- | This rebuilder relies on deterministic constructive traces.-dctRebuilder :: (Hashable k, Hashable v) => Rebuilder Monad (DCT k v) k v-dctRebuilder key _value task fetch = do-    dct <- get-    maybeCachedValue <- constructDCT key (fmap hash . fetch) dct-    case maybeCachedValue of-        Just cachedValue -> return cachedValue-        Nothing -> do-            (newValue, deps) <- trackM task fetch-            put =<< recordDCT key newValue deps (fmap hash . fetch) =<< get+--------------------------- Deep constructive traces ---------------------------+-- | This rebuilder relies on deep constructive traces.+dctRebuilder :: (Eq k, Hashable v) => Rebuilder Monad (DCT k v) k v+dctRebuilder key value task = Task $ \fetch -> do+    cachedValues <- constructDCT key (fmap hash . fetch) =<< get+    if value `elem` cachedValues+    then return value -- The current value has been verified, let's keep it+    else case cachedValues of+        (cachedValue:_) -> return cachedValue -- Any cached value will do+        _ -> do -- No cached values, need to run the task+            (newValue, deps) <- track task fetch+            put =<< recordDCT key newValue (map fst deps) (fmap hash . fetch) =<< get             return newValue  ------------------------------- Version traces ------------------------------- -- | This rebuilder relies on version/step traces. stRebuilder :: (Eq k, Hashable v) => Rebuilder Monad (Step, ST k v) k v-stRebuilder key value task fetch = do-    dirty <- not <$> verifyST key value (void . fetch) (gets snd)-    if not dirty+stRebuilder key value task = Task $ \fetch -> do+    upToDate <- verifyST key value (void . fetch) (gets snd)+    if upToDate     then return value     else do-        (newValue, deps) <- trackM task fetch-        (step, st) <- get-        put . (step,) =<< recordST step key newValue deps st+        (newValue, deps) <- track task fetch+        modify $ \(step, st) -> (step, recordST step key newValue (map fst deps) st)         return newValue

@@ -1,13 +1,12 @@ {-# LANGUAGE FlexibleContexts, RankNTypes, ScopedTypeVariables, TupleSections #-}-{-# LANGUAGE FunctionalDependencies, MultiParamTypeClasses #-}-{-# LANGUAGE TypeApplications, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}  -- | Build schedulers execute task rebuilders in the right order. module Build.Scheduler (     topological,-    reordering, Chain,-    restarting,-    recursive,+    restarting, Chain,+    restarting2,+    suspending,     independent     ) where @@ -17,15 +16,32 @@  import Build import Build.Task+import Build.Task.Applicative import Build.Task.Monad-import Build.Task.Wrapped+import Build.Trace import Build.Store import Build.Rebuilder import Build.Utilities -import qualified Data.Set               as Set-import qualified Build.Task.Applicative as A+import qualified Data.Set as Set +type Scheduler c i j k v = Rebuilder c j k v -> Build c i k v++-- | Lift a computation operating on @i@ to @Store i k v@.+liftStore :: State i a -> State (Store i k v) a+liftStore x = do+    (a, newInfo) <- gets (runState x . getInfo)+    modify (putInfo newInfo)+    return a++-- | Lift a computation operating on @Store i k v@ to @Store (i, j) k v@.+liftInfo :: State (Store i k v) a -> State (Store (i, j) k v) a+liftInfo x = do+    store <- get+    let (a, newStore) = runState x (mapInfo fst store)+    put $ mapInfo (, snd $ getInfo $ store) newStore+    return a+ -- | Update the value of a key in the store. The function takes both the current -- value (the first parameter of type @v@) and the new value (the second -- parameter of type @v@), and can potentially avoid touching the store if the@@ -38,23 +54,25 @@ -- | This scheduler constructs the dependency graph of the target key by -- extracting all (static) dependencies upfront, and then traversing the graph -- in the topological order, rebuilding keys using the supplied rebuilder.-topological :: Ord k => Rebuilder Applicative i k v -> Build Applicative i k v-topological rebuilder tasks key = execState $ forM_ chain $ \k ->-    case tasks k of-        Nothing   -> return ()-        Just task -> do-            value <- gets (getValue k)-            let newTask = rebuilder k value (unwrap @Applicative task)-                newFetch :: k -> StateT i (State (Store i k v)) v-                newFetch = lift . gets . getValue-            info <- gets getInfo-            (newValue, newInfo) <- runStateT (newTask newFetch) info-            modify $ putInfo newInfo . updateValue k value newValue+topological :: forall i k v. Ord k => Scheduler Applicative i i k v+topological rebuilder tasks target = execState $ mapM_ build order   where-    deps  = maybe [] (\t -> A.dependencies $ unwrap @Applicative t) . tasks-    chain = case topSort (graph deps key) of+    build :: k -> State (Store i k v) ()+    build key = case tasks key of+        Nothing -> return ()+        Just task -> do+            store <- get+            let value = getValue key store+                newTask :: Task (MonadState i) k v+                newTask = rebuilder key value task+                fetch :: k -> State i v+                fetch k = return (getValue k store)+            newValue <- liftStore (run newTask fetch)+            modify $ updateValue key value newValue+    order = case topSort (graph deps target) of         Nothing -> error "Cannot build tasks with cyclic dependencies"         Just xs -> xs+    deps k = case tasks k of { Nothing -> []; Just task -> dependencies task }  ---------------------------------- Restarting ---------------------------------- -- | Convert a task with a total lookup function @k -> m v@ into a task@@ -63,7 +81,7 @@ -- where the result @Left e@ indicates that the task failed, e.g. because of a -- failed dependency lookup, and @Right v@ yeilds the value otherwise. try :: Task (MonadState i) k v -> Task (MonadState i) k (Either e v)-try task fetch = runExceptT $ task (ExceptT . fetch)+try task = Task $ \fetch -> runExceptT $ run task (ExceptT . fetch)  -- | The so-called @calculation chain@: the order in which keys were built -- during the previous build, which is used as the best guess for the current@@ -75,29 +93,30 @@ -- changed and a new dependency is still dirty, the corresponding build task is -- abandoned and the key is moved at the end of the calculation chain, so it can -- be restarted when all its dependencies are up to date.-reordering :: forall i k v. Ord k => Rebuilder Monad i k v -> Build Monad (i, Chain k) k v-reordering rebuilder tasks key = execState $ do-    chain    <- snd . getInfo <$> get-    newChain <- go Set.empty $ chain ++ [key | key `notElem` chain]-    modify . mapInfo $ \(i, _) -> (i, newChain)+restarting :: forall ir k v. Ord k => Scheduler Monad (ir, Chain k) ir k v+restarting rebuilder tasks target = execState $ do+    chain    <- gets (snd . getInfo)+    newChain <- liftInfo $ go Set.empty $ chain ++ [target | target `notElem` chain]+    modify . mapInfo $ \(ir, _) -> (ir, newChain)   where-    go :: Set k -> Chain k -> State (Store (i, Chain k) k v) (Chain k)-    go _    []     = return []-    go done (k:ks) = case tasks k of-        Nothing -> (k :) <$> go (Set.insert k done) ks+    go :: Set k -> Chain k -> State (Store ir k v) (Chain k)+    go _    []       = return []+    go done (key:ks) = case tasks key of+        Nothing -> (key :) <$> go (Set.insert key done) ks         Just task -> do             store <- get-            let value = getValue k store-                newTask :: Task (MonadState i) k v-                newTask = rebuilder k value (unwrap @Monad task)-                newFetch :: k -> State i (Either k v)-                newFetch k | k `Set.member` done = return $ Right (getValue k store)-                           | otherwise           = return $ Left k-            case runState (try newTask newFetch) (fst $ getInfo store) of-                (Left dep, _) -> go done $ [ dep | dep `notElem` ks ] ++ ks ++ [k]-                (Right newValue, newInfo) -> do-                    modify $ putInfo (newInfo, []) . updateValue k value newValue-                    (k :) <$> go (Set.insert k done) ks+            let value = getValue key store+                newTask :: Task (MonadState ir) k (Either k v)+                newTask = try $ rebuilder key value task+                fetch :: k -> State ir (Either k v)+                fetch k | k `Set.member` done = return $ Right (getValue k store)+                        | otherwise           = return $ Left k+            result <- liftStore (run newTask fetch)+            case result of+                Left dep -> go done $ dep : filter (/= dep) ks ++ [key]+                Right newValue -> do+                    modify $ updateValue key value newValue+                    (key :) <$> go (Set.insert key done) ks  -- | An item in the queue comprises a key that needs to be built and a list of -- keys that are blocked on it. More efficient implementations are possible,@@ -118,74 +137,81 @@ dequeue []          = Nothing dequeue ((k, bs):q) = Just (k, bs, q) --- | Check if a key is dirty by examining its dependencies, as well as the--- stored build information.-type IsDirty i k v = k -> Store i k v -> Bool- -- | A model of the scheduler used by Bazel. We extract a key K from the queue -- and try to build it. There are now two cases: -- 1. The build fails because one of the dependencies of K is dirty. In this --    case we add the dirty dependency to the queue, listing K as blocked by it. -- 2. The build succeeds, in which case we add all keys that were previously --    blocked by K to the queue.-restarting :: forall i k v. Eq k => IsDirty i k v -> Rebuilder Monad i k v -> Build Monad i k v-restarting isDirty rebuilder tasks key = execState $ go (enqueue key [] mempty)+restarting2 :: forall k v. (Hashable v, Eq k) => Scheduler Monad (CT k v) (CT k v) k v+restarting2 rebuilder tasks target = execState $ go (enqueue target [] mempty)   where-    go :: Queue k -> State (Store i k v) ()+    go :: Queue k -> State (Store (CT k v) k v) ()     go queue = case dequeue queue of         Nothing -> return ()-        Just (k, bs, q) -> case tasks k of+        Just (key, bs, q) -> case tasks key of             Nothing -> return () -- Never happens: we have no inputs in the queue             Just task -> do                 store <- get-                let value = getValue k store-                    upToDate k = isInput tasks k || not (isDirty k store)-                    newTask :: Task (MonadState i) k v-                    newTask = rebuilder k value (unwrap @Monad task)-                    newFetch :: k -> State i (Either k v)-                    newFetch k | upToDate k = return (Right (getValue k store))-                               | otherwise  = return (Left k)-                case runState (try newTask newFetch) (getInfo store) of-                    (Left dirtyDependency, _) -> go (enqueue dirtyDependency (k:bs) q)-                    (Right newValue, newInfo) -> do-                        modify $ putInfo newInfo . updateValue k value newValue+                let value = getValue key store+                    upToDate k = isInput tasks k || not (isDirtyCT k store)+                    newTask :: Task (MonadState (CT k v)) k (Either k v)+                    newTask = try $ rebuilder key value task+                    fetch :: k -> State (CT k v) (Either k v)+                    fetch k | upToDate k = return (Right (getValue k store))+                            | otherwise  = return (Left k)+                result <- liftStore (run newTask fetch)+                case result of+                    Left dep -> go (enqueue dep (key:bs) q)+                    Right newValue -> do+                        modify $ updateValue key value newValue                         go (foldr (\b -> enqueue b []) q bs) ------------------------------------ Recursive ------------------------------------- | This scheduler builds keys recursively: to build a key it first makes sure--- that all its dependencies are up to date and then executes the key's task.+---------------------------------- Suspending ----------------------------------+-- | This scheduler builds keys recursively: to build a key it executes the+-- associated task, discovering its dependencies on the fly, and if one of the+-- dependencies is dirty, the task is suspended until the dependency is rebuilt. -- It stores the set of keys that have already been built as part of the state -- to avoid executing the same task twice.-recursive :: forall i k v. Ord k => Rebuilder Monad i k v -> Build Monad i k v-recursive rebuilder tasks key store = fst $ execState (fetch key) (store, Set.empty)+suspending :: forall i k v. Ord k => Scheduler Monad i i k v+suspending rebuilder tasks target store = fst $ execState (fetch target) (store, Set.empty)   where     fetch :: k -> State (Store i k v, Set k) v-    fetch key = case tasks key of-        Nothing -> gets (getValue key . fst)-        Just task -> do-            done <- gets snd-            when (key `Set.notMember` done) $ do+    fetch key = do+        done <- gets snd+        case tasks key of+            Just task | key `Set.notMember` done -> do                 value <- gets (getValue key . fst)-                let newTask = rebuilder key value (unwrap @Monad task)-                    newFetch :: k -> StateT i (State (Store i k v, Set k)) v-                    newFetch = lift . fetch-                info <- gets (getInfo . fst)-                (newValue, newInfo) <- runStateT (newTask newFetch) info-                modify $ \(s, done) ->-                    ( putInfo newInfo $ updateValue key value newValue s-                    , Set.insert key done )-            gets (getValue key . fst)+                let newTask :: Task (MonadState i) k v+                    newTask = rebuilder key value task+                newValue <- liftRun newTask fetch+                modify $ \(s, d) -> (updateValue key value newValue s, Set.insert key d)+                return newValue+            _ -> gets (getValue key . fst) -- fetch the existing value +-- | Run a @Task (MonadState i)@ using a fetch callback operating on a larger+-- state that contains a @Store i k v@ plus some @extra@ information.+liftRun :: Task (MonadState i) k v+        -> (k -> State (Store i k v, extra) v) -> State (Store i k v, extra) v+liftRun t f = unwrap $ run t (Wrap . f)++newtype Wrap i extra k v a = Wrap { unwrap :: State (Store i k v, extra) a }+    deriving (Functor, Applicative, Monad)++instance MonadState i (Wrap i extra k v) where+    get   = Wrap $ gets (getInfo . fst)+    put i = Wrap $ modify $ \(store, extra) -> (putInfo i store, extra)+ -- | An incorrect scheduler that builds the target key without respecting its -- dependencies. It produces the correct result only if all dependencies of the -- target key are up to date.-independent :: forall i k v. Eq k => Rebuilder Monad i k v -> Build Monad i k v-independent rebuilder tasks key store = case tasks key of+independent :: forall i k v. Eq k => Scheduler Monad i i k v+independent rebuilder tasks target store = case tasks target of     Nothing -> store     Just task ->-        let value   = getValue key store-            newTask = rebuilder key value (unwrap @Monad task)-            newFetch :: k -> State i v-            newFetch k = return (getValue k store)-            (newValue, newInfo) = runState (newTask newFetch) (getInfo store)-        in putInfo newInfo $ updateValue key value newValue store+        let value   = getValue target store+            newTask = rebuilder target value task+            fetch :: k -> State i v+            fetch k = return (getValue k store)+            (newValue, newInfo) = runState (run newTask fetch) (getInfo store)+        in putInfo newInfo $ updateValue target value newValue store

@@ -1,55 +1,56 @@-{-# LANGUAGE ConstraintKinds, FlexibleContexts, RankNTypes, ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | This module defines two different strategies of self-tracking, based--- around the idea of storing task descriptions that can be parsed into a Task.+-- around the idea of storing task descriptions that can be parsed into a 'Task'. ----- * For Monad it works out beautifully. You just store the rule on the disk,---   and depend on it.+-- * For 'Monad' it works out beautifully. You just store the rule on the disk,+-- and depend on it. ----- * For Applicative, we generate a fresh Task each time, but have that Task---   depend on a fake version of the rules. This is a change in the Task, but---   it's one for which the standard implementations tend to cope with just fine.---   Most Applicative systems with self-tracking probably do it this way.+-- * For 'Applicative', we generate a fresh 'Task' each time, but have that+-- 'Task' depend on a fake version of the rules. This is a change in the 'Task',+-- but it's one for which the standard implementations tend to cope with just+-- fine. Most applicative systems with self-tracking probably do it this way. module Build.SelfTracking (     Key (..), Value (..), selfTrackingM, selfTrackingA     ) where  import Build.Task --- We assume that the fetch passed to a Task is consistent and returns values+-- | We assume that the fetch passed to a Task is consistent and returns values -- matching the keys. It is possible to switch to typed tasks to check this -- assumption at compile time, e.g. see "Build.Task.Typed". data Key k     = Key k   | KeyTask k data Value v t = Value v | ValueTask t --- Fetch a value+-- | Fetch a value. fetchValue :: Functor f => (Key k -> f (Value v t)) -> k -> f v fetchValue fetch key = extract <$> fetch (Key key)   where     extract (Value v) = v     extract _ = error "Inconsistent fetch" --- Fetch a task description+-- | Fetch a task description. fetchValueTask :: Functor f => (Key k -> f (Value v t)) -> k -> f t fetchValueTask fetch key = extract <$> fetch (KeyTask key)   where     extract (ValueTask t) = t     extract _ = error "Inconsistent fetch" --- | A model using Monad, works beautifully and allows storing the key on the disk.-selfTrackingM :: (t -> Task Monad k v) -> Tasks Monad k t -> Tasks Monad (Key k) (Value v t)+-- | A model for 'Monad', works beautifully and allows storing the key on the+-- disk.+selfTrackingM :: forall k v t. (t -> Task Monad k v) -> Tasks Monad k t -> Tasks Monad (Key k) (Value v t) selfTrackingM _      _     (KeyTask _) = Nothing -- Task keys are inputs selfTrackingM parser tasks (Key     k) = runTask <$> tasks k   where     -- Fetch the task description, parse it, and then run the obtained task-    runTask act fetch = do-        task <- parser <$> act (fetchValueTask fetch)-        Value <$> task (fetchValue fetch)+    runTask :: Task Monad k t -> Task Monad (Key k) (Value v t)+    runTask act = Task $ \fetch -> do+        task <- parser <$> run act (fetchValueTask fetch)+        Value <$> run task (fetchValue fetch) --- | The Applicative model requires every key to be able to associate with its+-- | The applicative model requires every key to be able to associate with its -- environment (e.g. a reader somewhere). Does not support cutoff if a key changes. selfTrackingA :: (t -> Task Applicative k v) -> (k -> t) -> Tasks Applicative (Key k) (Value v t) selfTrackingA _      _   (KeyTask _) = Nothing -- Task keys are inputs-selfTrackingA parser ask (Key k) = Just $ \fetch ->-    fetch (KeyTask k) *> (Value <$> parser (ask k) (fetchValue fetch))+selfTrackingA parser ask (Key k) = Just $ Task $ \fetch ->+    fetch (KeyTask k) *> (Value <$> run (parser $ ask k) (fetchValue fetch))

@@ -6,10 +6,10 @@     dumb, busy, memo,      -- * Applicative build systems-    make, ninja, bazel, buck,+    make, ninja, cloudBuild, buck,      -- * Monadic build systems-    excel, shake, cloudShake, nix+    excel, shake, cloudShake, bazel, nix     ) where  import Control.Monad.State@@ -18,6 +18,7 @@ import Build.Scheduler import Build.Store import Build.Rebuilder+import Build.Task import Build.Trace  -- | This is not a correct build system: given a target key, it simply rebuilds@@ -34,55 +35,60 @@     fetch :: k -> State (Store () k v) v     fetch k = case tasks k of         Nothing   -> gets (getValue k)-        Just task -> do v <- task fetch; modify (putValue k v); return v+        Just task -> do v <- run task fetch; modify (putValue k v); return v  -- | This is a correct but non-minimal build system: it will rebuild keys even -- if they are up to date. However, it performs memoization, therefore it never -- builds a key twice. memo :: Ord k => Build Monad () k v-memo = recursive perpetualRebuilder+memo = suspending perpetualRebuilder  -- | A model of Make: an applicative build system that uses file modification -- times to check if a key is up to date.-make :: forall k v. Ord k => Build Applicative (MakeInfo k) k v+make :: Ord k => Build Applicative (MakeInfo k) k v make = topological modTimeRebuilder  -- | A model of Ninja: an applicative build system that uses verifying traces -- to check if a key is up to date. ninja :: (Ord k, Hashable v) => Build Applicative (VT k v) k v-ninja = topological vtRebuilder+ninja = topological (adaptRebuilder vtRebuilder) -type ExcelInfo k = (ApproximationInfo k, Chain k)+-- | Excel stores a dirty bit per key and a calc chain.+type ExcelInfo k = (k -> Bool, Chain k)  -- | A model of Excel: a monadic build system that stores the calculation chain -- from the previuos build and approximate dependencies. excel :: Ord k => Build Monad (ExcelInfo k) k v-excel = reordering approximationRebuilder+excel = restarting dirtyBitRebuilder  -- | A model of Shake: a monadic build system that uses verifying traces to -- check if a key is up to date.-shake :: (Ord k, Hashable v) => Build Monad (Step, ST k v) k v-shake = recursive stRebuilder+shake :: (Ord k, Hashable v) => Build Monad (VT k v) k v+shake = suspending vtRebuilder  -- | A model of Bazel: a monadic build system that uses constructive traces -- to check if a key is up to date as well as for caching build results. Note -- that Bazel currently does not allow users to write monadic build rules: only -- built-in rules have access to dynamic dependencies. bazel :: (Ord k, Hashable v) => Build Monad (CT k v) k v-bazel = restarting isDirtyCT ctRebuilder+bazel = restarting2 ctRebuilder  -- | A model of Cloud Shake: a monadic build system that uses constructive -- traces to check if a key is up to date as well as for caching build results. cloudShake :: (Ord k, Hashable v) => Build Monad (CT k v) k v-cloudShake = recursive ctRebuilder+cloudShake = suspending ctRebuilder --- | A model of Buck: an applicative build system that uses deterministic--- constructive traces to check if a key is up to date as well as for caching--- build results.-buck :: (Hashable k, Hashable v) => Build Applicative (DCT k v) k v-buck = topological dctRebuilder+-- | A model of CloudBuild: an applicative build system that uses constructive+-- traces to check if a key is up to date as well as for caching build results.+cloudBuild :: (Ord k, Hashable v) => Build Applicative (CT k v) k v+cloudBuild = topological (adaptRebuilder ctRebuilder) --- | A model of Nix: a monadic build system that uses deterministic constructive+-- | A model of Buck: an applicative build system that uses deep constructive -- traces to check if a key is up to date as well as for caching build results.-nix :: (Hashable k, Hashable v) => Build Monad (DCT k v) k v-nix = recursive dctRebuilder+buck :: (Ord k, Hashable v) => Build Applicative (DCT k v) k v+buck = topological (adaptRebuilder dctRebuilder)++-- | A model of Nix: a monadic build system that uses deep constructive traces+-- to check if a key is up to date as well as for caching build results.+nix :: (Ord k, Hashable v) => Build Monad (DCT k v) k v+nix = suspending dctRebuilder

@@ -1,11 +1,9 @@-{-# LANGUAGE ConstraintKinds, RankNTypes, StandaloneDeriving #-}-{-# OPTIONS_GHC -Wno-unused-top-binds #-}+{-# LANGUAGE ConstraintKinds, RankNTypes #-}  -- | The Task abstractions.-module Build.Task (Task, Tasks) where+module Build.Task (Task (..), Tasks, compose, liftTask, liftTasks) where  import Control.Applicative-import Control.Monad.Trans.Reader  -- Ideally we would like to write: --@@ -15,36 +13,31 @@ -- Alas, we can't since it requires impredicative polymorphism and GHC currently -- does not support it. ----- A usual workaround is to wrap 'Task' into a newtype, but this leads to the+-- As a common workaround, we wrap 'Task' into a newtype, but this leads to the -- loss of higher-rank polymorphism: for example, we can no longer apply a -- monadic build system to an applicative task description or apply a monadic--- 'trackM' to trace the execution of a 'Task Applicative'. This leads to severe--- code duplication.------ Our workaround is inspired by the @lens@ library, which allows us to keep--- higher-rank polymorphism at the cost of inserting 'unwrap' in a few places--- in our code and using slightly strange definitions of 'Tasks' and 'Task'.--- See "Build.Task.Wrapped".+-- 'track' to trace the execution of a 'Task Applicative'. This leads to code+-- duplication in some places. +-- | A 'Task' is used to compute a value of type @v@, by finding the necessary+-- dependencies using the provided @fetch :: k -> f v@ callback.+newtype Task c k v = Task { run :: forall f. c f => (k -> f v) -> f v }+ -- | 'Tasks' associates a 'Task' with every non-input key. @Nothing@ indicates -- that the key is an input.-type Tasks c k v = forall f. c f => k -> Maybe ((k -> f v) -> f v)---- | A task is used to compute the value of a key, by finding the necessary--- dependencies using the provided @fetch :: k -> f v@ callback.-type Task c k v = forall f. c f => (k -> f v) -> f v+type Tasks c k v = k -> Maybe (Task c k v)  -- | Compose two task descriptions, preferring the first one in case there are -- two tasks corresponding to the same key. compose :: Tasks Monad k v -> Tasks Monad k v -> Tasks Monad k v compose t1 t2 key = t1 key <|> t2 key --- | An alternative type for task descriptions, isomorphic to 'Tasks' as--- demonstrated by functions 'fromTasks' and 'toTasks'.-type Tasks2 c k v = forall f. c f => (k -> f v) -> k -> Maybe (f v)--fromTasks :: Tasks Monad k v -> Tasks2 Monad k v-fromTasks tasks fetch key = ($fetch) <$> tasks key+-- | Lift an applicative task to @Task Monad@. Use this function when applying+-- monadic task combinators to applicative tasks.+liftTask :: Task Applicative k v -> Task Monad k v+liftTask (Task task) = Task task -toTasks :: Tasks2 Monad k v -> Tasks Monad k v-toTasks tasks2 key = runReaderT <$> tasks2 (\k -> ReaderT ($k)) key+-- | Lift a collection of applicative tasks to @Tasks Monad@. Use this function+-- when building applicative tasks with a monadic build system.+liftTasks :: Tasks Applicative k v -> Tasks Monad k v+liftTasks = fmap (fmap liftTask)

@@ -1,5 +1,3 @@-{-# LANGUAGE RankNTypes #-}- -- | Applicative tasks, as used by Make, Ninja and other applicative build -- systems. Dependencies of applicative tasks are known statically, before their -- execution.@@ -11,4 +9,4 @@  -- | Find the dependencies of an applicative task. dependencies :: Task Applicative k v -> [k]-dependencies task = getConst $ task (\k -> Const [k])+dependencies task = getConst $ run task (\k -> Const [k])

@@ -1,44 +0,0 @@-{-# LANGUAGE DeriveFunctor, RankNTypes #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}---- | The \"free\" structures for dependencies, providing either an applicative--- interface (for 'Depend') or a monadic interface (for 'Depends'). By passing--- them to a suitable 'Task' you can reconstruct all necessary dependencies.-module Build.Task.Depend (toDepend, Depend (..), toDepends, Depends (..)) where--import Build.Task------------------------------- Free Task Applicative -------------------------------- | A list of dependencies, and a function that when applied to those--- dependencies produces the result.-data Depend k v r = Depend [k] ([v] -> r)-    deriving Functor--instance Applicative (Depend k v) where-    pure v = Depend [] (\[] -> v)-    Depend d1 f1 <*> Depend d2 f2 = Depend (d1++d2) $-        \vs -> let (v1,v2) = splitAt (length d1) vs in f1 v1 $ f2 v2--toDepend :: Task Applicative k v -> Depend k v v-toDepend f = f $ \k -> Depend [k] $ \[v] -> v---------------------------------- Free Task Monad ----------------------------------- | A list of dependencies, and a function that when applied to those--- dependencies either the result or more dependencies.-data Depends k v r = Depends [k] ([v] -> Depends k v r)-                   | Done r-    deriving Functor--instance Applicative (Depends k v) where-    pure = return-    f1 <*> f2 = f2 >>= \v -> ($ v) <$> f1--instance Monad (Depends k v) where-    return = Done-    Done x >>= f = f x-    Depends ds op >>= f = Depends ds $ \vs -> f =<< op vs--toDepends :: Task Monad k v -> Depends k v v-toDepends f = f $ \k -> Depends [k] $ \[v] -> Done v

@@ -1,5 +1,3 @@-{-# LANGUAGE RankNTypes #-}- -- | Functorial tasks, which have exactly one statically known dependency. -- Docker is an example of a functorial build system: Docker containers are -- organised in layers, where each layer makes changes to the previous one.@@ -11,4 +9,4 @@  -- | Find the dependency of a functorial task. dependency :: Task Functor k v -> k-dependency task = getConst $ task Const+dependency task = getConst $ run task Const

@@ -1,9 +1,11 @@-{-# LANGUAGE RankNTypes, ScopedTypeVariables, TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | Monadic tasks, as used by Excel, Shake and other build systems. -- Dependencies of monadic tasks can only be discovered dynamically, i.e. during -- their execution.-module Build.Task.Monad (track, trackM, isInput, compute, partial, exceptional) where+module Build.Task.Monad (+    track, trackPure, isInput, computePure, compute, partial, exceptional+    ) where  import Control.Monad.Trans import Control.Monad.Trans.Except@@ -12,34 +14,42 @@ import Data.Functor.Identity import Data.Maybe +import Build.Store import Build.Task  -- | Execute a monadic task on a pure store @k -> v@, tracking the dependencies.-track :: Task Monad k v -> (k -> v) -> (v, [k])-track task fetch = runWriter $ task (\k -> writer (fetch k, [k]))+trackPure :: Task Monad k v -> (k -> v) -> (v, [k])+trackPure task fetch = runWriter $ run task (\k -> writer (fetch k, [k]))  -- | Execute a monadic task using an effectful fetch function @k -> m v@, -- tracking the dependencies.-trackM :: forall m k v. Monad m => Task Monad k v -> (k -> m v) -> m (v, [k])-trackM task fetch = runWriterT $ task trackingFetch+track :: forall m k v. Monad m => Task Monad k v -> (k -> m v) -> m (v, [(k, v)])+track task fetch = runWriterT $ run task trackingFetch   where-    trackingFetch :: k -> WriterT [k] m v-    trackingFetch k = tell [k] >> lift (fetch k)+    trackingFetch :: k -> WriterT [(k, v)] m v+    trackingFetch k = do+        v <- lift $ fetch k+        tell [(k, v)]+        return v  -- | Given a description of tasks, check if a key is input.-isInput :: forall k v. Tasks Monad k v -> k -> Bool-isInput tasks key = isNothing (tasks key :: Maybe ((k -> Maybe v) -> Maybe v))+isInput :: Tasks Monad k v -> k -> Bool+isInput tasks = isNothing . tasks  -- | Run a task with a pure lookup function.-compute :: Task Monad k v -> (k -> v) -> v-compute task store = runIdentity $ task (Identity . store)+computePure :: Task Monad k v -> (k -> v) -> v+computePure task store = runIdentity $ run task (Identity . store) +-- | Run a task in a given store.+compute :: Task Monad k v -> Store i k v -> v+compute task store = runIdentity $ run task (\k -> Identity (getValue k store))+ -- | Convert a task with a total lookup function @k -> m v@ into a task with a -- partial lookup function @k -> m (Maybe v)@. This essentially lifts the task -- from the type of values @v@ to @Maybe v@, where the result @Nothing@ -- indicates that the task failed because of a missing dependency. partial :: Task Monad k v -> Task Monad k (Maybe v)-partial task fetch = runMaybeT $ task (MaybeT . fetch)+partial task = Task $ \fetch -> runMaybeT $ run task (MaybeT . fetch)  -- | Convert a task with a total lookup function @k -> m v@ into a task with a -- lookup function that can throw exceptions @k -> m (Either e v)@. This@@ -47,4 +57,4 @@ -- the result @Left e@ indicates that the task failed because of a failed -- dependency lookup, and @Right v@ yeilds the value otherwise. exceptional :: Task Monad k v -> Task Monad k (Either e v)-exceptional task fetch = runExceptT $ task (ExceptT . fetch)+exceptional task = Task $ \fetch -> runExceptT $ run task (ExceptT . fetch)

@@ -1,28 +1,29 @@-{-# LANGUAGE RankNTypes, TypeApplications #-}- -- | A version of monadic tasks with some support for non-determinism. module Build.Task.MonadPlus (random, computeND, correctBuildValue) where  import Control.Monad  import Build.Task-import Build.Task.Wrapped import Build.Store  -- | An example of a non-deterministic task: generate a random number from a -- specified interval. random :: (Int, Int) -> Task MonadPlus k Int-random (low, high) = const $ foldr mplus mzero $ map pure [low..high]+random (low, high) = Task $ const $ foldr mplus mzero $ map pure [low..high]  -- | Run a non-deterministic task with a pure lookup function, listing all -- possible results.-computeND :: Task MonadPlus k v -> (k -> v) -> [v]-computeND task store = task (return . store)+computePureND :: Task MonadPlus k v -> (k -> v) -> [v]+computePureND task store = run task (return . store) +-- | Run a task in a given store.+computeND :: Task MonadPlus k v -> Store i k v -> [v]+computeND task store = computePureND task (flip getValue store)+ -- | Given a description of @tasks@, an initial @store@, and a @result@ produced -- by running a build system on a target @key@, this function returns 'True' if -- the @key@'s value is a possible result of running the associated task. correctBuildValue :: Eq v => Tasks MonadPlus k v -> Store i k v -> Store i k v -> k -> Bool correctBuildValue tasks store result k = case tasks k of-    Nothing -> getValue k result == getValue k store-    Just t -> getValue k result `elem` computeND (unwrap @MonadPlus t) (flip getValue store)+    Nothing   -> getValue k result == getValue k store+    Just task -> getValue k result `elem` computeND task store

@@ -2,7 +2,7 @@ {-# OPTIONS_GHC -Wno-unused-top-binds #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} --- | A Typed version of dependencies where the value type depends on the key.+-- | A model of polymorphic tasks, where the value type depends on the key. -- See the source for an example. module Build.Task.Typed (Task, Key (..), showDependencies) where 

@@ -1,68 +0,0 @@-{-# LANGUAGE ConstraintKinds, DeriveFunctor, FlexibleInstances #-}-{-# LANGUAGE RankNTypes, StandaloneDeriving #-}---- | This whole module is just a tiresome workaround for the lack of impredicative--- polymorphism. If GHC adds impredicative polymorphism, we can drop it entirely--- and simplify the rest of the code by removing unnecessary task unwrapping.-module Build.Task.Wrapped (GTask (..), Wrapped, unwrap) where--import Control.Applicative-import Control.Monad--import Build.Task---- | GTask is a generalised Task wrapped in a newtype. It is generalised in the--- sense that it computes a value of type @a@ given a fetch of type @k -> f v@.-newtype GTask c k v a =-    GTask { runGTask :: forall f. c f => (k -> f v) -> f a }--type Wrapped c k v = (k -> GTask c k v v) -> GTask c k v v--unwrap :: forall c k v. Wrapped c k v -> Task c k v-unwrap wrapped = runGTask (wrapped f)-  where-    f :: k -> GTask c k v v-    f k = GTask $ \f -> f k---- Thanks to the generalisation, we can make GTask an instance of many classes-deriving instance Functor (GTask Functor     k v)-deriving instance Functor (GTask Applicative k v)-deriving instance Functor (GTask Alternative k v)-deriving instance Functor (GTask Monad       k v)-deriving instance Functor (GTask MonadPlus   k v)--instance Applicative (GTask Applicative k v) where-    pure x = GTask $ \_ -> pure x-    GTask f <*> GTask x = GTask $ \fetch -> f fetch <*> x fetch--instance Applicative (GTask Alternative k v) where-    pure x = GTask $ \_ -> pure x-    GTask f <*> GTask x = GTask $ \fetch -> f fetch <*> x fetch--instance Applicative (GTask Monad k v) where-    pure x = GTask $ \_ -> pure x-    GTask f <*> GTask x = GTask $ \fetch -> f fetch <*> x fetch--instance Applicative (GTask MonadPlus k v) where-    pure x = GTask $ \_ -> pure x-    GTask f <*> GTask x = GTask $ \fetch -> f fetch <*> x fetch--instance Monad (GTask Monad k v) where-    return x = GTask $ \_ -> return x-    GTask x >>= f = GTask $ \fetch -> x fetch >>= \a -> runGTask (f a) fetch--instance Monad (GTask MonadPlus k v) where-    return x = GTask $ \_ -> return x-    GTask x >>= f = GTask $ \fetch -> x fetch >>= \a -> runGTask (f a) fetch--instance Alternative (GTask Alternative k v) where-    empty = GTask $ \_ -> empty-    GTask x <|> GTask y = GTask $ \fetch -> x fetch <|> y fetch--instance Alternative (GTask MonadPlus k v) where-    empty = GTask $ \_ -> empty-    GTask x <|> GTask y = GTask $ \fetch -> x fetch <|> y fetch--instance MonadPlus (GTask MonadPlus k v) where-    mzero = empty-    mplus = (<|>)

@@ -11,7 +11,7 @@     -- * Constructive traces     CT, isDirtyCT, recordCT, constructCT, -    -- * Constructive traces optimised for deterministic tasks+    -- * Constructive traces optimised for deep tasks     DCT, recordDCT, constructDCT,      -- * Step traces@@ -27,9 +27,9 @@  -- | A trace is parameterised by the types of keys @k@, hashes @h@, as well as the -- result @r@. For verifying traces, @r = h@; for constructive traces, @Hash r = h@.-data Trace k h r = Trace+data Trace k v r = Trace     { key     :: k-    , depends :: [(k, h)]+    , depends :: [(k, Hash v)]     , result  :: r }     deriving Show @@ -37,30 +37,28 @@  -- | An abstract data type for a set of verifying traces equipped with 'recordVT', -- 'verifyVT' and a 'Monoid' instance.-newtype VT k v = VT [Trace k (Hash v) (Hash v)] deriving (Monoid, Semigroup)+newtype VT k v = VT [Trace k v (Hash v)] deriving (Monoid, Semigroup, Show)  -- | Record a new trace for building a @key@ with dependencies @deps@, obtaining -- the hashes of up-to-date values by using @fetchHash@.-recordVT :: (Hashable v, Monad m) => k -> v -> [k] -> (k -> m (Hash v)) -> VT k v -> m (VT k v)-recordVT key value deps fetchHash (VT ts) = do-    hs <- mapM fetchHash deps-    return $ VT $ Trace key (zip deps hs) (hash value) : ts+recordVT :: k -> Hash v -> [(k, Hash v)] -> VT k v -> VT k v+recordVT key valueHash deps (VT ts) = VT $ Trace key deps valueHash : ts  -- | Given a function to compute the hash of a key's current value, -- a @key@, and a set of verifying traces, return 'True' if the @key@ is -- up-to-date.-verifyVT :: (Monad m, Eq k, Hashable v) => k -> v -> (k -> m (Hash v)) -> VT k v -> m Bool-verifyVT key value fetchHash (VT ts) = anyM match ts+verifyVT :: (Monad m, Eq k, Eq v) => k -> Hash v -> (k -> m (Hash v)) -> VT k v -> m Bool+verifyVT key valueHash fetchHash (VT ts) = anyM match ts   where     match (Trace k deps result)-        | k /= key || result /= hash value = return False+        | k /= key || result /= valueHash = return False         | otherwise = andM [ (h==) <$> fetchHash k | (k, h) <- deps ]  ------------------------------ Constructive traces -----------------------------  -- | An abstract data type for a set of constructive traces equipped with -- 'recordCT', 'isDirtyCT', 'constructCT' and a 'Monoid' instance.-newtype CT k v = CT [Trace k (Hash v) v] deriving (Monoid, Semigroup, Show)+newtype CT k v = CT [Trace k v v] deriving (Monoid, Semigroup, Show)  -- | Check if a given @key@ is dirty w.r.t a @store@. isDirtyCT :: (Eq k, Hashable v) => k -> Store (CT k v) k v -> Bool@@ -72,20 +70,15 @@  -- | Record a new trace for building a @key@ with dependencies @deps@, obtaining -- the hashes of up-to-date values by using @fetchHash@.-recordCT :: Monad m => k -> v -> [k] -> (k -> m (Hash v)) -> CT k v -> m (CT k v)-recordCT key value deps fetchHash (CT ts) = do-    hs <- mapM fetchHash deps-    return $ CT $ Trace key (zip deps hs) value : ts+recordCT :: k -> v -> [(k,Hash v)] -> CT k v -> CT k v+recordCT key value deps (CT ts) = CT $ Trace key deps value : ts  -- | Given a function to compute the hash of a key's current value, -- a @key@, and a set of constructive traces, return @Just newValue@ if it is -- possible to reconstruct it from the traces. Prefer reconstructing the -- currenct value, if it matches one of the traces.-constructCT :: (Monad m, Eq k, Eq v) => k -> v -> (k -> m (Hash v)) -> CT k v -> m (Maybe v)-constructCT key value fetchHash (CT ts) = do-    candidates <- catMaybes <$> mapM match ts-    if value `elem` candidates then return $ Just value-                               else return $ listToMaybe candidates+constructCT :: (Monad m, Eq k, Eq v) => k -> (k -> m (Hash v)) -> CT k v -> m [v]+constructCT key fetchHash (CT ts) = catMaybes <$> mapM match ts   where     match (Trace k deps result)         | k /= key  = return Nothing@@ -93,88 +86,66 @@             sameInputs <- andM [ (h==) <$> fetchHash k | (k, h) <- deps ]             return $ if sameInputs then Just result else Nothing ------------------------ Deterministic constructive traces -------------------------- | A tree of dependencies. It would be more efficient to use graphs, but--- trees are simpler and are sufficient for our model.-data Tree a = Leaf a | Node [Tree a]-    deriving (Eq, Foldable, Functor, Ord, Show, Traversable)--instance Hashable a => Hashable (Tree a) where-    hash (Leaf x) = Leaf <$> hash x-    hash (Node x) = Node <$> hash x+--------------------------- Deep constructive traces --------------------------- --- | Invariant: if a DCT contains a trace for a key @k@, then it must also--- contain traces for each of its non-input dependencies. Input keys cannot--- appear in a DCT because they are never built.-newtype DCT k v = DCT [Trace k (Hash (Tree (Hash v))) v] deriving (Monoid, Semigroup)+-- | Our current model has the same representation as 'CT', but requires an+-- additional invariant: if a DCT contains a trace for a key @k@, then it must+-- also contain traces for each of its non-input dependencies.+newtype DCT k v = DCT [Trace k v v] deriving (Monoid, Semigroup, Show)  -- | Extract the tree of input dependencies of a given key.-inputTree :: Eq k => DCT k v -> k -> Tree k-inputTree dct@(DCT ts) key = case [ deps | Trace k deps _ <- ts, k == key ] of-    [] -> Leaf key-    deps:_ -> Node $ map (inputTree dct . fst) deps---- | Like 'inputTree', but replaces each key with the hash of its current value.-inputHashTree :: (Eq k, Monad m) => DCT k v -> (k -> m (Hash v)) -> k -> m (Tree (Hash v))-inputHashTree dct fetchHash = traverse fetchHash . inputTree dct+deepDependencies :: (Eq k, Hashable v) => DCT k v -> Hash v -> k -> [k]+deepDependencies (DCT ts) valueHash key =+    case [ map fst deps | Trace k deps v <- ts, k == key, hash v == valueHash ] of+        []       -> [key] -- The @key@ is an input+        (deps:_) -> deps  -- We assume there is only one record for a pair (k, v)  -- | Record a new trace for building a @key@ with dependencies @deps@, obtaining -- the hashes of up-to-date values from the given @store@.-recordDCT :: forall k v m. (Hashable k, Hashable v, Monad m)+recordDCT :: forall k v m. (Eq k, Hashable v, Monad m)           => k -> v -> [k] -> (k -> m (Hash v)) -> DCT k v -> m (DCT k v)-recordDCT key value deps fetchHash (DCT ts) = do-    hs <- mapM depHash deps-    return $ DCT $ Trace key (zip deps hs) value : ts-  where-    depHash :: k -> m (Hash (Tree (Hash v)))-    depHash depKey = case [ deps | Trace k deps _ <- ts, k == depKey ] of-        [] -> hash . Leaf <$> fetchHash depKey -- depKey is an input-        deps:_ -> return $ fmap Node $ sequenceA $ map snd deps+recordDCT key value deps fetchHash dct@(DCT ts) = do+    let deepDeps = concatMap (deepDependencies dct $ hash value) deps+    hs <- mapM fetchHash deepDeps+    return $ DCT $ Trace key (zip deepDeps hs) value : ts  -- | Given a function to compute the hash of a key's current value,--- a @key@, and a set of deterministic constructive traces, return+-- a @key@, and a set of deep constructive traces, return -- @Just newValue@ if it is possible to reconstruct it from the traces.-constructDCT :: forall k v m. (Hashable k, Hashable v, Monad m)-             => k -> (k -> m (Hash v)) -> DCT k v -> m (Maybe v)-constructDCT key fetchHash dct@(DCT ts) = do-    candidates <- catMaybes <$> mapM match ts-    case candidates of-        []  -> return Nothing-        [v] -> return (Just v)-        _   -> error "Non-determinism detected"-  where-    match :: Trace k (Hash (Tree (Hash v))) v -> m (Maybe v)-    match (Trace k deps result)-        | k /= key  = return Nothing-        | otherwise = do-            sameInputs <- andM [ ((h ==) . hash) <$> inputHashTree dct fetchHash k | (k, h) <- deps ]-            return $ if sameInputs then Just result else Nothing+constructDCT :: forall k v m. (Eq k, Hashable v, Monad m)+             => k -> (k -> m (Hash v)) -> DCT k v -> m [v]+constructDCT key fetchHash (DCT ts) = constructCT key fetchHash (CT ts)  ----------------- Step traces: a refinement of verifying traces ----------------+-- Step traces are an optimised version of the direct implementation of+-- verifying traces (as given by the 'VT' datatype), which is used by Shake.+-- They support the same high-level interface that allows to verify if a key is+-- up to date ('verifyST') as well as record new traces ('recordST').  newtype Step = Step Int deriving (Enum, Eq, Ord, Show) instance Semigroup Step where Step a <> Step b = Step $ a + b instance Monoid Step where mempty = Step 0; mappend = (<>) +data TraceST k r = TraceST k [k] r deriving Show+ -- | A step trace, records the resulting value, the step it last build, the step -- where it changed.-newtype ST k v = ST [Trace k () (Hash v, Step, Step)]+newtype ST k v = ST [TraceST k (Hash v, Step, Step)]     deriving (Monoid, Semigroup, Show) -latestST :: Eq k => k -> ST k v -> Maybe (Trace k () (Hash v, Step, Step))+latestST :: Eq k => k -> ST k v -> Maybe (TraceST k (Hash v, Step, Step)) latestST k (ST ts) = fmap snd $ listToMaybe $ reverse $ sortOn fst-    [(step, t) | t@(Trace k2 _ (_, step, _)) <- ts, k == k2]+    [(step, t) | t@(TraceST k2 _ (_, step, _)) <- ts, k == k2]  -- | Record a new trace for building a @key@ with dependencies @deps@.-recordST :: (Hashable v, Eq k, Monad m) => Step -> k -> v -> [k] -> ST k v -> m (ST k v)-recordST step key value deps (ST ts) = do+recordST :: (Hashable v, Eq k) => Step -> k -> v -> [k] -> ST k v -> ST k v+recordST step key value deps (ST ts) =     let hv = hash value-    let lastChange = case latestST key (ST ts) of+        lastChange = case latestST key (ST ts) of             -- I rebuilt, didn't change, so use the old change time-            Just (Trace _ _ (hv2, _, chng)) | hv2 == hv -> chng+            Just (TraceST _ _ (hv2, _, chng)) | hv2 == hv -> chng             _ -> step-    return $ ST $ Trace key (map (,()) deps) (hash value, step, lastChange) : ts+    in ST $ TraceST key deps (hash value, step, lastChange) : ts  -- | Given a function to compute the hash of a key's current value, -- a @key@, and a set of verifying traces, return 'True' if the @key@ is@@ -183,9 +154,9 @@ verifyST key value demand st = do     me <- latestST key <$> st     case me of-        Just (Trace _ deps (hv, built, _)) | hash value == hv -> do-            mapM_ (demand . fst) deps+        Just (TraceST _ deps (hv, built, _)) | hash value == hv -> do+            mapM_ demand deps             st <- st             -- things with no traces must be inputs, which I'm going to ignore for now...-            return $ and [ built >= chng | Just (Trace _ _ (_, _, chng)) <- map (flip latestST st . fst) deps]+            return $ and [ built >= chng | Just (TraceST _ _ (_, _, chng)) <- map (flip latestST st) deps]         _ -> return False

@@ -1,10 +1,7 @@ -- | General utilities useful in the rest of the package module Build.Utilities (     -- * Graph operations-    graph, reachable, topSort, reach, reachM,--    -- * Logic combinators-    forall, forallM, exists, existsM, (==>)+    graph, reachable, topSort, reach, reachM     ) where  import Algebra.Graph@@ -52,25 +49,3 @@     go xs x | x `elem` xs = return Nothing -- A cycle is detected             | otherwise   = do res <- traverse (go (x:xs)) =<< successors x                                return $ ((x:xs)++) . concat <$> sequence res---- | Check that a predicate holds for all values of @a@.-forall :: (a -> Bool) -> Bool-forall = undefined---- | Check that a monadic predicate holds for all values of @a@.-forallM :: (a -> m Bool) -> m Bool-forallM = undefined---- | Check that a predicate holds for some value of @a@.-exists :: (a -> Bool) -> Bool-exists = undefined---- | Check that a monadic predicate holds for some value of @a@.-existsM :: (a -> m Bool) -> m Bool-existsM = undefined---- | Logical implication.-(==>) :: Bool -> Bool -> Bool-x ==> y = not x || y--infixr 0 ==>

@@ -1,12 +1,9 @@-{-# LANGUAGE Rank2Types #-}- module Examples where  import Build.Task import Control.Applicative import Control.Monad.Fail (MonadFail) - -- | A useful fetch for experimenting with build systems in interactive GHC. fetchIO :: (Show k, Read v) => k -> IO v fetchIO k = do putStr (show k ++ ": "); read <$> getLine@@ -19,7 +16,7 @@ -- For example, if n = 12, the sequence is 3, 10, 5, 16, 8, 4, 2, 1, ... collatz :: Tasks Functor Integer Integer collatz n | n <= 0    = Nothing-          | otherwise = Just $ \fetch -> f <$> fetch (n - 1)+          | otherwise = Just $ Task $ \fetch -> f <$> fetch (n - 1)   where     f k | even k    = k `div` 2         | otherwise = 3 * k + 1@@ -39,7 +36,7 @@ -- (n, m) = (2, 1) we get Lucas sequence: 2, 1, 3, 4, 7, 11, 18, 29, 47, ... fibonacci :: Tasks Applicative Integer Integer fibonacci n-    | n >= 2 = Just $ \fetch -> (+) <$> fetch (n-1) <*> fetch (n-2)+    | n >= 2 = Just $ Task $ \fetch -> (+) <$> fetch (n-1) <*> fetch (n-2)     | otherwise = Nothing  -- Fibonacci numbers are a classic example of memoization: a non-minimal build@@ -58,10 +55,10 @@ ackermann :: Tasks Monad (Integer, Integer) Integer ackermann (n, m)     | m < 0 || n < 0 = Nothing-    | m == 0    = Just $ const $ pure (n + 1)-    | n == 0    = Just $ \fetch -> fetch (m - 1, 1)-    | otherwise = Just $ \fetch -> do index <- fetch (m, n - 1)-                                      fetch (m - 1, index)+    | m == 0    = Just $ Task $ const $ pure (n + 1)+    | n == 0    = Just $ Task $ \fetch -> fetch (m - 1, 1)+    | otherwise = Just $ Task $ \fetch -> do index <- fetch (m, n - 1)+                                             fetch (m - 1, index)  -- Unlike Collatz and Fibonacci computations, the Ackermann computation cannot -- be statically analysed for dependencies. We can only find the first dependency@@ -70,23 +67,33 @@ ----------------------------- Spreadsheet examples -----------------------------  sprsh1 :: Tasks Applicative String Integer-sprsh1 "B1" = Just $ \fetch -> ((+)  <$> fetch "A1" <*> fetch "A2")-sprsh1 "B2" = Just $ \fetch -> ((*2) <$> fetch "B1")+sprsh1 "B1" = Just $ Task $ \fetch -> ((+)  <$> fetch "A1" <*> fetch "A2")+sprsh1 "B2" = Just $ Task $ \fetch -> ((*2) <$> fetch "B1") sprsh1 _    = Nothing  sprsh2 :: Tasks Monad String Integer-sprsh2 "B1" = Just $ \fetch -> do c1 <- fetch "C1"-                                  if c1 == 1 then fetch "B2" else fetch "A2"-sprsh2 "B2" = Just $ \fetch -> do c1 <- fetch "C1"-                                  if c1 == 1 then fetch "A1" else fetch "B1"+sprsh2 "B1" = Just $ Task $ \fetch -> do+    c1 <- fetch "C1"+    if c1 == 1 then fetch "B2" else fetch "A2"+sprsh2 "B2" = Just $ Task $ \fetch -> do+    c1 <- fetch "C1"+    if c1 == 1 then fetch "A1" else fetch "B1" sprsh2 _ = Nothing +sprsh5 :: Tasks Monad String String+sprsh5 "B1" = Just $ Task $ \fetch -> do+    formula <- fetch "B1-formula"+    evalFormula fetch formula+  where+    evalFormula = undefined+sprsh5 _ = Nothing+ sprsh3 :: Tasks Alternative String Integer-sprsh3 "B1" = Just $ \fetch -> (+) <$> fetch "A1" <*> (pure 1 <|> pure 2)+sprsh3 "B1" = Just $ Task $ \fetch -> (+) <$> fetch "A1" <*> (pure 1 <|> pure 2) sprsh3 _    = Nothing  sprsh4 :: Tasks MonadFail String Integer-sprsh4 "B1" = Just $ \fetch -> do+sprsh4 "B1" = Just $ Task $ \fetch -> do     a1 <- fetch "A1"     a2 <- fetch "A2"     if a2 == 0 then fail "division by 0" else return (a1 `div` a2)@@ -94,29 +101,29 @@  indirect :: Tasks Monad String Integer indirect key | key /= "B1" = Nothing-             | otherwise   = Just $ \fetch -> do c1 <- fetch "C1"-                                                 fetch ("A" ++ show c1)+             | otherwise   = Just $ Task $ \fetch -> do c1 <- fetch "C1"+                                                        fetch ("A" ++ show c1)  staticIF :: Bool -> Tasks Applicative String Int-staticIF b "B1" = Just $ \fetch ->+staticIF b "B1" = Just $ Task $ \fetch ->     if b then fetch "A1" else (+) <$> fetch "A2" <*> fetch "A3" staticIF _ _    = Nothing  -------------------------- Dynamic programming example ------------------------- -data Key = A Integer | B Integer | D Integer Integer+data Key = A Int | B Int | C Int Int deriving Eq -editDistance :: Tasks Monad Key Integer-editDistance (D i 0) = Just $ const $ pure i-editDistance (D 0 j) = Just $ const $ pure j-editDistance (D i j) = Just $ \fetch -> do+editDistance :: Tasks Monad Key Int+editDistance (C i 0) = Just $ Task $ const $ pure i+editDistance (C 0 j) = Just $ Task $ const $ pure j+editDistance (C i j) = Just $ Task $ \fetch -> do     ai <- fetch (A i)     bj <- fetch (B j)     if ai == bj-        then fetch (D (i - 1) (j - 1))+        then fetch (C (i - 1) (j - 1))         else do-            insert  <- fetch (D  i      (j - 1))-            delete  <- fetch (D (i - 1)  j     )-            replace <- fetch (D (i - 1) (j - 1))+            insert  <- fetch (C  i      (j - 1))+            delete  <- fetch (C (i - 1)  j     )+            replace <- fetch (C (i - 1) (j - 1))             return (1 + minimum [insert, delete, replace]) editDistance _ = Nothing

@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, RankNTypes, ConstraintKinds #-}+{-# LANGUAGE OverloadedStrings #-} import Control.Monad import Data.Bool import Data.List.Extra@@ -8,7 +8,6 @@ import qualified Data.Map as Map  import Build-import Build.Rebuilder import Build.Store import Build.System import Build.Task@@ -29,11 +28,11 @@     []     -> store     (k:ks) -> sequentialMultiBuildA build task ks (build task k store) +inputCells :: [Cell]+inputCells = [ "A1", "A2", "A3" ]+ inputs :: i -> Store i Cell Int-inputs i = initialise i $ \cell -> fromMaybe 0 $ lookup cell-    [ ("A1", 1)-    , ("A2", 2)-    , ("A3", 3) ]+inputs i = initialise i $ \cell -> fromMaybe 0 $ lookup cell $ zip inputCells [1..]  spreadsheet :: Spreadsheet spreadsheet cell = case name cell of@@ -75,6 +74,7 @@     let store   = inputs i         result  = sequentialMultiBuild build tasks targets store         correct = all (correctBuild tasks store result) targets+    -- when False $ putStrLn $ "========\n" ++ show (getInfo result) ++ "\n========"     putStr $ name ++ " is "     case (trim name, correct) of         ("dumb", False) -> do putStr "incorrect, which is [OK]\n"; return True@@ -86,6 +86,7 @@     let store   = inputs i         result  = sequentialMultiBuildA build tasksA targets store         correct = all (correctBuild tasks store result) targets+    -- when False $ putStrLn $ "========\n" ++ show (getInfo result) ++ "\n========"     putStrLn $ name ++ " is " ++ bool "incorrect: [FAIL]" "correct: [OK]" correct     return correct @@ -94,9 +95,10 @@     [ test  "dumb      " dumb       ()     , test  "busy      " busy       ()     , test  "memo      " memo       ()-    , testA "make      " make       (Map.empty, 0)+    , testA "make      " make       (0, Map.empty)     , testA "ninja     " ninja      mempty-    , test  "excel     " excel      ((const True, const Unknown), mempty)+    , testA "cloudBuild" cloudBuild mempty+    , test  "excel     " excel      (const True, mempty)     , test  "shake     " shake      mempty     , test  "bazel     " bazel      mempty     , test  "cloudShake" cloudShake mempty

@@ -1,4 +1,3 @@-{-# LANGUAGE RankNTypes #-} module Spreadsheet where  import Data.Bool@@ -11,7 +10,7 @@  -- | A 'Cell' is described by a pair integers: 'row' and 'column'. We provide -- @IsString@ instance for convenience, so @"A8"@ corresponds to @Cell 8 0@.-data Cell = Cell { row :: Int, column :: Int } deriving (Eq, Ord, Show)+data Cell = Cell { row :: Int, column :: Int } deriving (Eq, Ord)  -- | Get the name of a 'Cell', e.g. @name (Cell 8 0) == "A8"@. name :: Cell -> String@@ -29,6 +28,9 @@       where         fail = error $ "Cannot parse cell name " ++ string +instance Show Cell where+    show = name+ instance Hashable Cell where     hash (Cell row column) = Cell <$> hash row <*> hash column @@ -76,12 +78,11 @@ -- the mapping returns @Nothing@ are inputs. type Spreadsheet = Cell -> Maybe Formula --- TODO: Implement 'Random'. -- | Monadic spreadsheet computation. spreadsheetTask :: Spreadsheet -> Tasks Monad Cell Int spreadsheetTask spreadsheet cell@(Cell r c) = case spreadsheet cell of     Nothing      -> Nothing -- This is an input-    Just formula -> Just $ evaluate formula+    Just formula -> Just $ Task $ evaluate formula   where     evaluate formula fetch = go formula       where go formula = case formula of@@ -93,13 +94,13 @@                 IfZero fx fy fz         -> do                     x <- go fx                     if x == 0 then go fy else go fz-                Random _ _      -> error "Random not implemented"+                Random _ _      -> error "Not supported by monadic tasks"  -- | Applicative spreadsheet computation. spreadsheetTaskA :: Spreadsheet -> Tasks Applicative Cell Int spreadsheetTaskA spreadsheet cell@(Cell r c) = case spreadsheet cell of     Nothing      -> Nothing -- This is an input-    Just formula -> Just $ evaluate formula+    Just formula -> Just $ Task $ evaluate formula   where     evaluate formula fetch = go formula       where go formula = case formula of