-- | This module contains functionality that is common to the general idea of "updating" a term in Unison, which is when
-- we reassign a name from one hash to another and then see if all dependents still typecheck.
--
-- This occurs in the `pull`, `merge`, `update`, and `upgrade` commands.
module Unison.Cli.UpdateUtils
  ( -- * Loading definitions
    loadNamespaceDefinitions,

    -- * Getting dependents in a namespace
    getNamespaceDependentsOf,
    getNamespaceDependentsOf2,
    getNamespaceDependentsOf3,

    -- * Narrowing definitions
    narrowDefns,

    -- * Hydrating definitions
    hydrateDefns,

    -- * Parsing and typechecking
    parseAndTypecheck,
  )
where

import Control.Monad.Reader (ask)
import Data.Bifoldable (bifold, bifoldMap)
import Data.Bitraversable (bitraverse)
import Data.Foldable qualified as Foldable
import Data.List qualified as List
import Data.List.NonEmpty qualified as List.NonEmpty
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Set.NonEmpty (NESet)
import Data.Set.NonEmpty qualified as Set.NonEmpty
import U.Codebase.Branch qualified as V2
import U.Codebase.Causal qualified
import U.Codebase.Reference (TermReferenceId, TypeReferenceId)
import U.Codebase.Referent qualified as V2
import U.Codebase.Sqlite.Operations qualified as Operations
import Unison.Cli.Monad (Cli, Env (..))
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.TypeCheck (computeTypecheckingEnvironment)
import Unison.Debug qualified as Debug
import Unison.FileParsers qualified as FileParsers
import Unison.Hash (Hash)
import Unison.Name (Name)
import Unison.Name qualified as Name
import Unison.NameSegment (NameSegment)
import Unison.NameSegment qualified as NameSegment
import Unison.Names (Names)
import Unison.Names qualified as Names
import Unison.Parser.Ann (Ann)
import Unison.Parsers qualified as Parsers
import Unison.Prelude
import Unison.Reference (Reference, TermReference, TypeReference)
import Unison.Reference qualified as Reference
import Unison.Referent (Referent)
import Unison.Referent qualified as Referent
import Unison.Result qualified as Result
import Unison.Sqlite (Transaction)
import Unison.Symbol (Symbol)
import Unison.Syntax.Parser qualified as Parser
import Unison.UnisonFile (TypecheckedUnisonFile)
import Unison.Util.BiMultimap (BiMultimap)
import Unison.Util.BiMultimap qualified as BiMultimap
import Unison.Util.Conflicted (Conflicted (..))
import Unison.Util.Defn (Defn (..))
import Unison.Util.Defns (Defns (..), DefnsF, DefnsF2)
import Unison.Util.Nametree (Nametree (..), traverseNametreeWithName, unflattenNametrees)
import Unison.Util.Pretty (Pretty)
import Unison.Util.Pretty qualified as Pretty
import Unison.Util.Relation (Relation)
import Unison.Util.Relation qualified as Relation
import Unison.Util.Set qualified as Set
import Prelude hiding (unzip, zip, zipWith)

------------------------------------------------------------------------------------------------------------------------
-- Loading definitions

-- Load all "namespace definitions" of a branch, which are all terms and type declarations *except* those defined
-- in the "lib" namespace.
--
-- Fails if there is a conflicted name.
loadNamespaceDefinitions ::
  forall m.
  (Monad m) =>
  (V2.Referent -> m Referent) ->
  V2.Branch m ->
  m
    ( Either
        (Defn (Conflicted Name Referent) (Conflicted Name TypeReference))
        (Nametree (DefnsF (Map NameSegment) Referent TypeReference))
    )
loadNamespaceDefinitions :: forall (m :: * -> *).
Monad m =>
(Referent -> m Referent)
-> Branch m
-> m (Either
        (Defn (Conflicted Name Referent) (Conflicted Name Reference))
        (Nametree (DefnsF (Map NameSegment) Referent Reference)))
loadNamespaceDefinitions Referent -> m Referent
referent2to1 =
  (Nametree (DefnsF2 (Map NameSegment) NESet Referent Reference)
 -> Either
      (Defn (Conflicted Name Referent) (Conflicted Name Reference))
      (Nametree (DefnsF (Map NameSegment) Referent Reference)))
-> m (Nametree
        (DefnsF2 (Map NameSegment) NESet Referent Reference))
-> m (Either
        (Defn (Conflicted Name Referent) (Conflicted Name Reference))
        (Nametree (DefnsF (Map NameSegment) Referent Reference)))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Nametree (DefnsF2 (Map NameSegment) NESet Referent Reference)
-> Either
     (Defn (Conflicted Name Referent) (Conflicted Name Reference))
     (Nametree (DefnsF (Map NameSegment) Referent Reference))
assertNamespaceHasNoConflictedNames (m (Nametree (DefnsF2 (Map NameSegment) NESet Referent Reference))
 -> m (Either
         (Defn (Conflicted Name Referent) (Conflicted Name Reference))
         (Nametree (DefnsF (Map NameSegment) Referent Reference))))
-> (Branch m
    -> m (Nametree
            (DefnsF2 (Map NameSegment) NESet Referent Reference)))
