Merge branch 'trunk' into series/M2

.github/workflows/ci.yaml

@@ -85,3 +85,5 @@ jobs:
           x=`git status --porcelain -uno` bash -c 'if [[ -n $x ]]; then echo "$x" && false; fi'
       - name: prettyprint-round-trip
         run: stack --no-terminal exec unison transcript unison-src/transcripts-round-trip/main.md
+      - name: other test suites
+        run: stack --no-terminal test unison-util-relation

codebase2/codebase-sqlite/U/Codebase/Sqlite/DbId.hs

@@ -11,31 +11,30 @@ import Data.Bits (Bits)
 import Data.Word (Word64)
 import Database.SQLite.Simple.FromField
 import Database.SQLite.Simple.ToField
-import U.Util.Hashable (Hashable)
 
 newtype ObjectId = ObjectId Word64 deriving (Eq, Ord, Show)
-  deriving (Num, Real, Enum, Integral, Bits, Hashable, FromField, ToField) via Word64
+  deriving (Num, Real, Enum, Integral, Bits, FromField, ToField) via Word64
 
 newtype TextId = TextId Word64 deriving (Eq, Ord, Show)
-  deriving (Num, Real, Enum, Integral, Bits, Hashable, FromField, ToField) via Word64
+  deriving (Num, Real, Enum, Integral, Bits, FromField, ToField) via Word64
 
 newtype HashId = HashId Word64 deriving (Eq, Ord, Show)
-  deriving (Num, Real, Enum, Integral, Bits, Hashable, FromField, ToField) via Word64
+  deriving (Num, Real, Enum, Integral, Bits, FromField, ToField) via Word64
 
 newtype PatchObjectId = PatchObjectId { unPatchObjectId :: ObjectId } deriving (Eq, Ord)
-  deriving (Num, Real, Enum, Integral, Bits, Hashable, FromField, ToField) via ObjectId
+  deriving (Num, Real, Enum, Integral, Bits, FromField, ToField) via ObjectId
 
 newtype BranchObjectId = BranchObjectId { unBranchObjectId :: ObjectId } deriving (Eq, Ord)
-  deriving (Num, Real, Enum, Integral, Bits, Hashable, FromField, ToField) via ObjectId
+  deriving (Num, Real, Enum, Integral, Bits, FromField, ToField) via ObjectId
 
 newtype BranchHashId = BranchHashId { unBranchHashId :: HashId } deriving (Eq, Ord)
-  deriving (Num, Real, Enum, Integral, Bits, Hashable, FromField, ToField) via HashId
+  deriving (Num, Real, Enum, Integral, Bits, FromField, ToField) via HashId
 
 newtype CausalHashId = CausalHashId { unCausalHashId :: HashId } deriving (Eq, Ord)
-  deriving (Num, Real, Enum, Integral, Bits, Hashable, FromField, ToField) via HashId
+  deriving (Num, Real, Enum, Integral, Bits, FromField, ToField) via HashId
 
 newtype SchemaVersion = SchemaVersion Word64 deriving (Eq, Ord, Show)
-  deriving (Num, Real, Enum, Integral, Bits, Hashable, FromField, ToField) via Word64
+  deriving (Num, Real, Enum, Integral, Bits, FromField, ToField) via Word64
 
 instance Show PatchObjectId where
   show h = "PatchObjectId (" ++ show (unPatchObjectId h) ++ ")"

codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs

@@ -29,7 +29,7 @@ import Data.Bitraversable (Bitraversable (bitraverse))
 import Data.ByteString (ByteString)
 import Data.Bytes.Get (runGetS)
 import qualified Data.Bytes.Get as Get
-import Data.Foldable (for_, traverse_)
+import Data.Foldable (traverse_)
 import qualified Data.Foldable as Foldable
 import Data.Functor (void, (<&>))
 import Data.Functor.Identity (Identity)
@@ -122,7 +122,6 @@ import U.Util.Serialization (Get)
 import qualified U.Util.Serialization as S
 import qualified U.Util.Set as Set
 import qualified U.Util.Term as TermUtil
-import qualified U.Util.Type as TypeUtil
 
 -- * Error handling
 
@@ -263,6 +262,9 @@ s2cReferent = bitraverse s2cReference s2cReference
 s2cReferentId :: EDB m => S.Referent.Id -> m C.Referent.Id
 s2cReferentId = bitraverse loadHashByObjectId loadHashByObjectId
 
