{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

module Unison.Codebase.Branch.Type
  ( NamespaceHash,
    head,
    headHash,
    namespaceHash,
    Branch (..),
    Branch0,
    branch0,
    Unison.Codebase.Branch.Type.terms,
    Unison.Codebase.Branch.Type.types,
    children,
    nonEmptyChildren,
    history,
    edits,
    isEmpty0,
    deepTerms,
    deepTypes,
    deepDefns,
    deepPaths,
    deepEdits,
    Star,
    UnwrappedBranch,
  )
where

import Control.Lens hiding (children, cons, transform, uncons)
import Control.Monad.State (State)
import Control.Monad.State qualified as State
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map qualified as Map
import Data.Sequence qualified as Seq
import Data.Set qualified as Set
import U.Codebase.HashTags (CausalHash, PatchHash (..))
import Unison.Codebase.Causal.Type (Causal)
import Unison.Codebase.Causal.Type qualified as Causal
import Unison.Codebase.Metadata qualified as Metadata
import Unison.Codebase.Patch (Patch)
import Unison.Codebase.Path (Path (..))
import Unison.Hash qualified as Hash
import Unison.Name (Name)
import Unison.Name qualified as Name
import Unison.NameSegment (NameSegment)
import Unison.NameSegment qualified as NameSegment
import Unison.Prelude hiding (empty)
import Unison.Reference (Reference, TypeReference)
import Unison.Referent (Referent)
import Unison.Util.Defns (Defns (..), DefnsF)
import Unison.Util.Monoid qualified as Monoid
import Unison.Util.Relation (Relation)
import Unison.Util.Relation qualified as R
import Unison.Util.Relation qualified as Relation
import Unison.Util.Star2 qualified as Star2
import Prelude hiding (head, read, subtract)

-- | A node in the Unison namespace hierarchy
-- along with its history.
newtype Branch m = Branch {forall (m :: * -> *). Branch m -> UnwrappedBranch m
_history :: UnwrappedBranch m}
  deriving (Branch m -> Branch m -> Bool
(Branch m -> Branch m -> Bool)
-> (Branch m -> Branch m -> Bool) -> Eq (Branch m)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (m :: * -> *). Branch m -> Branch m -> Bool
$c== :: forall (m :: * -> *). Branch m -> Branch m -> Bool
== :: Branch m -> Branch m -> Bool
$c/= :: forall (m :: * -> *). Branch m -> Branch m -> Bool
/= :: Branch m -> Branch m -> Bool
Eq, Eq (Branch m)
Eq (Branch m) =>
(Branch m -> Branch m -> Ordering)
-> (Branch m -> Branch m -> Bool)
-> (Branch m -> Branch m -> Bool)
-> (Branch m -> Branch m -> Bool)
-> (Branch m -> Branch m -> Bool)
-> (Branch m -> Branch m -> Branch m)
-> (Branch m -> Branch m -> Branch m)
-> Ord (Branch m)
Branch m -> Branch m -> Bool
Branch m -> Branch m -> Ordering
Branch m -> Branch m -> Branch m
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 (m :: * -> *). Eq (Branch m)
forall (m :: * -> *). Branch m -> Branch m -> Bool
forall (m :: * -> *). Branch m -> Branch m -> Ordering
forall (m :: * -> *). Branch m -> Branch m -> Branch m
$ccompare :: forall (m :: * -> *). Branch m -> Branch m -> Ordering
compare :: Branch m -> Branch m -> Ordering
$c< :: forall (m :: * -> *). Branch m -> Branch m -> Bool
< :: Branch m -> Branch m -> Bool
$c<= :: forall (m :: * -> *). Branch m -> Branch m -> Bool
<= :: Branch m -> Branch m -> Bool
$c> :: forall (m :: * -> *). Branch m -> Branch m -> Bool
> :: Branch m -> Branch m -> Bool
$c>= :: forall (m :: * -> *). Branch m -> Branch m -> Bool
>= :: Branch m -> Branch m -> Bool
$cmax :: forall (m :: * -> *). Branch m -> Branch m -> Branch m
max :: Branch m -> Branch m -> Branch m
$cmin :: forall (m :: * -> *). Branch m -> Branch m -> Branch m
min :: Branch m -> Branch m -> Branch m
Ord)

type UnwrappedBranch m = Causal m (Branch0 m)

-- | A Hash for a namespace itself, it doesn't incorporate any history.
type NamespaceHash m = Hash.HashFor (Branch0 m)

type Star r n = Metadata.Star r n

head :: Branch m -> Branch0 m
head :: forall (m :: * -> *). Branch m -> Branch0 m
head (Branch UnwrappedBranch m
c) = UnwrappedBranch m -> Branch0 m
forall (m :: * -> *) e. Causal m e -> e
Causal.head UnwrappedBranch m
c

headHash :: Branch m -> CausalHash
headHash :: forall (m :: * -> *). Branch m -> CausalHash
headHash (Branch UnwrappedBranch m
c) = UnwrappedBranch m -> CausalHash
forall (m :: * -> *) e. Causal m e -> CausalHash
Causal.currentHash UnwrappedBranch m
c

namespaceHash :: Branch m -> NamespaceHash m
namespaceHash :: forall (m :: * -> *). Branch m -> NamespaceHash m
namespaceHash (Branch UnwrappedBranch m
c) = UnwrappedBranch m -> HashFor (Branch0 m)
forall (m :: * -> *) e. Causal m e -> HashFor e
Causal.valueHash UnwrappedBranch m
c

-- | A node in the Unison namespace hierarchy.
--
-- '_terms' and '_types' are the declarations at this level.
-- '_children' are the nodes one level below us.
-- '_edits' are the 'Patch's stored at this node in the code.
--
-- The remaining fields are derived from the four above.
-- None of the record fields are exported to avoid accidental tweaking without updating the
-- associated derived fields.
--
-- Use either the lensy accessors or the field getters.
data Branch0 m = Branch0
  { forall (m :: * -> *). Branch0 m -> Star Referent NameSegment
_terms :: Star Referent NameSegment,
    forall (m :: * -> *). Branch0 m -> Star Reference NameSegment
_types :: Star Reference NameSegment,
    -- | Note the 'Branch' here, not 'Branch0'.
    -- Every level in the tree has a history.
    forall (m :: * -> *). Branch0 m -> Map NameSegment (Branch m)
_children :: Map NameSegment (Branch m),
    forall (m :: * -> *).
Branch0 m -> Map NameSegment (PatchHash, m Patch)
_edits :: Map NameSegment (PatchHash, m Patch),
    -- | True if a branch and its children have no definitions or edits in them.
    -- (Computed recursively, and small enough to justify storing here to avoid computing more than once.)
    forall (m :: * -> *). Branch0 m -> Bool
_isEmpty0 :: Bool,
    -- names for this branch and its children
    forall (m :: * -> *). Branch0 m -> Relation Referent Name
_deepTerms :: Relation Referent Name,
    forall (m :: * -> *). Branch0 m -> Relation Reference Name
_deepTypes :: Relation Reference Name,
    forall (m :: * -> *). Branch0 m -> Set Path
_deepPaths :: Set Path,
    forall (m :: * -> *). Branch0 m -> Map Name PatchHash
_deepEdits :: Map Name PatchHash
  }

instance Eq (Branch0 m) where
  Branch0 m
a == :: Branch0 m -> Branch0 m -> Bool
== Branch0 m
b =
    Branch0 m -> Star Referent NameSegment
forall (m :: * -> *). Branch0 m -> Star Referent NameSegment
_terms Branch0 m
a Star Referent NameSegment -> Star Referent NameSegment -> Bool
forall a. Eq a => a -> a -> Bool
== Branch0 m -> Star Referent NameSegment
forall (m :: * -> *). Branch0 m -> Star Referent NameSegment
_terms Branch0 m
b
      Bool -> Bool -> Bool
&& Branch0 m -> Star Reference NameSegment
forall (m :: * -> *). Branch0 m -> Star Reference NameSegment
_types Branch0 m
a Star Reference NameSegment -> Star Reference NameSegment -> Bool
forall a. Eq a => a -> a -> Bool
== Branch0 m -> Star Reference NameSegment
forall (m :: * -> *). Branch0 m -> Star Reference NameSegment
_types Branch0 m
b
      Bool -> Bool -> Bool
&& Branch0 m -> Map NameSegment (Branch m)
forall (m :: * -> *). Branch0 m -> Map NameSegment (Branch m)
_children Branch0 m
a Map NameSegment (Branch m) -> Map NameSegment (Branch m) -> Bool
forall a. Eq a => a -> a -> Bool
== Branch0 m -> Map NameSegment (Branch m)
forall (m :: * -> *). Branch0 m -> Map NameSegment (Branch m)
_children Branch0 m
b
      Bool -> Bool -> Bool
&& (((PatchHash, m Patch) -> PatchHash)
-> Map NameSegment (PatchHash, m Patch)
-> Map NameSegment PatchHash
forall a b. (a -> b) -> Map NameSegment a -> Map NameSegment b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PatchHash, m Patch) -> PatchHash
forall a b. (a, b) -> a
fst (Map NameSegment (PatchHash, m Patch) -> Map NameSegment PatchHash)
-> (Branch0 m -> Map NameSegment (PatchHash, m Patch))
-> Branch0 m
-> Map NameSegment PatchHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Branch0 m -> Map NameSegment (PatchHash, m Patch)
forall (m :: * -> *).
Branch0 m -> Map NameSegment (PatchHash, m Patch)
_edits) Branch0 m
a Map NameSegment PatchHash -> Map NameSegment PatchHash -> Bool
forall a. Eq a => a -> a -> Bool
== (((PatchHash, m Patch) -> PatchHash)
-> Map NameSegment (PatchHash, m Patch)
-> Map NameSegment PatchHash
forall a b. (a -> b) -> Map NameSegment a -> Map NameSegment b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PatchHash, m Patch) -> PatchHash
forall a b. (a, b) -> a
fst (Map NameSegment (PatchHash, m Patch) -> Map NameSegment PatchHash)
-> (Branch0 m -> Map NameSegment (PatchHash, m Patch))
-> Branch0 m
-> Map NameSegment PatchHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Branch0 m -> Map NameSegment (PatchHash, m Patch)
forall (m :: * -> *).
Branch0 m -> Map NameSegment (PatchHash, m Patch)
_edits) Branch0 m
b

