Opaque.hs

{-# 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