Merge pull request #4608 from unisonweb/pg/sync

Changes to UCM for PG Share

codebase2/codebase-sqlite-hashing-v2/src/Unison/Hashing/V2/Convert2.hs

@@ -4,6 +4,7 @@ module Unison.Hashing.V2.Convert2
     v2ToH2Type,
     v2ToH2TypeD,
     h2ToV2Reference,
+    v2ToH2Referent,
     v2ToH2Branch,
     v2ToH2Term,
     v2ToH2Decl,

codebase2/codebase-sqlite/U/Codebase/Sqlite/Branch/Format.hs

@@ -11,6 +11,7 @@ module U.Codebase.Sqlite.Branch.Format
     localToDbBranch,
     localToDbDiff,
     localToHashBranch,
+    localToBranch,
     -- dbToLocalDiff,
   )
 where

codebase2/codebase-sqlite/U/Codebase/Sqlite/Branch/Full.hs

@@ -3,8 +3,8 @@
 module U.Codebase.Sqlite.Branch.Full where
 
 import Control.Lens
+import Data.Bitraversable
 import Data.Map.Strict qualified as Map
-import Data.Set qualified as Set
 import U.Codebase.HashTags
 import U.Codebase.Reference (Reference', TermReference', TypeReference')
 import U.Codebase.Reference qualified as Reference
@@ -91,13 +91,33 @@ metadataSetFormatReferences_ ::
 metadataSetFormatReferences_ f (Inline refs) = Inline <$> Set.traverse f refs
 
 quadmap :: forall t h p c t' h' p' c'. (Ord t', Ord h') => (t -> t') -> (h -> h') -> (p -> p') -> (c -> c') -> Branch' t h p c -> Branch' t' h' p' c'
-quadmap ft fh fp fc (Branch terms types patches children) =
+quadmap ft fh fp fc branch =
+  runIdentity $ quadmapM (Identity . ft) (Identity . fh) (Identity . fp) (Identity . fc) branch
+
+quadmapM :: forall t h p c t' h' p' c' m. (Ord t', Ord h', Applicative m) => (t -> m t') -> (h -> m h') -> (p -> m p') -> (c -> m c') -> Branch' t h p c -> m (Branch' t' h' p' c')
+quadmapM ft fh fp fc (Branch terms types patches children) =
   Branch
-    (Map.bimap ft doTerms terms)
-    (Map.bimap ft doTypes types)
-    (Map.bimap ft fp patches)
-    (Map.bimap ft fc children)
+    <$> (Map.bitraverse ft doTerms terms)
+    <*> (Map.bitraverse ft doTypes types)
+    <*> (Map.bitraverse ft fp patches)
+    <*> (Map.bitraverse ft fc children)
   where