-> Branch m
-> m (Either
        (Defn (Conflicted Name Referent) (Conflicted Name Reference))
        (Nametree (DefnsF (Map NameSegment) Referent Reference)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x. Map NameSegment x -> Map NameSegment x)
-> Branch m
-> m (Nametree
        (DefnsF2 (Map NameSegment) NESet Referent Reference))
go (NameSegment -> Map NameSegment x -> Map NameSegment x
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete NameSegment
NameSegment.libSegment)
  where
    go ::
      (forall x. Map NameSegment x -> Map NameSegment x) ->
      V2.Branch m ->
      m (Nametree (DefnsF2 (Map NameSegment) NESet Referent TypeReference))
    go :: (forall x. Map NameSegment x -> Map NameSegment x)
-> Branch m
-> m (Nametree
        (DefnsF2 (Map NameSegment) NESet Referent Reference))
go forall x. Map NameSegment x -> Map NameSegment x
f Branch m
branch = do
      Map NameSegment (NESet Referent)
terms <- Map NameSegment (Map Referent (m MdValues))
-> (Map Referent (m MdValues) -> m (NESet Referent))
-> m (Map NameSegment (NESet Referent))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Branch m
branch.terms (([Referent] -> NESet Referent)
-> m [Referent] -> m (NESet Referent)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NonEmpty Referent -> NESet Referent
forall a. Ord a => NonEmpty a -> NESet a
Set.NonEmpty.fromList (NonEmpty Referent -> NESet Referent)
-> ([Referent] -> NonEmpty Referent)
-> [Referent]
-> NESet Referent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Referent] -> NonEmpty Referent
forall a. HasCallStack => [a] -> NonEmpty a
List.NonEmpty.fromList) (m [Referent] -> m (NESet Referent))
-> (Map Referent (m MdValues) -> m [Referent])
-> Map Referent (m MdValues)
-> m (NESet Referent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Referent -> m Referent) -> [Referent] -> m [Referent]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Referent -> m Referent
referent2to1 ([Referent] -> m [Referent])
-> (Map Referent (m MdValues) -> [Referent])
-> Map Referent (m MdValues)
-> m [Referent]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Referent (m MdValues) -> [Referent]
forall k a. Map k a -> [k]
Map.keys)
      let types :: Map NameSegment (NESet Reference)
types = (Map Reference (m MdValues) -> NESet Reference)
-> Map NameSegment (Map Reference (m MdValues))
-> Map NameSegment (NESet Reference)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Set Reference -> NESet Reference
forall a. Set a -> NESet a
Set.NonEmpty.unsafeFromSet (Set Reference -> NESet Reference)
-> (Map Reference (m MdValues) -> Set Reference)
-> Map Reference (m MdValues)
-> NESet Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Reference (m MdValues) -> Set Reference
forall k a. Map k a -> Set k
Map.keysSet) Branch m
branch.types
      Map
  NameSegment
  (Nametree (DefnsF2 (Map NameSegment) NESet Referent Reference))
children <-
        Map NameSegment (CausalBranch m)
-> (CausalBranch m
    -> m (Nametree
            (DefnsF2 (Map NameSegment) NESet Referent Reference)))