+c2sReferentId :: EDB m => C.Referent.Id -> m S.Referent.Id
+c2sReferentId = bitraverse primaryHashToExistingObjectId primaryHashToExistingObjectId
+
 h2cReferent :: EDB m => S.ReferentH -> m C.Referent
 h2cReferent = bitraverse h2cReference h2cReference
 
@@ -427,7 +429,6 @@ componentByObjectId id = do
 -- * Codebase operations
 
 -- ** Saving & loading terms
-
 saveTermComponent :: EDB m => H.Hash -> [(C.Term Symbol, C.Term.Type Symbol)] -> m Db.ObjectId
 saveTermComponent h terms = do
   when debug . traceM $ "Operations.saveTermComponent " ++ show h
@@ -462,18 +463,12 @@ saveTermComponent h terms = do
          in Set.map (,self) dependencies
   traverse_ (uncurry Q.addToDependentsIndex) dependencies
 
-  -- populate type indexes
-  for_ (terms `zip` [0 ..]) \((_tm, tp), i) -> do
-    let self = C.Referent.RefId (C.Reference.Id oId i)
-        typeForIndexing = TypeUtil.removeAllEffectVars tp
-        typeMentionsForIndexing = TypeUtil.toReferenceMentions typeForIndexing
-        saveReferentH = bitraverse Q.saveText Q.saveHashHash
-    typeReferenceForIndexing <- saveReferentH $ TypeUtil.toReference typeForIndexing
-    Q.addToTypeIndex typeReferenceForIndexing self
-    traverse_ (flip Q.addToTypeMentionsIndex self <=< saveReferentH) typeMentionsForIndexing
-
   pure oId
 