history :: Iso' (Branch m) (UnwrappedBranch m)
history :: forall (m :: * -> *) (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p (UnwrappedBranch m) (f (UnwrappedBranch m))
-> p (Branch m) (f (Branch m))
history = (Branch m -> UnwrappedBranch m)
-> (UnwrappedBranch m -> Branch m)
-> Iso
     (Branch m) (Branch m) (UnwrappedBranch m) (UnwrappedBranch m)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso Branch m -> UnwrappedBranch m
forall (m :: * -> *). Branch m -> UnwrappedBranch m
_history UnwrappedBranch m -> Branch m
forall (m :: * -> *). UnwrappedBranch m -> Branch m
Branch

edits :: Lens' (Branch0 m) (Map NameSegment (PatchHash, m Patch))
edits :: forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Map NameSegment (PatchHash, m Patch)
 -> f (Map NameSegment (PatchHash, m Patch)))
-> Branch0 m -> f (Branch0 m)
edits =
  (Branch0 m -> Map NameSegment (PatchHash, m Patch))
-> (Branch0 m -> Map NameSegment (PatchHash, m Patch) -> Branch0 m)
-> Lens
     (Branch0 m)
     (Branch0 m)
     (Map NameSegment (PatchHash, m Patch))
     (Map NameSegment (PatchHash, m Patch))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
    Branch0 m -> Map NameSegment (PatchHash, m Patch)