-    doTerms = Map.bimap (bimap (bimap ft fh) (bimap ft fh)) doMetadata
-    doTypes = Map.bimap (bimap ft fh) doMetadata
-    doMetadata (Inline s) = Inline . Set.map (bimap ft fh) $ s
+    doTerms = Map.bitraverse (bitraverse (bitraverse ft fh) (bitraverse ft fh)) doMetadata
+    doTypes = Map.bitraverse (bitraverse ft fh) doMetadata
+    doMetadata (Inline s) = Inline <$> Set.traverse (bitraverse ft fh) s
+
+-- | Traversal over text references in a branch
+t_ :: (Ord t', Ord h) => Traversal (Branch' t h p c) (Branch' t' h p c) t t'
+t_ f = quadmapM f pure pure pure
+
+-- | Traversal over hash references in a branch
+h_ :: (Ord t, Ord h') => Traversal (Branch' t h p c) (Branch' t h' p c) h h'
+h_ f = quadmapM pure f pure pure
+
+-- | Traversal over patch references in a branch
+p_ :: (Ord t, Ord h) => Traversal (Branch' t h p c) (Branch' t h p' c) p p'
+p_ f = quadmapM pure pure f pure
+
+-- | Traversal over child references in a branch
+c_ :: (Ord t, Ord h) => Traversal (Branch' t h p c) (Branch' t h p c') c c'
+c_ f = quadmapM pure pure pure f

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

@@ -1,6 +1,6 @@
 -- | This module contains decoders for blobs stored in SQLite.
 module U.Codebase.Sqlite.Decode
-  ( DecodeError,
+  ( DecodeError (..),
 
     -- * @object.bytes@
     decodeBranchFormat,

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

@@ -2,8 +2,8 @@
 
 module U.Codebase.Sqlite.LocalIds where
 
+import Control.Lens
 import Data.Bifoldable (Bifoldable (bifoldMap))
-import Data.Bifunctor (Bifunctor (bimap))
 import Data.Bitraversable (Bitraversable (bitraverse))
 import Data.Bits (Bits)
 import Data.Vector (Vector)
@@ -48,3 +48,9 @@ instance Bifoldable LocalIds' where
 
 instance Bifunctor LocalIds' where
   bimap f g (LocalIds t d) = LocalIds (f <$> t) (g <$> d)
+
+t_ :: Traversal (LocalIds' t h) (LocalIds' t' h) t t'
+t_ f (LocalIds t d) = LocalIds <$> traverse f t <*> pure d
+
+h_ :: Traversal (LocalIds' t h) (LocalIds' t h') h h'
+h_ f (LocalIds t d) = LocalIds <$> pure t <*> traverse f d

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

@@ -1,3 +1,6 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
+
 -- | This module facilitates the creation of "localized" versions of objects, suitable for storage.
 --
 -- Localization is a stateful process in which the real database identifiers contained within an object, e.g. 'DbBranch', are canonicalized
@@ -24,35 +27,38 @@
 -- where all terms, types, etc. within the @branch@ structure refer to offsets in the associated vectors.
 module U.Codebase.Sqlite.LocalizeObject
   ( localizeBranch,
+    localizeBranchG,
     localizePatch,
+    localizePatchG,
   )
 where
 
 import Control.Lens
-import Control.Monad.Trans.State.Strict (StateT)
+import Control.Monad.State.Strict
 import Control.Monad.Trans.State.Strict qualified as State
 import Data.Bitraversable (bitraverse)
-import Data.Generics.Product.Typed (HasType (typed))
+import Data.Generics.Product (HasField (..))
 import Data.Map.Strict qualified as Map
+import U.Codebase.Reference (Reference')
+import U.Codebase.Referent (Referent')
 import U.Codebase.Sqlite.Branch.Format (BranchLocalIds)
 import U.Codebase.Sqlite.Branch.Format qualified as Branch
 import U.Codebase.Sqlite.Branch.Full (Branch' (..), DbBranch, LocalBranch)
 import U.Codebase.Sqlite.Branch.Full qualified as Branch
-import U.Codebase.Sqlite.DbId (BranchObjectId, CausalHashId, HashId, ObjectId, PatchObjectId, TextId)
 import U.Codebase.Sqlite.LocalIds
   ( LocalBranchChildId (..),
     LocalDefnId (..),
     LocalHashId (..),
     LocalPatchObjectId (..),
     LocalTextId (..),
   )
-import U.Codebase.Sqlite.Patch.Format (PatchLocalIds)
+import U.Codebase.Sqlite.Patch.Format (PatchLocalIds, PatchLocalIds')
 import U.Codebase.Sqlite.Patch.Format qualified as Patch
 import U.Codebase.Sqlite.Patch.Full (LocalPatch, Patch, Patch' (..))
-import U.Codebase.Sqlite.Patch.TermEdit (LocalTermEdit, TermEdit)
-import U.Codebase.Sqlite.Patch.TypeEdit (LocalTypeEdit, TypeEdit)
-import U.Codebase.Sqlite.Reference (LocalReference, LocalReferenceH, Reference, ReferenceH)
-import U.Codebase.Sqlite.Referent (LocalReferent, LocalReferentH, Referent, ReferentH)
+import U.Codebase.Sqlite.Patch.TermEdit (LocalTermEdit, TermEdit')
+import U.Codebase.Sqlite.Patch.TypeEdit (LocalTypeEdit, TypeEdit')
+import U.Codebase.Sqlite.Reference (LocalReference, LocalReferenceH)
+import U.Codebase.Sqlite.Referent (LocalReferent, LocalReferentH)
 import Unison.Prelude
 import Unison.Util.Map qualified as Map
 import Unison.Util.Set qualified as Set
@@ -62,70 +68,92 @@ import Unison.Util.Set qualified as Set
 
 -- | Localize a branch object.
 localizeBranch :: DbBranch -> (BranchLocalIds, LocalBranch)
-localizeBranch (Branch terms types patches children) =
+localizeBranch = localizeBranchG
+
+-- | Generalized form of 'localizeBranch'.
+localizeBranchG :: forall t d p c. (Ord t, Ord d, Ord p, Ord c) => Branch' t d p c -> (Branch.BranchLocalIds' t d p c, LocalBranch)
+localizeBranchG (Branch terms types patches children) =
   (runIdentity . runLocalizeBranch) do
     Branch
       <$> Map.bitraverse localizeText (Map.bitraverse localizeReferent localizeBranchMetadata) terms
       <*> Map.bitraverse localizeText (Map.bitraverse localizeReference localizeBranchMetadata) types
       <*> Map.bitraverse localizeText localizePatchReference patches
       <*> Map.bitraverse localizeText localizeBranchReference children
   where
-    localizeBranchMetadata :: (ContainsDefns s, ContainsText s, Monad m) => Branch.DbMetadataSet -> StateT s m Branch.LocalMetadataSet
+    localizeBranchMetadata ::
+      Branch.MetadataSetFormat' t d ->
+      State (LocalizeBranchState t d p c) (Branch.MetadataSetFormat' LocalTextId LocalDefnId)
     localizeBranchMetadata (Branch.Inline refs) =
       Branch.Inline <$> Set.traverse localizeReference refs
 
 -- | Localize a patch object.
 localizePatch :: Patch -> (PatchLocalIds, LocalPatch)
-localizePatch (Patch termEdits typeEdits) =
+localizePatch = localizePatchG
+
+localizePatchG :: forall t h d. (Ord t, Ord h, Ord d) => Patch' t h d -> (PatchLocalIds' t h d, LocalPatch)
+localizePatchG (Patch termEdits typeEdits) =
   (runIdentity . runLocalizePatch) do
     Patch
       <$> Map.bitraverse localizeReferentH (Set.traverse localizeTermEdit) termEdits
       <*> Map.bitraverse localizeReferenceH (Set.traverse localizeTypeEdit) typeEdits
   where
-    localizeTermEdit :: (ContainsText s, ContainsDefns s, Monad m) => TermEdit -> StateT s m LocalTermEdit
+    localizeTermEdit :: (TermEdit' t d) -> State (LocalizePatchState t h d) LocalTermEdit
     localizeTermEdit =
       bitraverse localizeText localizeDefn
 
-    localizeTypeEdit :: (ContainsText s, ContainsDefns s, Monad m) => TypeEdit -> StateT s m LocalTypeEdit
+    localizeTypeEdit :: TypeEdit' t d -> State (LocalizePatchState t h d) LocalTypeEdit
     localizeTypeEdit =
       bitraverse localizeText localizeDefn
 
 --------------------------------------------------------------------------------------------------------------------------------------------
 -- General-purpose localization
 
 -- Contains references to branch objects.
-type ContainsBranches s =
-  HasType (Map (BranchObjectId, CausalHashId) LocalBranchChildId) s
+class Ord c => ContainsBranches c s where
+  branches_ :: Lens' s (Map c LocalBranchChildId)
 
 -- Contains references to definition objects i.e. term/decl component objects.
-type ContainsDefns s =
-  HasType (Map ObjectId LocalDefnId) s
+class Ord d => ContainsDefns d s where
+  defns_ :: Lens' s (Map d LocalDefnId)
 
 -- Contains references to objects by their hash.
-type ContainsHashes =
-  HasType (Map HashId LocalHashId)
+class Ord h => ContainsHashes h s where
+  hashes_ :: Lens' s (Map h LocalHashId)
 
 -- Contains references to patch objects.
-type ContainsPatches =
-  HasType (Map PatchObjectId LocalPatchObjectId)
+class Ord p => ContainsPatches p s where
+  patches_ :: Lens' s (Map p LocalPatchObjectId)
 
 -- Contains text.
-type ContainsText =
-  HasType (Map TextId LocalTextId)
+class Ord t => ContainsText t s where
+  texts_ :: Lens' s (Map t LocalTextId)
 
 -- The inner state of the localization of a branch object.
-type LocalizeBranchState =
-  ( Map TextId LocalTextId,
-    Map ObjectId LocalDefnId,
-    Map PatchObjectId LocalPatchObjectId,
-    Map (BranchObjectId, CausalHashId) LocalBranchChildId
-  )
+data LocalizeBranchState t d p c = LocalizeBranchState
+  { texts :: Map t LocalTextId,
+    defns :: Map d LocalDefnId,
+    patches :: Map p LocalPatchObjectId,
+    branches :: Map c LocalBranchChildId
+  }
+  deriving (Show, Generic)
+
+instance Ord t => ContainsText t (LocalizeBranchState t d p c) where
+  texts_ = field @"texts"
+
+instance Ord d => ContainsDefns d (LocalizeBranchState t d p c) where
+  defns_ = field @"defns"
 
--- Run a computation that localizes a branch object, returning the local ids recorded within.
-runLocalizeBranch :: (Monad m) => StateT LocalizeBranchState m a -> m (BranchLocalIds, a)
+instance Ord p => ContainsPatches p (LocalizeBranchState t d p c) where
+  patches_ = field @"patches"
+
+instance Ord c => ContainsBranches c (LocalizeBranchState t d p c) where
+  branches_ = field @"branches"
+
+-- | Run a computation that localizes a branch object, returning the local ids recorded within.
+runLocalizeBranch :: forall m t d p c a. (Monad m, Ord t, Ord d, Ord p, Ord c) => StateT (LocalizeBranchState t d p c) m a -> m (Branch.BranchLocalIds' t d p c, a)
 runLocalizeBranch action = do
-  (result, (localTexts, localDefns, localPatches, localChildren)) <- State.runStateT action (mempty @LocalizeBranchState)
-  let branchLocalIds :: BranchLocalIds
+  (result, (LocalizeBranchState localTexts localDefns localPatches localChildren)) <- State.runStateT action (LocalizeBranchState mempty mempty mempty mempty)
+  let branchLocalIds :: Branch.BranchLocalIds' t d p c
       branchLocalIds =
         Branch.LocalIds
           { Branch.branchTextLookup = Map.valuesVector (Map.swap localTexts),
@@ -136,17 +164,27 @@ runLocalizeBranch action = do
   pure (branchLocalIds, result)
 
 -- The inner state of the localization of a patch object.
-type LocalizePatchState =
-  ( Map TextId LocalTextId,
-    Map HashId LocalHashId,
-    Map ObjectId LocalDefnId
-  )
+data LocalizePatchState t h d = LocalizePatchState
+  { texts :: Map t LocalTextId,
+    hashes :: Map h LocalHashId,
+    defns :: Map d LocalDefnId
+  }
+  deriving (Show, Generic)
+
+instance Ord t => ContainsText t (LocalizePatchState t h d) where
+  texts_ = field @"texts"
+
+instance Ord h => ContainsHashes h (LocalizePatchState t h d) where
+  hashes_ = field @"hashes"
+
+instance Ord d => ContainsDefns d (LocalizePatchState t h d) where
+  defns_ = field @"defns"
 
 -- Run a computation that localizes a patch object, returning the local ids recorded within.
-runLocalizePatch :: (Monad m) => StateT LocalizePatchState m a -> m (PatchLocalIds, a)
+runLocalizePatch :: forall t h d a m. (Monad m, Ord t, Ord h, Ord d) => StateT (LocalizePatchState t h d) m a -> m (PatchLocalIds' t h d, a)
 runLocalizePatch action = do
-  (result, (localTexts, localHashes, localDefns)) <- State.runStateT action (mempty @LocalizePatchState)
-  let patchLocalIds :: PatchLocalIds
+  (result, (LocalizePatchState localTexts localHashes localDefns)) <- State.runStateT action (LocalizePatchState mempty mempty mempty)
+  let patchLocalIds :: PatchLocalIds' t h d
       patchLocalIds =
         Patch.LocalIds
           { Patch.patchTextLookup = Map.valuesVector (Map.swap localTexts),
@@ -156,52 +194,52 @@ runLocalizePatch action = do
   pure (patchLocalIds, result)
 
 -- Localize a branch object reference in any monad that encapsulates the stateful localization of an object that contains branch references.
-localizeBranchReference :: (ContainsBranches s, Monad m) => (BranchObjectId, CausalHashId) -> StateT s m LocalBranchChildId
+localizeBranchReference :: (ContainsBranches c s, Monad m) => c -> StateT s m LocalBranchChildId
 localizeBranchReference =
-  zoom typed . localize
+  zoom branches_ . localize
 
 -- Localize a definition object reference in any monad that encapsulates the stateful localization of an object that contains definition
 -- references.
-localizeDefn :: (ContainsDefns s, Monad m) => ObjectId -> StateT s m LocalDefnId
+localizeDefn :: (ContainsDefns d s, Monad m) => d -> StateT s m LocalDefnId
 localizeDefn =
-  zoom typed . localize
+  zoom defns_ . localize
 
 -- Localize a hash reference in any monad that encapsulates the stateful localization of an object that contains hash references.
-localizeHash :: (ContainsHashes s, Monad m) => HashId -> StateT s m LocalHashId
+localizeHash :: (ContainsHashes h s, Monad m) => h -> StateT s m LocalHashId
 localizeHash =
-  zoom typed . localize
+  zoom hashes_ . localize
 
 -- Localize a patch object reference in any monad that encapsulates the stateful localization of an object that contains patch references.
-localizePatchReference :: (ContainsPatches s, Monad m) => PatchObjectId -> StateT s m LocalPatchObjectId
+localizePatchReference :: (ContainsPatches p s, Monad m) => p -> StateT s m LocalPatchObjectId
 localizePatchReference =
-  zoom typed . localize
+  zoom patches_ . localize
 
 -- Localize a reference in any monad that encapsulates the stateful localization of an object that contains references.
-localizeReference :: (ContainsDefns s, ContainsText s, Monad m) => Reference -> StateT s m LocalReference
+localizeReference :: (ContainsDefns d s, ContainsText t s, Monad m) => Reference' t d -> StateT s m LocalReference
 localizeReference =
   bitraverse localizeText localizeDefn
 
 -- Localize a possibly-missing reference in any monad that encapsulates the stateful localization of an object that contains
 -- possibly-missing references.
-localizeReferenceH :: (ContainsHashes s, ContainsText s, Monad m) => ReferenceH -> StateT s m LocalReferenceH
+localizeReferenceH :: (ContainsHashes h s, ContainsText t s, Monad m) => Reference' t h -> StateT s m LocalReferenceH
 localizeReferenceH =
   bitraverse localizeText localizeHash
 
 -- Localize a referent in any monad that encapsulates the stateful localization of an object that contains referents.
-localizeReferent :: (ContainsDefns s, ContainsText s, Monad m) => Referent -> StateT s m LocalReferent
+localizeReferent :: forall d t s m. (ContainsDefns d s, ContainsText t s, Monad m) => (Referent' (Reference' t d) (Reference' t d)) -> StateT s m LocalReferent
 localizeReferent =
   bitraverse localizeReference localizeReference
 
 -- Localize a possibly-missing referent in any monad that encapsulates the stateful localization of an object that contains possibly-missing
 -- referents.
-localizeReferentH :: (ContainsHashes s, ContainsText s, Monad m) => ReferentH -> StateT s m LocalReferentH
+localizeReferentH :: (ContainsHashes h s, ContainsText t s, Monad m, r ~ Reference' t h) => Referent' r r -> StateT s m LocalReferentH
 localizeReferentH =
   bitraverse localizeReferenceH localizeReferenceH
 
 -- Localize a text reference in any monad that encapsulates the stateful localization of an object that contains text.
-localizeText :: (ContainsText s, Monad m) => TextId -> StateT s m LocalTextId
+localizeText :: (ContainsText t s, Monad m) => t -> StateT s m LocalTextId
 localizeText =
-  zoom typed . localize
+  zoom texts_ . localize
 
 -- Resolve a real id to its corresponding local id, either by looking it up in a map, or else using the next available local id, which is
 -- recorded for next time.

codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Format.hs

@@ -7,6 +7,7 @@ module U.Codebase.Sqlite.Patch.Format
     SyncPatchFormat' (..),
     applyPatchDiffs,
     localPatchToPatch,
+    localPatchToPatch',
     localPatchDiffToPatchDiff,
     localPatchToHashPatch,
   )
@@ -74,6 +75,15 @@ localToPatch' :: (Ord t, Ord h, Ord d) => PatchLocalIds' t h d -> (Patch' LocalT
 localToPatch' li =
   Patch.Full.trimap (lookupPatchLocalText li) (lookupPatchLocalHash li) (lookupPatchLocalDefn li)
 
+-- | Generic version of `localPatchToPatch` that works with any `PatchLocalIds'`.
+localPatchToPatch' ::
+  (Ord t, Ord h, Ord d) =>
+  PatchLocalIds' t h d ->
+  Patch' LocalTextId LocalHashId LocalDefnId ->
+  Patch' t h d
+localPatchToPatch' li =
+  Patch.Full.trimap (lookupPatchLocalText li) (lookupPatchLocalHash li) (lookupPatchLocalDefn li)
+
 -- | Type specialized version of `localToPatch'`.
 localPatchToPatch :: PatchLocalIds -> LocalPatch -> Patch
 localPatchToPatch = localToPatch'