{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables #-}

-- | Build traces that are used for recording information from previuos builds.
module Build.Trace (
    Trace (..),

    -- * Verifying traces
    VT, recordVT, verifyVT,

    -- * Constructive traces
    CT, isDirtyCT, recordCT, constructCT,

    -- * Constructive traces optimised for deep tasks
    DCT, recordDCT, constructDCT,

    -- * Step traces
    Step, ST, recordST, verifyST
    ) where

import Build.Store

import Control.Monad.Extra
import Data.List (sortOn)
import Data.Maybe
import Data.Ord

-- | A trace is parameterised by the types of keys @k@, hashes @h@, as well as the
-- result @r@. For verifying traces, @r = h@; for constructive traces, @Hash r = h@.
data Trace k v r = Trace
    { forall k v r. Trace k v r -> k
key     :: k
    , forall k v r. Trace k v r -> [(k, Hash v)]
depends :: [(k, Hash v)]
    , forall k v r. Trace k v r -> r
result  :: r }
    deriving Int -> Trace k v r -> ShowS
[Trace k v r] -> ShowS
Trace k v r -> String
(Int -> Trace k v r -> ShowS)
-> (Trace k v r -> String)
-> ([Trace k v r] -> ShowS)
-> Show (Trace k v r)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k v r.
(Show k, Show v, Show r) =>
Int -> Trace k v r -> ShowS
forall k v r. (Show k, Show v, Show r) => [Trace k v r] -> ShowS
forall k v r. (Show k, Show v, Show r) => Trace k v r -> String
$cshowsPrec :: forall k v r.
(Show k, Show v, Show r) =>
Int -> Trace k v r -> ShowS
showsPrec :: Int -> Trace k v r -> ShowS
$cshow :: forall k v r. (Show k, Show v, Show r) => Trace k v r -> String
show :: Trace k v r -> String
$cshowList :: forall k v r. (Show k, Show v, Show r) => [Trace k v r] -> ShowS
showList :: [Trace k v r] -> ShowS
Show

------------------------------- Verifying traces -------------------------------

-- | An abstract data type for a set of verifying traces equipped with 'recordVT',
-- 'verifyVT' and a 'Monoid' instance.
newtype VT k v = VT [Trace k v (Hash v)] deriving (Semigroup (VT k v)
VT k v
Semigroup (VT k v) =>
VT k v
-> (VT k v -> VT k v -> VT k v)
-> ([VT k v] -> VT k v)
-> Monoid (VT k v)
[VT k v] -> VT k v
VT k v -> VT k v -> VT k v
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall k v. Semigroup (VT k v)
forall k v. VT k v
forall k v. [VT k v] -> VT k v
forall k v. VT k v -> VT k v -> VT k v
$cmempty :: forall k v. VT k v
mempty :: VT k v
$cmappend :: forall k v. VT k v -> VT k v -> VT k v
mappend :: VT k v -> VT k v -> VT k v
$cmconcat :: forall k v. [VT k v] -> VT k v
mconcat :: [VT k v] -> VT k v
Monoid, NonEmpty (VT k v) -> VT k v
VT k v -> VT k v -> VT k v
(VT k v -> VT k v -> VT k v)
-> (NonEmpty (VT k v) -> VT k v)
-> (forall b. Integral b => b -> VT k v -> VT k v)
-> Semigroup (VT k v)
forall b. Integral b => b -> VT k v -> VT k v
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall k v. NonEmpty (VT k v) -> VT k v
forall k v. VT k v -> VT k v -> VT k v
forall k v b. Integral b => b -> VT k v -> VT k v
$c<> :: forall k v. VT k v -> VT k v -> VT k v
<> :: VT k v -> VT k v -> VT k v
$csconcat :: forall k v. NonEmpty (VT k v) -> VT k v
sconcat :: NonEmpty (VT k v) -> VT k v
$cstimes :: forall k v b. Integral b => b -> VT k v -> VT k v
stimes :: forall b. Integral b => b -> VT k v -> VT k v
Semigroup, Int -> VT k v -> ShowS
[VT k v] -> ShowS
VT k v -> String
(Int -> VT k v -> ShowS)
-> (VT k v -> String) -> ([VT k v] -> ShowS) -> Show (VT k v)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k v. (Show k, Show v) => Int -> VT k v -> ShowS
forall k v. (Show k, Show v) => [VT k v] -> ShowS
forall k v. (Show k, Show v) => VT k v -> String
$cshowsPrec :: forall k v. (Show k, Show v) => Int -> VT k v -> ShowS
showsPrec :: Int -> VT k v -> ShowS
$cshow :: forall k v. (Show k, Show v) => VT k v -> String
show :: VT k v -> String
$cshowList :: forall k v. (Show k, Show v) => [VT k v] -> ShowS
showList :: [VT k v] -> ShowS
Show)

-- | Record a new trace for building a @key@ with dependencies @deps@, obtaining
-- the hashes of up-to-date values by using @fetchHash@.
recordVT :: k -> Hash v -> [(k, Hash v)] -> VT k v -> VT k v
recordVT :: forall k v. k -> Hash v -> [(k, Hash v)] -> VT k v -> VT k v
recordVT k
key Hash v
valueHash [(k, Hash v)]
deps (VT [Trace k v (Hash v)]
ts) = [Trace k v (Hash v)] -> VT k v
forall k v. [Trace k v (Hash v)] -> VT k v
VT ([Trace k v (Hash v)] -> VT k v) -> [Trace k v (Hash v)] -> VT k v
forall a b. (a -> b) -> a -> b
$ k -> [(k, Hash v)] -> Hash v -> Trace k v (Hash v)
forall k v r. k -> [(k, Hash v)] -> r -> Trace k v r
Trace k
key [(k, Hash v)]
deps Hash v
valueHash Trace k v (Hash v) -> [Trace k v (Hash v)] -> [Trace k v (Hash v)]
forall a. a -> [a] -> [a]
: [Trace k v (Hash v)]
ts

-- | Given a function to compute the hash of a key's current value,
-- a @key@, and a set of verifying traces, return 'True' if the @key@ is
-- up-to-date.
verifyVT :: (Monad m, Eq k, Eq v) => k -> Hash v -> (k -> m (Hash v)) -> VT k v -> m Bool
verifyVT :: 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 Hash v
valueHash k -> m (Hash v)
fetchHash (VT [Trace k v (Hash v)]
ts) = (Trace k v (Hash v) -> m Bool) -> [Trace k v (Hash v)] -> m Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
anyM Trace k v (Hash v) -> m Bool
match [Trace k v (Hash v)]
ts
  where
    match :: Trace k v (Hash v) -> m Bool
match (Trace k
k [(k, Hash v)]
deps Hash v
result)
        | k
k k -> k -> Bool
forall a. Eq a => a -> a -> Bool
/= k
key Bool -> Bool -> Bool
|| Hash v
result Hash v -> Hash v -> Bool
forall a. Eq a => a -> a -> Bool
/= Hash v
valueHash = Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        | Bool
otherwise = [m Bool] -> m Bool
forall (m :: * -> *). Monad m => [m Bool] -> m Bool
andM [ (Hash v
hHash v -> Hash v -> Bool
forall a. Eq a => a -> a -> Bool
==) (Hash v -> Bool) -> m (Hash v) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> m (Hash v)
fetchHash k
k | (k
k, Hash v
h) <- [(k, Hash v)]
deps ]

------------------------------ Constructive traces -----------------------------

-- | An abstract data type for a set of constructive traces equipped with
-- 'recordCT', 'isDirtyCT', 'constructCT' and a 'Monoid' instance.
newtype CT k v = CT [Trace k v v] deriving (Semigroup (CT k v)
CT k v
Semigroup (CT k v) =>
CT k v
-> (CT k v -> CT k v -> CT k v)
-> ([CT k v] -> CT k v)
-> Monoid (CT k v)
[CT k v] -> CT k v
CT k v -> CT k v -> CT k v
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall k v. Semigroup (CT k v)
forall k v. CT k v
forall k v. [CT k v] -> CT k v
forall k v. CT k v -> CT k v -> CT k v
$cmempty :: forall k v. CT k v
mempty :: CT k v
$cmappend :: forall k v. CT k v -> CT k v -> CT k v
mappend :: CT k v -> CT k v -> CT k v
$cmconcat :: forall k v. [CT k v] -> CT k v
mconcat :: [CT k v] -> CT k v
Monoid, NonEmpty (CT k v) -> CT k v
CT k v -> CT k v -> CT k v
(CT k v -> CT k v -> CT k v)
-> (NonEmpty (CT k v) -> CT k v)
-> (forall b. Integral b => b -> CT k v -> CT k v)
-> Semigroup (CT k v)
forall b. Integral b => b -> CT k v -> CT k v
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall k v. NonEmpty (CT k v) -> CT k v
forall k v. CT k v -> CT k v -> CT k v
forall k v b. Integral b => b -> CT k v -> CT k v
$c<> :: forall k v. CT k v -> CT k v -> CT k v
<> :: CT k v -> CT k v -> CT k v
$csconcat :: forall k v. NonEmpty (CT k v) -> CT k v
sconcat :: NonEmpty (CT k v) -> CT k v
$cstimes :: forall k v b. Integral b => b -> CT k v -> CT k v
stimes :: forall b. Integral b => b -> CT k v -> CT k v
Semigroup, Int -> CT k v -> ShowS
[CT k v] -> ShowS
CT k v -> String
(Int -> CT k v -> ShowS)
-> (CT k v -> String) -> ([CT k v] -> ShowS) -> Show (CT k v)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k v. (Show k, Show v) => Int -> CT k v -> ShowS
forall k v. (Show k, Show v) => [CT k v] -> ShowS
forall k v. (Show k, Show v) => CT k v -> String
$cshowsPrec :: forall k v. (Show k, Show v) => Int -> CT k v -> ShowS
showsPrec :: Int -> CT k v -> ShowS
$cshow :: forall k v. (Show k, Show v) => CT k v -> String
show :: CT k v -> String
$cshowList :: forall k v. (Show k, Show v) => [CT k v] -> ShowS
showList :: [CT k v] -> ShowS
Show)

-- | Check if a given @key@ is dirty w.r.t a @store@.
isDirtyCT :: (Eq k, Hashable v) => k -> Store (CT k v) k v -> Bool
isDirtyCT :: forall k v. (Eq k, Hashable v) => k -> Store (CT k v) k v -> Bool
isDirtyCT k
key Store (CT k v) k v
store = let CT [Trace k v v]
ts = Store (CT k v) k v -> CT k v
forall i k v. Store i k v -> i
getInfo Store (CT k v) k v
store in Bool -> Bool
not ((Trace k v v -> Bool) -> [Trace k v v] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Trace k v v -> Bool
match [Trace k v v]
ts)
  where
    match :: Trace k v v -> Bool
match (Trace k
k [(k, Hash v)]
deps v
result) = k
k k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
key
                               Bool -> Bool -> Bool
&& v
result v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== k -> Store (CT k v) k v -> v
forall k i v. k -> Store i k v -> v
getValue k
key Store (CT k v) k v
store
                               Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ k -> Store (CT k v) k v -> Hash v
forall v k i. Hashable v => k -> Store i k v -> Hash v
getHash k
k Store (CT k v) k v
store Hash v -> Hash v -> Bool
forall a. Eq a => a -> a -> Bool
== Hash v
h | (k
k, Hash v
h) <- [(k, Hash v)]
deps ]