forall (m :: * -> *).
Branch0 m -> Map NameSegment (PatchHash, m Patch)
_edits
    ( \Branch0 m
b0 Map NameSegment (PatchHash, m Patch)
e ->
        Branch0 m
b0 {_edits = e}
          Branch0 m -> (Branch0 m -> Branch0 m) -> Branch0 m
forall a b. a -> (a -> b) -> b
& Branch0 m -> Branch0 m
forall (m :: * -> *). Branch0 m -> Branch0 m
deriveIsEmpty
    )

terms :: Lens' (Branch0 m) (Star Referent NameSegment)
terms :: forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Star Referent NameSegment -> f (Star Referent NameSegment))
-> Branch0 m -> f (Branch0 m)
terms =
  (Branch0 m -> Star Referent NameSegment)
-> (Branch0 m -> Star Referent NameSegment -> Branch0 m)
-> Lens
     (Branch0 m)
     (Branch0 m)
     (Star Referent NameSegment)
     (Star Referent NameSegment)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
    Branch0 m -> Star Referent NameSegment
forall (m :: * -> *). Branch0 m -> Star Referent NameSegment
_terms
    \Branch0 m
branch Star Referent NameSegment
terms ->
      Branch0 m
branch {_terms = terms}
        Branch0 m -> (Branch0 m -> Branch0 m) -> Branch0 m
forall a b. a -> (a -> b) -> b
& Branch0 m -> Branch0 m
forall (m :: * -> *). Branch0 m -> Branch0 m
deriveDeepTerms
        Branch0 m -> (Branch0 m -> Branch0 m) -> Branch0 m
forall a b. a -> (a -> b) -> b
& Branch0 m -> Branch0 m
forall (m :: * -> *). Branch0 m -> Branch0 m
deriveIsEmpty

types :: Lens' (Branch0 m) (Star TypeReference NameSegment)
types :: forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Star Reference NameSegment -> f (Star Reference NameSegment))
-> Branch0 m -> f (Branch0 m)
types =
  (Branch0 m -> Star Reference NameSegment)
-> (Branch0 m -> Star Reference NameSegment -> Branch0 m)
-> Lens
     (Branch0 m)
     (Branch0 m)
     (Star Reference NameSegment)
     (Star Reference NameSegment)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
    Branch0 m -> Star Reference NameSegment
forall (m :: * -> *). Branch0 m -> Star Reference NameSegment
_types
    \Branch0 m
branch Star Reference NameSegment
types ->
      Branch0 m
branch {_types = types}
        Branch0 m -> (Branch0 m -> Branch0 m) -> Branch0 m
forall a b. a -> (a -> b) -> b
& Branch0 m -> Branch0 m
forall (m :: * -> *). Branch0 m -> Branch0 m
deriveDeepTypes
        Branch0 m -> (Branch0 m -> Branch0 m) -> Branch0 m
forall a b. a -> (a -> b) -> b
& Branch0 m -> Branch0 m
forall (m :: * -> *). Branch0 m -> Branch0 m
deriveIsEmpty

isEmpty0 :: Branch0 m -> Bool
isEmpty0 :: forall (m :: * -> *). Branch0 m -> Bool
isEmpty0 = Branch0 m -> Bool
forall (m :: * -> *). Branch0 m -> Bool
_isEmpty0

deepTerms :: Branch0 m -> Relation Referent Name
deepTerms :: forall (m :: * -> *). Branch0 m -> Relation Referent Name
deepTerms = Branch0 m -> Relation Referent Name
forall (m :: * -> *). Branch0 m -> Relation Referent Name
_deepTerms

deepTypes :: Branch0 m -> Relation TypeReference Name
deepTypes :: forall (m :: * -> *). Branch0 m -> Relation Reference Name
deepTypes = Branch0 m -> Relation Reference Name
forall (m :: * -> *). Branch0 m -> Relation Reference Name
_deepTypes

deepDefns :: Branch0 m -> DefnsF (Relation Name) Referent TypeReference
deepDefns :: forall (m :: * -> *).
Branch0 m -> DefnsF (Relation Name) Referent Reference
deepDefns Branch0 m
branch =
  Defns
    { $sel:terms:Defns :: Relation Name Referent
terms = Relation Referent Name -> Relation Name Referent
forall a b. Relation a b -> Relation b a
Relation.swap (Branch0 m -> Relation Referent Name
forall (m :: * -> *). Branch0 m -> Relation Referent Name
deepTerms Branch0 m
branch),
      $sel:types:Defns :: Relation Name Reference
types = Relation Reference Name -> Relation Name Reference
forall a b. Relation a b -> Relation b a
Relation.swap (Branch0 m -> Relation Reference Name
forall (m :: * -> *). Branch0 m -> Relation Reference Name
deepTypes Branch0 m
branch)
    }

deepPaths :: Branch0 m -> Set Path
deepPaths :: forall (m :: * -> *). Branch0 m -> Set Path
deepPaths = Branch0 m -> Set Path
forall (m :: * -> *). Branch0 m -> Set Path
_deepPaths

deepEdits :: Branch0 m -> Map Name PatchHash
deepEdits :: forall (m :: * -> *). Branch0 m -> Map Name PatchHash
deepEdits = Branch0 m -> Map Name PatchHash
forall (m :: * -> *). Branch0 m -> Map Name PatchHash
_deepEdits

