Use monotonic maps when constructing a branch

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

@@ -55,7 +55,9 @@ module Unison.Util.Relation
     -- * General traversals
     map,
     mapDom,
+    mapDomMonotonic,
     mapRan,
+    mapRanMonotonic,
     bimap,
     bitraverse,
 
@@ -633,6 +635,14 @@ mapDom f Relation {domain, range} =
       range = Map.map (S.map f) range
     }
 
+-- | Like 'mapDom', but takes a function that must be monotonic; i.e. @compare x y == compare (f x) (f y)@.
+mapDomMonotonic :: (Ord a, Ord a', Ord b) => (a -> a') -> Relation a b -> Relation a' b
+mapDomMonotonic f Relation {domain, range} =
+  Relation
+    { domain = Map.mapKeysMonotonic f domain,
+      range = Map.map (S.mapMonotonic f) range
+    }
+
 -- aka second
 mapRan :: (Ord a, Ord b, Ord b') => (b -> b') -> Relation a b -> Relation a b'
 mapRan f Relation {domain, range} =
@@ -641,6 +651,14 @@ mapRan f Relation {domain, range} =
       range = Map.mapKeysWith S.union f range
     }
 
+-- | Like 'mapRan', but takes a function that must be monotonic; i.e. @compare x y == compare (f x) (f y)@.
+mapRanMonotonic :: (Ord a, Ord b, Ord b') => (b -> b') -> Relation a b -> Relation a b'
+mapRanMonotonic f Relation {domain, range} =
+  Relation
+    { domain = Map.map (S.mapMonotonic f) domain,
+      range = Map.mapKeysMonotonic f range
+    }
+
 fromMap :: (Ord a, Ord b) => Map a b -> Relation a b
 fromMap = fromList . Map.toList
 

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

@@ -51,6 +51,15 @@ mapD1 f Relation3 {d1, d2, d3} =
       d3 = Map.map (R.mapDom f) d3
     }
 
+-- | Like 'mapD1', but takes a function that must be monotonic; i.e. @compare x y == compare (f x) (f y)@.
+mapD1Monotonic :: (Ord a, Ord a', Ord b, Ord c) => (a -> a') -> Relation3 a b c -> Relation3 a' b c
+mapD1Monotonic f Relation3 {d1, d2, d3} =
+  Relation3
+    { d1 = Map.mapKeysMonotonic f d1,
+      d2 = Map.map (R.mapDomMonotonic f) d2,
+      d3 = Map.map (R.mapDomMonotonic f) d3
+    }
+
 mapD2 :: (Ord a, Ord b, Ord b', Ord c) => (b -> b') -> Relation3 a b c -> Relation3 a b' c
 mapD2 f Relation3 {d1, d2, d3} =
   Relation3
@@ -59,6 +68,15 @@ mapD2 f Relation3 {d1, d2, d3} =
       d3 = Map.map (R.mapRan f) d3
     }
 
+-- | Like 'mapD2', but takes a function that must be monotonic; i.e. @compare x y == compare (f x) (f y)@.
+mapD2Monotonic :: (Ord a, Ord b, Ord b', Ord c) => (b -> b') -> Relation3 a b c -> Relation3 a b' c
+mapD2Monotonic f Relation3 {d1, d2, d3} =
+  Relation3
+    { d1 = Map.map (R.mapDomMonotonic f) d1,
+      d2 = Map.mapKeysMonotonic f d2,
+      d3 = Map.map (R.mapRanMonotonic f) d3
+    }
+
 member :: (Ord a, Ord b, Ord c) => a -> b -> c -> Relation3 a b c -> Bool
 member a b c = R.member b c . lookupD1 a
 

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

@@ -114,6 +114,16 @@ mapD2 f Relation4 {d1, d2, d3, d4} =
       d4 = Map.map (R3.mapD2 f) d4
     }
 
+-- | Like 'mapD2', but takes a function that must be monotonic; i.e. @compare x y == compare (f x) (f y)@.
+mapD2Monotonic :: (Ord a, Ord b, Ord b', Ord c, Ord d) => (b -> b') -> Relation4 a b c d -> Relation4 a b' c d
+mapD2Monotonic f Relation4 {d1, d2, d3, d4} =
+  Relation4
+    { d1 = Map.map (R3.mapD1Monotonic f) d1,
+      d2 = Map.mapKeysMonotonic f d2,
+      d3 = Map.map (R3.mapD2Monotonic f) d3,
+      d4 = Map.map (R3.mapD2Monotonic f) d4
+    }
+
 insertAll :: Foldable f => Ord a => Ord b => Ord c => Ord d
           => f (a,b,c,d) -> Relation4 a b c d -> Relation4 a b c d
 insertAll f r = foldl' (\r x -> uncurry4 insert x r) r f

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

@@ -200,45 +200,70 @@ children :: Lens' (Branch0 m) (Map NameSegment (Branch m))
 children = lens _children (\Branch0{..} x -> branch0 _terms _types x _edits)
 
 -- creates a Branch0 from the primary fields and derives the others.