-- | Record a new trace for building a @key@ with dependencies @deps@, obtaining
-- the hashes of up-to-date values by using @fetchHash@.
recordCT :: k -> v -> [(k,Hash v)] -> CT k v -> CT k v
recordCT :: forall k v. k -> v -> [(k, Hash v)] -> CT k v -> CT k v
recordCT k
key v
value [(k, Hash v)]
deps (CT [Trace k v v]
ts) = [Trace k v v] -> CT k v
forall k v. [Trace k v v] -> CT k v
CT ([Trace k v v] -> CT k v) -> [Trace k v v] -> CT k v
forall a b. (a -> b) -> a -> b
$ k -> [(k, Hash v)] -> v -> Trace k v v
forall k v r. k -> [(k, Hash v)] -> r -> Trace k v r
Trace k
key [(k, Hash v)]
deps v
value Trace k v v -> [Trace k v v] -> [Trace k v v]
forall a. a -> [a] -> [a]
: [Trace k v v]
ts

-- | Given a function to compute the hash of a key's current value,
-- a @key@, and a set of constructive traces, return @Just newValue@ if it is
-- possible to reconstruct it from the traces. Prefer reconstructing the
-- currenct value, if it matches one of the traces.
constructCT :: (Monad m, Eq k, Eq v) => k -> (k -> m (Hash v)) -> CT k v -> m [v]
constructCT :: forall (m :: * -> *) k v.
(Monad m, Eq k, Eq v) =>
k -> (k -> m (Hash v)) -> CT k v -> m [v]
constructCT k
key k -> m (Hash v)
fetchHash (CT [Trace k v v]
ts) = [Maybe v] -> [v]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe v] -> [v]) -> m [Maybe v] -> m [v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Trace k v v -> m (Maybe v)) -> [Trace k v v] -> m [Maybe v]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Trace k v v -> m (Maybe v)
forall {a}. Trace k v a -> m (Maybe a)
match [Trace k v v]
ts
  where
    match :: Trace k v a -> m (Maybe a)
