{-# LANGUAGE TemplateHaskell #-}

module Unison.Codebase.Causal
  ( Causal (currentHash, valueHash, head, tail, tails),
    pattern One,
    pattern Cons,
    pattern Merge,
    head_,
    one,
    cons,
    consDistinct,
    mergeNode,
    uncons,
    predecessors,
    threeWayMerge,
    threeWayMerge',
    squashMerge',
    lca,
    stepDistinct,
    stepDistinctM,
    transform,
    unsafeMapHashPreserving,
    before,
    beforeHash,
  )
where

import Control.Lens qualified as Lens
import Control.Monad.Extra qualified as Monad (anyM)
import Control.Monad.Reader qualified as Reader
import Control.Monad.State qualified as State
import Data.Map qualified as Map
import Data.Set qualified as Set
import U.Codebase.HashTags (CausalHash)
import Unison.Codebase.Causal.Type
  ( Causal
      ( UnsafeCons,
        UnsafeMerge,
        UnsafeOne,
        currentHash,
        head,
        tail,
        tails,
        valueHash
      ),
    before,
    lca,
    predecessors,
    pattern Cons,
    pattern Merge,
    pattern One,
  )
import Unison.Hash (HashFor (HashFor))
import Unison.Hashing.V2 qualified as Hashing (ContentAddressable)
import Unison.Hashing.V2.Convert qualified as Hashing
import Unison.Prelude
import Prelude hiding (head, read, tail)

-- | Focus the current head, keeping the hash up to date.
head_ :: (Hashing.ContentAddressable e) => Lens.Lens' (Causal m e) e
head_ :: forall e (m :: * -> *).
ContentAddressable e =>
Lens' (Causal m e) e
head_ = (Causal m e -> e)
-> (Causal m e -> e -> Causal m e)
-> Lens (Causal m e) (Causal m e) e e
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
Lens.lens Causal m e -> e
forall {m :: * -> *} {e}. Causal m e -> e
getter Causal m e -> e -> Causal m e
forall {e} {m :: * -> *}.
ContentAddressable e =>
Causal m e -> e -> Causal m e
setter
  where
    getter :: Causal m e -> e
getter = Causal m e -> e
forall {m :: * -> *} {e}. Causal m e -> e
head
    setter :: Causal m e -> e -> Causal m e
setter Causal m e
causal e
e =
      case Causal m e
causal of
        UnsafeOne {} -> e -> Causal m e
forall e (m :: * -> *). ContentAddressable e => e -> Causal m e
one e
e
        UnsafeCons {(CausalHash, m (Causal m e))
$sel:tail:UnsafeOne :: forall (m :: * -> *) e. Causal m e -> (CausalHash, m (Causal m e))
tail :: (CausalHash, m (Causal m e))
tail} -> e -> [(CausalHash, m (Causal m e))] -> Causal m e
forall e (m :: * -> *).
ContentAddressable e =>
e -> [(CausalHash, m (Causal m e))] -> Causal m e
fromListM e
e [(CausalHash, m (Causal m e))
tail]
        UnsafeMerge {Map CausalHash (m (Causal m e))
$sel:tails:UnsafeOne :: forall (m :: * -> *) e.
Causal m e -> Map CausalHash (m (Causal m e))
tails :: Map CausalHash (m (Causal m e))
tails} -> e -> Map CausalHash (m (Causal m e)) -> Causal m e
forall e (m :: * -> *).
ContentAddressable e =>
e -> Map CausalHash (m (Causal m e)) -> Causal m e
mergeNode e
e Map CausalHash (m (Causal m e))
tails

-- A `squashMerge combine c1 c2` gives the same resulting `e`
-- as a `threeWayMerge`, but doesn't introduce a merge node for the
-- result. Instead, the resulting causal is a simple `Cons` onto `c2`
-- (or is equal to `c2` if `c1` changes nothing).
squashMerge' ::
  forall m e.
  (Monad m, Hashing.ContentAddressable e, Eq e) =>
  (Causal m e -> Causal m e -> m (Maybe (Causal m e))) ->
  (e -> m e) ->
  (Maybe e -> e -> e -> m e) ->
  Causal m e ->
  Causal m e ->
  m (Causal m e)
squashMerge' :: forall (m :: * -> *) e.
(Monad m, ContentAddressable e, Eq e) =>
(Causal m e -> Causal m e -> m (Maybe (Causal m e)))
-> (e -> m e)
-> (Maybe e -> e -> e -> m e)
-> Causal m e
-> Causal m e
-> m (Causal m e)
squashMerge' Causal m e -> Causal m e -> m (Maybe (Causal m e))
lca e -> m e
discardHistory Maybe e -> e -> e -> m e
combine Causal m e
c1 Causal m e
c2 = do
  Maybe (Causal m e)
theLCA <- Causal m e -> Causal m e -> m (Maybe (Causal m e))
lca Causal m e
c1 Causal m e
c2
  let done :: e -> Causal m e
done e
newHead = e -> Causal m e -> Causal m e
forall (m :: * -> *) e.
(Applicative m, Eq e, ContentAddressable e) =>
e -> Causal m e -> Causal m e
consDistinct e
newHead Causal m e
c2
  case Maybe (Causal m e)
theLCA of
    Maybe (Causal m e)
Nothing -> e -> Causal m e
done (e -> Causal m e) -> m e -> m (Causal m e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe e -> e -> e -> m e
combine Maybe e
forall a. Maybe a
Nothing (Causal m e -> e
forall {m :: * -> *} {e}. Causal m e -> e
head Causal m e
c1) (Causal m e -> e
forall {m :: * -> *} {e}. Causal m e -> e
head Causal m e
c2)
    Just Causal m e
lca
      | Causal m e
lca Causal m e -> Causal m e -> Bool
forall a. Eq a => a -> a -> Bool
== Causal m e
c1 -> Causal m e -> m (Causal m e)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Causal m e
c2
      | Causal m e
lca Causal m e -> Causal m e -> Bool
forall a. Eq a => a -> a -> Bool
== Causal m e
c2 -> e -> Causal m e
done (e -> Causal m e) -> m e -> m (Causal m e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> e -> m e
discardHistory (Causal m e -> e
forall {m :: * -> *} {e}. Causal m e -> e
head Causal m e
c1)
      | Bool
otherwise -> e -> Causal m e
done (e -> Causal m e) -> m e -> m (Causal m e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe e -> e -> e -> m e
combine (e -> Maybe e
forall a. a -> Maybe a
Just (e -> Maybe e) -> e -> Maybe e
forall a b. (a -> b) -> a -> b
$ Causal m e -> e
forall {m :: * -> *} {e}. Causal m e -> e
head Causal m e
lca) (Causal m e -> e
forall {m :: * -> *} {e}. Causal m e -> e
head Causal m e
c1) (Causal m e -> e
forall {m :: * -> *} {e}. Causal m e -> e
head Causal m e
c2)

threeWayMerge ::
  forall m e.
  (Monad m, Hashing.ContentAddressable e) =>
  (Maybe e -> e -> e -> m e) ->
  Causal m e ->
  Causal m e ->
  m (Causal m e)
threeWayMerge :: forall (m :: * -> *) e.
(Monad m, ContentAddressable e) =>
(Maybe e -> e -> e -> m e)
-> Causal m e -> Causal m e -> m (Causal m e)
threeWayMerge = (Causal m e -> Causal m e -> m (Maybe (Causal m e)))
-> (Maybe e -> e -> e -> m e)
-> Causal m e
-> Causal m e
-> m (Causal m e)
forall (m :: * -> *) e.
(Monad m, ContentAddressable e) =>
(Causal m e -> Causal m e -> m (Maybe (Causal m e)))
-> (Maybe e -> e -> e -> m e)
-> Causal m e
-> Causal m e
-> m (Causal m e)
threeWayMerge' Causal m e -> Causal m e -> m (Maybe (Causal m e))
forall (m :: * -> *) e.
Monad m =>
Causal m e -> Causal m e -> m (Maybe (Causal m e))
lca

threeWayMerge' ::
  forall m e.
  (Monad m, Hashing.ContentAddressable e) =>
  (Causal m e -> Causal m e -> m (Maybe (Causal m e))) ->
  (Maybe e -> e -> e -> m e) ->
  Causal m e ->
  Causal m e ->
  m (Causal m e)
threeWayMerge' :: forall (m :: * -> *) e.
(Monad m, ContentAddressable e) =>
(Causal m e -> Causal m e -> m (Maybe (Causal m e)))
-> (Maybe e -> e -> e -> m e)
-> Causal m e
-> Causal m e
-> m (Causal m e)
threeWayMerge' Causal m e -> Causal m e -> m (Maybe (Causal m e))
lca Maybe e -> e -> e -> m e
combine Causal m e
c1 Causal m e
c2 = do
  Maybe (Causal m e)
theLCA <- Causal m e -> Causal m e -> m (Maybe (Causal m e))
lca Causal m e
c1 Causal m e
c2
  case Maybe (Causal m e)
theLCA of
    Maybe (Causal m e)
Nothing -> e -> Causal m e
done (e -> Causal m e) -> m e -> m (Causal m e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe e -> e -> e -> m e
combine Maybe e
forall a. Maybe a
Nothing (Causal m e -> e
forall {m :: * -> *} {e}. Causal m e -> e
head Causal m e
c1) (Causal m e -> e
forall {m :: * -> *} {e}. Causal m e -> e
head Causal m e
c2)
    Just Causal m e
lca
      | Causal m e
lca Causal m e -> Causal m e -> Bool
forall a. Eq a => a -> a -> Bool
== Causal m e
c1 -> Causal m e -> m (Causal m e)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Causal m e
c2
      | Causal m e
lca Causal m e -> Causal m e -> Bool
forall a. Eq a => a -> a -> Bool
== Causal m e
c2 -> Causal m e -> m (Causal m e)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Causal m e
c1
      | Bool
otherwise -> e -> Causal m e
done (e -> Causal m e) -> m e -> m (Causal m e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe e -> e -> e -> m e
combine (e -> Maybe e
forall a. a -> Maybe a
Just (e -> Maybe e) -> e -> Maybe e
forall a b. (a -> b) -> a -> b
$ Causal m e -> e
forall {m :: * -> *} {e}. Causal m e -> e
head Causal m e
lca) (Causal m e -> e
forall {m :: * -> *} {e}. Causal m e -> e
head Causal m e
c1) (Causal m e -> e
forall {m :: * -> *} {e}. Causal m e -> e
head Causal m e
c2)
  where
    done :: e -> Causal m e
    done :: e -> Causal m e
done e
newHead = e -> [Causal m e] -> Causal m e
forall (m :: * -> *) e.
(Applicative m, ContentAddressable e) =>
e -> [Causal m e] -> Causal m e
fromList e
newHead [Causal m e
c1, Causal m e
c2]

-- `True` if `h` is found in the history of `c` within `maxDepth` path length
-- from the tip of `c`
beforeHash :: forall m e. (Monad m) => Word -> CausalHash -> Causal m e -> m Bool
beforeHash :: forall (m :: * -> *) e.
Monad m =>
Word -> CausalHash -> Causal m e -> m Bool
beforeHash Word
maxDepth CausalHash
h Causal m e
c =
  ReaderT Word m Bool -> Word -> m Bool
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
Reader.runReaderT (StateT (Set (Causal m e)) (ReaderT Word m) Bool
-> Set (Causal m e) -> ReaderT Word m Bool
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
State.evalStateT (Causal m e -> StateT (Set (Causal m e)) (ReaderT Word m) Bool
go Causal m e
c) Set (Causal m e)
forall a. Set a
Set.empty) (Word
0 :: Word)
  where
    go :: Causal m e -> StateT (Set (Causal m e)) (ReaderT Word m) Bool
go Causal m e
c | CausalHash
h CausalHash -> CausalHash -> Bool
forall a. Eq a => a -> a -> Bool
== Causal m e -> CausalHash
forall (m :: * -> *) e. Causal m e -> CausalHash
currentHash Causal m e
c = Bool -> StateT (Set (Causal m e)) (ReaderT Word m) Bool
forall a. a -> StateT (Set (Causal m e)) (ReaderT Word m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    go Causal m e
c = do
      Word
currentDepth :: Word <- StateT (Set (Causal m e)) (ReaderT Word m) Word
forall r (m :: * -> *). MonadReader r m => m r
Reader.ask
      if Word
currentDepth Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
>= Word
maxDepth
        then Bool -> StateT (Set (Causal m e)) (ReaderT Word m) Bool
forall a. a -> StateT (Set (Causal m e)) (ReaderT Word m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
        else do
          Set (Causal m e)
seen <- StateT (Set (Causal m e)) (ReaderT Word m) (Set (Causal m e))
forall s (m :: * -> *). MonadState s m => m s
State.get
          [Causal m e]
cs <- ReaderT Word m [Causal m e]
-> StateT (Set (Causal m e)) (ReaderT Word m) [Causal m e]
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Set (Causal m e)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT Word m [Causal m e]
 -> StateT (Set (Causal m e)) (ReaderT Word m) [Causal m e])
-> (m [Causal m e] -> ReaderT Word m [Causal m e])
-> m [Causal m e]
-> StateT (Set (Causal m e)) (ReaderT Word m) [Causal m e]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m [Causal m e] -> ReaderT Word m [Causal m e]
forall (m :: * -> *) a. Monad m => m a -> ReaderT Word m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [Causal m e]
 -> StateT (Set (Causal m e)) (ReaderT Word m) [Causal m e])
-> m [Causal m e]
-> StateT (Set (Causal m e)) (ReaderT Word m) [Causal m e]
forall a b. (a -> b) -> a -> b
$ Seq (Causal m e) -> [Causal m e]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq (Causal m e) -> [Causal m e])
-> m (Seq (Causal m e)) -> m [Causal m e]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq (m (Causal m e)) -> m (Seq (Causal m e))
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => Seq (m a) -> m (Seq a)
sequence (Causal m e -> Seq (m (Causal m e))
forall (m :: * -> *) e. Causal m e -> Seq (m (Causal m e))
predecessors Causal m e
c)
          let unseens :: [Causal m e]
unseens = (Causal m e -> Bool) -> [Causal m e] -> [Causal m e]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Causal m e
c -> Causal m e
c Causal m e -> Set (Causal m e) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set (Causal m e)
seen) [Causal m e]
cs
          (Set (Causal m e) -> Set (Causal m e))
-> StateT (Set (Causal m e)) (ReaderT Word m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' (Set (Causal m e) -> Set (Causal m e) -> Set (Causal m e)
forall a. Semigroup a => a -> a -> a
<> [Causal m e] -> Set (Causal m e)
forall a. Ord a => [a] -> Set a
Set.fromList [Causal m e]
cs)
          (Causal m e -> StateT (Set (Causal m e)) (ReaderT Word m) Bool)
-> [Causal m e] -> StateT (Set (Causal m e)) (ReaderT Word m) Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
Monad.anyM ((Word -> Word)
-> StateT (Set (Causal m e)) (ReaderT Word m) Bool
-> StateT (Set (Causal m e)) (ReaderT Word m) Bool
forall a.
(Word -> Word)
-> StateT (Set (Causal m e)) (ReaderT Word m) a
-> StateT (Set (Causal m e)) (ReaderT Word m) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
Reader.local (Word
1 Word -> Word -> Word
forall a. Num a => a -> a -> a
+) (StateT (Set (Causal m e)) (ReaderT Word m) Bool
 -> StateT (Set (Causal m e)) (ReaderT Word m) Bool)
-> (Causal m e -> StateT (Set (Causal m e)) (ReaderT Word m) Bool)
-> Causal m e
-> StateT (Set (Causal m e)) (ReaderT Word m) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Causal m e -> StateT (Set (Causal m e)) (ReaderT Word m) Bool
go) [Causal m e]
unseens

stepDistinct :: (Applicative m, Eq e, Hashing.ContentAddressable e) => (e -> e) -> Causal m e -> Causal m e
stepDistinct :: forall (m :: * -> *) e.
(Applicative m, Eq e, ContentAddressable e) =>
(e -> e) -> Causal m e -> Causal m e
stepDistinct e -> e
f Causal m e
c = e -> e
f (Causal m e -> e
forall {m :: * -> *} {e}. Causal m e -> e
head Causal m e
c) e -> Causal m e -> Causal m e
forall (m :: * -> *) e.
(Applicative m, Eq e, ContentAddressable e) =>
e -> Causal m e -> Causal m e
`consDistinct` Causal m e
c

stepDistinctM ::
  (Applicative m, Functor n, Eq e, Hashing.ContentAddressable e) =>
  (e -> n e) ->
  Causal m e ->
  n (Causal m e)
stepDistinctM :: forall (m :: * -> *) (n :: * -> *) e.
(Applicative m, Functor n, Eq e, ContentAddressable e) =>
(e -> n e) -> Causal m e -> n (Causal m e)
stepDistinctM e -> n e
f Causal m e
c = (e -> Causal m e -> Causal m e
forall (m :: * -> *) e.
(Applicative m, Eq e, ContentAddressable e) =>
e -> Causal m e -> Causal m e
`consDistinct` Causal m e
c) (e -> Causal m e) -> n e -> n (Causal m e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> e -> n e
f (Causal m e -> e
forall {m :: * -> *} {e}. Causal m e -> e
head Causal m e
c)

-- | Causal construction should go through here for uniformity;
-- with an exception for `one`, which avoids an Applicative constraint.
fromList :: (Applicative m, Hashing.ContentAddressable e) => e -> [Causal m e] -> Causal m e
fromList :: forall (m :: * -> *) e.
(Applicative m, ContentAddressable e) =>
e -> [Causal m e] -> Causal m e
fromList e
e [Causal m e]
cs =
  e -> [(CausalHash, m (Causal m e))] -> Causal m e
forall e (m :: * -> *).
ContentAddressable e =>
e -> [(CausalHash, m (Causal m e))] -> Causal m e
fromListM e
e ((Causal m e -> (CausalHash, m (Causal m e)))
-> [Causal m e] -> [(CausalHash, m (Causal m e))]
forall a b. (a -> b) -> [a] -> [b]
map (\Causal m e
c -> (Causal m e -> CausalHash
forall (m :: * -> *) e. Causal m e -> CausalHash
currentHash Causal m e
c, Causal m e -> m (Causal m e)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Causal m e
c)) [Causal m e]
cs)

-- | Construct a causal from a list of predecessors. The predecessors may be given in any order.
fromListM :: (Hashing.ContentAddressable e) => e -> [(CausalHash, m (Causal m e))] -> Causal m e
fromListM :: forall e (m :: * -> *).
ContentAddressable e =>
e -> [(CausalHash, m (Causal m e))] -> Causal m e
fromListM e
e [(CausalHash, m (Causal m e))]
ts =
  case [(CausalHash, m (Causal m e))]
ts of
    [] -> CausalHash -> HashFor e -> e -> Causal m e
forall (m :: * -> *) e. CausalHash -> HashFor e -> e -> Causal m e
UnsafeOne CausalHash
ch HashFor e
eh e
e
    [(CausalHash, m (Causal m e))
t] -> CausalHash
-> HashFor e -> e -> (CausalHash, m (Causal m e)) -> Causal m e
forall (m :: * -> *) e.
CausalHash
-> HashFor e -> e -> (CausalHash, m (Causal m e)) -> Causal m e
UnsafeCons CausalHash
ch HashFor e
eh e
e (CausalHash, m (Causal m e))
t
    [(CausalHash, m (Causal m e))]
_ -> CausalHash
-> HashFor e -> e -> Map CausalHash (m (Causal m e)) -> Causal m e
forall (m :: * -> *) e.
CausalHash
-> HashFor e -> e -> Map CausalHash (m (Causal m e)) -> Causal m e
UnsafeMerge CausalHash
ch HashFor e
eh e
e ([(CausalHash, m (Causal m e))] -> Map CausalHash (m (Causal m e))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(CausalHash, m (Causal m e))]
ts)
  where
    (CausalHash
ch, HashFor e
eh) = (e -> Set CausalHash -> (CausalHash, HashFor e)
forall e.
ContentAddressable e =>
e -> Set CausalHash -> (CausalHash, HashFor e)
Hashing.hashCausal e
e ([CausalHash] -> Set CausalHash
forall a. Ord a => [a] -> Set a
Set.fromList (((CausalHash, m (Causal m e)) -> CausalHash)
-> [(CausalHash, m (Causal m e))] -> [CausalHash]
forall a b. (a -> b) -> [a] -> [b]
map (CausalHash, m (Causal m e)) -> CausalHash
forall a b. (a, b) -> a
fst [(CausalHash, m (Causal m e))]
ts)))

-- | An optimized variant of 'fromListM' for when it is known we have 2+ predecessors (merge node).
mergeNode :: (Hashing.ContentAddressable e) => e -> Map (CausalHash) (m (Causal m e)) -> Causal m e
mergeNode :: forall e (m :: * -> *).
ContentAddressable e =>
e -> Map CausalHash (m (Causal m e)) -> Causal m e
mergeNode e
newHead Map CausalHash (m (Causal m e))
predecessors =
  let (CausalHash
ch, HashFor e
eh) = e -> Set CausalHash -> (CausalHash, HashFor e)
forall e.
ContentAddressable e =>
e -> Set CausalHash -> (CausalHash, HashFor e)
Hashing.hashCausal e
newHead (Map CausalHash (m (Causal m e)) -> Set CausalHash
forall k a. Map k a -> Set k
Map.keysSet Map CausalHash (m (Causal m e))
predecessors)
   in CausalHash
-> HashFor e -> e -> Map CausalHash (m (Causal m e)) -> Causal m e
forall (m :: * -> *) e.
CausalHash
-> HashFor e -> e -> Map CausalHash (m (Causal m e)) -> Causal m e
UnsafeMerge CausalHash
ch HashFor e
eh e
newHead Map CausalHash (m (Causal m e))
predecessors

-- duplicated logic here instead of delegating to `fromList` to avoid `Applicative m` constraint.
one :: (Hashing.ContentAddressable e) => e -> Causal m e
one :: forall e (m :: * -> *). ContentAddressable e => e -> Causal m e
one e
e = CausalHash -> HashFor e -> e -> Causal m e
forall (m :: * -> *) e. CausalHash -> HashFor e -> e -> Causal m e
UnsafeOne CausalHash
ch HashFor e
eh e
e
  where
    (CausalHash
ch, HashFor e
eh) = e -> Set CausalHash -> (CausalHash, HashFor e)
forall e.
ContentAddressable e =>
e -> Set CausalHash -> (CausalHash, HashFor e)
Hashing.hashCausal e
e Set CausalHash
forall a. Monoid a => a
mempty

cons :: (Applicative m, Hashing.ContentAddressable e) => e -> Causal m e -> Causal m e
cons :: forall (m :: * -> *) e.
(Applicative m, ContentAddressable e) =>
e -> Causal m e -> Causal m e
cons e
e Causal m e
tail = e -> [Causal m e] -> Causal m e
forall (m :: * -> *) e.
(Applicative m, ContentAddressable e) =>
e -> [Causal m e] -> Causal m e
fromList e
e [Causal m e
tail]

consDistinct :: (Applicative m, Eq e, Hashing.ContentAddressable e) => e -> Causal m e -> Causal m e
consDistinct :: forall (m :: * -> *) e.
(Applicative m, Eq e, ContentAddressable e) =>
e -> Causal m e -> Causal m e
consDistinct e
e Causal m e
tl =
  if Causal m e -> e
forall {m :: * -> *} {e}. Causal m e -> e
head Causal m e
tl e -> e -> Bool
forall a. Eq a => a -> a -> Bool
== e
e
    then Causal m e
tl
    else e -> Causal m e -> Causal m e
forall (m :: * -> *) e.
(Applicative m, ContentAddressable e) =>
e -> Causal m e -> Causal m e
cons e
e Causal m e
tl

uncons :: (Applicative m) => Causal m e -> m (Maybe (e, Causal m e))
uncons :: forall (m :: * -> *) e.
Applicative m =>
Causal m e -> m (Maybe (e, Causal m e))
uncons Causal m e
c = case Causal m e
c of
  Cons CausalHash
_ HashFor e
_ e
e (CausalHash
_, m (Causal m e)
tl) -> (Causal m e -> (e, Causal m e))
-> Maybe (Causal m e) -> Maybe (e, Causal m e)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (e
e,) (Maybe (Causal m e) -> Maybe (e, Causal m e))
-> (Causal m e -> Maybe (Causal m e))
-> Causal m e
-> Maybe (e, Causal m e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Causal m e -> Maybe (Causal m e)
forall a. a -> Maybe a
Just (Causal m e -> Maybe (e, Causal m e))
-> m (Causal m e) -> m (Maybe (e, Causal m e))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Causal m e)
tl
  Causal m e
_ -> Maybe (e, Causal m e) -> m (Maybe (e, Causal m e))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (e, Causal m e)
forall a. Maybe a
Nothing

-- it's okay to call "Unsafe"* here with the existing hashes because `nt` can't
-- affect `e`.
transform :: (Functor m) => (forall a. m a -> n a) -> Causal m e -> Causal n e
transform :: forall (m :: * -> *) (n :: * -> *) e.
Functor m =>
(forall a. m a -> n a) -> Causal m e -> Causal n e
transform forall a. m a -> n a
nt Causal m e
c = case Causal m e
c of
  One CausalHash
h HashFor e
eh e
e -> CausalHash -> HashFor e -> e -> Causal n e
forall (m :: * -> *) e. CausalHash -> HashFor e -> e -> Causal m e
UnsafeOne CausalHash
h HashFor e
eh e
e
  Cons CausalHash
h HashFor e
eh e
e (CausalHash
ht, m (Causal m e)
tl) -> CausalHash
-> HashFor e -> e -> (CausalHash, n (Causal n e)) -> Causal n e
forall (m :: * -> *) e.
CausalHash
-> HashFor e -> e -> (CausalHash, m (Causal m e)) -> Causal m e
UnsafeCons CausalHash
h HashFor e
eh e
e (CausalHash
ht, m (Causal n e) -> n (Causal n e)
forall a. m a -> n a
nt ((forall a. m a -> n a) -> Causal m e -> Causal n e
forall (m :: * -> *) (n :: * -> *) e.
Functor m =>
(forall a. m a -> n a) -> Causal m e -> Causal n e
transform m a -> n a
forall a. m a -> n a
nt (Causal m e -> Causal n e) -> m (Causal m e) -> m (Causal n e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Causal m e)
tl))
  Merge CausalHash
h HashFor e
eh e
e Map CausalHash (m (Causal m e))
tls -> CausalHash
-> HashFor e -> e -> Map CausalHash (n (Causal n e)) -> Causal n e
forall (m :: * -> *) e.
CausalHash
-> HashFor e -> e -> Map CausalHash (m (Causal m e)) -> Causal m e
UnsafeMerge CausalHash
h HashFor e
eh e
e (Map CausalHash (n (Causal n e)) -> Causal n e)
-> Map CausalHash (n (Causal n e)) -> Causal n e
forall a b. (a -> b) -> a -> b
$ (m (Causal m e) -> n (Causal n e))
-> Map CausalHash (m (Causal m e))
-> Map CausalHash (n (Causal n e))
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\m (Causal m e)
mc -> m (Causal n e) -> n (Causal n e)
forall a. m a -> n a
nt ((forall a. m a -> n a) -> Causal m e -> Causal n e
forall (m :: * -> *) (n :: * -> *) e.
Functor m =>
(forall a. m a -> n a) -> Causal m e -> Causal n e
transform m a -> n a
forall a. m a -> n a
nt (Causal m e -> Causal n e) -> m (Causal m e) -> m (Causal n e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Causal m e)
mc)) Map CausalHash (m (Causal m e))
tls

-- "unsafe" because the hashes will be wrong if `f` affects aspects of `e` that impact hashing
unsafeMapHashPreserving :: forall m e e2. (Functor m) => (e -> e2) -> Causal m e -> Causal m e2
unsafeMapHashPreserving :: forall (m :: * -> *) e e2.
Functor m =>
(e -> e2) -> Causal m e -> Causal m e2
unsafeMapHashPreserving e -> e2
f Causal m e
c = case Causal m e
c of
  One CausalHash
h HashFor e
eh e
e -> CausalHash -> HashFor e2 -> e2 -> Causal m e2
forall (m :: * -> *) e. CausalHash -> HashFor e -> e -> Causal m e
UnsafeOne CausalHash
h (HashFor e -> HashFor e2
retagValueHash HashFor e
eh) (e -> e2
f e
e)
  Cons CausalHash
h HashFor e
eh e
e (CausalHash
ht, m (Causal m e)
tl) -> CausalHash
-> HashFor e2 -> e2 -> (CausalHash, m (Causal m e2)) -> Causal m e2
forall (m :: * -> *) e.
CausalHash
-> HashFor e -> e -> (CausalHash, m (Causal m e)) -> Causal m e
UnsafeCons CausalHash
h (HashFor e -> HashFor e2
retagValueHash HashFor e
eh) (e -> e2
f e
e) (CausalHash
ht, (e -> e2) -> Causal m e -> Causal m e2
forall (m :: * -> *) e e2.
Functor m =>
(e -> e2) -> Causal m e -> Causal m e2
unsafeMapHashPreserving e -> e2
f (Causal m e -> Causal m e2) -> m (Causal m e) -> m (Causal m e2)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Causal m e)
tl)
  Merge CausalHash
h HashFor e
eh e
e Map CausalHash (m (Causal m e))
tls -> CausalHash
-> HashFor e2
-> e2
-> Map CausalHash (m (Causal m e2))
-> Causal m e2
forall (m :: * -> *) e.
CausalHash
-> HashFor e -> e -> Map CausalHash (m (Causal m e)) -> Causal m e
UnsafeMerge CausalHash
h (HashFor e -> HashFor e2
retagValueHash HashFor e
eh) (e -> e2
f e
e) (Map CausalHash (m (Causal m e2)) -> Causal m e2)
-> Map CausalHash (m (Causal m e2)) -> Causal m e2
forall a b. (a -> b) -> a -> b
$ (m (Causal m e) -> m (Causal m e2))
-> Map CausalHash (m (Causal m e))
-> Map CausalHash (m (Causal m e2))
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ((Causal m e -> Causal m e2) -> m (Causal m e) -> m (Causal m e2)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Causal m e -> Causal m e2) -> m (Causal m e) -> m (Causal m e2))
-> (Causal m e -> Causal m e2) -> m (Causal m e) -> m (Causal m e2)
forall a b. (a -> b) -> a -> b
$ (e -> e2) -> Causal m e -> Causal m e2
forall (m :: * -> *) e e2.
Functor m =>
(e -> e2) -> Causal m e -> Causal m e2
unsafeMapHashPreserving e -> e2
f) Map CausalHash (m (Causal m e))
tls
  where
    retagValueHash :: HashFor e -> HashFor e2
