Merge pull request #5718 from unisonweb/25-05-22-synhash

tweak: don't bother synhashing when synhashes would be the same

Author: mitchellwrosen

codebase2/core/U/Codebase/Reference.hs

@@ -31,6 +31,7 @@ module U.Codebase.Reference
   )
 where
 
+import Control.DeepSeq (NFData)
 import Control.Lens (Lens, Lens', Prism, Prism', Traversal, lens, preview, prism)
 import Data.Bifoldable (Bifoldable (..))
 import Data.Bitraversable (Bitraversable (..))
@@ -75,6 +76,7 @@ data Reference' t h
   = ReferenceBuiltin t
   | ReferenceDerived (Id' h)
   deriving stock (Eq, Generic, Functor, Ord, Show)
+  deriving anyclass (NFData)
 
 -- | A type declaration reference.
 type TermReference' t h = Reference' t h
@@ -111,7 +113,8 @@ type Pos = Word64
 
 -- | @Pos@ is a position into a cycle, as cycles are hashed together.
 data Id' h = Id h Pos
-  deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)
+  deriving stock (Eq, Generic, Ord, Show, Functor, Foldable, Traversable)
+  deriving anyclass (NFData)
 
 t_ :: Prism (Reference' t h) (Reference' t' h) t t'
 t_ = prism ReferenceBuiltin \case

codebase2/core/Unison/NameSegment/Internal.hs

@@ -6,6 +6,7 @@
 --   thus should only be imported by parsers & printers.
 module Unison.NameSegment.Internal (NameSegment (..)) where
 
+import Control.DeepSeq (NFData)
 import GHC.TypeLits (ErrorMessage ((:$$:)), TypeError)
 import GHC.TypeLits qualified as TypeError (ErrorMessage (Text))
 import Unison.Prelude
@@ -25,6 +26,7 @@ newtype NameSegment = NameSegment
   }
   deriving stock (Eq, Generic, Ord, Show)
   deriving newtype (Alphabetical)
+  deriving anyclass (NFData)
 
 instance
   ( TypeError

codebase2/core/package.yaml

@@ -10,6 +10,7 @@ library:
 dependencies:
   - base
   - containers
+  - deepseq
   - lens
   - mtl
   - recover-rtti

codebase2/core/unison-core.cabal

@@ -57,6 +57,7 @@ library
   build-depends:
       base
     , containers
+    , deepseq
     , lens
     , mtl
     , recover-rtti

lib/unison-hash/package.yaml

@@ -7,6 +7,7 @@ ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-si
 dependencies:
   - base
   - bytestring
+  - deepseq
   - unison-prelude
   - unison-util-base32hex
 

lib/unison-hash/src/Unison/Hash.hs

@@ -20,6 +20,7 @@ module Unison.Hash
   )
 where
 
+import Control.DeepSeq (NFData)
 import Data.ByteString.Short (ShortByteString)
 import Data.ByteString.Short qualified as B.Short
 import U.Util.Base32Hex (Base32Hex)
@@ -28,7 +29,8 @@ import Unison.Prelude
 
 -- | A hash.
 newtype Hash = Hash {toShort :: ShortByteString}
-  deriving stock (Eq, Ord, Generic)
+  deriving stock (Eq, Generic, Ord)
+  deriving anyclass (NFData)
 
 instance Show Hash where
   show = show . toBase32HexText

lib/unison-hash/unison-hash.cabal

@@ -1,6 +1,6 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.37.0.
+-- This file has been generated from package.yaml by hpack version 0.36.0.
 --
 -- see: https://github.com/sol/hpack
 
@@ -53,6 +53,7 @@ library
   build-depends:
       base
     , bytestring
+    , deepseq
     , unison-prelude
     , unison-util-base32hex
   default-language: Haskell2010

lib/unison-prelude/src/Unison/Util/Map.hs

@@ -7,15 +7,19 @@ module Unison.Util.Map
     deleteLookup,
     deleteLookupJust,
     elemsSet,
+    foldKeysCommutative,
+    foldValuesCommutative,
     foldM,
     foldMapM,
     for_,
