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

import qualified Data.Map as Map
import qualified Data.Set as Set

import Build.Store
import Build.Task
import Build.Task.Applicative
import Build.Task.Monad
import Build.Trace

-- | Given a key-value pair and the corresponding task, a rebuilder returns a
-- new task that has access to the build information and can use it to skip
-- 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

-- | Always rebuilds the key.
perpetualRebuilder :: Rebuilder Monad i k v
perpetualRebuilder :: forall i k v. Rebuilder Monad i k v
perpetualRebuilder k
_key v
_value Task Monad k v
task = (k -> f v) -> f v
Task Monad k v
task

------------------------------------- Make -------------------------------------
type Time = Integer
type MakeInfo k = (Time, Map k Time)

-- | This rebuilder uses modification time to decide whether a key is dirty and
-- needs to be rebuilt. Used by Make.
modTimeRebuilder :: Ord k => Rebuilder Applicative (MakeInfo k) k v
modTimeRebuilder :: forall k v. Ord k => Rebuilder Applicative (MakeInfo k) k v
modTimeRebuilder k
key v
value Task Applicative k v
task k -> f v
fetch = do
    (Time
now, Map k Time
modTimes) <- f (MakeInfo k)
forall s (m :: * -> *). MonadState s m => m s
get
    let dirty :: Bool
dirty = case k -> Map k Time -> Maybe Time
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
key Map k Time
modTimes of
            Maybe Time
Nothing -> Bool
True
            Maybe Time
time -> (k -> Bool) -> [k] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\k
d -> k -> Map k Time -> Maybe Time
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
d Map k Time
modTimes Maybe Time -> Maybe Time -> Bool
forall a. Ord a => a -> a -> Bool
> Maybe Time
time) (Task Applicative k v -> [k]
forall k v. Task Applicative k v -> [k]
dependencies (k -> f v) -> f v
Task Applicative k v
task)
    if Bool -> Bool
not Bool
dirty
    then v -> f v
forall a. a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return v
value
    else do
        MakeInfo k -> f ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Time
now Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
1, k -> Time -> Map k Time -> Map k Time
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
key Time
now Map k Time
modTimes)
        (k -> f v) -> f v
Task Applicative k v
task k -> f v
fetch

----------------------------------- Dirty bit ----------------------------------
-- | If the key is dirty, rebuild it. Used by Excel.
dirtyBitRebuilder :: Rebuilder Monad (k -> Bool) k v
dirtyBitRebuilder :: forall k v. Rebuilder Monad (k -> Bool) k v
dirtyBitRebuilder k
key v
value Task Monad k v
task k -> f v
fetch = do
    k -> Bool
isDirty <- f (k -> Bool)
forall s (m :: * -> *). MonadState s m => m s
get
    if k -> Bool
isDirty k
key then (k -> f v) -> f v
Task Monad k v
task k -> f v
fetch else v -> f v
forall a. a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return v
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 :: forall k v. Ord k => Rebuilder Monad (Set k) k v
dirtyBitRebuilderWithCleanUp k
key v
value Task Monad k v
task k -> f v
fetch = do
    Set k
isDirty <- f (Set k)
forall s (m :: * -> *). MonadState s m => m s
get
    if k
key k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set k
isDirty then v -> f v
forall a. a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return v
value else do
        Set k -> f ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (k -> Set k -> Set k
forall a. Ord a => a -> Set a -> Set a
Set.delete k
key Set k
isDirty)
        (k -> f v) -> f v
Task Monad k v
task k -> f v
fetch

--------------------------- Approximate dependencies ---------------------------
-- | If there is an entry for a key, it is an conservative approximation of its
-- dependencies. Otherwise, we have no reasonable approximation and assume the
-- key is always dirty (e.g. it uses an INDIRECT reference).
type ApproximateDependencies k = Map k [k]

-- | A set of dirty keys and information about dependencies.
type ApproximationInfo k = (Set k, ApproximateDependencies k)

-- | This rebuilders uses approximate dependencies to decide whether a key
-- needs to be rebuilt.
approximateRebuilder :: (Ord k, Eq v) => Rebuilder Monad (ApproximationInfo k) k v
approximateRebuilder :: forall k v.
(Ord k, Eq v) =>
Rebuilder Monad (ApproximationInfo k) k v
approximateRebuilder k
key v
value Task Monad k v
task k -> f v
fetch = do
    (Set k
dirtyKeys, Map k [k]
deps) <- f (ApproximationInfo k)
forall s (m :: * -> *). MonadState s m => m s
get
    let dirty :: Bool
dirty = k
key k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set k
dirtyKeys Bool -> Bool -> Bool
||
                case k -> Map k [k] -> Maybe [k]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
key Map k [k]
deps of Maybe [k]
Nothing -> Bool
True
                                            Just [k]
ks -> (k -> Bool) -> [k] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set k
dirtyKeys) [k]
ks
    if Bool -> Bool
not Bool
dirty
    then v -> f v
forall a. a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return v
value
    else do
        v