match (Trace k
k [(k, Hash v)]
deps a
result)
        | k
k k -> k -> Bool
forall a. Eq a => a -> a -> Bool
/= k
key  = Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
        | Bool
otherwise = do
            Bool
sameInputs <- [m Bool] -> m Bool
forall (m :: * -> *). Monad m => [m Bool] -> m Bool
andM [ (Hash v
hHash v -> Hash v -> Bool
forall a. Eq a => a -> a -> Bool
==) (Hash v -> Bool) -> m (Hash v) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> m (Hash v)
fetchHash k
k | (k
k, Hash v
h) <- [(k, Hash v)]
deps ]
            Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ if Bool
sameInputs then a -> Maybe a
forall a. a -> Maybe a
Just a
result else Maybe a
forall a. Maybe a
Nothing

--------------------------- Deep constructive traces ---------------------------

-- | Our current model has the same representation as 'CT', but requires an
-- additional invariant: if a DCT contains a trace for a key @k@, then it must
-- also contain traces for each of its non-input dependencies.
newtype DCT k v = DCT [Trace k v v] deriving (Semigroup (DCT k v)
DCT k v
Semigroup (DCT k v) =>
DCT k v
-> (DCT k v -> DCT k v -> DCT k v)
-> ([DCT k v] -> DCT k v)
-> Monoid (DCT k v)
[DCT k v] -> DCT k v
DCT k v -> DCT k v -> DCT k v
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall k v. Semigroup (DCT k v)
forall k v. DCT k v
forall k v. [DCT k v] -> DCT k v
forall k v. DCT k v -> DCT k v -> DCT k v
$cmempty :: forall k v. DCT k v
mempty :: DCT k v
$cmappend :: forall k v. DCT k v -> DCT k v -> DCT k v
mappend :: DCT k v -> DCT k v -> DCT k v
$cmconcat :: forall k v. [DCT k v] -> DCT k v
mconcat :: [DCT k v] -> DCT k v
Monoid, NonEmpty (DCT k v) -> DCT k v
DCT k v -> DCT k v -> DCT k v
(DCT k v -> DCT k v -> DCT k v)
-> (NonEmpty (DCT k v) -> DCT k v)
-> (forall b. Integral b => b -> DCT k v -> DCT k v)
-> Semigroup (DCT k v)
forall b. Integral b => b -> DCT k v -> DCT k v
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall k v. NonEmpty (DCT k v) -> DCT k v
forall k v. DCT k v -> DCT k v -> DCT k v
forall k v b. Integral b => b -> DCT k v -> DCT k v
$c<> :: forall k v. DCT k v -> DCT k v -> DCT k v
<> :: DCT k v -> DCT k v -> DCT k v
$csconcat :: forall k v. NonEmpty (DCT k v) -> DCT k v
sconcat :: NonEmpty (DCT k v) -> DCT k v
$cstimes :: forall k v b. Integral b => b -> DCT k v -> DCT k v
stimes :: forall b. Integral b => b -> DCT k v -> DCT k v
Semigroup, Int -> DCT k v -> ShowS
[DCT k v] -> ShowS
DCT k v -> String
(Int -> DCT k v -> ShowS)
-> (DCT k v -> String) -> ([DCT k v] -> ShowS) -> Show (DCT k v)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k v. (Show k, Show v) => Int -> DCT k v -> ShowS
forall k v. (Show k, Show v) => [DCT k v] -> ShowS
forall k v. (Show k, Show v) => DCT k v -> String
$cshowsPrec :: forall k v. (Show k, Show v) => Int -> DCT k v -> ShowS
showsPrec :: Int -> DCT k v -> ShowS
$cshow :: forall k v. (Show k, Show v) => DCT k v -> String
show :: DCT k v -> String
$cshowList :: forall k v. (Show k, Show v) => [DCT k v] -> ShowS
showList :: [DCT k v] -> ShowS
Show)