-branch0 :: Metadata.Star Referent NameSegment
-        -> Metadata.Star Reference NameSegment
-        -> Map NameSegment (Branch m)
-        -> Map NameSegment (EditHash, m Patch)
-        -> Branch0 m
+branch0 ::
+  forall m.
+  Metadata.Star Referent NameSegment ->
+  Metadata.Star Reference NameSegment ->
+  Map NameSegment (Branch m) ->
+  Map NameSegment (EditHash, m Patch) ->
+  Branch0 m
 branch0 terms types children edits =
-  Branch0 terms types children edits
-          deepTerms' deepTypes'
-          deepTermMetadata' deepTypeMetadata'
-          deepPaths' deepEdits'
+  Branch0
+    { _terms = terms,
+      _types = types,
+      _children = children,
+      _edits = edits,
+      deepTerms = deepTerms',
+      deepTypes = deepTypes',
+      deepTermMetadata = deepTermMetadata',
+      deepTypeMetadata = deepTypeMetadata',
+      deepPaths = deepPaths',
+      deepEdits = deepEdits'
+    }
   where
-  deepTerms' = (R.mapRan Name.fromSegment . Star3.d1) terms
-    <> foldMap go (Map.toList children)
-   where
-    go (Name.fromSegment -> n, b) =
-      R.mapRan (Name.joinDot n) (deepTerms $ head b) -- could use mapKeysMonotonic
-  deepTypes' = (R.mapRan Name.fromSegment . Star3.d1) types
-    <> foldMap go (Map.toList children)
-   where
-    go (Name.fromSegment -> n, b) =
-      R.mapRan (Name.joinDot n) (deepTypes $ head b) -- could use mapKeysMonotonic
-  deepTermMetadata' = R4.mapD2 Name.fromSegment (Metadata.starToR4 terms)
-    <> foldMap go (Map.toList children)
-   where
-    go (Name.fromSegment -> n, b) =
-      R4.mapD2 (Name.joinDot n) (deepTermMetadata $ head b)
-  deepTypeMetadata' = R4.mapD2 Name.fromSegment (Metadata.starToR4 types)
-    <> foldMap go (Map.toList children)
-   where
-    go (Name.fromSegment -> n, b) =
-      R4.mapD2 (Name.joinDot n) (deepTypeMetadata $ head b)
-  deepPaths' = Set.map Path.singleton (Map.keysSet children)
-    <> foldMap go (Map.toList children)
-    where go (nameSeg, b) = Set.map (Path.cons nameSeg) (deepPaths $ head b)
-  deepEdits' = Map.mapKeys Name.fromSegment (Map.map fst edits)
-    <> foldMap go (Map.toList children)
-   where
-    go (nameSeg, b) =
-      Map.mapKeysMonotonic (Name.cons nameSeg) . deepEdits $ head b
+    children' :: [(NameSegment, Branch m)]
+    children' =
+      Map.toList children
+    deepTerms' :: Relation Referent Name
+    deepTerms' =
+      R.mapRanMonotonic Name.fromSegment (Star3.d1 terms) <> foldMap go children'
+      where
+        go :: (NameSegment, Branch m) -> Relation Referent Name
+        go (n, b) =
+          R.mapRanMonotonic (Name.cons n) (deepTerms $ head b)
+    deepTypes' :: Relation Reference Name
+    deepTypes' =
+      R.mapRanMonotonic Name.fromSegment (Star3.d1 types) <> foldMap go children'
+      where
+        go :: (NameSegment, Branch m) -> Relation Reference Name
+        go (n, b) =
+          R.mapRanMonotonic (Name.cons n) (deepTypes $ head b)
+    deepTermMetadata' :: Metadata.R4 Referent Name
+    deepTermMetadata' =
+      R4.mapD2Monotonic Name.fromSegment (Metadata.starToR4 terms) <> foldMap go children'
+      where
+        go (n, b) =
+          R4.mapD2Monotonic (Name.cons n) (deepTermMetadata $ head b)
+    deepTypeMetadata' :: Metadata.R4 Reference Name
+    deepTypeMetadata' =
+      R4.mapD2Monotonic Name.fromSegment (Metadata.starToR4 types) <> foldMap go children'
+      where
+        go (n, b) =
+          R4.mapD2Monotonic (Name.cons n) (deepTypeMetadata $ head b)
+    deepPaths' :: Set Path
+    deepPaths' =
+      Set.mapMonotonic Path.singleton (Map.keysSet children) <> foldMap go children'
+      where
+        go (n, b) =
+          -- N.B. (Path.cons n) is not monotonic wrt. Path ordering, because Path, unlike Name, does not compare in
+          -- reverse segment order.
+          Set.map (Path.cons n) (deepPaths $ head b)
+    deepEdits' :: Map Name EditHash
+    deepEdits' =
+      Map.mapKeysMonotonic Name.fromSegment (Map.map fst edits) <> foldMap go children'
+      where
+        go (n, b) =
+          Map.mapKeysMonotonic (Name.cons n) (deepEdits $ head b)
 
 head :: Branch m -> Branch0 m
 head (Branch c) = Causal.head c