build 1.0 → 1.1

raw patch · 24 files changed

+764/−234 lines, 24 filesdep ~algebraic-graphsdep ~containersdep ~extraPVP ok

version bump matches the API change (PVP)

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

API changes (from Hackage documentation)

Files

• CHANGES.md +5/−0
• LICENSE +1/−1
• README.md +14/−18
• build.cabal +37/−29
• src/Build.hs +3/−1
• src/Build/Multi.hs +3/−1
• src/Build/Rebuilder.hs +17/−20
• src/Build/Scheduler.hs +21/−19
• src/Build/SelfTracking.hs +9/−10
• src/Build/SelfTracking/Typed.hs +33/−0
• src/Build/System.hs +20/−12
• src/Build/Task.hs +3/−27
• src/Build/Task/Applicative.hs +3/−1
• src/Build/Task/Free.hs +51/−0
• src/Build/Task/Functor.hs +6/−1
• src/Build/Task/Monad.hs +10/−10
• src/Build/Task/MonadPlus.hs +5/−3
• src/Build/Task/Opaque.hs +373/−0
• src/Build/Task/Typed.hs +84/−36
• src/Build/Trace.hs +4/−5
• src/Build/Utilities.hs +3/−3
• test/Examples.hs +47/−27
• test/Main.hs +9/−8
• test/Spreadsheet.hs +3/−2

@@ -0,0 +1,5 @@+# Change log++## 1.0++The version published in ICFP 2018 paper "Build Systems à la Carte".

@@ -1,6 +1,6 @@ MIT License -Copyright (c) 2018 Andrey Mokhov+Copyright (c) 2018-2024 Andrey Mokhov, Neil Mitchell, Simon Peyton Jones  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal

@@ -1,31 +1,27 @@ # Build Systems à la Carte -[![Hackage version](https://img.shields.io/hackage/v/build.svg?label=Hackage)](https://hackage.haskell.org/package/build) [![Linux & OS X status](https://img.shields.io/travis/snowleopard/build/master.svg?label=Linux%20%26%20OS%20X)](https://travis-ci.org/snowleopard/build) [![Windows status](https://img.shields.io/appveyor/ci/snowleopard/build/master.svg?label=Windows)](https://ci.appveyor.com/project/snowleopard/build)+[![Hackage version](https://img.shields.io/hackage/v/build.svg?label=Hackage)](https://hackage.haskell.org/package/build) [![Build status](https://img.shields.io/github/actions/workflow/status/snowleopard/build/ci.yml?branch=main)](https://github.com/snowleopard/build/actions)  This project provides an executable framework for developing and comparing build systems, viewing them as related points in landscape rather than as isolated phenomena. The code derives from the ICFP 2018 paper-["Build Systems à la Carte"](https://github.com/snowleopard/build-systems/releases/download/icfp-submission/build-systems.pdf).+["Build Systems à la Carte"](https://dl.acm.org/citation.cfm?id=3236774)+([PDF](https://dl.acm.org/ft_gateway.cfm?id=3236774)).  ## Getting Started  You may be interested to:  * 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](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 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).+* Look at the [HTML documentation](https://hackage.haskell.org/package/build) of all modules for the last release,+  or generate it yourself using `stack haddock`.+* Read the code, particularly [Build.System](src/Build/System.hs), which is the concrete implementation of+  all build systems. -## Background Information+## Related Material -The task abstraction is explored more completely in-[this blog post](https://blogs.ncl.ac.uk/andreymokhov/the-task-abstraction/), and the motivation behind-the project in [an earlier blog post](https://blogs.ncl.ac.uk/andreymokhov/cloud-and-dynamic-builds/).+* Blog post [on the motivation behind the project](https://blogs.ncl.ac.uk/andreymokhov/cloud-and-dynamic-builds/).+* Blog post [on the task abstraction](https://blogs.ncl.ac.uk/andreymokhov/the-task-abstraction/).+* Blog post [reviewing how the paper was written](https://neilmitchell.blogspot.com/2018/07/inside-paper-build-systems-la-carte.html).+* Talk [by Neil on this paper and Shake](https://ndmitchell.com/#shake_18_may_2018).+* A talk on build systems+  [by Andrey](https://github.com/snowleopard/build/releases/download/icfp-final/build-systems-slides-andrey.pdf).

@@ -1,23 +1,28 @@-name:                build-version:             1.0-synopsis:            Build systems a la carte-homepage:            https://github.com/snowleopard/build-license:             MIT-license-file:        LICENSE-author:              Andrey Mokhov, Neil Mitchell, Simon Peyton Jones-maintainer:          Andrey Mokhov <andrey.mokhov@gmail.com>, github: @snowleopard-copyright:           Andrey Mokhov, Neil Mitchell, Simon Peyton Jones, 2018-category:            Algorithms, Data Structures-build-type:          Simple-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".-cabal-version:       >=1.10+cabal-version: 2.2+name:          build+version:       1.1+synopsis:      Build Systems à la Carte+homepage:      https://github.com/snowleopard/build+bug-reports:   https://github.com/snowleopard/build/issues+license:       MIT+license-file:  LICENSE+author:        Andrey Mokhov, Neil Mitchell, Simon Peyton Jones+maintainer:    Andrey Mokhov <andrey.mokhov@gmail.com>, github: @snowleopard+copyright:     Andrey Mokhov, Neil Mitchell, Simon Peyton Jones, 2018-2024+category:      Algorithms, Data Structures+build-type:    Simple+description:   A library for experimenting with build systems and incremental+               computation frameworks, based on the ideas presented in the ICFP+               2018 paper "Build Systems à la Carte".+tested-with:   GHC==9.8.2, GHC==9.6.3, GHC==9.4.7, GHC==9.2.8 +extra-doc-files:+    CHANGES.md+    README.md+ source-repository head   type:     git-  location: https://github.com/snowleopard/build+  location: https://github.com/snowleopard/build.git  library   hs-source-dirs:       src@@ -25,27 +30,30 @@                         Build.Multi,                         Build.Rebuilder,                         Build.SelfTracking,+                        Build.SelfTracking.Typed,                         Build.Scheduler,                         Build.Store,                         Build.Task,                         Build.Task.Applicative,+                        Build.Task.Free,                         Build.Task.Functor,                         Build.Task.Monad,                         Build.Task.MonadPlus,+                        Build.Task.Opaque,                         Build.Task.Typed,                         Build.Trace,                         Build.System   other-modules:        Build.Utilities-  build-depends:        algebraic-graphs >= 0.1.1   && < 0.2,+  build-depends:        algebraic-graphs >= 0.5     && < 0.8,                         base             >= 4.7     && < 5,-                        containers       >= 0.5.7.1 && < 0.6,-                        extra            >= 1.5.3   && < 1.7,+                        containers       >= 0.6     && < 0.7,+                        extra            >= 1.5.3   && < 1.8,                         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+                        mtl              >= 2.2.1   && < 2.4,+                        random           >= 1.1     && < 1.3,+                        transformers     >= 0.5.2.0 && < 0.7   default-language:     Haskell2010-  GHC-options:          -Wall+  ghc-options:          -Wall                         -fno-warn-name-shadowing                         -Wcompat                         -Wincomplete-record-updates@@ -60,12 +68,12 @@                         Spreadsheet     build-depends:      build,                         base         >= 4.7     && < 5,-                        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+                        containers   >= 0.6     && < 0.7,+                        extra        >= 1.5.3   && < 1.8,+                        mtl          >= 2.2.1   && < 2.4,+                        transformers >= 0.5.2.0 && < 0.7     default-language:   Haskell2010-    GHC-options:        -Wall+    ghc-options:        -Wall                         -fno-warn-name-shadowing                         -Wcompat                         -Wincomplete-record-updates