-- | Extract the tree of input dependencies of a given key.
deepDependencies :: (Eq k, Hashable v) => DCT k v -> Hash v -> k -> [k]
deepDependencies :: forall k v. (Eq k, Hashable v) => DCT k v -> Hash v -> k -> [k]
deepDependencies (DCT [Trace k v v]
ts) Hash v
valueHash k
key =
    case [ ((k, Hash v) -> k) -> [(k, Hash v)] -> [k]
forall a b. (a -> b) -> [a] -> [b]
map (k, Hash v) -> k
forall a b. (a, b) -> a
fst [(k, Hash v)]
deps | Trace k
k [(k, Hash v)]
deps v
v <- [Trace k v v]
ts, k
k k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
key, v -> Hash v
forall a. Hashable a => a -> Hash a
hash v
v Hash v -> Hash v -> Bool
forall a. Eq a => a -> a -> Bool
== Hash v
valueHash ] of
        []       -> [k
key] -- The @key@ is an input
        ([k]
deps:[[k]]
_) -> [k]
deps  -- We assume there is only one record for a pair (k, v)

-- | Record a new trace for building a @key@ with dependencies @deps@, obtaining
-- the hashes of up-to-date values from the given @store@.
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 :: 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
value [k]
deps k -> m (Hash v)
fetchHash dct :: DCT k v
dct@(DCT [Trace k v v]
ts) = do
    let deepDeps :: [k]
