{-# 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 h r = Trace
{ key :: k
, depends :: [(k, h)]
, result :: r }
deriving Show
newtype VT k v = VT [Trace k (Hash v) (Hash v)] deriving (Monoid, Semigroup)
recordVT :: (Hashable v, Monad m) => k -> v -> [k] -> (k -> m (Hash v)) -> VT k v -> m (VT k v)
recordVT key value deps fetchHash (VT ts) = do
hs <- mapM fetchHash deps
return $ VT $ Trace key (zip deps hs) (hash value) : ts
verifyVT :: (Monad m, Eq k, Hashable v) => k -> v -> (k -> m (Hash v)) -> VT k v -> m Bool
verifyVT key value fetchHash (VT ts) = anyM match ts
where
match (Trace k deps result)
| k /= key || result /= hash value = return False
| otherwise = andM [ (h==) <$> fetchHash k | (k, h) <- deps ]
newtype CT k v = CT [Trace k (Hash 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 :: Monad m => k -> v -> [k] -> (k -> m (Hash v)) -> CT k v -> m (CT k v)
recordCT key value deps fetchHash (CT ts) = do
hs <- mapM fetchHash deps
return $ CT $ Trace key (zip deps hs) value : ts
constructCT :: (Monad m, Eq k, Eq v) => k -> v -> (k -> m (Hash v)) -> CT k v -> m (Maybe v)
constructCT key value fetchHash (CT ts) = do
candidates <- catMaybes <$> mapM match ts
if value `elem` candidates then return $ Just value
else return $ listToMaybe candidates
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
data Tree a = Leaf a | Node [Tree a]
deriving (Eq, Foldable, Functor, Ord, Show, Traversable)
instance Hashable a => Hashable (Tree a) where
hash (Leaf x) = Leaf <$> hash x
hash (Node x) = Node <$> hash x
newtype DCT k v = DCT [Trace k (Hash (Tree (Hash v))) v] deriving (Monoid, Semigroup)
inputTree :: Eq k => DCT k v -> k -> Tree k
inputTree dct@(DCT ts) key = case [ deps | Trace k deps _ <- ts, k == key ] of
[] -> Leaf key
deps:_ -> Node $ map (inputTree dct . fst) deps
inputHashTree :: (Eq k, Monad m) => DCT k v -> (k -> m (Hash v)) -> k -> m (Tree (Hash v))
inputHashTree dct fetchHash = traverse fetchHash . inputTree dct
recordDCT :: forall k v m. (Hashable 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 ts) = do
hs <- mapM depHash deps
return $ DCT $ Trace key (zip deps hs) value : ts
where
depHash :: k -> m (Hash (Tree (Hash v)))
depHash depKey = case [ deps | Trace k deps _ <- ts, k == depKey ] of
[] -> hash . Leaf <$> fetchHash depKey
deps:_ -> return $ fmap Node $ sequenceA $ map snd deps
constructDCT :: forall k v m. (Hashable k, Hashable v, Monad m)
=> k -> (k -> m (Hash v)) -> DCT k v -> m (Maybe v)
constructDCT key fetchHash dct@(DCT ts) = do
candidates <- catMaybes <$> mapM match ts
case candidates of
[] -> return Nothing
[v] -> return (Just v)
_ -> error "Non-determinism detected"
where
match :: Trace k (Hash (Tree (Hash v))) v -> m (Maybe v)
match (Trace k deps result)
| k /= key = return Nothing
| otherwise = do
sameInputs <- andM [ ((h ==) . hash) <$> inputHashTree dct fetchHash k | (k, h) <- deps ]
return $ if sameInputs then Just result else Nothing
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 = (<>)
newtype ST k v = ST [Trace k () (Hash v, Step, Step)]
deriving (Monoid, Semigroup, Show)
latestST :: Eq k => k -> ST k v -> Maybe (Trace k () (Hash v, Step, Step))
latestST k (ST ts) = fmap snd $ listToMaybe $ reverse $ sortOn fst
[(step, t) | t@(Trace k2 _ (_, step, _)) <- ts, k == k2]
recordST :: (Hashable v, Eq k, Monad m) => Step -> k -> v -> [k] -> ST k v -> m (ST k v)
recordST step key value deps (ST ts) = do
let hv = hash value
let lastChange = case latestST key (ST ts) of
Just (Trace _ _ (hv2, _, chng)) | hv2 == hv -> chng
_ -> step
return $ ST $ Trace key (map (,()) 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 (Trace _ deps (hv, built, _)) | hash value == hv -> do
mapM_ (demand . fst) deps
st <- st
return $ and [ built >= chng | Just (Trace _ _ (_, _, chng)) <- map (flip latestST st . fst) deps]
_ -> return False