mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 10:35:57 +03:00
Add unison-codebase-sqlite-hashing-v2 package
unison-codebase-sqlite is now parameterized by the hashing functions
This commit is contained in:
Travis Staton
parent
3dcb952b3c
commit
535eaf98a9
56
codebase2/codebase-sqlite-hashing-v2/package.yaml
Normal file
56
codebase2/codebase-sqlite-hashing-v2/package.yaml
Normal file
@ -0,0 +1,56 @@
|
||||
name: unison-codebase-sqlite-hashing-v2
|
||||
github: unisonweb/unison
|
||||
copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors
|
||||
|
||||
ghc-options: -Wall
|
||||
|
||||
dependencies:
|
||||
- base
|
||||
- bytes
|
||||
- bytestring
|
||||
- containers
|
||||
- lens
|
||||
- text
|
||||
- unison-codebase
|
||||
- unison-codebase-sqlite
|
||||
- unison-core
|
||||
- unison-core1
|
||||
- unison-hashing-v2
|
||||
- unison-prelude
|
||||
- unison-sqlite
|
||||
- unison-util
|
||||
- unison-util-base32hex
|
||||
- unison-util-term
|
||||
- vector
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
when:
|
||||
- condition: false
|
||||
other-modules: Paths_unison_codebase_sqlite_hashing_v2
|
||||
|
||||
default-extensions:
|
||||
- ApplicativeDo
|
||||
- BangPatterns
|
||||
- BlockArguments
|
||||
- DeriveAnyClass
|
||||
- DeriveFunctor
|
||||
- DeriveGeneric
|
||||
- DeriveTraversable
|
||||
- DerivingStrategies
|
||||
- DerivingVia
|
||||
- DoAndIfThenElse
|
||||
- FlexibleContexts
|
||||
- FlexibleInstances
|
||||
- GeneralizedNewtypeDeriving
|
||||
- LambdaCase
|
||||
- MultiParamTypeClasses
|
||||
- NamedFieldPuns
|
||||
- OverloadedStrings
|
||||
- PatternSynonyms
|
||||
- RecordWildCards
|
||||
- RankNTypes
|
||||
- ScopedTypeVariables
|
||||
- TupleSections
|
||||
- TypeApplications
|
||||
- ViewPatterns
|
||||
@ -0,0 +1,24 @@
|
||||
module U.Codebase.Sqlite.V2.Decl
|
||||
( saveDeclComponent,
|
||||
)
|
||||
where
|
||||
|
||||
import qualified U.Codebase.Decl as V2
|
||||
import U.Codebase.Sqlite.DbId (ObjectId)
|
||||
import qualified U.Codebase.Sqlite.Queries as U.Sqlite
|
||||
import U.Codebase.Sqlite.Symbol (Symbol)
|
||||
import U.Codebase.Sqlite.V2.HashHandle
|
||||
import U.Util.Hash (Hash)
|
||||
import Unison.Prelude
|
||||
import Unison.Sqlite
|
||||
|
||||
saveDeclComponent ::
|
||||
-- | The serialized decl component if we already have it e.g. via sync
|
||||
Maybe ByteString ->
|
||||
-- | decl component hash
|
||||
Hash ->
|
||||
-- | decl component
|
||||
[V2.Decl Symbol] ->
|
||||
Transaction ObjectId
|
||||
saveDeclComponent =
|
||||
U.Sqlite.saveDeclComponent v2HashHandle
|
||||
@ -0,0 +1,19 @@
|
||||
module U.Codebase.Sqlite.V2.HashHandle
|
||||
( v2HashHandle,
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import U.Codebase.Sqlite.HashHandle
|
||||
import U.Util.Type (removeAllEffectVars)
|
||||
import Unison.Hashing.V2.Convert2 (h2ToV2Reference, v2ToH2Type, v2ToH2TypeD)
|
||||
import qualified Unison.Hashing.V2.Type as H2
|
||||
|
||||
v2HashHandle :: HashHandle
|
||||
v2HashHandle =
|
||||
HashHandle
|
||||
{ toReference = h2ToV2Reference . H2.toReference . v2ToH2Type,
|
||||
toReferenceMentions = Set.map h2ToV2Reference . H2.toReferenceMentions . v2ToH2Type . removeAllEffectVars,
|
||||
toReferenceDecl = \h -> h2ToV2Reference . H2.toReference . v2ToH2TypeD h,
|
||||
toReferenceDeclMentions = \h -> Set.map h2ToV2Reference . H2.toReferenceMentions . v2ToH2TypeD h . removeAllEffectVars
|
||||
}
|
||||
@ -0,0 +1,11 @@
|
||||
module U.Codebase.Sqlite.V2.SyncEntity where
|
||||
|
||||
import qualified U.Codebase.Sqlite.DbId as Db
|
||||
import U.Codebase.Sqlite.Entity (SyncEntity)
|
||||
import qualified U.Codebase.Sqlite.Queries as Q
|
||||
import U.Codebase.Sqlite.V2.HashHandle
|
||||
import U.Util.Hash32 (Hash32)
|
||||
import Unison.Sqlite
|
||||
|
||||
saveSyncEntity :: Hash32 -> SyncEntity -> Transaction (Either Db.CausalHashId Db.ObjectId)
|
||||
saveSyncEntity = Q.saveSyncEntity v2HashHandle
|
||||
@ -0,0 +1,24 @@
|
||||
module U.Codebase.Sqlite.V2.Term
|
||||
( saveTermComponent,
|
||||
)
|
||||
where
|
||||
|
||||
import U.Codebase.Sqlite.DbId (ObjectId)
|
||||
import qualified U.Codebase.Sqlite.Queries as U.Sqlite
|
||||
import U.Codebase.Sqlite.Symbol (Symbol)
|
||||
import U.Codebase.Sqlite.V2.HashHandle
|
||||
import qualified U.Codebase.Term as V2
|
||||
import U.Util.Hash (Hash)
|
||||
import Unison.Prelude
|
||||
import Unison.Sqlite
|
||||
|
||||
saveTermComponent ::
|
||||
-- | The serialized term component if we already have it e.g. via sync
|
||||
Maybe ByteString ->
|
||||
-- | term component hash
|
||||
Hash ->
|
||||
-- | term component
|
||||
[(V2.Term Symbol, V2.Type Symbol)] ->
|
||||
Transaction ObjectId
|
||||
saveTermComponent =
|
||||
U.Sqlite.saveTermComponent v2HashHandle
|
||||
@ -1,6 +1,9 @@
|
||||
-- | Description: Converts V2 types to the V2 hashing types
|
||||
module Unison.Hashing.V2.Convert2
|
||||
( convertTerm,
|
||||
( v2ToH2Term,
|
||||
v2ToH2Type,
|
||||
v2ToH2TypeD,
|
||||
h2ToV2Reference,
|
||||
)
|
||||
where
|
||||
|
||||
@ -10,9 +13,10 @@ import qualified U.Codebase.Referent as V2.Referent
|
||||
import qualified U.Codebase.Term as V2 (F, F' (..), MatchCase (..), Pattern (..), SeqOp (..), TermRef, TypeRef)
|
||||
import qualified U.Codebase.Type as V2.Type
|
||||
import qualified U.Core.ABT as V2
|
||||
import qualified U.Core.ABT as V2.ABT
|
||||
import qualified U.Util.Hash as V2 (Hash)
|
||||
import qualified Unison.ABT as H2 (transform)
|
||||
import Unison.Codebase.SqliteCodebase.Conversions (abt2to1)
|
||||
import qualified Unison.ABT as V1.ABT
|
||||
import qualified Unison.Hashing.V2.Kind as H2
|
||||
import qualified Unison.Hashing.V2.Pattern as H2.Pattern
|
||||
import qualified Unison.Hashing.V2.Reference as H2
|
||||
@ -21,8 +25,18 @@ import qualified Unison.Hashing.V2.Term as H2
|
||||
import qualified Unison.Hashing.V2.Type as H2.Type
|
||||
import Unison.Prelude
|
||||
|
||||
convertTerm :: forall v. Ord v => V2.Hash -> V2.Term (V2.F v) v () -> H2.Term v ()
|
||||
convertTerm thisTermComponentHash = H2.transform convertF . abt2to1
|
||||
-- | Delete me ASAP. I am defined elsewhere.
|
||||
abt2to1 :: Functor f => V2.ABT.Term f v a -> V1.ABT.Term f v a
|
||||
abt2to1 (V2.ABT.Term fv a out) = V1.ABT.Term fv a (go out)
|
||||
where
|
||||
go = \case
|
||||
V2.ABT.Cycle body -> V1.ABT.Cycle (abt2to1 body)
|
||||
V2.ABT.Abs v body -> V1.ABT.Abs v (abt2to1 body)
|
||||
V2.ABT.Var v -> V1.ABT.Var v
|
||||
V2.ABT.Tm tm -> V1.ABT.Tm (abt2to1 <$> tm)
|
||||
|
||||
v2ToH2Term :: forall v. Ord v => V2.Hash -> V2.Term (V2.F v) v () -> H2.Term v ()
|
||||
v2ToH2Term thisTermComponentHash = H2.transform convertF . abt2to1
|
||||
where
|
||||
convertF :: forall x. V2.F v x -> H2.F v () () x
|
||||
convertF = \case
|
||||
@ -37,7 +51,7 @@ convertTerm thisTermComponentHash = H2.transform convertF . abt2to1
|
||||
V2.Request a b -> H2.Request (convertReference a) b
|
||||
V2.Handle a b -> H2.Handle a b
|
||||
V2.App a b -> H2.App a b
|
||||
V2.Ann a b -> H2.Ann a (convertType b)
|
||||
V2.Ann a b -> H2.Ann a (v2ToH2Type b)
|
||||
V2.List a -> H2.List a
|
||||
V2.If a b c -> H2.If a b c
|
||||
V2.And a b -> H2.And a b
|
||||
@ -97,12 +111,18 @@ convertReference' idConv = \case
|
||||
V2.ReferenceBuiltin x -> H2.Builtin x
|
||||
V2.ReferenceDerived x -> H2.DerivedId (idConv x)
|
||||
|
||||
convertType :: forall v. Ord v => V2.Type.TypeR V2.TypeRef v -> H2.Type.Type v ()
|
||||
convertType = H2.transform convertF . abt2to1
|
||||
v2ToH2Type :: forall v. Ord v => V2.Type.TypeR V2.TypeRef v -> H2.Type.Type v ()
|
||||
v2ToH2Type = v2ToH2Type' convertReference
|
||||
|
||||
v2ToH2TypeD :: forall v. Ord v => V2.Hash -> V2.Type.TypeD v -> H2.Type.Type v ()
|
||||
v2ToH2TypeD defaultHash = v2ToH2Type' (convertReference' (convertId defaultHash))
|
||||
|
||||
v2ToH2Type' :: forall r v. Ord v => (r -> H2.Reference) -> V2.Type.TypeR r v -> H2.Type.Type v ()
|
||||
v2ToH2Type' mkReference = H2.transform convertF . abt2to1
|
||||
where
|
||||
convertF :: forall a. V2.Type.F' V2.TypeRef a -> H2.Type.F a
|
||||
convertF :: forall a. V2.Type.F' r a -> H2.Type.F a
|
||||
convertF = \case
|
||||
V2.Type.Ref x -> H2.Type.Ref (convertReference x)
|
||||
V2.Type.Ref x -> H2.Type.Ref (mkReference x)
|
||||
V2.Type.Arrow a b -> H2.Type.Arrow a b
|
||||
V2.Type.Ann a k -> H2.Type.Ann a (convertKind k)
|
||||
V2.Type.App a b -> H2.Type.App a b
|
||||
@ -115,3 +135,8 @@ convertKind :: V2.Kind -> H2.Kind
|
||||
convertKind = \case
|
||||
V2.Star -> H2.Star
|
||||
V2.Arrow a b -> H2.Arrow (convertKind a) (convertKind b)
|
||||
|
||||
h2ToV2Reference :: H2.Reference -> V2.Reference
|
||||
h2ToV2Reference = \case
|
||||
H2.Builtin txt -> V2.ReferenceBuiltin txt
|
||||
H2.DerivedId (H2.Id x y) -> V2.ReferenceDerived (V2.Id x y)
|
||||
@ -0,0 +1,71 @@
|
||||
cabal-version: 1.12
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.34.7.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
|
||||
name: unison-codebase-sqlite-hashing-v2
|
||||
version: 0.0.0
|
||||
homepage: https://github.com/unisonweb/unison#readme
|
||||
bug-reports: https://github.com/unisonweb/unison/issues
|
||||
copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors
|
||||
build-type: Simple
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://github.com/unisonweb/unison
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
U.Codebase.Sqlite.V2.Decl
|
||||
U.Codebase.Sqlite.V2.HashHandle
|
||||
U.Codebase.Sqlite.V2.SyncEntity
|
||||
U.Codebase.Sqlite.V2.Term
|
||||
Unison.Hashing.V2.Convert2
|
||||
hs-source-dirs:
|
||||
src
|
||||
default-extensions:
|
||||
ApplicativeDo
|
||||
BangPatterns
|
||||
BlockArguments
|
||||
DeriveAnyClass
|
||||
DeriveFunctor
|
||||
DeriveGeneric
|
||||
DeriveTraversable
|
||||
DerivingStrategies
|
||||
DerivingVia
|
||||
DoAndIfThenElse
|
||||
FlexibleContexts
|
||||
FlexibleInstances
|
||||
GeneralizedNewtypeDeriving
|
||||
LambdaCase
|
||||
MultiParamTypeClasses
|
||||
NamedFieldPuns
|
||||
OverloadedStrings
|
||||
PatternSynonyms
|
||||
RecordWildCards
|
||||
RankNTypes
|
||||
ScopedTypeVariables
|
||||
TupleSections
|
||||
TypeApplications
|
||||
ViewPatterns
|
||||
ghc-options: -Wall
|
||||
build-depends:
|
||||
base
|
||||
, bytes
|
||||
, bytestring
|
||||
, containers
|
||||
, lens
|
||||
, text
|
||||
, unison-codebase
|
||||
, unison-codebase-sqlite
|
||||
, unison-core
|
||||
, unison-core1
|
||||
, unison-hashing-v2
|
||||
, unison-prelude
|
||||
, unison-sqlite
|
||||
, unison-util
|
||||
, unison-util-base32hex
|
||||
, unison-util-term
|
||||
, vector
|
||||
default-language: Haskell2010
|
||||
@ -21,8 +21,8 @@ data DeclFormat = Decl LocallyIndexedComponent
|
||||
type LocallyIndexedComponent =
|
||||
LocallyIndexedComponent' TextId ObjectId
|
||||
|
||||
newtype LocallyIndexedComponent' t d
|
||||
= LocallyIndexedComponent (Vector (LocalIds' t d, Decl Symbol))
|
||||
newtype LocallyIndexedComponent' t d = LocallyIndexedComponent
|
||||
{unLocallyIndexedComponent :: Vector (LocalIds' t d, Decl Symbol)}
|
||||
deriving (Show)
|
||||
|
||||
type SyncDeclFormat =
|
||||
|
||||
@ -12,6 +12,7 @@ module U.Codebase.Sqlite.Decode
|
||||
decodeSyncNamespaceFormat,
|
||||
decodeSyncPatchFormat,
|
||||
decodeSyncTermFormat,
|
||||
decodeSyncTermAndType,
|
||||
decodeTermElementDiscardingTerm,
|
||||
decodeTermElementDiscardingType,
|
||||
decodeTermElementWithType,
|
||||
@ -26,9 +27,14 @@ module U.Codebase.Sqlite.Decode
|
||||
|
||||
-- * @watch_result.result@
|
||||
decodeWatchResultFormat,
|
||||
|
||||
-- * unsyncs
|
||||
unsyncTermComponent,
|
||||
unsyncDeclComponent,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Exception (throwIO)
|
||||
import Data.Bytes.Get (runGetS)
|
||||
import qualified Data.Bytes.Get as Get
|
||||
import qualified U.Codebase.Reference as C.Reference
|
||||
@ -53,7 +59,7 @@ data DecodeError = DecodeError
|
||||
err :: String -- the error message
|
||||
}
|
||||
deriving stock (Show)
|
||||
deriving anyclass (SqliteExceptionReason)
|
||||
deriving anyclass (SqliteExceptionReason, Exception)
|
||||
|
||||
getFromBytesOr :: Text -> Get a -> ByteString -> Either DecodeError a
|
||||
getFromBytesOr decoder get bs = case runGetS get bs of
|
||||
@ -99,6 +105,18 @@ decodeSyncTermFormat :: ByteString -> Either DecodeError TermFormat.SyncTermForm
|
||||
decodeSyncTermFormat =
|
||||
getFromBytesOr "decomposeTermFormat" Serialization.decomposeTermFormat
|
||||
|
||||
-- | N.B. The bytestring here is not the entire object.bytes column --
|
||||
-- it's just the serialized term and type from 'TermFormat.SyncTermFormat'.
|
||||
decodeSyncTermAndType :: ByteString -> Either DecodeError (TermFormat.Term, TermFormat.Type)
|
||||
decodeSyncTermAndType =
|
||||
getFromBytesOr "getTermAndType" Serialization.getTermAndType
|
||||
|
||||
-- | N.B. The bytestring here is not the entire object.bytes column --
|
||||
-- it's just the serialized decl from 'DeclFormat.SyncDeclFormat'.
|
||||
decodeDecl :: ByteString -> Either DecodeError (DeclFormat.Decl Symbol)
|
||||
decodeDecl =
|
||||
getFromBytesOr "getDeclElement" Serialization.getDeclElement
|
||||
|
||||
decodeTermFormat :: ByteString -> Either DecodeError TermFormat.TermFormat
|
||||
decodeTermFormat =
|
||||
getFromBytesOr "getTermFormat" Serialization.getTermFormat
|
||||
@ -147,3 +165,24 @@ decodeTempTermFormat =
|
||||
decodeWatchResultFormat :: ByteString -> Either DecodeError TermFormat.WatchResultFormat
|
||||
decodeWatchResultFormat =
|
||||
getFromBytesOr "getWatchResultFormat" Serialization.getWatchResultFormat
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- unsyncs
|
||||
|
||||
unsyncTermComponent :: TermFormat.SyncLocallyIndexedComponent' t d -> IO (TermFormat.LocallyIndexedComponent' t d)
|
||||
unsyncTermComponent (TermFormat.SyncLocallyIndexedComponent terms) = do
|
||||
let phi (localIds, bs) = do
|
||||
(a, b) <- decodeSyncTermAndType bs
|
||||
pure (localIds, a, b)
|
||||
case traverse phi terms of
|
||||
Left err -> throwIO err
|
||||
Right x -> pure (TermFormat.LocallyIndexedComponent x)
|
||||
|
||||
unsyncDeclComponent :: DeclFormat.SyncLocallyIndexedComponent' t d -> IO (DeclFormat.LocallyIndexedComponent' t d)
|
||||
unsyncDeclComponent (DeclFormat.SyncLocallyIndexedComponent decls) = do
|
||||
let phi (localIds, bs) = do
|
||||
decl <- decodeDecl bs
|
||||
pure (localIds, decl)
|
||||
case traverse phi decls of
|
||||
Left err -> throwIO err
|
||||
Right x -> pure (DeclFormat.LocallyIndexedComponent x)
|
||||
|
||||
22
codebase2/codebase-sqlite/U/Codebase/Sqlite/HashHandle.hs
Normal file
22
codebase2/codebase-sqlite/U/Codebase/Sqlite/HashHandle.hs
Normal file
@ -0,0 +1,22 @@
|
||||
module U.Codebase.Sqlite.HashHandle
|
||||
( HashHandle (..),
|
||||
)
|
||||
where
|
||||
|
||||
import qualified U.Codebase.Reference as C
|
||||
import U.Codebase.Sqlite.Symbol (Symbol)
|
||||
import qualified U.Codebase.Term as C.Term
|
||||
import qualified U.Codebase.Type as C.Type
|
||||
import U.Util.Hash (Hash)
|
||||
import Unison.Prelude
|
||||
|
||||
data HashHandle = HashHandle
|
||||
{ -- | Hash type
|
||||
toReference :: C.Term.Type Symbol -> C.Reference,
|
||||
-- | Hash type's mentions
|
||||
toReferenceMentions :: C.Term.Type Symbol -> Set C.Reference,
|
||||
-- | Hash decl
|
||||
toReferenceDecl :: Hash -> C.Type.TypeD Symbol -> C.Reference,
|
||||
-- | Hash decl's mentions
|
||||
toReferenceDeclMentions :: Hash -> C.Type.TypeD Symbol -> Set C.Reference
|
||||
}
|
||||
@ -11,13 +11,13 @@ module U.Codebase.Sqlite.Operations
|
||||
expectCausalBranchByCausalHash,
|
||||
|
||||
-- * terms
|
||||
saveTermComponent,
|
||||
Q.saveTermComponent,
|
||||
loadTermComponent,
|
||||
loadTermByReference,
|
||||
loadTypeOfTermByTermReference,
|
||||
|
||||
-- * decls
|
||||
saveDeclComponent,
|
||||
Q.saveDeclComponent,
|
||||
loadDeclComponent,
|
||||
loadDeclByReference,
|
||||
expectDeclTypeById,
|
||||
@ -55,11 +55,11 @@ module U.Codebase.Sqlite.Operations
|
||||
dependentsOfComponent,
|
||||
|
||||
-- ** type index
|
||||
addTypeToIndexForTerm,
|
||||
Q.addTypeToIndexForTerm,
|
||||
termsHavingType,
|
||||
|
||||
-- ** type mentions index
|
||||
addTypeMentionsToIndexForTerm,
|
||||
Q.addTypeMentionsToIndexForTerm,
|
||||
termsMentioningType,
|
||||
|
||||
-- ** name lookup index
|
||||
@ -80,29 +80,23 @@ module U.Codebase.Sqlite.Operations
|
||||
diffPatch,
|
||||
decodeTermElementWithType,
|
||||
loadTermWithTypeByReference,
|
||||
s2cTermWithType,
|
||||
Q.s2cTermWithType,
|
||||
Q.s2cDecl,
|
||||
declReferencesByPrefix,
|
||||
branchHashesByPrefix,
|
||||
derivedDependencies,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Lens (Lens')
|
||||
import qualified Control.Lens as Lens
|
||||
import qualified Control.Monad.Extra as Monad
|
||||
import Control.Monad.State (MonadState, evalStateT)
|
||||
import Control.Monad.Writer (MonadWriter, runWriterT)
|
||||
import qualified Control.Monad.Writer as Writer
|
||||
import Data.Bifunctor (Bifunctor (bimap))
|
||||
import Data.Bitraversable (Bitraversable (bitraverse))
|
||||
import qualified Data.Foldable as Foldable
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Map.Merge.Lazy as Map
|
||||
import qualified Data.Sequence as Seq
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as Text
|
||||
import Data.Tuple.Extra (uncurry3, (***))
|
||||
import qualified Data.Vector as Vector
|
||||
import qualified U.Codebase.Branch as C.Branch
|
||||
import qualified U.Codebase.Causal as C
|
||||
import U.Codebase.Decl (ConstructorId)
|
||||
@ -125,17 +119,14 @@ import qualified U.Codebase.Sqlite.Branch.Full as S.MetadataSet
|
||||
import qualified U.Codebase.Sqlite.DbId as Db
|
||||
import qualified U.Codebase.Sqlite.Decl.Format as S.Decl
|
||||
import U.Codebase.Sqlite.Decode
|
||||
import U.Codebase.Sqlite.HashHandle (HashHandle (..))
|
||||
import U.Codebase.Sqlite.LocalIds
|
||||
( LocalDefnId (..),
|
||||
LocalIds,
|
||||
LocalIds' (..),
|
||||
LocalTextId (..),
|
||||
( LocalIds,
|
||||
WatchLocalIds,
|
||||
)
|
||||
import qualified U.Codebase.Sqlite.LocalIds as LocalIds
|
||||
import qualified U.Codebase.Sqlite.LocalizeObject as LocalizeObject
|
||||
import qualified U.Codebase.Sqlite.NamedRef as S
|
||||
import qualified U.Codebase.Sqlite.ObjectType as OT
|
||||
import qualified U.Codebase.Sqlite.ObjectType as ObjectType
|
||||
import qualified U.Codebase.Sqlite.Patch.Diff as S
|
||||
import qualified U.Codebase.Sqlite.Patch.Format as S
|
||||
import qualified U.Codebase.Sqlite.Patch.Format as S.Patch.Format
|
||||
@ -156,17 +147,13 @@ import qualified U.Codebase.Term as C
|
||||
import qualified U.Codebase.Term as C.Term
|
||||
import qualified U.Codebase.TermEdit as C
|
||||
import qualified U.Codebase.TermEdit as C.TermEdit
|
||||
import qualified U.Codebase.Type as C.Type
|
||||
import qualified U.Codebase.TypeEdit as C
|
||||
import qualified U.Codebase.TypeEdit as C.TypeEdit
|
||||
import U.Codebase.WatchKind (WatchKind)
|
||||
import qualified U.Core.ABT as ABT
|
||||
import qualified U.Util.Base32Hex as Base32Hex
|
||||
import qualified U.Util.Hash as H
|
||||
import qualified U.Util.Hash32 as Hash32
|
||||
import qualified U.Util.Lens as Lens
|
||||
import qualified U.Util.Serialization as S
|
||||
import qualified U.Util.Term as TermUtil
|
||||
import Unison.Prelude
|
||||
import Unison.Sqlite
|
||||
import qualified Unison.Util.Map as Map
|
||||
@ -305,12 +292,8 @@ h2cReferent = bitraverse h2cReference h2cReference
|
||||
|
||||
-- ** convert and save references
|
||||
|
||||
-- | Save the text and hash parts of a Reference to the database and substitute their ids.
|
||||
saveReferenceH :: C.Reference -> Transaction S.ReferenceH
|
||||
saveReferenceH = bitraverse Q.saveText Q.saveHashHash
|
||||
|
||||
saveReferentH :: C.Referent -> Transaction S.ReferentH
|
||||
saveReferentH = bitraverse saveReferenceH saveReferenceH
|
||||
saveReferentH = bitraverse Q.saveReferenceH Q.saveReferenceH
|
||||
|
||||
-- ** Edits transformations
|
||||
|
||||
@ -341,7 +324,7 @@ c2sPatch :: C.Branch.Patch -> Transaction S.Patch
|
||||
c2sPatch (C.Branch.Patch termEdits typeEdits) =
|
||||
S.Patch
|
||||
<$> Map.bitraverse saveReferentH (Set.traverse c2sTermEdit) termEdits
|
||||
<*> Map.bitraverse saveReferenceH (Set.traverse c2sTypeEdit) typeEdits
|
||||
<*> Map.bitraverse Q.saveReferenceH (Set.traverse c2sTypeEdit) typeEdits
|
||||
where
|
||||
c2sTermEdit = \case
|
||||
C.TermEdit.Replace r t -> S.TermEdit.Replace <$> c2sReferent r <*> pure (c2sTyping t)
|
||||
@ -402,163 +385,14 @@ loadTermComponent :: H.Hash -> MaybeT Transaction [(C.Term Symbol, C.Term.Type S
|
||||
loadTermComponent h = do
|
||||
oid <- MaybeT (Q.loadObjectIdForAnyHash h)
|
||||
S.Term.Term (S.Term.LocallyIndexedComponent elements) <- MaybeT (Q.loadTermObject oid decodeTermFormat)
|
||||
lift . traverse (uncurry3 s2cTermWithType) $ Foldable.toList elements
|
||||
|
||||
saveTermComponent :: H.Hash -> [(C.Term Symbol, C.Term.Type Symbol)] -> Transaction Db.ObjectId
|
||||
saveTermComponent h terms = do
|
||||
when debug . traceM $ "Operations.saveTermComponent " ++ show h
|
||||
sTermElements <- traverse (uncurry c2sTerm) terms
|
||||
hashId <- Q.saveHashHash h
|
||||
let li = S.Term.LocallyIndexedComponent $ Vector.fromList sTermElements
|
||||
bytes = S.putBytes S.putTermFormat $ S.Term.Term li
|
||||
oId <- Q.saveObject hashId OT.TermComponent bytes
|
||||
-- populate dependents index
|
||||
let dependencies :: Set (S.Reference.Reference, S.Reference.Id) = foldMap unlocalizeRefs (sTermElements `zip` [0 ..])
|
||||
unlocalizeRefs :: ((LocalIds, S.Term.Term, S.Term.Type), C.Reference.Pos) -> Set (S.Reference.Reference, S.Reference.Id)
|
||||
unlocalizeRefs ((LocalIds tIds oIds, tm, tp), i) =
|
||||
let self = C.Reference.Id oId i
|
||||
dependencies :: Set S.Reference =
|
||||
let (tmRefs, tpRefs, tmLinks, tpLinks) = TermUtil.dependencies tm
|
||||
tpRefs' = Foldable.toList $ C.Type.dependencies tp
|
||||
getTermSRef :: S.Term.TermRef -> S.Reference
|
||||
getTermSRef = \case
|
||||
C.ReferenceBuiltin t -> C.ReferenceBuiltin (tIds Vector.! fromIntegral t)
|
||||
C.Reference.Derived Nothing i -> C.Reference.Derived oId i -- index self-references
|
||||
C.Reference.Derived (Just h) i -> C.Reference.Derived (oIds Vector.! fromIntegral h) i
|
||||
getTypeSRef :: S.Term.TypeRef -> S.Reference
|
||||
getTypeSRef = \case
|
||||
C.ReferenceBuiltin t -> C.ReferenceBuiltin (tIds Vector.! fromIntegral t)
|
||||
C.Reference.Derived h i -> C.Reference.Derived (oIds Vector.! fromIntegral h) i
|
||||
getSTypeLink = getTypeSRef
|
||||
getSTermLink :: S.Term.TermLink -> S.Reference
|
||||
getSTermLink = \case
|
||||
C.Referent.Con ref _conId -> getTypeSRef ref
|
||||
C.Referent.Ref ref -> getTermSRef ref
|
||||
in Set.fromList $
|
||||
map getTermSRef tmRefs
|
||||
++ map getSTermLink tmLinks
|
||||
++ map getTypeSRef (tpRefs ++ tpRefs')
|
||||
++ map getSTypeLink tpLinks
|
||||
in Set.map (,self) dependencies
|
||||
traverse_ (uncurry Q.addToDependentsIndex) dependencies
|
||||
|
||||
pure oId
|
||||
|
||||
-- | 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))
|
||||
c2xTerm saveText saveDefn tm tp =
|
||||
done =<< (runWriterT . flip evalStateT mempty) do
|
||||
sterm <- ABT.transformM go tm
|
||||
stype <- traverse (ABT.transformM goType) tp
|
||||
pure (sterm, stype)
|
||||
where
|
||||
go :: forall m a. (MonadWriter (Seq Text, Seq H.Hash) m, MonadState (Map Text LocalTextId, Map H.Hash LocalDefnId) m) => C.Term.F Symbol a -> m (S.Term.F a)
|
||||
go = \case
|
||||
C.Term.Int n -> pure $ C.Term.Int n
|
||||
C.Term.Nat n -> pure $ C.Term.Nat n
|
||||
C.Term.Float n -> pure $ C.Term.Float n
|
||||
C.Term.Boolean b -> pure $ C.Term.Boolean b
|
||||
C.Term.Text t -> C.Term.Text <$> lookupText t
|
||||
C.Term.Char ch -> pure $ C.Term.Char ch
|
||||
C.Term.Ref r ->
|
||||
C.Term.Ref <$> bitraverse lookupText (traverse lookupDefn) r
|
||||
C.Term.Constructor typeRef cid ->
|
||||
C.Term.Constructor
|
||||
<$> bitraverse lookupText lookupDefn typeRef
|
||||
<*> pure cid
|
||||
C.Term.Request typeRef cid ->
|
||||
C.Term.Request <$> bitraverse lookupText lookupDefn typeRef <*> pure cid
|
||||
C.Term.Handle a a2 -> pure $ C.Term.Handle a a2
|
||||
C.Term.App a a2 -> pure $ C.Term.App a a2
|
||||
C.Term.Ann a typ -> C.Term.Ann a <$> ABT.transformM goType typ
|
||||
C.Term.List as -> pure $ C.Term.List as
|
||||
C.Term.If c t f -> pure $ C.Term.If c t f
|
||||
C.Term.And a a2 -> pure $ C.Term.And a a2
|
||||
C.Term.Or a a2 -> pure $ C.Term.Or a a2
|
||||
C.Term.Lam a -> pure $ C.Term.Lam a
|
||||
C.Term.LetRec bs a -> pure $ C.Term.LetRec bs a
|
||||
C.Term.Let a a2 -> pure $ C.Term.Let a a2
|
||||
C.Term.Match a cs -> C.Term.Match a <$> traverse goCase cs
|
||||
C.Term.TermLink r ->
|
||||
C.Term.TermLink
|
||||
<$> bitraverse
|
||||
(bitraverse lookupText (traverse lookupDefn))
|
||||
(bitraverse lookupText lookupDefn)
|
||||
r
|
||||
C.Term.TypeLink r ->
|
||||
C.Term.TypeLink <$> bitraverse lookupText lookupDefn r
|
||||
goType ::
|
||||
forall m a.
|
||||
(MonadWriter (Seq Text, Seq H.Hash) m, MonadState (Map Text LocalTextId, Map H.Hash LocalDefnId) m) =>
|
||||
C.Type.FT a ->
|
||||
m (S.Term.FT a)
|
||||
goType = \case
|
||||
C.Type.Ref r -> C.Type.Ref <$> bitraverse lookupText lookupDefn r
|
||||
C.Type.Arrow i o -> pure $ C.Type.Arrow i o
|
||||
C.Type.Ann a k -> pure $ C.Type.Ann a k
|
||||
C.Type.App f a -> pure $ C.Type.App f a
|
||||
C.Type.Effect e a -> pure $ C.Type.Effect e a
|
||||
C.Type.Effects es -> pure $ C.Type.Effects es
|
||||
C.Type.Forall a -> pure $ C.Type.Forall a
|
||||
C.Type.IntroOuter a -> pure $ C.Type.IntroOuter a
|
||||
goCase ::
|
||||
forall m w s a.
|
||||
( MonadState s m,
|
||||
MonadWriter w m,
|
||||
Lens.Field1' s (Map Text LocalTextId),
|
||||
Lens.Field1' w (Seq Text),
|
||||
Lens.Field2' s (Map H.Hash LocalDefnId),
|
||||
Lens.Field2' w (Seq H.Hash)
|
||||
) =>
|
||||
C.Term.MatchCase Text C.Term.TypeRef a ->
|
||||
m (C.Term.MatchCase LocalTextId S.Term.TypeRef a)
|
||||
goCase = \case
|
||||
C.Term.MatchCase pat guard body ->
|
||||
C.Term.MatchCase <$> goPat pat <*> pure guard <*> pure body
|
||||
goPat ::
|
||||
forall m s w.
|
||||
( MonadState s m,
|
||||
MonadWriter w m,
|
||||
Lens.Field1' s (Map Text LocalTextId),
|
||||
Lens.Field1' w (Seq Text),
|
||||
Lens.Field2' s (Map H.Hash LocalDefnId),
|
||||
Lens.Field2' w (Seq H.Hash)
|
||||
) =>
|
||||
C.Term.Pattern Text C.Term.TypeRef ->
|
||||
m (C.Term.Pattern LocalTextId S.Term.TypeRef)
|
||||
goPat = \case
|
||||
C.Term.PUnbound -> pure $ C.Term.PUnbound
|
||||
C.Term.PVar -> pure $ C.Term.PVar
|
||||
C.Term.PBoolean b -> pure $ C.Term.PBoolean b
|
||||
C.Term.PInt i -> pure $ C.Term.PInt i
|
||||
C.Term.PNat n -> pure $ C.Term.PNat n
|
||||
C.Term.PFloat d -> pure $ C.Term.PFloat d
|
||||
C.Term.PText t -> C.Term.PText <$> lookupText t
|
||||
C.Term.PChar c -> pure $ C.Term.PChar c
|
||||
C.Term.PConstructor r i ps -> C.Term.PConstructor <$> bitraverse lookupText lookupDefn r <*> pure i <*> traverse goPat ps
|
||||
C.Term.PAs p -> C.Term.PAs <$> goPat p
|
||||
C.Term.PEffectPure p -> C.Term.PEffectPure <$> goPat p
|
||||
C.Term.PEffectBind r i bindings k -> C.Term.PEffectBind <$> bitraverse lookupText lookupDefn r <*> pure i <*> traverse goPat bindings <*> goPat k
|
||||
C.Term.PSequenceLiteral ps -> C.Term.PSequenceLiteral <$> traverse goPat ps
|
||||
C.Term.PSequenceOp l op r -> C.Term.PSequenceOp <$> goPat l <*> pure op <*> goPat r
|
||||
|
||||
done :: ((S.Term.Term, Maybe S.Term.Type), (Seq Text, Seq H.Hash)) -> m (LocalIds' t d, S.Term.Term, Maybe S.Term.Type)
|
||||
done ((tm, tp), (localTextValues, localDefnValues)) = do
|
||||
textIds <- traverse saveText localTextValues
|
||||
defnIds <- traverse saveDefn localDefnValues
|
||||
let ids =
|
||||
LocalIds
|
||||
(Vector.fromList (Foldable.toList textIds))
|
||||
(Vector.fromList (Foldable.toList defnIds))
|
||||
pure (ids, void tm, void <$> tp)
|
||||
lift . traverse (uncurry3 Q.s2cTermWithType) $ Foldable.toList elements
|
||||
|
||||
loadTermWithTypeByReference :: C.Reference.Id -> MaybeT Transaction (C.Term Symbol, C.Term.Type Symbol)
|
||||
loadTermWithTypeByReference (C.Reference.Id h i) = do
|
||||
oid <- MaybeT (Q.loadObjectIdForPrimaryHash h)
|
||||
-- retrieve and deserialize the blob
|
||||
(localIds, term, typ) <- MaybeT (Q.loadTermObject oid (decodeTermElementWithType i))
|
||||
lift (s2cTermWithType localIds term typ)
|
||||
lift (Q.s2cTermWithType localIds term typ)
|
||||
|
||||
loadTermByReference :: C.Reference.Id -> MaybeT Transaction (C.Term Symbol)
|
||||
loadTermByReference r@(C.Reference.Id h i) = do
|
||||
@ -576,95 +410,15 @@ loadTypeOfTermByTermReference id@(C.Reference.Id h i) = do
|
||||
(localIds, typ) <- MaybeT (Q.loadTermObject oid (decodeTermElementDiscardingTerm i))
|
||||
lift (s2cTypeOfTerm localIds typ)
|
||||
|
||||
s2cTermWithType :: LocalIds -> S.Term.Term -> S.Term.Type -> Transaction (C.Term Symbol, C.Term.Type Symbol)
|
||||
s2cTermWithType ids tm tp = do
|
||||
(substText, substHash) <- localIdsToLookups Q.expectText Q.expectPrimaryHashByObjectId ids
|
||||
pure (x2cTerm substText substHash tm, x2cTType substText substHash tp)
|
||||
|
||||
s2cTerm :: LocalIds -> S.Term.Term -> Transaction (C.Term Symbol)
|
||||
s2cTerm ids tm = do
|
||||
(substText, substHash) <- localIdsToLookups Q.expectText Q.expectPrimaryHashByObjectId ids
|
||||
pure $ x2cTerm substText substHash tm
|
||||
(substText, substHash) <- Q.localIdsToLookups Q.expectText Q.expectPrimaryHashByObjectId ids
|
||||
pure $ Q.x2cTerm substText substHash tm
|
||||
|
||||
s2cTypeOfTerm :: LocalIds -> S.Term.Type -> Transaction (C.Term.Type Symbol)
|
||||
s2cTypeOfTerm ids tp = do
|
||||
(substText, substHash) <- localIdsToLookups Q.expectText Q.expectPrimaryHashByObjectId ids
|
||||
pure $ x2cTType substText substHash tp
|
||||
|
||||
-- | implementation detail of {s,w}2c*Term* & s2cDecl
|
||||
localIdsToLookups :: Monad m => (t -> m Text) -> (d -> m H.Hash) -> LocalIds' t d -> m (LocalTextId -> Text, LocalDefnId -> H.Hash)
|
||||
localIdsToLookups loadText loadHash localIds = do
|
||||
texts <- traverse loadText $ LocalIds.textLookup localIds
|
||||
hashes <- traverse loadHash $ LocalIds.defnLookup localIds
|
||||
let substText (LocalTextId w) = texts Vector.! fromIntegral w
|
||||
substHash (LocalDefnId w) = hashes Vector.! fromIntegral w
|
||||
pure (substText, substHash)
|
||||
|
||||
localIdsToTypeRefLookup :: LocalIds -> Transaction (S.Decl.TypeRef -> C.Decl.TypeRef)
|
||||
localIdsToTypeRefLookup localIds = do
|
||||
(substText, substHash) <- localIdsToLookups Q.expectText Q.expectPrimaryHashByObjectId localIds
|
||||
pure $ bimap substText (fmap substHash)
|
||||
|
||||
-- | implementation detail of {s,w}2c*Term*
|
||||
x2cTerm :: (LocalTextId -> Text) -> (LocalDefnId -> H.Hash) -> S.Term.Term -> C.Term Symbol
|
||||
x2cTerm substText substHash =
|
||||
-- substitute the text and hashes back into the term
|
||||
C.Term.extraMap substText substTermRef substTypeRef substTermLink substTypeLink id
|
||||
where
|
||||
substTermRef = bimap substText (fmap substHash)
|
||||
substTypeRef = bimap substText substHash
|
||||
substTermLink = bimap substTermRef substTypeRef
|
||||
substTypeLink = substTypeRef
|
||||
|
||||
-- | implementation detail of {s,w}2c*Term*
|
||||
x2cTType :: (LocalTextId -> Text) -> (LocalDefnId -> H.Hash) -> S.Term.Type -> C.Term.Type Symbol
|
||||
x2cTType substText substHash = C.Type.rmap (bimap substText substHash)
|
||||
|
||||
lookupText ::
|
||||
forall m s w t.
|
||||
( MonadState s m,
|
||||
MonadWriter w m,
|
||||
Lens.Field1' s (Map t LocalTextId),
|
||||
Lens.Field1' w (Seq t),
|
||||
Ord t
|
||||
) =>
|
||||
t ->
|
||||
m LocalTextId
|
||||
lookupText = lookup_ Lens._1 Lens._1 LocalTextId
|
||||
|
||||
lookupDefn ::
|
||||
forall m s w d.
|
||||
( MonadState s m,
|
||||
MonadWriter w m,
|
||||
Lens.Field2' s (Map d LocalDefnId),
|
||||
Lens.Field2' w (Seq d),
|
||||
Ord d
|
||||
) =>
|
||||
d ->
|
||||
m LocalDefnId
|
||||
lookupDefn = lookup_ Lens._2 Lens._2 LocalDefnId
|
||||
|
||||
-- | shared implementation of lookupTextHelper and lookupDefnHelper
|
||||
-- Look up a value in the LUT, or append it.
|
||||
lookup_ ::
|
||||
(MonadState s m, MonadWriter w m, Ord t) =>
|
||||
Lens' s (Map t t') ->
|
||||
Lens' w (Seq t) ->
|
||||
(Word64 -> t') ->
|
||||
t ->
|
||||
m t'
|
||||
lookup_ stateLens writerLens mk t = do
|
||||
map <- Lens.use stateLens
|
||||
case Map.lookup t map of
|
||||
Nothing -> do
|
||||
let id = mk . fromIntegral $ Map.size map
|
||||
stateLens Lens.%= Map.insert t id
|
||||
Writer.tell $ Lens.set writerLens (Seq.singleton t) mempty
|
||||
pure id
|
||||
Just t' -> pure t'
|
||||
|
||||
c2sTerm :: C.Term Symbol -> C.Term.Type Symbol -> Transaction (LocalIds, S.Term.Term, S.Term.Type)
|
||||
c2sTerm tm tp = c2xTerm Q.saveText Q.expectObjectIdForPrimaryHash tm (Just tp) <&> \(w, tm, Just tp) -> (w, tm, tp)
|
||||
(substText, substHash) <- Q.localIdsToLookups Q.expectText Q.expectPrimaryHashByObjectId ids
|
||||
pure $ Q.x2cTType substText substHash tp
|
||||
|
||||
-- *** Watch expressions
|
||||
|
||||
@ -689,12 +443,12 @@ clearWatches :: Transaction ()
|
||||
clearWatches = Q.clearWatches
|
||||
|
||||
c2wTerm :: C.Term Symbol -> Transaction (WatchLocalIds, S.Term.Term)
|
||||
c2wTerm tm = c2xTerm Q.saveText Q.saveHashHash tm Nothing <&> \(w, tm, _) -> (w, tm)
|
||||
c2wTerm tm = Q.c2xTerm Q.saveText Q.saveHashHash tm Nothing <&> \(w, tm, _) -> (w, tm)
|
||||
|
||||
w2cTerm :: WatchLocalIds -> S.Term.Term -> Transaction (C.Term Symbol)
|
||||
w2cTerm ids tm = do
|
||||
(substText, substHash) <- localIdsToLookups Q.expectText Q.expectHash ids
|
||||
pure $ x2cTerm substText substHash tm
|
||||
(substText, substHash) <- Q.localIdsToLookups Q.expectText Q.expectHash ids
|
||||
pure $ Q.x2cTerm substText substHash tm
|
||||
|
||||
-- ** Saving & loading type decls
|
||||
|
||||
@ -702,80 +456,14 @@ loadDeclComponent :: H.Hash -> MaybeT Transaction [C.Decl Symbol]
|
||||
loadDeclComponent h = do
|
||||
oid <- MaybeT (Q.loadObjectIdForAnyHash h)
|
||||
S.Decl.Decl (S.Decl.LocallyIndexedComponent elements) <- MaybeT (Q.loadDeclObject oid decodeDeclFormat)
|
||||
lift . traverse (uncurry s2cDecl) $ Foldable.toList elements
|
||||
|
||||
saveDeclComponent :: H.Hash -> [C.Decl Symbol] -> Transaction Db.ObjectId
|
||||
saveDeclComponent h decls = do
|
||||
when debug . traceM $ "Operations.saveDeclComponent " ++ show h
|
||||
sDeclElements <- traverse (c2sDecl Q.saveText Q.expectObjectIdForPrimaryHash) decls
|
||||
hashId <- Q.saveHashHash h
|
||||
let li = S.Decl.LocallyIndexedComponent $ Vector.fromList sDeclElements
|
||||
bytes = S.putBytes S.putDeclFormat $ S.Decl.Decl li
|
||||
oId <- Q.saveObject hashId OT.DeclComponent bytes
|
||||
-- populate dependents index
|
||||
let dependencies :: Set (S.Reference.Reference, S.Reference.Id) = foldMap unlocalizeRefs (sDeclElements `zip` [0 ..])
|
||||
unlocalizeRefs :: ((LocalIds, S.Decl.Decl Symbol), C.Reference.Pos) -> Set (S.Reference.Reference, S.Reference.Id)
|
||||
unlocalizeRefs ((LocalIds tIds oIds, decl), i) =
|
||||
let self = C.Reference.Id oId i
|
||||
dependencies :: Set S.Decl.TypeRef = C.Decl.dependencies decl
|
||||
getSRef :: C.Reference.Reference' LocalTextId (Maybe LocalDefnId) -> S.Reference.Reference
|
||||
getSRef = \case
|
||||
C.ReferenceBuiltin t -> C.ReferenceBuiltin (tIds Vector.! fromIntegral t)
|
||||
C.Reference.Derived Nothing i -> C.Reference.Derived oId i -- index self-references
|
||||
C.Reference.Derived (Just h) i -> C.Reference.Derived (oIds Vector.! fromIntegral h) i
|
||||
in Set.map ((,self) . getSRef) dependencies
|
||||
traverse_ (uncurry Q.addToDependentsIndex) dependencies
|
||||
|
||||
pure oId
|
||||
|
||||
c2sDecl ::
|
||||
forall m t d.
|
||||
Monad m =>
|
||||
(Text -> m t) ->
|
||||
(H.Hash -> m d) ->
|
||||
C.Decl Symbol ->
|
||||
m (LocalIds' t d, S.Decl.Decl Symbol)
|
||||
c2sDecl saveText saveDefn (C.Decl.DataDeclaration dt m b cts) = do
|
||||
done =<< (runWriterT . flip evalStateT mempty) do
|
||||
cts' <- traverse (ABT.transformM goType) cts
|
||||
pure (C.Decl.DataDeclaration dt m b cts')
|
||||
where
|
||||
goType ::
|
||||
forall m a.
|
||||
(MonadWriter (Seq Text, Seq H.Hash) m, MonadState (Map Text LocalTextId, Map H.Hash LocalDefnId) m) =>
|
||||
C.Type.FD a ->
|
||||
m (S.Decl.F a)
|
||||
goType = \case
|
||||
C.Type.Ref r -> C.Type.Ref <$> bitraverse lookupText (traverse lookupDefn) r
|
||||
C.Type.Arrow i o -> pure $ C.Type.Arrow i o
|
||||
C.Type.Ann a k -> pure $ C.Type.Ann a k
|
||||
C.Type.App f a -> pure $ C.Type.App f a
|
||||
C.Type.Effect e a -> pure $ C.Type.Effect e a
|
||||
C.Type.Effects es -> pure $ C.Type.Effects es
|
||||
C.Type.Forall a -> pure $ C.Type.Forall a
|
||||
C.Type.IntroOuter a -> pure $ C.Type.IntroOuter a
|
||||
done :: (S.Decl.Decl Symbol, (Seq Text, Seq H.Hash)) -> m (LocalIds' t d, S.Decl.Decl Symbol)
|
||||
done (decl, (localTextValues, localDefnValues)) = do
|
||||
textIds <- traverse saveText localTextValues
|
||||
defnIds <- traverse saveDefn localDefnValues
|
||||
let ids =
|
||||
LocalIds
|
||||
(Vector.fromList (Foldable.toList textIds))
|
||||
(Vector.fromList (Foldable.toList defnIds))
|
||||
pure (ids, decl)
|
||||
|
||||
-- | Unlocalize a decl.
|
||||
s2cDecl :: LocalIds -> S.Decl.Decl Symbol -> Transaction (C.Decl Symbol)
|
||||
s2cDecl ids (C.Decl.DataDeclaration dt m b ct) = do
|
||||
substTypeRef <- localIdsToTypeRefLookup ids
|
||||
pure (C.Decl.DataDeclaration dt m b (C.Type.rmap substTypeRef <$> ct))
|
||||
lift . traverse (uncurry Q.s2cDecl) $ Foldable.toList elements
|
||||
|
||||
loadDeclByReference :: C.Reference.Id -> MaybeT Transaction (C.Decl Symbol)
|
||||
loadDeclByReference r@(C.Reference.Id h i) = do
|
||||
when debug . traceM $ "loadDeclByReference " ++ show r
|
||||
oid <- MaybeT (Q.loadObjectIdForPrimaryHash h)
|
||||
(localIds, decl) <- MaybeT (Q.loadDeclObject oid (decodeDeclElement i))
|
||||
lift (s2cDecl localIds decl)
|
||||
lift (Q.s2cDecl localIds decl)
|
||||
|
||||
expectDeclByReference :: C.Reference.Id -> Transaction (C.Decl Symbol)
|
||||
expectDeclByReference r@(C.Reference.Id h i) = do
|
||||
@ -783,7 +471,7 @@ expectDeclByReference r@(C.Reference.Id h i) = do
|
||||
-- retrieve the blob
|
||||
Q.expectObjectIdForPrimaryHash h
|
||||
>>= (\oid -> Q.expectDeclObject oid (decodeDeclElement i))
|
||||
>>= uncurry s2cDecl
|
||||
>>= uncurry Q.s2cDecl
|
||||
|
||||
-- * Branch transformation
|
||||
|
||||
@ -877,10 +565,13 @@ s2cBranch (S.Branch.Full.Branch tms tps patches children) =
|
||||
boId <- Q.expectBranchObjectIdByCausalHashId chId
|
||||
expectBranch boId
|
||||
|
||||
saveRootBranch :: C.Branch.CausalBranch Transaction -> Transaction (Db.BranchObjectId, Db.CausalHashId)
|
||||
saveRootBranch c = do
|
||||
saveRootBranch ::
|
||||
HashHandle ->
|
||||
C.Branch.CausalBranch Transaction ->
|
||||
Transaction (Db.BranchObjectId, Db.CausalHashId)
|
||||
saveRootBranch hh c = do
|
||||
when debug $ traceM $ "Operations.saveRootBranch " ++ show (C.causalHash c)
|
||||
(boId, chId) <- saveBranch c
|
||||
(boId, chId) <- saveBranch hh c
|
||||
Q.setNamespaceRoot chId
|
||||
pure (boId, chId)
|
||||
|
||||
@ -923,8 +614,11 @@ saveRootBranch c = do
|
||||
-- References, but also values
|
||||
-- Shallow - Hash? representation of the database relationships
|
||||
|
||||
saveBranch :: C.Branch.CausalBranch Transaction -> Transaction (Db.BranchObjectId, Db.CausalHashId)
|
||||
saveBranch (C.Causal hc he parents me) = do
|
||||
saveBranch ::
|
||||
HashHandle ->
|
||||
C.Branch.CausalBranch Transaction ->
|
||||
Transaction (Db.BranchObjectId, Db.CausalHashId)
|
||||
saveBranch hh (C.Causal hc he parents me) = do
|
||||
when debug $ traceM $ "\nOperations.saveBranch \n hc = " ++ show hc ++ ",\n he = " ++ show he ++ ",\n parents = " ++ show (Map.keys parents)
|
||||
|
||||
(chId, bhId) <- flip Monad.fromMaybeM (Q.loadCausalByCausalHash hc) do
|
||||
@ -939,14 +633,14 @@ saveBranch (C.Causal hc he parents me) = do
|
||||
-- by checking if there are causal parents associated with hc
|
||||
(flip Monad.fromMaybeM)
|
||||
(Q.loadCausalHashIdByCausalHash parentHash)
|
||||
(mcausal >>= fmap snd . saveBranch)
|
||||
(mcausal >>= fmap snd . saveBranch hh)
|
||||
|
||||
-- Save these CausalHashIds to the causal_parents table,
|
||||
Q.saveCausal chId bhId parentCausalHashIds
|
||||
Q.saveCausal hh chId bhId parentCausalHashIds
|
||||
pure (chId, bhId)
|
||||
boId <- flip Monad.fromMaybeM (Q.loadBranchObjectIdByCausalHashId chId) do
|
||||
branch <- c2sBranch =<< me
|
||||
saveDbBranchUnderHashId bhId branch
|
||||
saveDbBranchUnderHashId hh bhId branch
|
||||
pure (boId, chId)
|
||||
where
|
||||
c2sBranch :: C.Branch.Branch Transaction -> Transaction S.DbBranch
|
||||
@ -955,7 +649,7 @@ saveBranch (C.Causal hc he parents me) = do
|
||||
<$> Map.bitraverse saveNameSegment (Map.bitraverse c2sReferent c2sMetadata) terms
|
||||
<*> Map.bitraverse saveNameSegment (Map.bitraverse c2sReference c2sMetadata) types
|
||||
<*> Map.bitraverse saveNameSegment savePatchObjectId patches
|
||||
<*> Map.bitraverse saveNameSegment saveBranch children
|
||||
<*> Map.bitraverse saveNameSegment (saveBranch hh) children
|
||||
|
||||
saveNameSegment :: C.Branch.NameSegment -> Transaction Db.TextId
|
||||
saveNameSegment = Q.saveText . C.Branch.unNameSegment
|
||||
@ -971,7 +665,7 @@ saveBranch (C.Causal hc he parents me) = do
|
||||
Just patchOID -> pure patchOID
|
||||
Nothing -> do
|
||||
patch <- mp
|
||||
savePatch h patch
|
||||
savePatch hh h patch
|
||||
|
||||
expectRootCausal :: Transaction (C.Branch.CausalBranch Transaction)
|
||||
expectRootCausal = Q.expectNamespaceRoot >>= expectCausalBranchByCausalHashId
|
||||
@ -1125,14 +819,22 @@ expectDbBranch id =
|
||||
--
|
||||
-- Note: long-standing question: should this package depend on the hashing package? (If so, we would only need to take
|
||||
-- the DbBranch, and hash internally).
|
||||
saveDbBranch :: BranchHash -> S.DbBranch -> Transaction Db.BranchObjectId
|
||||
saveDbBranch hash branch = do
|
||||
saveDbBranch ::
|
||||
HashHandle ->
|
||||
BranchHash ->
|
||||
S.DbBranch ->
|
||||
Transaction Db.BranchObjectId
|
||||
saveDbBranch hh hash branch = do
|
||||
hashId <- Q.saveBranchHash hash
|
||||
saveDbBranchUnderHashId hashId branch
|
||||
saveDbBranchUnderHashId hh hashId branch
|
||||
|
||||
-- | Variant of 'saveDbBranch' that might be preferred by callers that already have a hash id, not a hash.
|
||||
saveDbBranchUnderHashId :: Db.BranchHashId -> S.DbBranch -> Transaction Db.BranchObjectId
|
||||
saveDbBranchUnderHashId id@(Db.unBranchHashId -> hashId) branch = do
|
||||
saveDbBranchUnderHashId ::
|
||||
HashHandle ->
|
||||
Db.BranchHashId ->
|
||||
S.DbBranch ->
|
||||
Transaction Db.BranchObjectId
|
||||
saveDbBranchUnderHashId hh id@(Db.unBranchHashId -> hashId) branch = do
|
||||
let (localBranchIds, localBranch) = LocalizeObject.localizeBranch branch
|
||||
when debug $
|
||||
traceM $
|
||||
@ -1140,7 +842,7 @@ saveDbBranchUnderHashId id@(Db.unBranchHashId -> hashId) branch = do
|
||||
++ "\n\tlBranch = "
|
||||
++ show localBranch
|
||||
let bytes = S.putBytes S.putBranchFormat $ S.BranchFormat.Full localBranchIds localBranch
|
||||
oId <- Q.saveObject hashId OT.Namespace bytes
|
||||
oId <- Q.saveObject hh hashId ObjectType.Namespace bytes
|
||||
pure $ Db.BranchObjectId oId
|
||||
|
||||
expectBranch :: Db.BranchObjectId -> Transaction (C.Branch.Branch Transaction)
|
||||
@ -1165,16 +867,24 @@ expectDbPatch patchId =
|
||||
S.Patch.Format.Full li f -> pure (S.Patch.Format.applyPatchDiffs (S.Patch.Format.localPatchToPatch li f) ds)
|
||||
S.Patch.Format.Diff ref' li' d' -> doDiff ref' (S.Patch.Format.localPatchDiffToPatchDiff li' d' : ds)
|
||||
|
||||
savePatch :: PatchHash -> C.Branch.Patch -> Transaction Db.PatchObjectId
|
||||
savePatch h c = do
|
||||
savePatch ::
|
||||
HashHandle ->
|
||||
PatchHash ->
|
||||
C.Branch.Patch ->
|
||||
Transaction Db.PatchObjectId
|
||||
savePatch hh h c = do
|
||||
(li, lPatch) <- LocalizeObject.localizePatch <$> c2sPatch c
|
||||
saveDbPatch h (S.Patch.Format.Full li lPatch)
|
||||
saveDbPatch hh h (S.Patch.Format.Full li lPatch)
|
||||
|
||||
saveDbPatch :: PatchHash -> S.PatchFormat -> Transaction Db.PatchObjectId
|
||||
saveDbPatch hash patch = do
|
||||
saveDbPatch ::
|
||||
HashHandle ->
|
||||
PatchHash ->
|
||||
S.PatchFormat ->
|
||||
Transaction Db.PatchObjectId
|
||||
saveDbPatch hh hash patch = do
|
||||
hashId <- Q.saveHashHash (unPatchHash hash)
|
||||
let bytes = S.putBytes S.putPatchFormat patch
|
||||
Db.PatchObjectId <$> Q.saveObject hashId OT.Patch bytes
|
||||
Db.PatchObjectId <$> Q.saveObject hh hashId ObjectType.Patch bytes
|
||||
|
||||
s2cPatch :: S.Patch -> Transaction C.Branch.Patch
|
||||
s2cPatch (S.Patch termEdits typeEdits) =
|
||||
@ -1224,19 +934,10 @@ termsMentioningType cTypeRef =
|
||||
set <- traverse s2cReferentId sIds
|
||||
pure (Set.fromList set)
|
||||
|
||||
addTypeToIndexForTerm :: S.Referent.Id -> C.Reference -> Transaction ()
|
||||
addTypeToIndexForTerm sTermId cTypeRef = do
|
||||
sTypeRef <- saveReferenceH cTypeRef
|
||||
Q.addToTypeIndex sTypeRef sTermId
|
||||
|
||||
addTypeMentionsToIndexForTerm :: S.Referent.Id -> Set C.Reference -> Transaction ()
|
||||
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
|
||||
componentReferencesByPrefix :: OT.ObjectType -> Text -> Maybe C.Reference.Pos -> Transaction [S.Reference.Id]
|
||||
componentReferencesByPrefix :: ObjectType.ObjectType -> Text -> Maybe C.Reference.Pos -> Transaction [S.Reference.Id]
|
||||
componentReferencesByPrefix ot b32prefix pos = do
|
||||
oIds :: [Db.ObjectId] <- Q.objectIdByBase32Prefix ot b32prefix
|
||||
let test = maybe (const True) (==) pos
|
||||
@ -1245,12 +946,12 @@ componentReferencesByPrefix ot b32prefix pos = do
|
||||
|
||||
termReferencesByPrefix :: Text -> Maybe Word64 -> Transaction [C.Reference.Id]
|
||||
termReferencesByPrefix t w =
|
||||
componentReferencesByPrefix OT.TermComponent t w
|
||||
componentReferencesByPrefix ObjectType.TermComponent t w
|
||||
>>= traverse (C.Reference.idH Q.expectPrimaryHashByObjectId)
|
||||
|
||||
declReferencesByPrefix :: Text -> Maybe Word64 -> Transaction [C.Reference.Id]
|
||||
declReferencesByPrefix t w =
|
||||
componentReferencesByPrefix OT.DeclComponent t w
|
||||
componentReferencesByPrefix ObjectType.DeclComponent t w
|
||||
>>= traverse (C.Reference.idH Q.expectPrimaryHashByObjectId)
|
||||
|
||||
termReferentsByPrefix :: Text -> Maybe Word64 -> Transaction [C.Referent.Id]
|
||||
@ -1265,7 +966,7 @@ declReferentsByPrefix ::
|
||||
Maybe ConstructorId ->
|
||||
Transaction [(H.Hash, C.Reference.Pos, C.DeclType, [C.Decl.ConstructorId])]
|
||||
declReferentsByPrefix b32prefix pos cid = do
|
||||
componentReferencesByPrefix OT.DeclComponent b32prefix pos
|
||||
componentReferencesByPrefix ObjectType.DeclComponent b32prefix pos
|
||||
>>= traverse (loadConstructors cid)
|
||||
where
|
||||
loadConstructors ::
|
||||
|
||||
@ -1,3 +1,5 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
-- | Some naming conventions used in this module:
|
||||
--
|
||||
-- * @32@: the base32 representation of a hash
|
||||
@ -142,35 +144,60 @@ module U.Codebase.Sqlite.Queries
|
||||
syncToTempEntity,
|
||||
insertTempEntity,
|
||||
saveTempEntityInMain,
|
||||
expectTempEntity,
|
||||
deleteTempEntity,
|
||||
|
||||
-- * elaborate hashes
|
||||
elaborateHashes,
|
||||
|
||||
-- * db misc
|
||||
createSchema,
|
||||
addTempEntityTables,
|
||||
schemaVersion,
|
||||
addTypeMentionsToIndexForTerm,
|
||||
addTypeToIndexForTerm,
|
||||
c2xTerm,
|
||||
createSchema,
|
||||
expectSchemaVersion,
|
||||
localIdsToLookups,
|
||||
s2cDecl,
|
||||
s2cTermWithType,
|
||||
saveDeclComponent,
|
||||
saveReferenceH,
|
||||
saveSyncEntity,
|
||||
saveTermComponent,
|
||||
schemaVersion,
|
||||
setSchemaVersion,
|
||||
x2cTType,
|
||||
x2cTerm,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Lens (Lens')
|
||||
import qualified Control.Lens as Lens
|
||||
import Control.Monad.Extra ((||^))
|
||||
import Control.Monad.State (MonadState, evalStateT)
|
||||
import Control.Monad.Writer (MonadWriter, runWriterT)
|
||||
import qualified Control.Monad.Writer as Writer
|
||||
import Data.Bifunctor (Bifunctor (bimap))
|
||||
import Data.Bitraversable (bitraverse)
|
||||
import Data.Bytes.Put (runPutS)
|
||||
import qualified Data.Foldable as Foldable
|
||||
import qualified Data.List.Extra as List
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.List.NonEmpty as Nel
|
||||
import qualified Data.Map as Map
|
||||
import Data.Map.NonEmpty (NEMap)
|
||||
import qualified Data.Map.NonEmpty as NEMap
|
||||
import qualified Data.Sequence as Seq
|
||||
import qualified Data.Set as Set
|
||||
import Data.String.Here.Uninterpolated (here, hereFile)
|
||||
import qualified Data.Vector as Vector
|
||||
import qualified U.Codebase.Decl as C
|
||||
import qualified U.Codebase.Decl as C.Decl
|
||||
import U.Codebase.HashTags (BranchHash (..), CausalHash (..), PatchHash (..))
|
||||
import U.Codebase.Reference (Reference' (..))
|
||||
import qualified U.Codebase.Reference as C
|
||||
import qualified U.Codebase.Reference as C.Reference
|
||||
import qualified U.Codebase.Referent as C.Referent
|
||||
import qualified U.Codebase.Sqlite.Branch.Format as NamespaceFormat
|
||||
import qualified U.Codebase.Sqlite.Causal as Causal
|
||||
import qualified U.Codebase.Sqlite.Causal as Sqlite.Causal
|
||||
@ -186,9 +213,17 @@ import U.Codebase.Sqlite.DbId
|
||||
TextId,
|
||||
)
|
||||
import qualified U.Codebase.Sqlite.Decl.Format as DeclFormat
|
||||
import qualified U.Codebase.Sqlite.Decl.Format as S.Decl
|
||||
import U.Codebase.Sqlite.Decode
|
||||
import U.Codebase.Sqlite.Entity (SyncEntity)
|
||||
import qualified U.Codebase.Sqlite.Entity as Entity
|
||||
import U.Codebase.Sqlite.HashHandle (HashHandle (..))
|
||||
import U.Codebase.Sqlite.LocalIds
|
||||
( LocalDefnId (..),
|
||||
LocalIds,
|
||||
LocalIds' (..),
|
||||
LocalTextId (..),
|
||||
)
|
||||
import qualified U.Codebase.Sqlite.LocalIds as LocalIds
|
||||
import qualified U.Codebase.Sqlite.NamedRef as S
|
||||
import U.Codebase.Sqlite.ObjectType (ObjectType (DeclComponent, Namespace, Patch, TermComponent))
|
||||
@ -196,20 +231,32 @@ import qualified U.Codebase.Sqlite.ObjectType as ObjectType
|
||||
import U.Codebase.Sqlite.Orphans ()
|
||||
import qualified U.Codebase.Sqlite.Patch.Format as PatchFormat
|
||||
import qualified U.Codebase.Sqlite.Reference as Reference
|
||||
import qualified U.Codebase.Sqlite.Reference as S
|
||||
import qualified U.Codebase.Sqlite.Reference as S.Reference
|
||||
import qualified U.Codebase.Sqlite.Referent as Referent
|
||||
import qualified U.Codebase.Sqlite.Referent as S.Referent
|
||||
import U.Codebase.Sqlite.Serialization as Serialization
|
||||
import U.Codebase.Sqlite.Symbol (Symbol)
|
||||
import U.Codebase.Sqlite.TempEntity (TempEntity)
|
||||
import qualified U.Codebase.Sqlite.TempEntity as TempEntity
|
||||
import U.Codebase.Sqlite.TempEntityType (TempEntityType)
|
||||
import qualified U.Codebase.Sqlite.TempEntityType as TempEntityType
|
||||
import qualified U.Codebase.Sqlite.Term.Format as S.Term
|
||||
import qualified U.Codebase.Sqlite.Term.Format as TermFormat
|
||||
import qualified U.Codebase.Term as C
|
||||
import qualified U.Codebase.Term as C.Term
|
||||
import qualified U.Codebase.Type as C.Type
|
||||
import U.Codebase.WatchKind (WatchKind)
|
||||
import qualified U.Core.ABT as ABT
|
||||
import qualified U.Util.Alternative as Alternative
|
||||
import U.Util.Hash (Hash)
|
||||
import qualified U.Util.Hash as Hash
|
||||
import U.Util.Hash32 (Hash32)
|
||||
import qualified U.Util.Hash32 as Hash32
|
||||
import U.Util.Hash32.Orphans.Sqlite ()
|
||||
import qualified U.Util.Lens as Lens
|
||||
import qualified U.Util.Serialization as S
|
||||
import qualified U.Util.Term as TermUtil
|
||||
import Unison.Prelude
|
||||
import Unison.Sqlite
|
||||
|
||||
@ -383,15 +430,20 @@ saveHashObject hId oId version = execute sql (hId, oId, version) where
|
||||
ON CONFLICT DO NOTHING
|
||||
|]
|
||||
|
||||
saveObject :: HashId -> ObjectType -> ByteString -> Transaction ObjectId
|
||||
saveObject h t blob = do
|
||||
saveObject ::
|
||||
HashHandle ->
|
||||
HashId ->
|
||||
ObjectType ->
|
||||
ByteString ->
|
||||
Transaction ObjectId
|
||||
saveObject hh h t blob = do
|
||||
oId <- execute sql (h, t, blob) >> expectObjectIdForPrimaryHashId h
|
||||
saveHashObject h oId 2 -- todo: remove this from here, and add it to other relevant places once there are v1 and v2 hashes
|
||||
rowsModified >>= \case
|
||||
0 -> pure ()
|
||||
_ -> do
|
||||
hash <- expectHash32 h
|
||||
tryMoveTempEntityDependents hash
|
||||
tryMoveTempEntityDependents hh hash
|
||||
pure oId
|
||||
where
|
||||
sql = [here|
|
||||
@ -629,14 +681,19 @@ recordObjectRehash old new =
|
||||
|
||||
-- |Maybe we would generalize this to something other than NamespaceHash if we
|
||||
-- end up wanting to store other kinds of Causals here too.
|
||||
saveCausal :: CausalHashId -> BranchHashId -> [CausalHashId] -> Transaction ()
|
||||
saveCausal self value parents = do
|
||||
saveCausal ::
|
||||
HashHandle ->
|
||||
CausalHashId ->
|
||||
BranchHashId ->
|
||||
[CausalHashId] ->
|
||||
Transaction ()
|
||||
saveCausal hh self value parents = do
|
||||
execute insertCausalSql (self, value)
|
||||
rowsModified >>= \case
|
||||
0 -> pure ()
|
||||
_ -> do
|
||||
executeMany insertCausalParentsSql (fmap (self,) parents)
|
||||
flushCausalDependents self
|
||||
flushCausalDependents hh self
|
||||
where
|
||||
insertCausalSql = [here|
|
||||
INSERT INTO causal (self_hash_id, value_hash_id)
|
||||
@ -647,10 +704,13 @@ saveCausal self value parents = do
|
||||
INSERT INTO causal_parent (causal_id, parent_id) VALUES (?, ?)
|
||||
|]
|
||||
|
||||
flushCausalDependents :: CausalHashId -> Transaction ()
|
||||
flushCausalDependents chId = do
|
||||
flushCausalDependents ::
|
||||
HashHandle ->
|
||||
CausalHashId ->
|
||||
Transaction ()
|
||||
flushCausalDependents hh chId = do
|
||||
hash <- expectHash32 (unCausalHashId chId)
|
||||
tryMoveTempEntityDependents hash
|
||||
tryMoveTempEntityDependents hh hash
|
||||
|
||||
-- | `tryMoveTempEntityDependents #foo` does this:
|
||||
-- 0. Precondition: We just inserted object #foo.
|
||||
@ -658,8 +718,12 @@ flushCausalDependents chId = do
|
||||
-- 2. Delete #foo as dependency from temp_entity_missing_dependency. e.g. (#bar, #foo), (#baz, #foo)
|
||||
-- 3. For each like #bar and #baz with no more rows in temp_entity_missing_dependency,
|
||||
-- insert_entity them.
|
||||
tryMoveTempEntityDependents :: Hash32 -> Transaction ()
|
||||
tryMoveTempEntityDependents dependency = do
|
||||
tryMoveTempEntityDependents ::
|
||||
-- | Move TempEntity to main
|
||||
HashHandle ->
|
||||
Hash32 ->
|
||||
Transaction ()
|
||||
tryMoveTempEntityDependents hh dependency = do
|
||||
dependents <-
|
||||
queryListCol
|
||||
[here|
|
||||
@ -673,7 +737,7 @@ tryMoveTempEntityDependents dependency = do
|
||||
flushIfReadyToFlush :: Hash32 -> Transaction ()
|
||||
flushIfReadyToFlush dependent = do
|
||||
readyToFlush dependent >>= \case
|
||||
True -> moveTempEntityToMain dependent
|
||||
True -> moveTempEntityToMain hh dependent
|
||||
False -> pure ()
|
||||
|
||||
readyToFlush :: Hash32 -> Transaction Bool
|
||||
@ -726,21 +790,6 @@ expectEntity hash = do
|
||||
Namespace -> Entity.N <$> decodeSyncNamespaceFormat bytes
|
||||
Patch -> Entity.P <$> decodeSyncPatchFormat bytes
|
||||
|
||||
moveTempEntityToMain :: Hash32 -> Transaction ()
|
||||
moveTempEntityToMain hash = do
|
||||
entity <- expectTempEntity hash
|
||||
deleteTempEntity hash
|
||||
_ <- saveTempEntityInMain hash entity
|
||||
pure ()
|
||||
|
||||
-- | Save a temp entity in main storage.
|
||||
--
|
||||
-- Precondition: all of its dependencies are already in main storage.
|
||||
saveTempEntityInMain :: Hash32 -> TempEntity -> Transaction (Either CausalHashId ObjectId)
|
||||
saveTempEntityInMain hash entity = do
|
||||
entity' <- tempToSyncEntity entity
|
||||
saveSyncEntity hash entity'
|
||||
|
||||
-- | Read an entity out of temp storage.
|
||||
expectTempEntity :: Hash32 -> Transaction TempEntity
|
||||
expectTempEntity hash = do
|
||||
@ -907,28 +956,6 @@ syncToTempEntity = \case
|
||||
TermFormat.SyncTerm . TermFormat.SyncLocallyIndexedComponent
|
||||
<$> Lens.traverseOf (traverse . Lens._1) (bitraverse expectText expectPrimaryHash32ByObjectId) terms
|
||||
|
||||
saveSyncEntity :: Hash32 -> SyncEntity -> Transaction (Either CausalHashId ObjectId)
|
||||
saveSyncEntity hash entity = do
|
||||
hashId <- saveHash hash
|
||||
case entity of
|
||||
Entity.TC stf -> do
|
||||
let bytes = runPutS (Serialization.recomposeTermFormat stf)
|
||||
Right <$> saveObject hashId ObjectType.TermComponent bytes
|
||||
Entity.DC sdf -> do
|
||||
let bytes = runPutS (Serialization.recomposeDeclFormat sdf)
|
||||
Right <$> saveObject hashId ObjectType.DeclComponent bytes
|
||||
Entity.N sbf -> do
|
||||
let bytes = runPutS (Serialization.recomposeBranchFormat sbf)
|
||||
Right <$> saveObject hashId ObjectType.Namespace bytes
|
||||
Entity.P spf -> do
|
||||
let bytes = runPutS (Serialization.recomposePatchFormat spf)
|
||||
Right <$> saveObject hashId ObjectType.Patch bytes
|
||||
Entity.C scf -> case scf of
|
||||
Sqlite.Causal.SyncCausalFormat{valueHash, parents} -> do
|
||||
let causalHashId = CausalHashId hashId
|
||||
saveCausal causalHashId valueHash (Foldable.toList parents)
|
||||
pure $ Left causalHashId
|
||||
|
||||
-- -- maybe: look at whether parent causal is "committed"; if so, then increment;
|
||||
-- -- otherwise, don't.
|
||||
-- getNurseryGeneration :: DB m => m Generation
|
||||
@ -1624,3 +1651,407 @@ elaborateHashes hashes = do
|
||||
)
|
||||
execute_ [here|DROP TABLE new_temp_entity_dependents|]
|
||||
pure result
|
||||
|
||||
moveTempEntityToMain ::
|
||||
HashHandle ->
|
||||
Hash32 ->
|
||||
Transaction ()
|
||||
moveTempEntityToMain hh hash = do
|
||||
entity <- expectTempEntity hash
|
||||
deleteTempEntity hash
|
||||
_ <- saveTempEntityInMain hh hash entity
|
||||
pure ()
|
||||
|
||||
-- | Save a temp entity in main storage.
|
||||
--
|
||||
-- Precondition: all of its dependencies are already in main storage.
|
||||
saveTempEntityInMain :: HashHandle -> Hash32 -> TempEntity -> Transaction (Either CausalHashId ObjectId)
|
||||
saveTempEntityInMain hh hash entity = do
|
||||
entity' <- tempToSyncEntity entity
|
||||
saveSyncEntity hh hash entity'
|
||||
|
||||
saveSyncEntity ::
|
||||
HashHandle ->
|
||||
Hash32 ->
|
||||
SyncEntity ->
|
||||
Transaction (Either CausalHashId ObjectId)
|
||||
saveSyncEntity hh hash entity = do
|
||||
case entity of
|
||||
Entity.TC stf -> do
|
||||
lic :: TermFormat.LocallyIndexedComponent <- do
|
||||
let TermFormat.SyncTerm x = stf
|
||||
unsafeIO (unsyncTermComponent x)
|
||||
|
||||
tc :: [(C.Term Symbol, C.Term.Type Symbol)] <-
|
||||
traverse
|
||||
(\(a, b, c) -> s2cTermWithType a b c)
|
||||
(toList $ TermFormat.unLocallyIndexedComponent lic)
|
||||
let bytes = runPutS (Serialization.recomposeTermFormat stf)
|
||||
objId <- saveTermComponent hh (Just bytes) (Hash32.toHash hash) tc
|
||||
pure (Right objId)
|
||||
Entity.DC sdf -> do
|
||||
lic :: S.Decl.LocallyIndexedComponent <- do
|
||||
let S.Decl.SyncDecl xs = sdf
|
||||
unsafeIO (unsyncDeclComponent xs)
|
||||
|
||||
dc :: [C.Decl.Decl Symbol] <-
|
||||
traverse
|
||||
(\(localIds, decl) -> s2cDecl localIds decl)
|
||||
(toList $ S.Decl.unLocallyIndexedComponent lic)
|
||||
|
||||
let bytes = runPutS (Serialization.recomposeDeclFormat sdf)
|
||||
objId <- saveDeclComponent hh (Just bytes) (Hash32.toHash hash) dc
|
||||
|
||||
pure (Right objId)
|
||||
Entity.N sbf -> do
|
||||
hashId <- saveHash hash
|
||||
let bytes = runPutS (Serialization.recomposeBranchFormat sbf)
|
||||
Right <$> saveObject hh hashId ObjectType.Namespace bytes
|
||||
Entity.P spf -> do
|
||||
hashId <- saveHash hash
|
||||
let bytes = runPutS (Serialization.recomposePatchFormat spf)
|
||||
Right <$> saveObject hh hashId ObjectType.Patch bytes
|
||||
Entity.C scf -> case scf of
|
||||
Sqlite.Causal.SyncCausalFormat {valueHash, parents} -> do
|
||||
hashId <- saveHash hash
|
||||
let causalHashId = CausalHashId hashId
|
||||
saveCausal hh causalHashId valueHash (toList parents)
|
||||
pure $ Left causalHashId
|
||||
|
||||
s2cTermWithType :: LocalIds.LocalIds -> S.Term.Term -> S.Term.Type -> Transaction (C.Term Symbol, C.Term.Type Symbol)
|
||||
s2cTermWithType ids tm tp = do
|
||||
(substText, substHash) <- localIdsToLookups expectText expectPrimaryHashByObjectId ids
|
||||
pure (x2cTerm substText substHash tm, x2cTType substText substHash tp)
|
||||
|
||||
saveTermComponent ::
|
||||
HashHandle ->
|
||||
-- | The serialized term component if we already have it e.g. via sync
|
||||
Maybe ByteString ->
|
||||
-- | term component hash
|
||||
Hash ->
|
||||
-- | term component
|
||||
[(C.Term Symbol, C.Term.Type Symbol)] ->
|
||||
Transaction ObjectId
|
||||
saveTermComponent hh@HashHandle {..} maybeEncodedTerms h terms = do
|
||||
when debug . traceM $ "Operations.saveTermComponent " ++ show h
|
||||
sTermElements <- traverse (uncurry c2sTerm) terms
|
||||
hashId <- saveHashHash h
|
||||
let bytes = fromMaybe mkByteString maybeEncodedTerms
|
||||
mkByteString =
|
||||
let li = S.Term.LocallyIndexedComponent $ Vector.fromList sTermElements
|
||||
in S.putBytes Serialization.putTermFormat $ S.Term.Term li
|
||||
oId <- saveObject hh hashId ObjectType.TermComponent bytes
|
||||
-- populate dependents index
|
||||
let dependencies :: Set (S.Reference.Reference, S.Reference.Id) = foldMap unlocalizeRefs (sTermElements `zip` [0 ..])
|
||||
unlocalizeRefs :: ((LocalIds, S.Term.Term, S.Term.Type), C.Reference.Pos) -> Set (S.Reference.Reference, S.Reference.Id)
|
||||
unlocalizeRefs ((LocalIds tIds oIds, tm, tp), i) =
|
||||
let self = C.Reference.Id oId i
|
||||
dependencies :: Set S.Reference =
|
||||
let (tmRefs, tpRefs, tmLinks, tpLinks) = TermUtil.dependencies tm
|
||||
tpRefs' = Foldable.toList $ C.Type.dependencies tp
|
||||
getTermSRef :: S.Term.TermRef -> S.Reference
|
||||
getTermSRef = \case
|
||||
C.ReferenceBuiltin t -> C.ReferenceBuiltin (tIds Vector.! fromIntegral t)
|
||||
C.Reference.Derived Nothing i -> C.Reference.Derived oId i -- index self-references
|
||||
C.Reference.Derived (Just h) i -> C.Reference.Derived (oIds Vector.! fromIntegral h) i
|
||||
getTypeSRef :: S.Term.TypeRef -> S.Reference
|
||||
getTypeSRef = \case
|
||||
C.ReferenceBuiltin t -> C.ReferenceBuiltin (tIds Vector.! fromIntegral t)
|
||||
C.Reference.Derived h i -> C.Reference.Derived (oIds Vector.! fromIntegral h) i
|
||||
getSTypeLink = getTypeSRef
|
||||
getSTermLink :: S.Term.TermLink -> S.Reference
|
||||
getSTermLink = \case
|
||||
C.Referent.Con ref _conId -> getTypeSRef ref
|
||||
C.Referent.Ref ref -> getTermSRef ref
|
||||
in Set.fromList $
|
||||
map getTermSRef tmRefs
|
||||
++ map getSTermLink tmLinks
|
||||
++ map getTypeSRef (tpRefs ++ tpRefs')
|
||||
++ map getSTypeLink tpLinks
|
||||
in Set.map (,self) dependencies
|
||||
traverse_ (uncurry addToDependentsIndex) dependencies
|
||||
for_ ((snd <$> terms) `zip` [0 ..]) \(tp, i) -> do
|
||||
let self = C.Referent.RefId (C.Reference.Id oId i)
|
||||
typeForIndexing = toReference tp
|
||||
typeMentionsForIndexing = toReferenceMentions tp
|
||||
addTypeToIndexForTerm self typeForIndexing
|
||||
addTypeMentionsToIndexForTerm self typeMentionsForIndexing
|
||||
|
||||
pure oId
|
||||
|
||||
-- | Unlocalize a decl.
|
||||
s2cDecl :: LocalIds -> S.Decl.Decl Symbol -> Transaction (C.Decl Symbol)
|
||||
s2cDecl ids (C.Decl.DataDeclaration dt m b ct) = do
|
||||
substTypeRef <- localIdsToTypeRefLookup ids
|
||||
pure (C.Decl.DataDeclaration dt m b (C.Type.rmap substTypeRef <$> ct))
|
||||
|
||||
saveDeclComponent ::
|
||||
HashHandle ->
|
||||
Maybe ByteString ->
|
||||
Hash ->
|
||||
[C.Decl Symbol] ->
|
||||
Transaction ObjectId
|
||||
saveDeclComponent hh@HashHandle {..} maybeEncodedDecls h decls = do
|
||||
when debug . traceM $ "Operations.saveDeclComponent " ++ show h
|
||||
sDeclElements <- traverse (c2sDecl saveText expectObjectIdForPrimaryHash) decls
|
||||
hashId <- saveHashHash h
|
||||
let bytes = fromMaybe mkByteString maybeEncodedDecls
|
||||
mkByteString =
|
||||
let li = S.Decl.LocallyIndexedComponent $ Vector.fromList sDeclElements
|
||||
in S.putBytes Serialization.putDeclFormat $ S.Decl.Decl li
|
||||
oId <- saveObject hh hashId ObjectType.DeclComponent bytes
|
||||
-- populate dependents index
|
||||
let dependencies :: Set (S.Reference.Reference, S.Reference.Id) = foldMap unlocalizeRefs (sDeclElements `zip` [0 ..])
|
||||
unlocalizeRefs :: ((LocalIds, S.Decl.Decl Symbol), C.Reference.Pos) -> Set (S.Reference.Reference, S.Reference.Id)
|
||||
unlocalizeRefs ((LocalIds tIds oIds, decl), i) =
|
||||
let self = C.Reference.Id oId i
|
||||
dependencies :: Set S.Decl.TypeRef = C.Decl.dependencies decl
|
||||
getSRef :: C.Reference.Reference' LocalTextId (Maybe LocalDefnId) -> S.Reference.Reference
|
||||
getSRef = \case
|
||||
C.ReferenceBuiltin t -> C.ReferenceBuiltin (tIds Vector.! fromIntegral t)
|
||||
C.Reference.Derived Nothing i -> C.Reference.Derived oId i -- index self-references
|
||||
C.Reference.Derived (Just h) i -> C.Reference.Derived (oIds Vector.! fromIntegral h) i
|
||||
in Set.map ((,self) . getSRef) dependencies
|
||||
traverse_ (uncurry addToDependentsIndex) dependencies
|
||||
for_ ((fmap C.Decl.constructorTypes decls) `zip` [0 ..]) \(ctors, i) ->
|
||||
for_ (ctors `zip` [0 ..]) \(tp, j) -> do
|
||||
let self = C.Referent.ConId (C.Reference.Id oId i) j
|
||||
typeForIndexing = toReferenceDecl h tp
|
||||
typeMentionsForIndexing = toReferenceDeclMentions h tp
|
||||
addTypeToIndexForTerm self typeForIndexing
|
||||
addTypeMentionsToIndexForTerm self typeMentionsForIndexing
|
||||
|
||||
pure oId
|
||||
|
||||
-- | implementation detail of {s,w}2c*Term* & s2cDecl
|
||||
localIdsToLookups :: Monad m => (t -> m Text) -> (d -> m Hash) -> LocalIds' t d -> m (LocalTextId -> Text, LocalDefnId -> Hash)
|
||||
localIdsToLookups loadText loadHash localIds = do
|
||||
texts <- traverse loadText $ LocalIds.textLookup localIds
|
||||
hashes <- traverse loadHash $ LocalIds.defnLookup localIds
|
||||
let substText (LocalTextId w) = texts Vector.! fromIntegral w
|
||||
substHash (LocalDefnId w) = hashes Vector.! fromIntegral w
|
||||
pure (substText, substHash)
|
||||
|
||||
-- | implementation detail of {s,w}2c*Term*
|
||||
x2cTerm :: (LocalTextId -> Text) -> (LocalDefnId -> Hash) -> S.Term.Term -> C.Term Symbol
|
||||
x2cTerm substText substHash =
|
||||
-- substitute the text and hashes back into the term
|
||||
C.Term.extraMap substText substTermRef substTypeRef substTermLink substTypeLink id
|
||||
where
|
||||
substTermRef = bimap substText (fmap substHash)
|
||||
substTypeRef = bimap substText substHash
|
||||
substTermLink = bimap substTermRef substTypeRef
|
||||
substTypeLink = substTypeRef
|
||||
|
||||
-- | implementation detail of {s,w}2c*Term*
|
||||
x2cTType :: (LocalTextId -> Text) -> (LocalDefnId -> Hash) -> S.Term.Type -> C.Term.Type Symbol
|
||||
x2cTType substText substHash = C.Type.rmap (bimap substText substHash)
|
||||
|
||||
c2sTerm :: C.Term Symbol -> C.Term.Type Symbol -> Transaction (LocalIds, S.Term.Term, S.Term.Type)
|
||||
c2sTerm tm tp = c2xTerm saveText expectObjectIdForPrimaryHash tm (Just tp) <&> \(w, tm, Just tp) -> (w, tm, tp)
|
||||
|
||||
addTypeToIndexForTerm :: S.Referent.Id -> C.Reference -> Transaction ()
|
||||
addTypeToIndexForTerm sTermId cTypeRef = do
|
||||
sTypeRef <- saveReferenceH cTypeRef
|
||||
addToTypeIndex sTypeRef sTermId
|
||||
|
||||
addTypeMentionsToIndexForTerm :: S.Referent.Id -> Set C.Reference -> Transaction ()
|
||||
addTypeMentionsToIndexForTerm sTermId cTypeMentionRefs = do
|
||||
traverse_ (flip addToTypeMentionsIndex sTermId <=< saveReferenceH) cTypeMentionRefs
|
||||
|
||||
localIdsToTypeRefLookup :: LocalIds -> Transaction (S.Decl.TypeRef -> C.Decl.TypeRef)
|
||||
localIdsToTypeRefLookup localIds = do
|
||||
(substText, substHash) <- localIdsToLookups expectText expectPrimaryHashByObjectId localIds
|
||||
pure $ bimap substText (fmap substHash)
|
||||
|
||||
c2sDecl ::
|
||||
forall m t d.
|
||||
Monad m =>
|
||||
(Text -> m t) ->
|
||||
(Hash -> m d) ->
|
||||
C.Decl Symbol ->
|
||||
m (LocalIds' t d, S.Decl.Decl Symbol)
|
||||
c2sDecl saveText saveDefn (C.Decl.DataDeclaration dt m b cts) = do
|
||||
done =<< (runWriterT . flip evalStateT mempty) do
|
||||
cts' <- traverse (ABT.transformM goType) cts
|
||||
pure (C.Decl.DataDeclaration dt m b cts')
|
||||
where
|
||||
goType ::
|
||||
forall m a.
|
||||
(MonadWriter (Seq Text, Seq Hash) m, MonadState (Map Text LocalTextId, Map Hash LocalDefnId) m) =>
|
||||
C.Type.FD a ->
|
||||
m (S.Decl.F a)
|
||||
goType = \case
|
||||
C.Type.Ref r -> C.Type.Ref <$> bitraverse lookupText (traverse lookupDefn) r
|
||||
C.Type.Arrow i o -> pure $ C.Type.Arrow i o
|
||||
C.Type.Ann a k -> pure $ C.Type.Ann a k
|
||||
C.Type.App f a -> pure $ C.Type.App f a
|
||||
C.Type.Effect e a -> pure $ C.Type.Effect e a
|
||||
C.Type.Effects es -> pure $ C.Type.Effects es
|
||||
C.Type.Forall a -> pure $ C.Type.Forall a
|
||||
C.Type.IntroOuter a -> pure $ C.Type.IntroOuter a
|
||||
done :: (S.Decl.Decl Symbol, (Seq Text, Seq Hash)) -> m (LocalIds' t d, S.Decl.Decl Symbol)
|
||||
done (decl, (localTextValues, localDefnValues)) = do
|
||||
textIds <- traverse saveText localTextValues
|
||||
defnIds <- traverse saveDefn localDefnValues
|
||||
let ids =
|
||||
LocalIds
|
||||
(Vector.fromList (Foldable.toList textIds))
|
||||
(Vector.fromList (Foldable.toList defnIds))
|
||||
pure (ids, decl)
|
||||
|
||||
-- | 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) -> (Hash -> m d) -> C.Term Symbol -> Maybe (C.Term.Type Symbol) -> m (LocalIds' t d, S.Term.Term, Maybe (S.Term.Type))
|
||||
c2xTerm saveText saveDefn tm tp =
|
||||
done =<< (runWriterT . flip evalStateT mempty) do
|
||||
sterm <- ABT.transformM go tm
|
||||
stype <- traverse (ABT.transformM goType) tp
|
||||
pure (sterm, stype)
|
||||
where
|
||||
go :: forall m a. (MonadWriter (Seq Text, Seq Hash) m, MonadState (Map Text LocalTextId, Map Hash LocalDefnId) m) => C.Term.F Symbol a -> m (S.Term.F a)
|
||||
go = \case
|
||||
C.Term.Int n -> pure $ C.Term.Int n
|
||||
C.Term.Nat n -> pure $ C.Term.Nat n
|
||||
C.Term.Float n -> pure $ C.Term.Float n
|
||||
C.Term.Boolean b -> pure $ C.Term.Boolean b
|
||||
C.Term.Text t -> C.Term.Text <$> lookupText t
|
||||
C.Term.Char ch -> pure $ C.Term.Char ch
|
||||
C.Term.Ref r ->
|
||||
C.Term.Ref <$> bitraverse lookupText (traverse lookupDefn) r
|
||||
C.Term.Constructor typeRef cid ->
|
||||
C.Term.Constructor
|
||||
<$> bitraverse lookupText lookupDefn typeRef
|
||||
<*> pure cid
|
||||
C.Term.Request typeRef cid ->
|
||||
C.Term.Request <$> bitraverse lookupText lookupDefn typeRef <*> pure cid
|
||||
C.Term.Handle a a2 -> pure $ C.Term.Handle a a2
|
||||
C.Term.App a a2 -> pure $ C.Term.App a a2
|
||||
C.Term.Ann a typ -> C.Term.Ann a <$> ABT.transformM goType typ
|
||||
C.Term.List as -> pure $ C.Term.List as
|
||||
C.Term.If c t f -> pure $ C.Term.If c t f
|
||||
C.Term.And a a2 -> pure $ C.Term.And a a2
|
||||
C.Term.Or a a2 -> pure $ C.Term.Or a a2
|
||||
C.Term.Lam a -> pure $ C.Term.Lam a
|
||||
C.Term.LetRec bs a -> pure $ C.Term.LetRec bs a
|
||||
C.Term.Let a a2 -> pure $ C.Term.Let a a2
|
||||
C.Term.Match a cs -> C.Term.Match a <$> traverse goCase cs
|
||||
C.Term.TermLink r ->
|
||||
C.Term.TermLink
|
||||
<$> bitraverse
|
||||
(bitraverse lookupText (traverse lookupDefn))
|
||||
(bitraverse lookupText lookupDefn)
|
||||
r
|
||||
C.Term.TypeLink r ->
|
||||
C.Term.TypeLink <$> bitraverse lookupText lookupDefn r
|
||||
goType ::
|
||||
forall m a.
|
||||
(MonadWriter (Seq Text, Seq Hash) m, MonadState (Map Text LocalTextId, Map Hash LocalDefnId) m) =>
|
||||
C.Type.FT a ->
|
||||
m (S.Term.FT a)
|
||||
goType = \case
|
||||
C.Type.Ref r -> C.Type.Ref <$> bitraverse lookupText lookupDefn r
|
||||
C.Type.Arrow i o -> pure $ C.Type.Arrow i o
|
||||
C.Type.Ann a k -> pure $ C.Type.Ann a k
|
||||
C.Type.App f a -> pure $ C.Type.App f a
|
||||
C.Type.Effect e a -> pure $ C.Type.Effect e a
|
||||
C.Type.Effects es -> pure $ C.Type.Effects es
|
||||
C.Type.Forall a -> pure $ C.Type.Forall a
|
||||
C.Type.IntroOuter a -> pure $ C.Type.IntroOuter a
|
||||
goCase ::
|
||||
forall m w s a.
|
||||
( MonadState s m,
|
||||
MonadWriter w m,
|
||||
Lens.Field1' s (Map Text LocalTextId),
|
||||
Lens.Field1' w (Seq Text),
|
||||
Lens.Field2' s (Map Hash LocalDefnId),
|
||||
Lens.Field2' w (Seq Hash)
|
||||
) =>
|
||||
C.Term.MatchCase Text C.Term.TypeRef a ->
|
||||
m (C.Term.MatchCase LocalTextId S.Term.TypeRef a)
|
||||
goCase = \case
|
||||
C.Term.MatchCase pat guard body ->
|
||||
C.Term.MatchCase <$> goPat pat <*> pure guard <*> pure body
|
||||
goPat ::
|
||||
forall m s w.
|
||||
( MonadState s m,
|
||||
MonadWriter w m,
|
||||
Lens.Field1' s (Map Text LocalTextId),
|
||||
Lens.Field1' w (Seq Text),
|
||||
Lens.Field2' s (Map Hash LocalDefnId),
|
||||
Lens.Field2' w (Seq Hash)
|
||||
) =>
|
||||
C.Term.Pattern Text C.Term.TypeRef ->
|
||||
m (C.Term.Pattern LocalTextId S.Term.TypeRef)
|
||||
goPat = \case
|
||||
C.Term.PUnbound -> pure $ C.Term.PUnbound
|
||||
C.Term.PVar -> pure $ C.Term.PVar
|
||||
C.Term.PBoolean b -> pure $ C.Term.PBoolean b
|
||||
C.Term.PInt i -> pure $ C.Term.PInt i
|
||||
C.Term.PNat n -> pure $ C.Term.PNat n
|
||||
C.Term.PFloat d -> pure $ C.Term.PFloat d
|
||||
C.Term.PText t -> C.Term.PText <$> lookupText t
|
||||
C.Term.PChar c -> pure $ C.Term.PChar c
|
||||
C.Term.PConstructor r i ps -> C.Term.PConstructor <$> bitraverse lookupText lookupDefn r <*> pure i <*> traverse goPat ps
|
||||
C.Term.PAs p -> C.Term.PAs <$> goPat p
|
||||
C.Term.PEffectPure p -> C.Term.PEffectPure <$> goPat p
|
||||
C.Term.PEffectBind r i bindings k -> C.Term.PEffectBind <$> bitraverse lookupText lookupDefn r <*> pure i <*> traverse goPat bindings <*> goPat k
|
||||
C.Term.PSequenceLiteral ps -> C.Term.PSequenceLiteral <$> traverse goPat ps
|
||||
C.Term.PSequenceOp l op r -> C.Term.PSequenceOp <$> goPat l <*> pure op <*> goPat r
|
||||
|
||||
done :: ((S.Term.Term, Maybe S.Term.Type), (Seq Text, Seq Hash)) -> m (LocalIds' t d, S.Term.Term, Maybe S.Term.Type)
|
||||
done ((tm, tp), (localTextValues, localDefnValues)) = do
|
||||
textIds <- traverse saveText localTextValues
|
||||
defnIds <- traverse saveDefn localDefnValues
|
||||
let ids =
|
||||
LocalIds
|
||||
(Vector.fromList (Foldable.toList textIds))
|
||||
(Vector.fromList (Foldable.toList defnIds))
|
||||
pure (ids, void tm, void <$> tp)
|
||||
|
||||
-- | Save the text and hash parts of a Reference to the database and substitute their ids.
|
||||
saveReferenceH :: C.Reference -> Transaction S.ReferenceH
|
||||
saveReferenceH = bitraverse saveText saveHashHash
|
||||
|
||||
lookupText ::
|
||||
forall m s w t.
|
||||
( MonadState s m,
|
||||
MonadWriter w m,
|
||||
Lens.Field1' s (Map t LocalTextId),
|
||||
Lens.Field1' w (Seq t),
|
||||
Ord t
|
||||
) =>
|
||||
t ->
|
||||
m LocalTextId
|
||||
lookupText = lookup_ Lens._1 Lens._1 LocalTextId
|
||||
|
||||
lookupDefn ::
|
||||
forall m s w d.
|
||||
( MonadState s m,
|
||||
MonadWriter w m,
|
||||
Lens.Field2' s (Map d LocalDefnId),
|
||||
Lens.Field2' w (Seq d),
|
||||
Ord d
|
||||
) =>
|
||||
d ->
|
||||
m LocalDefnId
|
||||
lookupDefn = lookup_ Lens._2 Lens._2 LocalDefnId
|
||||
|
||||
-- | shared implementation of lookupTextHelper and lookupDefnHelper
|
||||
-- Look up a value in the LUT, or append it.
|
||||
lookup_ ::
|
||||
(MonadState s m, MonadWriter w m, Ord t) =>
|
||||
Lens' s (Map t t') ->
|
||||
Lens' w (Seq t) ->
|
||||
(Word64 -> t') ->
|
||||
t ->
|
||||
m t'
|
||||
lookup_ stateLens writerLens mk t = do
|
||||
map <- Lens.use stateLens
|
||||
case Map.lookup t map of
|
||||
Nothing -> do
|
||||
let id = mk . fromIntegral $ Map.size map
|
||||
stateLens Lens.%= Map.insert t id
|
||||
Writer.tell $ Lens.set writerLens (Seq.singleton t) mempty
|
||||
pure id
|
||||
Just t' -> pure t'
|
||||
|
||||
@ -265,6 +265,9 @@ getTermComponent =
|
||||
TermFormat.LocallyIndexedComponent
|
||||
<$> getFramedArray (getTuple3 getLocalIds (getFramed getTerm) getTType)
|
||||
|
||||
getTermAndType :: MonadGet m => m (TermFormat.Term, TermFormat.Type)
|
||||
getTermAndType = (,) <$> getFramed getTerm <*> getTType
|
||||
|
||||
getTerm :: MonadGet m => m TermFormat.Term
|
||||
getTerm = getABT getSymbol getUnit getF
|
||||
where
|
||||
|
||||
@ -24,6 +24,7 @@ import qualified U.Codebase.Reference as Reference
|
||||
import qualified U.Codebase.Sqlite.Branch.Format as BL
|
||||
import U.Codebase.Sqlite.DbId
|
||||
import qualified U.Codebase.Sqlite.Decl.Format as DeclFormat
|
||||
import U.Codebase.Sqlite.HashHandle (HashHandle)
|
||||
import qualified U.Codebase.Sqlite.LocalIds as L
|
||||
import qualified U.Codebase.Sqlite.ObjectType as OT
|
||||
import qualified U.Codebase.Sqlite.Patch.Format as PL
|
||||
@ -89,18 +90,20 @@ sync22 ::
|
||||
( MonadIO m,
|
||||
MonadError Error m
|
||||
) =>
|
||||
HashHandle ->
|
||||
Env m ->
|
||||
IO (Sync m Entity)
|
||||
sync22 Env {runSrc, runDest, idCacheSize = size} = do
|
||||
sync22 hh Env {runSrc, runDest, idCacheSize = size} = do
|
||||
tCache <- Cache.semispaceCache size
|
||||
hCache <- Cache.semispaceCache size
|
||||
oCache <- Cache.semispaceCache size
|
||||
cCache <- Cache.semispaceCache size
|
||||
pure $ Sync (trySync runSrc runDest tCache hCache oCache cCache)
|
||||
pure $ Sync (trySync hh runSrc runDest tCache hCache oCache cCache)
|
||||
|
||||
trySync ::
|
||||
forall m.
|
||||
(MonadIO m, MonadError Error m) =>
|
||||
HashHandle ->
|
||||
(forall a. Transaction a -> m a) ->
|
||||
(forall a. Transaction a -> m a) ->
|
||||
Cache TextId TextId ->
|
||||
@ -109,7 +112,7 @@ trySync ::
|
||||
Cache CausalHashId CausalHashId ->
|
||||
Entity ->
|
||||
m (TrySyncResult Entity)
|
||||
trySync runSrc runDest tCache hCache oCache cCache = \case
|
||||
trySync hh runSrc runDest tCache hCache oCache cCache = \case
|
||||
-- for causals, we need to get the value_hash_id of the thingo
|
||||
-- - maybe enqueue their parents
|
||||
-- - enqueue the self_ and value_ hashes
|
||||
@ -126,7 +129,7 @@ trySync runSrc runDest tCache hCache oCache cCache = \case
|
||||
parents' :: [CausalHashId] <- findParents' chId
|
||||
bhId' <- lift $ syncBranchHashId bhId
|
||||
chId' <- lift $ syncCausalHashId chId
|
||||
lift (runDest (Q.saveCausal chId' bhId' parents'))
|
||||
lift (runDest (Q.saveCausal hh chId' bhId' parents'))
|
||||
|
||||
case result of
|
||||
Left deps -> pure . Sync.Missing $ toList deps
|
||||
@ -164,7 +167,7 @@ trySync runSrc runDest tCache hCache oCache cCache = \case
|
||||
. TermFormat.SyncLocallyIndexedComponent
|
||||
$ Vector.zip localIds' bytes
|
||||
lift do
|
||||
oId' <- runDest $ Q.saveObject hId' objType bytes'
|
||||
oId' <- runDest $ Q.saveObject hh hId' objType bytes'
|
||||
-- copy reference-specific stuff
|
||||
for_ [0 .. length localIds - 1] \(fromIntegral -> idx) -> do
|
||||
let ref = Reference.Id oId idx
|
||||
@ -197,7 +200,7 @@ trySync runSrc runDest tCache hCache oCache cCache = \case
|
||||
. DeclFormat.SyncLocallyIndexedComponent
|
||||
$ Vector.zip localIds' declBytes
|
||||
lift do
|
||||
oId' <- runDest $ Q.saveObject hId' objType bytes'
|
||||
oId' <- runDest $ Q.saveObject hh hId' objType bytes'
|
||||
-- copy per-element-of-the-component stuff
|
||||
for_ [0 .. length localIds - 1] \(fromIntegral -> idx) -> do
|
||||
let ref = Reference.Id oId idx
|
||||
@ -210,26 +213,26 @@ trySync runSrc runDest tCache hCache oCache cCache = \case
|
||||
Right (BL.SyncFull ids body) -> do
|
||||
ids' <- syncBranchLocalIds ids
|
||||
let bytes' = runPutS $ S.recomposeBranchFormat (BL.SyncFull ids' body)
|
||||
oId' <- lift . runDest $ Q.saveObject hId' objType bytes'
|
||||
oId' <- lift . runDest $ Q.saveObject hh hId' objType bytes'
|
||||
pure oId'
|
||||
Right (BL.SyncDiff boId ids body) -> do
|
||||
boId' <- syncBranchObjectId boId
|
||||
ids' <- syncBranchLocalIds ids
|
||||
let bytes' = runPutS $ S.recomposeBranchFormat (BL.SyncDiff boId' ids' body)
|
||||
oId' <- lift . runDest $ Q.saveObject hId' objType bytes'
|
||||
oId' <- lift . runDest $ Q.saveObject hh hId' objType bytes'
|
||||
pure oId'
|
||||
Left s -> throwError $ DecodeError ErrBranchFormat bytes s
|
||||
OT.Patch -> case flip runGetS bytes S.decomposePatchFormat of
|
||||
Right (PL.SyncFull ids body) -> do
|
||||
ids' <- syncPatchLocalIds ids
|
||||
let bytes' = runPutS $ S.recomposePatchFormat (PL.SyncFull ids' body)
|
||||
oId' <- lift . runDest $ Q.saveObject hId' objType bytes'
|
||||
oId' <- lift . runDest $ Q.saveObject hh hId' objType bytes'
|
||||
pure oId'
|
||||
Right (PL.SyncDiff poId ids body) -> do
|
||||
poId' <- syncPatchObjectId poId
|
||||
ids' <- syncPatchLocalIds ids
|
||||
let bytes' = runPutS $ S.recomposePatchFormat (PL.SyncDiff poId' ids' body)
|
||||
oId' <- lift . runDest $ Q.saveObject hId' objType bytes'
|
||||
oId' <- lift . runDest $ Q.saveObject hh hId' objType bytes'
|
||||
pure oId'
|
||||
Left s -> throwError $ DecodeError ErrPatchFormat bytes s
|
||||
case result of
|
||||
|
||||
@ -38,8 +38,8 @@ type TypeLink = TypeRef
|
||||
-- * The term's type, also with internal references to local id.
|
||||
type LocallyIndexedComponent = LocallyIndexedComponent' TextId ObjectId
|
||||
|
||||
newtype LocallyIndexedComponent' t d
|
||||
= LocallyIndexedComponent (Vector (LocalIds' t d, Term, Type))
|
||||
newtype LocallyIndexedComponent' t d = LocallyIndexedComponent
|
||||
{unLocallyIndexedComponent :: Vector (LocalIds' t d, Term, Type)}
|
||||
deriving (Show)
|
||||
|
||||
newtype SyncLocallyIndexedComponent' t d
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
cabal-version: 1.12
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.34.4.
|
||||
-- This file has been generated from package.yaml by hpack version 0.34.7.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
|
||||
@ -27,6 +27,7 @@ library
|
||||
U.Codebase.Sqlite.Decl.Format
|
||||
U.Codebase.Sqlite.Decode
|
||||
U.Codebase.Sqlite.Entity
|
||||
U.Codebase.Sqlite.HashHandle
|
||||
U.Codebase.Sqlite.LocalIds
|
||||
U.Codebase.Sqlite.LocalizeObject
|
||||
U.Codebase.Sqlite.NamedRef
|
||||
|
||||
@ -102,6 +102,7 @@ dependencies:
|
||||
- unicode-show
|
||||
- unison-codebase
|
||||
- unison-codebase-sqlite
|
||||
- unison-codebase-sqlite-hashing-v2
|
||||
- unison-codebase-sync
|
||||
- unison-core
|
||||
- unison-core1
|
||||
|
||||
@ -32,6 +32,7 @@ import U.Codebase.HashTags (CausalHash (CausalHash))
|
||||
import qualified U.Codebase.Sqlite.Operations as Ops
|
||||
import qualified U.Codebase.Sqlite.Queries as Q
|
||||
import qualified U.Codebase.Sqlite.Sync22 as Sync22
|
||||
import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle)
|
||||
import qualified U.Codebase.Sync as Sync
|
||||
import qualified U.Util.Cache as Cache
|
||||
import qualified U.Util.Hash as H2
|
||||
@ -138,7 +139,7 @@ createCodebaseOrError debugName path action = do
|
||||
Sqlite.trySetJournalMode conn Sqlite.JournalMode'WAL
|
||||
Sqlite.runTransaction conn do
|
||||
Q.createSchema
|
||||
void . Ops.saveRootBranch $ Cv.causalbranch1to2 Branch.empty
|
||||
void . Ops.saveRootBranch v2HashHandle $ Cv.causalbranch1to2 Branch.empty
|
||||
|
||||
sqliteCodebase debugName path Local action >>= \case
|
||||
Left schemaVersion -> error ("Failed to open codebase with schema version: " ++ show schemaVersion ++ ", which is unexpected because I just created this codebase.")
|
||||
@ -526,7 +527,7 @@ syncInternal progress runSrc runDest b = time "syncInternal" do
|
||||
-- or if it exists in the source codebase, then we can sync22 it
|
||||
-- if it doesn't exist in the dest or source branch,
|
||||
-- then just use putBranch to the dest
|
||||
sync <- liftIO (Sync22.sync22 (Sync22.hoistEnv lift syncEnv))
|
||||
sync <- liftIO (Sync22.sync22 v2HashHandle (Sync22.hoistEnv lift syncEnv))
|
||||
let doSync :: [Sync22.Entity] -> m ()
|
||||
doSync =
|
||||
throwExceptT
|
||||
|
||||
@ -50,6 +50,7 @@ import qualified U.Codebase.Sqlite.Patch.Full as S
|
||||
import qualified U.Codebase.Sqlite.Patch.TermEdit as TermEdit
|
||||
import qualified U.Codebase.Sqlite.Patch.TypeEdit as TypeEdit
|
||||
import qualified U.Codebase.Sqlite.Queries as Q
|
||||
import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle)
|
||||
import U.Codebase.Sync (Sync (Sync))
|
||||
import qualified U.Codebase.Sync as Sync
|
||||
import U.Codebase.WatchKind (WatchKind)
|
||||
@ -257,6 +258,7 @@ migrateCausal oldCausalHashId = fmap (either id id) . runExceptT $ do
|
||||
}
|
||||
(lift . lift) do
|
||||
Q.saveCausal
|
||||
v2HashHandle
|
||||
(SC.DbCausal.selfHash newCausal)
|
||||
(SC.DbCausal.valueHash newCausal)
|
||||
(Set.toList $ SC.DbCausal.parents newCausal)
|
||||
@ -335,7 +337,7 @@ migrateBranch oldObjectId = fmap (either id id) . runExceptT $ do
|
||||
|
||||
newHash <- lift . lift $ Hashing.dbBranchHash newBranch
|
||||
newHashId <- lift . lift $ Q.saveBranchHash (coerce Cv.hash1to2 newHash)
|
||||
newObjectId <- lift . lift $ Ops.saveDbBranchUnderHashId newHashId newBranch
|
||||
newObjectId <- lift . lift $ Ops.saveDbBranchUnderHashId v2HashHandle newHashId newBranch
|
||||
field @"objLookup"
|
||||
%= Map.insert
|
||||
oldObjectId
|
||||
@ -398,6 +400,7 @@ migratePatch oldObjectId = fmap (either id id) . runExceptT $ do
|
||||
newObjectId <-
|
||||
lift . lift $
|
||||
Ops.saveDbPatch
|
||||
v2HashHandle
|
||||
(coerce Cv.hash1to2 newHash)
|
||||
(S.Patch.Format.Full localPatchIds localPatch)
|
||||
newHashId <- lift . lift $ Q.expectHashIdByHash (coerce Cv.hash1to2 newHash)
|
||||
@ -868,5 +871,5 @@ saveV2EmptyBranch = do
|
||||
let branch = S.emptyBranch
|
||||
newHash <- Hashing.dbBranchHash branch
|
||||
newHashId <- Q.saveBranchHash (coerce Cv.hash1to2 newHash)
|
||||
_ <- Ops.saveDbBranchUnderHashId newHashId branch
|
||||
_ <- Ops.saveDbBranchUnderHashId v2HashHandle newHashId branch
|
||||
pure (newHashId, newHash)
|
||||
|
||||
@ -23,6 +23,9 @@ import qualified U.Codebase.Sqlite.NamedRef as S
|
||||
import qualified U.Codebase.Sqlite.ObjectType as OT
|
||||
import qualified U.Codebase.Sqlite.Operations as Ops
|
||||
import qualified U.Codebase.Sqlite.Queries as Q
|
||||
import U.Codebase.Sqlite.V2.Decl (saveDeclComponent)
|
||||
import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle)
|
||||
import U.Codebase.Sqlite.V2.Term (saveTermComponent)
|
||||
import qualified U.Util.Cache as Cache
|
||||
import qualified U.Util.Hash as H2
|
||||
import qualified Unison.Builtin as Builtins
|
||||
@ -267,24 +270,17 @@ tryFlushTermBuffer termBuffer =
|
||||
let loop h =
|
||||
tryFlushBuffer
|
||||
termBuffer
|
||||
( \h2 component -> do
|
||||
oId <-
|
||||
Ops.saveTermComponent h2 $
|
||||
fmap (bimap (Cv.term1to2 h) Cv.ttype1to2) component
|
||||
addTermComponentTypeIndex oId (fmap snd component)
|
||||
( \h2 component ->
|
||||
void $
|
||||
saveTermComponent
|
||||
Nothing
|
||||
h2
|
||||
(fmap (bimap (Cv.term1to2 h) Cv.ttype1to2) component)
|
||||
)
|
||||
loop
|
||||
h
|
||||
in loop
|
||||
|
||||
addTermComponentTypeIndex :: ObjectId -> [Type Symbol Ann] -> Transaction ()
|
||||
addTermComponentTypeIndex oId types = for_ (types `zip` [0 ..]) \(tp, i) -> do
|
||||
let self = C.Referent.RefId (C.Reference.Id oId i)
|
||||
typeForIndexing = Hashing.typeToReference tp
|
||||
typeMentionsForIndexing = Hashing.typeToReferenceMentions tp
|
||||
Ops.addTypeToIndexForTerm self (Cv.reference1to2 typeForIndexing)
|
||||
Ops.addTypeMentionsToIndexForTerm self (Set.map Cv.reference1to2 typeMentionsForIndexing)
|
||||
|
||||
addDeclComponentTypeIndex :: ObjectId -> [[Type Symbol Ann]] -> Transaction ()
|
||||
addDeclComponentTypeIndex oId ctorss =
|
||||
for_ (ctorss `zip` [0 ..]) \(ctors, i) ->
|
||||
@ -329,10 +325,12 @@ tryFlushDeclBuffer termBuffer declBuffer =
|
||||
let loop h =
|
||||
tryFlushBuffer
|
||||
declBuffer
|
||||
( \h2 component -> do
|
||||
oId <- Ops.saveDeclComponent h2 $ fmap (Cv.decl1to2 h) component
|
||||
addDeclComponentTypeIndex oId $
|
||||
fmap (map snd . Decl.constructors . Decl.asDataDecl) component
|
||||
( \h2 component ->
|
||||
void $
|
||||
saveDeclComponent
|
||||
Nothing
|
||||
h2
|
||||
(fmap (Cv.decl1to2 h) component)
|
||||
)
|
||||
(\h -> tryFlushTermBuffer termBuffer h >> loop h)
|
||||
h
|
||||
@ -382,7 +380,7 @@ putRootBranch :: TVar (Maybe (Sqlite.DataVersion, Branch Transaction)) -> Branch
|
||||
putRootBranch rootBranchCache branch1 = do
|
||||
-- todo: check to see if root namespace hash has been externally modified
|
||||
-- and do something (merge?) it if necessary. But for now, we just overwrite it.
|
||||
void (Ops.saveRootBranch (Cv.causalbranch1to2 branch1))
|
||||
void (Ops.saveRootBranch v2HashHandle (Cv.causalbranch1to2 branch1))
|
||||
Sqlite.unsafeIO (atomically $ modifyTVar' rootBranchCache (fmap . second $ const branch1))
|
||||
|
||||
-- if this blows up on cromulent hashes, then switch from `hashToHashId`
|
||||
@ -401,7 +399,7 @@ getBranchForHash doGetDeclType h = do
|
||||
|
||||
putBranch :: Branch Transaction -> Transaction ()
|
||||
putBranch =
|
||||
void . Ops.saveBranch . Cv.causalbranch1to2
|
||||
void . Ops.saveBranch v2HashHandle . Cv.causalbranch1to2
|
||||
|
||||
isCausalHash :: Branch.CausalHash -> Transaction Bool
|
||||
isCausalHash (Causal.CausalHash h) =
|
||||
@ -418,7 +416,7 @@ getPatch h =
|
||||
|
||||
putPatch :: Branch.EditHash -> Patch -> Transaction ()
|
||||
putPatch h p =
|
||||
void $ Ops.savePatch (Cv.patchHash1to2 h) (Cv.patch1to2 p)
|
||||
void $ Ops.savePatch v2HashHandle (Cv.patchHash1to2 h) (Cv.patch1to2 p)
|
||||
|
||||
patchExists :: Branch.EditHash -> Transaction Bool
|
||||
patchExists h = fmap isJust $ Q.loadPatchObjectIdForPrimaryHash (Cv.patchHash1to2 h)
|
||||
|
||||
@ -88,7 +88,6 @@ library
|
||||
Unison.FileParser
|
||||
Unison.FileParsers
|
||||
Unison.Hashing.V2.Convert
|
||||
Unison.Hashing.V2.Convert2
|
||||
Unison.Lexer
|
||||
Unison.NamePrinter
|
||||
Unison.Parser
|
||||
@ -269,6 +268,7 @@ library
|
||||
, unicode-show
|
||||
, unison-codebase
|
||||
, unison-codebase-sqlite
|
||||
, unison-codebase-sqlite-hashing-v2
|
||||
, unison-codebase-sync
|
||||
, unison-core
|
||||
, unison-core1
|
||||
@ -450,6 +450,7 @@ test-suite parser-typechecker-tests
|
||||
, unicode-show
|
||||
, unison-codebase
|
||||
, unison-codebase-sqlite
|
||||
, unison-codebase-sqlite-hashing-v2
|
||||
, unison-codebase-sync
|
||||
, unison-core
|
||||
, unison-core1
|
||||
|
||||
@ -18,6 +18,7 @@ packages:
|
||||
- unison-share-api
|
||||
- codebase2/codebase
|
||||
- codebase2/codebase-sqlite
|
||||
- codebase2/codebase-sqlite-hashing-v2
|
||||
- codebase2/codebase-sync
|
||||
- codebase2/core
|
||||
- codebase2/util
|
||||
|
||||
@ -53,6 +53,7 @@ dependencies:
|
||||
- transformers
|
||||
- unison-codebase
|
||||
- unison-codebase-sqlite
|
||||
- unison-codebase-sqlite-hashing-v2
|
||||
- unison-sqlite
|
||||
- unison-core1
|
||||
- unison-parser-typechecker
|
||||
|
||||
@ -43,6 +43,7 @@ import Servant.Client (BaseUrl)
|
||||
import qualified Servant.Client as Servant (ClientEnv (..), ClientM, client, defaultMakeClientRequest, hoistClient, mkClientEnv, runClientM)
|
||||
import U.Codebase.HashTags (CausalHash)
|
||||
import qualified U.Codebase.Sqlite.Queries as Q
|
||||
import U.Codebase.Sqlite.V2.SyncEntity (saveSyncEntity)
|
||||
import U.Util.Hash32 (Hash32)
|
||||
import Unison.Auth.HTTPClient (AuthenticatedHttpClient)
|
||||
import qualified Unison.Auth.HTTPClient as Auth
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
cabal-version: 1.12
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.34.4.
|
||||
-- This file has been generated from package.yaml by hpack version 0.34.7.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
|
||||
@ -136,6 +136,7 @@ library
|
||||
, transformers
|
||||
, unison-codebase
|
||||
, unison-codebase-sqlite
|
||||
, unison-codebase-sqlite-hashing-v2
|
||||
, unison-core1
|
||||
, unison-parser-typechecker
|
||||
, unison-prelude
|
||||
@ -238,6 +239,7 @@ executable cli-integration-tests
|
||||
, transformers
|
||||
, unison-codebase
|
||||
, unison-codebase-sqlite
|
||||
, unison-codebase-sqlite-hashing-v2
|
||||
, unison-core1
|
||||
, unison-parser-typechecker
|
||||
, unison-prelude
|
||||
@ -334,6 +336,7 @@ executable transcripts
|
||||
, unison-cli
|
||||
, unison-codebase
|
||||
, unison-codebase-sqlite
|
||||
, unison-codebase-sqlite-hashing-v2
|
||||
, unison-core1
|
||||
, unison-parser-typechecker
|
||||
, unison-prelude
|
||||
@ -435,6 +438,7 @@ executable unison
|
||||
, unison-cli
|
||||
, unison-codebase
|
||||
, unison-codebase-sqlite
|
||||
, unison-codebase-sqlite-hashing-v2
|
||||
, unison-core1
|
||||
, unison-parser-typechecker
|
||||
, unison-prelude
|
||||
@ -540,6 +544,7 @@ test-suite cli-tests
|
||||
, unison-cli
|
||||
, unison-codebase
|
||||
, unison-codebase-sqlite
|
||||
, unison-codebase-sqlite-hashing-v2
|
||||
, unison-core1
|
||||
, unison-parser-typechecker
|
||||
, unison-prelude
|
||||
|
||||
@ -26,6 +26,7 @@ library:
|
||||
- safe
|
||||
- text
|
||||
- transformers
|
||||
- unison-core
|
||||
- unison-prelude
|
||||
- unison-util
|
||||
- unison-util-base32hex
|
||||
|
||||
@ -319,17 +319,17 @@ renames rn0 t0@(Term fvs ann t)
|
||||
| Map.null rn = t0
|
||||
| Var v <- t,
|
||||
Just u <- Map.lookup v rn =
|
||||
annotatedVar ann u
|
||||
annotatedVar ann u
|
||||
| Cycle body <- t =
|
||||
cycle' ann (renames rn body)
|
||||
cycle' ann (renames rn body)
|
||||
| Abs v t <- t,
|
||||
-- rename iterated variables all at once to avoid a capture issue
|
||||
AbsNA' (unzip -> (as, vs)) body <- t,
|
||||
(rn, us) <- mangle (freeVars body) rn (v : vs),
|
||||
not $ Map.null rn =
|
||||
absChain' (zip (ann : as) us) (renames rn body)
|
||||
absChain' (zip (ann : as) us) (renames rn body)
|
||||
| Tm body <- t =
|
||||
tm' ann (renames rn <$> body)
|
||||
tm' ann (renames rn <$> body)
|
||||
| otherwise = t0
|
||||
where
|
||||
rn = Map.restrictKeys rn0 fvs
|
||||
@ -339,7 +339,7 @@ renames rn0 t0@(Term fvs ann t)
|
||||
mangle1 avs m v
|
||||
| any (== v) vs,
|
||||
u <- freshIn (avs <> Set.fromList vs) v =
|
||||
(Map.insert v u m, u)
|
||||
(Map.insert v u m, u)
|
||||
| otherwise = (Map.delete v m, v)
|
||||
where
|
||||
vs = toList m
|
||||
@ -403,20 +403,20 @@ subst' :: (Foldable f, Functor f, Var v) => (a -> Term f v a) -> v -> Set v -> T
|
||||
subst' replace v r t2@(Term fvs ann body)
|
||||
| Set.notMember v fvs = t2 -- subtrees not containing the var can be skipped
|
||||
| otherwise = case body of
|
||||
Var v'
|
||||
| v == v' -> replace ann -- var match; perform replacement
|
||||
| otherwise -> t2 -- var did not match one being substituted; ignore
|
||||
Cycle body -> cycle' ann (subst' replace v r body)
|
||||
Abs x _ | x == v -> t2 -- x shadows v; ignore subtree
|
||||
Abs x e -> abs' ann x' e'
|
||||
where
|
||||
x' = freshIn (fvs `Set.union` r) x
|
||||
-- rename x to something that cannot be captured by `r`
|
||||
e' =
|
||||
if x /= x'
|
||||
then subst' replace v r (rename x x' e)
|
||||
else subst' replace v r e
|
||||
Tm body -> tm' ann (fmap (subst' replace v r) body)
|
||||
Var v'
|
||||
| v == v' -> replace ann -- var match; perform replacement
|
||||
| otherwise -> t2 -- var did not match one being substituted; ignore
|
||||
Cycle body -> cycle' ann (subst' replace v r body)
|
||||
Abs x _ | x == v -> t2 -- x shadows v; ignore subtree
|
||||
Abs x e -> abs' ann x' e'
|
||||
where
|
||||
x' = freshIn (fvs `Set.union` r) x
|
||||
-- rename x to something that cannot be captured by `r`
|
||||
e' =
|
||||
if x /= x'
|
||||
then subst' replace v r (rename x x' e)
|
||||
else subst' replace v r e
|
||||
Tm body -> tm' ann (fmap (subst' replace v r) body)
|
||||
|
||||
-- Like `subst`, but the annotation of the replacement is inherited from
|
||||
-- the previous annotation at each replacement point.
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
cabal-version: 1.12
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.34.4.
|
||||
-- This file has been generated from package.yaml by hpack version 0.34.7.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
|
||||
@ -100,6 +100,7 @@ library
|
||||
, safe
|
||||
, text
|
||||
, transformers
|
||||
, unison-core
|
||||
, unison-prelude
|
||||
, unison-util
|
||||
, unison-util-base32hex
|
||||
|
||||
@ -121,13 +121,13 @@ unforall' :: Type v a -> ([v], Type v a)
|
||||
unforall' (ForallsNamed' vs t) = (vs, t)
|
||||
unforall' t = ([], t)
|
||||
|
||||
toReference :: (ABT.Var v, Show v) => Type v a -> Reference
|
||||
toReference :: (Ord v, Show v) => Type v a -> Reference
|
||||
toReference (Ref' r) = r
|
||||
-- a bit of normalization - any unused type parameters aren't part of the hash
|
||||
toReference (ForallNamed' v body) | not (Set.member v (ABT.freeVars body)) = toReference body
|
||||
toReference t = Reference.Derived (ABT.hash t) 0
|
||||
|
||||
toReferenceMentions :: (ABT.Var v, Show v) => Type v a -> Set Reference
|
||||
toReferenceMentions :: (Ord v, Show v) => Type v a -> Set Reference
|
||||
toReferenceMentions ty =
|
||||
let (vs, _) = unforall' ty
|
||||
gen ty = generalize (Set.toList (freeVars ty)) $ generalize vs ty
|
||||
|
||||
Loading…
Reference in New Issue
Block a user