-> m (Map
        NameSegment
        (Nametree (DefnsF2 (Map NameSegment) NESet Referent Reference)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Map NameSegment (CausalBranch m)
-> Map NameSegment (CausalBranch m)
forall x. Map NameSegment x -> Map NameSegment x
f Branch m
branch.children) \CausalBranch m
childCausal -> do
          Branch m
child <- CausalBranch m
childCausal.value
          (forall x. Map NameSegment x -> Map NameSegment x)
-> Branch m
-> m (Nametree
        (DefnsF2 (Map NameSegment) NESet Referent Reference))
go Map NameSegment x -> Map NameSegment x
forall a. a -> a
forall x. Map NameSegment x -> Map NameSegment x
id Branch m
child
      pure Nametree {$sel:value:Nametree :: DefnsF2 (Map NameSegment) NESet Referent Reference
value = Defns {Map NameSegment (NESet Referent)
terms :: Map NameSegment (NESet Referent)
$sel:terms:Defns :: Map NameSegment (NESet Referent)
terms, Map NameSegment (NESet Reference)
types :: Map NameSegment (NESet Reference)
$sel:types:Defns :: Map NameSegment (NESet Reference)
types}, Map
  NameSegment
  (Nametree (DefnsF2 (Map NameSegment) NESet Referent Reference))
children :: Map
  NameSegment
  (Nametree (DefnsF2 (Map NameSegment) NESet Referent Reference))
$sel:children:Nametree :: Map
  NameSegment
  (Nametree (DefnsF2 (Map NameSegment) NESet Referent Reference))
children}

-- | Assert that there are no unconflicted names in a namespace.
assertNamespaceHasNoConflictedNames ::
  Nametree (DefnsF2 (Map NameSegment) NESet Referent TypeReference) ->
  Either
    (Defn (Conflicted Name Referent) (Conflicted Name TypeReference))
    (Nametree (DefnsF (Map NameSegment) Referent TypeReference))
assertNamespaceHasNoConflictedNames :: Nametree (DefnsF2 (Map NameSegment) NESet Referent Reference)
-> Either
     (Defn (Conflicted Name Referent) (Conflicted Name Reference))
     (Nametree (DefnsF (Map NameSegment) Referent Reference))
assertNamespaceHasNoConflictedNames =
  ([NameSegment]
 -> DefnsF2 (Map NameSegment) NESet Referent Reference
 -> Either
      (Defn (Conflicted Name Referent) (Conflicted Name Reference))
      (DefnsF (Map NameSegment) Referent Reference))
-> Nametree (DefnsF2 (Map NameSegment) NESet Referent Reference)
-> Either
     (Defn (Conflicted Name Referent) (Conflicted Name Reference))
     (Nametree (DefnsF (Map NameSegment) Referent Reference))
forall (f :: * -> *) a b.
Applicative f =>
([NameSegment] -> a -> f b) -> Nametree a -> f (Nametree b)
traverseNametreeWithName \[NameSegment]
segments DefnsF2 (Map NameSegment) NESet Referent Reference
defns -> do
    let toName :: NameSegment -> Name
toName NameSegment
segment =
          NonEmpty NameSegment -> Name
Name.fromReverseSegments (NameSegment
segment NameSegment -> [NameSegment] -> NonEmpty NameSegment
forall a. a -> [a] -> NonEmpty a
List.NonEmpty.:| [NameSegment]
segments)
    Map NameSegment Referent
terms <-
      DefnsF2 (Map NameSegment) NESet Referent Reference
defns.terms Map NameSegment (NESet Referent)
-> (Map NameSegment (NESet Referent)
    -> Either
         (Defn (Conflicted Name Referent) (Conflicted Name Reference))
         (Map NameSegment Referent))
-> Either
     (Defn (Conflicted Name Referent) (Conflicted Name Reference))
     (Map NameSegment Referent)
forall a b. a -> (a -> b) -> b
& (NameSegment
 -> NESet Referent
 -> Either
      (Defn (Conflicted Name Referent) (Conflicted Name Reference))
      Referent)
-> Map NameSegment (NESet Referent)
-> Either
     (Defn (Conflicted Name Referent) (Conflicted Name Reference))
     (Map NameSegment Referent)
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey \NameSegment
segment ->
        (NESet Referent
 -> Defn (Conflicted Name Referent) (Conflicted Name Reference))
-> NESet Referent
-> Either
     (Defn (Conflicted Name Referent) (Conflicted Name Reference))
     Referent
forall ref x. (NESet ref -> x) -> NESet ref -> Either x ref
assertUnconflicted (Conflicted Name Referent
-> Defn (Conflicted Name Referent) (Conflicted Name Reference)
forall term typ. term -> Defn term typ
TermDefn (Conflicted Name Referent
 -> Defn (Conflicted Name Referent) (Conflicted Name Reference))
-> (NESet Referent -> Conflicted Name Referent)
-> NESet Referent
-> Defn (Conflicted Name Referent) (Conflicted Name Reference)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> NESet Referent -> Conflicted Name Referent
forall n a. n -> NESet a -> Conflicted n a
Conflicted (NameSegment -> Name
toName NameSegment
segment))
    Map NameSegment Reference
types <-
      DefnsF2 (Map NameSegment) NESet Referent Reference
defns.types Map NameSegment (NESet Reference)
-> (Map NameSegment (NESet Reference)
    -> Either
         (Defn (Conflicted Name Referent) (Conflicted Name Reference))
         (Map NameSegment Reference))
-> Either
     (Defn (Conflicted Name Referent) (Conflicted Name Reference))
     (Map NameSegment Reference)
forall a b. a -> (a -> b) -> b
& (NameSegment
 -> NESet Reference
 -> Either
      (Defn (Conflicted Name Referent) (Conflicted Name Reference))
      Reference)
-> Map NameSegment (NESet Reference)
-> Either
     (Defn (Conflicted Name Referent) (Conflicted Name Reference))
     (Map NameSegment Reference)
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey \NameSegment
segment ->
        (NESet Reference
 -> Defn (Conflicted Name Referent) (Conflicted Name Reference))
-> NESet Reference
-> Either
     (Defn (Conflicted Name Referent) (Conflicted Name Reference))
     Reference
forall ref x. (NESet ref -> x) -> NESet ref -> Either x ref
assertUnconflicted (Conflicted Name Reference
-> Defn (Conflicted Name Referent) (Conflicted Name Reference)
forall term typ. typ -> Defn term typ
TypeDefn (Conflicted Name Reference
 -> Defn (Conflicted Name Referent) (Conflicted Name Reference))
-> (NESet Reference -> Conflicted Name Reference)
-> NESet Reference
-> Defn (Conflicted Name Referent) (Conflicted Name Reference)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> NESet Reference -> Conflicted Name Reference
forall n a. n -> NESet a -> Conflicted n a
Conflicted (NameSegment -> Name
toName NameSegment
segment))
    pure Defns {Map NameSegment Referent
$sel:terms:Defns :: Map NameSegment Referent
terms :: Map NameSegment Referent
terms, Map NameSegment Reference
$sel:types:Defns :: Map NameSegment Reference
types :: Map NameSegment Reference
types}
  where
    assertUnconflicted :: (NESet ref -> x) -> NESet ref -> Either x ref
    assertUnconflicted :: forall ref x. (NESet ref -> x) -> NESet ref -> Either x ref
assertUnconflicted NESet ref -> x
conflicted NESet ref
refs
      | NESet ref -> Int
forall a. NESet a -> Int
Set.NonEmpty.size NESet ref
refs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = ref -> Either x ref
forall a b. b -> Either a b
Right (NESet ref -> ref
forall a. NESet a -> a
Set.NonEmpty.findMin NESet ref
refs)
      | Bool
otherwise = x -> Either x ref
forall a b. a -> Either a b
Left (NESet ref -> x
conflicted NESet ref
refs)

------------------------------------------------------------------------------------------------------------------------
-- Getting dependents in a namespace

-- | Given a namespace and a set of dependencies, return the subset of the namespace that consists of only the
-- (transitive) dependents of the dependencies.
getNamespaceDependentsOf ::
  Names ->
  Set Reference ->
  Transaction (DefnsF (Relation Name) TermReferenceId TypeReferenceId)
getNamespaceDependentsOf :: Names
-> Set Reference -> Transaction (DefnsF (Relation Name) Id Id)
getNamespaceDependentsOf Names
names Set Reference
dependencies = do
  DefnsF Set Id Id
dependents <- Set Id -> Set Reference -> Transaction (DefnsF Set Id Id)
Operations.transitiveDependentsWithinScope (Names -> Set Id
Names.referenceIds Names
names) Set Reference
dependencies
  pure ((Set Id -> Relation Name Id)
-> (Set Id -> Relation Name Id)
-> DefnsF Set Id Id
-> DefnsF (Relation Name) Id Id
forall a b c d. (a -> b) -> (c -> d) -> Defns a c -> Defns b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ((Id -> Relation Name Id) -> Set Id -> Relation Name Id
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Id -> Relation Name Id
nameTerm) ((Id -> Relation Name Id) -> Set Id -> Relation Name Id
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Id -> Relation Name Id
nameType) DefnsF Set Id Id
dependents)
  where
    nameTerm :: TermReferenceId -> Relation Name TermReferenceId
    nameTerm :: Id -> Relation Name Id
nameTerm Id
ref =
      Set Name -> Id -> Relation Name Id
forall (f :: * -> *) a b.
(Foldable f, Ord a, Ord b) =>
f a -> b -> Relation a b
Relation.fromManyDom (Referent -> Relation Name Referent -> Set Name
forall b a. Ord b => b -> Relation a b -> Set a
Relation.lookupRan (Id -> Referent
Referent.fromTermReferenceId Id
ref) (Names -> Relation Name Referent
Names.terms Names
names)) Id
ref

    nameType :: TypeReferenceId -> Relation Name TypeReferenceId
    nameType :: Id -> Relation Name Id
nameType Id
ref =
      Set Name -> Id -> Relation Name Id
forall (f :: * -> *) a b.
(Foldable f, Ord a, Ord b) =>
f a -> b -> Relation a b
Relation.fromManyDom (Reference -> Relation Name Reference -> Set Name
forall b a. Ord b => b -> Relation a b -> Set a
Relation.lookupRan (Id -> Reference
Reference.fromId Id
ref) (Names -> Relation Name Reference
Names.types Names
names)) Id
ref

-- | Given a namespace and a set of dependencies, return the subset of the namespace that consists of only the
-- (transitive) dependents of the dependencies.
getNamespaceDependentsOf2 ::
  Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) ->
  Set Reference ->
  Transaction (DefnsF (Map Name) TermReferenceId TypeReferenceId)