+    fromSetA,
     insertLookup,
     invert,
     lookupJust,
     mergeMap,
     unionWithM,
     remap,
+    thenInsertPair,
     traverseKeys,
     traverseKeysWith,
     swap,
@@ -36,6 +40,7 @@ import Data.Map.Internal qualified as Map (Map (Bin, Tip))
 import Data.Map.Merge.Strict qualified as Map
 import Data.Map.Strict qualified as Map
 import Data.Set qualified as Set
+import Data.Set.Internal qualified as Set (Set (..))
 import Data.These (These (..))
 import Data.Vector (Vector)
 import Data.Vector qualified as Vector
@@ -123,6 +128,26 @@ elemsSet :: (Ord v) => Map k v -> Set v
 elemsSet =
   Set.fromList . Map.elems
 
+-- | Fold the keys of a map strictly with a "commutative" combining function that doesn't receive the elements in any
+-- particular order.
+foldKeysCommutative :: (k -> acc -> acc) -> acc -> Map k v -> acc
+foldKeysCommutative f =
+  let go !acc = \case
+        Map.Bin _ k _ l r : xs -> go (f k acc) (l : r : xs)
+        Map.Tip : xs -> go acc xs
+        [] -> acc
+   in \z xs -> go z [xs]
+
+-- | Fold the values of a map strictly with a "commutative" combining function that doesn't receive the elements in any
+-- particular order.
+foldValuesCommutative :: (v -> acc -> acc) -> acc -> Map k v -> acc
+foldValuesCommutative f =
+  let go !acc = \case
+        Map.Bin _ _ v l r : xs -> go (f v acc) (l : r : xs)
+        Map.Tip : xs -> go acc xs
+        [] -> acc
+   in \z xs -> go z [xs]
+
 -- | Like 'Map.foldlWithKey'', but with a monadic accumulator.
 foldM :: (Monad m) => (acc -> k -> v -> m acc) -> acc -> Map k v -> m acc
 foldM f acc0 =
@@ -158,6 +183,15 @@ for_ m f =
         f k v
         go ys
 
+-- | Like 'Map.fromSet', but in an applicative functor.
+fromSetA :: (Applicative m) => (k -> m a) -> Set k -> m (Map k a)
+fromSetA f =
+  go
+  where
+    go = \case
+      Set.Tip -> pure Map.Tip
+      Set.Bin n k l r -> (\v l' r' -> Map.Bin n k v l' r') <$> f k <*> go l <*> go r
+
 unionWithM ::
   forall m k a.
   (Monad m, Ord k) =>
@@ -182,6 +216,11 @@ remap :: (Ord k1) => ((k0, v0) -> (k1, v1)) -> Map k0 v0 -> Map k1 v1
 remap f =
   Map.fromList . map f . Map.toList
 