newValue <- (k -> f v) -> f v
Task Monad k v
task k -> f v
fetch
        Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (v
value v -> v -> Bool
forall a. Eq a => a -> a -> Bool
/= v
newValue) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ ApproximationInfo k -> f ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (k -> Set k -> Set k
forall a. Ord a => a -> Set a -> Set a
Set.insert k
key Set k
dirtyKeys, Map k [k]
deps)
        v -> f v
forall a. a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return v
newValue

------------------------------- Verifying traces -------------------------------
-- | This rebuilder relies on verifying traces.
vtRebuilder :: (Eq k, Hashable v) => Rebuilder Monad (VT k v) k v
vtRebuilder :: forall k v. (Eq k, Hashable v) => Rebuilder Monad (VT k v) k v
vtRebuilder k
key v
value Task Monad k v
task k -> f v
fetch = do
    Bool
upToDate <- k -> Hash v -> (k -> f (Hash v)) -> VT k v -> f Bool
forall (m :: * -> *) k v.
(Monad m, Eq k, Eq v) =>
k -> Hash v -> (k -> m (Hash v)) -> VT k v -> m Bool
verifyVT k
key (v -> Hash v
forall a. Hashable a => a -> Hash a
hash v
value) ((v -> Hash v) -> f v -> f (Hash v)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap v -> Hash v
forall a. Hashable a => a -> Hash a
hash (f v -> f (Hash v)) -> (k -> f v) -> k -> f (Hash v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> f v
fetch) (VT k v -> f Bool) -> f (VT k v) -> f Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< f (VT k v)
forall s (m :: * -> *). MonadState s m => m s
get
    if Bool
upToDate
    then v -> f v
forall a. a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return v
value
    else do
        (v
newValue, [(k, v)]
deps) <- Task Monad k v -> (k -> f v) -> f (v, [(k, v)])
forall (m :: * -> *) k v.
Monad m =>
Task Monad k v -> (k -> m v) -> m (v, [(k, v)])
track (k -> f v) -> f v
Task Monad k v
task k -> f v
fetch
        (VT k v -> VT k v) -> f ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((VT k v -> VT k v) -> f ()) -> (VT k v -> VT k v) -> f ()
forall a b. (a -> b) -> a -> b
$ k -> Hash v -> [(k, Hash v)] -> VT k v -> VT k v
forall k v. k -> Hash v -> [(k, Hash v)] -> VT k v -> VT k v
recordVT k
key (v -> Hash v
forall a. Hashable a => a -> Hash a
hash v
newValue) [ (k
k, v -> Hash v
forall a. Hashable a => a -> Hash a
hash v
v) | (k
k, v
v) <- [(k, v)]
deps ]
        v -> f v
forall a. a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return v
newValue

------------------------------ Constructive traces -----------------------------
-- | This rebuilder relies on constructive traces.
ctRebuilder :: (Eq k, Hashable v) => Rebuilder Monad (CT k v) k v
ctRebuilder :: forall k v. (Eq k, Hashable v) => Rebuilder Monad (CT k v) k v
ctRebuilder k
key v
value Task Monad k v
task k -> f v
fetch = do
    [v]
cachedValues <- k -> (k -> f (Hash v)) -> CT k v -> f [v]
forall (m :: * -> *) k v.
(Monad m, Eq k, Eq v) =>
k -> (k -> m (Hash v)) -> CT k v -> m [v]
constructCT k
key ((v -> Hash v) -> f v -> f (Hash v)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap v -> Hash v
forall a. Hashable a => a -> Hash a
hash (f v -> f (Hash v)) -> (k -> f v) -> k -> f (Hash v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> f v
fetch) (CT k v -> f [v]) -> f (CT k v) -> f [v]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< f (CT k v)
forall s (m :: * -> *). MonadState s m => m s
get
    if v
value v -> [v] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [v]
cachedValues
    then v -> f v
forall a. a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return v
value -- The current value has been verified, let's keep it
    else case [v]
cachedValues of
        (v
cachedValue:[v]
_) -> v -> f v
forall a. a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return v
cachedValue -- Any cached value will do
        [v]
_ -> do -- No cached values, need to run the task
            (v
newValue, [(k, v)]
deps) <- Task Monad k v -> (k -> f v) -> f (v, [(k, v)])
forall (m :: * -> *) k v.
Monad m =>
Task Monad k v -> (k -> m v) -> m (v, [(k, v)])
track (k -> f v) -> f v
Task Monad k v
task k -> f v
fetch
            (CT k v -> CT k v) -> f ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CT k v -> CT k v) -> f ()) -> (CT k v -> CT k v) -> f ()
forall a b. (a -> b) -> a -> b
$ k -> v -> [(k, Hash v)] -> CT k v -> CT k v
forall k v. k -> v -> [(k, Hash v)] -> CT k v -> CT k v
recordCT k
key v
newValue [ (k
k, v -> Hash v
forall a. Hashable a => a -> Hash a
hash v
v) | (k
k, v
v) <- [(k, v)]
deps ]
            v -> f v
forall a. a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return v
newValue