children :: Lens' (Branch0 m) (Map NameSegment (Branch m))
children :: forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Map NameSegment (Branch m) -> f (Map NameSegment (Branch m)))
-> Branch0 m -> f (Branch0 m)
children = (Branch0 m -> Map NameSegment (Branch m))
-> (Branch0 m -> Map NameSegment (Branch m) -> Branch0 m)
-> Lens
     (Branch0 m)
     (Branch0 m)
     (Map NameSegment (Branch m))
     (Map NameSegment (Branch m))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Branch0 m -> Map NameSegment (Branch m)
forall (m :: * -> *). Branch0 m -> Map NameSegment (Branch m)
_children (\Branch0 {Star Referent NameSegment
_terms :: forall (m :: * -> *). Branch0 m -> Star Referent NameSegment
_terms :: Star Referent NameSegment
_terms, Star Reference NameSegment
_types :: forall (m :: * -> *). Branch0 m -> Star Reference NameSegment
_types :: Star Reference NameSegment
_types, Map NameSegment (PatchHash, m Patch)
_edits :: forall (m :: * -> *).
Branch0 m -> Map NameSegment (PatchHash, m Patch)
_edits :: Map NameSegment (PatchHash, m Patch)
_edits} Map NameSegment (Branch m)
x -> Star Referent NameSegment
-> Star Reference NameSegment
-> Map NameSegment (Branch m)
-> Map NameSegment (PatchHash, m Patch)
-> Branch0 m
forall (m :: * -> *).
Star Referent NameSegment
-> Star Reference NameSegment
-> Map NameSegment (Branch m)
-> Map NameSegment (PatchHash, m Patch)
-> Branch0 m
branch0 Star Referent NameSegment
_terms Star Reference NameSegment
_types Map NameSegment (Branch m)
x Map NameSegment (PatchHash, m Patch)
_edits)

nonEmptyChildren :: Branch0 m -> Map NameSegment (Branch m)
nonEmptyChildren :: forall (m :: * -> *). Branch0 m -> Map NameSegment (Branch m)
nonEmptyChildren Branch0 m
b =
  Branch0 m
b
    Branch0 m
-> (Branch0 m -> Map NameSegment (Branch m))
-> Map NameSegment (Branch m)
forall a b. a -> (a -> b) -> b
& Branch0 m -> Map NameSegment (Branch m)
forall (m :: * -> *). Branch0 m -> Map NameSegment (Branch m)
_children
    Map NameSegment (Branch m)
-> (Map NameSegment (Branch m) -> Map NameSegment (Branch m))
-> Map NameSegment (Branch m)
forall a b. a -> (a -> b) -> b
& (Branch m -> Bool)
-> Map NameSegment (Branch m) -> Map NameSegment (Branch m)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Bool -> Bool
not (Bool -> Bool) -> (Branch m -> Bool) -> Branch m -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Branch0 m -> Bool
forall (m :: * -> *). Branch0 m -> Bool
isEmpty0 (Branch0 m -> Bool) -> (Branch m -> Branch0 m) -> Branch m -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Branch m -> Branch0 m
forall (m :: * -> *). Branch m -> Branch0 m
head)

-- creates a Branch0 from the primary fields and derives the others.
branch0 ::
  forall m.
  Metadata.Star Referent NameSegment ->
  Metadata.Star TypeReference NameSegment ->
  Map NameSegment (Branch m) ->
  Map NameSegment (PatchHash, m Patch) ->
  Branch0 m
branch0 :: forall (m :: * -> *).
Star Referent NameSegment
-> Star Reference NameSegment
-> Map NameSegment (Branch m)
-> Map NameSegment (PatchHash, m Patch)
-> Branch0 m
branch0 Star Referent NameSegment
terms Star Reference NameSegment
types Map NameSegment (Branch m)
children Map NameSegment (PatchHash, m Patch)
edits =
  Branch0
    { _terms :: Star Referent NameSegment
_terms = Star Referent NameSegment
terms,
      _types :: Star Reference NameSegment
_types = Star Reference NameSegment
types,
      _children :: Map NameSegment (Branch m)
_children = Map NameSegment (Branch m)
children,
      _edits :: Map NameSegment (PatchHash, m Patch)
_edits = Map NameSegment (PatchHash, m Patch)
edits,
      $sel:_isEmpty0:Branch0 :: Bool
_isEmpty0 = Bool
False,
      -- These are all overwritten immediately
      $sel:_deepTerms:Branch0 :: Relation Referent Name
_deepTerms = Relation Referent Name
forall a b. Relation a b
R.empty,
      $sel:_deepTypes:Branch0 :: Relation Reference Name
_deepTypes = Relation Reference Name
forall a b. Relation a b
R.empty,
      $sel:_deepPaths:Branch0 :: Set Path
_deepPaths = Set Path
forall a. Set a
Set.empty,
      $sel:_deepEdits:Branch0 :: Map Name PatchHash
_deepEdits = Map Name PatchHash
forall k a. Map k a
Map.empty
    }
    Branch0 m -> (Branch0 m -> Branch0 m) -> Branch0 m
forall a b. a -> (a -> b) -> b
& Branch0 m -> Branch0 m
forall (m :: * -> *). Branch0 m -> Branch0 m
deriveDeepTerms
    Branch0 m -> (Branch0 m -> Branch0 m) -> Branch0 m
forall a b. a -> (a -> b) -> b
& Branch0 m -> Branch0 m
forall (m :: * -> *). Branch0 m -> Branch0 m
deriveDeepTypes
    Branch0 m -> (Branch0 m -> Branch0 m) -> Branch0 m
forall a b. a -> (a -> b) -> b
& Branch0 m -> Branch0 m
forall (m :: * -> *). Branch0 m -> Branch0 m
deriveDeepPaths
    Branch0 m -> (Branch0 m -> Branch0 m) -> Branch0 m