+-- | Save the text and hash parts of a Reference to the database and substitute their ids.
+saveReferenceH :: DB m => C.Reference' Text H.Hash -> m (C.Reference' Db.TextId Db.HashId)
+saveReferenceH = bitraverse Q.saveText Q.saveHashHash
+
 -- | implementation detail of c2{s,w}Term
 --  The Type is optional, because we don't store them for watch expression results.
 c2xTerm :: forall m t d. Monad m => (Text -> m t) -> (H.Hash -> m d) -> C.Term Symbol -> Maybe (C.Term.Type Symbol) -> m (LocalIds' t d, S.Term.Term, Maybe (S.Term.Type))
@@ -730,7 +725,7 @@ w2cTerm ids tm = do
 
 -- ** Saving & loading type decls
 
-saveDeclComponent :: EDB m => H.Hash -> [C.Decl Symbol] -> m Db.ObjectId
+saveDeclComponent :: EDB m => H.Hash -> [(C.Decl Symbol)] -> m Db.ObjectId
 saveDeclComponent h decls = do
   when debug . traceM $ "Operations.saveDeclComponent " ++ show h
   sDeclElements <- traverse (c2sDecl Q.saveText primaryHashToExistingObjectId) decls
@@ -751,20 +746,6 @@ saveDeclComponent h decls = do
          in Set.mapMaybe (fmap (,self) . getSRef) dependencies
   traverse_ (uncurry Q.addToDependentsIndex) dependencies
 
-  -- populate type indexes
-  for_
-    (zip decls [0 ..])
-    \(C.DataDeclaration _ _ _ ctorTypes, i) -> for_
-      (zip ctorTypes [0 ..])
-      \(tp, j) -> do
-        let self = C.Referent.ConId (C.Reference.Id oId i) j
-            typeForIndexing :: C.Type.TypeT Symbol = TypeUtil.removeAllEffectVars (C.Type.typeD2T h tp)
-            typeReferenceForIndexing = TypeUtil.toReference typeForIndexing
-            typeMentionsForIndexing = TypeUtil.toReferenceMentions typeForIndexing
-            saveReferentH = bitraverse Q.saveText Q.saveHashHash
-        flip Q.addToTypeIndex self =<< saveReferentH typeReferenceForIndexing
-        traverse_ (flip Q.addToTypeMentionsIndex self <=< saveReferentH) typeMentionsForIndexing
-
   pure oId
 
 c2sDecl :: forall m t d. EDB m => (Text -> m t) -> (H.Hash -> m d) -> C.Decl Symbol -> m (LocalIds' t d, S.Decl.Decl Symbol)
@@ -1278,6 +1259,15 @@ termsMentioningType cTypeRef = do
     Nothing -> mempty
     Just set -> Set.fromList set
 
+addTypeToIndexForTerm :: EDB m => S.Referent.Id -> C.Reference -> m ()
+addTypeToIndexForTerm sTermId cTypeRef = do
+  sTypeRef <- saveReferenceH cTypeRef
+  Q.addToTypeIndex sTypeRef sTermId
+
+addTypeMentionsToIndexForTerm :: EDB m => S.Referent.Id -> Set C.Reference -> m ()
+addTypeMentionsToIndexForTerm sTermId cTypeMentionRefs = do
+  traverse_ (flip Q.addToTypeMentionsIndex sTermId <=< saveReferenceH) cTypeMentionRefs
+
 -- something kind of funny here.  first, we don't need to enumerate all the reference pos if we're just picking one
 -- second, it would be nice if we could leave these as S.References a little longer
 -- so that we remember how to blow up if they're missing

codebase2/codebase/U/Codebase/Decl.hs

@@ -11,9 +11,6 @@ import U.Codebase.Reference (Reference')
 import U.Codebase.Type (TypeR)
 import qualified U.Codebase.Type as Type
 import U.Util.Hash (Hash)
-import qualified U.Util.Hashable as Hashable
-
--- import qualified U.Core.ABT as ABT
 
 type ConstructorId = Word64
 
@@ -44,44 +41,9 @@ dependencies (DataDeclaration _ _ _ cts) = foldMap Type.dependencies cts
 
 data V v = Bound v | Ctor Int
 
--- toABT :: Ord v => Decl v -> ABT.Term F (V v) ()
--- toABT (DataDeclaration dt m bound constructors) =
---   ABT.tm () $ Modified dt m dd'
---   where
---   dd' = ABT.absChain bound $
---           ABT.absCycle
---             constructors dd
---             (ABT.tm () . Constructors $ ABT.transform Type <$> constructorTypes dd)
-
 data F a
   = Type (Type.FD a)
   | LetRec [a] a
   | Constructors [a]
   | Modified DeclType Modifier a
   deriving (Functor, Foldable, Show)
-
-instance Hashable.Hashable1 F where
-  hash1 hashCycle hash e =
-    -- Note: start each layer with leading `2` byte, to avoid collisions with
-    -- terms, which start each layer with leading `1`. See `Hashable1 Term.F`
-    Hashable.accumulate $
-      tag 2 : case e of
-        Type t -> [tag 0, hashed $ Hashable.hash1 hashCycle hash t]
-        LetRec bindings body ->
-          let (hashes, hash') = hashCycle bindings
-           in [tag 1] ++ map hashed hashes ++ [hashed $ hash' body]
-        Constructors cs ->
-          let (hashes, _) = hashCycle cs
-           in tag 2 : map hashed hashes
-        Modified dt m t ->
-          [tag 3, Hashable.accumulateToken dt, Hashable.accumulateToken m, hashed $ hash t]
-    where
-      (tag, hashed) = (Hashable.Tag, Hashable.Hashed)
-
-instance Hashable.Hashable DeclType where
-  tokens Data = [Hashable.Tag 0]
-  tokens Effect = [Hashable.Tag 1]
-
-instance Hashable.Hashable Modifier where
-  tokens Structural = [Hashable.Tag 0]
-  tokens (Unique txt) = [Hashable.Tag 1, Hashable.Text txt]

codebase2/codebase/U/Codebase/Kind.hs

@@ -1,14 +1,3 @@
-{-# LANGUAGE DeriveGeneric #-}
-
 module U.Codebase.Kind where
 
-import U.Util.Hashable (Hashable)
-import qualified U.Util.Hashable as Hashable
-import GHC.Generics (Generic)
-
-data Kind = Star | Arrow Kind Kind deriving (Eq,Ord,Read,Show,Generic)
-
-instance Hashable Kind where
-  tokens k = case k of
-    Star -> [Hashable.Tag 0]
-    Arrow k1 k2 -> (Hashable.Tag 1 : Hashable.tokens k1) ++ Hashable.tokens k2
+data Kind = Star | Arrow Kind Kind deriving (Eq,Ord,Read,Show)

codebase2/codebase/U/Codebase/Reference.hs

@@ -9,10 +9,7 @@ module U.Codebase.Reference where
 
 import Data.Text (Text)
 import Data.Word (Word64)
-import qualified U.Util.Hash as Hash
 import U.Util.Hash (Hash)
-import U.Util.Hashable (Hashable (..))
-import qualified U.Util.Hashable as Hashable
 import Control.Lens (lens, Lens, Bifunctor(..), Traversal)
 import Data.Bitraversable (Bitraversable(..))
 import Data.Bifoldable (Bifoldable(..))
@@ -59,15 +56,3 @@ instance Bifoldable Reference' where
 instance Bitraversable Reference' where
   bitraverse f _ (ReferenceBuiltin t) = ReferenceBuiltin <$> f t
   bitraverse _ g (ReferenceDerived id) = ReferenceDerived <$> traverse g id
-
-instance Hashable Reference where
-  tokens (ReferenceBuiltin txt) =
-    [Hashable.Tag 0, Hashable.Text txt]
-  tokens (ReferenceDerived (Id h i)) =
-    [Hashable.Tag 1, Hashable.Bytes (Hash.toBytes h), Hashable.Nat i]
-
-instance Hashable (Reference' Text (Maybe Hash)) where
-  tokens (ReferenceBuiltin txt) =
-    [Hashable.Tag 0, Hashable.Text txt]
-  tokens (ReferenceDerived (Id h i)) =
-    [Hashable.Tag 1, Hashable.accumulateToken h, Hashable.Nat i]

codebase2/codebase/U/Codebase/Referent.hs

@@ -8,8 +8,6 @@ import Data.Text (Text)
 import U.Codebase.Reference (Reference, Reference')
 import qualified U.Codebase.Reference as Reference
 import U.Util.Hash (Hash)
-import U.Util.Hashable (Hashable (..))
-import qualified U.Util.Hashable as Hashable
 import Data.Bifunctor (Bifunctor(..))
 import Data.Bifoldable (Bifoldable(..))
 import Data.Bitraversable (Bitraversable(..))
@@ -29,10 +27,6 @@ data Id' hTm hTp
   | ConId (Reference.Id' hTp) ConstructorId
   deriving (Eq, Ord, Show)
 
-instance (Hashable rTm, Hashable rTp) => Hashable (Referent' rTm rTp) where
-  tokens (Ref r) = Hashable.Tag 0 : Hashable.tokens r
-  tokens (Con r i) = [Hashable.Tag 1] ++ Hashable.tokens r ++ [Hashable.Nat (fromIntegral i)]
-
 instance Bifunctor Referent' where
   bimap f g = \case
     Ref r -> Ref (f r)

codebase2/codebase/U/Codebase/Term.hs

@@ -24,15 +24,12 @@ import qualified Data.Set as Set
 import Data.Text (Text)
 import Data.Word (Word64)
 import GHC.Generics (Generic, Generic1)
-import U.Codebase.Reference (Reference, Reference' (ReferenceBuiltin, ReferenceDerived))
-import qualified U.Codebase.Reference as Reference
+import U.Codebase.Reference (Reference, Reference')
 import U.Codebase.Referent (Referent')
 import U.Codebase.Type (TypeR)
 import qualified U.Codebase.Type as Type
 import qualified U.Core.ABT as ABT
 import U.Util.Hash (Hash)
-import qualified U.Util.Hash as Hash
-import qualified U.Util.Hashable as H
 
 type ConstructorId = Word64
 
@@ -230,96 +227,3 @@ dependencies =
     typeRef r = Writer.tell (mempty, Set.singleton r, mempty, mempty)
     termLink r = Writer.tell (mempty, mempty, Set.singleton r, mempty)
     typeLink r = Writer.tell (mempty, mempty, mempty, Set.singleton r)
-
--- * Instances
-
-instance H.Hashable SeqOp where
-  tokens PCons = [H.Tag 0]
-  tokens PSnoc = [H.Tag 1]
-  tokens PConcat = [H.Tag 2]
-
-instance H.Hashable (Pattern Text Reference) where
-  tokens (PUnbound) = [H.Tag 0]
-  tokens (PVar) = [H.Tag 1]
-  tokens (PBoolean b) = H.Tag 2 : [H.Tag $ if b then 1 else 0]
-  tokens (PInt n) = H.Tag 3 : [H.Int n]
-  tokens (PNat n) = H.Tag 4 : [H.Nat n]
-  tokens (PFloat f) = H.Tag 5 : H.tokens f
-  tokens (PConstructor r n args) =
-    [H.Tag 6, H.accumulateToken r, H.Nat $ fromIntegral n, H.accumulateToken args]
-  tokens (PEffectPure p) = H.Tag 7 : H.tokens p
-  tokens (PEffectBind r n args k) =
-    [H.Tag 8, H.accumulateToken r, H.Nat $ fromIntegral n, H.accumulateToken args, H.accumulateToken k]
-  tokens (PAs p) = H.Tag 9 : H.tokens p
-  tokens (PText t) = H.Tag 10 : H.tokens t
-  tokens (PSequenceLiteral ps) = H.Tag 11 : concatMap H.tokens ps
-  tokens (PSequenceOp l op r) = H.Tag 12 : H.tokens op ++ H.tokens l ++ H.tokens r
-  tokens (PChar c) = H.Tag 13 : H.tokens c
-
-instance (Eq v, Show v) => H.Hashable1 (F v) where
-  hash1 hashCycle hash e =
-    let (tag, hashed, varint) =
-          (H.Tag, H.Hashed, H.Nat . fromIntegral)
-     in case e of
-          -- So long as `Reference.Derived` ctors are created using the same
-          -- hashing function as is used here, this case ensures that references
-          -- are 'transparent' wrt hash and hashing is unaffected by whether
-          -- expressions are linked. So for example `x = 1 + 1` and `y = x` hash
-          -- the same.
-          Ref (Reference.Derived (Just h) 0) -> H.fromBytes (Hash.toBytes h)
-          Ref (Reference.Derived h i) ->
-            H.accumulate
-              [ tag 1, -- it's a term
-                tag 1, -- it's a derived reference
-                H.accumulateToken (Hash.toBytes <$> h),
-                H.Nat i
-              ]
-          -- Note: start each layer with leading `1` byte, to avoid collisions
-          -- with types, which start each layer with leading `0`.
-          -- See `Hashable1 Type.F`
-          _ ->
-            H.accumulate $
-              tag 1 : -- it's a term
-              case e of
-                Nat n -> tag 64 : H.tokens n
-                Int i -> tag 65 : H.tokens i
-                Float d -> tag 66 : H.tokens d
-                Boolean b -> tag 67 : H.tokens b
-                Text t -> tag 68 : H.tokens t
-                Char c -> tag 69 : H.tokens c
-                Ref (ReferenceBuiltin name) -> [tag 2, H.accumulateToken name]
-                Ref ReferenceDerived {} ->
-                  error "handled above, but GHC can't figure this out"
-                App a a2 -> [tag 3, hashed (hash a), hashed (hash a2)]
-                Ann a t -> [tag 4, hashed (hash a), hashed (ABT.hash t)]
-                List as ->
-                  tag 5 :
-                  varint (fromIntegral (length as)) :
-                  map
-                    (hashed . hash)
-                    (Foldable.toList as)
-                Lam a -> [tag 6, hashed (hash a)]
-                -- note: we use `hashCycle` to ensure result is independent of
-                -- let binding order
-                LetRec as a -> case hashCycle as of
-                  (hs, hash) -> tag 7 : hashed (hash a) : map hashed hs
-                -- here, order is significant, so don't use hashCycle
-                Let b a -> [tag 8, hashed $ hash b, hashed $ hash a]
-                If b t f ->
-                  [tag 9, hashed $ hash b, hashed $ hash t, hashed $ hash f]
-                Request r n -> [tag 10, H.accumulateToken r, varint n]
-                Constructor r n -> [tag 12, H.accumulateToken r, varint n]
-                Match e branches ->
-                  tag 13 : hashed (hash e) : concatMap h branches
-                  where
-                    h (MatchCase pat guard branch) =
-                      concat
-                        [ [H.accumulateToken pat],
-                          Foldable.toList @Maybe (hashed . hash <$> guard),
-                          [hashed (hash branch)]
-                        ]
-                Handle h b -> [tag 15, hashed $ hash h, hashed $ hash b]
-                And x y -> [tag 16, hashed $ hash x, hashed $ hash y]
-                Or x y -> [tag 17, hashed $ hash x, hashed $ hash y]
-                TermLink r -> [tag 18, H.accumulateToken r]
-                TypeLink r -> [tag 19, H.accumulateToken r]