@@ -1,3 +1,5 @@+{-# LANGUAGE ImpredicativeTypes, ConstraintKinds #-}+ -- | Build systems and the properties they should ensure. module Build (     -- * Build@@ -26,7 +28,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 [] (\task -> snd $ trackPure task (flip getValue result)) . tasks+    deps = maybe [] (\task -> snd $ trackPure task (`getValue` result)) . tasks     correct k = case tasks k of         Nothing   -> getValue k result == getValue k store         Just task -> getValue k result == compute task result

@@ -1,3 +1,5 @@+{-# LANGUAGE ImpredicativeTypes #-}+ -- | Support for multiple-output tasks. module Build.Multi (Partition, multi) where @@ -17,7 +19,7 @@ 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 $ Task $ \fetch ->+    | otherwise = Just $ \fetch ->         sequenceA [ select k <$> fetch (partition k) | k <- keys ]   where     select k = fromMaybe (error msg) . lookup k . zip (partition k)

@@ -1,15 +1,16 @@-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ConstraintKinds, KindSignatures, ImpredicativeTypes, FlexibleContexts #-}  -- | Rebuilders take care of deciding whether a key needs to be rebuild and -- running the corresponding task if need be. module Build.Rebuilder (-    Rebuilder, adaptRebuilder, perpetualRebuilder,+    Rebuilder, perpetualRebuilder,     modTimeRebuilder, Time, MakeInfo,     dirtyBitRebuilder, dirtyBitRebuilderWithCleanUp,     approximateRebuilder, ApproximateDependencies, ApproximationInfo,     vtRebuilder, stRebuilder, ctRebuilder, dctRebuilder     ) where +import Control.Monad import Control.Monad.State import Data.Map (Map) import Data.Set (Set)@@ -28,13 +29,9 @@ -- 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 $ run task+perpetualRebuilder :: Rebuilder Monad i k v+perpetualRebuilder _key _value task = task  ------------------------------------- Make ------------------------------------- type Time = Integer@@ -43,7 +40,7 @@ -- | 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 = Task $ \fetch -> do+modTimeRebuilder key value task fetch = do     (now, modTimes) <- get     let dirty = case Map.lookup key modTimes of             Nothing -> True@@ -52,22 +49,22 @@     then return value     else do         put (now + 1, Map.insert key now modTimes)-        run task fetch+        task fetch  ----------------------------------- 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+dirtyBitRebuilder key value task fetch = do     isDirty <- get-    if isDirty key then run task fetch else return value+    if isDirty key then task fetch else return value  -- | 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+dirtyBitRebuilderWithCleanUp key value task fetch = do     isDirty <- get     if key `Set.notMember` isDirty then return value else do         put (Set.delete key isDirty)-        run task fetch+        task fetch  --------------------------- Approximate dependencies --------------------------- -- | If there is an entry for a key, it is an conservative approximation of its@@ -81,7 +78,7 @@ -- | This rebuilders uses approximate dependencies to decide whether a key -- needs to be rebuilt. approximateRebuilder :: (Ord k, Eq v) => Rebuilder Monad (ApproximationInfo k) k v-approximateRebuilder key value task = Task $ \fetch -> do+approximateRebuilder key value task fetch = do     (dirtyKeys, deps) <- get     let dirty = key `Set.member` dirtyKeys ||                 case Map.lookup key deps of Nothing -> True@@ -89,14 +86,14 @@     if not dirty     then return value     else do-        newValue <- run task fetch+        newValue <- 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 = Task $ \fetch -> do+vtRebuilder key value task fetch = do     upToDate <- verifyVT key (hash value) (fmap hash . fetch) =<< get     if upToDate     then return value@@ -108,7 +105,7 @@ ------------------------------ Constructive traces ----------------------------- -- | This rebuilder relies on constructive traces. ctRebuilder :: (Eq k, Hashable v) => Rebuilder Monad (CT k v) k v-ctRebuilder key value task = Task $ \fetch -> do+ctRebuilder key value 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@@ -122,7 +119,7 @@ --------------------------- 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+dctRebuilder key value 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@@ -136,7 +133,7 @@ ------------------------------- 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 = Task $ \fetch -> do+stRebuilder key value task fetch = do     upToDate <- verifyST key value (void . fetch) (gets snd)     if upToDate     then return value

@@ -1,8 +1,9 @@-{-# LANGUAGE FlexibleContexts, RankNTypes, ScopedTypeVariables, TupleSections #-}-{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+{-# LANGUAGE ImpredicativeTypes, FlexibleContexts, ScopedTypeVariables, TupleSections #-}+{-# LANGUAGE FlexibleInstances, ConstraintKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}  -- | Build schedulers execute task rebuilders in the right order. module Build.Scheduler (+    Scheduler,     topological,     restarting, Chain,     restarting2,@@ -12,6 +13,7 @@  import Control.Monad.State import Control.Monad.Trans.Except+import Data.Bifunctor import Data.Set (Set)  import Build@@ -39,16 +41,16 @@ liftInfo x = do     store <- get     let (a, newStore) = runState x (mapInfo fst store)-    put $ mapInfo (, snd $ getInfo $ store) newStore+    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--- value is unchanged. The current implementation simply ignores the current--- value, but in future this may be optimised, e.g. by comparing their hashes.+-- value (the first argument of type @v@) and the new value (the second argument+-- of type @v@), and can potentially avoid touching the store if the value is+-- unchanged. The current implementation simply ignores the current value, but+-- in future this may be optimised, e.g. by comparing their hashes. updateValue :: Eq k => k -> v -> v -> Store i k v -> Store i k v-updateValue key _value newValue = putValue key newValue+updateValue key _current_value = putValue key  ---------------------------------- Topological --------------------------------- -- | This scheduler constructs the dependency graph of the target key by@@ -67,21 +69,21 @@                 newTask = rebuilder key value task                 fetch :: k -> State i v                 fetch k = return (getValue k store)-            newValue <- liftStore (run newTask fetch)+            newValue <- liftStore (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 }+    deps k = maybe [] dependencies (tasks k)  ---------------------------------- Restarting ---------------------------------- -- | 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 -- essentially lifts the task from the type of values @v@ to @Either e v@, -- 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.+-- failed dependency lookup, and @Right v@ yields the value otherwise. try :: Task (MonadState i) k v -> Task (MonadState i) k (Either e v)-try task = Task $ \fetch -> runExceptT $ run task (ExceptT . fetch)+try task fetch = runExceptT $ 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@@ -111,7 +113,7 @@                 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)+            result <- liftStore (newTask fetch)             case result of                 Left dep -> go done $ dep : filter (/= dep) ks ++ [key]                 Right newValue -> do@@ -160,12 +162,12 @@                     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)+                result <- liftStore (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)+                        go (foldr (`enqueue` []) q bs)  ---------------------------------- Suspending ---------------------------------- -- | This scheduler builds keys recursively: to build a key it executes the@@ -185,7 +187,7 @@                 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)+                modify $ bimap (updateValue key value newValue) (Set.insert key)                 return newValue             _ -> gets (getValue key . fst) -- fetch the existing value @@ -193,14 +195,14 @@ -- 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)+liftRun t f = unwrap $ 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)+    put i = Wrap $ modify $ first (putInfo i)  -- | An incorrect scheduler that builds the target key without respecting its -- dependencies. It produces the correct result only if all dependencies of the@@ -213,5 +215,5 @@             newTask = rebuilder target value task             fetch :: k -> State i v             fetch k = return (getValue k store)-            (newValue, newInfo) = runState (run newTask fetch) (getInfo store)+            (newValue, newInfo) = runState (newTask fetch) (getInfo store)         in putInfo newInfo $ updateValue target value newValue store

@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables, ImpredicativeTypes #-}  -- | This module defines two different strategies of self-tracking, based -- around the idea of storing task descriptions that can be parsed into a 'Task'.@@ -36,21 +36,20 @@     extract (ValueTask t) = t     extract _ = error "Inconsistent fetch" --- | A model for 'Monad', works beautifully and allows storing the key on the--- disk.+-- | A model for 'Monad', works beautifully and allows storing the key on 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+selfTrackingM _          _     (KeyTask _) = Nothing -- Task keys are inputs+selfTrackingM taskParser tasks (Key     k) = runTask <$> tasks k   where     -- Fetch the task description, parse it, and then run the obtained task     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)+    runTask task fetch = do+        task <- task (fetchValueTask fetch)+        Value <$> taskParser task (fetchValue fetch)  -- | 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 $ Task $ \fetch ->-    fetch (KeyTask k) *> (Value <$> run (parser $ ask k) (fetchValue fetch))+selfTrackingA parser ask (Key k) = Just $ \fetch ->+    fetch (KeyTask k) *> (Value <$> (parser $ ask k) (fetchValue fetch))

@@ -0,0 +1,33 @@+{-# LANGUAGE GADTs, ImpredicativeTypes, ConstraintKinds, ScopedTypeVariables #-}++module Build.SelfTracking.Typed (+    Fetch, TaskT (..), TasksT, Key (..), selfTracking+  ) where++import Build.Task++type Fetch k f = forall v. k v -> f v++newtype TaskT c k v = TaskT { runT :: forall f. c f => Fetch k f -> f v }++type TasksT c k = forall v. k v -> Maybe (TaskT c k v)++-- | The type variable @s@ stands for "scripts" written in some task description+-- language.+data Key k v s a where+    Script :: k -> Key k v s s -- Keys for build scripts+    Value  :: k -> Key k v s v -- Keys for all other values++selfTracking :: forall k v s. (s -> Task Monad k v) -> Tasks Monad k s -> TasksT Monad (Key k v s)+selfTracking parse tasks key = case key of+    Script k -> getScript <$> tasks k+    Value  k -> runScript <$> tasks k+  where+    -- Get the task for building the script+    getScript :: Task Monad k s -> TaskT Monad (Key k v s) s+    getScript task = TaskT $ \fetch -> task (fetch . Script)+    -- Build the script, parse it, and then run the obtained task+    runScript :: Task Monad k s -> TaskT Monad (Key k v s) v+    runScript task = TaskT $ \fetch -> do+        script <- task (fetch . Script)+        parse script (fetch . Value)

@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ImpredicativeTypes, FlexibleContexts, ScopedTypeVariables #-}  -- | Models of several build systems. module Build.System (@@ -18,7 +18,6 @@ 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@@ -28,14 +27,14 @@  -- | This is a correct but non-minimal build system: given a target key it -- recursively rebuilds its dependencies, even if they are already up to date.--- There is no memoisation, therefore the a key may be built multiple times.+-- There is no memoisation, therefore a key may be built multiple times. busy :: forall k v. Eq k => Build Monad () k v-busy tasks key store = execState (fetch key) store+busy tasks key = execState (fetch key)   where     fetch :: k -> State (Store () k v) v     fetch k = case tasks k of         Nothing   -> gets (getValue k)-        Just task -> do v <- run task fetch; modify (putValue k v); return v+        Just task -> do v <- 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@@ -50,14 +49,17 @@  -- | 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 (adaptRebuilder vtRebuilder)+ninja :: forall k v. (Ord k, Hashable v) => Build Applicative (VT k v) k v+ninja = topological rebuilder+  where+    rebuilder :: Rebuilder Applicative (VT k v) k v+    rebuilder = vtRebuilder  -- | 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.+-- from the previous build and approximate dependencies. excel :: Ord k => Build Monad (ExcelInfo k) k v excel = restarting dirtyBitRebuilder @@ -80,13 +82,19 @@  -- | 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)+cloudBuild :: forall k v. (Ord k, Hashable v) => Build Applicative (CT k v) k v+cloudBuild = topological rebuilder+  where+    rebuilder :: Rebuilder Applicative (CT k v) k v+    rebuilder = ctRebuilder  -- | 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.-buck :: (Ord k, Hashable v) => Build Applicative (DCT k v) k v-buck = topological (adaptRebuilder dctRebuilder)+buck :: forall k v. (Ord k, Hashable v) => Build Applicative (DCT k v) k v+buck = topological rebuilder+  where+    rebuilder :: Rebuilder Applicative (DCT k v) k v+    rebuilder = 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.

@@ -1,27 +1,13 @@-{-# LANGUAGE ConstraintKinds, RankNTypes #-}+{-# LANGUAGE ImpredicativeTypes, ConstraintKinds #-}  -- | The Task abstractions.-module Build.Task (Task (..), Tasks, compose, liftTask, liftTasks) where+module Build.Task (Task, Tasks, compose) where  import Control.Applicative --- Ideally we would like to write:------    type Tasks c k v = k -> Maybe (Task c k v)---    type Task  c k v = forall f. c f => (k -> f v) -> f v------ Alas, we can't since it requires impredicative polymorphism and GHC currently--- does not support it.------ 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--- '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 }+type Task c k v = 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.@@ -31,13 +17,3 @@ -- 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---- | 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---- | 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,3 +1,5 @@+{-# LANGUAGE ImpredicativeTypes #-}+ -- | Applicative tasks, as used by Make, Ninja and other applicative build -- systems. Dependencies of applicative tasks are known statically, before their -- execution.@@ -9,4 +11,4 @@  -- | Find the dependencies of an applicative task. dependencies :: Task Applicative k v -> [k]-dependencies task = getConst $ run task (\k -> Const [k])+dependencies task = getConst $ task (\k -> Const [k])

@@ -0,0 +1,51 @@+{-# LANGUAGE ImpredicativeTypes, DeriveFunctor #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++-- | The free description of tasks.+module Build.Task.Free (+    Rule (..), toRule, fromRule, Action (..), toAction, fromAction+  ) where++import Build.Task+import Control.Monad++------------------------- Isomorphism with Make's Rule -------------------------+data Rule k v r = Rule [k] ([v] -> r)+    deriving Functor++instance Applicative (Rule k v) where+    pure v = Rule [] (\[] -> v)+    Rule d1 f1 <*> Rule d2 f2 = Rule (d1++d2) $ \vs ->+        let (v1,v2) = splitAt (length d1) vs in f1 v1 $ f2 v2++getRule :: k -> Rule k v v+getRule k = Rule [k] $ \[v] -> v++toRule :: Task Applicative k v -> Rule k v v+toRule task = task getRule++fromRule :: Rule k v v -> Task Applicative k v+fromRule (Rule ds f) fetch = f <$> traverse fetch ds++------------------------ Isomorphism with Shake's Action -----------------------+data Action k v a = Finished a+                  | Depends k (v -> Action k v a)+    deriving Functor++instance Applicative (Action k v) where+    pure  = Finished+    (<*>) = ap++instance Monad (Action k v) where+    return = pure+    Finished x    >>= f = f x+    Depends ds op >>= f = Depends ds (op >=> f)++toAction :: Task Monad k v -> Action k v v+toAction task = task $ \k -> Depends k Finished++fromAction :: Action k v v -> Task Monad k v+fromAction x fetch = f fetch x+  where+    f _     (Finished v  ) = return v+    f fetch (Depends d op) = fetch d >>= f fetch . op

@@ -1,12 +1,17 @@+{-# LANGUAGE ImpredicativeTypes, CPP #-} -- | 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. module Build.Task.Functor (dependency) where +#if __GLASGOW_HASKELL__ < 800+import Control.Applicative+#else import Data.Functor.Const+#endif  import Build.Task  -- | Find the dependency of a functorial task. dependency :: Task Functor k v -> k-dependency task = getConst $ run task Const+dependency task = getConst (task Const)

@@ -1,10 +1,10 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ImpredicativeTypes, 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, trackPure, isInput, computePure, compute, partial, exceptional+    track, trackPure, isInput, computePure, compute, liftMaybe, liftEither     ) where  import Control.Monad.Trans@@ -19,12 +19,12 @@  -- | Execute a monadic task on a pure store @k -> v@, tracking the dependencies. trackPure :: Task Monad k v -> (k -> v) -> (v, [k])-trackPure task fetch = runWriter $ run task (\k -> writer (fetch k, [k]))+trackPure task fetch = runWriter $ task (\k -> writer (fetch k, [k]))  -- | Execute a monadic task using an effectful fetch function @k -> m v@, -- tracking the dependencies. 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+track task fetch = runWriterT $ task trackingFetch   where     trackingFetch :: k -> WriterT [(k, v)] m v     trackingFetch k = do@@ -38,23 +38,23 @@  -- | Run a task with a pure lookup function. computePure :: Task Monad k v -> (k -> v) -> v-computePure task store = runIdentity $ run task (Identity . store)+computePure task store = runIdentity $ 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))+compute task store = runIdentity $ 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 = Task $ \fetch -> runMaybeT $ run task (MaybeT . fetch)+liftMaybe :: Task Monad k v -> Task Monad k (Maybe v)+liftMaybe task fetch = runMaybeT $ 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 -- essentially lifts the task from the type of values @v@ to @Either e v@, where -- 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 = Task $ \fetch -> runExceptT $ run task (ExceptT . fetch)+liftEither :: Task Monad k v -> Task Monad k (Either e v)+liftEither task fetch = runExceptT $ task (ExceptT . fetch)

@@ -1,3 +1,5 @@+{-# LANGUAGE ImpredicativeTypes #-}+ -- | A version of monadic tasks with some support for non-determinism. module Build.Task.MonadPlus (random, computeND, correctBuildValue) where @@ -9,16 +11,16 @@ -- | 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) = Task $ const $ foldr mplus mzero $ map pure [low..high]+random (low, high) = const $ msum $ map pure [low..high]  -- | Run a non-deterministic task with a pure lookup function, listing all -- possible results. computePureND :: Task MonadPlus k v -> (k -> v) -> [v]-computePureND task store = run task (return . store)+computePureND task store = 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)+computeND task store = computePureND task (`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

@@ -0,0 +1,373 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ConstraintKinds, RankNTypes, FlexibleInstances, GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Opaque monadic tasks, whose inputs and outputs can be dynamic.+module Build.Task.Opaque where++import Control.Monad+import Control.Monad.State+import Control.Monad.Writer+import Data.List (isInfixOf)+import Debug.Trace+import System.FilePath++-- | Environment variables are identified by names.+type Variable = String++-- | A collection of keys for accessing files, environment variables, and+-- contents of directories. Directories are somewhat magic, because their values+-- are derived from 'File' keys, i.e. creating a new file in a directory+-- requires updating the the corresponding 'Dir' key.+data Key a where+    File :: FilePath -> Key String     -- ^ File contents.+    Env  :: Variable -> Key String     -- ^ Environment variable.+    Dir  :: FilePath -> Key [FilePath] -- ^ Directory contents.++-- | Read a key's value in a computation context @f@.+type Get k f = forall a. k a -> f a++-- | Write a key's value in a computation context @f@. Note: the type can be+-- changed to @forall a. k a -> f a -> f a@ to allow for static analysis of+-- applicative and selective build tasks, since we cannot have @a@ in a static+-- context @f@, e.g. in @Const@. See more details in Section 5.3 of this paper:+-- https://www.staff.ncl.ac.uk/andrey.mokhov/selective-functors.pdf.+type Put k f = forall a. k a -> a -> f ()++-- | A build task is a stateful computation in a monadic context @f@ that is+-- given two callbacks: for reading and writing values to a key/value store.+type Task k a = forall f. Monad f => Get k f -> Put k f -> f a++-- | A unique task identifier, e.g. the path to the corresponding build script.+type TaskName = String++-- | A task along with its unique identifier.+data NamedTask k = NamedTask { taskName :: TaskName, task :: Task k () }++-- | A collection of build tasks using the same read and write interface.+type Tasks k = [NamedTask k]++-- | An example type of "black box" build tasks: we can only find out what they+-- read and write by executing them in a monadic context.+type BlackBox = Task Key ()++-- | Multiple black boxes, e.g. a collection of build scripts lying around.+type BlackBoxes = Tasks Key++-- | An example collection of black boxes.+tasks :: BlackBoxes+tasks = [NamedTask "release" release, NamedTask "build" build]+-- Placing "release" after "build" avoids restarting the "release" task:+-- [NamedTask "build" build, NamedTask "release" release]++-- | A typical build script that compiles a couple of C files, possibly+-- depending on some header files, and then links the resulting objects into an+-- executable.+build :: BlackBox+build get put = do+    compile "src/a.c" "obj/a.o" get put+    compile "src/b.c" "obj/b.o" get put+    link "obj" "out/exe" get put++-- | A script for packaging the contents of the directory @out@ in an archive.+-- Note that if called prematurely, it will miss some of the release files and+-- will /succeed/, yielding an incomplete archive. The task will therefore need+-- to be rerun whenever the key @Dir "out"@ is updated.+release :: BlackBox+release get put = do+    files   <- map ("out/" ++) <$> get (Dir "out")+    archive <- concat <$> mapM (get . File) files+    put (File "release.tar") archive++-- Note: this task doesn't need to be monadic, a selective interface is enough!+-- | Compile a C source file, possibly including the @lib.h@ header.+compile :: FilePath -> FilePath -> BlackBox+compile src obj get put = do+    source <- get (File src)+    header <- if "#include <lib.h>" `isInfixOf` source -- find an #include+         then do+            path <- get (Env "LIBDIR")+            get (File $ path ++ "/lib.h")+         else return ""+    put (File obj) (header ++ source)++-- | Link object files in a given directory, producing an executable. Note that+-- this task can /fail/ if run prematurely i.e. when some object files have not+-- yet been placed in the @obj@ directory, since some symbols will be undefined.+link :: FilePath -> FilePath -> BlackBox+link dir exe get put = do+    objs   <- map ("obj/" ++) <$> get (Dir dir)+    binary <- concat <$> mapM (get . File) objs+    put (File exe) binary++-- | A task execution log entry, recording either a read from a key and the+-- obtained value, or a write to a key, along with the written value.+data LogEntry k where+    GetEntry :: k a -> a -> LogEntry k+    PutEntry :: k a -> a -> LogEntry k++-- | A log is a sequence of log entries, in the execution order.+type Log k = [LogEntry k]++-- TODO: Can we simplify the implementation?+-- | Check if a log contains a 'GetEntry' for a given 'Key'. Useful to detect if+-- a task has a certain input dependency.+hasWrongGet :: Log Key -> Key a -> a -> Bool+hasWrongGet log k a = case k of+    File x -> any (matchesFile x a) log+    Env  x -> any (matchesEnv  x a) log+    Dir  x -> any (matchesDir  x a) log+  where+    matchesFile :: FilePath -> String -> LogEntry Key -> Bool+    matchesFile x a (GetEntry (File y) b) = (x == y) && (a /= b)+    matchesFile _ _ _ = False+    matchesEnv :: Variable -> String -> LogEntry Key -> Bool+    matchesEnv x a (GetEntry (Env y) b) = (x == y) && (a /= b)+    matchesEnv _ _ _ = False+    matchesDir :: FilePath -> [FilePath] -> LogEntry Key -> Bool+    matchesDir x a (GetEntry (Dir y) b) = (x == y) && (a /= b)+    matchesDir _ _ _ = False++{- Example execution of task 'build' in GHCi:++> log <- execute getIO putIO build+Get : File "src/a.c" = a+Put : File "obj/a.o" = a+Get : File "src/b.c" = b...#include <lib.h>...+Get : Env "LIBDIR" = libs+Get : File "libs/lib.h" = lib...+Put : File "obj/b.o" = lib...b...#include <lib.h>...+Get : Dir "obj" = ["a.o", "b.o", "c.o"]+Get : File "a.o" = 123+Get : File "b.o" = 456+Get : File "c.o" = 789+Put : File "out/exe" = 123456789++> log+[ Get (File "src/a.c", "a")+, Put (File "obj/a.o", "a")+, Get (File "src/b.c", "b...#include <lib.h>...")+, Get (Env "LIBDIR", "libs")+, Get (File "libs/lib.h", "lib...")+, Put (File "obj/b.o", "lib...b...#include <lib.h>...")+, Get (Dir "obj", ["a.o","b.o","c.o"])+, Get (File "a.o", "123")+, Get (File "b.o", "456")+, Get (File "c.o", "789")+, Put (File "out/exe", "123456789") ]++-}++-- TODO: Note that at the moment logging does not account for modifying+-- directories when creating new files.+-- | Execute a monadic task using given callbacks 'Get' and 'Put', logging all+-- reads and writes.+execute :: forall m k. Monad m => Get k m -> Put k m -> Task k () -> m (Log k)+execute get put task = execWriterT $ task loggingGet loggingPut+  where+    loggingGet :: k a -> WriterT (Log k) m a+    loggingGet k = do+        a <- lift $ get k+        tell [GetEntry k a]+        return a+    loggingPut :: k a -> a -> WriterT (Log k) m ()+    loggingPut k a = do+        lift $ put k a+        tell [PutEntry k a]++-- | An association of keys to values.+newtype Store = Store { getValue :: forall a. Key a -> a }++putValue :: Key a -> a -> Store -> Store+putValue (File x) a (Store f) = Store $ \k -> case k of+    File y | x == y -> a+    _ -> f k+putValue (Env x) a (Store f) = Store $ \k -> case k of+    Env y | x == y -> a+    _ -> f k+putValue (Dir x) a (Store f) = Store $ \k -> case k of+    Dir y | x == y -> a+    _ -> f k++-- | An example store with the following contents:+--+-- File "src/a.c"    -> "a"+-- File "src/b.c"    -> "b...#include <lib.h>..."+-- File "obj/main.o" -> "...main..."+-- File "lib/lib.h"  -> "lib..."+-- File "out/README" -> "This is a README..."+-- Env "LIBDIR"      -> "lib"+-- Dir "obj"         -> ["main.o"]+-- Dir "out"         -> ["README"]+exampleStore :: Store+exampleStore = Store $ \case+    File "src/a.c"    -> "a"+    File "src/b.c"    -> "b...#include <lib.h>..."+    File "obj/main.o" -> "...main..."+    File "lib/lib.h"  -> "lib..."+    File "out/README" -> "This is a README..."+    Env "LIBDIR"      -> "lib"+    Dir "obj"         -> ["main.o"]+    Dir "out"         -> ["README"]++    File _ -> "<empty file>"+    Env  _ -> "<empty variable>"+    Dir  _ -> [] -- empty directory++-- | Known information about build task dependencies.+type Graph = TaskName -> Maybe (Log Key)++-- | A build system that builds a collection of black box tasks by executing+-- them blindly, and recording the resulting dependencies.+blindBuild :: BlackBoxes -> Store -> Graph -> (Store, Graph)+blindBuild tasks store graph = fst $ execState build ((store, graph), tasks)+  where+    build :: State ((Store, Graph), BlackBoxes) ()+    build = do+      queue <- gets snd+      case queue of+        [] -> return ()+        (NamedTask id task : tasks) -> do+          -- Remove the first task from the queue+          modify $ \((s, g), _) -> ((s, g), tasks)+          -- Execute the task, possibly restaring some previously executed tasks+          log <- trace ("Execute " ++ id) $ execute get put task+          modify $ \((s, g), ts) -> let ng t = if t == id then Just log else g t+                                   in ((s, ng), ts)+          -- Build the rest of the queue+          build++    -- Simply return whatever is in the store.+    get :: Key a -> State ((Store, Graph), BlackBoxes) a+    get k = do+        store <- gets (fst . fst)+        let a = getValue store k+        trace ("Get (" ++ showKey k ++ ", " ++ showValue k a ++ ")") $ return a++    -- Update the value, and restart any tasks which depended on it but have+    -- been executed too early.+    put :: Key a -> a -> State ((Store, Graph), BlackBoxes) ()+    put k a = do+        -- Update the store+        trace ("Put (" ++ showKey k ++ ", " ++ showValue k a ++ ")") $+            modify $ \((s, g), bs) -> ((putValue k a s, g), bs)+        -- Restart any tasks which depended on this key+        graph <- gets (snd . fst)+        queue <- gets snd+        forM_ tasks $ \task@(NamedTask id _) -> case graph id of+            Nothing  -> return ()+            Just log -> when (hasWrongGet log k a && id `notInQueue` queue) $+                trace ("Restart " ++ id) $+                    modify $ \((s, g), bs) -> ((s, g), bs ++ [task])+        -- Make sure to update the corresponding directory key if a new file has+        -- been created+        case k of+            File path -> do+                let dir  = takeDirectory path+                    file = takeFileName path+                store <- gets (fst . fst)+                let files = getValue store (Dir dir)+                when (file `notElem` files) $ put (Dir dir) (files ++ [file])+            _ -> return ()++    -- Check that a task does not appear in a queue+    notInQueue :: TaskName -> BlackBoxes -> Bool+    notInQueue _  []     = True+    notInQueue id (t:ts) | id == taskName t = False+                         | otherwise        = notInQueue id ts++{- Example blind build++> res = blindBuild tasks exampleStore (const Nothing)+> res `seq` ()++Execute release+Get (Dir "out", ["README"])+Get (File "out/README", "This is a README...")+Put (File "release.tar", "This is a README...")+Put (Dir ".", ["release.tar"])+Execute build+Get (File "src/a.c", "a")+Put (File "obj/a.o", "a")+Put (Dir "obj", ["main.o","a.o"])+Get (File "src/b.c", "b...#include <lib.h>...")+Get (Env "LIBDIR", "lib")+Get (File "lib/lib.h", "lib...")+Put (File "obj/b.o", "lib...b...#include <lib.h>...")+Put (Dir "obj", ["main.o","a.o","b.o"])+Get (Dir "obj", ["main.o","a.o","b.o"])+Get (File "obj/main.o", "...main...")+Get (File "obj/a.o", "a")+Get (File "obj/b.o", "lib...b...#include <lib.h>...")+Put (File "out/exe", "...main...alib...b...#include <lib.h>...")+Put (Dir "out", ["README","exe"])+Restart release+Execute release+Get (Dir "out", ["README","exe"])+Get (File "out/README", "This is a README...")+Get (File "out/exe", "...main...alib...b...#include <lib.h>...")+Put (File "release.tar", "This is a README......main...alib...b...#include <lib.h>...")++> snd res "release"++Just [ Get (Dir "out", ["README","exe"])+     , Get (File "out/README", "This is a README...")+     , Get (File "out/exe", "alib...b...#include <lib.h>...<empty file>")+     , Put (File "release.tar", "This is a README...alib...b...#include <lib.h>...<empty file>")]++> snd res "build"++Just [ Get (File "src/a.c", "a")+     , Put (File "obj/a.o", "a")+     , Get (File "src/b.c", "b...#include <lib.h>...")+     , Get (Env "LIBDIR", "lib")+     , Get (File "lib/lib.h", "lib...")+     , Put (File "obj/b.o", "lib...b...#include <lib.h>...")+     , Get (Dir "obj", ["main.o","a.o","b.o"])+     , Get (File "obj/main.o", "...main...")+     , Get (File "obj/a.o", "a")+     , Get (File "obj/b.o", "lib...b...#include <lib.h>...")+     , Put (File "out/exe", "...main...alib...b...#include <lib.h>...")]++-}++---------------------------- Some boilerplate code -----------------------------++-- | A way to show the name of a key.+type ShowKey k = forall a. k a -> String++-- | A simple pretty-printer for the data type 'Key'.+showKey :: ShowKey Key+showKey (File f) = "File " ++ show f+showKey (Env  v) = "Env "  ++ show v+showKey (Dir  d) = "Dir "  ++ show d++-- | Show a value corresponding to a key, extracting an appropriate 'Show'+-- instance from it.+showValue :: Key a -> a -> String+showValue (File _) f = show f+showValue (Env  _) v = show v+showValue (Dir  _) d = show d++instance Show (LogEntry Key) where+    show (GetEntry k@(File _) a) = "Get (" ++ showKey k ++ ", " ++ show a ++ ")"+    show (GetEntry k@(Env  _) a) = "Get (" ++ showKey k ++ ", " ++ show a ++ ")"+    show (GetEntry k@(Dir  _) a) = "Get (" ++ showKey k ++ ", " ++ show a ++ ")"++    show (PutEntry k@(File _) a) = "Put (" ++ showKey k ++ ", " ++ show a ++ ")"+    show (PutEntry k@(Env  _) a) = "Put (" ++ showKey k ++ ", " ++ show a ++ ")"+    show (PutEntry k@(Dir  _) a) = "Put (" ++ showKey k ++ ", " ++ show a ++ ")"++----------------------------- Auxiliary functions ------------------------------++-- | A 'Get' in 'IO' for GHCi experiments.+getIO :: Get Key IO+getIO (File f) = putStr ("Get : File " ++ show f ++ " = ") >> getLine+getIO (Env  v) = putStr ("Get : Env " ++ show v ++ " = ") >> getLine+getIO (Dir  d) = putStr ("Get : Dir " ++ show d ++ " = ") >> (read <$> getLine)++-- | A 'Put' in 'IO' for GHCi experiments.+putIO :: Put Key IO+putIO (File f) x = putStr ("Put : File " ++ show f ++ " = ") >> putStrLn x+putIO (Env  v) x = putStr ("Put : Env " ++ show v ++ " = ") >> putStrLn x+putIO (Dir  d) x = putStr ("Put : Dir " ++ show d ++ " = ") >> print x

@@ -1,58 +1,106 @@-{-# LANGUAGE ConstraintKinds, RankNTypes, GADTs, TypeFamilies #-}+{-# LANGUAGE CPP, ConstraintKinds, RankNTypes, GADTs #-}+#if __GLASGOW_HASKELL__ < 800+{-# OPTIONS_GHC -Wno-unused-binds #-}+#else {-# OPTIONS_GHC -Wno-unused-top-binds #-}+#endif {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}  -- | 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+module Build.Task.Typed (Task, dependencies) where +#if __GLASGOW_HASKELL__ < 800+import Control.Applicative+#else import Data.Functor.Const-import Data.Functor.Identity+#endif --- | A type class for keys, equipped with an associated type family that--- can be used to determine the type of value corresponding to the key.-class Key k where-    type Value k :: *-    -- | The name of the key. Useful for avoiding heterogeneous lists of keys.-    showKey :: k -> String+-- | The @fetch@ callback whose result type depends on the type of the key.+type Fetch k f = forall a. k a -> f a  -- | A typed build task.-type Task c k = forall f. c f => (forall k. Key k => k -> f (Value k)) -> k -> Maybe (f (Value k))+--+-- A side observation: we could also rewrite the type of `Task` into+--+-- type Task c k = forall f. c f => (forall a. k a -> f a) -> (forall a. k a -> Maybe (f a))+--+-- ...which looks like a morphism between natural transformations. I'll let+-- category theory enthusiasts explain what this strange creature is doing here.+type Task c k = forall f a. c f => Fetch k f -> k a -> Maybe (f a) +-- | A way to show the name of a key.+type ShowKey k = forall a. k a -> String+ -- | Extract the names of dependencies.-showDependencies :: Task Applicative k -> k -> [String]-showDependencies task = maybe [] getConst . task (\k -> Const [showKey k])+dependencies :: ShowKey k -> Task Applicative k -> k a -> [String]+dependencies showKey task = maybe [] getConst . task (\k -> Const [showKey k]) ------------------------------------- Example ------------------------------------data ExampleKey a where-    Base       :: ExampleKey Int-    Number     :: ExampleKey Int-    SplitDigit :: ExampleKey (Int, Int)-    LastDigit  :: ExampleKey Int-    BaseDigits :: ExampleKey [Int]+----------------------------- GCC versison example -----------------------------+data Version = Version { major :: Int, minor :: Int }+    deriving (Eq, Ord) -instance Show (ExampleKey a) where-    show key = case key of-        Base       -> "Base"-        Number     -> "Number"-        SplitDigit -> "SplitDigit"-        LastDigit  -> "LastDigit"-        BaseDigits -> "BaseDigits"+data Key a where+    File       :: FilePath -> Key String+    GccVersion :: Key Version -instance Key (ExampleKey a) where-    type Value (ExampleKey a) = a-    showKey = show+newtype TaskT c k v = TaskT { runT :: forall f. c f => Fetch k f -> f v } -digits :: Task Applicative (ExampleKey a)-digits fetch SplitDigit = Just $ divMod <$> fetch Number <*> fetch Base-digits fetch LastDigit  = Just $ snd <$> fetch SplitDigit-digits fetch BaseDigits = Just $ enumFromTo 1 <$> fetch Base-digits _ _ = Nothing+type TasksT c k = forall a. k a -> Maybe (TaskT c k a) -fetch :: ExampleKey t -> Identity (Value (ExampleKey t))-fetch key = Identity $ case key of+example :: TasksT Monad Key+example (File "release.txt") = Just $ TaskT $ \fetch -> do+    readme  <- fetch (File "README")+    license <- fetch (File "LICENSE")+    return (readme ++ license)+example (File "main.o") = Just $ TaskT $ \fetch -> do+    let source = "main.c"+    version <- fetch GccVersion+    if version >= Version 8 0 then compileNew source+                              else compileOld source+example _ = Nothing++compileNew :: String -> f String+compileNew = undefined++compileOld :: String -> f String+compileOld = undefined++------------------------------------ Example -----------------------------------+data KeyN a where+    Base       :: KeyN Int+    Number     :: KeyN Int+    SplitDigit :: KeyN (Int, Int)+    LastDigit  :: KeyN Int+    BaseDigits :: KeyN [Int]++-- | A build task for some simple typed numeric calculations. We can perform+-- static analysis of this task using the function 'dependencies'. For example:+--+-- @+-- dependencies showKey task Base       == []+-- dependencies showKey task SplitDigit == ["Number","Base"]+-- @+task :: Task Applicative KeyN+task fetch SplitDigit = Just $ divMod <$> fetch Number <*> fetch Base+task fetch LastDigit  = Just $ snd <$> fetch SplitDigit+task fetch BaseDigits = Just $ (\b -> [0..(b - 1)]) <$> fetch Base+task _ _ = Nothing++-- | An example key/value mapping consistent with the build 'task'.+fetch :: Applicative f => Fetch KeyN f+fetch key = pure $ case key of     Base       -> 10     Number     -> 2018     SplitDigit -> (201, 8)     LastDigit  -> 8     BaseDigits -> [0..9]++-- | Show the name of a key.+showKey :: ShowKey KeyN+showKey key = case key of+    Base       -> "Base"+    Number     -> "Number"+    SplitDigit -> "SplitDigit"+    LastDigit  -> "LastDigit"+    BaseDigits -> "BaseDigits"

@@ -1,5 +1,4 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables #-}-{-# LANGUAGE DeriveTraversable, TupleSections #-}  -- | Build traces that are used for recording information from previuos builds. module Build.Trace (@@ -21,9 +20,9 @@ import Build.Store  import Control.Monad.Extra+import Data.List (sortOn) import Data.Maybe-import Data.List-import Data.Semigroup+import Data.Ord  -- | 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@.@@ -134,7 +133,7 @@     deriving (Monoid, Semigroup, Show)  latestST :: Eq k => k -> ST k v -> Maybe (TraceST k (Hash v, Step, Step))-latestST k (ST ts) = fmap snd $ listToMaybe $ reverse $ sortOn fst+latestST k (ST ts) = fmap snd $ listToMaybe $ sortOn (Down . fst)     [(step, t) | t@(TraceST k2 _ (_, step, _)) <- ts, k == k2]  -- | Record a new trace for building a @key@ with dependencies @deps@.@@ -158,5 +157,5 @@             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 (TraceST _ _ (_, _, chng)) <- map (flip latestST st) deps]+            return $ and [ built >= chng | Just (TraceST _ _ (_, _, chng)) <- map (`latestST` st) deps]         _ -> return False

@@ -5,9 +5,9 @@     ) where  import Algebra.Graph-import qualified Algebra.Graph.AdjacencyMap as AM-import qualified Algebra.Graph.Class        as C+import qualified Algebra.Graph.ToGraph as T +import Data.Either.Extra import Data.Functor.Identity import qualified Data.Set as Set @@ -28,7 +28,7 @@ -- | Compute the topological sort of a graph or return @Nothing@ if the graph -- has cycles. topSort :: Ord k => Graph k -> Maybe [k]-topSort = AM.topSort . C.toGraph+topSort = eitherToMaybe . T.topSort  -- | Given a function to compute successors of a vertex, apply it recursively -- starting from a given vertex. Returns @Nothing@ if this process does not

@@ -1,22 +1,24 @@+{-# LANGUAGE ConstraintKinds, ImpredicativeTypes, FlexibleContexts, GADTs #-} module Examples where  import Build.Task import Control.Applicative-import Control.Monad.Fail (MonadFail)+import Control.Monad.State.Class+import Data.Map (Map) +import qualified Data.Map as Map+ -- | 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  --------------------------- Task Functor: Collatz --------------------------- --- Collatz sequence:--- c[0] = n--- c[k] = f(c[k - 1]) where--- For example, if n = 12, the sequence is 3, 10, 5, 16, 8, 4, 2, 1, ...+-- Collatz sequence, starting with an initial value n = c[0].+-- For example, if n = 6, the sequence is 6, 3, 10, 5, 16, 8, 4, 2, 1, ... collatz :: Tasks Functor Integer Integer collatz n | n <= 0    = Nothing-          | otherwise = Just $ Task $ \fetch -> f <$> fetch (n - 1)+          | otherwise = Just $ \fetch -> f <$> fetch (n - 1)   where     f k | even k    = k `div` 2         | otherwise = 3 * k + 1@@ -36,7 +38,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 $ Task $ \fetch -> (+) <$> fetch (n-1) <*> fetch (n-2)+    | n >= 2 = Just $ \fetch -> (+) <$> fetch (n-1) <*> fetch (n-2)     | otherwise = Nothing  -- Fibonacci numbers are a classic example of memoization: a non-minimal build@@ -53,13 +55,31 @@ -- Formally, it has no inputs, but we return Nothing for negative inputs. -- For example, a[m, 1] = 2, 3, 5, 13, 65535, ... ackermann :: Tasks Monad (Integer, Integer) Integer-ackermann (n, m)+ackermann (m, n)     | m < 0 || n < 0 = Nothing-    | 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)+    | 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) +-- A cloud version of the Ackermann task that uses a cache to store known values+-- of the Ackermann function.+type Cache = Map (Integer, Integer) Integer++cloudAckermann :: Tasks (MonadState Cache) (Integer, Integer) Integer+cloudAckermann (m, n)+    | m < 0 || n < 0 = Nothing+    | m == 0    = Just $ const $ pure (n + 1)+    | n == 0    = Just $ \fetch -> fetch (m - 1, 1)+    | otherwise = Just $ \fetch -> do+        cache <- get+        case Map.lookup (m, n) cache of+            Nothing -> do index <- fetch (m, n - 1)+                          value <- fetch (m - 1, index)+                          modify (Map.insert (m, n) value)+                          return value+            Just value -> return value+ -- Unlike Collatz and Fibonacci computations, the Ackermann computation cannot -- be statically analysed for dependencies. We can only find the first dependency -- statically (Ackermann m (n - 1)), but not the second one.@@ -67,21 +87,21 @@ ----------------------------- Spreadsheet examples -----------------------------  sprsh1 :: Tasks Applicative String Integer-sprsh1 "B1" = Just $ Task $ \fetch -> ((+)  <$> fetch "A1" <*> fetch "A2")-sprsh1 "B2" = Just $ Task $ \fetch -> ((*2) <$> fetch "B1")+sprsh1 "B1" = Just $ \fetch -> (+)  <$> fetch "A1" <*> fetch "A2"+sprsh1 "B2" = Just $ \fetch -> (*2) <$> fetch "B1" sprsh1 _    = Nothing  sprsh2 :: Tasks Monad String Integer-sprsh2 "B1" = Just $ Task $ \fetch -> do+sprsh2 "B1" = Just $ \fetch -> do     c1 <- fetch "C1"     if c1 == 1 then fetch "B2" else fetch "A2"-sprsh2 "B2" = Just $ Task $ \fetch -> do+sprsh2 "B2" = Just $ \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+sprsh5 "B1" = Just $ \fetch -> do     formula <- fetch "B1-formula"     evalFormula fetch formula   where@@ -89,11 +109,11 @@ sprsh5 _ = Nothing  sprsh3 :: Tasks Alternative String Integer-sprsh3 "B1" = Just $ Task $ \fetch -> (+) <$> fetch "A1" <*> (pure 1 <|> pure 2)+sprsh3 "B1" = Just $ \fetch -> (+) <$> fetch "A1" <*> (pure 1 <|> pure 2) sprsh3 _    = Nothing  sprsh4 :: Tasks MonadFail String Integer-sprsh4 "B1" = Just $ Task $ \fetch -> do+sprsh4 "B1" = Just $ \fetch -> do     a1 <- fetch "A1"     a2 <- fetch "A2"     if a2 == 0 then fail "division by 0" else return (a1 `div` a2)@@ -101,22 +121,22 @@  indirect :: Tasks Monad String Integer indirect key | key /= "B1" = Nothing-             | otherwise   = Just $ Task $ \fetch -> do c1 <- fetch "C1"-                                                        fetch ("A" ++ show c1)+             | otherwise   = Just $ \fetch -> do c1 <- fetch "C1"+                                                 fetch ("A" ++ show c1)  staticIF :: Bool -> Tasks Applicative String Int-staticIF b "B1" = Just $ Task $ \fetch ->+staticIF b "B1" = Just $ \fetch ->     if b then fetch "A1" else (+) <$> fetch "A2" <*> fetch "A3" staticIF _ _    = Nothing  -------------------------- Dynamic programming example ------------------------- -data Key = A Int | B Int | C Int Int deriving Eq+data K = A Int | B Int | C Int Int deriving Eq -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+editDistance :: Tasks Monad K Int+editDistance (C i 0) = Just $ const $ pure i+editDistance (C 0 j) = Just $ const $ pure j+editDistance (C i j) = Just $ \fetch -> do     ai <- fetch (A i)     bj <- fetch (B j)     if ai == bj

@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, ImpredicativeTypes, ConstraintKinds #-} import Control.Monad import Data.Bool import Data.List.Extra@@ -11,11 +11,12 @@ import Build.Store import Build.System import Build.Task+import Build.Task.Free()  import Spreadsheet import Examples() --- | A build system that acceptes a list of target keys.+-- | A build system that accepts a list of target keys. type MultiBuild c i k v = Tasks c k v -> [k] -> Store i k v -> Store i k v  sequentialMultiBuild :: Build Monad i k v -> MultiBuild Monad i k v@@ -36,27 +37,27 @@  spreadsheet :: Spreadsheet spreadsheet cell = case name cell of-    "B1"  -> Just $ 1                       --          1+    "B1"  -> Just 1                         --          1     "B2"  -> Just $ "B1" + 1                -- 1 + 1 == 2     "B3"  -> Just $ "A3" * abs "B2"         -- 3 * 2 == 6     "C1"  -> Just $ IfZero "B3" "C2" 1000   --          1000     "C2"  -> Just $ IfZero "B3" 2000 "C1"   --          1000     "C3"  -> Just $ Random 1 6              --          1..6-    "F0"  -> Just $ 0                       --          0-    "F1"  -> Just $ 1                       --          1+    "F0"  -> Just 0                         --          0+    "F1"  -> Just 1                         --          1     'F':_ -> Just $ rel (-1) 0 + rel (-2) 0 --          Fn = F(n - 1) + F(n - 2)     _     -> Nothing  acyclicSpreadsheet :: Spreadsheet acyclicSpreadsheet cell = case name cell of-    "B1"  -> Just $ 1                       --          1+    "B1"  -> Just 1                         --          1     "B2"  -> Just $ "B1" + 1                -- 1 + 1 == 2     "B3"  -> Just $ "A3" * abs "B2"         -- 3 * 2 == 6     "C1"  -> Just $ IfZero "B3" "B2" 1000   --          1000     "C2"  -> Just $ IfZero "B3" 2000 "C1"   --          1000     "C3"  -> Just $ Random 1 6              --          1..6-    "F0"  -> Just $ 0                       --          0-    "F1"  -> Just $ 1                       --          1+    "F0"  -> Just 0                         --          0+    "F1"  -> Just 1                         --          1     'F':_ -> Just $ rel (-1) 0 + rel (-2) 0 --          Fn = F(n - 1) + F(n - 2)     _     -> Nothing 

@@ -1,3 +1,4 @@+{-# LANGUAGE ImpredicativeTypes #-} module Spreadsheet where  import Data.Bool@@ -82,7 +83,7 @@ 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 $ Task $ evaluate formula+    Just formula -> Just $ evaluate formula   where     evaluate formula fetch = go formula       where go formula = case formula of@@ -100,7 +101,7 @@ 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 $ Task $ evaluate formula+    Just formula -> Just $ evaluate formula   where     evaluate formula fetch = go formula       where go formula = case formula of