getNamespaceDependentsOf2 :: Defns (BiMultimap Referent Name) (BiMultimap Reference Name)
-> Set Reference -> Transaction (DefnsF (Map Name) Id Id)
getNamespaceDependentsOf2 Defns (BiMultimap Referent Name) (BiMultimap Reference Name)
defns Set Reference
dependencies = do
  let toTermScope :: BiMultimap Referent b -> Set Id
toTermScope = (Referent -> Maybe Id) -> Set Referent -> Set Id
forall b a. Ord b => (a -> Maybe b) -> Set a -> Set b
Set.mapMaybe Referent -> Maybe Id
Referent.toReferenceId (Set Referent -> Set Id)
-> (BiMultimap Referent b -> Set Referent)
-> BiMultimap Referent b
-> Set Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BiMultimap Referent b -> Set Referent
forall a b. BiMultimap a b -> Set a
BiMultimap.dom
  let toTypeScope :: BiMultimap Reference b -> Set Id
toTypeScope = (Reference -> Maybe Id) -> Set Reference -> Set Id
forall b a. Ord b => (a -> Maybe b) -> Set a -> Set b
Set.mapMaybe Reference -> Maybe Id
Reference.toId (Set Reference -> Set Id)
-> (BiMultimap Reference b -> Set Reference)
-> BiMultimap Reference b
-> Set Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BiMultimap Reference b -> Set Reference
forall a b. BiMultimap a b -> Set a
BiMultimap.dom
  let scope :: Set Id
scope = (BiMultimap Referent Name -> Set Id)
-> (BiMultimap Reference Name -> Set Id)
-> Defns (BiMultimap Referent Name) (BiMultimap Reference Name)
-> Set Id
forall m a b. Monoid m => (a -> m) -> (b -> m) -> Defns a b -> m
forall (p :: * -> * -> *) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap BiMultimap Referent Name -> Set Id
forall {b}. BiMultimap Referent b -> Set Id
toTermScope BiMultimap Reference Name -> Set Id
forall {b}. BiMultimap Reference b -> Set Id
toTypeScope Defns (BiMultimap Referent Name) (BiMultimap Reference Name)
defns
  Set Id -> Set Reference -> Transaction (DefnsF Set Id Id)
Operations.transitiveDependentsWithinScope Set Id
scope Set Reference
dependencies
    Transaction (DefnsF Set Id Id)
