{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
{-# LANGUAGE DeriveTraversable, TupleSections #-}
module Build.Trace (
Trace (..),
VT, recordVT, verifyVT,
CT, isDirtyCT, recordCT, constructCT,
DCT, recordDCT, constructDCT,
Step, ST, recordST, verifyST
) where
import Build.Store
import Control.Monad.Extra
import Data.Maybe
import Data.List
import Data.Semigroup
data Trace k v r = Trace
{ key :: k
, depends :: [(k, Hash v)]
, result :: r }
deriving Show
newtype VT k v = VT [Trace k v (Hash v)] deriving (Monoid, Semigroup, Show)
recordVT :: k -> Hash v -> [(k, Hash v)] -> VT k v -> VT k v
recordVT key valueHash deps (VT ts) = VT $ Trace key deps valueHash : ts
verifyVT :: (Monad m, Eq k, Eq v) => k -> Hash v -> (k -> m (Hash v)) -> VT k v -> m Bool
verifyVT key valueHash fetchHash (VT ts) = anyM match ts
where
match (Trace k deps result)
| k /= key || result /= valueHash = return False
| otherwise = andM [ (h==) <$> fetchHash k | (k, h) <- deps ]
newtype CT k v = CT [Trace k v v] deriving (Monoid, Semigroup, Show)
isDirtyCT :: (Eq k, Hashable v) => k -> Store (CT k v) k v -> Bool
isDirtyCT key store = let CT ts = getInfo store in not (any match ts)
where
match (Trace k deps result) = k == key
&& result == getValue key store
&& and [ getHash k store == h | (k, h) <- deps ]
recordCT :: k -> v -> [(k,Hash v)] -> CT k v -> CT k v
recordCT key value deps (CT ts) = CT $ Trace key deps value : ts
constructCT :: (Monad m, Eq k, Eq v) => k -> (k -> m (Hash v)) -> CT k v -> m [v]
constructCT key fetchHash (CT ts) = catMaybes <$> mapM match ts
where
match (Trace k deps result)
| k /= key = return Nothing
| otherwise = do
sameInputs <- andM [ (h==) <$> fetchHash k | (k, h) <- deps ]
return $ if sameInputs then Just result else Nothing
newtype DCT k v = DCT [Trace k v v] deriving (Monoid, Semigroup, Show)
deepDependencies :: (Eq k, Hashable v) => DCT k v -> Hash v -> k -> [k]
deepDependencies (DCT ts) valueHash key =
case [ map fst deps | Trace k deps v <- ts, k == key, hash v == valueHash ] of
[] -> [key]
(deps:_) -> deps
recordDCT :: 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 key value deps fetchHash dct@(DCT ts) = do
let deepDeps = concatMap (deepDependencies dct $ hash value) deps
hs <- mapM fetchHash deepDeps
return $ DCT $ Trace key (zip deepDeps hs) value : ts
constructDCT :: forall k v m. (Eq k, Hashable v, Monad m)
=> k -> (k -> m (Hash v)) -> DCT k v -> m [v]
constructDCT key fetchHash (DCT ts) = constructCT key fetchHash (CT ts)
newtype Step = Step Int deriving (Enum, Eq, Ord, Show)
instance Semigroup Step where Step a <> Step b = Step $ a + b
instance Monoid Step where mempty = Step 0; mappend = (<>)
data TraceST k r = TraceST k [k] r deriving Show
newtype ST k v = ST [TraceST k (Hash v, Step, Step)]
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
[(step, t) | t@(TraceST k2 _ (_, step, _)) <- ts, k == k2]
recordST :: (Hashable v, Eq k) => Step -> k -> v -> [k] -> ST k v -> ST k v
recordST step key value deps (ST ts) =
let hv = hash value
lastChange = case latestST key (ST ts) of
Just (TraceST _ _ (hv2, _, chng)) | hv2 == hv -> chng
_ -> step
in ST $ TraceST key deps (hash value, step, lastChange) : ts
verifyST :: (Monad m, Eq k, Hashable v) => k -> v -> (k -> m ()) -> m (ST k v) -> m Bool
verifyST key value demand st = do
me <- latestST key <$> st
case me of
Just (TraceST _ deps (hv, built, _)) | hash value == hv -> do
mapM_ demand deps
st <- st
return $ and [ built >= chng | Just (TraceST _ _ (_, _, chng)) <- map (flip latestST st) deps]
_ -> return False