--------------------------- Deep constructive traces ---------------------------
-- | This rebuilder relies on deep constructive traces.
dctRebuilder :: (Eq k, Hashable v) => Rebuilder Monad (DCT k v) k v
dctRebuilder :: forall k v. (Eq k, Hashable v) => Rebuilder Monad (DCT k v) k v
dctRebuilder k
key v
value Task Monad k v
task k -> f v
fetch = do
    [v]
cachedValues <- k -> (k -> f (Hash v)) -> DCT k v -> f [v]
forall k v (m :: * -> *).
(Eq k, Hashable v, Monad m) =>
k -> (k -> m (Hash v)) -> DCT k v -> m [v]
constructDCT k
key ((v -> Hash v) -> f v -> f (Hash v)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap v -> Hash v
forall a. Hashable a => a -> Hash a
hash (f v -> f (Hash v)) -> (k -> f v) -> k -> f (Hash v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> f v
fetch) (DCT k v -> f [v]) -> f (DCT k v) -> f [v]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< f (DCT k v)
forall s (m :: * -> *). MonadState s m => m s
get
    if v
value v -> [v] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [v]
cachedValues
    then v -> f v
forall a. a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return v
value -- The current value has been verified, let's keep it
    else case [v]
cachedValues of
        (v
cachedValue:[v]
_) -> v -> f v
forall a. a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return v
cachedValue -- Any cached value will do
        [v]
_ -> do -- No cached values, need to run the task
            (v
newValue, [(k, v)]
deps) <- Task Monad k v -> (k -> f v) -> f (v, [(k, v)])
forall (m :: * -> *) k v.
Monad m =>
Task Monad k v -> (k -> m v) -> m (v, [(k, v)])
track (k -> f v) -> f v
Task Monad k v
task k -> f v
fetch
            DCT k v -> f ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (DCT k v -> f ()) -> f (DCT k v) -> f ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< k -> v -> [k] -> (k -> f (Hash v)) -> DCT k v -> f (DCT k v)
forall k v (m :: * -> *).
(Eq k, Hashable v, Monad m) =>
k -> v -> [k] -> (k -> m (Hash v)) -> DCT k v -> m (DCT k v)
recordDCT k
key v
newValue (((k, v) -> k) -> [(k, v)] -> [k]
forall a b. (a -> b) -> [a] -> [b]
map (k, v) -> k
forall a b. (a, b) -> a
fst [(k, v)]
deps) ((v -> Hash v) -> f v -> f (Hash v)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap v -> Hash v
forall a. Hashable a => a -> Hash a
hash (f v -> f (Hash v)) -> (k -> f v) -> k -> f (Hash v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> f v
fetch) (DCT k v -> f (DCT k v)) -> f (DCT k v) -> f (DCT k v)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< f (DCT k v)
forall s (m :: * -> *). MonadState s m => m s
get
            v -> f v
forall a. a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return v
newValue

------------------------------- Version traces -------------------------------
-- | This rebuilder relies on version/step traces.
stRebuilder :: (Eq k, Hashable v) => Rebuilder Monad (Step, ST k v) k v
stRebuilder :: forall k v.
(Eq k, Hashable v) =>
Rebuilder Monad (Step, ST k v) k v
stRebuilder k
key v
value Task Monad k v
task k -> f v
fetch = do
    Bool
upToDate <- k -> v -> (k -> f ()) -> f (ST k v) -> f Bool
forall (m :: * -> *) k v.
(Monad m, Eq k, Hashable v) =>
k -> v -> (k -> m ()) -> m (ST k v) -> m Bool
verifyST k
key v
value (f v -> f ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (f v -> f ()) -> (k -> f v) -> k -> f ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> f v
fetch) (((Step, ST k v) -> ST k v) -> f (ST k v)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Step, ST k v) -> ST k v
forall a b. (a, b) -> b
snd)
    if Bool
upToDate
    then v -> f v
forall a. a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return v
value
    else do
        (v
newValue, [(k, v)]
deps) <- Task Monad k v -> (k -> f v) -> f (v, [(k, v)])
forall (m :: * -> *) k v.
Monad m =>
Task Monad k v -> (k -> m v) -> m (v, [(k, v)])
track (k -> f v) -> f v
Task Monad k v
task k -> f v
fetch
        ((Step, ST k v) -> (Step, ST k v)) -> f ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (((Step, ST k v) -> (Step, ST k v)) -> f ())
-> ((Step, ST k v) -> (Step, ST k v)) -> f ()
forall a b. (a -> b) -> a -> b
$ \(Step
step, ST k v
st) -> (Step
step, Step -> k -> v -> [k] -> ST k v -> ST k v
forall v k.
(Hashable v, Eq k) =>
Step -> k -> v -> [k] -> ST k v -> ST k v
recordST Step
step k
key v
newValue (((k, v) -> k) -> [(k, v)] -> [k]
forall a b. (a -> b) -> [a] -> [b]
map (k, v) -> k
forall a b. (a, b) -> a
fst [(k, v)]
deps) ST k v
st)
        v -> f v
forall a. a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return v
newValue