-> (DefnsF Set Id Id -> DefnsF (Map Name) Id Id)
-> Transaction (DefnsF (Map Name) Id Id)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Set Id -> Map Name Id)
-> (Set Id -> Map Name Id)
-> DefnsF Set Id Id
-> DefnsF (Map Name) Id Id
forall a b c d. (a -> b) -> (c -> d) -> Defns a c -> Defns b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ((Map Name Id -> Id -> Map Name Id)
-> Map Name Id -> Set Id -> Map Name Id
forall a b. (a -> b -> a) -> a -> Set b -> a
Set.foldl' Map Name Id -> Id -> Map Name Id
addTerms Map Name Id
forall k a. Map k a
Map.empty) ((Map Name Id -> Id -> Map Name Id)
-> Map Name Id -> Set Id -> Map Name Id
forall a b. (a -> b -> a) -> a -> Set b -> a
Set.foldl' Map Name Id -> Id -> Map Name Id
addTypes Map Name Id
forall k a. Map k a
Map.empty)
  where
    addTerms :: Map Name TermReferenceId -> TermReferenceId -> Map Name TermReferenceId
    addTerms :: Map Name Id -> Id -> Map Name Id
addTerms Map Name Id
acc0 Id
ref =
      let names :: Set Name
names = Referent -> BiMultimap Referent Name -> Set Name
forall a b. Ord a => a -> BiMultimap a b -> Set b
BiMultimap.lookupDom (Id -> Referent
Referent.fromTermReferenceId Id
ref) Defns (BiMultimap Referent Name) (BiMultimap Reference Name)
defns.terms
       in (Map Name Id -> Name -> Map Name Id)
-> Map Name Id -> Set Name -> Map Name Id
forall a b. (a -> b -> a) -> a -> Set b -> a
Set.foldl' (\Map Name Id
acc Name
name -> Name -> Id -> Map Name Id -> Map Name Id
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
name Id
ref Map Name Id
acc) Map Name Id
acc0 Set Name
names

    addTypes :: Map Name TypeReferenceId -> TypeReferenceId -> Map Name TypeReferenceId
    addTypes :: Map Name Id -> Id -> Map Name Id
addTypes Map Name Id
acc0 Id
ref =
      let names :: Set Name
names = Reference -> BiMultimap Reference Name -> Set Name
forall a b. Ord a => a -> BiMultimap a b -> Set b
BiMultimap.lookupDom (Id -> Reference
Reference.fromId Id
ref) Defns (BiMultimap Referent Name) (BiMultimap Reference Name)
defns.types
       in (Map Name Id -> Name -> Map Name Id)
-> Map Name Id -> Set Name -> Map Name Id
forall a b. (a -> b -> a) -> a -> Set b -> a
Set.foldl' (\Map Name Id
acc Name
name -> Name -> Id -> Map Name Id -> Map Name Id
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
name Id
ref Map Name Id
acc) Map Name Id
acc0 Set Name
names

-- | Given a namespace and a set of dependencies, return the subset of the namespace that consists of only the
-- (transitive) dependents of the dependencies.
getNamespaceDependentsOf3 ::
  Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) ->
  DefnsF Set TermReference TypeReference ->
  Transaction (DefnsF Set TermReferenceId TypeReferenceId)
getNamespaceDependentsOf3 :: Defns (BiMultimap Referent Name) (BiMultimap Reference Name)
-> DefnsF Set Reference Reference -> Transaction (DefnsF Set Id Id)
getNamespaceDependentsOf3 Defns (BiMultimap Referent Name) (BiMultimap Reference Name)
defns DefnsF Set Reference Reference
dependencies = do
  let toTermScope :: BiMultimap Referent b -> Set Id
toTermScope = (Referent -> Maybe Id) -> Set Referent -> Set Id
forall b a. Ord b => (a -> Maybe b) -> Set a -> Set b
Set.mapMaybe Referent -> Maybe Id
Referent.toReferenceId (Set Referent -> Set Id)
-> (BiMultimap Referent b -> Set Referent)
-> BiMultimap Referent b
-> Set Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BiMultimap Referent b -> Set Referent
forall a b. BiMultimap a b -> Set a
BiMultimap.dom
  let toTypeScope :: BiMultimap Reference b -> Set Id
toTypeScope = (Reference -> Maybe Id) -> Set Reference -> Set Id
forall b a. Ord b => (a -> Maybe b) -> Set a -> Set b
Set.mapMaybe Reference -> Maybe Id
Reference.toId (Set Reference -> Set Id)
-> (BiMultimap Reference b -> Set Reference)
-> BiMultimap Reference b
-> Set Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BiMultimap Reference b -> Set Reference
forall a b. BiMultimap a b -> Set a
BiMultimap.dom
  let scope :: Set Id
scope = (BiMultimap Referent Name -> Set Id)
-> (BiMultimap Reference Name -> Set Id)
-> Defns (BiMultimap Referent Name) (BiMultimap Reference Name)
-> Set Id
forall m a b. Monoid m => (a -> m) -> (b -> m) -> Defns a b -> m
forall (p :: * -> * -> *) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap BiMultimap Referent Name -> Set Id
forall {b}. BiMultimap Referent b -> Set Id
toTermScope BiMultimap Reference Name -> Set Id
forall {b}. BiMultimap Reference b -> Set Id
toTypeScope Defns (BiMultimap Referent Name) (BiMultimap Reference Name)
defns
  Set Id -> Set Reference -> Transaction (DefnsF Set Id Id)