forall a b. a -> (a -> b) -> b
& Branch0 m -> Branch0 m
forall (m :: * -> *). Branch0 m -> Branch0 m
deriveDeepEdits
    Branch0 m -> (Branch0 m -> Branch0 m) -> Branch0 m
forall a b. a -> (a -> b) -> b
& Branch0 m -> Branch0 m
forall (m :: * -> *). Branch0 m -> Branch0 m
deriveIsEmpty

deriveIsEmpty :: Branch0 m -> Branch0 m
deriveIsEmpty :: forall (m :: * -> *). Branch0 m -> Branch0 m
deriveIsEmpty Branch0 m
b0 =
  let isEmpty' :: Bool
isEmpty' =
        Relation Referent NameSegment -> Bool
forall a b. Relation a b -> Bool
R.null (Star Referent NameSegment -> Relation Referent NameSegment
forall fact d1 d2. Star2 fact d1 d2 -> Relation fact d1
Star2.d1 (Star Referent NameSegment -> Relation Referent NameSegment)
-> Star Referent NameSegment -> Relation Referent NameSegment
forall a b. (a -> b) -> a -> b
$ Branch0 m -> Star Referent NameSegment
forall (m :: * -> *). Branch0 m -> Star Referent NameSegment
_terms Branch0 m
b0)
          Bool -> Bool -> Bool
&& Relation Reference NameSegment -> Bool
forall a b. Relation a b -> Bool
R.null (Star Reference NameSegment -> Relation Reference NameSegment
forall fact d1 d2. Star2 fact d1 d2 -> Relation fact d1
Star2.d1 (Star Reference NameSegment -> Relation Reference NameSegment)
-> Star Reference NameSegment -> Relation Reference NameSegment
forall a b. (a -> b) -> a -> b
$ Branch0 m -> Star Reference NameSegment
forall (m :: * -> *). Branch0 m -> Star Reference NameSegment
_types Branch0 m
b0)
          Bool -> Bool -> Bool
&& Map NameSegment (PatchHash, m Patch) -> Bool
forall k a. Map k a -> Bool
Map.null (Branch0 m -> Map NameSegment (PatchHash, m Patch)
forall (m :: * -> *).
Branch0 m -> Map NameSegment (PatchHash, m Patch)
_edits Branch0 m
b0)
          Bool -> Bool -> Bool
&& (Branch m -> Bool) -> Map NameSegment (Branch m) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Branch0 m -> Bool
forall (m :: * -> *). Branch0 m -> Bool
isEmpty0 (Branch0 m -> Bool) -> (Branch m -> Branch0 m) -> Branch m -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Branch m -> Branch0 m
forall (m :: * -> *). Branch m -> Branch0 m
head) (Branch0 m -> Map NameSegment (Branch m)
forall (m :: * -> *). Branch0 m -> Map NameSegment (Branch m)
_children Branch0 m
b0)
   in Branch0 m
b0 {_isEmpty0 = isEmpty'}

-- | Derive the 'deepTerms' field of a branch.
deriveDeepTerms :: Branch0 m -> Branch0 m
deriveDeepTerms :: forall (m :: * -> *). Branch0 m -> Branch0 m
deriveDeepTerms Branch0 m
branch =
  Branch0 m
branch {_deepTerms = R.fromList (makeDeepTerms branch)}
  where
    makeDeepTerms :: Branch0 m -> [(Referent, Name)]
    makeDeepTerms :: forall (m :: * -> *). Branch0 m -> [(Referent, Name)]
makeDeepTerms Branch0 m
branch = State (Set (NamespaceHash m)) [(Referent, Name)]
-> Set (NamespaceHash m) -> [(Referent, Name)]
forall s a. State s a -> s -> a
State.evalState (Seq (DeepChildAcc m)
-> [(Referent, Name)]
-> State (Set (NamespaceHash m)) [(Referent, Name)]
forall (m :: * -> *).
Seq (DeepChildAcc m)
-> [(Referent, Name)] -> DeepState m [(Referent, Name)]
go (DeepChildAcc m -> Seq (DeepChildAcc m)
forall a. a -> Seq a
Seq.singleton ([], Int
0, Branch0 m
branch)) [(Referent, Name)]
forall a. Monoid a => a
mempty) Set (NamespaceHash m)
forall a. Set a
Set.empty
      where
        -- `reversePrefix` might be ["Nat", "base", "lib"], and `b0` the `Nat` sub-namespace.
        -- Then `R.toList` might produce the NameSegment "+", and we put the two together to
        -- construct the name `Name Relative ("+" :| ["Nat","base","lib"])`.
        go ::
          forall m.
          Seq (DeepChildAcc m) ->
          [(Referent, Name)] ->
          DeepState m [(Referent, Name)]
        go :: forall (m :: * -> *).
Seq (DeepChildAcc m)
-> [(Referent, Name)] -> DeepState m [(Referent, Name)]
go Seq (DeepChildAcc m)
Seq.Empty [(Referent, Name)]
acc = [(Referent, Name)]
-> StateT (Set (NamespaceHash m)) Identity [(Referent, Name)]
forall a. a -> StateT (Set (NamespaceHash m)) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Referent, Name)]
acc
        go (e :: DeepChildAcc m
e@([NameSegment]
reversePrefix, Int
_, Branch0 m
b0) Seq.:<| Seq (DeepChildAcc m)
work) [(Referent, Name)]
acc = do
          let terms :: [(Referent, Name)]
              terms :: [(Referent, Name)]
terms =
                ((Referent, NameSegment) -> (Referent, Name))
