{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}

module Unison.Codebase.Causal.Type
  ( Causal (..),
    pattern One,
    pattern Cons,
    pattern Merge,
    before,
    predecessors,
    lca,
  )
where

import Data.Map qualified as Map
import Data.Sequence qualified as Seq
import Data.Set qualified as Set
import U.Codebase.HashTags (CausalHash)
import Unison.Hash (HashFor (..))
import Unison.Prelude
import Prelude hiding (head, read, tail)

{-
`Causal a` has 5 operations, specified algebraically here:

\* `before : Causal m a -> Causal m a -> m Bool` defines a partial order on
            `Causal`.
\* `head : Causal m a -> a`, which represents the "latest" `a` value in a causal
          chain.
\* `one : a -> Causal m a`, satisfying `head (one hd) == hd`
\* `cons : a -> Causal a -> Causal a`, satisfying `head (cons hd tl) == hd` and
          also `before tl (cons hd tl)`.
\* `merge : CommutativeSemigroup a => Causal a -> Causal a -> Causal a`, which is
           commutative (but not associative) and satisfies:
  * `before c1 (merge c1 c2)`
  * `before c2 (merge c1 c2)`
\* `sequence : Causal a -> Causal a -> Causal a`, which is defined as
              `sequence c1 c2 = cons (head c2) (merge c1 c2)`.
  * `before c1 (sequence c1 c2)`
  * `head (sequence c1 c2) == head c2`
-}

instance (Show e) => Show (Causal m e) where
  show :: Causal m e -> String
show = \case
    UnsafeOne CausalHash
h HashFor e
eh e
e -> String
"One " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
3 ShowS -> (CausalHash -> String) -> CausalHash -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CausalHash -> String
forall a. Show a => a -> String
show) CausalHash
h String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
3 ShowS -> (HashFor e -> String) -> HashFor e -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashFor e -> String
forall a. Show a => a -> String
show) HashFor e
eh String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ e -> String
forall a. Show a => a -> String
show e
e
    UnsafeCons CausalHash
h HashFor e
eh e
e (CausalHash, m (Causal m e))
t -> String
"Cons " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
3 ShowS -> (CausalHash -> String) -> CausalHash -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CausalHash -> String
forall a. Show a => a -> String
show) CausalHash
h String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
3 ShowS -> (HashFor e -> String) -> HashFor e -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashFor e -> String
forall a. Show a => a -> String
show) HashFor e
eh String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ e -> String
forall a. Show a => a -> String
show e
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
3 ShowS -> (CausalHash -> String) -> CausalHash -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CausalHash -> String
forall a. Show a => a -> String
show) ((CausalHash, m (Causal m e)) -> CausalHash
forall a b. (a, b) -> a
fst (CausalHash, m (Causal m e))
t)
    UnsafeMerge CausalHash
h HashFor e
eh e
e Map CausalHash (m (Causal m e))
ts -> String
"Merge " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
3 ShowS -> (CausalHash -> String) -> CausalHash -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CausalHash -> String
forall a. Show a => a -> String
show) CausalHash
h String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
3 ShowS -> (HashFor e -> String) -> HashFor e -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashFor e -> String
forall a. Show a => a -> String
show) HashFor e
eh String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ e -> String
forall a. Show a => a -> String
show e
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ([String] -> String
forall a. Show a => a -> String
show ([String] -> String)
-> (Set CausalHash -> [String]) -> Set CausalHash -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CausalHash -> String) -> [CausalHash] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
3 ShowS -> (CausalHash -> String) -> CausalHash -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CausalHash -> String
forall a. Show a => a -> String
show) ([CausalHash] -> [String])
-> (Set CausalHash -> [CausalHash]) -> Set CausalHash -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set CausalHash -> [CausalHash]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList) (Map CausalHash (m (Causal m e)) -> Set CausalHash
forall k a. Map k a -> Set k
Map.keysSet Map CausalHash (m (Causal m e))
ts)

