add Names.lenientToNametree

lib/unison-util-relation/src/Unison/Util/BiMultimap.hs

@@ -178,6 +178,7 @@ invertDomain =
     g x acc y =
       Map.insert y x acc
 
+-- | Construct a left-unique relation from a mapping from its right-elements to its left-elements.
 fromRange :: (Ord a, Ord b) => Map b a -> BiMultimap a b
 fromRange m =
   BiMultimap (Map.foldlWithKey' f Map.empty m) m

parser-typechecker/src/Unison/Codebase/Branch.hs

@@ -139,6 +139,7 @@ import Unison.NameSegment (NameSegment)
 import Unison.NameSegment qualified as NameSegment
 import Unison.Prelude hiding (empty)
 import Unison.Reference (TermReference, TermReferenceId, TypeReference, TypeReferenceId)
+import Unison.Reference qualified as Reference
 import Unison.Referent (Referent)
 import Unison.Referent qualified as Referent
 import Unison.Util.List qualified as List
@@ -148,7 +149,6 @@ import Unison.Util.Set qualified as Set
 import Unison.Util.Star2 qualified as Star2
 import Witherable (FilterableWithIndex (imapMaybe))
 import Prelude hiding (head, read, subtract)
-import qualified Unison.Reference as Reference
 
 instance AsEmpty (Branch m) where
   _Empty = prism' (const empty) matchEmpty
@@ -215,7 +215,6 @@ deepTypeReferenceIds :: Branch0 m -> Set TypeReferenceId
 deepTypeReferenceIds =
   Set.mapMaybe Reference.toId . deepTypeReferences
 
-
 namespaceStats :: Branch0 m -> NamespaceStats
 namespaceStats b =
   NamespaceStats

unison-core/package.yaml

@@ -66,6 +66,7 @@ default-extensions:
   - DerivingStrategies
   - DerivingVia
   - DoAndIfThenElse
+  - DuplicateRecordFields
   - FlexibleContexts
   - FlexibleInstances
   - GADTs

unison-core/src/Unison/Names.hs

@@ -49,12 +49,15 @@ module Unison.Names
     hashQualifyTypesRelation,
     hashQualifyTermsRelation,
     fromTermsAndTypes,
+    lenientToNametree,
   )
 where
 
 import Data.Map qualified as Map
+import Data.Semialign (alignWith)
 import Data.Set qualified as Set
 import Data.Text qualified as Text
+import Data.These (These (..))
 import Text.FuzzyFind qualified as FZF
 import Unison.ConstructorReference (GConstructorReference (..))
 import Unison.ConstructorType qualified as CT
@@ -64,6 +67,7 @@ import Unison.LabeledDependency (LabeledDependency)
 import Unison.LabeledDependency qualified as LD
 import Unison.Name (Name)
 import Unison.Name qualified as Name
+import Unison.NameSegment (NameSegment)
 import Unison.Prelude
 import Unison.Reference (Reference, TermReference, TypeReference)
 import Unison.Reference qualified as Reference
@@ -71,6 +75,10 @@ import Unison.Referent (Referent)
 import Unison.Referent qualified as Referent
 import Unison.ShortHash (ShortHash)
 import Unison.ShortHash qualified as SH
+import Unison.Util.BiMultimap (BiMultimap)
+import Unison.Util.BiMultimap qualified as BiMultimap
+import Unison.Util.Defns (Defns (..), DefnsF)
+import Unison.Util.Nametree (Nametree, unflattenNametree)
 import Unison.Util.Relation (Relation)
 import Unison.Util.Relation qualified as R
 import Unison.Util.Relation qualified as Relation
@@ -95,7 +103,7 @@ instance Monoid (Names) where
   mempty = Names mempty mempty
 
 isEmpty :: Names -> Bool
-isEmpty n = R.null (terms n) && R.null (types n)
+isEmpty n = R.null n.terms && R.null n.types
 
 map :: (Name -> Name) -> Names -> Names
 map f (Names {terms, types}) = Names terms' types'