-> [(Referent, NameSegment)] -> [(Referent, Name)]
forall a b. (a -> b) -> [a] -> [b]
map
                  ((NameSegment -> Name)
-> (Referent, NameSegment) -> (Referent, Name)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (NonEmpty NameSegment -> Name
Name.fromReverseSegments (NonEmpty NameSegment -> Name)
-> (NameSegment -> NonEmpty NameSegment) -> NameSegment -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NameSegment -> [NameSegment] -> NonEmpty NameSegment
forall a. a -> [a] -> NonEmpty a
NonEmpty.:| [NameSegment]
reversePrefix)))
                  (Relation Referent NameSegment -> [(Referent, NameSegment)]
forall a b. Relation a b -> [(a, b)]
R.toList (Star Referent NameSegment -> Relation Referent NameSegment
forall fact d1 d2. Star2 fact d1 d2 -> Relation fact d1
Star2.d1 (Branch0 m -> Star Referent NameSegment
forall (m :: * -> *). Branch0 m -> Star Referent NameSegment
_terms Branch0 m
b0)))
          Seq (DeepChildAcc m)
children <- DeepChildAcc m -> DeepState m (Seq (DeepChildAcc m))
forall (m :: * -> *).
DeepChildAcc m -> DeepState m (Seq (DeepChildAcc m))
deepChildrenHelper DeepChildAcc m
e
          Seq (DeepChildAcc m)
-> [(Referent, Name)]
-> StateT (Set (NamespaceHash m)) Identity [(Referent, Name)]
forall (m :: * -> *).
Seq (DeepChildAcc m)
-> [(Referent, Name)] -> DeepState m [(Referent, Name)]
go (Seq (DeepChildAcc m)
work Seq (DeepChildAcc m)
-> Seq (DeepChildAcc m) -> Seq (DeepChildAcc m)
forall a. Semigroup a => a -> a -> a
<> Seq (DeepChildAcc m)
children) ([(Referent, Name)]
terms [(Referent, Name)] -> [(Referent, Name)] -> [(Referent, Name)]
forall a. Semigroup a => a -> a -> a
<> [(Referent, Name)]
acc)

-- | Derive the 'deepTypes' field of a branch.
deriveDeepTypes :: forall m. Branch0 m -> Branch0 m
deriveDeepTypes :: forall (m :: * -> *). Branch0 m -> Branch0 m
deriveDeepTypes Branch0 m
branch =
  Branch0 m
branch {_deepTypes = R.fromList (makeDeepTypes branch)}
  where
    makeDeepTypes :: Branch0 m -> [(TypeReference, Name)]
    makeDeepTypes :: Branch0 m -> [(Reference, Name)]
makeDeepTypes Branch0 m
branch = State (Set (NamespaceHash m)) [(Reference, Name)]
-> Set (NamespaceHash m) -> [(Reference, Name)]
forall s a. State s a -> s -> a
State.evalState (Seq (DeepChildAcc m)
-> [(Reference, Name)]
-> State (Set (NamespaceHash m)) [(Reference, Name)]
go (DeepChildAcc m -> Seq (DeepChildAcc m)
forall a. a -> Seq a
Seq.singleton ([], Int
0, Branch0 m
branch)) [(Reference, Name)]
forall a. Monoid a => a
mempty) Set (NamespaceHash m)
forall a. Set a
Set.empty
      where
        go ::
          Seq (DeepChildAcc m) ->
          [(TypeReference, Name)] ->
          DeepState m [(TypeReference, Name)]
        go :: Seq (DeepChildAcc m)
-> [(Reference, Name)]
-> State (Set (NamespaceHash m)) [(Reference, Name)]
go Seq (DeepChildAcc m)
Seq.Empty [(Reference, Name)]
acc = [(Reference, Name)]
-> State (Set (NamespaceHash m)) [(Reference, Name)]
forall a. a -> StateT (Set (NamespaceHash m)) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Reference, Name)]
acc
        go (e :: DeepChildAcc m
e@([NameSegment]
reversePrefix, Int
_, Branch0 m
b0) Seq.:<| Seq (DeepChildAcc m)
work) [(Reference, Name)]
acc = do
          let types :: [(TypeReference, Name)]
              types :: [(Reference, Name)]
types = ((Reference, NameSegment) -> (Reference, Name))
-> [(Reference, NameSegment)] -> [(Reference, Name)]
forall a b. (a -> b) -> [a] -> [b]
map ((NameSegment -> Name)
-> (Reference, NameSegment) -> (Reference, Name)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (NonEmpty NameSegment -> Name
Name.fromReverseSegments (NonEmpty NameSegment -> Name)
-> (NameSegment -> NonEmpty NameSegment) -> NameSegment -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NameSegment -> [NameSegment] -> NonEmpty NameSegment
forall a. a -> [a] -> NonEmpty a
NonEmpty.:| [NameSegment]
reversePrefix))) (Relation Reference NameSegment -> [(Reference, NameSegment)]
forall a b. Relation a b -> [(a, b)]
R.toList (Star Reference NameSegment -> Relation Reference NameSegment
forall fact d1 d2. Star2 fact d1 d2 -> Relation fact d1
Star2.d1 (Branch0 m -> Star Reference NameSegment
forall (m :: * -> *). Branch0 m -> Star Reference NameSegment
_types Branch0 m
b0)))
          Seq (DeepChildAcc m)
children <- DeepChildAcc m -> DeepState m (Seq (DeepChildAcc m))
forall (m :: * -> *).
DeepChildAcc m -> DeepState m (Seq (DeepChildAcc m))
deepChildrenHelper DeepChildAcc m
e
          Seq (DeepChildAcc m)