-- h is the type of the pure data structure that will be hashed and used as
-- an index; e.g. h = Branch00, e = Branch0 m
data Causal m e
  = UnsafeOne
      { forall (m :: * -> *) e. Causal m e -> CausalHash
currentHash :: CausalHash,
        forall (m :: * -> *) e. Causal m e -> HashFor e
valueHash :: HashFor e,
        forall (m :: * -> *) e. Causal m e -> e
head :: e
      }
  | UnsafeCons
      { currentHash :: CausalHash,
        valueHash :: HashFor e,
        head :: e,
        forall (m :: * -> *) e. Causal m e -> (CausalHash, m (Causal m e))
tail :: (CausalHash, m (Causal m e))
      }
  | -- The merge operation `<>` flattens and normalizes for order
    UnsafeMerge
      { currentHash :: CausalHash,
        valueHash :: HashFor e,
        head :: e,
        forall (m :: * -> *) e.
Causal m e -> Map CausalHash (m (Causal m e))
tails :: Map CausalHash (m (Causal m e))
      }

pattern One :: CausalHash -> HashFor e -> e -> Causal m e
pattern $mOne :: forall {r} {e} {m :: * -> *}.
Causal m e
-> (CausalHash -> HashFor e -> e -> r) -> ((# #) -> r) -> r
One h eh e <- UnsafeOne h eh e

pattern Cons :: CausalHash -> HashFor e -> e -> (CausalHash, m (Causal m e)) -> Causal m e
pattern $mCons :: forall {r} {e} {m :: * -> *}.
Causal m e
-> (CausalHash
    -> HashFor e -> e -> (CausalHash, m (Causal m e)) -> r)
-> ((# #) -> r)
-> r
Cons h eh e tail <- UnsafeCons h eh e tail

pattern Merge :: CausalHash -> HashFor e -> e -> Map CausalHash (m (Causal m e)) -> Causal m e
pattern $mMerge :: forall {r} {e} {m :: * -> *}.
Causal m e
-> (CausalHash
    -> HashFor e -> e -> Map CausalHash (m (Causal m e)) -> r)
-> ((# #) -> r)
-> r
Merge h eh e tails <- UnsafeMerge h eh e tails

{-# COMPLETE One, Cons, Merge #-}

predecessors :: Causal m e -> Seq (m (Causal m e))
predecessors :: forall (m :: * -> *) e. Causal m e -> Seq (m (Causal m e))
predecessors (UnsafeOne CausalHash
_ HashFor e
_ e
_) = Seq (m (Causal m e))
forall a. Seq a
Seq.empty
predecessors (UnsafeCons CausalHash
_ HashFor e
_ e
_ (CausalHash
_, m (Causal m e)
t)) = m (Causal m e) -> Seq (m (Causal m e))
forall a. a -> Seq a
Seq.singleton m (Causal m e)
t
predecessors (UnsafeMerge CausalHash
_ HashFor e
_ e
_ Map CausalHash (m (Causal m e))
ts) = [m (Causal m e)] -> Seq (m (Causal m e))
forall a. [a] -> Seq a
Seq.fromList ([m (Causal m e)] -> Seq (m (Causal m e)))
-> [m (Causal m e)] -> Seq (m (Causal m e))
forall a b. (a -> b) -> a -> b
$ Map CausalHash (m (Causal m e)) -> [m (Causal m e)]
forall k a. Map k a -> [a]
Map.elems Map CausalHash (m (Causal m e))
ts

before :: (Monad m) => Causal m e -> Causal m e -> m Bool
before :: forall (m :: * -> *) e.
Monad m =>
Causal m e -> Causal m e -> m Bool
before Causal m e
a Causal m e
b = (Maybe (Causal m e) -> Maybe (Causal m e) -> Bool
forall a. Eq a => a -> a -> Bool
== Causal m e -> Maybe (Causal m e)
forall a. a -> Maybe a
Just Causal m e
a) (Maybe (Causal m e) -> Bool) -> m (Maybe (Causal m e)) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 Causal m e
a Causal m e
b

-- Find the lowest common ancestor of two causals.
lca :: (Monad m) => Causal m e -> Causal m e -> m (Maybe (Causal m e))
lca :: forall (m :: * -> *) e.
Monad m =>
Causal m e -> Causal m e -> m (Maybe (Causal m e))
lca Causal m e
a Causal m e
b =
  Seq (m (Causal m e))
-> Seq (m (Causal m e)) -> m (Maybe (Causal m e))
forall (m :: * -> *) e.
Monad m =>
Seq (m (Causal m e))
-> Seq (m (Causal m e)) -> m (Maybe (Causal m e))
lca' (m (Causal m e) -> Seq (m (Causal m e))
forall a. a -> Seq a
Seq.singleton (m (Causal m e) -> Seq (m (Causal m e)))
-> m (Causal m e) -> Seq (m (Causal m e))
forall a b. (a -> b) -> a -> b
$ Causal m e -> m (Causal m e)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Causal m e
a) (m (Causal m e) -> Seq (m (Causal m e))
forall a. a -> Seq a
Seq.singleton (m (Causal m e) -> Seq (m (Causal m e)))
-> m (Causal m e) -> Seq (m (Causal m e))
forall a b. (a -> b) -> a -> b
$ Causal m e -> m (Causal m e)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Causal m e
b)

-- `lca' xs ys` finds the lowest common ancestor of any element of `xs` and any
-- element of `ys`.
-- This is a breadth-first search used in the implementation of `lca a b`.
lca' ::
  (Monad m) =>
  Seq (m (Causal m e)) ->
  Seq (m (Causal m e)) ->
  m (Maybe (Causal m e))
lca' :: forall (m :: * -> *) e.
Monad m =>
Seq (m (Causal m e))
-> Seq (m (Causal m e)) -> m (Maybe (Causal m e))
lca' = Set CausalHash
-> Set CausalHash
-> Seq (m (Causal m e))
-> Seq (m (Causal m e))
-> m (Maybe (Causal m e))
forall {m :: * -> *} {e}.
Monad m =>
Set CausalHash
-> Set CausalHash
-> Seq (m (Causal m e))
-> Seq (m (Causal m e))
-> m (Maybe (Causal m e))
go Set CausalHash
forall a. Set a
Set.empty Set CausalHash
forall a. Set a
Set.empty
  where
    go :: Set CausalHash
-> Set CausalHash
-> Seq (m (Causal m e))
-> Seq (m (Causal m e))
-> m (Maybe (Causal m e))
go Set CausalHash
seenLeft Set CausalHash
seenRight Seq (m (Causal m e))
remainingLeft Seq (m (Causal m e))
remainingRight =
      case Seq (m (Causal m e)) -> ViewL (m (Causal m e))
forall a. Seq a -> ViewL a
Seq.viewl Seq (m (Causal m e))
remainingLeft of
        ViewL (m (Causal m e))
Seq.EmptyL -> Set CausalHash -> Seq (m (Causal m e)) -> m (Maybe (Causal m e))
forall {m :: * -> *} {e}.
Monad m =>
Set CausalHash -> Seq (m (Causal m e)) -> m (Maybe (Causal m e))
search Set CausalHash
seenLeft Seq (m (Causal m e))
remainingRight
        m (Causal m e)
a Seq.:< Seq (m (Causal m e))
as -> do
          Causal m e
left <- m (Causal m e)
a
          if CausalHash -> Set CausalHash -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (Causal m e -> CausalHash
forall (m :: * -> *) e. Causal m e -> CausalHash
currentHash Causal m e
left) Set CausalHash
seenRight
            then Maybe (Causal m e) -> m (Maybe (Causal m e))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Causal m e) -> m (Maybe (Causal m e)))
-> Maybe (Causal m e) -> m (Maybe (Causal m e))
forall a b. (a -> b) -> a -> b
$ Causal m e -> Maybe (Causal m e)
forall a. a -> Maybe a
Just Causal m e
left
            else -- Note: swapping position of left and right when we recurse so that
            -- we search each side equally. This avoids having to case on both
            -- arguments, and the order shouldn't really matter.

              Set CausalHash
-> Set CausalHash
-> Seq (m (Causal m e))
-> Seq (m (Causal m e))
-> m (Maybe (Causal m e))
go
                Set CausalHash
seenRight
                (CausalHash -> Set CausalHash -> Set CausalHash
forall a. Ord a => a -> Set a -> Set a
Set.insert (Causal m e -> CausalHash
forall (m :: * -> *) e. Causal m e -> CausalHash
currentHash Causal m e
left) Set CausalHash
seenLeft)
                Seq (m (Causal m e))
remainingRight
                (Seq (m (Causal m e))
as Seq (m (Causal m e))
-> Seq (m (Causal m e)) -> Seq (m (Causal m e))
forall a. Semigroup a => a -> a -> a
<> Causal m e -> Seq (m (Causal m e))
forall (m :: * -> *) e. Causal m e -> Seq (m (Causal m e))
predecessors Causal m e
left)
    search :: Set CausalHash -> Seq (m (Causal m e)) -> m (Maybe (Causal m e))
search Set CausalHash
seen Seq (m (Causal m e))
remaining = case Seq (m (Causal m e)) -> ViewL (m (Causal m e))
forall a. Seq a -> ViewL a
Seq.viewl Seq (m (Causal m e))
remaining of
      ViewL (m (Causal m e))
Seq.EmptyL -> Maybe (Causal m e) -> m (Maybe (Causal m e))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Causal m e)
forall a. Maybe a
Nothing
      m (Causal m e)
a Seq.:< Seq (m (Causal m e))
as -> do
        Causal m e
current <- m (Causal m e)
a
        if CausalHash -> Set CausalHash -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (Causal m e -> CausalHash
forall (m :: * -> *) e. Causal m e -> CausalHash
currentHash Causal m e
current) Set CausalHash
seen
          then Maybe (Causal m e) -> m (Maybe (Causal m e))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Causal m e) -> m (Maybe (Causal m e)))
-> Maybe (Causal m e) -> m (Maybe (Causal m e))
forall a b. (a -> b) -> a -> b
$ Causal m e -> Maybe (Causal m e)
forall a. a -> Maybe a
Just Causal m e
current
          else Set CausalHash -> Seq (m (Causal m e)) -> m (Maybe (Causal m e))
search Set CausalHash
seen (Seq (m (Causal m e))
as Seq (m (Causal m e))
-> Seq (m (Causal m e)) -> Seq (m (Causal m e))
forall a. Semigroup a => a -> a -> a
<> Causal m e -> Seq (m (Causal m e))
forall (m :: * -> *) e. Causal m e -> Seq (m (Causal m e))
predecessors Causal m e
current)

instance Eq (Causal m a) where
  Causal m a
a == :: Causal m a -> Causal m a -> Bool
== Causal m a
b = Causal m a -> CausalHash
forall (m :: * -> *) e. Causal m e -> CausalHash
currentHash Causal m a
a CausalHash -> CausalHash -> Bool
forall a. Eq a => a -> a -> Bool
== Causal m a -> CausalHash
forall (m :: * -> *) e. Causal m e -> CausalHash
currentHash Causal m a
b

instance Ord (Causal m a) where
  Causal m a
a <= :: Causal m a -> Causal m a -> Bool
<= Causal m a
b = Causal m a -> CausalHash
forall (m :: * -> *) e. Causal m e -> CausalHash
currentHash Causal m a
a CausalHash -> CausalHash -> Bool
forall a. Ord a => a -> a -> Bool
<= Causal m a -> CausalHash
forall (m :: * -> *) e. Causal m e -> CausalHash
currentHash Causal m a
b