@@ -122,8 +130,8 @@ fuzzyFind nameToText query names =
     . Prelude.filter prefilter
     . Map.toList
     -- `mapMonotonic` is safe here and saves a log n factor
-    $ (Set.mapMonotonic Left <$> R.toMultimap (terms names))
-      <> (Set.mapMonotonic Right <$> R.toMultimap (types names))
+    $ (Set.mapMonotonic Left <$> R.toMultimap names.terms)
+      <> (Set.mapMonotonic Right <$> R.toMultimap names.types)
   where
     lowerqueryt = Text.toLower . Text.pack <$> query
     -- For performance, case-insensitive substring matching as a pre-filter
@@ -250,8 +258,8 @@ unionLeft' ::
   Names
 unionLeft' shouldOmit a b = Names terms' types'
   where
-    terms' = foldl' go (terms a) (R.toList $ terms b)
-    types' = foldl' go (types a) (R.toList $ types b)
+    terms' = foldl' go a.terms (R.toList b.terms)
+    types' = foldl' go a.types (R.toList b.types)
     go :: (Ord a, Ord b) => Relation a b -> (a, b) -> Relation a b
     go acc (n, r) = if shouldOmit n r acc then acc else R.insert n r acc
 
@@ -260,7 +268,7 @@ numHashChars :: Int
 numHashChars = 3
 
 termsNamed :: Names -> Name -> Set Referent
-termsNamed = flip R.lookupDom . terms
+termsNamed = flip R.lookupDom . (.terms)
 
 -- | Get all terms with a specific name.
 refTermsNamed :: Names -> Name -> Set TermReference
@@ -281,13 +289,13 @@ refTermsHQNamed names = \case
      in Set.mapMaybe f (termsNamed names name)
 
 typesNamed :: Names -> Name -> Set TypeReference
-typesNamed = flip R.lookupDom . types
+typesNamed = flip R.lookupDom . (.types)
 
 namesForReferent :: Names -> Referent -> Set Name
-namesForReferent names r = R.lookupRan r (terms names)
+namesForReferent names r = R.lookupRan r names.terms
 
 namesForReference :: Names -> TypeReference -> Set Name
-namesForReference names r = R.lookupRan r (types names)
+namesForReference names r = R.lookupRan r names.types
 
 termAliases :: Names -> Name -> Referent -> Set Name
 termAliases names n r = Set.delete n $ namesForReferent names r
@@ -422,20 +430,20 @@ filterTypes f (Names terms types) = Names terms (R.filterDom f types)
 difference :: Names -> Names -> Names
 difference a b =
   Names
-    (R.difference (terms a) (terms b))
-    (R.difference (types a) (types b))
+    (R.difference a.terms b.terms)
+    (R.difference a.types b.types)
 
 contains :: Names -> Reference -> Bool
 contains names =
   -- We want to compute `termsReferences` only once, if `contains` is partially applied to a `Names`, and called over
   -- and over for different references. GHC would probably float `termsReferences` out without the explicit lambda, but
   -- it's written like this just to be sure.
-  \r -> Set.member r termsReferences || R.memberRan r (types names)
+  \r -> Set.member r termsReferences || R.memberRan r names.types
   where
     -- this check makes `contains` O(n) instead of O(log n)
     termsReferences :: Set TermReference
     termsReferences =
-      Set.map Referent.toReference (R.ran (terms names))
+      Set.map Referent.toReference (R.ran names.terms)
 
 -- | filters out everything from the domain except what's conflicted
 conflicts :: Names -> Names
@@ -448,9 +456,9 @@ conflicts Names {..} = Names (R.filterManyDom terms) (R.filterManyDom types)
 -- See usage in `FileParser` for handling precendence of symbol
 -- resolution where local names are preferred to codebase names.
 shadowTerms :: [Name] -> Names -> Names
-shadowTerms ns n0 = Names terms' (types n0)
+shadowTerms ns n0 = Names terms' n0.types
   where
-    terms' = foldl' go (terms n0) ns
+    terms' = foldl' go n0.terms ns
     go ts name = R.deleteDom name ts
 
 -- | Given a mapping from name to qualified name, update a `Names`,