deepDeps = (k -> [k]) -> [k] -> [k]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (DCT k v -> Hash v -> k -> [k]
forall k v. (Eq k, Hashable v) => DCT k v -> Hash v -> k -> [k]
deepDependencies DCT k v
dct (Hash v -> k -> [k]) -> Hash v -> k -> [k]
forall a b. (a -> b) -> a -> b
$ v -> Hash v
forall a. Hashable a => a -> Hash a
hash v
value) [k]
deps
    [Hash v]
hs <- (k -> m (Hash v)) -> [k] -> m [Hash v]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM k -> m (Hash v)
fetchHash [k]
deepDeps
    DCT k v -> m (DCT k v)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DCT k v -> m (DCT k v)) -> DCT k v -> m (DCT k v)
forall a b. (a -> b) -> a -> b
$ [Trace k v v] -> DCT k v
forall k v. [Trace k v v] -> DCT k v
DCT ([Trace k v v] -> DCT k v) -> [Trace k v v] -> DCT k v
forall a b. (a -> b) -> a -> b
$ k -> [(k, Hash v)] -> v -> Trace k v v
forall k v r. k -> [(k, Hash v)] -> r -> Trace k v r
Trace k
key ([k] -> [Hash v] -> [(k, Hash v)]
forall a b. [a] -> [b] -> [(a, b)]
zip [k]
deepDeps [Hash v]
hs) v
value Trace k v v -> [Trace k v v] -> [Trace k v v]
forall a. a -> [a] -> [a]
: [Trace k v v]
ts

-- | Given a function to compute the hash of a key's current value,
-- a @key@, and a set of deep constructive traces, return
-- @Just newValue@ if it is possible to reconstruct it from the traces.
constructDCT :: forall k v m. (Eq k, Hashable v, Monad m)
             => k -> (k -> m (Hash v)) -> DCT k v -> m [v]
constructDCT :: forall k v (m :: * -> *).
(Eq k, Hashable v, Monad m) =>
k -> (k -> m (Hash v)) -> DCT k v -> m [v]
constructDCT k
key k -> m (Hash v)
fetchHash (DCT [Trace k v v]
ts) = k -> (k -> m (Hash v)) -> CT k v -> m [v]
forall (m :: * -> *) k v.
(Monad m, Eq k, Eq v) =>
k -> (k -> m (Hash v)) -> CT k v -> m [v]
constructCT k
key k -> m (Hash v)
fetchHash ([Trace k v v] -> CT k v
forall k v. [Trace k v v] -> CT k v
CT [Trace k v v]
ts)

----------------- Step traces: a refinement of verifying traces ----------------
-- Step traces are an optimised version of the direct implementation of
-- verifying traces (as given by the 'VT' datatype), which is used by Shake.
-- They support the same high-level interface that allows to verify if a key is
-- up to date ('verifyST') as well as record new traces ('recordST').