+-- | Insert a pair in postfix-style.
+thenInsertPair :: (Ord k) => Map k v -> (k, v) -> Map k v
+thenInsertPair m (k, v) =
+  Map.insert k v m
+
 traverseKeys :: (Applicative f, Ord k') => (k -> f k') -> Map k v -> f (Map k' v)
 traverseKeys f = bitraverse f pure
 

lib/unison-prelude/src/Unison/Util/Set.hs

@@ -1,6 +1,9 @@
 module Unison.Util.Set
   ( asSingleton,
     difference1,
+    differenceMap,
+    foldCommutativeM,
+    insertMaybe,
     intersects,
     mapMaybe,
     symmetricDifference,
@@ -9,14 +12,19 @@ module Unison.Util.Set
     flatMap,
     filterM,
     forMaybe,
+    thenInsert,
+    thenInsertMaybe,
   )
 where
 
 import Data.Function ((&))
 import Data.Functor ((<&>))
+import Data.Map.Internal qualified as Map.Internal (Map (..))
+import Data.Map.Strict (Map)
 import Data.Maybe qualified as Maybe
 import Data.Set (Set)
 import Data.Set qualified as Set
+import Data.Set.Internal qualified as Set.Internal (Set (..), merge)
 import Unison.Util.Monoid (foldMapM)
 
 -- | Get the only member of a set, iff it's a singleton.
@@ -31,6 +39,36 @@ difference1 xs ys =
   where
     zs = Set.difference xs ys
 
+-- | Like 'Set.difference', but the second argument is a map.
+differenceMap :: (Ord k) => Set k -> Map k a -> Set k
+differenceMap Set.Internal.Tip _ = Set.Internal.Tip
+differenceMap x Map.Internal.Tip = x
+differenceMap x (Map.Internal.Bin _ k _ yl yr)
+  | Set.size zl + Set.size zr == Set.size x = x
+  | otherwise = Set.Internal.merge zl zr
+  where
+    (xl, xr) = Set.split k x
+    !zl = differenceMap xl yl
+    !zr = differenceMap xr yr
+
+-- | Fold a set strictly with a monadic "commutative" combining function that doesn't receive the elements in any
+-- particular order.
+foldCommutativeM :: (Monad m) => (a -> b -> m b) -> b -> Set a -> m b
+foldCommutativeM f =
+  let go !acc = \case
+        Set.Internal.Bin _ x l r : xs -> do
+          !acc1 <- f x acc
+          go acc1 (l : r : xs)
+        Set.Internal.Tip : xs -> go acc xs
+        [] -> pure acc
+   in \z xs -> go z [xs]
+
+insertMaybe :: (Ord a) => Maybe a -> Set a -> Set a
+insertMaybe mx xs =
+  case mx of
+    Just x -> Set.insert x xs
+    Nothing -> xs
+
 -- | Get whether two sets intersect.
 intersects :: (Ord a) => Set a -> Set a -> Bool
 intersects xs ys =
@@ -64,3 +102,12 @@ filterM p =
     p x <&> \case
       False -> Set.empty
       True -> Set.singleton x
+
+thenInsert :: (Ord a) => Set a -> a -> Set a
+thenInsert xs x =
+  Set.insert x xs
+
+thenInsertMaybe :: (Ord a) => Set a -> Maybe a -> Set a
+thenInsertMaybe xs = \case
+  Just x -> Set.insert x xs
+  Nothing -> xs

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

@@ -61,14 +61,15 @@ import Prelude hiding (filter)
 --
 -- "Left-unique" means that for all @(x, y)@ in the relation, @y@ is related only to @x@.
 data BiMultimap a b = BiMultimap
-  { toMultimap :: (Map a (NESet b)), -- intentionally lazy in case it's not used after `fromRange`
-    toMapR :: (Map b a)
+  { toMultimap :: Map a (NESet b), -- intentionally lazy in case it's not used after `fromRange`
+    toMapR :: Map b a
   }
-  deriving (Eq, Ord, Show)
+  deriving stock (Eq, Ord, Show)
 
 -- | An empty left-unique relation.
 empty :: (Ord a, Ord b) => BiMultimap a b
-empty = BiMultimap mempty mempty
+empty =
+  BiMultimap Map.empty Map.empty
 
 -- | Is a left-unique relation empty?
 isEmpty :: BiMultimap a b -> Bool
@@ -167,6 +168,7 @@ withoutRan :: (Ord a, Ord b) => Set b -> BiMultimap a b -> BiMultimap a b
 withoutRan ys m =
   fromRange (Map.withoutKeys (range m) ys)
 
+-- | /O(1)/.
 domain :: BiMultimap a b -> Map a (NESet b)
 domain = toMultimap
 
@@ -216,8 +218,10 @@ ran =
 
 -- | Convert a left-unique relation to a relation (forgetting its left-uniqueness).
 toRelation :: (Ord a, Ord b) => BiMultimap a b -> Relation a b
-toRelation =
-  Relation.fromMultimap . Map.map Set.NonEmpty.toSet . domain
+toRelation m =
+  Relation.unsafeFromMultimaps
+    (Set.NonEmpty.toSet <$> domain m)
+    (Set.singleton <$> range m)
 
 -- | Insert a pair into a left-unique relation, maintaining left-uniqueness, preferring the latest inserted element.
 --