-> [(Reference, Name)]
-> State (Set (NamespaceHash m)) [(Reference, Name)]
go (Seq (DeepChildAcc m)
work Seq (DeepChildAcc m)
-> Seq (DeepChildAcc m) -> Seq (DeepChildAcc m)
forall a. Semigroup a => a -> a -> a
<> Seq (DeepChildAcc m)
children) ([(Reference, Name)]
types [(Reference, Name)] -> [(Reference, Name)] -> [(Reference, Name)]
forall a. Semigroup a => a -> a -> a
<> [(Reference, Name)]
acc)

-- | Derive the 'deepPaths' field of a branch.
deriveDeepPaths :: forall m. Branch0 m -> Branch0 m
deriveDeepPaths :: forall (m :: * -> *). Branch0 m -> Branch0 m
deriveDeepPaths Branch0 m
branch =
  Branch0 m
branch {_deepPaths = makeDeepPaths branch}
  where
    makeDeepPaths :: Branch0 m -> Set Path
    makeDeepPaths :: Branch0 m -> Set Path
makeDeepPaths Branch0 m
branch = State (Set (NamespaceHash m)) (Set Path)
-> Set (NamespaceHash m) -> Set Path
forall s a. State s a -> s -> a
State.evalState (Seq (DeepChildAcc m)
-> Set Path -> State (Set (NamespaceHash m)) (Set Path)
go (DeepChildAcc m -> Seq (DeepChildAcc m)
forall a. a -> Seq a
Seq.singleton ([], Int
0, Branch0 m
branch)) Set Path
forall a. Monoid a => a
mempty) Set (NamespaceHash m)
forall a. Set a
Set.empty
      where
        go :: Seq (DeepChildAcc m) -> Set Path -> DeepState m (Set Path)
        go :: Seq (DeepChildAcc m)
-> Set Path -> State (Set (NamespaceHash m)) (Set Path)
go Seq (DeepChildAcc m)
Seq.Empty Set Path
acc = Set Path -> State (Set (NamespaceHash m)) (Set Path)
forall a. a -> StateT (Set (NamespaceHash m)) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set Path
acc
        go (e :: DeepChildAcc m
e@([NameSegment]
reversePrefix, Int
_, Branch0 m
b0) Seq.:<| Seq (DeepChildAcc m)
work) Set Path
acc = do
          let paths :: Set Path
              paths :: Set Path
paths =
                if Branch0 m -> Bool
forall (m :: * -> *). Branch0 m -> Bool
isEmpty0 Branch0 m
b0
                  then Set Path
forall a. Set a
Set.empty
                  else (Path -> Set Path
forall a. a -> Set a
Set.singleton (Path -> Set Path)
-> ([NameSegment] -> Path) -> [NameSegment] -> Set Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq NameSegment -> Path
Path (Seq NameSegment -> Path)
-> ([NameSegment] -> Seq NameSegment) -> [NameSegment] -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NameSegment] -> Seq NameSegment
forall a. [a] -> Seq a
Seq.fromList ([NameSegment] -> Seq NameSegment)
-> ([NameSegment] -> [NameSegment])
-> [NameSegment]
-> Seq NameSegment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NameSegment] -> [NameSegment]
forall a. [a] -> [a]
reverse) [NameSegment]
reversePrefix
          Seq (DeepChildAcc m)
children <- DeepChildAcc m -> DeepState m (Seq (DeepChildAcc m))
forall (m :: * -> *).
DeepChildAcc m -> DeepState m (Seq (DeepChildAcc m))
deepChildrenHelper DeepChildAcc m
e
          Seq (DeepChildAcc m)
-> Set Path -> State (Set (NamespaceHash m)) (Set Path)
go (Seq (DeepChildAcc m)
work Seq (DeepChildAcc m)
-> Seq (DeepChildAcc m) -> Seq (DeepChildAcc m)
forall a. Semigroup a => a -> a -> a
<> Seq (DeepChildAcc m)
children) (Set Path
paths Set Path -> Set Path -> Set Path
forall a. Semigroup a => a -> a -> a
<> Set Path
acc)

-- | Derive the 'deepEdits' field of a branch.
deriveDeepEdits :: forall m. Branch0 m -> Branch0 m
deriveDeepEdits :: forall (m :: * -> *). Branch0 m -> Branch0 m
deriveDeepEdits Branch0 m
branch =
  Branch0 m
branch {_deepEdits = makeDeepEdits branch}
  where
    makeDeepEdits :: Branch0 m -> Map Name PatchHash
    makeDeepEdits :: Branch0 m -> Map Name PatchHash
makeDeepEdits Branch0 m
branch = State (Set (NamespaceHash m)) (Map Name PatchHash)
-> Set (NamespaceHash m) -> Map Name PatchHash
forall s a. State s a -> s -> a
State.evalState (Seq (DeepChildAcc m)
-> Map Name PatchHash
-> State (Set (NamespaceHash m)) (Map Name PatchHash)
go (DeepChildAcc m -> Seq (DeepChildAcc m)
forall a. a -> Seq a
Seq.singleton ([], Int
0, Branch0 m
branch)) Map Name PatchHash
forall a. Monoid a => a
mempty) Set (NamespaceHash m)
forall a. Set a
Set.empty
      where
        go :: (Seq (DeepChildAcc m)) -> Map Name PatchHash -> DeepState m (Map Name PatchHash)
        go :: Seq (DeepChildAcc m)
-> Map Name PatchHash
-> State (Set (NamespaceHash m)) (Map Name PatchHash)
go Seq (DeepChildAcc m)
Seq.Empty Map Name PatchHash
acc = Map Name PatchHash
-> State (Set (NamespaceHash m)) (Map Name PatchHash)
forall a. a -> StateT (Set (NamespaceHash m)) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Name PatchHash
acc
        go (e :: DeepChildAcc m
e@([NameSegment]
reversePrefix, Int
_, Branch0 m
b0) Seq.:<| Seq (DeepChildAcc m)
work) Map Name PatchHash
acc = do
          let edits :: Map Name PatchHash
              edits :: Map Name PatchHash
