{-# 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 { forall (k :: * -> *). NamedTask k -> TaskName
taskName :: TaskName, forall (k :: * -> *). NamedTask k -> Task k ()
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 :: BlackBoxes
tasks = [TaskName -> Task Key () -> NamedTask Key
forall (k :: * -> *). TaskName -> Task k () -> NamedTask k
NamedTask TaskName
"release" Get Key f -> Put Key f -> f ()
Task Key ()
release, TaskName -> Task Key () -> NamedTask Key
forall (k :: * -> *). TaskName -> Task k () -> NamedTask k
NamedTask TaskName
"build" Get Key f -> Put Key f -> f ()
Task Key ()
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 :: Task Key ()
build Get Key f
get Put Key f
put = do
    TaskName -> TaskName -> Task Key ()
compile TaskName
"src/a.c" TaskName
"obj/a.o" Key a -> f a
Get Key f
get Key a -> a -> f ()
Put Key f
put
    TaskName -> TaskName -> Task Key ()
compile TaskName
"src/b.c" TaskName
"obj/b.o" Key a -> f a
Get Key f
get Key a -> a -> f ()
Put Key f
put
    TaskName -> TaskName -> Task Key ()
link TaskName
"obj" TaskName
"out/exe" Key a -> f a
Get Key f
get Key a -> a -> f ()
Put Key f
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 :: Task Key ()
release Get Key f
get Put Key f
put = do
    [TaskName]
files   <- (TaskName -> TaskName) -> [TaskName] -> [TaskName]
forall a b. (a -> b) -> [a] -> [b]
map (TaskName
"out/" TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++) ([TaskName] -> [TaskName]) -> f [TaskName] -> f [TaskName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key [TaskName] -> f [TaskName]
Get Key f
get (TaskName -> Key [TaskName]
Dir TaskName
"out")
    TaskName
archive <- [TaskName] -> TaskName
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([TaskName] -> TaskName) -> f [TaskName] -> f TaskName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TaskName -> f TaskName) -> [TaskName] -> f [TaskName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Key TaskName -> f TaskName
Get Key f
get (Key TaskName -> f TaskName)
-> (TaskName -> Key TaskName) -> TaskName -> f TaskName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TaskName -> Key TaskName
File) [TaskName]
files
    Key TaskName -> TaskName -> f ()
Put Key f
put (TaskName -> Key TaskName
File TaskName
"release.tar") TaskName
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 :: TaskName -> TaskName -> Task Key ()
compile TaskName
src TaskName
obj Get Key f
get Put Key f
put = do
    TaskName
source <- Key TaskName -> f TaskName
Get Key f
get (TaskName -> Key TaskName
File TaskName
src)
    TaskName
header <- if TaskName
"#include <lib.h>" TaskName -> TaskName -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` TaskName
source -- find an #include
         then do
            TaskName
path <- Key TaskName -> f TaskName
Get Key f
get (TaskName -> Key TaskName
Env TaskName
"LIBDIR")
            Key TaskName -> f TaskName
Get Key f
get (TaskName -> Key TaskName
File (TaskName -> Key TaskName) -> TaskName -> Key TaskName
forall a b. (a -> b) -> a -> b
$ TaskName
path TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName
"/lib.h")
         else TaskName -> f TaskName
forall a. a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return TaskName
""
    Key TaskName -> TaskName -> f ()
Put Key f
put (TaskName -> Key TaskName
File TaskName
obj) (TaskName
header TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName
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 :: TaskName -> TaskName -> Task Key ()
link TaskName
dir TaskName
exe Get Key f
get Put Key f
put = do
    [TaskName]
objs   <- (TaskName -> TaskName) -> [TaskName] -> [TaskName]
forall a b. (a -> b) -> [a] -> [b]
map (TaskName
"obj/" TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++) ([TaskName] -> [TaskName]) -> f [TaskName] -> f [TaskName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key [TaskName] -> f [TaskName]
Get Key f
get (TaskName -> Key [TaskName]
Dir TaskName
dir)
    TaskName
binary <- [TaskName] -> TaskName
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([TaskName] -> TaskName) -> f [TaskName] -> f TaskName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TaskName -> f TaskName) -> [TaskName] -> f [TaskName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Key TaskName -> f TaskName
Get Key f
get (Key TaskName -> f TaskName)
-> (TaskName -> Key TaskName) -> TaskName -> f TaskName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TaskName -> Key TaskName
File) [TaskName]
objs
    Key TaskName -> TaskName -> f ()
Put Key f
put (TaskName -> Key TaskName
File TaskName
exe) TaskName
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 :: forall a. Log Key -> Key a -> a -> Bool
hasWrongGet Log Key
log Key a
k a
a = case Key a
k of
    File TaskName
x -> (LogEntry Key -> Bool) -> Log Key -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TaskName -> TaskName -> LogEntry Key -> Bool
matchesFile TaskName
x a
TaskName
a) Log Key
log
    Env  TaskName
x -> (LogEntry Key -> Bool) -> Log Key -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TaskName -> TaskName -> LogEntry Key -> Bool
matchesEnv  TaskName
x a
TaskName
a) Log Key
log
    Dir  TaskName
x -> (LogEntry Key -> Bool) -> Log Key -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TaskName -> [TaskName] -> LogEntry Key -> Bool
matchesDir  TaskName
x a
[TaskName]
a) Log Key
log
  where
    matchesFile :: FilePath -> String -> LogEntry Key -> Bool
    matchesFile :: TaskName -> TaskName -> LogEntry Key -> Bool
matchesFile TaskName
x TaskName
a (GetEntry (File TaskName
y) a
b) = (TaskName
x TaskName -> TaskName -> Bool
forall a. Eq a => a -> a -> Bool
== TaskName
y) Bool -> Bool -> Bool
&& (TaskName
a TaskName -> TaskName -> Bool
forall a. Eq a => a -> a -> Bool
/= a
TaskName
b)
    matchesFile TaskName
_ TaskName
_ LogEntry Key
_ = Bool
False
    matchesEnv :: Variable -> String -> LogEntry Key -> Bool
    matchesEnv :: TaskName -> TaskName -> LogEntry Key -> Bool
matchesEnv TaskName
x TaskName
a (GetEntry (Env TaskName
y) a
b) = (TaskName
x TaskName -> TaskName -> Bool
forall a. Eq a => a -> a -> Bool
== TaskName
y) Bool -> Bool -> Bool
&& (TaskName
a TaskName -> TaskName -> Bool
forall a. Eq a => a -> a -> Bool
/= a
TaskName
b)
    matchesEnv TaskName
_ TaskName
_ LogEntry Key
_ = Bool
False
    matchesDir :: FilePath -> [FilePath] -> LogEntry Key -> Bool
    matchesDir :: TaskName -> [TaskName] -> LogEntry Key -> Bool
matchesDir TaskName
x [TaskName]
a (GetEntry (Dir TaskName
y) a
b) = (TaskName
x TaskName -> TaskName -> Bool
forall a. Eq a => a -> a -> Bool
== TaskName
y) Bool -> Bool -> Bool
&& ([TaskName]
a [TaskName] -> [TaskName] -> Bool
forall a. Eq a => a -> a -> Bool
/= a
[TaskName]
b)
    matchesDir TaskName
_ [TaskName]
_ LogEntry Key
_ = Bool
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 :: forall (m :: * -> *) (k :: * -> *).
Monad m =>
Get k m -> Put k m -> Task k () -> m (Log k)
execute Get k m
get Put k m
put Task k ()
task = WriterT (Log k) m () -> m (Log k)
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT (WriterT (Log k) m () -> m (Log k))
-> WriterT (Log k) m () -> m (Log k)
forall a b. (a -> b) -> a -> b
$ Get k (WriterT (Log k) m)
-> Put k (WriterT (Log k) m) -> WriterT (Log k) m ()
Task k ()
task k a -> WriterT (Log k) m a
Get k (WriterT (Log k) m)
loggingGet k a -> a -> WriterT (Log k) m ()
Put k (WriterT (Log k) m)
loggingPut
  where
    loggingGet :: k a -> WriterT (Log k) m a
    loggingGet :: Get k (WriterT (Log k) m)
loggingGet k a
k = do
        a
a <- m a -> WriterT (Log k) m a
forall (m :: * -> *) a. Monad m => m a -> WriterT (Log k) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> WriterT (Log k) m a) -> m a -> WriterT (Log k) m a
forall a b. (a -> b) -> a -> b
$ k a -> m a
Get k m
get k a
k
        Log k -> WriterT (Log k) m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [k a -> a -> LogEntry k
forall (k :: * -> *) a. k a -> a -> LogEntry k
GetEntry k a
k a
a]
        a -> WriterT (Log k) m a
forall a. a -> WriterT (Log k) m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    loggingPut :: k a -> a -> WriterT (Log k) m ()
    loggingPut :: Put k (WriterT (Log k) m)
loggingPut k a
k a
a = do
        m () -> WriterT (Log k) m ()
forall (m :: * -> *) a. Monad m => m a -> WriterT (Log k) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WriterT (Log k) m ()) -> m () -> WriterT (Log k) m ()
forall a b. (a -> b) -> a -> b
$ k a -> a -> m ()
Put k m
put k a
k a
a
        Log k -> WriterT (Log k) m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [k a -> a -> LogEntry k
forall (k :: * -> *) a. k a -> a -> LogEntry k
PutEntry k a
k a
a]

-- | An association of keys to values.
newtype Store = Store { Store -> forall a. Key a -> a
getValue :: forall a. Key a -> a }

putValue :: Key a -> a -> Store -> Store
putValue :: forall a. Key a -> a -> Store -> Store
putValue (File TaskName
x) a
a (Store forall a. Key a -> a
f) = (forall a. Key a -> a) -> Store
Store ((forall a. Key a -> a) -> Store)
-> (forall a. Key a -> a) -> Store
forall a b. (a -> b) -> a -> b
$ \Key a
k -> case Key a
k of
    File TaskName
y | TaskName
x TaskName -> TaskName -> Bool
forall a. Eq a => a -> a -> Bool
== TaskName
y -> a
a
a
    Key a
_ -> Key a -> a
forall a. Key a -> a
f Key a
k
putValue (Env TaskName
x) a
a (Store forall a. Key a -> a
f) = (forall a. Key a -> a) -> Store
Store ((forall a. Key a -> a) -> Store)
-> (forall a. Key a -> a) -> Store
forall a b. (a -> b) -> a -> b
$ \Key a
k -> case Key a
k of
    Env TaskName
y | TaskName
x TaskName -> TaskName -> Bool
forall a. Eq a => a -> a -> Bool
== TaskName
y -> a
a
a
    Key a
_ -> Key a -> a
forall a. Key a -> a
f Key a
k
putValue (Dir TaskName
x) a
a (Store forall a. Key a -> a
f) = (forall a. Key a -> a) -> Store
Store ((forall a. Key a -> a) -> Store)
-> (forall a. Key a -> a) -> Store
forall a b. (a -> b) -> a -> b
$ \Key a
k -> case Key a
k of
    Dir TaskName
y | TaskName
x TaskName -> TaskName -> Bool
forall a. Eq a => a -> a -> Bool
== TaskName
y -> a
a
a
    Key a
_ -> Key a -> a
forall a. Key a -> a
f Key a
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
exampleStore = (forall a. Key a -> a) -> Store
Store ((forall a. Key a -> a) -> Store)
-> (forall a. Key a -> a) -> Store
forall a b. (a -> b) -> a -> b
$ \case
    File TaskName
"src/a.c"    -> a
TaskName
"a"
    File TaskName
"src/b.c"    -> a
TaskName
"b...#include <lib.h>..."
    File TaskName
"obj/main.o" -> a
TaskName
"...main..."
    File TaskName
"lib/lib.h"  -> a
TaskName
"lib..."
    File TaskName
"out/README" -> a
TaskName
"This is a README..."
    Env TaskName
"LIBDIR"      -> a
TaskName
"lib"
    Dir TaskName
"obj"         -> [TaskName
"main.o"]
    Dir TaskName
"out"         -> [TaskName
"README"]

    File TaskName
_ -> a
TaskName
"<empty file>"
    Env  TaskName
_ -> a
TaskName
"<empty variable>"
    Dir  TaskName
_ -> [] -- 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 :: BlackBoxes -> Store -> Graph -> (Store, Graph)
blindBuild BlackBoxes
tasks Store
store Graph
graph = ((Store, Graph), BlackBoxes) -> (Store, Graph)
forall a b. (a, b) -> a
fst (((Store, Graph), BlackBoxes) -> (Store, Graph))
-> ((Store, Graph), BlackBoxes) -> (Store, Graph)
forall a b. (a -> b) -> a -> b
$ State ((Store, Graph), BlackBoxes) ()
-> ((Store, Graph), BlackBoxes) -> ((Store, Graph), BlackBoxes)
forall s a. State s a -> s -> s
execState State ((Store, Graph), BlackBoxes) ()
build ((Store
store, Graph
graph), BlackBoxes
tasks)
  where
    build :: State ((Store, Graph), BlackBoxes) ()
    build :: State ((Store, Graph), BlackBoxes) ()
build = do
      BlackBoxes
queue <- (((Store, Graph), BlackBoxes) -> BlackBoxes)
-> StateT ((Store, Graph), BlackBoxes) Identity BlackBoxes
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Store, Graph), BlackBoxes) -> BlackBoxes
forall a b. (a, b) -> b
snd
      case BlackBoxes
queue of
        [] -> () -> State ((Store, Graph), BlackBoxes) ()
forall a. a -> StateT ((Store, Graph), BlackBoxes) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        (NamedTask TaskName
id Task Key ()
task : BlackBoxes
tasks) -> do
          -- Remove the first task from the queue
          (((Store, Graph), BlackBoxes) -> ((Store, Graph), BlackBoxes))
-> State ((Store, Graph), BlackBoxes) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((((Store, Graph), BlackBoxes) -> ((Store, Graph), BlackBoxes))
 -> State ((Store, Graph), BlackBoxes) ())
-> (((Store, Graph), BlackBoxes) -> ((Store, Graph), BlackBoxes))
-> State ((Store, Graph), BlackBoxes) ()
forall a b. (a -> b) -> a -> b
$ \((Store
s, Graph
g), BlackBoxes
_) -> ((Store
s, Graph
g), BlackBoxes
tasks)
          -- Execute the task, possibly restaring some previously executed tasks
          Log Key
log <- TaskName
-> StateT ((Store, Graph), BlackBoxes) Identity (Log Key)
-> StateT ((Store, Graph), BlackBoxes) Identity (Log Key)
forall a. TaskName -> a -> a
trace (TaskName
"Execute " TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName
id) (StateT ((Store, Graph), BlackBoxes) Identity (Log Key)
 -> StateT ((Store, Graph), BlackBoxes) Identity (Log Key))
-> StateT ((Store, Graph), BlackBoxes) Identity (Log Key)
-> StateT ((Store, Graph), BlackBoxes) Identity (Log Key)
forall a b. (a -> b) -> a -> b
$ Get Key (StateT ((Store, Graph), BlackBoxes) Identity)
-> Put Key (StateT ((Store, Graph), BlackBoxes) Identity)
-> Task Key ()
-> StateT ((Store, Graph), BlackBoxes) Identity (Log Key)
forall (m :: * -> *) (k :: * -> *).
Monad m =>
Get k m -> Put k m -> Task k () -> m (Log k)
execute Key a -> State ((Store, Graph), BlackBoxes) a
Get Key (StateT ((Store, Graph), BlackBoxes) Identity)
get Key a -> a -> State ((Store, Graph), BlackBoxes) ()
Put Key (StateT ((Store, Graph), BlackBoxes) Identity)
put Get Key f -> Put Key f -> f ()
Task Key ()
task
          (((Store, Graph), BlackBoxes) -> ((Store, Graph), BlackBoxes))
-> State ((Store, Graph), BlackBoxes) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((((Store, Graph), BlackBoxes) -> ((Store, Graph), BlackBoxes))
 -> State ((Store, Graph), BlackBoxes) ())
-> (((Store, Graph), BlackBoxes) -> ((Store, Graph), BlackBoxes))
-> State ((Store, Graph), BlackBoxes) ()
forall a b. (a -> b) -> a -> b
$ \((Store
s, Graph
g), BlackBoxes
ts) -> let ng :: Graph
ng TaskName
t = if TaskName
t TaskName -> TaskName -> Bool
forall a. Eq a => a -> a -> Bool
== TaskName
id then Log Key -> Maybe (Log Key)
forall a. a -> Maybe a
Just Log Key
log else Graph
g TaskName
t
                                   in ((Store
s, Graph
ng), BlackBoxes
ts)
          -- Build the rest of the queue
          State ((Store, Graph), BlackBoxes) ()
build

    -- Simply return whatever is in the store.
    get :: Key a -> State ((Store, Graph), BlackBoxes) a
    get :: Get Key (StateT ((Store, Graph), BlackBoxes) Identity)
get Key a
k = do
        Store
store <- (((Store, Graph), BlackBoxes) -> Store)
-> StateT ((Store, Graph), BlackBoxes) Identity Store
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Store, Graph) -> Store
forall a b. (a, b) -> a
fst ((Store, Graph) -> Store)
-> (((Store, Graph), BlackBoxes) -> (Store, Graph))
-> ((Store, Graph), BlackBoxes)
-> Store
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Store, Graph), BlackBoxes) -> (Store, Graph)
forall a b. (a, b) -> a
fst)
        let a :: a
a = Store -> forall a. Key a -> a
getValue Store
store Key a
k
        TaskName
-> State ((Store, Graph), BlackBoxes) a
-> State ((Store, Graph), BlackBoxes) a
forall a. TaskName -> a -> a
trace (TaskName
"Get (" TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ Key a -> TaskName
ShowKey Key
showKey Key a
k TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName
", " TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ Key a -> a -> TaskName
forall a. Key a -> a -> TaskName
showValue Key a
k a
a TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName
")") (State ((Store, Graph), BlackBoxes) a
 -> State ((Store, Graph), BlackBoxes) a)
-> State ((Store, Graph), BlackBoxes) a
-> State ((Store, Graph), BlackBoxes) a
forall a b. (a -> b) -> a -> b
$ a -> State ((Store, Graph), BlackBoxes) a
forall a. a -> StateT ((Store, Graph), BlackBoxes) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return a
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 :: Put Key (StateT ((Store, Graph), BlackBoxes) Identity)
put Key a
k a
a = do
        -- Update the store
        TaskName
-> State ((Store, Graph), BlackBoxes) ()
-> State ((Store, Graph), BlackBoxes) ()
forall a. TaskName -> a -> a
trace (TaskName
"Put (" TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ Key a -> TaskName
ShowKey Key
showKey Key a
k TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName
", " TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ Key a -> a -> TaskName
forall a. Key a -> a -> TaskName
showValue Key a
k a
a TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName
")") (State ((Store, Graph), BlackBoxes) ()
 -> State ((Store, Graph), BlackBoxes) ())
-> State ((Store, Graph), BlackBoxes) ()
-> State ((Store, Graph), BlackBoxes) ()
forall a b. (a -> b) -> a -> b
$
            (((Store, Graph), BlackBoxes) -> ((Store, Graph), BlackBoxes))
-> State ((Store, Graph), BlackBoxes) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((((Store, Graph), BlackBoxes) -> ((Store, Graph), BlackBoxes))
 -> State ((Store, Graph), BlackBoxes) ())
-> (((Store, Graph), BlackBoxes) -> ((Store, Graph), BlackBoxes))
-> State ((Store, Graph), BlackBoxes) ()
forall a b. (a -> b) -> a -> b
$ \((Store
s, Graph
g), BlackBoxes
bs) -> ((Key a -> a -> Store -> Store
forall a. Key a -> a -> Store -> Store
putValue Key a
k a
a Store
s, Graph
g), BlackBoxes
bs)
        -- Restart any tasks which depended on this key
        Graph
graph <- (((Store, Graph), BlackBoxes) -> Graph)
-> StateT ((Store, Graph), BlackBoxes) Identity Graph
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Store, Graph) -> Graph
forall a b. (a, b) -> b
snd ((Store, Graph) -> Graph)
-> (((Store, Graph), BlackBoxes) -> (Store, Graph))
-> ((Store, Graph), BlackBoxes)
-> Graph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Store, Graph), BlackBoxes) -> (Store, Graph)
forall a b. (a, b) -> a
fst)
        BlackBoxes
queue <- (((Store, Graph), BlackBoxes) -> BlackBoxes)
-> StateT ((Store, Graph), BlackBoxes) Identity BlackBoxes
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Store, Graph), BlackBoxes) -> BlackBoxes
forall a b. (a, b) -> b
snd
        BlackBoxes
-> (NamedTask Key -> State ((Store, Graph), BlackBoxes) ())
-> State ((Store, Graph), BlackBoxes) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ BlackBoxes
tasks ((NamedTask Key -> State ((Store, Graph), BlackBoxes) ())
 -> State ((Store, Graph), BlackBoxes) ())
-> (NamedTask Key -> State ((Store, Graph), BlackBoxes) ())
-> State ((Store, Graph), BlackBoxes) ()
forall a b. (a -> b) -> a -> b
$ \task :: NamedTask Key
task@(NamedTask TaskName
id Task Key ()
_) -> case Graph
graph TaskName
id of
            Maybe (Log Key)
Nothing  -> () -> State ((Store, Graph), BlackBoxes) ()
forall a. a -> StateT ((Store, Graph), BlackBoxes) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just Log Key
log -> Bool
-> State ((Store, Graph), BlackBoxes) ()
-> State ((Store, Graph), BlackBoxes) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Log Key -> Key a -> a -> Bool
forall a. Log Key -> Key a -> a -> Bool
hasWrongGet Log Key
log Key a
k a
a Bool -> Bool -> Bool
&& TaskName
id TaskName -> BlackBoxes -> Bool
`notInQueue` BlackBoxes
queue) (State ((Store, Graph), BlackBoxes) ()
 -> State ((Store, Graph), BlackBoxes) ())
-> State ((Store, Graph), BlackBoxes) ()
-> State ((Store, Graph), BlackBoxes) ()
forall a b. (a -> b) -> a -> b
$
                TaskName
-> State ((Store, Graph), BlackBoxes) ()
-> State ((Store, Graph), BlackBoxes) ()
forall a. TaskName -> a -> a
trace (TaskName
"Restart " TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName
id) (State ((Store, Graph), BlackBoxes) ()
 -> State ((Store, Graph), BlackBoxes) ())
-> State ((Store, Graph), BlackBoxes) ()
-> State ((Store, Graph), BlackBoxes) ()
forall a b. (a -> b) -> a -> b
$
                    (((Store, Graph), BlackBoxes) -> ((Store, Graph), BlackBoxes))
-> State ((Store, Graph), BlackBoxes) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((((Store, Graph), BlackBoxes) -> ((Store, Graph), BlackBoxes))
 -> State ((Store, Graph), BlackBoxes) ())
-> (((Store, Graph), BlackBoxes) -> ((Store, Graph), BlackBoxes))
-> State ((Store, Graph), BlackBoxes) ()
forall a b. (a -> b) -> a -> b
$ \((Store
s, Graph
g), BlackBoxes
bs) -> ((Store
s, Graph
g), BlackBoxes
bs BlackBoxes -> BlackBoxes -> BlackBoxes
forall a. [a] -> [a] -> [a]
++ [NamedTask Key
task])
        -- Make sure to update the corresponding directory key if a new file has
        -- been created
        case Key a
k of
            File TaskName
path -> do
                let dir :: TaskName
dir  = TaskName -> TaskName
takeDirectory TaskName
path
                    file :: TaskName
file = TaskName -> TaskName
takeFileName TaskName
path
                Store
store <- (((Store, Graph), BlackBoxes) -> Store)
-> StateT ((Store, Graph), BlackBoxes) Identity Store
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Store, Graph) -> Store
forall a b. (a, b) -> a
fst ((Store, Graph) -> Store)
-> (((Store, Graph), BlackBoxes) -> (Store, Graph))
-> ((Store, Graph), BlackBoxes)
-> Store
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Store, Graph), BlackBoxes) -> (Store, Graph)
forall a b. (a, b) -> a
fst)
                let files :: [TaskName]
files = Store -> forall a. Key a -> a
getValue Store
store (TaskName -> Key [TaskName]
Dir TaskName
dir)
                Bool
-> State ((Store, Graph), BlackBoxes) ()
-> State ((Store, Graph), BlackBoxes) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TaskName
file TaskName -> [TaskName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [TaskName]
files) (State ((Store, Graph), BlackBoxes) ()
 -> State ((Store, Graph), BlackBoxes) ())
-> State ((Store, Graph), BlackBoxes) ()
-> State ((Store, Graph), BlackBoxes) ()
forall a b. (a -> b) -> a -> b
$ Key [TaskName]
-> [TaskName] -> State ((Store, Graph), BlackBoxes) ()
Put Key (StateT ((Store, Graph), BlackBoxes) Identity)
put (TaskName -> Key [TaskName]
Dir TaskName
dir) ([TaskName]
files [TaskName] -> [TaskName] -> [TaskName]
forall a. [a] -> [a] -> [a]
++ [TaskName
file])
            Key a
_ -> () -> State ((Store, Graph), BlackBoxes) ()
forall a. a -> StateT ((Store, Graph), BlackBoxes) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- Check that a task does not appear in a queue
    notInQueue :: TaskName -> BlackBoxes -> Bool
    notInQueue :: TaskName -> BlackBoxes -> Bool
notInQueue TaskName
_  []     = Bool
True
    notInQueue TaskName
id (NamedTask Key
t:BlackBoxes
ts) | TaskName
id TaskName -> TaskName -> Bool
forall a. Eq a => a -> a -> Bool
== NamedTask Key -> TaskName
forall (k :: * -> *). NamedTask k -> TaskName
taskName NamedTask Key
t = Bool
False
                         | Bool
otherwise        = TaskName -> BlackBoxes -> Bool
notInQueue TaskName
id BlackBoxes
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 :: ShowKey Key
showKey (File TaskName
f) = TaskName
"File " TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName -> TaskName
forall a. Show a => a -> TaskName
show TaskName
f
showKey (Env  TaskName
v) = TaskName
"Env "  TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName -> TaskName
forall a. Show a => a -> TaskName
show TaskName
v
showKey (Dir  TaskName
d) = TaskName
"Dir "  TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName -> TaskName
forall a. Show a => a -> TaskName
show TaskName
d

-- | Show a value corresponding to a key, extracting an appropriate 'Show'
-- instance from it.
showValue :: Key a -> a -> String
showValue :: forall a. Key a -> a -> TaskName
showValue (File TaskName
_) a
f = a -> TaskName
forall a. Show a => a -> TaskName
show a
f
showValue (Env  TaskName
_) a
v = a -> TaskName
forall a. Show a => a -> TaskName
show a
v
showValue (Dir  TaskName
_) a
d = a -> TaskName
forall a. Show a => a -> TaskName
show a
d

instance Show (LogEntry Key) where
    show :: LogEntry Key -> TaskName
show (GetEntry k :: Key a
k@(File TaskName
_) a
a) = TaskName
"Get (" TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ Key a -> TaskName
ShowKey Key
showKey Key a
k TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName
", " TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ a -> TaskName
forall a. Show a => a -> TaskName
show a
a TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName
")"
    show (GetEntry k :: Key a
k@(Env  TaskName
_) a
a) = TaskName
"Get (" TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ Key a -> TaskName
ShowKey Key
showKey Key a
k TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName
", " TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ a -> TaskName
forall a. Show a => a -> TaskName
show a
a TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName
")"
    show (GetEntry k :: Key a
k@(Dir  TaskName
_) a
a) = TaskName
"Get (" TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ Key a -> TaskName
ShowKey Key
showKey Key a
k TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName
", " TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ a -> TaskName
forall a. Show a => a -> TaskName
show a
a TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName
")"

    show (PutEntry k :: Key a
k@(File TaskName
_) a
a) = TaskName
"Put (" TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ Key a -> TaskName
ShowKey Key
showKey Key a
k TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName
", " TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ a -> TaskName
forall a. Show a => a -> TaskName
show a
a TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName
")"
    show (PutEntry k :: Key a
k@(Env  TaskName
_) a
a) = TaskName
"Put (" TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ Key a -> TaskName
ShowKey Key
showKey Key a
k TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName
", " TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ a -> TaskName
forall a. Show a => a -> TaskName
show a
a TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName
")"
    show (PutEntry k :: Key a
k@(Dir  TaskName
_) a
a) = TaskName
"Put (" TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ Key a -> TaskName
ShowKey Key
showKey Key a
k TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName
", " TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ a -> TaskName
forall a. Show a => a -> TaskName
show a
a TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName
")"

----------------------------- Auxiliary functions ------------------------------

-- | A 'Get' in 'IO' for GHCi experiments.
getIO :: Get Key IO
getIO :: Get Key IO
getIO (File TaskName
f) = TaskName -> IO ()
putStr (TaskName
"Get : File " TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName -> TaskName
forall a. Show a => a -> TaskName
show TaskName
f TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName
" = ") IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO a
IO TaskName
getLine
getIO (Env  TaskName
v) = TaskName -> IO ()
putStr (TaskName
"Get : Env " TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName -> TaskName
forall a. Show a => a -> TaskName
show TaskName
v TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName
" = ") IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO a
IO TaskName
getLine
getIO (Dir  TaskName
d) = TaskName -> IO ()
putStr (TaskName
"Get : Dir " TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName -> TaskName
forall a. Show a => a -> TaskName
show TaskName
d TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName
" = ") IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (TaskName -> a
forall a. Read a => TaskName -> a
read (TaskName -> a) -> IO TaskName -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO TaskName
getLine)

-- | A 'Put' in 'IO' for GHCi experiments.
putIO :: Put Key IO
putIO :: Put Key IO
putIO (File TaskName
f) a
x = TaskName -> IO ()
putStr (TaskName
"Put : File " TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName -> TaskName
forall a. Show a => a -> TaskName
show TaskName
f TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName
" = ") IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TaskName -> IO ()
putStrLn a
TaskName
x
putIO (Env  TaskName
v) a
x = TaskName -> IO ()
putStr (TaskName
"Put : Env " TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName -> TaskName
forall a. Show a => a -> TaskName
show TaskName
v TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName
" = ") IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TaskName -> IO ()
putStrLn a
TaskName
x
putIO (Dir  TaskName
d) a
x = TaskName -> IO ()
putStr (TaskName
"Put : Dir " TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName -> TaskName
forall a. Show a => a -> TaskName
show TaskName
d TaskName -> TaskName -> TaskName
forall a. [a] -> [a] -> [a]
++ TaskName
" = ") IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> IO ()
forall a. Show a => a -> IO ()
print a
x