@@ -461,8 +469,8 @@ shadowTerms ns n0 = Names terms' (types n0)
 importing :: [(Name, Name)] -> Names -> Names
 importing shortToLongName ns =
   Names
-    (foldl' go (terms ns) shortToLongName)
-    (foldl' go (types ns) shortToLongName)
+    (foldl' go ns.terms shortToLongName)
+    (foldl' go ns.types shortToLongName)
   where
     go :: (Ord r) => Relation Name r -> (Name, Name) -> Relation Name r
     go m (shortname, qname) = case Name.searchByRankedSuffix qname m of
@@ -476,8 +484,8 @@ importing shortToLongName ns =
 -- `[(foo, io.foo), (bar, io.bar)]`.
 expandWildcardImport :: Name -> Names -> [(Name, Name)]
 expandWildcardImport prefix ns =
-  [(suffix, full) | Just (suffix, full) <- go <$> R.toList (terms ns)]
-    <> [(suffix, full) | Just (suffix, full) <- go <$> R.toList (types ns)]
+  [(suffix, full) | Just (suffix, full) <- go <$> R.toList ns.terms]
+    <> [(suffix, full) | Just (suffix, full) <- go <$> R.toList ns.types]
   where
     go :: (Name, a) -> Maybe (Name, Name)
     go (full, _) = do
@@ -498,7 +506,7 @@ constructorsForType r ns =
       possibleDatas = [Referent.Con (ConstructorReference r cid) CT.Data | cid <- [0 ..]]
       possibleEffects = [Referent.Con (ConstructorReference r cid) CT.Effect | cid <- [0 ..]]
       trim [] = []
-      trim (h : t) = case R.lookupRan h (terms ns) of
+      trim (h : t) = case R.lookupRan h ns.terms of
         s
           | Set.null s -> []
           | otherwise -> [(n, h) | n <- toList s] ++ trim t
@@ -517,3 +525,29 @@ hashQualifyRelation fromNamedRef rel = R.map go rel
       if Set.size (R.lookupDom n rel) > 1
         then (HQ.take numHashChars $ fromNamedRef n r, r)
         else (HQ.NameOnly n, r)
+
+-- | "Leniently" view a Names as a NameTree
+--
+-- This function is "lenient" in the sense that it does not handle conflicted names with any smarts whatsoever. The
+-- resulting nametree will simply contain one of the associated references of a conflicted name - we don't specify
+-- which.
+lenientToNametree :: Names -> Nametree (DefnsF (Map NameSegment) Referent TypeReference)
+lenientToNametree names =
+  alignWith
+    ( \case
+        This terms -> Defns {terms, types = Map.empty}
+        That types -> Defns {terms = Map.empty, types}
+        These terms types -> Defns {terms, types}
+    )
+    (lenientRelationToNametree names.terms)
+    (lenientRelationToNametree names.types)
+  where
+    lenientRelationToNametree :: Ord a => Relation Name a -> Nametree (Map NameSegment a)
+    lenientRelationToNametree =
+      unflattenNametree . lenientRelationToLeftUniqueRelation
+
+    lenientRelationToLeftUniqueRelation :: (Ord a, Ord b) => Relation a b -> BiMultimap b a
+    lenientRelationToLeftUniqueRelation =
+      -- The partial `Set.findMin` are fine here because Relation.domain only has non-empty Set values. A NESet would be
+      -- better.
+      BiMultimap.fromRange . Map.map Set.findMin . Relation.domain

unison-core/unison-core1.cabal

@@ -72,6 +72,7 @@ library
       DerivingStrategies
       DerivingVia
       DoAndIfThenElse
+      DuplicateRecordFields
       FlexibleContexts
       FlexibleInstances
       GADTs
@@ -140,6 +141,7 @@ test-suite tests
       DerivingStrategies
       DerivingVia
       DoAndIfThenElse
+      DuplicateRecordFields
       FlexibleContexts
       FlexibleInstances
       GADTs