edits =
                (NameSegment -> Name)
-> Map NameSegment PatchHash -> Map Name PatchHash
forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysMonotonic
                  (NonEmpty NameSegment -> Name
Name.fromReverseSegments (NonEmpty NameSegment -> Name)
-> (NameSegment -> NonEmpty NameSegment) -> NameSegment -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NameSegment -> [NameSegment] -> NonEmpty NameSegment
forall a. a -> [a] -> NonEmpty a
NonEmpty.:| [NameSegment]
reversePrefix))
                  ((PatchHash, m Patch) -> PatchHash
forall a b. (a, b) -> a
fst ((PatchHash, m Patch) -> PatchHash)
-> Map NameSegment (PatchHash, m Patch)
-> Map NameSegment PatchHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Branch0 m -> Map NameSegment (PatchHash, m Patch)
forall (m :: * -> *).
Branch0 m -> Map NameSegment (PatchHash, m Patch)
_edits Branch0 m
b0)
          Seq (DeepChildAcc m)
children <- DeepChildAcc m -> DeepState m (Seq (DeepChildAcc m))
forall (m :: * -> *).
DeepChildAcc m -> DeepState m (Seq (DeepChildAcc m))
deepChildrenHelper DeepChildAcc m
e
          Seq (DeepChildAcc m)
-> Map Name PatchHash
-> State (Set (NamespaceHash m)) (Map Name PatchHash)
go (Seq (DeepChildAcc m)
work Seq (DeepChildAcc m)
-> Seq (DeepChildAcc m) -> Seq (DeepChildAcc m)
forall a. Semigroup a => a -> a -> a
<> Seq (DeepChildAcc m)
children) (Map Name PatchHash
edits Map Name PatchHash -> Map Name PatchHash -> Map Name PatchHash
forall a. Semigroup a => a -> a -> a
<> Map Name PatchHash
acc)

-- | State used by deepChildrenHelper to determine whether to descend into a child branch.
-- Contains the set of visited namespace hashes.
type DeepState m = State (Set (NamespaceHash m))

-- | Represents a unit of remaining work in traversing children for computing `deep*`.
-- (reverse prefix to a branch, the number of `lib` segments in the reverse prefix, and the branch itself)
type DeepChildAcc m = ([NameSegment], Int, Branch0 m)

-- | Helper for knowing whether to descend into a child branch or not.
-- Accepts child namespaces with previously unseen hashes, and any nested under 1 or fewer `lib` segments.
deepChildrenHelper :: forall m. DeepChildAcc m -> DeepState m (Seq (DeepChildAcc m))
deepChildrenHelper :: forall (m :: * -> *).
DeepChildAcc m -> DeepState m (Seq (DeepChildAcc m))
deepChildrenHelper ([NameSegment]
reversePrefix, Int
libDepth, Branch0 m
b0) = do
  let go :: (NameSegment, Branch m) -> DeepState m (Seq (DeepChildAcc m))
      go :: (NameSegment, Branch m) -> DeepState m (Seq (DeepChildAcc m))
go (NameSegment
ns, Branch m
b) = do
        let h :: NamespaceHash m
h = Branch m -> NamespaceHash m
forall (m :: * -> *). Branch m -> NamespaceHash m
namespaceHash Branch m
b
        Seq (DeepChildAcc m)
result <- do
          let isShallowDependency :: Bool
isShallowDependency = Int
libDepth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1
          Bool
isUnseenNamespace <- (Set (NamespaceHash m) -> Bool)
-> StateT (Set (NamespaceHash m)) Identity Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets (NamespaceHash m -> Set (NamespaceHash m) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember NamespaceHash m
h)
          pure
            if Bool
isShallowDependency Bool -> Bool -> Bool
|| Bool
isUnseenNamespace
              then
                let libDepth' :: Int
libDepth' = if NameSegment
ns NameSegment -> NameSegment -> Bool
forall a. Eq a => a -> a -> Bool
== NameSegment
NameSegment.libSegment then Int
libDepth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 else Int
libDepth
                 in DeepChildAcc m -> Seq (DeepChildAcc m)
forall a. a -> Seq a
Seq.singleton (NameSegment
ns NameSegment -> [NameSegment] -> [NameSegment]
forall a. a -> [a] -> [a]
: [NameSegment]
reversePrefix, Int
libDepth', Branch m -> Branch0 m
forall (m :: * -> *). Branch m -> Branch0 m
head Branch m
b)
              else Seq (DeepChildAcc m)
forall a. Seq a
Seq.empty
        (Set (NamespaceHash m) -> Set (NamespaceHash m))
-> StateT (Set (NamespaceHash m)) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' (NamespaceHash m -> Set (NamespaceHash m) -> Set (NamespaceHash m)
forall a. Ord a => a -> Set a -> Set a
Set.insert NamespaceHash m
h)
        pure Seq (DeepChildAcc m)
result
  ((NameSegment, Branch m) -> DeepState m (Seq (DeepChildAcc m)))
-> [(NameSegment, Branch m)] -> DeepState m (Seq (DeepChildAcc m))
forall (m :: * -> *) (f :: * -> *) b a.
(Monad m, Foldable f, Monoid b) =>
(a -> m b) -> f a -> m b
Monoid.foldMapM (NameSegment, Branch m) -> DeepState m (Seq (DeepChildAcc m))
go (Map NameSegment (Branch m) -> [(NameSegment, Branch m)]
forall k a. Map k a -> [(k, a)]
Map.toList (Branch0 m -> Map NameSegment (Branch m)
forall (m :: * -> *). Branch0 m -> Map NameSegment (Branch m)
nonEmptyChildren Branch0 m
b0))