Operations.transitiveDependentsWithinScope Set Id
scope (DefnsF Set Reference Reference -> Set Reference
forall m. Monoid m => Defns m m -> m
forall (p :: * -> * -> *) m. (Bifoldable p, Monoid m) => p m m -> m
bifold DefnsF Set Reference Reference
dependencies)

------------------------------------------------------------------------------------------------------------------------
-- Narrowing definitions

-- | "Narrow" a namespace that may contain conflicted names, resulting in either a failure (if we find a conflicted
-- name), or the narrowed nametree without conflicted names.
narrowDefns ::
  forall term typ.
  (Ord term, Ord typ) =>
  DefnsF (Relation Name) term typ ->
  Either
    ( Defn
        (Conflicted Name term)
        (Conflicted Name typ)
    )
    (Nametree (DefnsF (Map NameSegment) term typ))
narrowDefns :: forall term typ.
(Ord term, Ord typ) =>
DefnsF (Relation Name) term typ
-> Either
     (Defn (Conflicted Name term) (Conflicted Name typ))
     (Nametree (DefnsF (Map NameSegment) term typ))
narrowDefns =
  (DefnsF (Map Name) term typ
 -> Nametree (DefnsF (Map NameSegment) term typ))
-> Either
     (Defn (Conflicted Name term) (Conflicted Name typ))
     (DefnsF (Map Name) term typ)
-> Either
     (Defn (Conflicted Name term) (Conflicted Name typ))
     (Nametree (DefnsF (Map NameSegment) term typ))
forall a b.
(a -> b)
-> Either (Defn (Conflicted Name term) (Conflicted Name typ)) a
-> Either (Defn (Conflicted Name term) (Conflicted Name typ)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DefnsF (Map Name) term typ
-> Nametree (DefnsF (Map NameSegment) term typ)
forall term typ.
(Ord term, Ord typ) =>
DefnsF (Map Name) term typ
-> Nametree (DefnsF (Map NameSegment) term typ)
unflattenNametrees
    (Either
   (Defn (Conflicted Name term) (Conflicted Name typ))
   (DefnsF (Map Name) term typ)
 -> Either
      (Defn (Conflicted Name term) (Conflicted Name typ))
      (Nametree (DefnsF (Map NameSegment) term typ)))
-> (DefnsF (Relation Name) term typ
    -> Either
         (Defn (Conflicted Name term) (Conflicted Name typ))
         (DefnsF (Map Name) term typ))
-> DefnsF (Relation Name) term typ
-> Either
     (Defn (Conflicted Name term) (Conflicted Name typ))
     (Nametree (DefnsF (Map NameSegment) term typ))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Relation Name term
 -> Either
      (Defn (Conflicted Name term) (Conflicted Name typ))
      (Map Name term))
-> (Relation Name typ
    -> Either
         (Defn (Conflicted Name term) (Conflicted Name typ)) (Map Name typ))