newtype Step = Step Int deriving (Int -> Step
Step -> Int
Step -> [Step]
Step -> Step
Step -> Step -> [Step]
Step -> Step -> Step -> [Step]
(Step -> Step)
-> (Step -> Step)
-> (Int -> Step)
-> (Step -> Int)
-> (Step -> [Step])
-> (Step -> Step -> [Step])
-> (Step -> Step -> [Step])
-> (Step -> Step -> Step -> [Step])
-> Enum Step
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Step -> Step
succ :: Step -> Step
$cpred :: Step -> Step
pred :: Step -> Step
$ctoEnum :: Int -> Step
toEnum :: Int -> Step
$cfromEnum :: Step -> Int
fromEnum :: Step -> Int
$cenumFrom :: Step -> [Step]
enumFrom :: Step -> [Step]
$cenumFromThen :: Step -> Step -> [Step]
enumFromThen :: Step -> Step -> [Step]
$cenumFromTo :: Step -> Step -> [Step]
enumFromTo :: Step -> Step -> [Step]
$cenumFromThenTo :: Step -> Step -> Step -> [Step]
enumFromThenTo :: Step -> Step -> Step -> [Step]
Enum, Step -> Step -> Bool
(Step -> Step -> Bool) -> (Step -> Step -> Bool) -> Eq Step
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Step -> Step -> Bool
== :: Step -> Step -> Bool
$c/= :: Step -> Step -> Bool
/= :: Step -> Step -> Bool
Eq, Eq Step
Eq Step =>
(Step -> Step -> Ordering)
-> (Step -> Step -> Bool)
-> (Step -> Step -> Bool)
-> (Step -> Step -> Bool)
-> (Step -> Step -> Bool)
-> (Step -> Step -> Step)
-> (Step -> Step -> Step)
-> Ord Step
Step -> Step -> Bool
Step -> Step -> Ordering
Step -> Step -> Step
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Step -> Step -> Ordering
compare :: Step -> Step -> Ordering
$c< :: Step -> Step -> Bool
< :: Step -> Step -> Bool
$c<= :: Step -> Step -> Bool
<= :: Step -> Step -> Bool
$c> :: Step -> Step -> Bool
> :: Step -> Step -> Bool
$c>= :: Step -> Step -> Bool
>= :: Step -> Step -> Bool
$cmax :: Step -> Step -> Step
max :: Step -> Step -> Step
$cmin :: Step -> Step -> Step
min :: Step -> Step -> Step
Ord, Int -> Step -> ShowS
[Step] -> ShowS
Step -> String
(Int -> Step -> ShowS)
-> (Step -> String) -> ([Step] -> ShowS) -> Show Step
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Step -> ShowS
showsPrec :: Int -> Step -> ShowS
$cshow :: Step -> String
show :: Step -> String
$cshowList :: [Step] -> ShowS
showList :: [Step] -> ShowS
Show)
instance Semigroup Step where Step Int
a <> :: Step -> Step -> Step
<> Step Int
b = Int -> Step
Step (Int -> Step) -> Int -> Step
forall a b. (a -> b) -> a -> b
$ Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b
instance Monoid Step where mempty :: Step
mempty = Int -> Step
Step Int
0; mappend :: Step -> Step -> Step
mappend = Step -> Step -> Step
forall a. Semigroup a => a -> a -> a
(<>)

data TraceST k r = TraceST k [k] r deriving Int -> TraceST k r -> ShowS
[TraceST k r] -> ShowS
TraceST k r -> String
(Int -> TraceST k r -> ShowS)
-> (TraceST k r -> String)
-> ([TraceST k r] -> ShowS)
-> Show (TraceST k r)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k r. (Show k, Show r) => Int -> TraceST k r -> ShowS
forall k r. (Show k, Show r) => [TraceST k r] -> ShowS
forall k r. (Show k, Show r) => TraceST k r -> String
$cshowsPrec :: forall k r. (Show k, Show r) => Int -> TraceST k r -> ShowS
showsPrec :: Int -> TraceST k r -> ShowS
$cshow :: forall k r. (Show k, Show r) => TraceST k r -> String
show :: TraceST k r -> String
$cshowList :: forall k r. (Show k, Show r) => [TraceST k r] -> ShowS
showList :: [TraceST k r] -> ShowS
Show