retagValueHash = forall a b. Coercible a b => a -> b
forall a b. Coercible a b => a -> b
coerce @(HashFor e) @(HashFor e2)

data FoldHistoryResult a = Satisfied a | Unsatisfied a deriving (FoldHistoryResult a -> FoldHistoryResult a -> Bool
(FoldHistoryResult a -> FoldHistoryResult a -> Bool)
-> (FoldHistoryResult a -> FoldHistoryResult a -> Bool)
-> Eq (FoldHistoryResult a)
forall a.
Eq a =>
FoldHistoryResult a -> FoldHistoryResult a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a.
Eq a =>
FoldHistoryResult a -> FoldHistoryResult a -> Bool
== :: FoldHistoryResult a -> FoldHistoryResult a -> Bool
$c/= :: forall a.
Eq a =>
FoldHistoryResult a -> FoldHistoryResult a -> Bool
/= :: FoldHistoryResult a -> FoldHistoryResult a -> Bool
Eq, Eq (FoldHistoryResult a)
Eq (FoldHistoryResult a) =>
(FoldHistoryResult a -> FoldHistoryResult a -> Ordering)
-> (FoldHistoryResult a -> FoldHistoryResult a -> Bool)
-> (FoldHistoryResult a -> FoldHistoryResult a -> Bool)
-> (FoldHistoryResult a -> FoldHistoryResult a -> Bool)
-> (FoldHistoryResult a -> FoldHistoryResult a -> Bool)
-> (FoldHistoryResult a
    -> FoldHistoryResult a -> FoldHistoryResult a)
-> (FoldHistoryResult a
    -> FoldHistoryResult a -> FoldHistoryResult a)
-> Ord (FoldHistoryResult a)
FoldHistoryResult a -> FoldHistoryResult a -> Bool
FoldHistoryResult a -> FoldHistoryResult a -> Ordering
FoldHistoryResult a -> FoldHistoryResult a -> FoldHistoryResult a
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
forall a. Ord a => Eq (FoldHistoryResult a)
forall a.
Ord a =>
FoldHistoryResult a -> FoldHistoryResult a -> Bool
forall a.
Ord a =>
FoldHistoryResult a -> FoldHistoryResult a -> Ordering
forall a.
Ord a =>
FoldHistoryResult a -> FoldHistoryResult a -> FoldHistoryResult a
$ccompare :: forall a.
Ord a =>
FoldHistoryResult a -> FoldHistoryResult a -> Ordering
compare :: FoldHistoryResult a -> FoldHistoryResult a -> Ordering
$c< :: forall a.
Ord a =>
FoldHistoryResult a -> FoldHistoryResult a -> Bool
< :: FoldHistoryResult a -> FoldHistoryResult a -> Bool
$c<= :: forall a.
Ord a =>
FoldHistoryResult a -> FoldHistoryResult a -> Bool
<= :: FoldHistoryResult a -> FoldHistoryResult a -> Bool
$c> :: forall a.
Ord a =>
FoldHistoryResult a -> FoldHistoryResult a -> Bool
> :: FoldHistoryResult a -> FoldHistoryResult a -> Bool
$c>= :: forall a.
Ord a =>
FoldHistoryResult a -> FoldHistoryResult a -> Bool
>= :: FoldHistoryResult a -> FoldHistoryResult a -> Bool
$cmax :: forall a.
Ord a =>
FoldHistoryResult a -> FoldHistoryResult a -> FoldHistoryResult a
max :: FoldHistoryResult a -> FoldHistoryResult a -> FoldHistoryResult a
$cmin :: forall a.
Ord a =>
FoldHistoryResult a -> FoldHistoryResult a -> FoldHistoryResult a
min :: FoldHistoryResult a -> FoldHistoryResult a -> FoldHistoryResult a
Ord, Int -> FoldHistoryResult a -> ShowS
[FoldHistoryResult a] -> ShowS
FoldHistoryResult a -> String
(Int -> FoldHistoryResult a -> ShowS)
-> (FoldHistoryResult a -> String)
-> ([FoldHistoryResult a] -> ShowS)
-> Show (FoldHistoryResult a)
forall a. Show a => Int -> FoldHistoryResult a -> ShowS
forall a. Show a => [FoldHistoryResult a] -> ShowS
forall a. Show a => FoldHistoryResult a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> FoldHistoryResult a -> ShowS
showsPrec :: Int -> FoldHistoryResult a -> ShowS
$cshow :: forall a. Show a => FoldHistoryResult a -> String
show :: FoldHistoryResult a -> String
$cshowList :: forall a. Show a => [FoldHistoryResult a] -> ShowS
showList :: [FoldHistoryResult a] -> ShowS
Show)