-> DefnsF (Relation Name) term typ
-> Either
     (Defn (Conflicted Name term) (Conflicted Name typ))
     (DefnsF (Map Name) term typ)
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> Defns a b -> f (Defns c d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse
      ((Name
 -> NESet term -> Defn (Conflicted Name term) (Conflicted Name typ))
-> Relation Name term
-> Either
     (Defn (Conflicted Name term) (Conflicted Name typ)) (Map Name term)
forall ref x.
Ord ref =>
(Name -> NESet ref -> x)
-> Relation Name ref -> Either x (Map Name ref)
go (\Name
name -> Conflicted Name term
-> Defn (Conflicted Name term) (Conflicted Name typ)
forall term typ. term -> Defn term typ
TermDefn (Conflicted Name term
 -> Defn (Conflicted Name term) (Conflicted Name typ))
-> (NESet term -> Conflicted Name term)
-> NESet term
-> Defn (Conflicted Name term) (Conflicted Name typ)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> NESet term -> Conflicted Name term
forall n a. n -> NESet a -> Conflicted n a
Conflicted Name
name))
      ((Name
 -> NESet typ -> Defn (Conflicted Name term) (Conflicted Name typ))
-> Relation Name typ
-> Either
     (Defn (Conflicted Name term) (Conflicted Name typ)) (Map Name typ)
forall ref x.
Ord ref =>
(Name -> NESet ref -> x)
-> Relation Name ref -> Either x (Map Name ref)
go (\Name
name -> Conflicted Name typ
-> Defn (Conflicted Name term) (Conflicted Name typ)
forall term typ. typ -> Defn term typ
TypeDefn (Conflicted Name typ
 -> Defn (Conflicted Name term) (Conflicted Name typ))
-> (NESet typ -> Conflicted Name typ)
-> NESet typ
-> Defn (Conflicted Name term) (Conflicted Name typ)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> NESet typ -> Conflicted Name typ
forall n a. n -> NESet a -> Conflicted n a
Conflicted Name
name))
  where
    go :: forall ref x. (Ord ref) => (Name -> NESet ref -> x) -> Relation Name ref -> Either x (Map Name ref)
    go :: forall ref x.
Ord ref =>
(Name -> NESet ref -> x)
-> Relation Name ref -> Either x (Map Name ref)
go Name -> NESet ref -> x
conflicted =
      (Name -> Set ref -> Either x ref)
-> Map Name (Set ref) -> Either x (Map Name ref)
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey Name -> Set ref -> Either x ref
unconflicted (Map Name (Set ref) -> Either x (Map Name ref))
-> (Relation Name ref -> Map Name (Set ref))
-> Relation Name ref
-> Either x (Map Name ref)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Relation Name ref -> Map Name (Set ref)
forall a b. Relation a b -> Map a (Set b)
Relation.domain
      where
        unconflicted :: Name -> Set ref -> Either x ref
        unconflicted :: Name -> Set ref -> Either x ref
unconflicted Name
name Set ref
refs0
          | NESet ref -> Int
forall a. NESet a -> Int
Set.NonEmpty.size NESet ref
refs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = ref -> Either x ref
forall a b. b -> Either a b
Right (NESet ref -> ref
forall a. NESet a -> a
Set.NonEmpty.findMin NESet ref
refs)
          | Bool
otherwise = x -> Either x ref
forall a b. a -> Either a b
Left (Name -> NESet ref -> x
conflicted Name
name NESet ref
refs)
          where
            refs :: NESet ref
refs = Set ref -> NESet ref
forall a. Set a -> NESet a
Set.NonEmpty.unsafeFromSet Set ref
refs0

------------------------------------------------------------------------------------------------------------------------
-- Hydrating definitions

-- | Hydrate term/type references to actual terms/types.
hydrateDefns ::
  forall m name term typ.
  (Monad m, Ord name) =>
  (Hash -> m [term]) ->
  (Hash -> m [typ]) ->
  DefnsF (Map name) TermReferenceId TypeReferenceId ->
  m (DefnsF (Map name) (TermReferenceId, term) (TypeReferenceId, typ))
hydrateDefns :: forall (m :: * -> *) name term typ.
(Monad m, Ord name) =>
(Hash -> m [term])
-> (Hash -> m [typ])
-> DefnsF (Map name) Id Id
-> m (DefnsF (Map name) (Id, term) (Id, typ))
hydrateDefns Hash -> m [term]
getTermComponent Hash -> m [typ]
getTypeComponent = do
  (Map name Id -> m (Map name (Id, term)))
-> (Map name Id -> m (Map name (Id, typ)))
-> DefnsF (Map name) Id Id
-> m (DefnsF (Map name) (Id, term) (Id, typ))
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> Defns a b -> f (Defns c d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse Map name Id -> m (Map name (Id, term))
hydrateTerms Map name Id -> m (Map name (Id, typ))
hydrateTypes
  where
    hydrateTerms :: Map name TermReferenceId -> m (Map name (TermReferenceId, term))
    hydrateTerms :: Map name Id -> m (Map name (Id, term))
hydrateTerms Map name Id
terms =
      (Hash -> m [term])
-> Map name Id
-> (name -> Id -> term -> (Id, term))
-> m (Map name (Id, term))
forall a b name (m :: * -> *).
(Monad m, Ord name) =>
(Hash -> m [a])
-> Map name Id -> (name -> Id -> a -> b) -> m (Map name b)
hydrateDefns_ Hash -> m [term]
getTermComponent Map name Id
terms \name
_ -> (,)

    hydrateTypes :: Map name TypeReferenceId -> m (Map name (TypeReferenceId, typ))
    hydrateTypes :: Map name Id -> m (Map name (Id, typ))
hydrateTypes Map name Id
types =
      (Hash -> m [typ])
-> Map name Id
-> (name -> Id -> typ -> (Id, typ))
-> m (Map name (Id, typ))
forall a b name (m :: * -> *).
(Monad m, Ord name) =>
(Hash -> m [a])
-> Map name Id -> (name -> Id -> a -> b) -> m (Map name b)
hydrateDefns_ Hash -> m [typ]
getTypeComponent Map name Id
types \name
_ -> (,)

hydrateDefns_ ::
  forall a b name m.
  (Monad m, Ord name) =>
  (Hash -> m [a]) ->
  Map name Reference.Id ->
  (name -> Reference.Id -> a -> b) ->
  m (Map name b)
hydrateDefns_ :: forall a b name (m :: * -> *).
(Monad m, Ord name) =>
(Hash -> m [a])
-> Map name Id -> (name -> Id -> a -> b) -> m (Map name b)
hydrateDefns_ Hash -> m [a]
getComponent Map name Id
defns name -> Id -> a -> b
modify =
  (Map name b -> Hash -> m (Map name b))
-> Map name b -> Set Hash -> m (Map name b)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
Foldable.foldlM Map name b -> Hash -> m (Map name b)
f Map name b
forall k a. Map k a
Map.empty ((Id -> Set Hash) -> Map name Id -> Set Hash
forall m a. Monoid m => (a -> m) -> Map name a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Hash -> Set Hash
forall a. a -> Set a
Set.singleton (Hash -> Set Hash) -> (Id -> Hash) -> Id -> Set Hash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Hash
Reference.idToHash) Map name Id
defns)
  where
    f :: Map name b -> Hash -> m (Map name b)
    f :: Map name b -> Hash -> m (Map name b)
f Map name b
acc Hash
hash =
      (Map name b -> (Id, a) -> Map name b)
-> Map name b -> [(Id, a)] -> Map name b
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Map name b -> (Id, a) -> Map name b
g Map name b
acc ([(Id, a)] -> Map name b)
-> ([a] -> [(Id, a)]) -> [a] -> Map name b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash -> [a] -> [(Id, a)]
forall a. Hash -> [a] -> [(Id, a)]
Reference.componentFor Hash
hash ([a] -> Map name b) -> m [a] -> m (Map name b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Hash -> m [a]
getComponent Hash
hash

    g :: Map name b -> (Reference.Id, a) -> Map name b
    g :: Map name b -> (Id, a) -> Map name b
g Map name b
acc (Id
ref, a
thing) =
      (Map name b -> name -> Map name b)
-> Map name b -> Set name -> Map name b
forall a b. (a -> b -> a) -> a -> Set b -> a
Set.foldl' (Id -> a -> Map name b -> name -> Map name b
h Id
ref a
thing) Map name b
acc (Id -> BiMultimap Id name -> Set name
forall a b. Ord a => a -> BiMultimap a b -> Set b
BiMultimap.lookupDom Id
ref BiMultimap Id name
defns2)

    h :: Reference.Id -> a -> Map name b -> name -> Map name b
    h :: Id -> a -> Map name b -> name -> Map name b
h Id
ref a
thing Map name b
acc name
name =
      name -> b -> Map name b -> Map name b
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert name
name (name -> Id -> a -> b
modify name
name Id
ref a
thing) Map name b
acc

    defns2 :: BiMultimap Reference.Id name
    defns2 :: BiMultimap Id name
defns2 =
      Map name Id -> BiMultimap Id name
forall a b. (Ord a, Ord b) => Map b a -> BiMultimap a b
BiMultimap.fromRange Map name Id
defns

------------------------------------------------------------------------------------------------------------------------
-- Parsing and typechecking

-- TODO: find a better module for this function, as it's used in a couple places
parseAndTypecheck ::
  Pretty Pretty.ColorText ->
  Parser.ParsingEnv Transaction ->
  Cli (Maybe (TypecheckedUnisonFile Symbol Ann))
parseAndTypecheck :: Pretty ColorText
-> ParsingEnv Transaction
-> Cli (Maybe (TypecheckedUnisonFile Symbol Ann))
parseAndTypecheck Pretty ColorText
prettyUf ParsingEnv Transaction
parsingEnv = do
  Env
env <- Cli Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  let stringUf :: String
stringUf = Width -> Pretty ColorText -> String
Pretty.toPlain Width
80 Pretty ColorText
prettyUf
  DebugFlag -> Cli () -> Cli ()
forall (m :: * -> *). Monad m => DebugFlag -> m () -> m ()
Debug.whenDebug DebugFlag
Debug.Update do
    IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
      String -> IO ()
putStrLn String
"--- Scratch ---"
      String -> IO ()
putStrLn String
stringUf
  Transaction (Maybe (TypecheckedUnisonFile Symbol Ann))
-> Cli (Maybe (TypecheckedUnisonFile Symbol Ann))
forall a. Transaction a -> Cli a
Cli.runTransaction do
    String
-> String
-> ParsingEnv Transaction
-> Transaction (Either (Err Symbol) (UnisonFile Symbol Ann))
forall (m :: * -> *) v.
(Monad m, Var v) =>
String
-> String -> ParsingEnv m -> m (Either (Err v) (UnisonFile v Ann))
Parsers.parseFile String
"<update>" String
stringUf ParsingEnv Transaction
parsingEnv Transaction (Either (Err Symbol) (UnisonFile Symbol Ann))
-> (Either (Err Symbol) (UnisonFile Symbol Ann)
    -> Transaction (Maybe (TypecheckedUnisonFile Symbol Ann)))
-> Transaction (Maybe (TypecheckedUnisonFile Symbol Ann))
forall a b. Transaction a -> (a -> Transaction b) -> Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left Err Symbol
_ -> Maybe (TypecheckedUnisonFile Symbol Ann)
-> Transaction (Maybe (TypecheckedUnisonFile Symbol Ann))
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TypecheckedUnisonFile Symbol Ann)
forall a. Maybe a
Nothing
      Right UnisonFile Symbol Ann