-- | A step trace, records the resulting value, the step it last build, the step
-- where it changed.
newtype ST k v = ST [TraceST k (Hash v, Step, Step)]
    deriving (Semigroup (ST k v)
ST k v
Semigroup (ST k v) =>
ST k v
-> (ST k v -> ST k v -> ST k v)
-> ([ST k v] -> ST k v)
-> Monoid (ST k v)
[ST k v] -> ST k v
ST k v -> ST k v -> ST k v
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall k v. Semigroup (ST k v)
forall k v. ST k v
forall k v. [ST k v] -> ST k v
forall k v. ST k v -> ST k v -> ST k v
$cmempty :: forall k v. ST k v
mempty :: ST k v
$cmappend :: forall k v. ST k v -> ST k v -> ST k v
mappend :: ST k v -> ST k v -> ST k v
$cmconcat :: forall k v. [ST k v] -> ST k v
mconcat :: [ST k v] -> ST k v
Monoid, NonEmpty (ST k v) -> ST k v
ST k v -> ST k v -> ST k v
(ST k v -> ST k v -> ST k v)
-> (NonEmpty (ST k v) -> ST k v)
-> (forall b. Integral b => b -> ST k v -> ST k v)
-> Semigroup (ST k v)
forall b. Integral b => b -> ST k v -> ST k v
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall k v. NonEmpty (ST k v) -> ST k v
forall k v. ST k v -> ST k v -> ST k v
forall k v b. Integral b => b -> ST k v -> ST k v
$c<> :: forall k v. ST k v -> ST k v -> ST k v
<> :: ST k v -> ST k v -> ST k v
$csconcat :: forall k v. NonEmpty (ST k v) -> ST k v
sconcat :: NonEmpty (ST k v) -> ST k v
$cstimes :: forall k v b. Integral b => b -> ST k v -> ST k v
stimes :: forall b. Integral b => b -> ST k v -> ST k v
Semigroup, Int -> ST k v -> ShowS
[ST k v] -> ShowS
ST k v -> String
(Int -> ST k v -> ShowS)
-> (ST k v -> String) -> ([ST k v] -> ShowS) -> Show (ST k v)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k v. (Show k, Show v) => Int -> ST k v -> ShowS
forall k v. (Show k, Show v) => [ST k v] -> ShowS
forall k v. (Show k, Show v) => ST k v -> String
$cshowsPrec :: forall k v. (Show k, Show v) => Int -> ST k v -> ShowS
showsPrec :: Int -> ST k v -> ShowS
$cshow :: forall k v. (Show k, Show v) => ST k v -> String
show :: ST k v -> String
$cshowList :: forall k v. (Show k, Show v) => [ST k v] -> ShowS
showList :: [ST k v] -> ShowS
Show)

latestST :: Eq k => k -> ST k v -> Maybe (TraceST k (Hash v, Step, Step))
latestST :: forall k v.
Eq k =>
k -> ST k v -> Maybe (TraceST k (Hash v, Step, Step))
latestST k
k (ST [TraceST k (Hash v, Step, Step)]
ts) = ((Step, TraceST k (Hash v, Step, Step))
 -> TraceST k (Hash v, Step, Step))
-> Maybe (Step, TraceST k (Hash v, Step, Step))
-> Maybe (TraceST k (Hash v, Step, Step))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Step, TraceST k (Hash v, Step, Step))
-> TraceST k (Hash v, Step, Step)
forall a b. (a, b) -> b
snd (Maybe (Step, TraceST k (Hash v, Step, Step))
 -> Maybe (TraceST k (Hash v, Step, Step)))
-> Maybe (Step, TraceST k (Hash v, Step, Step))
-> Maybe (TraceST k (Hash v, Step, Step))
forall a b. (a -> b) -> a -> b
$ [(Step, TraceST k (Hash v, Step, Step))]
-> Maybe (Step, TraceST k (Hash v, Step, Step))
forall a. [a] -> Maybe a
listToMaybe ([(Step, TraceST k (Hash v, Step, Step))]
 -> Maybe (Step, TraceST k (Hash v, Step, Step)))
-> [(Step, TraceST k (Hash v, Step, Step))]
-> Maybe (Step, TraceST k (Hash v, Step, Step))
forall a b. (a -> b) -> a -> b
$ ((Step, TraceST k (Hash v, Step, Step)) -> Down Step)
-> [(Step, TraceST k (Hash v, Step, Step))]
-> [(Step, TraceST k (Hash v, Step, Step))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Step -> Down Step
forall a. a -> Down a
Down (Step -> Down Step)
-> ((Step, TraceST k (Hash v, Step, Step)) -> Step)
-> (Step, TraceST k (Hash v, Step, Step))
-> Down Step
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Step, TraceST k (Hash v, Step, Step)) -> Step
forall a b. (a, b) -> a
fst)
    [(Step
step, TraceST k (Hash v, Step, Step)
t) | t :: TraceST k (Hash v, Step, Step)
t@(TraceST k
k2 [k]
_ (Hash v
_, Step
step, Step
_)) <- [TraceST k (Hash v, Step, Step)]
ts, k
k k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
k2]

