{-# LANGUAGE TupleSections #-}
module Build.Rebuilder (
Rebuilder, adaptRebuilder, perpetualRebuilder,
modTimeRebuilder, Time, MakeInfo,
dirtyBitRebuilder, dirtyBitRebuilderWithCleanUp,
approximateRebuilder, ApproximateDependencies, ApproximationInfo,
vtRebuilder, stRebuilder, ctRebuilder, dctRebuilder
) where
import Control.Monad.State
import Data.Map (Map)
import Data.Set (Set)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Build.Store
import Build.Task
import Build.Task.Applicative
import Build.Task.Monad
import Build.Trace
type Rebuilder c i k v = k -> v -> Task c k v -> Task (MonadState i) k v
adaptRebuilder :: Rebuilder Monad i k v -> Rebuilder Applicative i k v
adaptRebuilder rebuilder key value task = rebuilder key value $ Task $ run task
perpetualRebuilder :: Rebuilder Monad () k v
perpetualRebuilder _key _value task = Task $ run task
type Time = Integer
type MakeInfo k = (Time, Map k Time)
modTimeRebuilder :: Ord k => Rebuilder Applicative (MakeInfo k) k v
modTimeRebuilder key value task = Task $ \fetch -> do
(now, modTimes) <- get
let dirty = case Map.lookup key modTimes of
Nothing -> True
time -> any (\d -> Map.lookup d modTimes > time) (dependencies task)
if not dirty
then return value
else do
put (now + 1, Map.insert key now modTimes)
run task fetch
dirtyBitRebuilder :: Rebuilder Monad (k -> Bool) k v
dirtyBitRebuilder key value task = Task $ \fetch -> do
isDirty <- get
if isDirty key then run task fetch else return value
dirtyBitRebuilderWithCleanUp :: Ord k => Rebuilder Monad (Set k) k v
dirtyBitRebuilderWithCleanUp key value task = Task $ \fetch -> do
isDirty <- get
if key `Set.notMember` isDirty then return value else do
put (Set.delete key isDirty)
run task fetch
type ApproximateDependencies k = Map k [k]
type ApproximationInfo k = (Set k, ApproximateDependencies k)
approximateRebuilder :: (Ord k, Eq v) => Rebuilder Monad (ApproximationInfo k) k v
approximateRebuilder key value task = Task $ \fetch -> do
(dirtyKeys, deps) <- get
let dirty = key `Set.member` dirtyKeys ||
case Map.lookup key deps of Nothing -> True
Just ks -> any (`Set.member` dirtyKeys) ks
if not dirty
then return value
else do
newValue <- run task fetch
when (value /= newValue) $ put (Set.insert key dirtyKeys, deps)
return newValue
vtRebuilder :: (Eq k, Hashable v) => Rebuilder Monad (VT k v) k v
vtRebuilder key value task = Task $ \fetch -> do
upToDate <- verifyVT key (hash value) (fmap hash . fetch) =<< get
if upToDate
then return value
else do
(newValue, deps) <- track task fetch
modify $ recordVT key (hash newValue) [ (k, hash v) | (k, v) <- deps ]
return newValue
ctRebuilder :: (Eq k, Hashable v) => Rebuilder Monad (CT k v) k v
ctRebuilder key value task = Task $ \fetch -> do
cachedValues <- constructCT key (fmap hash . fetch) =<< get
if value `elem` cachedValues
then return value
else case cachedValues of
(cachedValue:_) -> return cachedValue
_ -> do
(newValue, deps) <- track task fetch
modify $ recordCT key newValue [ (k, hash v) | (k, v) <- deps ]
return newValue
dctRebuilder :: (Eq k, Hashable v) => Rebuilder Monad (DCT k v) k v
dctRebuilder key value task = Task $ \fetch -> do
cachedValues <- constructDCT key (fmap hash . fetch) =<< get
if value `elem` cachedValues
then return value
else case cachedValues of
(cachedValue:_) -> return cachedValue
_ -> do
(newValue, deps) <- track task fetch
put =<< recordDCT key newValue (map fst deps) (fmap hash . fetch) =<< get
return newValue
stRebuilder :: (Eq k, Hashable v) => Rebuilder Monad (Step, ST k v) k v
stRebuilder key value task = Task $ \fetch -> do
upToDate <- verifyST key value (void . fetch) (gets snd)
if upToDate
then return value
else do
(newValue, deps) <- track task fetch
modify $ \(step, st) -> (step, recordST step key newValue (map fst deps) st)
return newValue