uf -> do
        Env Symbol Ann
typecheckingEnv <-
          ShouldUseTndr Transaction
-> Codebase IO Symbol Ann
-> [Type Symbol Ann]
-> UnisonFile Symbol Ann
-> Transaction (Env Symbol Ann)
computeTypecheckingEnvironment (ParsingEnv Transaction -> ShouldUseTndr Transaction
forall (m :: * -> *). ParsingEnv m -> ShouldUseTndr m
FileParsers.ShouldUseTndr'Yes ParsingEnv Transaction
parsingEnv) Env
env.codebase [] UnisonFile Symbol Ann
uf
        pure (Result (Seq (Note Symbol Ann)) (TypecheckedUnisonFile Symbol Ann)
-> Maybe (TypecheckedUnisonFile Symbol Ann)
forall notes a. Result notes a -> Maybe a
Result.result (Env Symbol Ann
-> UnisonFile Symbol Ann
-> Result
     (Seq (Note Symbol Ann)) (TypecheckedUnisonFile Symbol Ann)
forall (m :: * -> *) v.
(Monad m, Var v) =>
Env v Ann
-> UnisonFile v
-> ResultT (Seq (Note v Ann)) m (TypecheckedUnisonFile v Ann)
FileParsers.synthesizeFile Env Symbol Ann
typecheckingEnv UnisonFile Symbol Ann
uf))