-- | Record a new trace for building a @key@ with dependencies @deps@.
recordST :: (Hashable v, Eq k) => Step -> k -> v -> [k] -> ST k v -> ST k v
recordST :: forall v k.
(Hashable v, Eq k) =>
Step -> k -> v -> [k] -> ST k v -> ST k v
recordST Step
step k
key v
value [k]
deps (ST [TraceST k (Hash v, Step, Step)]
ts) =
    let hv :: Hash v
hv = v -> Hash v
forall a. Hashable a => a -> Hash a
hash v
value
        lastChange :: Step
lastChange = case k -> ST k v -> Maybe (TraceST k (Hash v, Step, Step))
forall k v.
Eq k =>
k -> ST k v -> Maybe (TraceST k (Hash v, Step, Step))
latestST k
key ([TraceST k (Hash v, Step, Step)] -> ST k v
forall k v. [TraceST k (Hash v, Step, Step)] -> ST k v
ST [TraceST k (Hash v, Step, Step)]
ts) of
            -- I rebuilt, didn't change, so use the old change time
            Just (TraceST k
_ [k]
_ (Hash v
hv2, Step
_, Step
chng)) | Hash v
hv2 Hash v -> Hash v -> Bool
forall a. Eq a => a -> a -> Bool
== Hash v
hv -> Step
chng
            Maybe (TraceST k (Hash v, Step, Step))
_ -> Step
step
    in [TraceST k (Hash v, Step, Step)] -> ST k v
forall k v. [TraceST k (Hash v, Step, Step)] -> ST k v
ST ([TraceST k (Hash v, Step, Step)] -> ST k v)
-> [TraceST k (Hash v, Step, Step)] -> ST k v
forall a b. (a -> b) -> a -> b
$ k -> [k] -> (Hash v, Step, Step) -> TraceST k (Hash v, Step, Step)
forall k r. k -> [k] -> r -> TraceST k r
TraceST k
key [k]
deps (v -> Hash v
forall a. Hashable a => a -> Hash a
hash v
value, Step
step, Step
lastChange) TraceST k (Hash v, Step, Step)
-> [TraceST k (Hash v, Step, Step)]
-> [TraceST k (Hash v, Step, Step)]
forall a. a -> [a] -> [a]
: [TraceST k (Hash v, Step, Step)]
ts

-- | Given a function to compute the hash of a key's current value,
-- a @key@, and a set of verifying traces, return 'True' if the @key@ is
-- up-to-date.
verifyST :: (Monad m, Eq k, Hashable v) => k -> v -> (k -> m ()) -> m (ST k v) -> m Bool
verifyST :: 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 k -> m ()
demand m (ST k v)
st = do
    Maybe (TraceST k (Hash v, Step, Step))
me <- k -> ST k v -> Maybe (TraceST k (Hash v, Step, Step))
forall k v.
Eq k =>
k -> ST k v -> Maybe (TraceST k (Hash v, Step, Step))
latestST k
key (ST k v -> Maybe (TraceST k (Hash v, Step, Step)))
-> m (ST k v) -> m (Maybe (TraceST k (Hash v, Step, Step)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (ST k v)
st
    case Maybe (TraceST k (Hash v, Step, Step))
me of
        Just (TraceST k
_ [k]
deps (Hash v
hv, Step
built, Step
_)) | v -> Hash v
forall a. Hashable a => a -> Hash a
hash v
value Hash v -> Hash v -> Bool
forall a. Eq a => a -> a -> Bool
== Hash v
hv -> do
            (k -> m ()) -> [k] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ k -> m ()
demand [k]
deps
            ST k v
st <- m (ST k v)
st
            -- things with no traces must be inputs, which I'm going to ignore for now...
            Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Step
built Step -> Step -> Bool
forall a. Ord a => a -> a -> Bool
>= Step
chng | Just (TraceST k
_ [k]
_ (Hash v
_, Step
_, Step
chng)) <- (k -> Maybe (TraceST k (Hash v, Step, Step)))
-> [k] -> [Maybe (TraceST k (Hash v, Step, Step))]
forall a b. (a -> b) -> [a] -> [b]
map (k -> ST k v -> Maybe (TraceST k (Hash v, Step, Step))
forall k v.
Eq k =>
k -> ST k v -> Maybe (TraceST k (Hash v, Step, Step))
`latestST` ST k v
st) [k]
deps]
        Maybe (TraceST k (Hash v, Step, Step))
_ -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False