unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-09-20 23:07:13 +03:00
Code Issues Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/trunk' into cp/rewrite-slurping

Browse Source
This commit is contained in:
Chris Penner 2022-02-17 10:14:45 -06:00
commit e9c92e295e
192 changed files with 10002 additions and 5174 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

75
.github/workflows/release.yaml vendored
View File

@ -36,3 +36,78 @@ jobs:
with:
files: /tmp/ucm/**/*.tar.gz
build_linux:
name: "build_linux"
runs-on: ubuntu-18.04
steps:
- uses: actions/checkout@v2
- name: install stack
run: |
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-linux-x86_64.tar.gz | tar -xz
echo "$HOME/stack-2.5.1-linux-x86_64/" >> $GITHUB_PATH
# One of the transcripts fails if the user's git name hasn't been set.
- name: set git user info
run: |
git config --global user.name "GitHub Actions"
git config --global user.email "actions@github.com"
- name: build
run: stack --no-terminal build --flag unison-parser-typechecker:optimized
- name: fetch latest codebase-ui and package with ucm
run: |
mkdir -p /tmp/ucm/ui
UCM=$(stack path | awk '/local-install-root/{print $2}')/bin/unison
cp $UCM /tmp/ucm/ucm
wget -O/tmp/unisonLocal.zip https://github.com/unisonweb/codebase-ui/releases/download/latest/unisonLocal.zip
unzip -d /tmp/ucm/ui /tmp/unisonLocal.zip
tar -c -z -f ucm-linux.tar.gz -C /tmp/ucm .
- name: Upload linux artifact
uses: actions/upload-artifact@v2
with:
if-no-files-found: error
name: build-linux
path: ucm-linux.tar.gz
build_macos:
name: "build_macos"
runs-on: macos-10.15
steps:
- uses: actions/checkout@v2
- name: install stack
run: |
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-osx-x86_64.tar.gz | tar -xz
echo "$HOME/stack-2.5.1-osx-x86_64/" >> $GITHUB_PATH
# One of the transcripts fails if the user's git name hasn't been set.
- name: set git user info
run: |
git config --global user.name "GitHub Actions"
git config --global user.email "actions@github.com"
- name: remove ~/.stack/setup-exe-cache on macOS
run: rm -rf ~/.stack/setup-exe-cache
- name: build
run: stack --no-terminal build --flag unison-parser-typechecker:optimized
- name: fetch latest codebase-ui and package with ucm
run: |
mkdir -p /tmp/ucm/ui
UCM=$(stack path | awk '/local-install-root/{print $2}')/bin/unison
cp $UCM /tmp/ucm/ucm
wget -O/tmp/unisonLocal.zip https://github.com/unisonweb/codebase-ui/releases/download/latest/unisonLocal.zip
unzip -d /tmp/ucm/ui /tmp/unisonLocal.zip
tar -c -z -f ucm-macos.tar.gz -C /tmp/ucm .
- name: Upload macos artifact
uses: actions/upload-artifact@v2
with:
if-no-files-found: error
name: build-macos
path: ucm-macos.tar.gz

1
CONTRIBUTORS.markdown
View File

@ -66,3 +66,4 @@ The format for this list: name, GitHub handle, and then optional blurb about wha
* Sameer Kolhar (@kolharsam)
* Nicole Prindle (@nprindle)
* Harald Gliebe (@hagl)
* Phil de Joux (@philderbeast)

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

@ -1,26 +1,68 @@
{- ORMOLU_DISABLE -} -- Remove this when the file is ready to be auto-formatted
module U.Codebase.Sqlite.Branch.Format where
module U.Codebase.Sqlite.Branch.Format
( BranchFormat (..),
BranchLocalIds (..),
SyncBranchFormat (..),
localToDbBranch,
localToDbDiff,
-- dbToLocalDiff,
) where
import Data.Vector (Vector)
import U.Codebase.Sqlite.Branch.Diff (LocalDiff)
import U.Codebase.Sqlite.Branch.Full (LocalBranch)
import U.Codebase.Sqlite.DbId (CausalHashId, BranchObjectId, ObjectId, PatchObjectId, TextId)
import Data.ByteString (ByteString)
import qualified Data.Vector as Vector
import U.Codebase.Sqlite.Branch.Diff (Diff, LocalDiff)
import qualified U.Codebase.Sqlite.Branch.Diff as Branch.Diff
import U.Codebase.Sqlite.Branch.Full (DbBranch, LocalBranch)
import qualified U.Codebase.Sqlite.Branch.Full as Branch.Full
import U.Codebase.Sqlite.DbId (BranchObjectId, CausalHashId, ObjectId, PatchObjectId, TextId)
import U.Codebase.Sqlite.LocalIds
( LocalBranchChildId (..),
LocalDefnId (..),
LocalPatchObjectId (..),
LocalTextId (..),
)
import Unison.Prelude
-- |you can use the exact same `BranchLocalIds` when converting between `Full` and `Diff`
-- | A 'BranchFormat' is a deserialized namespace object (@object.bytes@).
--
-- you can use the exact same `BranchLocalIds` when converting between `Full` and `Diff`
data BranchFormat
= Full BranchLocalIds LocalBranch
| Diff BranchObjectId BranchLocalIds LocalDiff
deriving Show
deriving (Show)
-- | A 'BranchLocalIds' is a mapping between local ids (local to this object) encoded as offsets, and actual database ids.
--
-- For example, a @branchTextLookup@ vector of @[50, 74]@ means "local id 0 corresponds to database text id 50, and
-- local id 1 corresponds to database text id 74".
data BranchLocalIds = LocalIds
{ branchTextLookup :: Vector TextId,
branchDefnLookup :: Vector ObjectId,
branchPatchLookup :: Vector PatchObjectId,
branchChildLookup :: Vector (BranchObjectId, CausalHashId)
}
deriving Show
deriving (Show)
data SyncBranchFormat
= SyncFull BranchLocalIds ByteString
| SyncDiff BranchObjectId BranchLocalIds ByteString
localToDbBranch :: BranchLocalIds -> LocalBranch -> DbBranch
localToDbBranch li =
Branch.Full.quadmap (lookupBranchLocalText li) (lookupBranchLocalDefn li) (lookupBranchLocalPatch li) (lookupBranchLocalChild li)
localToDbDiff :: BranchLocalIds -> LocalDiff -> Diff
localToDbDiff li =
Branch.Diff.quadmap (lookupBranchLocalText li) (lookupBranchLocalDefn li) (lookupBranchLocalPatch li) (lookupBranchLocalChild li)
lookupBranchLocalText :: BranchLocalIds -> LocalTextId -> TextId
lookupBranchLocalText li (LocalTextId w) = branchTextLookup li Vector.! fromIntegral w
lookupBranchLocalDefn :: BranchLocalIds -> LocalDefnId -> ObjectId
lookupBranchLocalDefn li (LocalDefnId w) = branchDefnLookup li Vector.! fromIntegral w
lookupBranchLocalPatch :: BranchLocalIds -> LocalPatchObjectId -> PatchObjectId
lookupBranchLocalPatch li (LocalPatchObjectId w) = branchPatchLookup li Vector.! fromIntegral w
lookupBranchLocalChild :: BranchLocalIds -> LocalBranchChildId -> (BranchObjectId, CausalHashId)
lookupBranchLocalChild li (LocalBranchChildId w) = branchChildLookup li Vector.! fromIntegral w

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

@ -1,21 +1,45 @@
{- ORMOLU_DISABLE -} -- Remove this when the file is ready to be auto-formatted
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module U.Codebase.Sqlite.Branch.Full where
import Data.Map (Map)
import Data.Set (Set)
import Control.Lens
import qualified Data.Set as Set
import U.Codebase.Reference (Reference')
import qualified U.Codebase.Reference as Reference
import U.Codebase.Referent (Referent')
import U.Codebase.Sqlite.DbId (BranchObjectId, CausalHashId, ObjectId, PatchObjectId, TextId)
import U.Codebase.Sqlite.LocalIds (LocalBranchChildId, LocalDefnId, LocalPatchObjectId, LocalTextId)
import qualified Unison.Util.Set as Set
import Unison.Prelude
import qualified Unison.Util.Map as Map
import Data.Bifunctor (Bifunctor(bimap))
import qualified Data.Set as Set
import qualified Data.Map as Map
-- |
-- @
-- Branch
-- { terms :: Map LocalTextId (Map LocalReferent LocalMetadataSet),
-- types :: Map LocalTextId (Map LocalReference LocalMetadataSet),
-- patches :: Map LocalTextId LocalPatchObjectId,
-- children :: Map LocalTextId LocalBranchChildId
-- }
-- @
type LocalBranch = Branch' LocalTextId LocalDefnId LocalPatchObjectId LocalBranchChildId
-- |
-- @
-- Branch
-- { terms :: Map TextId (Map Referent DbMetadataSet),
-- types :: Map TextId (Map Reference DbMetadataSet),
-- patches :: Map TextId PatchObjectId,
-- children :: Map TextId (BranchObjectId, CausalHashId)
-- }
-- @
type DbBranch = Branch' TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId)
type Referent'' t h = Referent' (Reference' t h) (Reference' t h)
@ -26,14 +50,38 @@ data Branch' t h p c = Branch
patches :: Map t p,
children :: Map t c
}
deriving Show
deriving (Show, Generic)
emptyBranch :: Branch' t h p c
emptyBranch = Branch Map.empty Map.empty Map.empty Map.empty
branchHashes_ :: (Ord h', Ord t, Ord h) => Traversal (Branch' t h p c) (Branch' t h' p c) h h'
branchHashes_ f Branch {..} = do
newTerms <- for terms (Map.bitraversed both metadataSetFormatReferences_ . Reference.h_ %%~ f)
newTypes <- for types (Map.bitraversed id metadataSetFormatReferences_ . Reference.h_ %%~ f)
pure Branch {terms = newTerms, types = newTypes, patches, children}
patches_ :: Traversal (Branch' t h p c) (Branch' t h p' c) p p'
patches_ f Branch {..} = (\newPatches -> Branch terms types newPatches children) <$> traverse f patches
childrenHashes_ :: Traversal (Branch' t h p c) (Branch' t h p c') c c'
childrenHashes_ f Branch {..} = Branch terms types patches <$> traverse f children
branchCausalHashes_ :: Traversal (Branch' t h p c) (Branch' t h p c') c c'
branchCausalHashes_ f Branch {..} =
Branch terms types patches <$> traverse f children
type LocalMetadataSet = MetadataSetFormat' LocalTextId LocalDefnId
type DbMetadataSet = MetadataSetFormat' TextId ObjectId
data MetadataSetFormat' t h = Inline (Set (Reference' t h))
deriving Show
deriving (Show)
metadataSetFormatReferences_ ::
(Ord t, Ord h, Ord h') =>
Traversal (MetadataSetFormat' t h) (MetadataSetFormat' t h') (Reference' t h) (Reference' t h')
metadataSetFormatReferences_ f (Inline refs) = Inline <$> Set.traverse f refs
quadmap :: forall t h p c t' h' p' c'. (Ord t', Ord h') => (t -> t') -> (h -> h') -> (p -> p') -> (c -> c') -> Branch' t h p c -> Branch' t' h' p' c'
quadmap ft fh fp fc (Branch terms types patches children) =

42
codebase2/codebase-sqlite/U/Codebase/Sqlite/Causal.hs Normal file
View File

@ -0,0 +1,42 @@
{-# LANGUAGE RecordWildCards #-}
module U.Codebase.Sqlite.Causal where
import U.Codebase.Sqlite.DbId (BranchHashId, CausalHashId)
import Unison.Prelude
data GDbCausal causalHash valueHash = DbCausal
{ selfHash :: causalHash,
valueHash :: valueHash,
parents :: Set causalHash
}
-- Causal Plan
-- * Load a DbCausal (how do we do this)
-- => new function Queries.localCausalByCausalHashId, can model after loadCausalByCausalHash or factor out of
-- * Add valueHashId as a dependency if unmigrated
-- * Add parent causal hash ids as dependencies if unmigrated
-- => Queries.loadCausalParents
-- * Map over Branch hash IDs
-- * Inside saveDBCausal (new / factored out of original)
-- * Save as a new self-hash
-- ==> Queries.saveCausal
-- * Map over parent causal hash IDs
-- ==> Queries.saveCausalParents
type DbCausal = GDbCausal CausalHashId BranchHashId
-- causalHashes_ :: Traversal (GDbCausal ch vh) (GDbCausal ch' vh) ch ch'
-- causalHashes_ f DbCausal {..} =
-- DbCausal <$> f selfHash <*> pure valueHash <*> (fmap Set.fromList . traverse f . Set.toList $ parents)
-- valueHashes_ :: Lens (GDbCausal ch vh) (GDbCausal ch vh) vh vh'
-- valueHashes_ f DbCausal{..} =
-- (\p vh -> DbCausal selfHash vh p) parents <$> f valueHash
-- data Causal m hc he e = Causal
-- { causalHash :: hc,
-- valueHash :: he,
-- parents :: Map hc (m (Causal m hc he e)),
-- value :: m e
-- }

52
codebase2/codebase-sqlite/U/Codebase/Sqlite/Decl/Format.hs
View File

@ -17,10 +17,60 @@ data DeclFormat = Decl LocallyIndexedComponent
-- | V1: Decls included `Hash`es inline
-- V2: Instead of `Hash`, we use a smaller index.
data LocallyIndexedComponent
newtype LocallyIndexedComponent
= LocallyIndexedComponent (Vector (LocalIds, Decl Symbol))
deriving Show
-- [OldDecl] ==map==> [NewDecl] ==number==> [(NewDecl, Int)] ==sort==> [(NewDecl, Int)] ==> permutation is map snd of that
-- type List a = Nil | Cons (List a)
-- unique type Thunk = Thunk (Int ->{MakeThunk} Int)
-- ability MakeThunk where go : (Int -> Int) -> Thunk
-- What mitchell thinks unhashComponent is doing:
--
-- Take a recursive type like
--
-- Fix \myself -> Alternatives [Nil, Cons a myself]
--
-- And write it with variables in place of recursive mentions like
--
-- (Var 1, Alternatives [Nil, Cons a (Var 1)]
-- can derive `original` from Hash + [OldDecl]
-- original :: Map Reference.Id (Decl v a)
-- named, rewritten_dependencies :: Map (Reference.Id {old}) (v, Decl v a {old pos in references})
-- named = Decl.unhashComponent original
-- Mapping from the sky: (Reference.Id -> Reference.Id)
-- rewritten_dependencies = replace_dependency_pos's skymap named
-- new_references :: Map v (Reference.Id {new}, DataDeclaration v a)
-- new_references = Unison.Hashing.V2.Convert.hashDecls $ Map.toList $ Foldable.toList rewritten_dependencies
-- hashDecls ::
-- Var v =>
-- Map v (Memory.DD.DataDeclaration v a) ->
-- ResolutionResult v a [(v, Memory.Reference.Id, Memory.DD.DataDeclaration v a)]
-- compute correspondence between `v`s in `fst <$> named` compared to `fst <$> new_references` to get a Reference.Id -> Reference.Id mapping
-- mitchell tapped out before understanding the following line
-- compute correspondence between constructors names & constructor indices in corresponding decls
-- submit/mappend these two correspondences to sky mapping
-- Swap the Reference positions according to our map of already computed swaps
-- Hydrate into the parser-typechecker version, get the new hash
-- reserialize it into the sqlite format
-- Compare the old and new sqlite versions to add those ConstructorID/Pos mappings to our context.
-- unrelated Q:
-- do we kinda have circular dependency issues here?
-- parser-typechecker depends on codebase2, but we are talking about doing things at the parser-typechecker level in this migration
-- answer: no
type Decl v = DeclR TypeRef v
type Type v = ABT.Term F v ()

3
codebase2/codebase-sqlite/U/Codebase/Sqlite/LocalIds.hs
View File

@ -25,6 +25,9 @@ type WatchLocalIds = LocalIds' TextId HashId
newtype LocalTextId = LocalTextId Word64 deriving (Eq, Ord, Show, Num, Real, Enum, Integral, Bits) via Word64
-- | represents an index into a defnLookup
--
-- In this context, "definition" means an object that is either a term component or a (type) decl component, not a
-- patch, namespace, or any other kind of object.
newtype LocalDefnId = LocalDefnId Word64 deriving (Eq, Ord, Show, Num, Real, Enum, Integral, Bits) via Word64
-- | a local index to a hash, used when the corresponding object is allowed to be absent

216
codebase2/codebase-sqlite/U/Codebase/Sqlite/LocalizeObject.hs Normal file
View File

@ -0,0 +1,216 @@
-- | This module facilitates the creation of "localized" versions of objects, suitable for storage.
--
-- Localization is a stateful process in which the real database identifiers contained within an object, e.g. 'DbBranch', are canonicalized
-- as local identifiers counting up from 0 in the order they are encountered in the object. The association between real and local
-- identifier is captured in a vector, where the @ith@ index maps local identifier @i@ to the real identifier it corresponds to.
--
-- For example, consider a branch object that refers to terms @#foo@ and @#bar@. In totally made-up syntax,
--
-- @
-- branch = {
-- terms = [#foo, #bar]
-- }
-- @
--
-- The localized version of this branch would be
--
-- @
-- branch = {
-- terms = [0, 1]
-- }
-- terms = [#foo, #bar]
-- @
--
-- where all terms, types, etc. within the @branch@ structure refer to offsets in the associated vectors.
module U.Codebase.Sqlite.LocalizeObject
( localizeBranch,
localizePatch,
)
where
import Control.Lens
import Control.Monad.Trans.State.Strict (StateT)
import qualified Control.Monad.Trans.State.Strict as State
import Data.Bitraversable (bitraverse)
import Data.Generics.Product.Typed (HasType (typed))
import qualified Data.Map.Strict as Map
import U.Codebase.Sqlite.Branch.Format (BranchLocalIds)
import qualified U.Codebase.Sqlite.Branch.Format as Branch
import U.Codebase.Sqlite.Branch.Full (Branch' (..), DbBranch, LocalBranch)
import qualified U.Codebase.Sqlite.Branch.Full as Branch
import U.Codebase.Sqlite.DbId (BranchObjectId, CausalHashId, HashId, ObjectId, PatchObjectId, TextId)
import U.Codebase.Sqlite.LocalIds
( LocalBranchChildId (..),
LocalDefnId (..),
LocalHashId (..),
LocalPatchObjectId (..),
LocalTextId (..),
)
import U.Codebase.Sqlite.Patch.Format (PatchLocalIds)
import qualified U.Codebase.Sqlite.Patch.Format as Patch
import U.Codebase.Sqlite.Patch.Full (LocalPatch, Patch, Patch' (..))
import U.Codebase.Sqlite.Patch.TermEdit (LocalTermEdit, TermEdit)
import U.Codebase.Sqlite.Patch.TypeEdit (LocalTypeEdit, TypeEdit)
import U.Codebase.Sqlite.Reference (LocalReference, LocalReferenceH, Reference, ReferenceH)
import U.Codebase.Sqlite.Referent (LocalReferent, LocalReferentH, Referent, ReferentH)
import Unison.Prelude
import qualified Unison.Util.Map as Map
import qualified Unison.Util.Set as Set
--------------------------------------------------------------------------------------------------------------------------------------------
-- High-level localization
-- | Localize a branch object.
localizeBranch :: DbBranch -> (BranchLocalIds, LocalBranch)
localizeBranch (Branch terms types patches children) =
(runIdentity . runLocalizeBranch) do
Branch
<$> Map.bitraverse localizeText (Map.bitraverse localizeReferent localizeBranchMetadata) terms
<*> Map.bitraverse localizeText (Map.bitraverse localizeReference localizeBranchMetadata) types
<*> Map.bitraverse localizeText localizePatchReference patches
<*> Map.bitraverse localizeText localizeBranchReference children
where
localizeBranchMetadata :: (ContainsDefns s, ContainsText s, Monad m) => Branch.DbMetadataSet -> StateT s m Branch.LocalMetadataSet
localizeBranchMetadata (Branch.Inline refs) =
Branch.Inline <$> Set.traverse localizeReference refs
-- | Localize a patch object.
localizePatch :: Patch -> (PatchLocalIds, LocalPatch)
localizePatch (Patch termEdits typeEdits) =
(runIdentity . runLocalizePatch) do
Patch
<$> Map.bitraverse localizeReferentH (Set.traverse localizeTermEdit) termEdits
<*> Map.bitraverse localizeReferenceH (Set.traverse localizeTypeEdit) typeEdits
where
localizeTermEdit :: (ContainsText s, ContainsDefns s, Monad m) => TermEdit -> StateT s m LocalTermEdit
localizeTermEdit =
bitraverse localizeText localizeDefn
localizeTypeEdit :: (ContainsText s, ContainsDefns s, Monad m) => TypeEdit -> StateT s m LocalTypeEdit
localizeTypeEdit =
bitraverse localizeText localizeDefn
--------------------------------------------------------------------------------------------------------------------------------------------
-- General-purpose localization
-- Contains references to branch objects.
type ContainsBranches s =
HasType (Map (BranchObjectId, CausalHashId) LocalBranchChildId) s
-- Contains references to definition objects i.e. term/decl component objects.
type ContainsDefns s =
HasType (Map ObjectId LocalDefnId) s
-- Contains references to objects by their hash.
type ContainsHashes =
HasType (Map HashId LocalHashId)
-- Contains references to patch objects.
type ContainsPatches =
HasType (Map PatchObjectId LocalPatchObjectId)
-- Contains text.
type ContainsText =
HasType (Map TextId LocalTextId)
-- The inner state of the localization of a branch object.
type LocalizeBranchState =
( Map TextId LocalTextId,
Map ObjectId LocalDefnId,
Map PatchObjectId LocalPatchObjectId,
Map (BranchObjectId, CausalHashId) LocalBranchChildId
)
-- Run a computation that localizes a branch object, returning the local ids recorded within.
runLocalizeBranch :: Monad m => StateT LocalizeBranchState m a -> m (BranchLocalIds, a)
runLocalizeBranch action = do
(result, (localTexts, localDefns, localPatches, localChildren)) <- State.runStateT action (mempty @LocalizeBranchState)
let branchLocalIds :: BranchLocalIds
branchLocalIds =
Branch.LocalIds
{ Branch.branchTextLookup = Map.valuesVector (Map.swap localTexts),
Branch.branchDefnLookup = Map.valuesVector (Map.swap localDefns),
Branch.branchPatchLookup = Map.valuesVector (Map.swap localPatches),
Branch.branchChildLookup = Map.valuesVector (Map.swap localChildren)
}
pure (branchLocalIds, result)
-- The inner state of the localization of a patch object.
type LocalizePatchState =
( Map TextId LocalTextId,
Map HashId LocalHashId,
Map ObjectId LocalDefnId
)
-- Run a computation that localizes a patch object, returning the local ids recorded within.
runLocalizePatch :: Monad m => StateT LocalizePatchState m a -> m (PatchLocalIds, a)
runLocalizePatch action = do
(result, (localTexts, localHashes, localDefns)) <- State.runStateT action (mempty @LocalizePatchState)
let patchLocalIds :: PatchLocalIds
patchLocalIds =
Patch.LocalIds
{ Patch.patchTextLookup = Map.valuesVector (Map.swap localTexts),
Patch.patchHashLookup = Map.valuesVector (Map.swap localHashes),
Patch.patchDefnLookup = Map.valuesVector (Map.swap localDefns)
}
pure (patchLocalIds, result)
-- Localize a branch object reference in any monad that encapsulates the stateful localization of an object that contains branch references.
localizeBranchReference :: (ContainsBranches s, Monad m) => (BranchObjectId, CausalHashId) -> StateT s m LocalBranchChildId
localizeBranchReference =
zoom typed . localize
-- Localize a definition object reference in any monad that encapsulates the stateful localization of an object that contains definition
-- references.
localizeDefn :: (ContainsDefns s, Monad m) => ObjectId -> StateT s m LocalDefnId
localizeDefn =
zoom typed . localize
-- Localize a hash reference in any monad that encapsulates the stateful localization of an object that contains hash references.
localizeHash :: (ContainsHashes s, Monad m) => HashId -> StateT s m LocalHashId
localizeHash =
zoom typed . localize
-- Localize a patch object reference in any monad that encapsulates the stateful localization of an object that contains patch references.
localizePatchReference :: (ContainsPatches s, Monad m) => PatchObjectId -> StateT s m LocalPatchObjectId
localizePatchReference =
zoom typed . localize
-- Localize a reference in any monad that encapsulates the stateful localization of an object that contains references.
localizeReference :: (ContainsDefns s, ContainsText s, Monad m) => Reference -> StateT s m LocalReference
localizeReference =
bitraverse localizeText localizeDefn
-- Localize a possibly-missing reference in any monad that encapsulates the stateful localization of an object that contains
-- possibly-missing references.
localizeReferenceH :: (ContainsHashes s, ContainsText s, Monad m) => ReferenceH -> StateT s m LocalReferenceH
localizeReferenceH =
bitraverse localizeText localizeHash
-- Localize a referent in any monad that encapsulates the stateful localization of an object that contains referents.
localizeReferent :: (ContainsDefns s, ContainsText s, Monad m) => Referent -> StateT s m LocalReferent
localizeReferent =
bitraverse localizeReference localizeReference
-- Localize a possibly-missing referent in any monad that encapsulates the stateful localization of an object that contains possibly-missing
-- referents.
localizeReferentH :: (ContainsHashes s, ContainsText s, Monad m) => ReferentH -> StateT s m LocalReferentH
localizeReferentH =
bitraverse localizeReferenceH localizeReferenceH
-- Localize a text reference in any monad that encapsulates the stateful localization of an object that contains text.
localizeText :: (ContainsText s, Monad m) => TextId -> StateT s m LocalTextId
localizeText =
zoom typed . localize
-- Resolve a real id to its corresponding local id, either by looking it up in a map, or else using the next available local id, which is
-- recorded for next time.
localize :: (Coercible localId Word64, Monad m, Ord realId) => realId -> StateT (Map realId localId) m localId
localize realId = do
mapping <- State.get
case Map.lookup realId mapping of
Nothing -> do
let nextLocalId = coerce @Word64 (fromIntegral (Map.size mapping))
State.put $! Map.insert realId nextLocalId mapping
pure nextLocalId
Just localId -> pure localId

662
codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs
View File

@ -11,85 +11,101 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
module U.Codebase.Sqlite.Operations (
-- * data version
dataVersion,
module U.Codebase.Sqlite.Operations
( -- * data version
dataVersion,
-- * branches
saveRootBranch,
loadMaybeRootCausalHash,
loadRootCausalHash,
loadRootCausal,
saveBranch,
loadCausalBranchByCausalHash,
-- * branches
saveRootBranch,
loadMaybeRootCausalHash,
loadRootCausalHash,
loadRootCausal,
saveBranch,
loadCausalBranchByCausalHash,
-- * terms
saveTermComponent,
loadTermByReference,
loadTypeOfTermByTermReference,
-- * terms
saveTermComponent,
loadTermComponent,
loadTermByReference,
loadTypeOfTermByTermReference,
-- * decls
saveDeclComponent,
loadDeclByReference,
getDeclTypeByReference,
-- * decls
saveDeclComponent,
loadDeclComponent,
loadDeclByReference,
getDeclTypeById,
-- * patches
savePatch,
loadPatchById,
-- * terms/decls
getCycleLen,
-- * test for stuff in codebase
objectExistsForHash,
-- * patches
savePatch,
loadPatchById,
-- * dubiously exported stuff involving database ids
loadHashByObjectId,
primaryHashToMaybeObjectId,
primaryHashToMaybePatchObjectId,
-- * test for stuff in codebase
objectExistsForHash,
-- * watch expression cache
saveWatch,
loadWatch,
listWatches,
clearWatches,
-- * dubiously exported stuff involving database ids
loadHashByObjectId,
primaryHashToMaybeObjectId,
primaryHashToMaybePatchObjectId,
-- * indexes
-- ** nearest common ancestor
before,
lca,
-- ** prefix index
componentReferencesByPrefix,
termReferentsByPrefix,
declReferentsByPrefix,
causalHashesByPrefix,
-- ** dependents index
dependents,
-- ** type index
addTypeToIndexForTerm,
termsHavingType,
-- ** type mentions index
addTypeMentionsToIndexForTerm,
termsMentioningType,
-- * watch expression cache
saveWatch,
loadWatch,
listWatches,
clearWatches,
-- * delete me
getCycleLen,
-- * indexes
-- * Error types
Error(..),
DecodeError(..),
-- ** nearest common ancestor
before,
lca,
-- ** Constraint kinds
EDB,
-- ** prefix index
componentReferencesByPrefix,
termReferentsByPrefix,
declReferentsByPrefix,
causalHashesByPrefix,
-- * somewhat unexpectedly unused definitions
c2sReferenceId,
c2sReferentId,
diffPatch,
decodeTermElementWithType,
loadTermWithTypeByReference,
s2cTermWithType,
declReferencesByPrefix,
branchHashesByPrefix,
derivedDependencies,
) where
-- ** dependents index
dependents,
dependentsOfComponent,
-- ** type index
addTypeToIndexForTerm,
termsHavingType,
-- ** type mentions index
addTypeMentionsToIndexForTerm,
termsMentioningType,
-- * low-level stuff
liftQ,
loadDbBranchByObjectId,
loadDbPatchById,
saveBranchObject,
saveDbPatch,
-- * Error types
Error (..),
DecodeError (..),
-- ** Constraint kinds
EDB,
-- * somewhat unexpectedly unused definitions
c2sReferenceId,
c2sReferentId,
diffPatch,
decodeTermElementWithType,
loadTermWithTypeByReference,
s2cTermWithType,
declReferencesByPrefix,
branchHashesByPrefix,
derivedDependencies,
)
where
import Control.Lens (Lens')
import qualified Control.Lens as Lens
@ -97,10 +113,10 @@ import Control.Monad (MonadPlus (mzero), join, unless, when, (<=<))
import Control.Monad.Except (ExceptT, MonadError, MonadIO (liftIO), runExceptT)
import qualified Control.Monad.Except as Except
import qualified Control.Monad.Extra as Monad
import Control.Monad.State (MonadState, StateT, evalStateT)
import Control.Monad.State (MonadState, evalStateT)
import Control.Monad.Trans (MonadTrans (lift))
import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT)
import Control.Monad.Writer (MonadWriter, WriterT, runWriterT)
import Control.Monad.Writer (MonadWriter, runWriterT)
import qualified Control.Monad.Writer as Writer
import Data.Bifunctor (Bifunctor (bimap))
import Data.Bitraversable (Bitraversable (bitraverse))
@ -151,23 +167,19 @@ import U.Codebase.Sqlite.Connection (Connection)
import qualified U.Codebase.Sqlite.DbId as Db
import qualified U.Codebase.Sqlite.Decl.Format as S.Decl
import U.Codebase.Sqlite.LocalIds
( LocalBranchChildId (..),
LocalDefnId (..),
LocalHashId (..),
( LocalDefnId (..),
LocalIds,
LocalIds' (..),
LocalPatchObjectId (..),
LocalTextId (..),
WatchLocalIds,
)
import qualified U.Codebase.Sqlite.LocalIds as LocalIds
import qualified U.Codebase.Sqlite.LocalizeObject as LocalizeObject
import qualified U.Codebase.Sqlite.ObjectType as OT
import qualified U.Codebase.Sqlite.Patch.Diff as S
import qualified U.Codebase.Sqlite.Patch.Diff as S.PatchDiff
import qualified U.Codebase.Sqlite.Patch.Format as S
import qualified U.Codebase.Sqlite.Patch.Format as S.PatchFormat
import qualified U.Codebase.Sqlite.Patch.Full as S
import qualified U.Codebase.Sqlite.Patch.Full as S.Patch.Full
import qualified U.Codebase.Sqlite.Patch.Format as S.Patch.Format
import qualified U.Codebase.Sqlite.Patch.Full as S (LocalPatch, Patch, Patch' (..))
import qualified U.Codebase.Sqlite.Patch.TermEdit as S
import qualified U.Codebase.Sqlite.Patch.TermEdit as S.TermEdit
import qualified U.Codebase.Sqlite.Patch.TypeEdit as S
@ -220,7 +232,9 @@ type EDB m = (Err m, DB m)
type ErrString = String
data DecodeError
= ErrTermElement Word64
= ErrTermFormat
| ErrDeclFormat
| ErrTermElement Word64
| ErrDeclElement Word64
| ErrFramedArrayLen
| ErrTypeOfTerm C.Reference.Id
@ -234,7 +248,6 @@ data Error
= DecodeError DecodeError ByteString ErrString
| DatabaseIntegrityError Q.Integrity
| UnknownDependency H.Hash
| UnknownText Text
| ExpectedBranch CausalHash BranchHash
| ExpectedBranch' Db.CausalHashId
| LegacyUnknownCycleLen H.Hash
@ -257,12 +270,6 @@ liftQ a =
-- * Database lookups
lookupTextId :: EDB m => Text -> m Db.TextId
lookupTextId t =
Q.loadText t >>= \case
Just textId -> pure textId
Nothing -> throwError $ UnknownText t
loadTextById :: EDB m => Db.TextId -> m Text
loadTextById = liftQ . Q.loadTextById
@ -279,6 +286,12 @@ primaryHashToMaybeObjectId h = do
Just hashId -> Q.maybeObjectIdForPrimaryHashId hashId
Nothing -> pure Nothing
anyHashToMaybeObjectId :: DB m => H.Hash -> m (Maybe Db.ObjectId)
anyHashToMaybeObjectId h = do
(Q.loadHashId . H.toBase32Hex) h >>= \case
Just hashId -> Q.maybeObjectIdForAnyHashId hashId
Nothing -> pure Nothing
primaryHashToMaybePatchObjectId :: EDB m => PatchHash -> m (Maybe Db.PatchObjectId)
primaryHashToMaybePatchObjectId =
(fmap . fmap) Db.PatchObjectId . primaryHashToMaybeObjectId . unPatchHash
@ -308,15 +321,19 @@ loadRootCausalHash :: EDB m => m CausalHash
loadRootCausalHash = loadCausalHashById =<< liftQ Q.loadNamespaceRoot
loadMaybeRootCausalHash :: EDB m => m (Maybe CausalHash)
loadMaybeRootCausalHash = runMaybeT $
loadCausalHashById =<< MaybeT (liftQ Q.loadMaybeNamespaceRoot)
loadMaybeRootCausalHash =
runMaybeT $
loadCausalHashById =<< MaybeT (liftQ Q.loadMaybeNamespaceRoot)
-- * Reference transformations
-- ** read existing references
-- |Assumes that a derived reference would already exist in the database
-- (by virtue of dependencies being stored before dependents), but does
-- not assume a builtin reference would.
c2sReference :: EDB m => C.Reference -> m S.Reference
c2sReference = bitraverse lookupTextId primaryHashToExistingObjectId
c2sReference = bitraverse Q.saveText primaryHashToExistingObjectId
s2cReference :: EDB m => S.Reference -> m C.Reference
s2cReference = bitraverse loadTextById loadHashByObjectId
@ -342,12 +359,23 @@ s2cReferent = bitraverse s2cReference s2cReference
s2cReferentId :: EDB m => S.Referent.Id -> m C.Referent.Id
s2cReferentId = bitraverse loadHashByObjectId loadHashByObjectId
c2sReferent :: EDB m => C.Referent -> m S.Referent
c2sReferent = bitraverse c2sReference c2sReference
c2sReferentId :: EDB m => C.Referent.Id -> m S.Referent.Id
c2sReferentId = bitraverse primaryHashToExistingObjectId primaryHashToExistingObjectId
h2cReferent :: EDB m => S.ReferentH -> m C.Referent
h2cReferent = bitraverse h2cReference h2cReference
-- ** convert and save references
-- | Save the text and hash parts of a Reference to the database and substitute their ids.
saveReferenceH :: DB m => C.Reference -> m S.ReferenceH
saveReferenceH = bitraverse Q.saveText Q.saveHashHash
saveReferentH :: DB m => C.Referent -> m S.ReferentH
saveReferentH = bitraverse saveReferenceH saveReferenceH
-- ** Edits transformations
s2cTermEdit :: EDB m => S.TermEdit -> m C.TermEdit
@ -372,76 +400,21 @@ s2cTypeEdit = \case
S.TypeEdit.Replace r -> C.TypeEdit.Replace <$> s2cReference r
S.TypeEdit.Deprecate -> pure C.TypeEdit.Deprecate
-- | assumes that all relevant values are already in the DB
c2lPatch :: EDB m => C.Branch.Patch -> m (S.PatchLocalIds, S.LocalPatch)
c2lPatch (C.Branch.Patch termEdits typeEdits) =
done =<< (runWriterT . flip evalStateT startState) do
S.Patch
<$> Map.bitraverse saveReferentH (Set.traverse saveTermEdit) termEdits
<*> Map.bitraverse saveReferenceH (Set.traverse saveTypeEdit) typeEdits
-- | assumes that all relevant defns are already in the DB
c2sPatch :: EDB m => C.Branch.Patch -> m S.Patch
c2sPatch (C.Branch.Patch termEdits typeEdits) =
S.Patch
<$> Map.bitraverse saveReferentH (Set.traverse c2sTermEdit) termEdits
<*> Map.bitraverse saveReferenceH (Set.traverse c2sTypeEdit) typeEdits
where
startState = mempty @(Map Text LocalTextId, Map H.Hash LocalHashId, Map H.Hash LocalDefnId)
done ::
EDB m =>
(a, (Seq Text, Seq H.Hash, Seq H.Hash)) ->
m (S.PatchFormat.PatchLocalIds, a)
done (lPatch, (textValues, hashValues, defnValues)) = do
textIds <- liftQ $ traverse Q.saveText textValues
hashIds <- liftQ $ traverse Q.saveHashHash hashValues
objectIds <- traverse primaryHashToExistingObjectId defnValues
let ids =
S.PatchFormat.LocalIds
(Vector.fromList (Foldable.toList textIds))
(Vector.fromList (Foldable.toList hashIds))
(Vector.fromList (Foldable.toList objectIds))
pure (ids, lPatch)
lookupText ::
( 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
lookupHash ::
( MonadState s m,
MonadWriter w m,
Lens.Field2' s (Map d LocalHashId),
Lens.Field2' w (Seq d),
Ord d
) =>
d ->
m LocalHashId
lookupHash = lookup_ Lens._2 Lens._2 LocalHashId
lookupDefn ::
( MonadState s m,
MonadWriter w m,
Lens.Field3' s (Map d LocalDefnId),
Lens.Field3' w (Seq d),
Ord d
) =>
d ->
m LocalDefnId
lookupDefn = lookup_ Lens._3 Lens._3 LocalDefnId
saveTermEdit = \case
C.TermEdit.Replace r t -> S.TermEdit.Replace <$> saveReferent r <*> pure (c2sTyping t)
c2sTermEdit = \case
C.TermEdit.Replace r t -> S.TermEdit.Replace <$> c2sReferent r <*> pure (c2sTyping t)
C.TermEdit.Deprecate -> pure S.TermEdit.Deprecate
saveTypeEdit = \case
C.TypeEdit.Replace r -> S.TypeEdit.Replace <$> saveReference r
c2sTypeEdit = \case
C.TypeEdit.Replace r -> S.TypeEdit.Replace <$> c2sReference r
C.TypeEdit.Deprecate -> pure S.TypeEdit.Deprecate
saveReference = bitraverse lookupText lookupDefn
saveReferenceH = bitraverse lookupText lookupHash
saveReferent = bitraverse saveReference saveReference
saveReferentH = bitraverse saveReferenceH saveReferenceH
-- | produces a diff
-- diff = full - ref; full = diff + ref
diffPatch :: S.LocalPatch -> S.LocalPatch -> S.LocalPatchDiff
@ -463,6 +436,9 @@ diffPatch (S.Patch fullTerms fullTypes) (S.Patch refTerms refTypes) =
-- * Deserialization helpers
decodeTermFormat :: Err m => ByteString -> m S.Term.TermFormat
decodeTermFormat = getFromBytesOr ErrTermFormat S.getTermFormat
decodeComponentLengthOnly :: Err m => ByteString -> m Word64
decodeComponentLengthOnly = getFromBytesOr ErrFramedArrayLen (Get.skip 1 >> S.lengthFramedArray)
@ -475,27 +451,29 @@ decodeTermElementDiscardingTerm i = getFromBytesOr (ErrTermElement i) (S.lookupT
decodeTermElementDiscardingType :: Err m => C.Reference.Pos -> ByteString -> m (LocalIds, S.Term.Term)
decodeTermElementDiscardingType i = getFromBytesOr (ErrTermElement i) (S.lookupTermElementDiscardingType i)
decodeDeclFormat :: Err m => ByteString -> m S.Decl.DeclFormat
decodeDeclFormat = getFromBytesOr ErrDeclFormat S.getDeclFormat
decodeDeclElement :: Err m => Word64 -> ByteString -> m (LocalIds, S.Decl.Decl Symbol)
decodeDeclElement i = getFromBytesOr (ErrDeclElement i) (S.lookupDeclElement i)
-- * legacy conversion helpers
getCycleLen :: EDB m => H.Hash -> m Word64
getCycleLen :: EDB m => H.Hash -> m (Maybe Word64)
getCycleLen h = do
when debug $ traceM $ "\ngetCycleLen " ++ (Text.unpack . Base32Hex.toText $ H.toBase32Hex h)
runMaybeT (primaryHashToExistingObjectId h)
>>= maybe (throwError $ LegacyUnknownCycleLen h) pure
>>= liftQ . Q.loadObjectById
-- todo: decodeComponentLengthOnly is unintentionally a hack that relies on
-- the fact the two things that references can refer to (term and decl
-- components) have the same basic serialized structure: first a format
-- byte that is always 0 for now, followed by a framed array representing
-- the strongly-connected component. :grimace:
>>= decodeComponentLengthOnly
>>= pure . fromIntegral
runMaybeT $
-- actually want Nothing in case of non term/decl component hash
MaybeT (anyHashToMaybeObjectId h)
>>= liftQ . Q.loadObjectById
-- todo: decodeComponentLengthOnly is unintentionally a hack that relies on
-- the fact the two things that references can refer to (term and decl
-- components) have the same basic serialized structure: first a format
-- byte that is always 0 for now, followed by a framed array representing
-- the strongly-connected component. :grimace:
>>= decodeComponentLengthOnly
getDeclTypeByReference :: EDB m => C.Reference.Id -> m C.Decl.DeclType
getDeclTypeByReference r@(C.Reference.Id h pos) =
-- | Get the 'C.DeclType.DeclType' of a 'C.Reference.Id'.
getDeclTypeById :: EDB m => C.Reference.Id -> m C.Decl.DeclType
getDeclTypeById r@(C.Reference.Id h pos) =
runMaybeT (loadDeclByReference r)
>>= maybe (throwError $ LegacyUnknownConstructorType h pos) pure
>>= pure . C.Decl.declType
@ -509,6 +487,18 @@ componentByObjectId id = do
-- * Codebase operations
-- ** Saving & loading terms
loadTermComponent :: EDB m => H.Hash -> MaybeT m [(C.Term Symbol, C.Term.Type Symbol)]
loadTermComponent h = do
MaybeT (anyHashToMaybeObjectId h)
>>= liftQ . Q.loadObjectById
-- retrieve and deserialize the blob
>>= decodeTermFormat
>>= \case
S.Term.Term (S.Term.LocallyIndexedComponent elements) ->
lift . traverse (uncurry3 s2cTermWithType) $
Foldable.toList elements
saveTermComponent :: EDB m => H.Hash -> [(C.Term Symbol, C.Term.Type Symbol)] -> m Db.ObjectId
saveTermComponent h terms = do
when debug . traceM $ "Operations.saveTermComponent " ++ show h
@ -549,10 +539,6 @@ saveTermComponent h terms = do
pure oId
-- | Save the text and hash parts of a Reference to the database and substitute their ids.
saveReferenceH :: DB m => C.Reference' Text H.Hash -> m (C.Reference' Db.TextId Db.HashId)
saveReferenceH = bitraverse Q.saveText Q.saveHashHash
-- | implementation detail of c2{s,w}Term
-- The Type is optional, because we don't store them for watch expression results.
c2xTerm :: forall m t d. Monad m => (Text -> m t) -> (H.Hash -> m d) -> C.Term Symbol -> Maybe (C.Term.Type Symbol) -> m (LocalIds' t d, S.Term.Term, Maybe (S.Term.Type))
@ -705,7 +691,7 @@ s2cTypeOfTerm ids tp = do
(substText, substHash) <- localIdsToLookups loadTextById loadHashByObjectId ids
pure $ x2cTType substText substHash tp
-- | implementation detail of {s,w}2c*Term*
-- | 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
@ -714,6 +700,11 @@ localIdsToLookups loadText loadHash localIds = do
substHash (LocalDefnId w) = hashes Vector.! fromIntegral w
pure (substText, substHash)
localIdsToTypeRefLookup :: EDB m => LocalIds -> m (S.Decl.TypeRef -> C.Decl.TypeRef)
localIdsToTypeRefLookup localIds = do
(substText, substHash) <- localIdsToLookups loadTextById loadHashByObjectId 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 =
@ -809,6 +800,15 @@ w2cTerm ids tm = do
-- ** Saving & loading type decls
loadDeclComponent :: EDB m => H.Hash -> MaybeT m [C.Decl Symbol]
loadDeclComponent h = do
MaybeT (anyHashToMaybeObjectId h)
>>= liftQ . Q.loadObjectById
>>= decodeDeclFormat
>>= \case
S.Decl.Decl (S.Decl.LocallyIndexedComponent elements) ->
lift . traverse (uncurry s2cDecl) $ Foldable.toList elements
saveDeclComponent :: EDB m => H.Hash -> [C.Decl Symbol] -> m Db.ObjectId
saveDeclComponent h decls = do
when debug . traceM $ "Operations.saveDeclComponent " ++ show h
@ -863,26 +863,19 @@ c2sDecl saveText saveDefn (C.Decl.DataDeclaration dt m b cts) = do
(Vector.fromList (Foldable.toList defnIds))
pure (ids, decl)
s2cDecl :: EDB m => LocalIds -> S.Decl.Decl Symbol -> m (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))
loadDeclByReference :: EDB m => C.Reference.Id -> MaybeT m (C.Decl Symbol)
loadDeclByReference r@(C.Reference.Id h i) = do
when debug . traceM $ "loadDeclByReference " ++ show r
-- retrieve the blob
(localIds, C.Decl.DataDeclaration dt m b ct) <-
MaybeT (primaryHashToMaybeObjectId h)
>>= liftQ . Q.loadObjectWithTypeById
>>= \case (OT.DeclComponent, blob) -> pure blob; _ -> mzero
>>= decodeDeclElement i
-- look up the text and hashes that are used by the term
texts <- traverse loadTextById $ LocalIds.textLookup localIds
hashes <- traverse loadHashByObjectId $ LocalIds.defnLookup localIds
-- substitute the text and hashes back into the term
let substText tIdx = texts Vector.! fromIntegral tIdx
substHash hIdx = hashes Vector.! fromIntegral hIdx
substTypeRef :: S.Decl.TypeRef -> C.Decl.TypeRef
substTypeRef = bimap substText (fmap substHash)
pure (C.Decl.DataDeclaration dt m b (C.Type.rmap substTypeRef <$> ct)) -- lens might be nice here
MaybeT (primaryHashToMaybeObjectId h)
>>= liftQ . Q.loadObjectWithTypeById
>>= \case (OT.DeclComponent, blob) -> pure blob; _ -> mzero
>>= decodeDeclElement i
>>= uncurry s2cDecl
-- * Branch transformation
@ -950,15 +943,6 @@ s2cBranch (S.Branch.Full.Branch tms tps patches children) =
Nothing -> throwError (ExpectedBranch' chId)
Just boId -> loadBranchByObjectId boId
-- this maps from the key used by C.Branch to a local id
type BranchSavingState = (Map Text LocalTextId, Map H.Hash LocalDefnId, Map Db.PatchObjectId LocalPatchObjectId, Map (Db.BranchObjectId, Db.CausalHashId) LocalBranchChildId)
type BranchSavingWriter = (Seq Text, Seq H.Hash, Seq Db.PatchObjectId, Seq (Db.BranchObjectId, Db.CausalHashId))
type BranchSavingConstraint m = (MonadState BranchSavingState m, MonadWriter BranchSavingWriter m)
type BranchSavingMonad m = StateT BranchSavingState (WriterT BranchSavingWriter m)
saveRootBranch :: EDB m => C.Branch.Causal m -> m (Db.BranchObjectId, Db.CausalHashId)
saveRootBranch c = do
when debug $ traceM $ "Operations.saveRootBranch " ++ show (C.causalHash c)
@ -966,6 +950,45 @@ saveRootBranch c = do
Q.setNamespaceRoot chId
pure (boId, chId)
-- saveBranch is kind of a "deep save causal"
-- we want a "shallow save causal" that could take a
-- forall m e. Causal m CausalHash BranchHash e
--
-- data Identity a = Identity
-- e == ()
--
-- data C.Branch m = Branch
-- { terms :: Map NameSegment (Map Referent (m MdValues)),
-- types :: Map NameSegment (Map Reference (m MdValues)),
-- patches :: Map NameSegment (PatchHash, m Patch),
-- children :: Map NameSegment (Causal m)
-- }
--
-- U.Codebase.Sqlite.Branch.Full.Branch'
-- type ShallowBranch = Branch' NameSegment Hash PatchHash CausalHash
-- data ShallowBranch causalHash patchHash = ShallowBranch
-- { terms :: Map NameSegment (Map Referent MdValues),
-- types :: Map NameSegment (Map Reference MdValues),
-- patches :: Map NameSegment patchHash,
-- children :: Map NameSegment causalHash
-- }
--
-- data Causal m hc he e = Causal
-- { causalHash :: hc,
-- valueHash :: he,
-- parents :: Map hc (m (Causal m hc he e)),
-- value :: m e
-- }
-- data ShallowCausal causalHash branchHash = ShallowCausal
-- { causalHash :: causalHash,
-- valueHash :: branchHash,
-- parents :: Set causalHash,
-- }
--
-- References, but also values
-- Shallow - Hash? representation of the database relationships
saveBranch :: EDB m => C.Branch.Causal m -> m (Db.BranchObjectId, Db.CausalHashId)
saveBranch (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)
@ -988,95 +1011,41 @@ saveBranch (C.Causal hc he parents me) = do
liftQ (Q.saveCausalParents chId parentCausalHashIds)
pure (chId, bhId)
boId <- flip Monad.fromMaybeM (liftQ $ Q.loadBranchObjectIdByCausalHashId chId) do
(li, lBranch) <- c2lBranch =<< me
branch <- c2sBranch =<< me
let (li, lBranch) = LocalizeObject.localizeBranch branch
saveBranchObject bhId li lBranch
pure (boId, chId)
where
c2lBranch :: EDB m => C.Branch.Branch m -> m (BranchLocalIds, S.Branch.Full.LocalBranch)
c2lBranch (C.Branch.Branch terms types patches children) =
done =<< (runWriterT . flip evalStateT startState) do
S.Branch
<$> Map.bitraverse saveNameSegment (Map.bitraverse saveReferent saveMetadata) terms
<*> Map.bitraverse saveNameSegment (Map.bitraverse saveReference saveMetadata) types
<*> Map.bitraverse saveNameSegment savePatch' patches
<*> Map.bitraverse saveNameSegment saveChild children
saveNameSegment (C.Branch.NameSegment t) = lookupText t
saveReference :: BranchSavingConstraint m => C.Reference.Reference -> m S.Reference.LocalReference
saveReference = bitraverse lookupText lookupDefn
saveReferent :: BranchSavingConstraint m => C.Referent.Referent -> m S.Referent.LocalReferent
saveReferent = bitraverse saveReference saveReference
saveMetadata :: Monad m => m C.Branch.MdValues -> BranchSavingMonad m S.Branch.Full.LocalMetadataSet
saveMetadata mm = do
C.Branch.MdValues m <- (lift . lift) mm
S.Branch.Full.Inline <$> Set.traverse saveReference (Map.keysSet m)
savePatch' :: EDB m => (PatchHash, m C.Branch.Patch) -> BranchSavingMonad m LocalPatchObjectId
savePatch' (h, mp) = do
patchOID <-
primaryHashToMaybePatchObjectId h >>= \case
Just patchOID -> pure patchOID
Nothing -> savePatch h =<< (lift . lift) mp
lookupPatch patchOID
saveChild :: EDB m => C.Branch.Causal m -> BranchSavingMonad m LocalBranchChildId
saveChild c = (lift . lift) (saveBranch c) >>= lookupChild
lookupText ::
( 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 ::
( 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
lookupPatch ::
( MonadState s m,
MonadWriter w m,
Lens.Field3' s (Map p LocalPatchObjectId),
Lens.Field3' w (Seq p),
Ord p
) =>
p ->
m LocalPatchObjectId
lookupPatch = lookup_ Lens._3 Lens._3 LocalPatchObjectId
lookupChild ::
( MonadState s m,
MonadWriter w m,
Lens.Field4' s (Map c LocalBranchChildId),
Lens.Field4' w (Seq c),
Ord c
) =>
c ->
m LocalBranchChildId
lookupChild = lookup_ Lens._4 Lens._4 LocalBranchChildId
startState = mempty @BranchSavingState
saveBranchObject :: DB m => Db.BranchHashId -> BranchLocalIds -> S.Branch.Full.LocalBranch -> m Db.BranchObjectId
saveBranchObject id@(Db.unBranchHashId -> hashId) li lBranch = do
when debug $ traceM $ "saveBranchObject\n\tid = " ++ show id ++ "\n\tli = " ++ show li ++ "\n\tlBranch = " ++ show lBranch
let bytes = S.putBytes S.putBranchFormat $ S.BranchFormat.Full li lBranch
oId <- Q.saveObject hashId OT.Namespace bytes
pure $ Db.BranchObjectId oId
done :: (EDB m, Show a) => (a, BranchSavingWriter) -> m (BranchLocalIds, a)
done (lBranch, written@(textValues, defnHashes, patchObjectIds, branchCausalIds)) = do
when debug $ traceM $ "saveBranch.done\n\tlBranch = " ++ show lBranch ++ "\n\twritten = " ++ show written
textIds <- liftQ $ traverse Q.saveText textValues
defnObjectIds <- traverse primaryHashToExistingObjectId defnHashes
let ids =
S.BranchFormat.LocalIds
(Vector.fromList (Foldable.toList textIds))
(Vector.fromList (Foldable.toList defnObjectIds))
(Vector.fromList (Foldable.toList patchObjectIds))
(Vector.fromList (Foldable.toList branchCausalIds))
pure (ids, lBranch)
c2sBranch :: EDB m => C.Branch.Branch m -> m S.DbBranch
c2sBranch (C.Branch.Branch terms types patches children) =
S.Branch
<$> 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
saveNameSegment :: EDB m => C.Branch.NameSegment -> m Db.TextId
saveNameSegment = liftQ . Q.saveText . C.Branch.unNameSegment
c2sMetadata :: EDB m => m C.Branch.MdValues -> m S.Branch.Full.DbMetadataSet
c2sMetadata mm = do
C.Branch.MdValues m <- mm
S.Branch.Full.Inline <$> Set.traverse c2sReference (Map.keysSet m)
savePatchObjectId :: EDB m => (PatchHash, m C.Branch.Patch) -> m Db.PatchObjectId
savePatchObjectId (h, mp) = do
primaryHashToMaybePatchObjectId h >>= \case
Just patchOID -> pure patchOID
Nothing -> do
patch <- mp
savePatch h patch
saveBranchObject :: DB m => Db.BranchHashId -> BranchLocalIds -> S.Branch.Full.LocalBranch -> m Db.BranchObjectId
saveBranchObject id@(Db.unBranchHashId -> hashId) li lBranch = do
when debug $ traceM $ "saveBranchObject\n\tid = " ++ show id ++ "\n\tli = " ++ show li ++ "\n\tlBranch = " ++ show lBranch
let bytes = S.putBytes S.putBranchFormat $ S.BranchFormat.Full li lBranch
oId <- Q.saveObject hashId OT.Namespace bytes
pure $ Db.BranchObjectId oId
loadRootCausal :: EDB m => m (C.Branch.Causal m)
loadRootCausal = liftQ Q.loadNamespaceRoot >>= loadCausalByCausalHashId
@ -1104,17 +1073,16 @@ loadCausalByCausalHashId id = do
pure (h, loadCausalByCausalHashId hId)
pure $ C.Causal hc hb (Map.fromList loadParents) loadNamespace
-- | is this even a thing? loading a branch by causal hash? yes I guess so.
loadBranchByCausalHashId :: EDB m => Db.CausalHashId -> m (Maybe (C.Branch.Branch m))
loadBranchByCausalHashId id = do
(liftQ . Q.loadBranchObjectIdByCausalHashId) id
>>= traverse loadBranchByObjectId
loadBranchByObjectId :: EDB m => Db.BranchObjectId -> m (C.Branch.Branch m)
loadBranchByObjectId id = do
loadDbBranchByObjectId :: EDB m => Db.BranchObjectId -> m S.DbBranch
loadDbBranchByObjectId id =
deserializeBranchObject id >>= \case
S.BranchFormat.Full li f -> s2cBranch (l2sFull li f)
S.BranchFormat.Diff r li d -> doDiff r [l2sDiff li d]
S.BranchFormat.Full li f -> pure (S.BranchFormat.localToDbBranch li f)
S.BranchFormat.Diff r li d -> doDiff r [S.BranchFormat.localToDbDiff li d]
where
deserializeBranchObject :: EDB m => Db.BranchObjectId -> m S.BranchFormat
deserializeBranchObject id = do
@ -1122,21 +1090,14 @@ loadBranchByObjectId id = do
(liftQ . Q.loadObjectById) (Db.unBranchObjectId id)
>>= getFromBytesOr (ErrBranch id) S.getBranchFormat
l2sFull :: S.BranchFormat.BranchLocalIds -> S.LocalBranch -> S.DbBranch
l2sFull li =
S.Branch.Full.quadmap (lookupBranchLocalText li) (lookupBranchLocalDefn li) (lookupBranchLocalPatch li) (lookupBranchLocalChild li)
l2sDiff :: S.BranchFormat.BranchLocalIds -> S.Branch.LocalDiff -> S.Branch.Diff
l2sDiff li = S.BranchDiff.quadmap (lookupBranchLocalText li) (lookupBranchLocalDefn li) (lookupBranchLocalPatch li) (lookupBranchLocalChild li)
doDiff :: EDB m => Db.BranchObjectId -> [S.Branch.Diff] -> m (C.Branch.Branch m)
doDiff :: EDB m => Db.BranchObjectId -> [S.Branch.Diff] -> m S.DbBranch
doDiff ref ds =
deserializeBranchObject ref >>= \case
S.BranchFormat.Full li f -> joinFull (l2sFull li f) ds
S.BranchFormat.Diff ref' li' d' -> doDiff ref' (l2sDiff li' d' : ds)
S.BranchFormat.Full li f -> joinFull (S.BranchFormat.localToDbBranch li f) ds
S.BranchFormat.Diff ref' li' d' -> doDiff ref' (S.BranchFormat.localToDbDiff li' d' : ds)
where
joinFull :: EDB m => S.DbBranch -> [S.Branch.Diff] -> m (C.Branch.Branch m)
joinFull f [] = s2cBranch f
joinFull :: EDB m => S.DbBranch -> [S.Branch.Diff] -> m S.DbBranch
joinFull f [] = pure f
joinFull
(S.Branch.Full.Branch tms tps patches children)
(S.Branch.Diff tms' tps' patches' children' : ds) = joinFull f' ds
@ -1224,73 +1185,37 @@ loadBranchByObjectId id = do
let (Set.fromList -> adds, Set.fromList -> removes) = S.BranchDiff.addsRemoves md'
in Just . S.MetadataSet.Inline $ (Set.union adds $ Set.difference md removes)
lookupBranchLocalText :: S.BranchLocalIds -> LocalTextId -> Db.TextId
lookupBranchLocalText li (LocalTextId w) = S.BranchFormat.branchTextLookup li Vector.! fromIntegral w
lookupBranchLocalDefn :: S.BranchLocalIds -> LocalDefnId -> Db.ObjectId
lookupBranchLocalDefn li (LocalDefnId w) = S.BranchFormat.branchDefnLookup li Vector.! fromIntegral w
lookupBranchLocalPatch :: BranchLocalIds -> LocalPatchObjectId -> Db.PatchObjectId
lookupBranchLocalPatch li (LocalPatchObjectId w) = S.BranchFormat.branchPatchLookup li Vector.! fromIntegral w
lookupBranchLocalChild :: BranchLocalIds -> LocalBranchChildId -> (Db.BranchObjectId, Db.CausalHashId)
lookupBranchLocalChild li (LocalBranchChildId w) = S.BranchFormat.branchChildLookup li Vector.! fromIntegral w
loadBranchByObjectId :: EDB m => Db.BranchObjectId -> m (C.Branch.Branch m)
loadBranchByObjectId id =
loadDbBranchByObjectId id >>= s2cBranch
-- * Patch transformation
loadPatchById :: EDB m => Db.PatchObjectId -> m C.Branch.Patch
loadPatchById patchId =
loadDbPatchById patchId >>= s2cPatch
loadDbPatchById :: EDB m => Db.PatchObjectId -> m S.Patch
loadDbPatchById patchId =
deserializePatchObject patchId >>= \case
S.PatchFormat.Full li p -> s2cPatch (l2sPatchFull li p)
S.PatchFormat.Diff ref li d -> doDiff ref [l2sPatchDiff li d]
S.Patch.Format.Full li p -> pure (S.Patch.Format.localPatchToPatch li p)
S.Patch.Format.Diff ref li d -> doDiff ref [S.Patch.Format.localPatchDiffToPatchDiff li d]
where
doDiff :: EDB m => Db.PatchObjectId -> [S.PatchDiff] -> m C.Branch.Patch
doDiff :: EDB m => Db.PatchObjectId -> [S.PatchDiff] -> m S.Patch
doDiff ref ds =
deserializePatchObject ref >>= \case
S.PatchFormat.Full li f -> joinFull (l2sPatchFull li f) ds
S.PatchFormat.Diff ref' li' d' -> doDiff ref' (l2sPatchDiff li' d' : ds)
joinFull :: EDB m => S.Patch -> [S.PatchDiff] -> m C.Branch.Patch
joinFull f [] = s2cPatch f
joinFull (S.Patch termEdits typeEdits) (S.PatchDiff addedTermEdits addedTypeEdits removedTermEdits removedTypeEdits : ds) = joinFull f' ds
where
f' = S.Patch (addRemove addedTermEdits removedTermEdits termEdits) (addRemove addedTypeEdits removedTypeEdits typeEdits)
addRemove :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b) -> Map a (Set b)
addRemove add del src =
(Map.unionWith (<>) add (Map.differenceWith remove src del))
remove :: Ord b => Set b -> Set b -> Maybe (Set b)
remove src del =
let diff = Set.difference src del
in if diff == mempty then Nothing else Just diff
-- implementation detail of loadPatchById?
lookupPatchLocalText :: S.PatchLocalIds -> LocalTextId -> Db.TextId
lookupPatchLocalText li (LocalTextId w) = S.PatchFormat.patchTextLookup li Vector.! fromIntegral w
lookupPatchLocalHash :: S.PatchLocalIds -> LocalHashId -> Db.HashId
lookupPatchLocalHash li (LocalHashId w) = S.PatchFormat.patchHashLookup li Vector.! fromIntegral w
lookupPatchLocalDefn :: S.PatchLocalIds -> LocalDefnId -> Db.ObjectId
lookupPatchLocalDefn li (LocalDefnId w) = S.PatchFormat.patchDefnLookup li Vector.! fromIntegral w
l2sPatchFull :: S.PatchFormat.PatchLocalIds -> S.LocalPatch -> S.Patch
l2sPatchFull li =
S.Patch.Full.trimap
(lookupPatchLocalText li)
(lookupPatchLocalHash li)
(lookupPatchLocalDefn li)
l2sPatchDiff :: S.PatchFormat.PatchLocalIds -> S.LocalPatchDiff -> S.PatchDiff
l2sPatchDiff li =
S.PatchDiff.trimap
(lookupPatchLocalText li)
(lookupPatchLocalHash li)
(lookupPatchLocalDefn li)
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 :: EDB m => PatchHash -> C.Branch.Patch -> m Db.PatchObjectId
savePatch h c = do
(li, lPatch) <- c2lPatch c
hashId <- Q.saveHashHash (unPatchHash h)
let bytes = S.putBytes S.putPatchFormat $ S.PatchFormat.Full li lPatch
(li, lPatch) <- LocalizeObject.localizePatch <$> c2sPatch c
saveDbPatch h (S.Patch.Format.Full li lPatch)
saveDbPatch :: EDB m => PatchHash -> S.PatchFormat -> m Db.PatchObjectId
saveDbPatch hash patch = do
hashId <- Q.saveHashHash (unPatchHash hash)
let bytes = S.putBytes S.putPatchFormat patch
Db.PatchObjectId <$> Q.saveObject hashId OT.Patch bytes
s2cPatch :: EDB m => S.Patch -> m C.Branch.Patch
@ -1385,26 +1310,25 @@ declReferentsByPrefix ::
Text ->
Maybe C.Reference.Pos ->
Maybe ConstructorId ->
m [(H.Hash, C.Reference.Pos, Word64, C.DeclType, [C.Decl.ConstructorId])]
m [(H.Hash, C.Reference.Pos, C.DeclType, [C.Decl.ConstructorId])]
declReferentsByPrefix b32prefix pos cid = do
componentReferencesByPrefix OT.DeclComponent b32prefix pos
>>= traverse (loadConstructors cid)
where
loadConstructors :: EDB m => Maybe Word64 -> S.Reference.Id -> m (H.Hash, C.Reference.Pos, Word64, C.DeclType, [ConstructorId])
loadConstructors :: EDB m => Maybe Word64 -> S.Reference.Id -> m (H.Hash, C.Reference.Pos, C.DeclType, [ConstructorId])
loadConstructors cid rid@(C.Reference.Id oId pos) = do
(dt, len, ctorCount) <- getDeclCtorCount rid
(dt, ctorCount) <- getDeclCtorCount rid
h <- loadHashByObjectId oId
let test :: ConstructorId -> Bool
test = maybe (const True) (==) cid
cids = [cid | cid <- [0 :: ConstructorId .. ctorCount - 1], test cid]
pure (h, pos, len, dt, cids)
getDeclCtorCount :: EDB m => S.Reference.Id -> m (C.Decl.DeclType, Word64, ConstructorId)
pure (h, pos, dt, cids)
getDeclCtorCount :: EDB m => S.Reference.Id -> m (C.Decl.DeclType, ConstructorId)
getDeclCtorCount id@(C.Reference.Id r i) = do
when debug $ traceM $ "getDeclCtorCount " ++ show id
bs <- liftQ (Q.loadObjectById r)
len <- decodeComponentLengthOnly bs
(_localIds, decl) <- decodeDeclElement i bs
pure (C.Decl.declType decl, len, fromIntegral $ length (C.Decl.constructorTypes decl))
pure (C.Decl.declType decl, fromIntegral $ length (C.Decl.constructorTypes decl))
branchHashesByPrefix :: EDB m => ShortBranchHash -> m (Set BranchHash)
branchHashesByPrefix (ShortBranchHash b32prefix) = do
@ -1423,8 +1347,14 @@ dependents :: EDB m => C.Reference -> m (Set C.Reference.Id)
dependents r = do
r' <- c2sReference r
sIds :: [S.Reference.Id] <- Q.getDependentsForDependency r'
-- how will you convert this back to Unison.Reference if you
-- don't know the cycle size?
cIds <- traverse s2cReferenceId sIds
pure $ Set.fromList cIds
-- | returns a list of known definitions referencing `h`
dependentsOfComponent :: EDB m => H.Hash -> m (Set C.Reference.Id)
dependentsOfComponent h = do
oId <- primaryHashToExistingObjectId h
sIds :: [S.Reference.Id] <- Q.getDependentsForDependencyComponent oId
cIds <- traverse s2cReferenceId sIds
pure $ Set.fromList cIds

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

@ -1,11 +1,25 @@
{- ORMOLU_DISABLE -} -- Remove this when the file is ready to be auto-formatted
module U.Codebase.Sqlite.Patch.Format where
module U.Codebase.Sqlite.Patch.Format
( PatchFormat (..),
PatchLocalIds (..),
SyncPatchFormat (..),
applyPatchDiffs,
localPatchToPatch,
localPatchDiffToPatchDiff,
)
where
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import U.Codebase.Sqlite.DbId (HashId, ObjectId, PatchObjectId, TextId)
import U.Codebase.Sqlite.Patch.Diff (LocalPatchDiff)
import U.Codebase.Sqlite.Patch.Full (LocalPatch)
import Data.ByteString (ByteString)
import U.Codebase.Sqlite.LocalIds (LocalDefnId (LocalDefnId), LocalHashId (LocalHashId), LocalTextId (LocalTextId))
import U.Codebase.Sqlite.Patch.Diff (LocalPatchDiff, PatchDiff, PatchDiff' (..))
import qualified U.Codebase.Sqlite.Patch.Diff as Patch.Diff
import U.Codebase.Sqlite.Patch.Full (LocalPatch, Patch, Patch' (..))
import qualified U.Codebase.Sqlite.Patch.Full as Patch.Full
import Unison.Prelude
data PatchFormat
= Full PatchLocalIds LocalPatch
@ -19,4 +33,48 @@ data PatchLocalIds = LocalIds
data SyncPatchFormat
= SyncFull PatchLocalIds ByteString
| SyncDiff PatchObjectId PatchLocalIds ByteString
| SyncDiff PatchObjectId PatchLocalIds ByteString
-- | Apply a list of patch diffs to a patch, left to right.
applyPatchDiffs :: Patch -> [PatchDiff] -> Patch
applyPatchDiffs =
foldl' apply
where
apply :: Patch -> PatchDiff -> Patch
apply (Patch termEdits typeEdits) (PatchDiff addedTermEdits addedTypeEdits removedTermEdits removedTypeEdits) =
let !termEdits' = addRemove addedTermEdits removedTermEdits termEdits
!typeEdits' = addRemove addedTypeEdits removedTypeEdits typeEdits
in
Patch
{ termEdits = termEdits',
typeEdits = typeEdits'
}
addRemove :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b) -> Map a (Set b)
addRemove add del src =
Map.unionWith (<>) add (Map.differenceWith remove src del)
remove :: Ord b => Set b -> Set b -> Maybe (Set b)
remove src del =
let diff = Set.difference src del
in if Set.null diff then Nothing else Just diff
localPatchToPatch :: PatchLocalIds -> LocalPatch -> Patch
localPatchToPatch li =
Patch.Full.trimap (lookupPatchLocalText li) (lookupPatchLocalHash li) (lookupPatchLocalDefn li)
localPatchDiffToPatchDiff :: PatchLocalIds -> LocalPatchDiff -> PatchDiff
localPatchDiffToPatchDiff li =
Patch.Diff.trimap
(lookupPatchLocalText li)
(lookupPatchLocalHash li)
(lookupPatchLocalDefn li)
lookupPatchLocalText :: PatchLocalIds -> LocalTextId -> TextId
lookupPatchLocalText li (LocalTextId w) = patchTextLookup li Vector.! fromIntegral w
lookupPatchLocalHash :: PatchLocalIds -> LocalHashId -> HashId
lookupPatchLocalHash li (LocalHashId w) = patchHashLookup li Vector.! fromIntegral w
lookupPatchLocalDefn :: PatchLocalIds -> LocalDefnId -> ObjectId
lookupPatchLocalDefn li (LocalDefnId w) = patchDefnLookup li Vector.! fromIntegral w

33
codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Full.hs
View File

@ -1,19 +1,38 @@
module U.Codebase.Sqlite.Patch.Full where
import Data.Bifunctor (Bifunctor (bimap))
import Control.Lens
import Data.Map (Map)
import Data.Set (Set)
import qualified Data.Set as Set
import U.Codebase.Reference (Reference')
import qualified U.Codebase.Reference as Reference
import U.Codebase.Referent (Referent')
import qualified U.Codebase.Referent as Referent
import qualified U.Codebase.Sqlite.DbId as Db
import U.Codebase.Sqlite.LocalIds (LocalDefnId, LocalHashId, LocalTextId)
import U.Codebase.Sqlite.Patch.TermEdit (TermEdit')
import qualified U.Codebase.Sqlite.Patch.TermEdit as TermEdit
import U.Codebase.Sqlite.Patch.TypeEdit (TypeEdit')
import qualified U.Codebase.Sqlite.Patch.TypeEdit as TypeEdit
import qualified Unison.Util.Map as Map
import qualified Unison.Util.Set as Set
-- |
-- @
-- LocalPatch
-- { termEdits :: Map ReferentH (Set TermEdit),
-- typeEdits :: Map ReferenceH (Set TypeEdit)
-- }
-- @
type Patch = Patch' Db.TextId Db.HashId Db.ObjectId
-- |
-- @
-- LocalPatch
-- { termEdits :: Map LocalReferentH (Set LocalTermEdit),
-- typeEdits :: Map LocalReferenceH (Set LocalTypeEdit)
-- }
-- @
type LocalPatch = Patch' LocalTextId LocalHashId LocalDefnId
type Referent'' t h = Referent' (Reference' t h) (Reference' t h)
@ -23,6 +42,18 @@ data Patch' t h o = Patch
typeEdits :: Map (Reference' t h) (Set (TypeEdit' t o))
}
patchH_ :: (Ord t, Ord h') => Traversal (Patch' t h o) (Patch' t h' o) h h'
patchH_ f Patch {termEdits, typeEdits} = do
newTermEdits <- termEdits & Map.traverseKeys . Referent.refs_ . Reference.h_ %%~ f
newTypeEdits <- typeEdits & Map.traverseKeys . Reference.h_ %%~ f
pure Patch {termEdits = newTermEdits, typeEdits = newTypeEdits}
patchO_ :: (Ord t, Ord o') => Traversal (Patch' t h o) (Patch' t h o') o o'
patchO_ f Patch {termEdits, typeEdits} = do
newTermEdits <- termEdits & traversed . Set.traverse . TermEdit.h_ %%~ f
newTypeEdits <- typeEdits & traversed . Set.traverse . TypeEdit.h_ %%~ f
pure Patch {termEdits = newTermEdits, typeEdits = newTypeEdits}
trimap ::
(Ord t', Ord h', Ord o') =>
(t -> t') ->

16
codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/TermEdit.hs
View File

@ -1,12 +1,13 @@
module U.Codebase.Sqlite.Patch.TermEdit where
import Data.Bifoldable (Bifoldable (bifoldMap))
import Data.Bifunctor (Bifunctor (bimap))
import Data.Bitraversable (Bitraversable (bitraverse))
import U.Codebase.Reference (Reference')
import qualified U.Codebase.Referent as Referent
import qualified U.Codebase.Sqlite.DbId as Db
import U.Codebase.Sqlite.LocalIds (LocalDefnId, LocalTextId)
import Control.Lens
import qualified U.Codebase.Reference as Reference
type TermEdit = TermEdit' Db.TextId Db.ObjectId
@ -17,6 +18,19 @@ type Referent' t h = Referent.Referent' (Reference' t h) (Reference' t h)
data TermEdit' t h = Replace (Referent' t h) Typing | Deprecate
deriving (Eq, Ord, Show)
_Replace :: Prism (TermEdit' t h) (TermEdit' t' h') (Referent' t h, Typing) (Referent' t' h', Typing)
_Replace = prism embed project
where
project :: TermEdit' t h -> Either (TermEdit' t' h') (Referent' t h, Typing)
project (Replace ref typ) = Right (ref, typ)
project Deprecate = Left Deprecate
embed :: (Referent' t' h', Typing) -> TermEdit' t' h'
embed (ref, typ) = Replace ref typ
h_ :: Traversal (TermEdit' t h) (TermEdit' t h') h h'
h_ f = _Replace . _1 . Referent.refs_ . Reference.h_ %%~ f
-- Replacements with the Same type can be automatically propagated.
-- Replacements with a Subtype can be automatically propagated but may result in dependents getting more general types, so requires re-inference.
-- Replacements of a Different type need to be manually propagated by the programmer.

13
codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/TypeEdit.hs
View File

@ -1,11 +1,12 @@
module U.Codebase.Sqlite.Patch.TypeEdit where
import Data.Bifoldable (Bifoldable (bifoldMap))
import Data.Bifunctor (Bifunctor (bimap))
import Data.Bitraversable (Bitraversable (bitraverse))
import U.Codebase.Reference (Reference')
import qualified U.Codebase.Sqlite.DbId as Db
import U.Codebase.Sqlite.LocalIds (LocalDefnId, LocalTextId)
import Control.Lens
import qualified U.Codebase.Reference as Reference
type LocalTypeEdit = TypeEdit' LocalTextId LocalDefnId
@ -14,6 +15,16 @@ type TypeEdit = TypeEdit' Db.TextId Db.ObjectId
data TypeEdit' t h = Replace (Reference' t h) | Deprecate
deriving (Eq, Ord, Show)
_Replace :: Prism (TypeEdit' t h) (TypeEdit' t' h') (Reference' t h) (Reference' t' h')
_Replace = prism Replace project
where
project :: TypeEdit' t h -> Either (TypeEdit' t' h') (Reference' t h)
project (Replace ref) = Right ref
project Deprecate = Left Deprecate
h_ :: Traversal (TypeEdit' t h) (TypeEdit' t h') h h'
h_ = _Replace . Reference.h_
instance Bifunctor TypeEdit' where
bimap f g (Replace r) = Replace (bimap f g r)
bimap _ _ Deprecate = Deprecate

162
codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs
View File

@ -18,7 +18,8 @@
{-# LANGUAGE TypeOperators #-}
module U.Codebase.Sqlite.Queries (
-- * Constraint kinds
DB, Err,
DB, EDB, Err,
-- * Error types
Integrity(..),
@ -32,6 +33,7 @@ module U.Codebase.Sqlite.Queries (
saveHashHash,
loadHashId,
loadHashById,
loadHashHashById,
loadHashIdByHash,
expectHashIdByHash,
saveCausalHash,
@ -46,6 +48,7 @@ module U.Codebase.Sqlite.Queries (
expectObjectIdForAnyHashId,
maybeObjectIdForPrimaryHashId,
maybeObjectIdForAnyHashId,
recordObjectRehash,
-- * object table
saveObject,
@ -86,6 +89,7 @@ module U.Codebase.Sqlite.Queries (
-- ** dependents index
addToDependentsIndex,
getDependentsForDependency,
getDependentsForDependencyComponent,
getDependenciesForDependent,
getDependencyIdsForDependent,
-- ** type index
@ -103,9 +107,21 @@ module U.Codebase.Sqlite.Queries (
namespaceHashIdByBase32Prefix,
causalHashIdByBase32Prefix,
-- * garbage collection
vacuum,
garbageCollectObjectsWithoutHashes,
garbageCollectWatchesWithoutObjects,
-- migrations
countObjects,
countCausals,
countWatches,
getCausalsWithoutBranchObjects,
-- * db misc
createSchema,
schemaVersion,
setSchemaVersion,
setFlags,
DataVersion,
@ -114,6 +130,7 @@ module U.Codebase.Sqlite.Queries (
savepoint,
release,
rollbackRelease,
rollbackTo,
withSavepoint,
withSavepoint_,
@ -260,6 +277,26 @@ schemaVersion = queryAtoms_ sql >>= \case
vs -> error $ show (MultipleSchemaVersions vs)
where sql = "SELECT version from schema_version;"
setSchemaVersion :: DB m => SchemaVersion -> m ()
setSchemaVersion schemaVersion = execute sql (Only schemaVersion)
where
sql = [here|
UPDATE schema_version
SET version = ?
|]
countObjects :: DB m => m Int
countObjects = head <$> queryAtoms_ sql
where sql = [here| SELECT COUNT(*) FROM object |]
countCausals :: DB m => m Int
countCausals = head <$> queryAtoms_ sql
where sql = [here| SELECT COUNT(*) FROM causal |]
countWatches :: DB m => m Int
countWatches = head <$> queryAtoms_ sql
where sql = [here| SELECT COUNT(*) FROM watch |]
saveHash :: DB m => Base32Hex -> m HashId
saveHash base32 = execute sql (Only base32) >> queryOne (loadHashId base32)
where sql = [here|
@ -327,7 +364,7 @@ saveHashObject hId oId version = execute sql (hId, oId, version) where
saveObject :: DB m => HashId -> ObjectType -> ByteString -> m ObjectId
saveObject h t blob = do
oId <- execute sql (h, t, blob) >> queryOne (maybeObjectIdForPrimaryHashId h)
saveHashObject h oId 1 -- todo: remove this from here, and add it to other relevant places once there are v1 and v2 hashes
saveHashObject h oId 2 -- todo: remove this from here, and add it to other relevant places once there are v1 and v2 hashes
pure oId
where
sql = [here|
@ -400,6 +437,19 @@ hashIdWithVersionForObject = query sql . Only where sql = [here|
SELECT hash_id, hash_version FROM hash_object WHERE object_id = ?
|]
-- | @recordObjectRehash old new@ records that object @old@ was rehashed and inserted as a new object, @new@.
--
-- This function rewrites @old@'s @hash_object@ rows in place to point at the new object.
recordObjectRehash :: DB m => ObjectId -> ObjectId -> m ()
recordObjectRehash old new =
execute sql (new, old)
where
sql = [here|
UPDATE hash_object
SET object_id = ?
WHERE object_id = ?
|]
updateObjectBlob :: DB m => ObjectId -> ByteString -> m ()
updateObjectBlob oId bs = execute sql (oId, bs) where sql = [here|
UPDATE object SET bytes = ? WHERE id = ?
@ -543,7 +593,6 @@ clearWatches :: DB m => m ()
clearWatches = do
execute_ "DELETE FROM watch_result"
execute_ "DELETE FROM watch"
execute_ "VACUUM"
-- * Index-building
addToTypeIndex :: DB m => Reference' TextId HashId -> Referent.Id -> m ()
@ -643,6 +692,62 @@ getTypeMentionsReferencesForComponent r =
fixupTypeIndexRow :: Reference' TextId HashId :. Referent.Id -> (Reference' TextId HashId, Referent.Id)
fixupTypeIndexRow (rh :. ri) = (rh, ri)
-- | Delete objects without hashes. An object typically *would* have a hash, but (for example) during a migration in which an object's hash
-- may change, its corresponding hash_object row may be updated to point at a new version of that object. This procedure clears out all
-- references to objects that do not have any corresponding hash_object rows.
garbageCollectObjectsWithoutHashes :: DB m => m ()
garbageCollectObjectsWithoutHashes = do
execute_
[here|
CREATE TEMPORARY TABLE object_without_hash AS
SELECT id
FROM object
WHERE id NOT IN (
SELECT object_id
FROM hash_object
)
|]
execute_
[here|
DELETE FROM dependents_index
WHERE dependency_object_id IN object_without_hash
OR dependent_object_id IN object_without_hash
|]
execute_
[here|
DELETE FROM find_type_index
WHERE term_referent_object_id IN object_without_hash
|]
execute_
[here|
DELETE FROM find_type_mentions_index
WHERE term_referent_object_id IN object_without_hash
|]
execute_
[here|
DELETE FROM object
WHERE id IN object_without_hash
|]
execute_
[here|
DROP TABLE object_without_hash
|]
-- | Delete all
garbageCollectWatchesWithoutObjects :: DB m => m ()
garbageCollectWatchesWithoutObjects = do
execute_
[here|
DELETE FROM watch
WHERE watch.hash_id NOT IN
(SELECT hash_object.hash_id FROM hash_object)
|]
-- | Clean the database and recover disk space.
-- This is an expensive operation. Also note that it cannot be executed within a transaction.
vacuum :: DB m => m ()
vacuum = execute_ "VACUUM"
addToDependentsIndex :: DB m => Reference.Reference -> Reference.Id -> m ()
addToDependentsIndex dependency dependent = execute sql (dependency :. dependent)
where sql = [here|
@ -676,6 +781,22 @@ getDependentsForDependency dependency =
ReferenceBuiltin _ -> const True
ReferenceDerived (C.Reference.Id oid0 _pos0) -> \(C.Reference.Id oid1 _pos1) -> oid0 /= oid1
getDependentsForDependencyComponent :: DB m => ObjectId -> m [Reference.Id]
getDependentsForDependencyComponent dependency =
filter isNotSelfReference <$> query sql (Only dependency)
where
sql =
[here|
SELECT dependent_object_id, dependent_component_index
FROM dependents_index
WHERE dependency_builtin IS NULL
AND dependency_object_id IS ?
|]
isNotSelfReference :: Reference.Id -> Bool
isNotSelfReference = \case
(C.Reference.Id oid1 _pos1) -> dependency /= oid1
-- | Get non-self dependencies of a user-defined dependent.
getDependenciesForDependent :: DB m => Reference.Id -> m [Reference.Reference]
getDependenciesForDependent dependent@(C.Reference.Id oid0 _) =
@ -733,6 +854,18 @@ namespaceHashIdByBase32Prefix prefix = queryAtoms sql (Only $ prefix <> "%") whe
INNER JOIN hash ON id = value_hash_id
WHERE base32 LIKE ?
|]
-- | Finds all causals that refer to a branch for which we don't have an object stored.
-- Although there are plans to support this in the future, currently all such cases
-- are the result of database inconsistencies and are unexpected.
getCausalsWithoutBranchObjects :: DB m => m [CausalHashId]
getCausalsWithoutBranchObjects = queryAtoms_ sql
where sql = [here|
SELECT self_hash_id from causal
WHERE value_hash_id NOT IN (SELECT hash_id FROM hash_object)
|]
{- ORMOLU_ENABLE -}
before :: DB m => CausalHashId -> CausalHashId -> m Bool
@ -889,12 +1022,33 @@ withImmediateTransaction action = do
-- | low-level transaction stuff
savepoint, release, rollbackTo, rollbackRelease :: DB m => String -> m ()
-- | Create a savepoint, which is a named transaction which may wrap many nested
-- sub-transactions.
savepoint :: DB m => String -> m ()
savepoint name = execute_ (fromString $ "SAVEPOINT " ++ name)
-- | Release a savepoint, which will commit the results once all
-- wrapping transactions/savepoints are commited.
release :: DB m => String -> m ()
release name = execute_ (fromString $ "RELEASE " ++ name)
-- | Roll the database back to its state from when the savepoint was created.
-- Note: this also re-starts the savepoint and it must still be released if that is the
-- intention. See 'rollbackRelease'.
rollbackTo :: DB m => String -> m ()
rollbackTo name = execute_ (fromString $ "ROLLBACK TO " ++ name)
-- | Roll back the savepoint and immediately release it.
-- This effectively _aborts_ the savepoint, useful if an irrecoverable error is
-- encountered.
rollbackRelease :: DB m => String -> m ()
rollbackRelease name = rollbackTo name *> release name
-- | Runs the provided action within a savepoint.
-- Releases the savepoint on completion.
-- If an exception occurs, the savepoint will be rolled-back and released,
-- abandoning all changes.
withSavepoint :: (MonadUnliftIO m, DB m) => String -> (m () -> m r) -> m r
withSavepoint name action =
UnliftIO.bracket_

5
codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs
View File

@ -349,9 +349,10 @@ lookupTermElementDiscardingTerm i =
getTType :: MonadGet m => m TermFormat.Type
getTType = getType getReference
getType :: MonadGet m => m r -> m (Type.TypeR r Symbol)
getType :: forall m r. MonadGet m => m r -> m (Type.TypeR r Symbol)
getType getReference = getABT getSymbol getUnit go
where
go :: m x -> m (Type.F' r x)
go getChild =
getWord8 >>= \case
0 -> Type.Ref <$> getReference
@ -808,6 +809,7 @@ putDType :: MonadPut m => DeclFormat.Type Symbol -> m ()
putDType = putType putRecursiveReference putSymbol
putType ::
forall m r v.
(MonadPut m, Ord v) =>
(r -> m ()) ->
(v -> m ()) ->
@ -815,6 +817,7 @@ putType ::
m ()
putType putReference putVar = putABT putVar putUnit go
where
go :: (x -> m ()) -> Type.F' r x -> m ()
go putChild t = case t of
Type.Ref r -> putWord8 0 *> putReference r
Type.Arrow i o -> putWord8 1 *> putChild i *> putChild o

31
codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs
View File

@ -361,22 +361,27 @@ trySync tCache hCache oCache cCache = \case
srcParents <- runSrc $ Q.loadCausalParents chId
traverse syncCausal srcParents
-- Sync any watches of the given kinds to the dest if and only if watches of those kinds
-- exist in the src.
syncWatch :: WK.WatchKind -> Sqlite.Reference.IdH -> m (TrySyncResult Entity)
syncWatch wk r | debug && trace ("Sync22.syncWatch " ++ show wk ++ " " ++ show r) False = undefined
syncWatch wk r = do
r' <- traverse syncHashLiteral r
doneKinds <- runDest (Q.loadWatchKindsByReference r')
if (notElem wk doneKinds) then do
runSrc (Q.loadWatch wk r) >>= traverse \blob -> do
TL.SyncWatchResult li body <-
either (throwError . DecodeError ErrWatchResult blob) pure $ runGetS S.decomposeWatchFormat blob
li' <- bitraverse syncTextLiteral syncHashLiteral li
when debug $ traceM $ "LocalIds for Source watch result " ++ show r ++ ": " ++ show li
when debug $ traceM $ "LocalIds for Dest watch result " ++ show r' ++ ": " ++ show li'
let blob' = runPutS $ S.recomposeWatchFormat (TL.SyncWatchResult li' body)
runDest (Q.saveWatch wk r' blob')
pure Sync.Done
else pure Sync.PreviouslyDone
runSrc (Q.loadWatch wk r) >>= \case
Nothing -> pure Sync.Done
Just blob -> do
r' <- traverse syncHashLiteral r
doneKinds <- runDest (Q.loadWatchKindsByReference r')
if (elem wk doneKinds)
then pure Sync.PreviouslyDone
else do
TL.SyncWatchResult li body <-
either (throwError . DecodeError ErrWatchResult blob) pure $ runGetS S.decomposeWatchFormat blob
li' <- bitraverse syncTextLiteral syncHashLiteral li
when debug $ traceM $ "LocalIds for Source watch result " ++ show r ++ ": " ++ show li
when debug $ traceM $ "LocalIds for Dest watch result " ++ show r' ++ ": " ++ show li'
let blob' = runPutS $ S.recomposeWatchFormat (TL.SyncWatchResult li' body)
runDest (Q.saveWatch wk r' blob')
pure Sync.Done
syncSecondaryHashes oId oId' =
runSrc (Q.hashIdWithVersionForObject oId) >>= traverse_ (go oId')

72
codebase2/codebase-sqlite/U/Codebase/Sqlite/Term/Format.hs
View File

@ -7,25 +7,91 @@ import Data.ByteString (ByteString)
import Data.Vector (Vector)
import U.Codebase.Reference (Reference')
import U.Codebase.Referent (Referent')
import U.Codebase.Sqlite.LocalIds
( LocalIds', LocalTextId, LocalDefnId, WatchLocalIds )
import U.Codebase.Sqlite.Symbol ( Symbol )
import U.Codebase.Sqlite.LocalIds (LocalDefnId, LocalIds', LocalTextId, WatchLocalIds)
import U.Codebase.Sqlite.Symbol (Symbol)
import qualified U.Codebase.Term as Term
import qualified U.Core.ABT as ABT
import qualified U.Codebase.Type as Type
import qualified U.Codebase.Sqlite.Reference as Sqlite
import U.Codebase.Sqlite.DbId (ObjectId, TextId)
-- |
-- * Builtin terms are represented as local text ids.
-- * Non-builtin terms are represented as local definition ids, with an added distinguished element (here @Nothing@)
-- which represents a self-reference.
type TermRef = Reference' LocalTextId (Maybe LocalDefnId)
-- |
-- * Builtin types are represented as a local text id.
-- * Non-builtin types are represented by a local definition id.
type TypeRef = Reference' LocalTextId LocalDefnId
type TermLink = Referent' TermRef TypeRef
type TypeLink = TypeRef
-- | A 'LocallyIndexedComponent' is a vector that has one element per member of the component (invariant: 1+).
--
-- Each element is a term, which is represented as:
--
-- * Lookup vectors that map local ids to database ids for texts and objects referenced by the term.
-- * The term itself, with internal references to local ids (offsets into the lookup vectors).
-- * 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))
deriving Show
{-
message = "hello, world" -> ABT { ... { Term.F.Text "hello, world" } } -> hashes to (#abc, 0)
program = printLine message -> ABT { ... { Term.F.App (ReferenceBuiltin ##io.PrintLine) (Reference #abc 0) } } -> hashes to (#def, 0)
text table =
id text
-- ------------
1 hello, world
2 message
3 program
4 Text
5 IO
6 Unit
7 io.PrintLine
hash table =
id base32
-- ------
10 abc
11 def
hash_object table =
hash_id object_id hash_version
------- --------- ------------
10 20 2
object table =
{ 20 ->
LocallyIndexedComponent [
(localIds = LocalIds {
text = [1,4]
defs = []
},
term = ABT { ... { Term.F.Text (LocalTextId 0) } },
type = ABT { ... { Term.FT.Ref (Builtin (LocalTextId 1)) }}
)
],
21 ->
LocallyIndexedComponent [
(localIds = LocalIds {
text = [7,5,6]
defs = [20]
},
term = ABT { ... { Term.F.App (ReferenceBuiltin (LocalTextId 7) (ReferenceId (LocalDefnId 0) 0) } },
type = ABT { ... { Term.FT.App (Term.FT.Ref (Builtin (LocalTextId 0))) (Term.FT.Ref (Builtin (LocalTextId 1))) } }
)
],
}
-}
type F =
Term.F' LocalTextId TermRef TypeRef TermLink TypeLink Symbol

24
codebase2/codebase-sqlite/package.yaml
View File

@ -1,6 +1,29 @@
name: unison-codebase-sqlite
github: unisonweb/unison
default-extensions:
- ApplicativeDo
- BangPatterns
- BlockArguments
- ConstraintKinds
- DeriveFunctor
- DerivingStrategies
- DoAndIfThenElse
- FlexibleContexts
- FlexibleInstances
- FunctionalDependencies
- GeneralizedNewtypeDeriving
- InstanceSigs
- LambdaCase
- MultiParamTypeClasses
- NamedFieldPuns
- PatternSynonyms
- ScopedTypeVariables
- TupleSections
- TypeApplications
- TypeFamilies
- TypeFamilyDependencies
library:
source-dirs: .
@ -15,6 +38,7 @@ dependencies:
- extra
- here
- lens
- generic-lens
- monad-validate
- mtl
- safe

14
codebase2/codebase-sqlite/sql/create.sql
View File

@ -3,7 +3,7 @@
CREATE TABLE schema_version (
version INTEGER NOT NULL
);
INSERT INTO schema_version (version) VALUES (1);
INSERT INTO schema_version (version) VALUES (2);
-- actually stores the 512-byte hashes
CREATE TABLE hash (
@ -120,20 +120,30 @@ CREATE TABLE causal_metadata (
CREATE INDEX causal_metadata_causal_id ON causal_metadata(causal_id);
CREATE TABLE watch_result (
-- See Note [Watch expression identifier]
hash_id INTEGER NOT NULL CONSTRAINT watch_result_fk1 REFERENCES hash(id),
component_index INTEGER NOT NULL,
result BLOB NOT NULL,
result BLOB NOT NULL, -- evaluated result of the watch expression
PRIMARY KEY (hash_id, component_index)
) WITHOUT ROWID;
CREATE TABLE watch (
-- See Note [Watch expression identifier]
hash_id INTEGER NOT NULL CONSTRAINT watch_fk1 REFERENCES hash(id),
component_index INTEGER NOT NULL,
watch_kind_id INTEGER NOT NULL CONSTRAINT watch_fk2 REFERENCES watch_kind_description(id),
PRIMARY KEY (hash_id, component_index, watch_kind_id)
) WITHOUT ROWID;
CREATE INDEX watch_kind ON watch(watch_kind_id);
-- Note [Watch expression identifier]
-- The hash_id + component_index is an unevaluated term reference. We use hash_id instead of object_id because the
-- unevaluated term may not exist in the codebase: it is not added merely by watching it without a name, e.g `> 2 + 3`.
CREATE TABLE watch_kind_description (
id INTEGER PRIMARY KEY NOT NULL,
description TEXT UNIQUE NOT NULL

25
codebase2/codebase-sqlite/unison-codebase-sqlite.cabal
View File

@ -21,11 +21,13 @@ library
U.Codebase.Sqlite.Branch.Diff
U.Codebase.Sqlite.Branch.Format
U.Codebase.Sqlite.Branch.Full
U.Codebase.Sqlite.Causal
U.Codebase.Sqlite.Connection
U.Codebase.Sqlite.DbId
U.Codebase.Sqlite.Decl.Format
U.Codebase.Sqlite.JournalMode
U.Codebase.Sqlite.LocalIds
U.Codebase.Sqlite.LocalizeObject
U.Codebase.Sqlite.ObjectType
U.Codebase.Sqlite.Operations
U.Codebase.Sqlite.Patch.Diff
@ -44,12 +46,35 @@ library
Paths_unison_codebase_sqlite
hs-source-dirs:
./
default-extensions:
ApplicativeDo
BangPatterns
BlockArguments
ConstraintKinds
DeriveFunctor
DerivingStrategies
DoAndIfThenElse
FlexibleContexts
FlexibleInstances
FunctionalDependencies
GeneralizedNewtypeDeriving
InstanceSigs
LambdaCase
MultiParamTypeClasses
NamedFieldPuns
PatternSynonyms
ScopedTypeVariables
TupleSections
TypeApplications
TypeFamilies
TypeFamilyDependencies
build-depends:
base
, bytes
, bytestring
, containers
, extra
, generic-lens
, here
, lens
, monad-validate

4
codebase2/codebase/U/Codebase/Branch.hs
View File

@ -12,7 +12,7 @@ import U.Codebase.TermEdit (TermEdit)
import U.Codebase.TypeEdit (TypeEdit)
import qualified Data.Map as Map
newtype NameSegment = NameSegment Text deriving (Eq, Ord, Show)
newtype NameSegment = NameSegment { unNameSegment :: Text } deriving (Eq, Ord, Show)
type MetadataType = Reference
type MetadataValue = Reference
@ -37,4 +37,4 @@ instance Show (Branch m) where
show b = "Branch { terms = " ++ show (fmap Map.keys (terms b)) ++
", types = " ++ show (fmap Map.keys (types b)) ++
", patches = " ++ show (fmap fst (patches b)) ++
", children = " ++ show (Map.keys (children b))
", children = " ++ show (Map.keys (children b))

17
codebase2/codebase/U/Codebase/Reference.hs
View File

@ -11,7 +11,7 @@ module U.Codebase.Reference where
import Data.Text (Text)
import Data.Word (Word64)
import U.Util.Hash (Hash)
import Control.Lens (lens, Lens, Bifunctor(..), Traversal)
import Control.Lens (lens, Lens, Bifunctor(..), Traversal, Prism, prism)
import Data.Bitraversable (Bitraversable(..))
import Data.Bifoldable (Bifoldable(..))
@ -24,6 +24,13 @@ data Reference' t h
| ReferenceDerived (Id' h)
deriving (Eq, Ord, Show)
_ReferenceDerived :: Prism (Reference' t h) (Reference' t h') (Id' h) (Id' h')
_ReferenceDerived = prism embed project
where
embed (Id h pos) = ReferenceDerived (Id h pos)
project (ReferenceDerived id') = Right id'
project (ReferenceBuiltin t) = Left (ReferenceBuiltin t)
pattern Derived :: h -> Pos -> Reference' t h
pattern Derived h i = ReferenceDerived (Id h i)
@ -33,13 +40,13 @@ type Pos = Word64
data Id' h = Id h Pos
deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
t :: Traversal (Reference' t h) (Reference' t' h) t t'
t f = \case
t_ :: Traversal (Reference' t h) (Reference' t' h) t t'
t_ f = \case
ReferenceBuiltin t -> ReferenceBuiltin <$> f t
ReferenceDerived id -> pure (ReferenceDerived id)
h :: Traversal (Reference' t h) (Reference' t h') h h'
h f = \case
h_ :: Traversal (Reference' t h) (Reference' t h') h h'
h_ f = \case
ReferenceBuiltin t -> pure (ReferenceBuiltin t)
Derived h i -> Derived <$> f h <*> pure i

30
codebase2/codebase/U/Codebase/Referent.hs
View File

@ -2,10 +2,12 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveTraversable #-}
module U.Codebase.Referent where
import Data.Text (Text)
import U.Codebase.Reference (Reference, Reference')
import qualified U.Codebase.Reference as Reference
import U.Util.Hash (Hash)
@ -13,14 +15,32 @@ import Data.Bifunctor (Bifunctor(..))
import Data.Bifoldable (Bifoldable(..))
import Data.Bitraversable (Bitraversable(..))
import U.Codebase.Decl (ConstructorId)
import Control.Lens (Prism, Traversal)
import Data.Generics.Sum (_Ctor)
import Unison.Prelude
type Referent = Referent' Reference Reference
type ReferentH = Referent' (Reference' Text (Maybe Hash)) (Reference' Text Hash)
data Referent' rTm rTp
= Ref rTm
| Con rTp ConstructorId
deriving (Eq, Ord, Show)
data Referent' termRef typeRef
= Ref termRef
| Con typeRef ConstructorId
deriving (Eq, Ord, Show, Generic, Functor, Foldable, Traversable)
refs_ :: Traversal (Referent' ref ref) (Referent' ref' ref') ref ref'
refs_ f r = bitraverse f f r
typeRef_ :: Traversal (Referent' typeRef termRef) (Referent' typeRef' termRef) typeRef typeRef'
typeRef_ f = bitraverse f pure
termRef_ :: Traversal (Referent' typeRef termRef) (Referent' typeRef termRef') termRef termRef'
termRef_ f = bitraverse pure f
_Ref :: Prism (Referent' tmr tyr) (Referent' tmr' tyr) tmr tmr'
_Ref = _Ctor @"Ref"
_Con :: Prism (Referent' tmr tyr) (Referent' tmr tyr') (tyr, ConstructorId) (tyr', ConstructorId)
_Con = _Ctor @"Con"
type Id = Id' Hash Hash
data Id' hTm hTp

4
codebase2/codebase/U/Codebase/Term.hs
View File

@ -110,10 +110,10 @@ data Pattern t r
| PFloat !Double
| PText !t
| PChar !Char
| PConstructor !r !Int [Pattern t r]
| PConstructor !r !ConstructorId [Pattern t r]
| PAs (Pattern t r)
| PEffectPure (Pattern t r)
| PEffectBind !r !Int [Pattern t r] (Pattern t r)
| PEffectBind !r !ConstructorId [Pattern t r] (Pattern t r)
| PSequenceLiteral [Pattern t r]
| PSequenceOp (Pattern t r) !SeqOp (Pattern t r)
deriving (Generic, Functor, Foldable, Traversable, Show)

19
codebase2/codebase/package.yaml
View File

@ -1,14 +1,33 @@
name: unison-codebase
github: unisonweb/unison
default-extensions:
- ApplicativeDo
- BlockArguments
- DeriveFunctor
- DeriveGeneric
- DerivingStrategies
- DoAndIfThenElse
- FlexibleContexts
- FlexibleInstances
- LambdaCase
- MultiParamTypeClasses
- NamedFieldPuns
- PatternSynonyms
- ScopedTypeVariables
- TupleSections
- TypeApplications
library:
source-dirs: .
dependencies:
- base
- containers
- generic-lens
- lens
- mtl
- text
- unison-core
- unison-util
- unison-prelude

20
codebase2/codebase/unison-codebase.cabal
View File

@ -4,7 +4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
-- hash: 007d5ba1a9afa5423c79bb923619ab440794eb2496188191ac82b66ee645901c
-- hash: b4d3c77715f39c915cacffccf179f1ed62bce29ba013cecc3a25c847f5851233
name: unison-codebase
version: 0.0.0
@ -36,12 +36,30 @@ library
Paths_unison_codebase
hs-source-dirs:
./
default-extensions:
ApplicativeDo
BlockArguments
DeriveFunctor
DeriveGeneric
DerivingStrategies
DoAndIfThenElse
FlexibleContexts
FlexibleInstances
LambdaCase
MultiParamTypeClasses
NamedFieldPuns
PatternSynonyms
ScopedTypeVariables
TupleSections
TypeApplications
build-depends:
base
, containers
, generic-lens
, lens
, mtl
, text
, unison-core
, unison-prelude
, unison-util
default-language: Haskell2010

3
codebase2/util-serialization/U/Util/Serialization.hs
View File

@ -218,8 +218,7 @@ putFramedArray put (toList -> as) = do
getFramedArray :: MonadGet m => m a -> m (Vector a)
getFramedArray getA = do
offsets :: [Int] <- getList getVarInt
_end <- getVarInt @_ @Int
let count = length offsets
let count = length offsets - 1
Vector.replicateM count getA
-- | Look up a 0-based index in a framed array, O(num array elements),

1
codebase2/util/package.yaml
View File

@ -27,6 +27,7 @@ dependencies:
- time
- unison-util-relation
- unliftio
- vector
default-extensions:
- ApplicativeDo

2
codebase2/util/unison-util.cabal
View File

@ -60,6 +60,7 @@ library
, time
, unison-util-relation
, unliftio
, vector
default-language: Haskell2010
benchmark bench
@ -102,4 +103,5 @@ benchmark bench
, unison-util
, unison-util-relation
, unliftio
, vector
default-language: Haskell2010

84
docs/repoformats/v2.markdown
View File

@ -248,3 +248,87 @@ data BranchLocalIds = LocalIds
`PatchObjectIds` reference the object ids of patch objects, as you might imagine.
`branchChildLookup` contains two fields: a `CausalHashId` which points to the history of the child, and the `BranchObjectId` which proves that the relevant namespace slice is also present. In general, a codebase may not have the namespace slice corresponding to every causal id, but it ought to have them for the children of another namespace slice it does have (thus, the `BranchObjectId` is used). The causal relationship stored relationally rather than as blobs, and the `CausalHashId` is a useful index into the `causal_parents` table.
<!---
Here are some examples that Arya Chris Mitchell worked through during their onboarding
{-
projects.arya.message = "hello, world" -> <text constant> -> #abc
projects.arya.program = printLine message -> printLine #abc -> #def
projects.arya {
terms = { "message" -> #abc
, "program" -> #def
}
}
text table =
{ 1 -> "hello, world"
, 2 -> "message"
, 3 -> "program"
}
hash table =
{ 10 -> "abc"
, 11 -> "def"
}
object table =
{ ...
}
projects.arya {
terms = { TextId 2 -> Reference { builtin = null, object = ObjectId 20, position = 0 }
, TextId 3 -> Reference { builtin = null, object = ObjectId 21, position = 0 }
}
}
stored in original codebase:
projects.arya = BranchFormat.Full {
localIds = {
text = [2, 3]
hash = [10, 11]
object = [20, 21]
}
localBranch = {
terms = { LocalTextId 0 -> Reference { builtin = null, object = LocalObjectId 0, position = 0 }
, LocalTextId 1 -> Reference { builtin = null, object = LocalObjectId 1, position = 0 }
}
...
}
}
write to dest codebase:
text table =
{ ...
, 901 -> "hello, world"
, 902 -> "message"
, 903 -> "program"
}
hash table =
{ ...
, 500 -> "abc"
, 501 -> "def"
}
projects.arya {
-- updated copy of original localIds, with new mapping
localIds = {
text = [902, 903]
hash = [500, 501]
object = [300, 301]
}
-- copy unmodified from original
localBranch = {
terms = { LocalTextId 0 -> Reference { builtin = null, object = LocalObjectId 0, position = 0 }
, LocalTextId 1 -> Reference { builtin = null, object = LocalObjectId 1, position = 0 }
}
...
}
}
-->

2
lib/unison-prelude/package.yaml
View File

@ -15,6 +15,8 @@ dependencies:
- safe
- text
- transformers
- lens
- vector
- unliftio
ghc-options:

30
lib/unison-prelude/src/Unison/Util/Map.hs
View File

@ -1,18 +1,28 @@
{-# LANGUAGE RankNTypes #-}
-- | @Map@ utilities.
module Unison.Util.Map
( bimap,
bitraverse,
bitraversed,
deleteLookup,
foldMapM,
unionWithM,
traverseKeys,
traverseKeysWith,
swap,
valuesVector,
)
where
import Control.Lens hiding (bimap)
import qualified Control.Monad as Monad
import qualified Data.Bifunctor as B
import qualified Data.Bitraversable as B
import Data.Foldable (foldlM)
import qualified Data.Map.Strict as Map
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import Unison.Prelude
bimap :: Ord a' => (a -> a') -> (b -> b') -> Map a b -> Map a' b'
@ -21,6 +31,19 @@ bimap fa fb = Map.fromList . map (B.bimap fa fb) . Map.toList
bitraverse :: (Applicative f, Ord a') => (a -> f a') -> (b -> f b') -> Map a b -> f (Map a' b')
bitraverse fa fb = fmap Map.fromList . traverse (B.bitraverse fa fb) . Map.toList
bitraversed :: (Ord a', Ord k') => Traversal k k' a a' -> Traversal v v' a a' -> Traversal (Map k v) (Map k' v') a a'
bitraversed keyT valT f m =
bitraverse (keyT f) (valT f) m
-- | 'swap' throws away data if the input contains duplicate values
swap :: Ord b => Map a b -> Map b a
swap =
Map.foldlWithKey' (\z a b -> Map.insert b a z) mempty
valuesVector :: Map k v -> Vector v
valuesVector =
Vector.fromList . Map.elems
-- | Like 'Map.delete', but returns the value as well.
deleteLookup :: Ord k => k -> Map k v -> (Maybe v, Map k v)
deleteLookup =
@ -51,3 +74,10 @@ unionWithM f m1 m2 =
go m1 (k, a2) = case Map.lookup k m1 of
Just a1 -> do a <- f a1 a2; pure $ Map.insert k a m1
Nothing -> pure $ Map.insert k a2 m1
traverseKeys :: (Applicative f, Ord k') => (k -> f k') -> Map k v -> f (Map k' v)
traverseKeys f = bitraverse f pure
traverseKeysWith :: (Applicative f, Ord k') => (v -> v -> v) -> (k -> f k') -> Map k v -> f (Map k' v)
traverseKeysWith combine f m =
Map.fromListWith combine <$> (Map.toList m & traversed . _1 %%~ f)

2
lib/unison-prelude/unison-prelude.cabal
View File

@ -44,9 +44,11 @@ library
, containers
, either
, extra
, lens
, mtl
, safe
, text
, transformers
, unliftio
, vector
default-language: Haskell2010

3
parser-typechecker/package.yaml
View File

@ -66,6 +66,7 @@ library:
- fingertree
- fsnotify
- generic-monoid
- generic-lens
- hashable
- hashtables
- haskeline
@ -95,6 +96,7 @@ library:
- regex-tdfa
- safe
- safe-exceptions
- semialign
- mwc-random
- NanoID
- lucid
@ -137,6 +139,7 @@ library:
- unison-util-relation
- open-browser
- uri-encode
- generic-lens
executables:
prettyprintdemo:

13
parser-typechecker/src/Unison/Builtin.hs
View File

@ -11,6 +11,7 @@ module Unison.Builtin
,builtinEffectDecls
,builtinConstructorType
,builtinTypeDependents
,builtinTypeDependentsOfComponent
,builtinTypes
,builtinTermsByType
,builtinTermsByTypeMention
@ -35,6 +36,7 @@ import Unison.Codebase.CodeLookup ( CodeLookup(..) )
import qualified Unison.Builtin.Decls as DD
import qualified Unison.Builtin.Terms as TD
import qualified Unison.DataDeclaration as DD
import Unison.Hash (Hash)
import Unison.Parser.Ann (Ann (..))
import qualified Unison.Reference as R
import qualified Unison.Referent as Referent
@ -64,7 +66,7 @@ names0 = Names terms types where
((CT.Effect,) . (second . second) DD.toDataDecl <$> builtinEffectDecls)
, ((_,vc,_), cid) <- DD.constructors' decl `zip` [0..]] <>
Rel.fromList [ (Name.unsafeFromVar v, Referent.Ref (R.DerivedId i))
| (v,i) <- Map.toList $ TD.builtinTermsRef Intrinsic]
| (v,i) <- Map.toList $ TD.builtinTermsRef]
types = Rel.fromList builtinTypes <>
Rel.fromList [ (Name.unsafeFromVar v, R.DerivedId r)
| (v,(r,_)) <- builtinDataDecls ] <>
@ -123,6 +125,15 @@ builtinTermsByTypeMention =
builtinTypeDependents :: R.Reference -> Set R.Reference
builtinTypeDependents r = Rel.lookupRan r builtinDependencies
builtinTypeDependentsOfComponent :: Hash -> Set R.Reference
builtinTypeDependentsOfComponent h0 = Rel.searchRan ord builtinDependencies
where
ord :: R.Reference -> Ordering
ord = \case
R.Derived h _i -> compare h h0
r -> compare r r0
r0 = R.Derived h0 0
-- WARNING:
-- As with the terms, we should avoid changing these references, even
-- if we decide to change their names.

15
parser-typechecker/src/Unison/Builtin/Decls.hs
View File

@ -17,11 +17,11 @@ import Unison.DataDeclaration
Modifier (Structural, Unique),
)
import qualified Unison.DataDeclaration as DD
import Unison.Hashing.V2.Convert (hashDecls)
import Unison.Hashing.V2.Convert (hashDataDecls)
import qualified Unison.Pattern as Pattern
import Unison.Reference (Reference)
import qualified Unison.Reference as Reference
import Unison.Referent (ConstructorId, Referent)
import Unison.Referent (Referent)
import qualified Unison.Referent as Referent
import Unison.Symbol (Symbol)
import Unison.Term (Term, Term2)
@ -30,6 +30,7 @@ import Unison.Type (Type)
import qualified Unison.Type as Type
import Unison.Var (Var)
import qualified Unison.Var as Var
import Unison.DataDeclaration.ConstructorId (ConstructorId)
lookupDeclRef :: Text -> Reference
lookupDeclRef str
@ -81,10 +82,10 @@ pairCtorRef, unitCtorRef :: Referent
pairCtorRef = Referent.Con (ConstructorReference pairRef 0) CT.Data
unitCtorRef = Referent.Con (ConstructorReference unitRef 0) CT.Data
constructorId :: Reference -> Text -> Maybe Int
constructorId :: Reference -> Text -> Maybe ConstructorId
constructorId ref name = do
(_,_,dd) <- find (\(_,r,_) -> Reference.DerivedId r == ref) builtinDataDecls
elemIndex name $ DD.constructorNames dd
fmap fromIntegral . elemIndex name $ DD.constructorNames dd
noneId, someId, okConstructorId, failConstructorId, docBlobId, docLinkId, docSignatureId, docSourceId, docEvaluateId, docJoinId, linkTermId, linkTypeId, eitherRightId, eitherLeftId :: ConstructorId
isPropagatedConstructorId, isTestConstructorId, bufferModeNoBufferingId, bufferModeLineBufferingId, bufferModeBlockBufferingId, bufferModeSizedBlockBufferingId :: ConstructorId
@ -122,10 +123,10 @@ failConstructorReferent = Referent.Con (ConstructorReference testResultRef failC
builtinDataDecls :: [(Symbol, Reference.Id, DataDeclaration Symbol ())]
builtinDataDecls = rs1 ++ rs
where
rs1 = case hashDecls $ Map.fromList
rs1 = case hashDataDecls $ Map.fromList
[ (v "Link" , link)
] of Right a -> a; Left e -> error $ "builtinDataDecls: " <> show e
rs = case hashDecls $ Map.fromList
rs = case hashDataDecls $ Map.fromList
[ (v "Unit" , unit)
, (v "Tuple" , tuple)
, (v "Optional" , opt)
@ -311,7 +312,7 @@ builtinDataDecls = rs1 ++ rs
builtinEffectDecls :: [(Symbol, Reference.Id, DD.EffectDeclaration Symbol ())]
builtinEffectDecls =
case hashDecls $ Map.fromList [ (v "Exception", exception) ] of
case hashDataDecls $ Map.fromList [ (v "Exception", exception) ] of
Right a -> over _3 DD.EffectDeclaration <$> a
Left e -> error $ "builtinEffectDecls: " <> show e
where

25
parser-typechecker/src/Unison/Builtin/Terms.hs
View File

@ -2,7 +2,10 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module Unison.Builtin.Terms where
module Unison.Builtin.Terms
( builtinTermsRef
, builtinTermsSrc
) where
import Data.Map (Map)
import qualified Data.Map as Map
@ -20,24 +23,24 @@ import qualified Unison.Var as Var
import Unison.Symbol (Symbol)
builtinTermsSrc :: a -> [(Symbol, Term Symbol a, Type Symbol a)]
builtinTermsSrc a =
builtinTermsSrc ann =
[ ( v "metadata.isPropagated",
Term.constructor a (ConstructorReference Decls.isPropagatedRef Decls.isPropagatedConstructorId),
Type.ref a Decls.isPropagatedRef
Term.constructor ann (ConstructorReference Decls.isPropagatedRef Decls.isPropagatedConstructorId),
Type.ref ann Decls.isPropagatedRef
),
( v "metadata.isTest",
Term.constructor a (ConstructorReference Decls.isTestRef Decls.isTestConstructorId),
Type.ref a Decls.isTestRef
Term.constructor ann (ConstructorReference Decls.isTestRef Decls.isTestConstructorId),
Type.ref ann Decls.isTestRef
)
]
v :: Var v => Text -> v
v = Var.named
builtinTermsRef :: a -> Map Symbol Reference.Id
builtinTermsRef a =
fmap fst
builtinTermsRef :: Map Symbol Reference.Id
builtinTermsRef =
fmap (\(refId, _, _) -> refId)
. H.hashTermComponents
. Map.fromList
. fmap (\(v, tm, _tp) -> (v, tm))
$ builtinTermsSrc a
. fmap (\(v, tm, tp) -> (v, (tm, tp)))
$ builtinTermsSrc ()

26
parser-typechecker/src/Unison/Codebase.hs
View File

@ -6,6 +6,7 @@ module Unison.Codebase
getTerm,
unsafeGetTerm,
unsafeGetTermWithType,
getTermComponentWithTypes,
getTypeOfTerm,
unsafeGetTypeOfTermById,
isTerm,
@ -23,6 +24,7 @@ module Unison.Codebase
-- * Type declarations
getTypeDeclaration,
unsafeGetTypeDeclaration,
getDeclComponent,
putTypeDeclaration,
typeReferencesByPrefix,
isType,
@ -64,6 +66,7 @@ module Unison.Codebase
-- * Dependents
dependents,
dependentsOfComponent,
-- * Sync
@ -83,11 +86,13 @@ module Unison.Codebase
CodebasePath,
SyncToDir,
-- * Misc
-- * Misc (organize these better)
addDefsToCodebase,
componentReferencesForReference,
installUcmDependencies,
toCodeLookup,
typeLookupForDependencies,
unsafeGetComponentLength,
)
where
@ -117,6 +122,7 @@ import Unison.CodebasePath (CodebasePath, getCodebaseDir)
import Unison.ConstructorReference (ConstructorReference, GConstructorReference(..))
import Unison.DataDeclaration (Decl)
import qualified Unison.DataDeclaration as DD
import Unison.Hash (Hash)
import qualified Unison.Hashing.V2.Convert as Hashing
import qualified Unison.Parser.Ann as Parser
import Unison.Prelude
@ -287,6 +293,12 @@ getTypeOfReferent c = \case
Referent.Ref r -> getTypeOfTerm c r
Referent.Con r _ -> getTypeOfConstructor c r
componentReferencesForReference :: Monad m => Codebase m v a -> Reference -> m (Set Reference)
componentReferencesForReference c = \case
r@Reference.Builtin{} -> pure (Set.singleton r)
Reference.Derived h _i ->
Set.mapMonotonic Reference.DerivedId . Reference.componentFromLength h <$> unsafeGetComponentLength c h
-- | Get the set of terms, type declarations, and builtin types that depend on the given term, type declaration, or
-- builtin type.
dependents :: Functor m => Codebase m v a -> Reference -> m (Set Reference)
@ -295,6 +307,12 @@ dependents c r =
. Set.map Reference.DerivedId
<$> dependentsImpl c r
dependentsOfComponent :: Functor f => Codebase f v a -> Hash -> f (Set Reference)
dependentsOfComponent c h =
Set.union (Builtin.builtinTypeDependentsOfComponent h)
. Set.map Reference.DerivedId
<$> dependentsOfComponentImpl c h
-- | Get the set of terms-or-constructors that have the given type.
termsOfType :: (Var v, Functor m) => Codebase m v a -> Type v a -> m (Set Referent.Referent)
termsOfType c ty = termsOfTypeByReference c $ Hashing.typeToReference ty
@ -376,6 +394,12 @@ viewRemoteBranch ::
viewRemoteBranch codebase ns gitBranchBehavior action =
viewRemoteBranch' codebase ns gitBranchBehavior (\(b, _dir) -> action b)
unsafeGetComponentLength :: (HasCallStack, Monad m) => Codebase m v a -> Hash -> m Reference.CycleSize
unsafeGetComponentLength codebase h =
getComponentLength codebase h >>= \case
Nothing -> error (reportBug "E713350" ("component with hash " ++ show h ++ " not found"))
Just size -> pure size
-- | Like 'getTerm', for when the term is known to exist in the codebase.
unsafeGetTerm :: (HasCallStack, Monad m) => Codebase m v a -> Reference.Id -> m (Term v a)
unsafeGetTerm codebase rid =

284
parser-typechecker/src/Unison/Codebase/Branch.hs
View File

@ -3,11 +3,11 @@
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Unison.Codebase.Branch
( -- * Branch types
Branch(..)
, BranchDiff(..)
, UnwrappedBranch
, Branch0(..)
, Raw(..)
@ -24,7 +24,6 @@ module Unison.Codebase.Branch
, empty0
, discardHistory
, discardHistory0
, toCausalRaw
, transform
-- * Branch tests
, isEmpty
@ -32,8 +31,6 @@ module Unison.Codebase.Branch
, isOne
, before
, lca
-- * diff
, diff0
-- * properties
, history
, head
@ -75,11 +72,6 @@ module Unison.Codebase.Branch
-- ** Term/type queries
, deepReferents
, deepTypeReferences
-- * Branch serialization
, cachedRead
, Cache
, sync
, consBranchSnapshot
) where
@ -87,50 +79,45 @@ import Unison.Prelude hiding (empty)
import Prelude hiding (head,read,subtract)
import Control.Lens hiding ( children, cons, transform, uncons )
import qualified Control.Monad.State as State
import Control.Monad.State ( StateT )
import Data.Bifunctor ( second )
import qualified Data.Map as Map
import qualified Data.Map.Merge.Lazy as Map
import qualified Data.Set as Set
import qualified Unison.Codebase.Patch as Patch
import Unison.Codebase.Patch ( Patch )
import qualified Unison.Codebase.Causal as Causal
import Unison.Codebase.Causal ( Causal
, pattern RawOne
, pattern RawCons
, pattern RawMerge
)
import Unison.Codebase.Path ( Path(..) )
import qualified Unison.Codebase.Path as Path
import Unison.NameSegment ( NameSegment )
import qualified Unison.Codebase.Metadata as Metadata
import qualified Unison.Hash as Hash
import Unison.Hashable ( Hashable )
import qualified Unison.Hashable as H
import Unison.Name ( Name )
import qualified Unison.Name as Name
import Unison.Reference ( TypeReference )
import Unison.Referent ( Referent )
import qualified U.Util.Cache as Cache
import qualified Unison.Util.Relation as R
import Unison.Util.Relation ( Relation )
import qualified Unison.Util.Relation4 as R4
import qualified Unison.Util.Star3 as Star3
import qualified Unison.Util.List as List
import Control.Lens hiding (children, cons, transform, uncons)
import Data.Bifunctor (second)
import qualified Data.Map as Map
import qualified Data.Semialign as Align
import Data.These (These(..))
import qualified Data.Set as Set
import Data.These (These (..))
import Unison.Codebase.Branch.Raw (Raw (Raw))
import Unison.Codebase.Branch.Type
( Branch (..),
Branch0 (..),
EditHash,
Hash,
Star,
UnwrappedBranch,
edits,
head,
headHash,
history,
)
import Unison.Codebase.Causal (Causal)
import qualified Unison.Codebase.Causal as Causal
import qualified Unison.Codebase.Metadata as Metadata
import Unison.Codebase.Patch (Patch)
import qualified Unison.Codebase.Patch as Patch
import Unison.Codebase.Path (Path (..))
import qualified Unison.Codebase.Path as Path
import qualified Unison.Hashing.V2.Convert as H
import qualified Unison.Hashing.V2.Hashable as H
import Unison.Name (Name)
import qualified Unison.Name as Name
import Unison.NameSegment (NameSegment)
import Unison.Reference (TypeReference)
import Unison.Referent (Referent)
import qualified Unison.Util.List as List
import Unison.Util.Relation (Relation)
import qualified Unison.Util.Relation as R
import qualified Unison.Util.Relation as Relation
-- | A node in the Unison namespace hierarchy
-- along with its history.
newtype Branch m = Branch { _history :: UnwrappedBranch m }
deriving (Eq, Ord)
history :: Iso' (Branch m) (UnwrappedBranch m)
history = iso _history Branch
import qualified Unison.Util.Relation4 as R4
import qualified Unison.Util.Star3 as Star3
instance AsEmpty (Branch m) where
_Empty = prism' (const empty) matchEmpty
@ -139,72 +126,8 @@ instance AsEmpty (Branch m) where
| b0 == empty = Just ()
| otherwise = Nothing
type UnwrappedBranch m = Causal m Raw (Branch0 m)
type Hash = Causal.RawHash Raw
type EditHash = Hash.Hash
type Star r n = Metadata.Star r n
-- | A node in the Unison namespace hierarchy.
--
-- '_terms' and '_types' are the declarations at this level.
-- '_children' are the nodes one level below us.
-- '_edits' are the 'Patch's stored at this node in the code.
--
-- The @deep*@ fields are derived from the four above.
data Branch0 m = Branch0
{ _terms :: Star Referent NameSegment
, _types :: Star TypeReference NameSegment
, _children :: Map NameSegment (Branch m)
-- ^ Note the 'Branch' here, not 'Branch0'.
-- Every level in the tree has a history.
, _edits :: Map NameSegment (EditHash, m Patch)
-- names and metadata for this branch and its children
-- (ref, (name, value)) iff ref has metadata `value` at name `name`
, deepTerms :: Relation Referent Name
, deepTypes :: Relation TypeReference Name
, deepTermMetadata :: Metadata.R4 Referent Name
, deepTypeMetadata :: Metadata.R4 TypeReference Name
, deepPaths :: Set Path
, deepEdits :: Map Name EditHash
}
edits :: Lens' (Branch0 m) (Map NameSegment (EditHash, m Patch))
edits = lens _edits (\b0 e -> b0{_edits=e})
-- Represents a shallow diff of a Branch0.
-- Each of these `Star`s contain metadata as well, so an entry in
-- `added` or `removed` could be an update to the metadata.
data BranchDiff = BranchDiff
{ addedTerms :: Star Referent NameSegment
, removedTerms :: Star Referent NameSegment
, addedTypes :: Star TypeReference NameSegment
, removedTypes :: Star TypeReference NameSegment
, changedPatches :: Map NameSegment Patch.PatchDiff
} deriving (Eq, Ord, Show)
instance Semigroup BranchDiff where
left <> right = BranchDiff
{ addedTerms = addedTerms left <> addedTerms right
, removedTerms = removedTerms left <> removedTerms right
, addedTypes = addedTypes left <> addedTypes right
, removedTypes = removedTypes left <> removedTypes right
, changedPatches =
Map.unionWith (<>) (changedPatches left) (changedPatches right)
}
instance Monoid BranchDiff where
mappend = (<>)
mempty = BranchDiff mempty mempty mempty mempty mempty
-- The raw Branch
data Raw = Raw
{ _termsR :: Star Referent NameSegment
, _typesR :: Star TypeReference NameSegment
, _childrenR :: Map NameSegment Hash
, _editsR :: Map NameSegment EditHash
}
instance H.Hashable (Branch0 m) where
hash = H.hashBranch0
deepReferents :: Branch0 m -> Set Referent
deepReferents = R.dom . deepTerms
@ -346,17 +269,11 @@ deriveDeepEdits branch =
go n b =
Map.mapKeys (Name.cons n) (deepEdits $ head b)
head :: Branch m -> Branch0 m
head (Branch c) = Causal.head c
-- | Update the head of the current causal.
-- This re-hashes the current causal head after modifications.
head_ :: Lens' (Branch m) (Branch0 m)
head_ = history . Causal.head_
headHash :: Branch m -> Hash
headHash (Branch c) = Causal.currentHash c
-- | a version of `deepEdits` that returns the `m Patch` as well.
deepEdits' :: Branch0 m -> Map Name (EditHash, m Patch)
deepEdits' = go id where
@ -391,96 +308,6 @@ toList0 = go Path.empty where
go p b = (p, b) : (Map.toList (_children b) >>= (\(seg, cb) ->
go (Path.snoc p seg) (head cb) ))
instance Eq (Branch0 m) where
a == b = view terms a == view terms b
&& view types a == view types b
&& view children a == view children b
&& (fmap fst . view edits) a == (fmap fst . view edits) b
-- This type is a little ugly, so we wrap it up with a nice type alias for
-- use outside this module.
type Cache m = Cache.Cache (Causal.RawHash Raw) (UnwrappedBranch m)
-- Can use `Cache.nullCache` to disable caching if needed
cachedRead :: forall m . MonadIO m
=> Cache m
-> Causal.Deserialize m Raw Raw
-> (EditHash -> m Patch)
-> Hash
-> m (Branch m)
cachedRead cache deserializeRaw deserializeEdits h =
Branch <$> Causal.cachedRead cache d h
where
fromRaw :: Raw -> m (Branch0 m)
fromRaw Raw {..} = do
children <- traverse go _childrenR
edits <- for _editsR $ \hash -> (hash,) . pure <$> deserializeEdits hash
pure $ branch0 _termsR _typesR children edits
go = cachedRead cache deserializeRaw deserializeEdits
d :: Causal.Deserialize m Raw (Branch0 m)
d h = deserializeRaw h >>= \case
RawOne raw -> RawOne <$> fromRaw raw
RawCons raw h -> flip RawCons h <$> fromRaw raw
RawMerge raw hs -> flip RawMerge hs <$> fromRaw raw
sync
:: Monad m
=> (Hash -> m Bool)
-> Causal.Serialize m Raw Raw
-> (EditHash -> m Patch -> m ())
-> Branch m
-> m ()
sync exists serializeRaw serializeEdits b = do
_written <- State.execStateT (sync' exists serializeRaw serializeEdits b) mempty
-- traceM $ "Branch.sync wrote " <> show (Set.size written) <> " namespace files."
pure ()
-- serialize a `Branch m` indexed by the hash of its corresponding Raw
sync'
:: forall m
. Monad m
=> (Hash -> m Bool)
-> Causal.Serialize m Raw Raw
-> (EditHash -> m Patch -> m ())
-> Branch m
-> StateT (Set Hash) m ()
sync' exists serializeRaw serializeEdits b = Causal.sync exists
serialize0
(view history b)
where
serialize0 :: Causal.Serialize (StateT (Set Hash) m) Raw (Branch0 m)
serialize0 h b0 = case b0 of
RawOne b0 -> do
writeB0 b0
lift $ serializeRaw h $ RawOne (toRaw b0)
RawCons b0 ht -> do
writeB0 b0
lift $ serializeRaw h $ RawCons (toRaw b0) ht
RawMerge b0 hs -> do
writeB0 b0
lift $ serializeRaw h $ RawMerge (toRaw b0) hs
where
writeB0 :: Branch0 m -> StateT (Set Hash) m ()
writeB0 b0 = do
for_ (view children b0) $ \c -> do
queued <- State.get
when (Set.notMember (headHash c) queued) $
sync' exists serializeRaw serializeEdits c
for_ (view edits b0) (lift . uncurry serializeEdits)
-- this has to serialize the branch0 and its descendants in the tree,
-- and then serialize the rest of the history of the branch as well
toRaw :: Branch0 m -> Raw
toRaw Branch0 {..} =
Raw _terms _types (headHash <$> _children) (fst <$> _edits)
toCausalRaw :: Branch m -> Causal.Raw Raw Raw
toCausalRaw = \case
Branch (Causal.One _h e) -> RawOne (toRaw e)
Branch (Causal.Cons _h e (ht, _m)) -> RawCons (toRaw e) ht
Branch (Causal.Merge _h e tls) -> RawMerge (toRaw e) (Map.keysSet tls)
-- returns `Nothing` if no Branch at `path` or if Branch is empty at `path`
getAt :: Path
-> Branch m
@ -631,11 +458,11 @@ modifyPatches seg f = mapMOf edits update
p' <- case Map.lookup seg m of
Nothing -> pure $ f Patch.empty
Just (_, p) -> f <$> p
let h = H.accumulate' p'
let h = H.hashPatch p'
pure $ Map.insert seg (h, pure p') m
replacePatch :: Applicative m => NameSegment -> Patch -> Branch0 m -> Branch0 m
replacePatch n p = over edits (Map.insert n (H.accumulate' p, pure p))
replacePatch n p = over edits (Map.insert n (H.hashPatch p, pure p))
deletePatch :: NameSegment -> Branch0 m -> Branch0 m
deletePatch n = over edits (Map.delete n)
@ -748,14 +575,6 @@ batchUpdatesM (toList -> actions) curBranch = foldM execActions curBranch (group
pathLocation (Path Empty) = HereActions
pathLocation _ = ChildActions
instance Hashable (Branch0 m) where
tokens b =
[ H.accumulateToken (_terms b)
, H.accumulateToken (_types b)
, H.accumulateToken (headHash <$> _children b)
, H.accumulateToken (fst <$> _edits b)
]
-- todo: consider inlining these into Actions2
addTermName
:: Referent -> NameSegment -> Metadata.Metadata -> Branch0 m -> Branch0 m
@ -780,23 +599,6 @@ deleteTypeName _ _ b = b
lca :: Monad m => Branch m -> Branch m -> m (Maybe (Branch m))
lca (Branch a) (Branch b) = fmap Branch <$> Causal.lca a b
diff0 :: Monad m => Branch0 m -> Branch0 m -> m BranchDiff
diff0 old new = do
newEdits <- sequenceA $ snd <$> _edits new
oldEdits <- sequenceA $ snd <$> _edits old
let diffEdits = Map.merge (Map.mapMissing $ \_ p -> Patch.diff p mempty)
(Map.mapMissing $ \_ p -> Patch.diff mempty p)
(Map.zipWithMatched (const Patch.diff))
newEdits
oldEdits
pure $ BranchDiff
{ addedTerms = Star3.difference (_terms new) (_terms old)
, removedTerms = Star3.difference (_terms old) (_terms new)
, addedTypes = Star3.difference (_types new) (_types old)
, removedTypes = Star3.difference (_types old) (_types new)
, changedPatches = diffEdits
}
transform :: Functor m => (forall a . m a -> n a) -> Branch m -> Branch n
transform f b = case _history b of
causal -> Branch . Causal.transform f $ transformB0s f causal
@ -812,13 +614,11 @@ transform f b = case _history b of
-> Causal m Raw (Branch0 n)
transformB0s f = Causal.unsafeMapHashPreserving (transformB0 f)
-- | Traverse the head branch of all direct children.
-- The index of the traversal is the name of that child branch according to the parent.
children0 :: IndexedTraversal' NameSegment (Branch0 m) (Branch0 m)
children0 = children .> itraversed <. (history . Causal.head_)
-- | @head `consBranchSnapshot` base@ Cons's the current state of @head@ onto @base@ as-is.
-- Consider whether you really want this behaviour or the behaviour of 'Causal.squashMerge'
-- That is, it does not perform any common ancestor detection, or change reconciliation, it

61
parser-typechecker/src/Unison/Codebase/Branch/BranchDiff.hs Normal file
View File

@ -0,0 +1,61 @@
module Unison.Codebase.Branch.BranchDiff where
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Map.Merge.Lazy as MapMerge
import Unison.Codebase.Branch.Type (Branch0(_types,_terms,_edits))
import qualified Unison.Codebase.Metadata as Metadata
import qualified Unison.Codebase.Patch as Patch
import Unison.NameSegment (NameSegment)
import Unison.Reference (Reference)
import Unison.Referent (Referent)
import qualified Unison.Util.Star3 as Star3
type Star r n = Metadata.Star r n
-- Represents a shallow diff of a Branch0.
-- Each of these `Star`s contain metadata as well, so an entry in
-- `added` or `removed` could be an update to the metadata.
data BranchDiff = BranchDiff
{ addedTerms :: Star Referent NameSegment,
removedTerms :: Star Referent NameSegment,
addedTypes :: Star Reference NameSegment,
removedTypes :: Star Reference NameSegment,
changedPatches :: Map NameSegment Patch.PatchDiff
}
deriving (Eq, Ord, Show)
diff0 :: Monad m => Branch0 m -> Branch0 m -> m BranchDiff
diff0 old new = do
newEdits <- sequenceA $ snd <$> _edits new
oldEdits <- sequenceA $ snd <$> _edits old
let diffEdits =
MapMerge.merge
(MapMerge.mapMissing $ \_ p -> Patch.diff p mempty)
(MapMerge.mapMissing $ \_ p -> Patch.diff mempty p)
(MapMerge.zipWithMatched (const Patch.diff))
newEdits
oldEdits
pure $
BranchDiff
{ addedTerms = Star3.difference (_terms new) (_terms old),
removedTerms = Star3.difference (_terms old) (_terms new),
addedTypes = Star3.difference (_types new) (_types old),
removedTypes = Star3.difference (_types old) (_types new),
changedPatches = diffEdits
}
instance Semigroup BranchDiff where
left <> right =
BranchDiff
{ addedTerms = addedTerms left <> addedTerms right,
removedTerms = removedTerms left <> removedTerms right,
addedTypes = addedTypes left <> addedTypes right,
removedTypes = removedTypes left <> removedTypes right,
changedPatches =
Map.unionWith (<>) (changedPatches left) (changedPatches right)
}
instance Monoid BranchDiff where
mappend = (<>)
mempty = BranchDiff mempty mempty mempty mempty mempty

26
parser-typechecker/src/Unison/Codebase/Branch/Merge.hs
View File

@ -12,6 +12,16 @@ module Unison.Codebase.Branch.Merge
import Unison.Prelude hiding (empty)
import Unison.Codebase.Branch
( head,
isEmpty0,
isEmpty,
discardHistory0,
empty0,
cons,
branch0,
Branch0(_children, _edits, _terms, _types),
EditHash,
Branch(..) )
import Prelude hiding (head, read, subtract)
import qualified Data.Map as Map
@ -19,10 +29,12 @@ import qualified Data.Map.Merge.Lazy as Map
import qualified Unison.Codebase.Causal as Causal
import Unison.Codebase.Patch (Patch)
import qualified Unison.Codebase.Patch as Patch
import qualified Unison.Hashable as H
import qualified Unison.Hashing.V2.Convert as H
import Unison.Util.Map (unionWithM)
import qualified Unison.Util.Relation as R
import qualified Unison.Util.Star3 as Star3
import qualified Unison.Codebase.Branch.BranchDiff as BDiff
import Unison.Codebase.Branch.BranchDiff (BranchDiff (BranchDiff))
data MergeMode = RegularMerge | SquashMerge deriving (Eq,Ord,Show)
@ -45,8 +57,8 @@ merge'' lca mode (Branch x) (Branch y) =
combine :: Maybe (Branch0 m) -> Branch0 m -> Branch0 m -> m (Branch0 m)
combine Nothing l r = merge0 lca mode l r
combine (Just ca) l r = do
dl <- diff0 ca l
dr <- diff0 ca r
dl <- BDiff.diff0 ca l
dr <- BDiff.diff0 ca r
head0 <- apply ca (dl <> dr)
children <- Map.mergeA
(Map.traverseMaybeMissing $ combineMissing ca)
@ -65,13 +77,13 @@ merge'' lca mode (Branch x) (Branch y) =
else pure $ Just nw
apply :: Branch0 m -> BranchDiff -> m (Branch0 m)
apply b0 BranchDiff {..} = do
apply b0 (BranchDiff addedTerms removedTerms addedTypes removedTypes changedPatches) = do
patches <- sequenceA
$ Map.differenceWith patchMerge (pure @m <$> _edits b0) changedPatches
let newPatches = makePatch <$> Map.difference changedPatches (_edits b0)
makePatch Patch.PatchDiff {..} =
let p = Patch.Patch _addedTermEdits _addedTypeEdits
in (H.accumulate' p, pure p)
in (H.hashPatch p, pure p)
pure $ branch0 (Star3.difference (_terms b0) removedTerms <> addedTerms)
(Star3.difference (_types b0) removedTypes <> addedTypes)
(_children b0)
@ -85,7 +97,7 @@ merge'' lca mode (Branch x) (Branch y) =
, _typeEdits = R.difference (Patch._typeEdits p) _removedTypeEdits
<> _addedTypeEdits
}
pure (H.accumulate' np, pure np)
pure (H.hashPatch np, pure np)
merge0 :: forall m. Monad m => (Branch m -> Branch m -> m (Maybe (Branch m)))
-> MergeMode -> Branch0 m -> Branch0 m -> m (Branch0 m)
@ -103,4 +115,4 @@ merge0 lca mode b1 b2 = do
e1 <- m1
e2 <- m2
let e3 = e1 <> e2
pure (H.accumulate' e3, pure e3)
pure (H.hashPatch e3, pure e3)

21
parser-typechecker/src/Unison/Codebase/Branch/Raw.hs Normal file
View File

@ -0,0 +1,21 @@
module Unison.Codebase.Branch.Raw where
import Data.Map (Map)
import qualified Unison.Codebase.Metadata as Metadata
import Unison.Hash (Hash)
import qualified Unison.Hash as Hash
import Unison.NameSegment (NameSegment)
import Unison.Reference (Reference)
import Unison.Referent (Referent)
type Star r n = Metadata.Star r n
type EditHash = Hash.Hash
-- The raw Branch
data Raw = Raw
{ _termsR :: Star Referent NameSegment,
_typesR :: Star Reference NameSegment,
_childrenR :: Map NameSegment Hash,
_editsR :: Map NameSegment EditHash
}

75
parser-typechecker/src/Unison/Codebase/Branch/Type.hs Normal file
View File

@ -0,0 +1,75 @@
{-# LANGUAGE TemplateHaskell #-}
module Unison.Codebase.Branch.Type where
import Control.Lens
import Data.Map (Map)
import Data.Set (Set)
import Unison.Codebase.Branch.Raw (Raw)
import Unison.Codebase.Causal.Type (Causal)
import qualified Unison.Codebase.Causal.Type as Causal
import qualified Unison.Codebase.Metadata as Metadata
import Unison.Codebase.Patch (Patch)
import Unison.Codebase.Path (Path)
import qualified Unison.Hash as Hash
import Unison.Name (Name)
import Unison.NameSegment (NameSegment)
import Unison.Reference (Reference)
import Unison.Referent (Referent)
import Unison.Util.Relation (Relation)
-- | A node in the Unison namespace hierarchy
-- along with its history.
newtype Branch m = Branch {_history :: UnwrappedBranch m}
deriving (Eq, Ord)
type UnwrappedBranch m = Causal m Raw (Branch0 m)
type Hash = Causal.RawHash Raw
type EditHash = Hash.Hash
type Star r n = Metadata.Star r n
head :: Branch m -> Branch0 m
head (Branch c) = Causal.head c
headHash :: Branch m -> Hash
headHash (Branch c) = Causal.currentHash c
-- | A node in the Unison namespace hierarchy.
--
-- '_terms' and '_types' are the declarations at this level.
-- '_children' are the nodes one level below us.
-- '_edits' are the 'Patch's stored at this node in the code.
--
-- The @deep*@ fields are derived from the four above.
data Branch0 m = Branch0
{ _terms :: Star Referent NameSegment,
_types :: Star Reference NameSegment,
-- | Note the 'Branch' here, not 'Branch0'.
-- Every level in the tree has a history.
_children :: Map NameSegment (Branch m),
_edits :: Map NameSegment (EditHash, m Patch),
-- names and metadata for this branch and its children
-- (ref, (name, value)) iff ref has metadata `value` at name `name`
deepTerms :: Relation Referent Name,
deepTypes :: Relation Reference Name,
deepTermMetadata :: Metadata.R4 Referent Name,
deepTypeMetadata :: Metadata.R4 Reference Name,
deepPaths :: Set Path,
deepEdits :: Map Name EditHash
}
instance Eq (Branch0 m) where
a == b =
_terms a == _terms b
&& _types a == _types b
&& _children a == _children b
&& (fmap fst . _edits) a == (fmap fst . _edits) b
history :: Iso' (Branch m) (UnwrappedBranch m)
history = iso _history Branch
edits :: Lens' (Branch0 m) (Map NameSegment (EditHash, m Patch))
edits = lens _edits (\b0 e -> b0 {_edits = e})

279
parser-typechecker/src/Unison/Codebase/Causal.hs
View File

@ -4,27 +4,23 @@
{-# LANGUAGE TemplateHaskell #-}
module Unison.Codebase.Causal
( Causal (..),
Raw (..),
RawHash (..),
( Causal(currentHash, head, tail, tails),
pattern One,
pattern Cons,
pattern Merge,
RawHash (RawHash, unRawHash),
head_,
one,
cons,
cons',
consDistinct,
uncons,
hash,
predecessors,
Deserialize,
Serialize,
cachedRead,
threeWayMerge,
threeWayMerge',
squashMerge',
lca,
stepDistinct,
stepDistinctM,
sync,
transform,
unsafeMapHashPreserving,
before,
@ -34,68 +30,33 @@ where
import Unison.Prelude
import qualified Control.Monad.Extra as Monad (anyM)
import Control.Monad.State (StateT)
import qualified Control.Monad.State as State
import qualified Control.Monad.Reader as Reader
import qualified Data.Map as Map
import Data.Sequence (ViewL (..))
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified U.Util.Cache as Cache
import Unison.Hash (Hash)
import Unison.Hashable (Hashable)
import qualified Unison.Hashable as Hashable
import Prelude hiding (head, read, tail)
import qualified Control.Lens as Lens
{-
`Causal a` has 5 operations, specified algebraically here:
* `before : Causal m a -> Causal m a -> m Bool` defines a partial order on
`Causal`.
* `head : Causal m a -> a`, which represents the "latest" `a` value in a causal
chain.
* `one : a -> Causal m a`, satisfying `head (one hd) == hd`
* `cons : a -> Causal a -> Causal a`, satisfying `head (cons hd tl) == hd` and
also `before tl (cons hd tl)`.
* `merge : CommutativeSemigroup a => Causal a -> Causal a -> Causal a`, which is
commutative (but not associative) and satisfies:
* `before c1 (merge c1 c2)`
* `before c2 (merge c1 c2)`
* `sequence : Causal a -> Causal a -> Causal a`, which is defined as
`sequence c1 c2 = cons (head c2) (merge c1 c2)`.
* `before c1 (sequence c1 c2)`
* `head (sequence c1 c2) == head c2`
-}
newtype RawHash a = RawHash { unRawHash :: Hash }
deriving (Eq, Ord, Generic)
instance Show (RawHash a) where
show = show . unRawHash
instance Show e => Show (Causal m h e) where
show = \case
One h e -> "One " ++ (take 3 . show) h ++ " " ++ show e
Cons h e t -> "Cons " ++ (take 3 . show) h ++ " " ++ show e ++ " " ++ (take 3 . show) (fst t)
Merge h e ts -> "Merge " ++ (take 3 . show) h ++ " " ++ show e ++ " " ++ (show . fmap (take 3 . show) . toList) (Map.keysSet ts)
-- h is the type of the pure data structure that will be hashed and used as
-- an index; e.g. h = Branch00, e = Branch0 m
data Causal m h e
= One { currentHash :: RawHash h
, head :: e
}
| Cons { currentHash :: RawHash h
, head :: e
, tail :: (RawHash h, m (Causal m h e))
}
-- The merge operation `<>` flattens and normalizes for order
| Merge { currentHash :: RawHash h
, head :: e
, tails :: Map (RawHash h) (m (Causal m h e))
}
import qualified Control.Monad.Extra as Monad (anyM)
import qualified Control.Monad.Reader as Reader
import qualified Control.Monad.State as State
import qualified Data.Map as Map
import qualified Data.Set as Set
import Unison.Codebase.Causal.Type
( Causal
( UnsafeCons,
UnsafeMerge,
UnsafeOne,
currentHash,
head,
tail,
tails
),
RawHash (RawHash, unRawHash),
pattern One,
pattern Cons,
pattern Merge,
before,
predecessors,
lca,
)
import qualified Unison.Hashing.V2.Convert as Hashing
import Unison.Hashing.V2.Hashable (Hashable)
import Prelude hiding (head, read, tail)
-- | Focus the current head, keeping the hash up to date.
head_ :: Hashable e => Lens.Lens' (Causal m h e) e
@ -104,121 +65,9 @@ head_ = Lens.lens getter setter
getter = head
setter causal e =
case causal of
One {} -> one e
Cons{tail=(rawHash, c)} -> cons' e rawHash c
Merge{tails} -> mergeNode e tails
-- A serializer `Causal m h e`. Nonrecursive -- only responsible for
-- writing a single node of the causal structure.
data Raw h e
= RawOne e
| RawCons e (RawHash h)
| RawMerge e (Set (RawHash h))
type Deserialize m h e = RawHash h -> m (Raw h e)
cachedRead :: MonadIO m
=> Cache.Cache (RawHash h) (Causal m h e)
-> Deserialize m h e
-> RawHash h -> m (Causal m h e)
cachedRead cache deserializeRaw h = Cache.lookup cache h >>= \case
Nothing -> do
raw <- deserializeRaw h
causal <- pure $ case raw of
RawOne e -> One h e
RawCons e tailHash -> Cons h e (tailHash, read tailHash)
RawMerge e tailHashes -> Merge h e $
Map.fromList [(h, read h) | h <- toList tailHashes ]
Cache.insert cache h causal
pure causal
Just causal -> pure causal
where
read = cachedRead cache deserializeRaw
type Serialize m h e = RawHash h -> Raw h e -> m ()
-- Sync a causal to some persistent store, stopping when hitting a Hash which
-- has already been written, according to the `exists` function provided.
sync
:: forall m h e
. Monad m
=> (RawHash h -> m Bool)
-> Serialize (StateT (Set (RawHash h)) m) h e
-> Causal m h e
-> StateT (Set (RawHash h)) m ()
sync exists serialize c = do
queued <- State.get
itExists <- if Set.member (currentHash c) queued then pure True
else lift . exists $ currentHash c
unless itExists $ go c
where
go :: Causal m h e -> StateT (Set (RawHash h)) m ()
go c = do
queued <- State.get
when (Set.notMember (currentHash c) queued) $ do
State.modify (Set.insert $ currentHash c)
case c of
One currentHash head -> serialize currentHash $ RawOne head
Cons currentHash head (tailHash, tailm) -> do
-- write out the tail first, so what's on disk is always valid
b <- lift $ exists tailHash
unless b $ go =<< lift tailm
serialize currentHash (RawCons head tailHash)
Merge currentHash head tails -> do
for_ (Map.toList tails) $ \(hash, cm) -> do
b <- lift $ exists hash
unless b $ go =<< lift cm
serialize currentHash (RawMerge head (Map.keysSet tails))
instance Eq (Causal m h a) where
a == b = currentHash a == currentHash b
instance Ord (Causal m h a) where
a <= b = currentHash a <= currentHash b
instance Hashable (RawHash h) where
tokens (RawHash h) = Hashable.tokens h
-- Find the lowest common ancestor of two causals.
lca :: Monad m => Causal m h e -> Causal m h e -> m (Maybe (Causal m h e))
lca a b =
lca' (Seq.singleton $ pure a) (Seq.singleton $ pure b)
-- `lca' xs ys` finds the lowest common ancestor of any element of `xs` and any
-- element of `ys`.
-- This is a breadth-first search used in the implementation of `lca a b`.
lca'
:: Monad m
=> Seq (m (Causal m h e))
-> Seq (m (Causal m h e))
-> m (Maybe (Causal m h e))
lca' = go Set.empty Set.empty where
go seenLeft seenRight remainingLeft remainingRight =
case Seq.viewl remainingLeft of
Seq.EmptyL -> search seenLeft remainingRight
a :< as -> do
left <- a
if Set.member (currentHash left) seenRight
then pure $ Just left
-- Note: swapping position of left and right when we recurse so that
-- we search each side equally. This avoids having to case on both
-- arguments, and the order shouldn't really matter.
else go seenRight
(Set.insert (currentHash left) seenLeft)
remainingRight
(as <> predecessors left)
search seen remaining = case Seq.viewl remaining of
Seq.EmptyL -> pure Nothing
a :< as -> do
current <- a
if Set.member (currentHash current) seen
then pure $ Just current
else search seen (as <> predecessors current)
predecessors :: Causal m h e -> Seq (m (Causal m h e))
predecessors (One _ _ ) = Seq.empty
predecessors (Cons _ _ (_, t)) = Seq.singleton t
predecessors (Merge _ _ ts ) = Seq.fromList $ Map.elems ts
UnsafeOne {} -> one e
UnsafeCons _ _ tail -> fromListM e [tail]
UnsafeMerge _ _ tails -> mergeNode e tails
-- A `squashMerge combine c1 c2` gives the same resulting `e`
-- as a `threeWayMerge`, but doesn't introduce a merge node for the
@ -268,17 +117,8 @@ threeWayMerge' lca combine c1 c2 = do
| lca == c2 -> pure c1
| otherwise -> done <$> combine (Just $ head lca) (head c1) (head c2)
where
predecessors =
Map.fromList [(currentHash c1, pure c1), (currentHash c2, pure c2)]
done :: e -> Causal m h e
done newHead = mergeNode newHead predecessors
mergeNode :: Hashable e => e -> Map (RawHash h) (m (Causal m h e)) -> Causal m h e
mergeNode newHead predecessors =
Merge (RawHash (hash (newHead, Map.keys predecessors))) newHead predecessors
before :: Monad m => Causal m h e -> Causal m h e -> m Bool
before a b = (== Just a) <$> lca a b
done newHead = fromList newHead [c1, c2]
-- `True` if `h` is found in the history of `c` within `maxDepth` path length
-- from the tip of `c`
@ -298,9 +138,6 @@ beforeHash maxDepth h c =
State.modify' (<> Set.fromList cs)
Monad.anyM (Reader.local (1+) . go) unseens
hash :: Hashable e => e -> Hash
hash = Hashable.accumulate'
stepDistinct :: (Applicative m, Eq e, Hashable e) => (e -> e) -> Causal m h e -> Causal m h e
stepDistinct f c = f (head c) `consDistinct` c
@ -309,14 +146,35 @@ stepDistinctM
=> (e -> n e) -> Causal m h e -> n (Causal m h e)
stepDistinctM f c = (`consDistinct` c) <$> f (head c)
-- | Causal construction should go through here for uniformity;
-- with an exception for `one`, which avoids an Applicative constraint.
fromList :: (Applicative m, Hashable e) => e -> [Causal m h e] -> Causal m h e
fromList e cs =
fromListM e (map (\c -> (currentHash c, pure c)) cs)
-- | Construct a causal from a list of predecessors. The predecessors may be given in any order.
fromListM :: Hashable e => e -> [(RawHash h, m (Causal m h e))] -> Causal m h e
fromListM e ts =
case ts of
[] -> UnsafeOne h e
[t] -> UnsafeCons h e t
_ -> UnsafeMerge h e (Map.fromList ts)
where
h = RawHash (Hashing.hashCausal e (Set.fromList (map fst ts)))
-- | An optimized variant of 'fromListM' for when it is known we have 2+ predecessors (merge node).
mergeNode :: Hashable e => e -> Map (RawHash h) (m (Causal m h e)) -> Causal m h e
mergeNode newHead predecessors =
UnsafeMerge (RawHash (Hashing.hashCausal newHead (Map.keysSet predecessors))) newHead predecessors
-- duplicated logic here instead of delegating to `fromList` to avoid `Applicative m` constraint.
one :: Hashable e => e -> Causal m h e
one e = One (RawHash $ hash e) e
one e = UnsafeOne h e
where
h = RawHash $ Hashing.hashCausal e mempty
cons :: (Applicative m, Hashable e) => e -> Causal m h e -> Causal m h e
cons e tl = cons' e (currentHash tl) (pure tl)
cons' :: Hashable e => e -> RawHash h -> m (Causal m h e) -> Causal m h e
cons' e ht mt = Cons (RawHash $ hash [hash e, unRawHash ht]) e (ht, mt)
cons e tail = fromList e [tail]
consDistinct :: (Applicative m, Eq e, Hashable e) => e -> Causal m h e -> Causal m h e
consDistinct e tl =
@ -328,16 +186,19 @@ uncons c = case c of
Cons _ e (_,tl) -> fmap (e,) . Just <$> tl
_ -> pure Nothing
-- it's okay to call "Unsafe"* here with the existing hashes because `nt` can't
-- affect `e`.
transform :: Functor m => (forall a . m a -> n a) -> Causal m h e -> Causal n h e
transform nt c = case c of
One h e -> One h e
Cons h e (ht, tl) -> Cons h e (ht, nt (transform nt <$> tl))
Merge h e tls -> Merge h e $ Map.map (\mc -> nt (transform nt <$> mc)) tls
One h e -> UnsafeOne h e
Cons h e (ht, tl) -> UnsafeCons h e (ht, nt (transform nt <$> tl))
Merge h e tls -> UnsafeMerge h e $ Map.map (\mc -> nt (transform nt <$> mc)) tls
-- "unsafe" because the hashes will be wrong if `f` affects aspects of `e` that impact hashing
unsafeMapHashPreserving :: Functor m => (e -> e2) -> Causal m h e -> Causal m h e2
unsafeMapHashPreserving f c = case c of
One h e -> One h (f e)
Cons h e (ht, tl) -> Cons h (f e) (ht, unsafeMapHashPreserving f <$> tl)
Merge h e tls -> Merge h (f e) $ Map.map (fmap $ unsafeMapHashPreserving f) tls
One h e -> UnsafeOne h (f e)
Cons h e (ht, tl) -> UnsafeCons h (f e) (ht, unsafeMapHashPreserving f <$> tl)
Merge h e tls -> UnsafeMerge h (f e) $ Map.map (fmap $ unsafeMapHashPreserving f) tls
data FoldHistoryResult a = Satisfied a | Unsatisfied a deriving (Eq,Ord,Show)

2
parser-typechecker/src/Unison/Codebase/Causal/FoldHistory.hs
View File

@ -6,7 +6,7 @@ module Unison.Codebase.Causal.FoldHistory (FoldHistoryResult (..), foldHistoryUn
import Unison.Prelude
import Unison.Codebase.Causal ( Causal(..), RawHash )
import Unison.Codebase.Causal (Causal(..), RawHash, pattern One, pattern Cons, pattern Merge)
import Prelude hiding (tail, head)
import qualified Data.Sequence as Seq
import qualified Data.Set as Set

134
parser-typechecker/src/Unison/Codebase/Causal/Type.hs Normal file
View File

@ -0,0 +1,134 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Unison.Codebase.Causal.Type
( Causal (..),
RawHash (..),
pattern One,
pattern Cons,
pattern Merge,
before,
predecessors,
lca,
)
where
import qualified Data.Map as Map
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import Unison.Hash (Hash)
import Unison.Prelude
import Prelude hiding (head, read, tail)
{-
`Causal a` has 5 operations, specified algebraically here:
* `before : Causal m a -> Causal m a -> m Bool` defines a partial order on
`Causal`.
* `head : Causal m a -> a`, which represents the "latest" `a` value in a causal
chain.
* `one : a -> Causal m a`, satisfying `head (one hd) == hd`
* `cons : a -> Causal a -> Causal a`, satisfying `head (cons hd tl) == hd` and
also `before tl (cons hd tl)`.
* `merge : CommutativeSemigroup a => Causal a -> Causal a -> Causal a`, which is
commutative (but not associative) and satisfies:
* `before c1 (merge c1 c2)`
* `before c2 (merge c1 c2)`
* `sequence : Causal a -> Causal a -> Causal a`, which is defined as
`sequence c1 c2 = cons (head c2) (merge c1 c2)`.
* `before c1 (sequence c1 c2)`
* `head (sequence c1 c2) == head c2`
-}
newtype RawHash a = RawHash {unRawHash :: Hash}
deriving (Eq, Ord, Generic)
instance Show (RawHash a) where
show = show . unRawHash
instance Show e => Show (Causal m h e) where
show = \case
UnsafeOne h e -> "One " ++ (take 3 . show) h ++ " " ++ show e
UnsafeCons h e t -> "Cons " ++ (take 3 . show) h ++ " " ++ show e ++ " " ++ (take 3 . show) (fst t)
UnsafeMerge h e ts -> "Merge " ++ (take 3 . show) h ++ " " ++ show e ++ " " ++ (show . fmap (take 3 . show) . toList) (Map.keysSet ts)
-- h is the type of the pure data structure that will be hashed and used as
-- an index; e.g. h = Branch00, e = Branch0 m
data Causal m h e
= UnsafeOne
{ currentHash :: RawHash h,
head :: e
}
| UnsafeCons
{ currentHash :: RawHash h,
head :: e,
tail :: (RawHash h, m (Causal m h e))
}
| -- The merge operation `<>` flattens and normalizes for order
UnsafeMerge
{ currentHash :: RawHash h,
head :: e,
tails :: Map (RawHash h) (m (Causal m h e))
}
pattern One :: RawHash h -> e -> Causal m h e
pattern One h e <- UnsafeOne h e
pattern Cons :: RawHash h -> e -> (RawHash h, m (Causal m h e)) -> Causal m h e
pattern Cons h e tail <- UnsafeCons h e tail
pattern Merge :: RawHash h -> e -> Map (RawHash h) (m (Causal m h e)) -> Causal m h e
pattern Merge h e tails <- UnsafeMerge h e tails
{-# COMPLETE One, Cons, Merge #-}
predecessors :: Causal m h e -> Seq (m (Causal m h e))
predecessors (UnsafeOne _ _) = Seq.empty
predecessors (UnsafeCons _ _ (_, t)) = Seq.singleton t
predecessors (UnsafeMerge _ _ ts) = Seq.fromList $ Map.elems ts
before :: Monad m => Causal m h e -> Causal m h e -> m Bool
before a b = (== Just a) <$> lca a b
-- Find the lowest common ancestor of two causals.
lca :: Monad m => Causal m h e -> Causal m h e -> m (Maybe (Causal m h e))
lca a b =
lca' (Seq.singleton $ pure a) (Seq.singleton $ pure b)
-- `lca' xs ys` finds the lowest common ancestor of any element of `xs` and any
-- element of `ys`.
-- This is a breadth-first search used in the implementation of `lca a b`.
lca' ::
Monad m =>
Seq (m (Causal m h e)) ->
Seq (m (Causal m h e)) ->
m (Maybe (Causal m h e))
lca' = go Set.empty Set.empty
where
go seenLeft seenRight remainingLeft remainingRight =
case Seq.viewl remainingLeft of
Seq.EmptyL -> search seenLeft remainingRight
a Seq.:< as -> do
left <- a
if Set.member (currentHash left) seenRight
then pure $ Just left
else -- Note: swapping position of left and right when we recurse so that
-- we search each side equally. This avoids having to case on both
-- arguments, and the order shouldn't really matter.
go
seenRight
(Set.insert (currentHash left) seenLeft)
remainingRight
(as <> predecessors left)
search seen remaining = case Seq.viewl remaining of
Seq.EmptyL -> pure Nothing
a Seq.:< as -> do
current <- a
if Set.member (currentHash current) seen
then pure $ Just current
else search seen (as <> predecessors current)
instance Eq (Causal m h a) where
a == b = currentHash a == currentHash b
instance Ord (Causal m h a) where
a <= b = currentHash a <= currentHash b

10
parser-typechecker/src/Unison/Codebase/Editor/Git.hs
View File

@ -193,10 +193,7 @@ withRepo repo@(ReadGitRepo {url = uri, ref = mayGitRef}) branchBehavior action =
"--force", -- force updating local refs even if not fast-forward
-- update local refs with the same name they have on the remote.
"--refmap", "*:*",
-- Note: a shallow fetch saves time initially, but prevents
-- 'local' clones from using hard-links, so doing a normal fetch saves the most time
-- in the long run.
-- "--depth", "1",
"--depth", "1",
uri, -- The repo to fetch from
gitRef -- The specific reference to fetch
] ++ gitVerbosity
@ -221,10 +218,7 @@ cloneIfMissing repo@(ReadGitRepo {url=uri}) localPath = do
gitGlobal
(["clone"]
++ ["--bare"]
-- Note: a shallow clone saves time on the initial clone, but prevents all future
-- 'local' clones from using hard-links, so doing a full clone saves the most time
-- in the long run.
-- ++ ["--depth", "1"]
++ ["--depth", "1"]
++ [uri, Text.pack localPath]))
`withIOError` (throwError . GitError.CloneException repo . show)
isGitDir <- liftIO $ isGitRepo (Bare localPath)

6
parser-typechecker/src/Unison/Codebase/Patch.hs
View File

@ -15,8 +15,6 @@ import Unison.Codebase.TermEdit ( TermEdit, Typing(Same) )
import qualified Unison.Codebase.TermEdit as TermEdit
import Unison.Codebase.TypeEdit ( TypeEdit )
import qualified Unison.Codebase.TypeEdit as TypeEdit
import Unison.Hashable ( Hashable )
import qualified Unison.Hashable as H
import Unison.Reference ( Reference )
import qualified Unison.Util.Relation as R
import Unison.Util.Relation ( Relation )
@ -120,10 +118,6 @@ instance Monoid Patch where
mappend = (<>)
mempty = Patch mempty mempty
instance Hashable Patch where
tokens e = [ H.Hashed (H.accumulate (H.tokens (_termEdits e))),
H.Hashed (H.accumulate (H.tokens (_typeEdits e))) ]
instance Semigroup PatchDiff where
a <> b = PatchDiff
{ _addedTermEdits = _addedTermEdits a <> _addedTermEdits b

1020
parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs
View File

File diff suppressed because it is too large Load Diff

10
parser-typechecker/src/Unison/Codebase/SqliteCodebase/Branch/Dependencies.hs
View File

@ -76,13 +76,13 @@ fromBranch0 b =
fromTermsStar :: Branch.Star Referent NameSegment -> Dependencies
fromTermsStar s = Dependencies mempty terms decls where
terms = Set.fromList $
[ h | Referent.Ref (Derived h _ _) <- references s] ++
[ h | (Derived h _ _) <- mdValues s]
[ h | Referent.Ref (Derived h _) <- references s] ++
[ h | (Derived h _) <- mdValues s]
decls = Set.fromList $
[ h | Referent.Con (ConstructorReference (Derived h _i _n) _) _ <- references s ]
[ h | Referent.Con (ConstructorReference (Derived h _i) _) _ <- references s ]
fromTypesStar :: Branch.Star Reference NameSegment -> Dependencies
fromTypesStar s = Dependencies mempty terms decls where
terms = Set.fromList [ h | (Derived h _ _) <- mdValues s ]
decls = Set.fromList [ h | (Derived h _ _) <- references s ]
terms = Set.fromList [ h | (Derived h _) <- mdValues s ]
decls = Set.fromList [ h | (Derived h _) <- references s ]
fromEdits :: Map NameSegment (EditHash, m Patch) -> Dependencies
fromEdits m = Dependencies (Set.fromList . fmap fst $ toList m) mempty mempty

277
parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs
View File

@ -3,10 +3,8 @@
module Unison.Codebase.SqliteCodebase.Conversions where
import Control.Monad (foldM)
import Data.Bifunctor (Bifunctor (bimap))
import Data.Bitraversable (Bitraversable (bitraverse))
import Data.Foldable (Foldable (toList))
import Data.Foldable (Foldable (foldl', toList))
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Set as Set
@ -31,20 +29,18 @@ import qualified U.Codebase.WatchKind as V2.WatchKind
import qualified U.Core.ABT as V2.ABT
import qualified U.Util.Hash as V2
import qualified U.Util.Hash as V2.Hash
import qualified Unison.Util.Map as Map
import qualified Unison.Util.Set as Set
import qualified Unison.ABT as V1.ABT
import qualified Unison.Codebase.Branch as V1.Branch
import qualified Unison.Codebase.Causal as V1.Causal
import qualified Unison.Codebase.Causal.Type as V1.Causal
import qualified Unison.Codebase.Metadata as V1.Metadata
import qualified Unison.Codebase.Patch as V1
import qualified Unison.Codebase.ShortBranchHash as V1
import qualified Unison.Codebase.TermEdit as V1.TermEdit
import qualified Unison.Codebase.TypeEdit as V1.TypeEdit
import qualified Unison.ConstructorReference as V1 (GConstructorReference(..))
import qualified Unison.ConstructorReference as V1 (GConstructorReference (..))
import qualified Unison.ConstructorType as CT
import qualified Unison.DataDeclaration as V1.Decl
import Unison.Hash (base32Hex, Hash)
import Unison.Hash (Hash, base32Hex)
import qualified Unison.Hash as V1
import qualified Unison.Kind as V1.Kind
import qualified Unison.NameSegment as V1
@ -58,6 +54,7 @@ import qualified Unison.Referent as V1.Referent
import qualified Unison.Symbol as V1
import qualified Unison.Term as V1.Term
import qualified Unison.Type as V1.Type
import qualified Unison.Util.Map as Map
import qualified Unison.Util.Relation as Relation
import qualified Unison.Util.Star3 as V1.Star3
import qualified Unison.Var as Var
@ -96,6 +93,8 @@ term1to2 h =
where
termF1to2 :: V1.Term.F V1.Symbol Ann Ann a -> V2.Term.F V2.Symbol a
termF1to2 = go
go :: V1.Term.F V1.Symbol Ann Ann a -> V2.Term.F V2.Symbol a
go = \case
V1.Term.Int i -> V2.Term.Int i
V1.Term.Nat n -> V2.Term.Nat n
@ -120,8 +119,10 @@ term1to2 h =
V1.Term.TermLink r -> V2.Term.TermLink (rreferent1to2 h r)
V1.Term.TypeLink r -> V2.Term.TypeLink (reference1to2 r)
V1.Term.Blank _ -> error ("can't serialize term with blanks (" ++ unpack (base32Hex h) ++ ")")
goCase (V1.Term.MatchCase p g b) =
V2.Term.MatchCase (goPat p) g b
goPat :: V1.Pattern.Pattern a -> V2.Term.Pattern Text V2.Reference
goPat = \case
V1.Pattern.Unbound _ -> V2.Term.PUnbound
@ -146,15 +147,15 @@ term1to2 h =
V1.Pattern.Snoc -> V2.Term.PSnoc
V1.Pattern.Concat -> V2.Term.PConcat
term2to1 :: forall m. Monad m => Hash -> (Hash -> m V1.Reference.Size) -> (V2.Reference -> m CT.ConstructorType) -> V2.Term.Term V2.Symbol -> m (V1.Term.Term V1.Symbol Ann)
term2to1 h lookupSize lookupCT tm =
V1.ABT.transformM (termF2to1 h lookupSize lookupCT)
term2to1 :: forall m. Monad m => Hash -> (V2.Reference -> m CT.ConstructorType) -> V2.Term.Term V2.Symbol -> m (V1.Term.Term V1.Symbol Ann)
term2to1 h lookupCT tm =
V1.ABT.transformM (termF2to1 h lookupCT)
. V1.ABT.vmap symbol2to1
. V1.ABT.amap (const Ann.External)
$ abt2to1 tm
where
termF2to1 :: forall m a. Monad m => Hash -> (Hash -> m V1.Reference.Size) -> (V2.Reference -> m CT.ConstructorType) -> V2.Term.F V2.Symbol a -> m (V1.Term.F V1.Symbol Ann Ann a)
termF2to1 h lookupSize lookupCT = go
termF2to1 :: forall m a. Monad m => Hash -> (V2.Reference -> m CT.ConstructorType) -> V2.Term.F V2.Symbol a -> m (V1.Term.F V1.Symbol Ann Ann a)
termF2to1 h lookupCT = go
where
go :: V2.Term.F V2.Symbol a -> m (V1.Term.F V1.Symbol Ann Ann a)
go = \case
@ -164,14 +165,14 @@ term2to1 h lookupSize lookupCT tm =
V2.Term.Boolean b -> pure $ V1.Term.Boolean b
V2.Term.Text t -> pure $ V1.Term.Text t
V2.Term.Char c -> pure $ V1.Term.Char c
V2.Term.Ref r -> V1.Term.Ref <$> rreference2to1 h lookupSize r
V2.Term.Ref r -> pure $ V1.Term.Ref (rreference2to1 h r)
V2.Term.Constructor r i ->
V1.Term.Constructor <$> (V1.ConstructorReference <$> reference2to1 lookupSize r <*> pure (fromIntegral i))
pure (V1.Term.Constructor (V1.ConstructorReference (reference2to1 r) (fromIntegral i)))
V2.Term.Request r i ->
V1.Term.Request <$> (V1.ConstructorReference <$> reference2to1 lookupSize r <*> pure (fromIntegral i))
pure (V1.Term.Request (V1.ConstructorReference (reference2to1 r) (fromIntegral i)))
V2.Term.Handle a a4 -> pure $ V1.Term.Handle a a4
V2.Term.App a a4 -> pure $ V1.Term.App a a4
V2.Term.Ann a t2 -> V1.Term.Ann a <$> ttype2to1 lookupSize t2
V2.Term.Ann a t2 -> pure $ V1.Term.Ann a (ttype2to1 t2)
V2.Term.List sa -> pure $ V1.Term.List sa
V2.Term.If a a4 a5 -> pure $ V1.Term.If a a4 a5
V2.Term.And a a4 -> pure $ V1.Term.And a a4
@ -180,8 +181,8 @@ term2to1 h lookupSize lookupCT tm =
V2.Term.LetRec as a -> pure $ V1.Term.LetRec False as a
V2.Term.Let a a4 -> pure $ V1.Term.Let False a a4
V2.Term.Match a cases -> V1.Term.Match a <$> traverse goCase cases
V2.Term.TermLink rr -> V1.Term.TermLink <$> rreferent2to1 h lookupSize lookupCT rr
V2.Term.TypeLink r -> V1.Term.TypeLink <$> reference2to1 lookupSize r
V2.Term.TermLink rr -> V1.Term.TermLink <$> rreferent2to1 h lookupCT rr
V2.Term.TypeLink r -> pure $ V1.Term.TypeLink (reference2to1 r)
goCase = \case
V2.Term.MatchCase pat cond body ->
V1.Term.MatchCase <$> (goPat pat) <*> pure cond <*> pure body
@ -195,11 +196,11 @@ term2to1 h lookupSize lookupCT tm =
V2.Term.PText t -> pure $ V1.Pattern.Text a t
V2.Term.PChar c -> pure $ V1.Pattern.Char a c
V2.Term.PConstructor r i ps ->
V1.Pattern.Constructor a <$> (V1.ConstructorReference <$> reference2to1 lookupSize r <*> pure i) <*> (traverse goPat ps)
V1.Pattern.Constructor a (V1.ConstructorReference (reference2to1 r) i) <$> traverse goPat ps
V2.Term.PAs p -> V1.Pattern.As a <$> goPat p
V2.Term.PEffectPure p -> V1.Pattern.EffectPure a <$> goPat p
V2.Term.PEffectBind r i ps p ->
V1.Pattern.EffectBind a <$> (V1.ConstructorReference <$> reference2to1 lookupSize r <*> pure i) <*> traverse goPat ps <*> goPat p
V1.Pattern.EffectBind a (V1.ConstructorReference (reference2to1 r) i) <$> traverse goPat ps <*> goPat p
V2.Term.PSequenceLiteral ps -> V1.Pattern.SequenceLiteral a <$> traverse goPat ps
V2.Term.PSequenceOp p1 op p2 -> V1.Pattern.SequenceOp a <$> goPat p1 <*> pure (goOp op) <*> goPat p2
goOp = \case
@ -208,11 +209,10 @@ term2to1 h lookupSize lookupCT tm =
V2.Term.PConcat -> V1.Pattern.Concat
a = Ann.External
decl2to1 :: Monad m => Hash -> (Hash -> m V1.Reference.Size) -> V2.Decl.Decl V2.Symbol -> m (V1.Decl.Decl V1.Symbol Ann)
decl2to1 h lookupSize (V2.Decl.DataDeclaration dt m bound cts) =
decl2to1 :: Hash -> V2.Decl.Decl V2.Symbol -> V1.Decl.Decl V1.Symbol Ann
decl2to1 h (V2.Decl.DataDeclaration dt m bound cts) =
goCT dt
<$> V1.Decl.DataDeclaration (goMod m) Ann.External (symbol2to1 <$> bound)
<$> cts'
$ V1.Decl.DataDeclaration (goMod m) Ann.External (symbol2to1 <$> bound) cts'
where
goMod = \case
V2.Decl.Structural -> V1.Decl.Structural
@ -220,10 +220,10 @@ decl2to1 h lookupSize (V2.Decl.DataDeclaration dt m bound cts) =
goCT = \case
V2.Decl.Data -> Right
V2.Decl.Effect -> Left . V1.Decl.EffectDeclaration
cts' = traverse mkCtor (zip cts [0 ..])
mkCtor (type1, i) = do
type2 <- dtype2to1 h lookupSize type1
pure $ (Ann.External, V1.symbol . pack $ "Constructor" ++ show i, type2)
cts' = map mkCtor (zip cts [0 ..])
mkCtor (type1, i) =
(Ann.External, V1.symbol . pack $ "Constructor" ++ show i, type2)
where type2 = dtype2to1 h type1
decl1to2 :: Hash -> V1.Decl.Decl V1.Symbol a -> V2.Decl.Decl V2.Symbol
decl1to2 h decl1 = case V1.Decl.asDataDecl decl1 of
@ -247,10 +247,8 @@ symbol1to2 (V1.Symbol i varType) = V2.Symbol i (Var.rawName varType)
shortHashSuffix1to2 :: Text -> V1.Reference.Pos
shortHashSuffix1to2 =
fst
-- todo: move suffix parsing to frontend
. either error id
. V1.Reference.readSuffix
-- todo: move suffix parsing to frontend
either error id . V1.Reference.readSuffix
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)
@ -270,24 +268,22 @@ abt1to2 (V1.ABT.Term fv a out) = V2.ABT.Term fv a (go out)
V1.ABT.Var v -> V2.ABT.Var v
V1.ABT.Tm tm -> V2.ABT.Tm (abt1to2 <$> tm)
rreference2to1 :: Applicative m => Hash -> (Hash -> m V1.Reference.Size) -> V2.Reference' Text (Maybe V2.Hash) -> m V1.Reference
rreference2to1 h lookupSize = \case
V2.ReferenceBuiltin t -> pure $ V1.Reference.Builtin t
V2.ReferenceDerived i -> V1.Reference.DerivedId <$> rreferenceid2to1 h lookupSize i
rreference2to1 :: Hash -> V2.Reference' Text (Maybe V2.Hash) -> V1.Reference
rreference2to1 h = \case
V2.ReferenceBuiltin t -> V1.Reference.Builtin t
V2.ReferenceDerived i -> V1.Reference.DerivedId $ rreferenceid2to1 h i
rreference1to2 :: Hash -> V1.Reference -> V2.Reference' Text (Maybe V2.Hash)
rreference1to2 h = \case
V1.Reference.Builtin t -> V2.ReferenceBuiltin t
V1.Reference.DerivedId i -> V2.ReferenceDerived (rreferenceid1to2 h i)
rreferenceid2to1 :: Functor m => Hash -> (Hash -> m V1.Reference.Size) -> V2.Reference.Id' (Maybe V2.Hash) -> m V1.Reference.Id
rreferenceid2to1 h lookupSize (V2.Reference.Id oh i) =
V1.Reference.Id h' i <$> lookupSize h'
where
h' = maybe h hash2to1 oh
rreferenceid2to1 :: Hash -> V2.Reference.Id' (Maybe V2.Hash) -> V1.Reference.Id
rreferenceid2to1 h (V2.Reference.Id oh i) = V1.Reference.Id h' i
where h' = maybe h hash2to1 oh
rreferenceid1to2 :: Hash -> V1.Reference.Id -> V2.Reference.Id' (Maybe V2.Hash)
rreferenceid1to2 h (V1.Reference.Id h' i _n) = V2.Reference.Id oh i
rreferenceid1to2 h (V1.Reference.Id h' i) = V2.Reference.Id oh i
where
oh = if h == h' then Nothing else Just (hash1to2 h')
@ -303,10 +299,10 @@ branchHash2to1 = V1.Causal.RawHash . hash2to1 . V2.unCausalHash
patchHash1to2 :: V1.Branch.EditHash -> V2.PatchHash
patchHash1to2 = V2.PatchHash . hash1to2
reference2to1 :: Applicative m => (Hash -> m V1.Reference.Size) -> V2.Reference -> m V1.Reference
reference2to1 lookupSize = \case
V2.ReferenceBuiltin t -> pure $ V1.Reference.Builtin t
V2.ReferenceDerived i -> V1.Reference.DerivedId <$> referenceid2to1 lookupSize i
reference2to1 :: V2.Reference -> V1.Reference
reference2to1 = \case
V2.ReferenceBuiltin t -> V1.Reference.Builtin t
V2.ReferenceDerived i -> V1.Reference.DerivedId $ referenceid2to1 i
reference1to2 :: V1.Reference -> V2.Reference
reference1to2 = \case
@ -314,39 +310,38 @@ reference1to2 = \case
V1.Reference.DerivedId i -> V2.ReferenceDerived (referenceid1to2 i)
referenceid1to2 :: V1.Reference.Id -> V2.Reference.Id
referenceid1to2 (V1.Reference.Id h i _n) = V2.Reference.Id (hash1to2 h) i
referenceid1to2 (V1.Reference.Id h i) = V2.Reference.Id (hash1to2 h) i
referenceid2to1 :: Functor m => (Hash -> m V1.Reference.Size) -> V2.Reference.Id -> m V1.Reference.Id
referenceid2to1 lookupSize (V2.Reference.Id h i) =
V1.Reference.Id sh i <$> lookupSize sh
referenceid2to1 :: V2.Reference.Id -> V1.Reference.Id
referenceid2to1 (V2.Reference.Id h i) = V1.Reference.Id sh i
where
sh = hash2to1 h
rreferent2to1 :: Applicative m => Hash -> (Hash -> m V1.Reference.Size) -> (V2.Reference -> m CT.ConstructorType) -> V2.ReferentH -> m V1.Referent
rreferent2to1 h lookupSize lookupCT = \case
V2.Ref r -> V1.Ref <$> rreference2to1 h lookupSize r
V2.Con r i -> V1.Con <$> (V1.ConstructorReference <$> reference2to1 lookupSize r <*> pure (fromIntegral i)) <*> lookupCT r
rreferent2to1 :: Applicative m => Hash -> (V2.Reference -> m CT.ConstructorType) -> V2.ReferentH -> m V1.Referent
rreferent2to1 h lookupCT = \case
V2.Ref r -> pure . V1.Ref $ rreference2to1 h r
V2.Con r i -> V1.Con (V1.ConstructorReference (reference2to1 r) (fromIntegral i)) <$> lookupCT r
rreferent1to2 :: Hash -> V1.Referent -> V2.ReferentH
rreferent1to2 h = \case
V1.Ref r -> V2.Ref (rreference1to2 h r)
V1.Con (V1.ConstructorReference r i) _ct -> V2.Con (reference1to2 r) (fromIntegral i)
referent2to1 :: Applicative m => (Hash -> m V1.Reference.Size) -> (V2.Reference -> m CT.ConstructorType) -> V2.Referent -> m V1.Referent
referent2to1 lookupSize lookupCT = \case
V2.Ref r -> V1.Ref <$> reference2to1 lookupSize r
V2.Con r i -> V1.Con <$> (V1.ConstructorReference <$> reference2to1 lookupSize r <*> pure (fromIntegral i)) <*> lookupCT r
referent2to1 :: Applicative m => (V2.Reference -> m CT.ConstructorType) -> V2.Referent -> m V1.Referent
referent2to1 lookupCT = \case
V2.Ref r -> pure $ V1.Ref (reference2to1 r)
V2.Con r i -> V1.Con (V1.ConstructorReference (reference2to1 r) (fromIntegral i)) <$> lookupCT r
referent1to2 :: V1.Referent -> V2.Referent
referent1to2 = \case
V1.Ref r -> V2.Ref $ reference1to2 r
V1.Con (V1.ConstructorReference r i) _ct -> V2.Con (reference1to2 r) (fromIntegral i)
referentid2to1 :: Applicative m => (Hash -> m V1.Reference.Size) -> (V2.Reference -> m CT.ConstructorType) -> V2.Referent.Id -> m V1.Referent.Id
referentid2to1 lookupSize lookupCT = \case
V2.RefId r -> V1.RefId <$> referenceid2to1 lookupSize r
referentid2to1 :: Applicative m => (V2.Reference -> m CT.ConstructorType) -> V2.Referent.Id -> m V1.Referent.Id
referentid2to1 lookupCT = \case
V2.RefId r -> pure $ V1.RefId (referenceid2to1 r)
V2.ConId r i ->
V1.ConId <$> (V1.ConstructorReference <$>referenceid2to1 lookupSize r <*> pure (fromIntegral i)) <*> lookupCT (V2.ReferenceDerived r)
V1.ConId (V1.ConstructorReference (referenceid2to1 r) (fromIntegral i)) <$> lookupCT (V2.ReferenceDerived r)
hash2to1 :: V2.Hash.Hash -> Hash
hash2to1 (V2.Hash.Hash sbs) = V1.Hash sbs
@ -357,29 +352,29 @@ causalHash2to1 = V1.Causal.RawHash . hash2to1 . V2.unCausalHash
causalHash1to2 :: V1.Causal.RawHash V1.Branch.Raw -> V2.CausalHash
causalHash1to2 = V2.CausalHash . hash1to2 . V1.Causal.unRawHash
ttype2to1 :: Monad m => (Hash -> m V1.Reference.Size) -> V2.Term.Type V2.Symbol -> m (V1.Type.Type V1.Symbol Ann)
ttype2to1 lookupSize = type2to1' (reference2to1 lookupSize)
ttype2to1 :: V2.Term.Type V2.Symbol -> V1.Type.Type V1.Symbol Ann
ttype2to1 = type2to1' reference2to1
dtype2to1 :: Monad m => Hash -> (Hash -> m V1.Reference.Size) -> V2.Decl.Type V2.Symbol -> m (V1.Type.Type V1.Symbol Ann)
dtype2to1 h lookupSize = type2to1' (rreference2to1 h lookupSize)
dtype2to1 :: Hash -> V2.Decl.Type V2.Symbol -> V1.Type.Type V1.Symbol Ann
dtype2to1 h = type2to1' (rreference2to1 h)
type2to1' :: Monad m => (r -> m V1.Reference) -> V2.Type.TypeR r V2.Symbol -> m (V1.Type.Type V1.Symbol Ann)
type2to1' :: (r -> V1.Reference) -> V2.Type.TypeR r V2.Symbol -> V1.Type.Type V1.Symbol Ann
type2to1' convertRef =
V1.ABT.transformM (typeF2to1 convertRef)
V1.ABT.transform (typeF2to1 convertRef)
. V1.ABT.vmap symbol2to1
. V1.ABT.amap (const Ann.External)
. abt2to1
where
typeF2to1 :: Applicative m => (r -> m V1.Reference) -> V2.Type.F' r a -> m (V1.Type.F a)
typeF2to1 :: (r -> V1.Reference) -> V2.Type.F' r a -> (V1.Type.F a)
typeF2to1 convertRef = \case
V2.Type.Ref r -> V1.Type.Ref <$> convertRef r
V2.Type.Arrow i o -> pure $ V1.Type.Arrow i o
V2.Type.Ann a k -> pure $ V1.Type.Ann a (convertKind k)
V2.Type.App f x -> pure $ V1.Type.App f x
V2.Type.Effect e b -> pure $ V1.Type.Effect e b
V2.Type.Effects as -> pure $ V1.Type.Effects as
V2.Type.Forall a -> pure $ V1.Type.Forall a
V2.Type.IntroOuter a -> pure $ V1.Type.IntroOuter a
V2.Type.Ref r -> V1.Type.Ref $ convertRef r
V2.Type.Arrow i o -> V1.Type.Arrow i o
V2.Type.Ann a k -> V1.Type.Ann a (convertKind k)
V2.Type.App f x -> V1.Type.App f x
V2.Type.Effect e b -> V1.Type.Effect e b
V2.Type.Effects as -> V1.Type.Effects as
V2.Type.Forall a -> V1.Type.Forall a
V2.Type.IntroOuter a -> V1.Type.IntroOuter a
where
convertKind = \case
V2.Kind.Star -> V1.Kind.Star
@ -414,23 +409,23 @@ type1to2' convertRef =
V1.Kind.Arrow i o -> V2.Kind.Arrow (convertKind i) (convertKind o)
-- | forces loading v1 branches even if they may not exist
causalbranch2to1 :: Monad m => (String -> Hash -> m V1.Reference.Size) -> (V2.Reference -> m CT.ConstructorType) -> V2.Branch.Causal m -> m (V1.Branch.Branch m)
causalbranch2to1 lookupSize lookupCT = fmap V1.Branch.Branch . causalbranch2to1' lookupSize lookupCT
causalbranch2to1 :: Monad m => (V2.Reference -> m CT.ConstructorType) -> V2.Branch.Causal m -> m (V1.Branch.Branch m)
causalbranch2to1 lookupCT = fmap V1.Branch.Branch . causalbranch2to1' lookupCT
causalbranch2to1' :: Monad m => (String -> Hash -> m V1.Reference.Size) -> (V2.Reference -> m CT.ConstructorType) -> V2.Branch.Causal m -> m (V1.Branch.UnwrappedBranch m)
causalbranch2to1' lookupSize lookupCT (V2.Causal hc _he (Map.toList -> parents) me) = do
causalbranch2to1' :: Monad m => (V2.Reference -> m CT.ConstructorType) -> V2.Branch.Causal m -> m (V1.Branch.UnwrappedBranch m)
causalbranch2to1' lookupCT (V2.Causal hc _he (Map.toList -> parents) me) = do
let currentHash = causalHash2to1 hc
case parents of
[] -> V1.Causal.One currentHash <$> (me >>= branch2to1 lookupSize lookupCT)
[] -> V1.Causal.UnsafeOne currentHash <$> (me >>= branch2to1 lookupCT)
[(hp, mp)] -> do
let parentHash = causalHash2to1 hp
V1.Causal.Cons currentHash
<$> (me >>= branch2to1 lookupSize lookupCT)
<*> pure (parentHash, causalbranch2to1' lookupSize lookupCT =<< mp)
V1.Causal.UnsafeCons currentHash
<$> (me >>= branch2to1 lookupCT)
<*> pure (parentHash, causalbranch2to1' lookupCT =<< mp)
merge -> do
let tailsList = map (bimap causalHash2to1 (causalbranch2to1' lookupSize lookupCT =<<)) merge
let tailsList = map (bimap causalHash2to1 (causalbranch2to1' lookupCT =<<)) merge
e <- me
V1.Causal.Merge currentHash <$> branch2to1 lookupSize lookupCT e <*> pure (Map.fromList tailsList)
V1.Causal.UnsafeMerge currentHash <$> branch2to1 lookupCT e <*> pure (Map.fromList tailsList)
causalbranch1to2 :: forall m. Monad m => V1.Branch.Branch m -> V2.Branch.Causal m
causalbranch1to2 (V1.Branch.Branch c) = causal1to2' hash1to2cb hash1to2c branch1to2 c
@ -453,13 +448,15 @@ causalbranch1to2 (V1.Branch.Branch c) = causal1to2' hash1to2cb hash1to2c branch1
V1.Causal.Cons (h1to22 -> (hc, hb)) e (ht, mt) -> V2.Causal hc hb (Map.singleton (h1to2 ht) (causal1to2 h1to22 h1to2 e1to2 <$> mt)) (e1to2 e)
V1.Causal.Merge (h1to22 -> (hc, hb)) e parents -> V2.Causal hc hb (Map.bimap h1to2 (causal1to2 h1to22 h1to2 e1to2 <$>) parents) (e1to2 e)
-- todo: this could be a pure function
branch1to2 :: forall m. Monad m => V1.Branch.Branch0 m -> m (V2.Branch.Branch m)
branch1to2 b = do
terms <- pure $ doTerms (V1.Branch._terms b)
types <- pure $ doTypes (V1.Branch._types b)
patches <- pure $ doPatches (V1.Branch._edits b)
children <- pure $ doChildren (V1.Branch._children b)
pure $ V2.Branch.Branch terms types patches children
branch1to2 b =
pure $
V2.Branch.Branch
(doTerms (V1.Branch._terms b))
(doTypes (V1.Branch._types b))
(doPatches (V1.Branch._edits b))
(doChildren (V1.Branch._children b))
where
-- is there a more readable way to structure these that's also linear?
doTerms :: V1.Branch.Star V1.Referent.Referent V1.NameSegment -> Map V2.Branch.NameSegment (Map V2.Referent.Referent (m V2.Branch.MdValues))
@ -498,32 +495,27 @@ causalbranch1to2 (V1.Branch.Branch c) = causal1to2' hash1to2cb hash1to2c branch1
doChildren :: Map V1.NameSegment (V1.Branch.Branch m) -> Map V2.Branch.NameSegment (V2.Branch.Causal m)
doChildren = Map.bimap namesegment1to2 causalbranch1to2
patch2to1 ::
forall m.
Monad m =>
(String -> Hash -> m V1.Reference.Size) ->
V2.Branch.Patch ->
m V1.Patch
patch2to1 lookupSize (V2.Branch.Patch v2termedits v2typeedits) = do
termEdits <- Map.bitraverse referent2to1' (Set.traverse termedit2to1) v2termedits
typeEdits <- Map.bitraverse (reference2to1 (lookupSize "patch->old type")) (Set.traverse typeedit2to1) v2typeedits
pure $ V1.Patch (Relation.fromMultimap termEdits) (Relation.fromMultimap typeEdits)
patch2to1 :: V2.Branch.Patch -> V1.Patch
patch2to1 (V2.Branch.Patch v2termedits v2typeedits) =
V1.Patch (Relation.fromMultimap termEdits) (Relation.fromMultimap typeEdits)
where
referent2to1' :: V2.Referent -> m V1.Reference
termEdits = Map.bimap referent2to1' (Set.map termedit2to1) v2termedits
typeEdits = Map.bimap reference2to1 (Set.map typeedit2to1) v2typeedits
referent2to1' :: V2.Referent -> V1.Reference
referent2to1' = \case
V2.Referent.Ref r -> reference2to1 (lookupSize "patch->old term") r
V2.Referent.Ref r -> reference2to1 r
V2.Referent.Con {} -> error "found referent on LHS when converting patch2to1"
termedit2to1 :: V2.TermEdit.TermEdit -> m V1.TermEdit.TermEdit
termedit2to1 :: V2.TermEdit.TermEdit -> V1.TermEdit.TermEdit
termedit2to1 = \case
V2.TermEdit.Replace (V2.Referent.Ref r) t ->
V1.TermEdit.Replace <$> reference2to1 (lookupSize "patch->new term") r <*> typing2to1 t
V1.TermEdit.Replace (reference2to1 r) (typing2to1 t)
V2.TermEdit.Replace {} -> error "found referent on RHS when converting patch2to1"
V2.TermEdit.Deprecate -> pure V1.TermEdit.Deprecate
typeedit2to1 :: V2.TypeEdit.TypeEdit -> m V1.TypeEdit.TypeEdit
V2.TermEdit.Deprecate -> V1.TermEdit.Deprecate
typeedit2to1 :: V2.TypeEdit.TypeEdit -> V1.TypeEdit.TypeEdit
typeedit2to1 = \case
V2.TypeEdit.Replace r -> V1.TypeEdit.Replace <$> reference2to1 (lookupSize "patch->new type") r
V2.TypeEdit.Deprecate -> pure V1.TypeEdit.Deprecate
typing2to1 t = pure $ case t of
V2.TypeEdit.Replace r -> V1.TypeEdit.Replace (reference2to1 r)
V2.TypeEdit.Deprecate -> V1.TypeEdit.Deprecate
typing2to1 t = case t of
V2.TermEdit.Same -> V1.TermEdit.Same
V2.TermEdit.Subtype -> V1.TermEdit.Subtype
V2.TermEdit.Different -> V1.TermEdit.Different
@ -560,55 +552,26 @@ namesegment1to2 (V1.NameSegment t) = V2.Branch.NameSegment t
branch2to1 ::
Monad m =>
(String -> Hash -> m V1.Reference.Size) ->
(V2.Reference -> m CT.ConstructorType) ->
V2.Branch.Branch m ->
m (V1.Branch.Branch0 m)
branch2to1 lookupSize lookupCT (V2.Branch.Branch v2terms v2types v2patches v2children) = do
v1terms <- toStar (reference2to1 $ lookupSize "term metadata") =<< Map.bitraverse (pure . namesegment2to1) (Map.bitraverse (referent2to1 (lookupSize "term") lookupCT) id) v2terms
v1types <- toStar (reference2to1 $ lookupSize "type metadata") =<< Map.bitraverse (pure . namesegment2to1) (Map.bitraverse (reference2to1 (lookupSize "type")) id) v2types
v1patches <- Map.bitraverse (pure . namesegment2to1) (bitraverse (pure . edithash2to1) (fmap (patch2to1 lookupSize))) v2patches
v1children <- Map.bitraverse (pure . namesegment2to1) (causalbranch2to1 lookupSize lookupCT) v2children
branch2to1 lookupCT (V2.Branch.Branch v2terms v2types v2patches v2children) = do
v1terms <- toStar reference2to1 <$> Map.bitraverse (pure . namesegment2to1) (Map.bitraverse (referent2to1 lookupCT) id) v2terms
v1types <- toStar reference2to1 <$> Map.bitraverse (pure . namesegment2to1) (Map.bitraverse (pure . reference2to1) id) v2types
v1children <- Map.bitraverse (pure . namesegment2to1) (causalbranch2to1 lookupCT) v2children
pure $ V1.Branch.branch0 v1terms v1types v1children v1patches
where
toStar :: forall m name ref. (Monad m, Ord name, Ord ref) => (V2.Reference -> m V1.Reference) -> Map name (Map ref V2.Branch.MdValues) -> m (V1.Metadata.Star ref name)
toStar mdref2to1 m = foldM insert mempty (Map.toList m)
v1patches = Map.bimap namesegment2to1 (bimap edithash2to1 (fmap patch2to1)) v2patches
toStar :: forall name ref. (Ord name, Ord ref) => (V2.Reference -> V1.Reference) -> Map name (Map ref V2.Branch.MdValues) -> V1.Metadata.Star ref name
toStar mdref2to1 m = foldl' insert mempty (Map.toList m)
where
insert star (name, m) = foldM (insert' name) star (Map.toList m)
insert' :: name -> V1.Metadata.Star ref name -> (ref, V2.Branch.MdValues) -> m (V1.Metadata.Star ref name)
insert' name star (ref, V2.Branch.MdValues mdvals) = do
insert star (name, m) = foldl' (insert' name) star (Map.toList m)
insert' :: name -> V1.Metadata.Star ref name -> (ref, V2.Branch.MdValues) -> V1.Metadata.Star ref name
insert' name star (ref, V2.Branch.MdValues mdvals) =
let facts = Set.singleton ref
names = Relation.singleton ref name
types :: Relation.Relation ref V1.Metadata.Type <-
Relation.insertManyRan ref <$> traverse mdref2to1 (Map.elems mdvals) <*> pure mempty
vals :: Relation.Relation ref (V1.Metadata.Type, V1.Metadata.Value) <-
Relation.insertManyRan ref <$> (traverse (\(t, v) -> (,) <$> mdref2to1 v <*> mdref2to1 t) (Map.toList mdvals)) <*> pure mempty
pure $ star <> V1.Star3.Star3 facts names types vals
-- V2.Branch0 should have the metadata types, could bulk load with relational operations
-- type Star a n = Star3 a n Type (Type, Value)
-- type Star a n = Star3 a n Type (Reference, Reference)
-- MdValues is a Set V2.Reference
-- (Name, TermRef, Metadata Type, Metadata Value) <-- decided not this (because name was too long/repetitive?)
-- (BranchId/Hash, TermRef, Metadata Type, Metadata Value) <-- what about this
-- data V2.Branch m = Branch
-- { terms :: Map NameSegment (Map Referent (m MdValues)),
-- types :: Map NameSegment (Map Reference (m MdValues)),
-- patches :: Map NameSegment (PatchHash, m Patch),
-- children :: Map NameSegment (Causal m)
-- }
-- branch0 :: Metadata.Star Referent NameSegment
-- -> Metadata.Star Reference NameSegment
-- -> Map NameSegment (Branch m)
-- -> Map NameSegment (EditHash, m Patch)
-- -> Branch0 m
-- type Metadata.Star a n = Star3 a n Type (Type, Value)
-- data Star3 fact d1 d2 d3
-- = Star3 { fact :: Set fact
-- , d1 :: Relation fact d1
-- , d2 :: Relation fact d2
-- , d3 :: Relation fact d3 } deriving (Eq,Ord,Show)
types :: Relation.Relation ref V1.Metadata.Type =
Relation.insertManyRan ref (fmap mdref2to1 (Map.elems mdvals)) mempty
vals :: Relation.Relation ref (V1.Metadata.Type, V1.Metadata.Value) =
Relation.insertManyRan ref (fmap (\(v, t) -> (mdref2to1 t, mdref2to1 v)) (Map.toList mdvals)) mempty
in star <> V1.Star3.Star3 facts names types vals

919
parser-typechecker/src/Unison/Codebase/SqliteCodebase/MigrateSchema12.hs Normal file
View File

@ -0,0 +1,919 @@
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Unison.Codebase.SqliteCodebase.MigrateSchema12
( migrateSchema12,
)
where
import Control.Lens
import Control.Monad.Except (ExceptT, runExceptT)
import Control.Monad.Reader (ReaderT (runReaderT), ask, mapReaderT)
import Control.Monad.State.Strict
import Control.Monad.Trans.Except (throwE)
import Control.Monad.Trans.Writer.CPS (Writer, execWriter, tell)
import Data.Generics.Product
import Data.Generics.Sum (_Ctor)
import Data.List.Extra (nubOrd)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Tuple (swap)
import Data.Tuple.Extra ((***))
import qualified Data.Zip as Zip
import System.Environment (lookupEnv)
import System.IO.Unsafe (unsafePerformIO)
import U.Codebase.HashTags (BranchHash (..), CausalHash (..), PatchHash (..))
import qualified U.Codebase.Reference as UReference
import qualified U.Codebase.Referent as UReferent
import qualified U.Codebase.Sqlite.Branch.Full as S
import qualified U.Codebase.Sqlite.Branch.Full as S.Branch.Full
import U.Codebase.Sqlite.Causal (GDbCausal (..))
import qualified U.Codebase.Sqlite.Causal as SC
import U.Codebase.Sqlite.Connection (Connection)
import U.Codebase.Sqlite.DbId
( BranchHashId (..),
BranchObjectId (..),
CausalHashId (..),
HashId,
ObjectId,
PatchObjectId (..),
TextId,
)
import qualified U.Codebase.Sqlite.LocalizeObject as S.LocalizeObject
import qualified U.Codebase.Sqlite.Operations as Ops
import qualified U.Codebase.Sqlite.Patch.Format as S.Patch.Format
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.Sync (Sync (Sync))
import qualified U.Codebase.Sync as Sync
import U.Codebase.WatchKind (WatchKind)
import qualified U.Codebase.WatchKind as WK
import U.Util.Monoid (foldMapM)
import qualified Unison.ABT as ABT
import qualified Unison.Codebase as Codebase
import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv
import qualified Unison.Codebase.SqliteCodebase.MigrateSchema12.DbHelpers as Hashing
import Unison.Codebase.Type (Codebase (Codebase))
import qualified Unison.ConstructorReference as ConstructorReference
import qualified Unison.DataDeclaration as DD
import Unison.DataDeclaration.ConstructorId (ConstructorId)
import Unison.Hash (Hash)
import qualified Unison.Hash as Unison
import qualified Unison.Hashing.V2.Causal as Hashing
import qualified Unison.Hashing.V2.Convert as Convert
import Unison.Pattern (Pattern)
import qualified Unison.Pattern as Pattern
import Unison.Prelude
import qualified Unison.Reference as Reference
import qualified Unison.Referent as Referent
import qualified Unison.Referent' as Referent'
import qualified Unison.Term as Term
import Unison.Type (Type)
import qualified Unison.Type as Type
import qualified Unison.Util.Set as Set
import Unison.Var (Var)
import UnliftIO (MonadUnliftIO)
import UnliftIO.Exception (bracket_, onException)
-- todo:
-- * write a harness to call & seed algorithm
-- * [x] embed migration in a transaction/savepoint and ensure that we never leave the codebase in a
-- weird state even if we crash.
-- * [x] may involve writing a `Progress`
-- * raw DB things:
-- * [x] write new namespace root after migration.
-- * [x] overwrite object_id column in hash_object table to point at new objects
-- * [x] delete references to old objects in index tables (where else?)
-- * [x] delete old objects
--
-- * refer to github megaticket https://github.com/unisonweb/unison/issues/2471
-- ☢️ [x] incorporate type signature into hash of term <- chris/arya have started ☢️
-- [x] store type annotation in the term
-- * [x] Refactor Causal helper functions to use V2 hashing
-- * [x] I guess move Hashable to V2.Hashing pseudo-package
-- * [x] Delete V1 Hashing to ensure it's unused
-- * [x] Salt V2 hashes with version number
-- * [ ] confirm that pulls are handled ok
-- * [x] Make a backup of the v1 codebase before migrating, in a temp directory.
-- Include a message explaining where we put it.
-- * [ ] Improved error message (don't crash) if loading a codebase newer than your ucm
-- * [x] Update the schema version in the database after migrating so we only migrate
-- once.
verboseOutput :: Bool
verboseOutput =
isJust (unsafePerformIO (lookupEnv "UNISON_MIGRATION_DEBUG"))
{-# NOINLINE verboseOutput #-}
migrateSchema12 :: forall a m v. (MonadUnliftIO m, Var v) => Connection -> Codebase m v a -> m ()
migrateSchema12 conn codebase = do
withinSavepoint "MIGRATESCHEMA12" $ do
liftIO $ putStrLn $ "Starting codebase migration. This may take a while, it's a good time to make some tea ☕️"
corruptedCausals <- runDB conn (liftQ Q.getCausalsWithoutBranchObjects)
when (not . null $ corruptedCausals) $ do
liftIO $ putStrLn $ "⚠️ I detected " <> show (length corruptedCausals) <> " corrupted namespace(s) in the history of the codebase."
liftIO $ putStrLn $ "This is due to a bug in a previous version of ucm."
liftIO $ putStrLn $ "This only affects the history of your codebase, the most up-to-date iteration will remain intact."
liftIO $ putStrLn $ "I'll go ahead with the migration, but will replace any corrupted namespaces with empty ones."
liftIO $ putStrLn $ "Updating Namespace Root..."
rootCausalHashId <- runDB conn (liftQ Q.loadNamespaceRoot)
numEntitiesToMigrate <- runDB conn . liftQ $ do
sum <$> sequenceA [Q.countObjects, Q.countCausals, Q.countWatches]
v2EmptyBranchHashInfo <- saveV2EmptyBranch conn
watches <-
foldMapM
(\watchKind -> map (W watchKind) <$> Codebase.watches codebase (Cv.watchKind2to1 watchKind))
[WK.RegularWatch, WK.TestWatch]
migrationState <-
(Sync.sync @_ @Entity migrationSync (progress numEntitiesToMigrate) (CausalE rootCausalHashId : watches))
`runReaderT` Env {db = conn, codebase}
`execStateT` MigrationState Map.empty Map.empty Map.empty Set.empty 0 v2EmptyBranchHashInfo
let (_, newRootCausalHashId) = causalMapping migrationState ^?! ix rootCausalHashId
liftIO $ putStrLn $ "Updating Namespace Root..."
runDB conn . liftQ $ Q.setNamespaceRoot newRootCausalHashId
liftIO $ putStrLn $ "Rewriting old object IDs..."
ifor_ (objLookup migrationState) \oldObjId (newObjId, _, _, _) -> do
(runDB conn . liftQ) do
Q.recordObjectRehash oldObjId newObjId
liftIO $ putStrLn $ "Garbage collecting orphaned objects..."
runDB conn (liftQ Q.garbageCollectObjectsWithoutHashes)
liftIO $ putStrLn $ "Garbage collecting orphaned watches..."
runDB conn (liftQ Q.garbageCollectWatchesWithoutObjects)
liftIO $ putStrLn $ "Updating Schema Version..."
runDB conn . liftQ $ Q.setSchemaVersion 2
liftIO $ putStrLn $ "Cleaning up..."
runDB conn (liftQ Q.vacuum)
where
withinSavepoint :: (String -> m c -> m c)
withinSavepoint name act =
bracket_
(runDB conn $ Q.savepoint name)
(runDB conn $ Q.release name)
(act `onException` runDB conn (Q.rollbackTo name))
progress :: Int -> Sync.Progress (ReaderT (Env m v a) (StateT MigrationState m)) Entity
progress numToMigrate =
let incrementProgress :: ReaderT (Env m v a) (StateT MigrationState m) ()
incrementProgress = do
numDone <- field @"numMigrated" <+= 1
liftIO $ putStr $ "\r 🏗 " <> show numDone <> " / ~" <> show numToMigrate <> " entities migrated. 🚧"
need :: Entity -> ReaderT (Env m v a) (StateT MigrationState m) ()
need e = when verboseOutput $ liftIO $ putStrLn $ "Need: " ++ show e
done :: Entity -> ReaderT (Env m v a) (StateT MigrationState m) ()
done e = do
when verboseOutput $ liftIO $ putStrLn $ "Done: " ++ show e
incrementProgress
errorHandler :: Entity -> ReaderT (Env m v a) (StateT MigrationState m) ()
errorHandler e = do
case e of
-- We expect non-fatal errors when migrating watches.
W {} -> pure ()
e -> liftIO $ putStrLn $ "Error: " ++ show e
incrementProgress
allDone :: ReaderT (Env m v a) (StateT MigrationState m) ()
allDone = liftIO $ putStrLn $ "\nFinished migrating, initiating cleanup."
in Sync.Progress {need, done, error = errorHandler, allDone}
type Old a = a
type New a = a
type ConstructorName v = v
type DeclName v = v
data MigrationState = MigrationState
-- Mapping between old cycle-position -> new cycle-position for a given Decl object.
{ referenceMapping :: Map (Old SomeReferenceId) (New SomeReferenceId),
causalMapping :: Map (Old CausalHashId) (New (CausalHash, CausalHashId)),
-- We also store the old hash for this object ID since we need a way to
-- convert Object Reference IDs into Hash Reference IDs so we can use the referenceMapping.
objLookup :: Map (Old ObjectId) (New ObjectId, New HashId, New Hash, Old Hash),
-- Remember the hashes of term/decls that we have already migrated to avoid migrating them twice.
migratedDefnHashes :: Set (Old Hash),
numMigrated :: Int,
v2EmptyBranchHashInfo :: (BranchHashId, Hash)
}
deriving (Generic)
data Entity
= TermComponent Unison.Hash
| DeclComponent Unison.Hash
| CausalE CausalHashId
| BranchE ObjectId
| PatchE ObjectId
| W WK.WatchKind Reference.Id
deriving (Eq, Ord, Show)
data Env m v a = Env {db :: Connection, codebase :: Codebase m v a}
migrationSync ::
(MonadIO m, Var v) =>
Sync (ReaderT (Env m v a) (StateT MigrationState m)) Entity
migrationSync = Sync \case
TermComponent hash -> do
Env {codebase, db} <- ask
lift (migrateTermComponent db codebase hash)
DeclComponent hash -> do
Env {codebase, db} <- ask
lift (migrateDeclComponent db codebase hash)
BranchE objectId -> do
Env {db} <- ask
lift (migrateBranch db objectId)
CausalE causalHashId -> do
Env {db} <- ask
lift (migrateCausal db causalHashId)
PatchE objectId -> do
Env {db} <- ask
lift (migratePatch db (PatchObjectId objectId))
W watchKind watchId -> do
Env {codebase} <- ask
lift (migrateWatch codebase watchKind watchId)
runDB :: MonadIO m => Connection -> ReaderT Connection (ExceptT Ops.Error (ExceptT Q.Integrity m)) a -> m a
runDB conn = (runExceptT >=> err) . (runExceptT >=> err) . flip runReaderT conn
where
err :: forall e x m. (Show e, Applicative m) => (Either e x -> m x)
err = \case Left err -> error $ show err; Right a -> pure a
liftQ :: Monad m => ReaderT Connection (ExceptT Q.Integrity m) a -> ReaderT Connection (ExceptT Ops.Error (ExceptT Q.Integrity m)) a
liftQ = mapReaderT lift
migrateCausal :: MonadIO m => Connection -> CausalHashId -> StateT MigrationState m (Sync.TrySyncResult Entity)
migrateCausal conn oldCausalHashId = fmap (either id id) . runExceptT $ do
whenM (Map.member oldCausalHashId <$> use (field @"causalMapping")) (throwE Sync.PreviouslyDone)
oldBranchHashId <- runDB conn . liftQ $ Q.loadCausalValueHashId oldCausalHashId
oldCausalParentHashIds <- runDB conn . liftQ $ Q.loadCausalParents oldCausalHashId
maybeOldBranchObjId <-
runDB conn . liftQ $
Q.maybeObjectIdForAnyHashId (unBranchHashId oldBranchHashId)
migratedObjIds <- gets objLookup
-- If the branch for this causal hasn't been migrated, migrate it first.
let unmigratedBranch =
case maybeOldBranchObjId of
Just branchObjId | branchObjId `Map.notMember` migratedObjIds -> [BranchE branchObjId]
_ -> []
migratedCausals <- gets causalMapping
let unmigratedParents =
oldCausalParentHashIds
& filter (`Map.notMember` migratedCausals)
& fmap CausalE
let unmigratedEntities = unmigratedBranch <> unmigratedParents
when (not . null $ unmigratedParents <> unmigratedBranch) (throwE $ Sync.Missing unmigratedEntities)
(newBranchHashId, newBranchHash) <- case maybeOldBranchObjId of
-- Some codebases are corrupted, likely due to interrupted save operations.
-- It's unfortunate, but rather than fail the whole migration we'll just replace them
-- with an empty branch.
Nothing -> use (field @"v2EmptyBranchHashInfo")
Just branchObjId -> do
let (_, newBranchHashId, newBranchHash, _) = migratedObjIds ^?! ix branchObjId
pure (BranchHashId newBranchHashId, newBranchHash)
let (newParentHashes, newParentHashIds) =
oldCausalParentHashIds
& fmap
(\oldParentHashId -> migratedCausals ^?! ix oldParentHashId)
& unzip
& bimap (Set.fromList . map unCausalHash) Set.fromList
let newCausalHash :: CausalHash
newCausalHash =
CausalHash . Cv.hash1to2 $
Hashing.hashCausal
( Hashing.Causal
{ branchHash = newBranchHash,
parents = Set.mapMonotonic Cv.hash2to1 newParentHashes
}
)
newCausalHashId <- runDB conn (Q.saveCausalHash newCausalHash)
let newCausal =
DbCausal
{ selfHash = newCausalHashId,
valueHash = newBranchHashId,
parents = newParentHashIds
}
runDB conn do
Q.saveCausal (SC.selfHash newCausal) (SC.valueHash newCausal)
Q.saveCausalParents (SC.selfHash newCausal) (Set.toList $ SC.parents newCausal)
field @"causalMapping" %= Map.insert oldCausalHashId (newCausalHash, newCausalHashId)
pure Sync.Done
migrateBranch :: MonadIO m => Connection -> ObjectId -> StateT MigrationState m (Sync.TrySyncResult Entity)
migrateBranch conn oldObjectId = fmap (either id id) . runExceptT $ do
whenM (Map.member oldObjectId <$> use (field @"objLookup")) (throwE Sync.PreviouslyDone)
oldBranch <- runDB conn (Ops.loadDbBranchByObjectId (BranchObjectId oldObjectId))
oldHash <- fmap Cv.hash2to1 . runDB conn $ Ops.loadHashByObjectId oldObjectId
oldBranchWithHashes <- runDB conn (traverseOf S.branchHashes_ (fmap Cv.hash2to1 . Ops.loadHashByObjectId) oldBranch)
migratedRefs <- gets referenceMapping
migratedObjects <- gets objLookup
migratedCausals <- gets causalMapping
let allMissingTypesAndTerms :: [Entity]
allMissingTypesAndTerms =
oldBranchWithHashes
^.. branchSomeRefs_
. uRefIdAsRefId_
. filtered (`Map.notMember` migratedRefs)
. to someReferenceIdToEntity
let allMissingPatches :: [Entity] =
oldBranch
^.. S.patches_
. to unPatchObjectId
. filtered (`Map.notMember` migratedObjects)
. to PatchE
let allMissingChildBranches :: [Entity] =
oldBranch
^.. S.childrenHashes_
. _1
. to unBranchObjectId
. filtered (`Map.notMember` migratedObjects)
. to BranchE
let allMissingChildCausals :: [Entity] =
oldBranch
^.. S.childrenHashes_
. _2
. filtered (`Map.notMember` migratedCausals)
. to CausalE
-- Identify dependencies and bail out if they aren't all built
let allMissingReferences :: [Entity]
allMissingReferences =
allMissingTypesAndTerms
++ allMissingPatches
++ allMissingChildBranches
++ allMissingChildCausals
when (not . null $ allMissingReferences) $
throwE $ Sync.Missing allMissingReferences
let remapPatchObjectId patchObjId = case Map.lookup (unPatchObjectId patchObjId) migratedObjects of
Nothing -> error $ "Expected patch: " <> show patchObjId <> " to be migrated"
Just (newPatchObjId, _, _, _) -> PatchObjectId newPatchObjId
let remapCausalHashId causalHashId = case Map.lookup causalHashId migratedCausals of
Nothing -> error $ "Expected causal hash id: " <> show causalHashId <> " to be migrated"
Just (_, newCausalHashId) -> newCausalHashId
let remapBranchObjectId objId = case Map.lookup (unBranchObjectId objId) migratedObjects of
Nothing -> error $ "Expected object: " <> show objId <> " to be migrated"
Just (newBranchObjId, _, _, _) -> BranchObjectId newBranchObjId
let newBranch :: S.DbBranch
newBranch =
oldBranch
& branchSomeRefs_ %~ remapObjIdRefs migratedObjects migratedRefs
& S.patches_ %~ remapPatchObjectId
& S.childrenHashes_ %~ (remapBranchObjectId *** remapCausalHashId)
let (localBranchIds, localBranch) = S.LocalizeObject.localizeBranch newBranch
newHash <- runDB conn (Ops.liftQ (Hashing.dbBranchHash newBranch))
newHashId <- runDB conn (Ops.liftQ (Q.saveBranchHash (BranchHash (Cv.hash1to2 newHash))))
newObjectId <- runDB conn (Ops.saveBranchObject newHashId localBranchIds localBranch)
field @"objLookup" %= Map.insert oldObjectId (unBranchObjectId newObjectId, unBranchHashId newHashId, newHash, oldHash)
pure Sync.Done
migratePatch ::
forall m.
MonadIO m =>
Connection ->
Old PatchObjectId ->
StateT MigrationState m (Sync.TrySyncResult Entity)
migratePatch conn oldObjectId = fmap (either id id) . runExceptT $ do
whenM (Map.member (unPatchObjectId oldObjectId) <$> use (field @"objLookup")) (throwE Sync.PreviouslyDone)
oldHash <- fmap Cv.hash2to1 . runDB conn $ Ops.loadHashByObjectId (unPatchObjectId oldObjectId)
oldPatch <- runDB conn (Ops.loadDbPatchById oldObjectId)
let hydrateHashes :: forall m. Q.EDB m => HashId -> m Hash
hydrateHashes hashId = do
Cv.hash2to1 <$> Q.loadHashHashById hashId
let hydrateObjectIds :: forall m. Ops.EDB m => ObjectId -> m Hash
hydrateObjectIds objId = do
Cv.hash2to1 <$> Ops.loadHashByObjectId objId
oldPatchWithHashes :: S.Patch' TextId Hash Hash <-
runDB conn do
(oldPatch & S.patchH_ %%~ liftQ . hydrateHashes)
>>= (S.patchO_ %%~ hydrateObjectIds)
migratedRefs <- gets referenceMapping
let isUnmigratedRef ref = Map.notMember ref migratedRefs
-- 2. Determine whether all things the patch refers to are built.
let unmigratedDependencies :: [Entity]
unmigratedDependencies =
oldPatchWithHashes ^.. patchSomeRefsH_ . uRefIdAsRefId_ . filtered isUnmigratedRef . to someReferenceIdToEntity
<> oldPatchWithHashes ^.. patchSomeRefsO_ . uRefIdAsRefId_ . filtered isUnmigratedRef . to someReferenceIdToEntity
when (not . null $ unmigratedDependencies) (throwE (Sync.Missing unmigratedDependencies))
let hashToHashId :: forall m. Q.EDB m => Hash -> m HashId
hashToHashId h =
fromMaybe (error $ "expected hashId for hash: " <> show h) <$> (Q.loadHashIdByHash (Cv.hash1to2 h))
let hashToObjectId :: forall m. Q.EDB m => Hash -> m ObjectId
hashToObjectId = hashToHashId >=> Q.expectObjectIdForPrimaryHashId
migratedReferences <- gets referenceMapping
let remapRef :: SomeReferenceId -> SomeReferenceId
remapRef ref = Map.findWithDefault ref ref migratedReferences
let newPatch =
oldPatchWithHashes
& patchSomeRefsH_ . uRefIdAsRefId_ %~ remapRef
& patchSomeRefsO_ . uRefIdAsRefId_ %~ remapRef
newPatchWithIds :: S.Patch <-
runDB conn . liftQ $ do
(newPatch & S.patchH_ %%~ hashToHashId)
>>= (S.patchO_ %%~ hashToObjectId)
let (localPatchIds, localPatch) = S.LocalizeObject.localizePatch newPatchWithIds
newHash <- runDB conn (liftQ (Hashing.dbPatchHash newPatchWithIds))
newObjectId <- runDB conn (Ops.saveDbPatch (PatchHash (Cv.hash1to2 newHash)) (S.Patch.Format.Full localPatchIds localPatch))
newHashId <- runDB conn (liftQ (Q.expectHashIdByHash (Cv.hash1to2 newHash)))
field @"objLookup" %= Map.insert (unPatchObjectId oldObjectId) (unPatchObjectId newObjectId, newHashId, newHash, oldHash)
pure Sync.Done
-- | PLAN
-- *
-- NOTE: this implementation assumes that watches will be migrated AFTER everything else is finished.
-- This is because it's difficult for us to know otherwise whether a reference refers to something which doesn't exist, or just
-- something that hasn't been migrated yet. If we do it last, we know that missing references are indeed just missing from the codebase.
migrateWatch ::
forall m v a.
(MonadIO m, Ord v) =>
Codebase m v a ->
WatchKind ->
Reference.Id ->
StateT MigrationState m (Sync.TrySyncResult Entity)
migrateWatch Codebase {getWatch, putWatch} watchKind oldWatchId = fmap (either id id) . runExceptT $ do
let watchKindV1 = Cv.watchKind2to1 watchKind
watchResultTerm <-
(lift . lift) (getWatch watchKindV1 oldWatchId) >>= \case
-- The hash which we're watching doesn't exist in the codebase, throw out this watch.
Nothing -> throwE Sync.Done
Just term -> pure term
migratedReferences <- gets referenceMapping
newWatchId <- case Map.lookup (TermReference oldWatchId) migratedReferences of
(Just (TermReference newRef)) -> pure newRef
_ -> throwE Sync.NonFatalError
let maybeRemappedTerm :: Maybe (Term.Term v a)
maybeRemappedTerm =
watchResultTerm
& termReferences_ %%~ \someRef -> Map.lookup someRef migratedReferences
case maybeRemappedTerm of
-- One or more references in the result didn't exist in our codebase.
Nothing -> pure Sync.NonFatalError
Just remappedTerm -> do
lift . lift $ putWatch watchKindV1 newWatchId remappedTerm
pure Sync.Done
uRefIdAsRefId_ :: Iso' (SomeReference (UReference.Id' Hash)) SomeReferenceId
uRefIdAsRefId_ = mapping uRefAsRef_
uRefAsRef_ :: Iso' (UReference.Id' Hash) Reference.Id
uRefAsRef_ = iso intoRef intoURef
where
intoRef (UReference.Id hash pos) = Reference.Id hash pos
intoURef (Reference.Id hash pos) = UReference.Id hash pos
-- Project an S.Referent'' into its SomeReferenceObjId's
someReferent_ ::
forall t h.
(forall ref. Traversal' ref (SomeReference ref)) ->
Traversal' (S.Branch.Full.Referent'' t h) (SomeReference (UReference.Id' h))
someReferent_ typeOrTermTraversal_ =
(UReferent._Ref . someReference_ typeOrTermTraversal_)
`failing` ( UReferent._Con
. asPair_ -- Need to unpack the embedded reference AND remap between mismatched Constructor ID types.
. asConstructorReference_
)
where
asPair_ f (UReference.ReferenceDerived id', conId) =
f (ConstructorReference.ConstructorReference id' (fromIntegral conId))
<&> \(ConstructorReference.ConstructorReference newId newConId) ->
(UReference.ReferenceDerived newId, fromIntegral newConId)
asPair_ _ (UReference.ReferenceBuiltin x, conId) = pure (UReference.ReferenceBuiltin x, conId)
-- asPair_ f (UReference.ReferenceDerived id', conId) =
-- f (id', fromIntegral conId)
-- <&> \(newId, newConId) -> (UReference.ReferenceDerived newId, fromIntegral newConId)
-- asPair_ _ (UReference.ReferenceBuiltin x, conId) = pure (UReference.ReferenceBuiltin x, conId)
someReference_ ::
(forall ref. Traversal' ref (SomeReference ref)) ->
Traversal' (UReference.Reference' t h) (SomeReference (UReference.Id' h))
someReference_ typeOrTermTraversal_ = UReference._ReferenceDerived . typeOrTermTraversal_
someMetadataSetFormat_ ::
(Ord t, Ord h) =>
(forall ref. Traversal' ref (SomeReference ref)) ->
Traversal' (S.Branch.Full.MetadataSetFormat' t h) (SomeReference (UReference.Id' h))
someMetadataSetFormat_ typeOrTermTraversal_ =
S.Branch.Full.metadataSetFormatReferences_ . someReference_ typeOrTermTraversal_
someReferenceMetadata_ ::
(Ord k, Ord t, Ord h) =>
Traversal' k (SomeReference (UReference.Id' h)) ->
Traversal'
(Map k (S.Branch.Full.MetadataSetFormat' t h))
(SomeReference (UReference.Id' h))
someReferenceMetadata_ keyTraversal_ f m =
Map.toList m
& traversed . beside keyTraversal_ (someMetadataSetFormat_ asTermReference_) %%~ f
<&> Map.fromList
branchSomeRefs_ :: (Ord t, Ord h) => Traversal' (S.Branch' t h p c) (SomeReference (UReference.Id' h))
branchSomeRefs_ f S.Branch.Full.Branch {children, patches, terms, types} = do
let newTypesMap = types & traversed . someReferenceMetadata_ (someReference_ asTypeReference_) %%~ f
let newTermsMap = terms & traversed . someReferenceMetadata_ (someReferent_ asTermReference_) %%~ f
S.Branch.Full.Branch <$> newTermsMap <*> newTypesMap <*> pure patches <*> pure children
patchSomeRefsH_ :: (Ord t, Ord h) => Traversal (S.Patch' t h o) (S.Patch' t h o) (SomeReference (UReference.Id' h)) (SomeReference (UReference.Id' h))
patchSomeRefsH_ f S.Patch {termEdits, typeEdits} = do
newTermEdits <- Map.fromList <$> (Map.toList termEdits & traversed . _1 . (someReferent_ asTermReference_) %%~ f)
newTypeEdits <- Map.fromList <$> (Map.toList typeEdits & traversed . _1 . (someReference_ asTypeReference_) %%~ f)
pure S.Patch {termEdits = newTermEdits, typeEdits = newTypeEdits}
patchSomeRefsO_ :: (Ord t, Ord h, Ord o) => Traversal' (S.Patch' t h o) (SomeReference (UReference.Id' o))
patchSomeRefsO_ f S.Patch {termEdits, typeEdits} = do
newTermEdits <- (termEdits & traversed . Set.traverse . termEditRefs_ %%~ f)
newTypeEdits <- (typeEdits & traversed . Set.traverse . typeEditRefs_ %%~ f)
pure (S.Patch {termEdits = newTermEdits, typeEdits = newTypeEdits})
termEditRefs_ :: Traversal' (TermEdit.TermEdit' t h) (SomeReference (UReference.Id' h))
termEditRefs_ f (TermEdit.Replace ref typing) =
TermEdit.Replace <$> (ref & someReferent_ asTermReference_ %%~ f) <*> pure typing
termEditRefs_ _f (TermEdit.Deprecate) = pure TermEdit.Deprecate
typeEditRefs_ :: Traversal' (TypeEdit.TypeEdit' t h) (SomeReference (UReference.Id' h))
typeEditRefs_ f (TypeEdit.Replace ref) =
TypeEdit.Replace <$> (ref & someReference_ asTypeReference_ %%~ f)
typeEditRefs_ _f (TypeEdit.Deprecate) = pure TypeEdit.Deprecate
migrateTermComponent ::
forall m v a.
(Ord v, Var v, Monad m, MonadIO m) =>
Connection ->
Codebase m v a ->
Unison.Hash ->
StateT MigrationState m (Sync.TrySyncResult Entity)
migrateTermComponent conn Codebase {..} oldHash = fmap (either id id) . runExceptT $ do
whenM (Set.member oldHash <$> use (field @"migratedDefnHashes")) (throwE Sync.PreviouslyDone)
oldComponent <-
(lift . lift $ getTermComponentWithTypes oldHash) >>= \case
Nothing -> error $ "Hash was missing from codebase: " <> show oldHash
Just c -> pure c
let componentIDMap :: Map (Old Reference.Id) (Term.Term v a, Type v a)
componentIDMap = Map.fromList $ Reference.componentFor oldHash oldComponent
let unhashed :: Map (Old Reference.Id) (v, Term.Term v a)
unhashed = Term.unhashComponent (fst <$> componentIDMap)
let vToOldReferenceMapping :: Map v (Old Reference.Id)
vToOldReferenceMapping =
unhashed
& Map.toList
& fmap (\(refId, (v, _trm)) -> (v, refId))
& Map.fromList
referencesMap <- gets referenceMapping
let allMissingReferences :: [Old SomeReferenceId]
allMissingReferences =
let missingTermRefs =
unhashed & foldSetter (traversed . _2 . termReferences_)
missingTypeRefs =
componentIDMap
& foldSetter (traversed . _2 . typeReferences_)
in filter (`Map.notMember` referencesMap) (missingTermRefs <> missingTypeRefs)
when (not . null $ allMissingReferences) $
throwE $ Sync.Missing . nubOrd $ (someReferenceIdToEntity <$> allMissingReferences)
let getMigratedReference :: Old SomeReferenceId -> New SomeReferenceId
getMigratedReference ref =
Map.findWithDefault (error $ "unmigrated reference" <> show ref) ref referencesMap
let remappedReferences :: Map (Old Reference.Id) (v, Term.Term v a, Type v a) =
Zip.zipWith
( \(v, trm) (_, typ) ->
( v,
trm & termReferences_ %~ getMigratedReference,
typ & typeReferences_ %~ getMigratedReference
)
)
unhashed
componentIDMap
let newTermComponents :: Map v (New Reference.Id, Term.Term v a, Type v a)
newTermComponents =
remappedReferences
& Map.elems
& fmap (\(v, trm, typ) -> (v, (trm, typ)))
& Map.fromList
& Convert.hashTermComponents
ifor newTermComponents $ \v (newReferenceId, trm, typ) -> do
let oldReferenceId = vToOldReferenceMapping ^?! ix v
field @"referenceMapping" %= Map.insert (TermReference oldReferenceId) (TermReference newReferenceId)
lift . lift $ putTerm newReferenceId trm typ
-- Need to get one of the new references to grab its hash, doesn't matter which one since
-- all hashes in the component are the same.
case newTermComponents ^? traversed . _1 . to Reference.idToHash of
Nothing -> pure ()
Just newHash -> insertObjectMappingForHash conn oldHash newHash
field @"migratedDefnHashes" %= Set.insert oldHash
pure Sync.Done
migrateDeclComponent ::
forall m v a.
(Ord v, Var v, Monad m, MonadIO m) =>
Connection ->
Codebase m v a ->
Unison.Hash ->
StateT MigrationState m (Sync.TrySyncResult Entity)
migrateDeclComponent conn Codebase {..} oldHash = fmap (either id id) . runExceptT $ do
whenM (Set.member oldHash <$> use (field @"migratedDefnHashes")) (throwE Sync.PreviouslyDone)
declComponent :: [DD.Decl v a] <-
(lift . lift $ getDeclComponent oldHash) >>= \case
Nothing -> error $ "Expected decl component for hash:" <> show oldHash
Just dc -> pure dc
let componentIDMap :: Map (Old Reference.Id) (DD.Decl v a)
componentIDMap = Map.fromList $ Reference.componentFor oldHash declComponent
let unhashed :: Map (Old Reference.Id) (DeclName v, DD.Decl v a)
unhashed = DD.unhashComponent componentIDMap
let allTypes :: [Type v a]
allTypes =
unhashed
^.. traversed
. _2
. beside DD.asDataDecl_ id
. to DD.constructors'
. traversed
. _3
migratedReferences <- gets referenceMapping
let unmigratedRefIds :: [SomeReferenceId]
unmigratedRefIds =
allTypes
& foldSetter
( traversed -- Every type in the list
. typeReferences_
. filtered (`Map.notMember` migratedReferences)
)
when (not . null $ unmigratedRefIds) do
throwE (Sync.Missing (nubOrd . fmap someReferenceIdToEntity $ unmigratedRefIds))
-- At this point we know we have all the required mappings from old references to new ones.
let remapTerm :: Type v a -> Type v a
remapTerm = typeReferences_ %~ \ref -> Map.findWithDefault (error "unmigrated reference") ref migratedReferences
let remappedReferences :: Map (Old Reference.Id) (DeclName v, DD.Decl v a)
remappedReferences =
unhashed
& traversed -- Traverse map of reference IDs
. _2 -- Select the DataDeclaration
. beside DD.asDataDecl_ id -- Unpack effect decls
. DD.constructors_ -- Get the data constructors
. traversed -- traverse the list of them
. _3 -- Select the Type term.
%~ remapTerm
let declNameToOldReference :: Map (DeclName v) (Old Reference.Id)
declNameToOldReference = Map.fromList . fmap swap . Map.toList . fmap fst $ remappedReferences
let newComponent :: [(DeclName v, Reference.Id, DD.Decl v a)]
newComponent =
remappedReferences
& Map.elems
& Map.fromList
& Convert.hashDecls
& fromRight (error "unexpected resolution error")
for_ newComponent $ \(declName, newReferenceId, dd) -> do
let oldReferenceId = declNameToOldReference ^?! ix declName
field @"referenceMapping" %= Map.insert (TypeReference oldReferenceId) (TypeReference newReferenceId)
let oldConstructorIds :: Map (ConstructorName v) (Old ConstructorId)
oldConstructorIds =
(componentIDMap ^?! ix oldReferenceId)
& DD.asDataDecl
& DD.constructors'
& imap (\constructorId (_ann, constructorName, _type) -> (constructorName, fromIntegral constructorId))
& Map.fromList
ifor_ (DD.constructors' (DD.asDataDecl dd)) \(fromIntegral -> newConstructorId) (_ann, constructorName, _type) -> do
field @"referenceMapping"
%= Map.insert
(ConstructorReference oldReferenceId (oldConstructorIds ^?! ix constructorName))
(ConstructorReference newReferenceId newConstructorId)
lift . lift $ putTypeDeclaration newReferenceId dd
-- Need to get one of the new references to grab its hash, doesn't matter which one since
-- all hashes in the component are the same.
case newComponent ^? traversed . _2 . to Reference.idToHash of
Nothing -> pure ()
Just newHash -> insertObjectMappingForHash conn oldHash newHash
field @"migratedDefnHashes" %= Set.insert oldHash
pure Sync.Done
insertObjectMappingForHash ::
(MonadIO m, MonadState MigrationState m) =>
Connection ->
Old Hash ->
New Hash ->
m ()
insertObjectMappingForHash conn oldHash newHash = do
(oldObjectId, newHashId, newObjectId) <- runDB conn . liftQ $ do
oldHashId <- Q.expectHashIdByHash . Cv.hash1to2 $ oldHash
oldObjectId <- Q.expectObjectIdForPrimaryHashId $ oldHashId
newHashId <- Q.expectHashIdByHash . Cv.hash1to2 $ newHash
newObjectId <- Q.expectObjectIdForPrimaryHashId $ newHashId
pure (oldObjectId, newHashId, newObjectId)
field @"objLookup" %= Map.insert oldObjectId (newObjectId, newHashId, newHash, oldHash)
typeReferences_ :: (Monad m, Ord v) => LensLike' m (Type v a) SomeReferenceId
typeReferences_ =
ABT.rewriteDown_ -- Focus all terms
. ABT.baseFunctor_ -- Focus Type.F
. Type._Ref -- Only the Ref constructor has references
. Reference._DerivedId
. asTypeReference_
termReferences_ :: (Monad m, Ord v) => LensLike' m (Term.Term v a) SomeReferenceId
termReferences_ =
ABT.rewriteDown_ -- Focus all terms
. ABT.baseFunctor_ -- Focus Term.F
. termFReferences_
termFReferences_ :: (Ord tv, Monad m) => LensLike' m (Term.F tv ta pa a) SomeReferenceId
termFReferences_ f t =
(t & Term._Ref . Reference._DerivedId . asTermReference_ %%~ f)
>>= Term._Constructor . someRefCon_ %%~ f
>>= Term._Request . someRefCon_ %%~ f
>>= Term._Ann . _2 . typeReferences_ %%~ f
>>= Term._Match . _2 . traversed . Term.matchPattern_ . patternReferences_ %%~ f
>>= Term._TermLink . referentAsSomeTermReference_ %%~ f
>>= Term._TypeLink . Reference._DerivedId . asTypeReference_ %%~ f
-- | Build a SomeConstructorReference
someRefCon_ :: Traversal' ConstructorReference.ConstructorReference SomeReferenceId
someRefCon_ = refConPair_ . asConstructorReference_
where
refConPair_ :: Traversal' ConstructorReference.ConstructorReference ConstructorReference.ConstructorReferenceId
refConPair_ f s =
case s of
ConstructorReference.ConstructorReference (Reference.Builtin _) _ -> pure s
ConstructorReference.ConstructorReference (Reference.DerivedId n) c ->
( \(ConstructorReference.ConstructorReference n' c') ->
ConstructorReference.ConstructorReference (Reference.DerivedId n') c'
)
<$> f (ConstructorReference.ConstructorReference n c)
patternReferences_ :: Traversal' (Pattern loc) SomeReferenceId
patternReferences_ f = \case
p@(Pattern.Unbound {}) -> pure p
p@(Pattern.Var {}) -> pure p
p@(Pattern.Boolean {}) -> pure p
p@(Pattern.Int {}) -> pure p
p@(Pattern.Nat {}) -> pure p
p@(Pattern.Float {}) -> pure p
p@(Pattern.Text {}) -> pure p
p@(Pattern.Char {}) -> pure p
(Pattern.Constructor loc ref patterns) ->
(\newRef newPatterns -> Pattern.Constructor loc newRef newPatterns)
<$> (ref & someRefCon_ %%~ f)
<*> (patterns & traversed . patternReferences_ %%~ f)
(Pattern.As loc pat) -> Pattern.As loc <$> patternReferences_ f pat
(Pattern.EffectPure loc pat) -> Pattern.EffectPure loc <$> patternReferences_ f pat
(Pattern.EffectBind loc ref patterns pat) ->
do
(\newRef newPatterns newPat -> Pattern.EffectBind loc newRef newPatterns newPat)
<$> (ref & someRefCon_ %%~ f)
<*> (patterns & traversed . patternReferences_ %%~ f)
<*> (patternReferences_ f pat)
(Pattern.SequenceLiteral loc patterns) ->
Pattern.SequenceLiteral loc <$> (patterns & traversed . patternReferences_ %%~ f)
Pattern.SequenceOp loc pat seqOp pat2 -> do
Pattern.SequenceOp loc <$> patternReferences_ f pat <*> pure seqOp <*> patternReferences_ f pat2
referentAsSomeTermReference_ :: Traversal' Referent.Referent SomeReferenceId
referentAsSomeTermReference_ f = \case
(Referent'.Ref' (Reference.DerivedId refId)) -> do
newRefId <- refId & asTermReference_ %%~ f
pure (Referent'.Ref' (Reference.DerivedId newRefId))
(Referent'.Con' (ConstructorReference.ConstructorReference (Reference.DerivedId refId) conId) conType) ->
(ConstructorReference.ConstructorReference refId conId & asConstructorReference_ %%~ f)
<&> \(ConstructorReference.ConstructorReference newRefId newConId) ->
Referent'.Con'
(ConstructorReference.ConstructorReference (Reference.DerivedId newRefId) newConId)
conType
r -> pure r
type SomeReferenceId = SomeReference Reference.Id
type SomeReferenceObjId = SomeReference (UReference.Id' ObjectId)
remapObjIdRefs ::
(Map (Old ObjectId) (New ObjectId, New HashId, New Hash, Old Hash)) ->
(Map SomeReferenceId SomeReferenceId) ->
SomeReferenceObjId ->
SomeReferenceObjId
remapObjIdRefs objMapping refMapping someObjIdRef = newSomeObjId
where
oldObjId :: ObjectId
oldObjId = someObjIdRef ^. someRef_ . UReference.idH
(newObjId, _, _, oldHash) =
case Map.lookup oldObjId objMapping of
Nothing -> error $ "Expected object mapping for ID: " <> show oldObjId
Just found -> found
oldSomeRefId :: SomeReferenceId
oldSomeRefId = (someObjIdRef & someRef_ . UReference.idH .~ oldHash) ^. uRefIdAsRefId_
newSomeRefId :: SomeReferenceId
newSomeRefId = case Map.lookup oldSomeRefId refMapping of
Nothing -> error $ "Expected reference mapping for ID: " <> show oldSomeRefId
Just r -> r
newSomeObjId :: SomeReference (UReference.Id' (New ObjectId))
newSomeObjId = (newSomeRefId ^. from uRefIdAsRefId_) & someRef_ . UReference.idH .~ newObjId
data SomeReference ref
= TermReference ref
| TypeReference ref
| ConstructorReference ref ConstructorId
deriving (Eq, Functor, Generic, Ord, Show, Foldable, Traversable)
someRef_ :: Lens (SomeReference ref) (SomeReference ref') ref ref'
someRef_ = lens getter setter
where
setter (TermReference _) r = TermReference r
setter (TypeReference _) r = TypeReference r
setter (ConstructorReference _ conId) r = (ConstructorReference r conId)
getter = \case
TermReference r -> r
TypeReference r -> r
ConstructorReference r _ -> r
_TermReference :: Prism' (SomeReference ref) ref
_TermReference = _Ctor @"TermReference"
-- | This is only safe as long as you don't change the constructor of your SomeReference
asTermReference_ :: Traversal' ref (SomeReference ref)
asTermReference_ f ref =
f (TermReference ref) <&> \case
TermReference ref' -> ref'
_ -> error "asTermReference_: SomeReferenceId constructor was changed."
-- | This is only safe as long as you don't change the constructor of your SomeReference
asTypeReference_ :: Traversal' ref (SomeReference ref)
asTypeReference_ f ref =
f (TypeReference ref) <&> \case
TypeReference ref' -> ref'
_ -> error "asTypeReference_: SomeReferenceId constructor was changed."
-- | This is only safe as long as you don't change the constructor of your SomeReference
asConstructorReference_ :: Traversal' (ConstructorReference.GConstructorReference ref) (SomeReference ref)
asConstructorReference_ f (ConstructorReference.ConstructorReference ref cId) =
f (ConstructorReference ref cId) <&> \case
ConstructorReference ref' cId -> ConstructorReference.ConstructorReference ref' cId
_ -> error "asConstructorReference_: SomeReferenceId constructor was changed."
someReferenceIdToEntity :: SomeReferenceId -> Entity
someReferenceIdToEntity = \case
(TermReference ref) -> TermComponent (Reference.idToHash ref)
(TypeReference ref) -> DeclComponent (Reference.idToHash ref)
-- Constructors are migrated by their decl component.
(ConstructorReference ref _conId) -> DeclComponent (Reference.idToHash ref)
foldSetter :: LensLike (Writer [a]) s t a a -> s -> [a]
foldSetter t s = execWriter (s & t %%~ \a -> tell [a] *> pure a)
-- | Save an empty branch and get its new hash to use when replacing
-- branches which are missing due to database corruption.
saveV2EmptyBranch :: MonadIO m => Connection -> m (BranchHashId, Hash)
saveV2EmptyBranch conn = do
let branch = S.emptyBranch
let (localBranchIds, localBranch) = S.LocalizeObject.localizeBranch branch
newHash <- runDB conn (Ops.liftQ (Hashing.dbBranchHash branch))
newHashId <- runDB conn (Ops.liftQ (Q.saveBranchHash (BranchHash (Cv.hash1to2 newHash))))
_ <- runDB conn (Ops.saveBranchObject newHashId localBranchIds localBranch)
pure (newHashId, newHash)

140
parser-typechecker/src/Unison/Codebase/SqliteCodebase/MigrateSchema12/DbHelpers.hs Normal file
View File

@ -0,0 +1,140 @@
module Unison.Codebase.SqliteCodebase.MigrateSchema12.DbHelpers
( dbBranchHash,
dbPatchHash,
)
where
import qualified U.Codebase.Reference as S hiding (Reference)
import qualified U.Codebase.Reference as S.Reference
import qualified U.Codebase.Referent as S.Referent
import U.Codebase.Sqlite.Branch.Full (DbMetadataSet)
import qualified U.Codebase.Sqlite.Branch.Full as S
import qualified U.Codebase.Sqlite.Branch.Full as S.Branch.Full
import qualified U.Codebase.Sqlite.Branch.Full as S.MetadataSet
import qualified U.Codebase.Sqlite.DbId as Db
import qualified U.Codebase.Sqlite.Patch.Full as S
import qualified U.Codebase.Sqlite.Patch.TermEdit as S (TermEdit)
import qualified U.Codebase.Sqlite.Patch.TermEdit as S.TermEdit
import qualified U.Codebase.Sqlite.Patch.TypeEdit as S (TypeEdit)
import qualified U.Codebase.Sqlite.Patch.TypeEdit as S.TypeEdit
import U.Codebase.Sqlite.Queries (EDB)
import qualified U.Codebase.Sqlite.Queries as Q
import qualified U.Codebase.Sqlite.Reference as S
import qualified U.Codebase.Sqlite.Referent as S
import qualified U.Util.Hash
import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv
import Unison.Hash (Hash)
import Unison.Hashing.V2.Branch (NameSegment (..))
import qualified Unison.Hashing.V2.Branch as Hashing.Branch
import qualified Unison.Hashing.V2.Patch as Hashing (Patch (..))
import qualified Unison.Hashing.V2.Patch as Hashing.Patch
import qualified Unison.Hashing.V2.Reference as Hashing (Reference)
import qualified Unison.Hashing.V2.Reference as Hashing.Reference
import qualified Unison.Hashing.V2.Referent as Hashing (Referent)
import qualified Unison.Hashing.V2.Referent as Hashing.Referent
import qualified Unison.Hashing.V2.TermEdit as Hashing (TermEdit)
import qualified Unison.Hashing.V2.TermEdit as Hashing.TermEdit
import qualified Unison.Hashing.V2.TypeEdit as Hashing (TypeEdit)
import qualified Unison.Hashing.V2.TypeEdit as Hashing.TypeEdit
import Unison.Prelude
import qualified Unison.Util.Map as Map
import qualified Unison.Util.Set as Set
dbBranchHash :: EDB m => S.DbBranch -> m Hash
dbBranchHash (S.Branch.Full.Branch tms tps patches children) =
fmap Hashing.Branch.hashBranch $
Hashing.Branch.Raw
<$> doTerms tms
<*> doTypes tps
<*> doPatches patches
<*> doChildren children
where
doTerms :: EDB m => Map Db.TextId (Map S.Referent S.DbMetadataSet) -> m (Map NameSegment (Map Hashing.Referent Hashing.Branch.MdValues))
doTerms =
Map.bitraverse
s2hNameSegment
(Map.bitraverse s2hReferent s2hMetadataSet)
doTypes ::
EDB m =>
Map Db.TextId (Map S.Reference S.DbMetadataSet) ->
m (Map NameSegment (Map Hashing.Reference Hashing.Branch.MdValues))
doTypes =
Map.bitraverse
s2hNameSegment
(Map.bitraverse s2hReference s2hMetadataSet)
doPatches :: EDB m => Map Db.TextId Db.PatchObjectId -> m (Map NameSegment Hash)
doPatches =
Map.bitraverse s2hNameSegment (objectIdToPrimaryHash . Db.unPatchObjectId)
doChildren :: EDB m => Map Db.TextId (Db.BranchObjectId, Db.CausalHashId) -> m (Map NameSegment Hash)
doChildren =
Map.bitraverse s2hNameSegment \(_boId, chId) -> causalHashIdToHash chId
dbPatchHash :: forall m. EDB m => S.Patch -> m Hash
dbPatchHash S.Patch {S.termEdits, S.typeEdits} =
fmap Hashing.Patch.hashPatch $
Hashing.Patch
<$> doTermEdits termEdits
<*> doTypeEdits typeEdits
where
doTermEdits :: Map S.ReferentH (Set S.TermEdit) -> m (Map Hashing.Referent (Set Hashing.TermEdit))
doTermEdits =
Map.bitraverse s2hReferentH (Set.traverse s2hTermEdit)
doTypeEdits :: Map S.ReferenceH (Set S.TypeEdit) -> m (Map Hashing.Reference (Set Hashing.TypeEdit))
doTypeEdits =
Map.bitraverse s2hReferenceH (Set.traverse s2hTypeEdit)
s2hMetadataSet :: EDB m => DbMetadataSet -> m Hashing.Branch.MdValues
s2hMetadataSet = \case
S.MetadataSet.Inline rs -> Hashing.Branch.MdValues <$> Set.traverse s2hReference rs
s2hNameSegment :: EDB m => Db.TextId -> m NameSegment
s2hNameSegment =
fmap NameSegment . Q.loadTextById
s2hReferent :: EDB m => S.Referent -> m Hashing.Referent
s2hReferent = \case
S.Referent.Ref r -> Hashing.Referent.Ref <$> s2hReference r
S.Referent.Con r cid -> Hashing.Referent.Con <$> s2hReference r <*> pure (fromIntegral cid)
s2hReferentH :: EDB m => S.ReferentH -> m Hashing.Referent
s2hReferentH = \case
S.Referent.Ref r -> Hashing.Referent.Ref <$> s2hReferenceH r
S.Referent.Con r cid -> Hashing.Referent.Con <$> s2hReferenceH r <*> pure (fromIntegral cid)
s2hReference :: EDB m => S.Reference -> m Hashing.Reference
s2hReference = \case
S.ReferenceBuiltin t -> Hashing.Reference.Builtin <$> Q.loadTextById t
S.Reference.Derived h i -> Hashing.Reference.Derived <$> objectIdToPrimaryHash h <*> pure i
s2hReferenceH :: EDB m => S.ReferenceH -> m Hashing.Reference
s2hReferenceH = \case
S.ReferenceBuiltin t -> Hashing.Reference.Builtin <$> Q.loadTextById t
S.Reference.Derived h i -> Hashing.Reference.Derived <$> loadHashHashById h <*> pure i
s2hTermEdit :: EDB m => S.TermEdit -> m Hashing.TermEdit
s2hTermEdit = \case
S.TermEdit.Replace r _typing -> Hashing.TermEdit.Replace <$> s2hReferent r
S.TermEdit.Deprecate -> pure Hashing.TermEdit.Deprecate
s2hTypeEdit :: EDB m => S.TypeEdit -> m Hashing.TypeEdit
s2hTypeEdit = \case
S.TypeEdit.Replace r -> Hashing.TypeEdit.Replace <$> s2hReference r
S.TypeEdit.Deprecate -> pure Hashing.TypeEdit.Deprecate
-- Mitchell: Do these variants of Q.* queries belong somewhere else? Or in Q perhaps?
causalHashIdToHash :: EDB m => Db.CausalHashId -> m Hash
causalHashIdToHash =
fmap Cv.hash2to1 . Q.loadHashHashById . Db.unCausalHashId
objectIdToPrimaryHash :: EDB m => Db.ObjectId -> m Hash
objectIdToPrimaryHash =
fmap (Cv.hash2to1 . U.Util.Hash.fromBase32Hex) . Q.loadPrimaryHashByObjectId
loadHashHashById :: EDB m => Db.HashId -> m Hash
loadHashHashById =
fmap Cv.hash2to1 . Q.loadHashHashById

11
parser-typechecker/src/Unison/Codebase/TermEdit.hs
View File

@ -1,8 +1,6 @@
{- ORMOLU_DISABLE -} -- Remove this when the file is ready to be auto-formatted
module Unison.Codebase.TermEdit where
import Unison.Hashable (Hashable)
import qualified Unison.Hashable as H
import Unison.Reference (Reference)
data TermEdit = Replace Reference Typing | Deprecate
@ -18,15 +16,6 @@ references Deprecate = []
data Typing = Same | Subtype | Different
deriving (Eq, Ord, Show)
instance Hashable Typing where
tokens Same = [H.Tag 0]
tokens Subtype = [H.Tag 1]
tokens Different = [H.Tag 2]
instance Hashable TermEdit where
tokens (Replace r t) = [H.Tag 0] ++ H.tokens r ++ H.tokens t
tokens Deprecate = [H.Tag 1]
toReference :: TermEdit -> Maybe Reference
toReference (Replace r _) = Just r
toReference Deprecate = Nothing

6
parser-typechecker/src/Unison/Codebase/Type.hs
View File

@ -23,6 +23,7 @@ import Unison.Codebase.SqliteCodebase.GitError (GitSqliteCodebaseError)
import Unison.Codebase.SyncMode (SyncMode)
import Unison.CodebasePath (CodebasePath)
import Unison.DataDeclaration (Decl)
import Unison.Hash (Hash)
import Unison.Prelude
import Unison.Reference (Reference)
import qualified Unison.Reference as Reference
@ -63,6 +64,10 @@ data Codebase m v a = Codebase
-- | Enqueue the put of a type declaration into the codebase, if it doesn't already exist. The implementation may
-- choose to delay the put until all of the type declaration's references are stored as well.
putTypeDeclaration :: Reference.Id -> Decl v a -> m (),
-- getTermComponent :: Hash -> m (Maybe [Term v a]),
getTermComponentWithTypes :: Hash -> m (Maybe [(Term v a, Type v a)]),
getDeclComponent :: Hash -> m (Maybe [Decl v a]),
getComponentLength :: Hash -> m (Maybe Reference.CycleSize),
-- | Get the root branch.
getRootBranch :: m (Either GetRootBranchError (Branch m)),
-- | Get whether the root branch exists.
@ -89,6 +94,7 @@ data Codebase m v a = Codebase
-- | Get the set of user-defined terms and type declarations that depend on the given term, type declaration, or
-- builtin type.
dependentsImpl :: Reference -> m (Set Reference.Id),
dependentsOfComponentImpl :: Hash -> m (Set Reference.Id),
-- | Copy a branch and all of its dependencies from the given codebase into this one.
syncFromDirectory :: CodebasePath -> SyncMode -> Branch m -> m (),
-- | Copy a branch and all of its dependencies from this codebase into the given codebase.

6
parser-typechecker/src/Unison/Codebase/TypeEdit.hs
View File

@ -2,8 +2,6 @@
module Unison.Codebase.TypeEdit where
import Unison.Reference (Reference)
import Unison.Hashable (Hashable)
import qualified Unison.Hashable as H
data TypeEdit = Replace Reference | Deprecate
deriving (Eq, Ord, Show)
@ -12,10 +10,6 @@ references :: TypeEdit -> [Reference]
references (Replace r) = [r]
references Deprecate = []
instance Hashable TypeEdit where
tokens (Replace r) = H.Tag 0 : H.tokens r
tokens Deprecate = [H.Tag 1]
toReference :: TypeEdit -> Maybe Reference
toReference (Replace r) = Just r
toReference Deprecate = Nothing

88
parser-typechecker/src/Unison/DeclPrinter.hs
View File

@ -26,13 +26,18 @@ import Unison.PrettyPrintEnvDecl ( PrettyPrintEnvDecl(..) )
import qualified Unison.PrettyPrintEnv as PPE
import qualified Unison.Referent as Referent
import Unison.Reference ( Reference(DerivedId) )
import qualified Unison.Result as Result
import qualified Unison.Util.SyntaxText as S
import qualified Unison.Type as Type
import qualified Unison.Typechecker as Typechecker
import Unison.Typechecker.TypeLookup (TypeLookup(TypeLookup))
import qualified Unison.Typechecker.TypeLookup as TypeLookup
import qualified Unison.TypePrinter as TypePrinter
import Unison.Util.Pretty ( Pretty )
import qualified Unison.Util.Pretty as P
import Unison.Var ( Var )
import qualified Unison.Var as Var
import qualified Unison.Term as Term
type SyntaxText = S.SyntaxText' Reference
@ -128,35 +133,60 @@ prettyDataDecl (PrettyPrintEnvDecl unsuffixifiedPPE suffixifiedPPE) r name dd =
--
-- This function bails with `Nothing` if the names aren't an exact match for
-- the expected record naming convention.
fieldNames
:: forall v a . Var v
=> PrettyPrintEnv
-> Reference
-> HashQualified Name
-> DataDeclaration v a
-> Maybe [HashQualified Name]
fieldNames env r name dd = case DD.constructors dd of
[(_, typ)] -> let
vars :: [v]
vars = [ Var.freshenId (fromIntegral n) (Var.named "_") | n <- [0..Type.arity typ - 1]]
accessors = DD.generateRecordAccessors (map (,()) vars) (HQ.toVar name) r
hashes = Hashing.hashTermComponents (Map.fromList accessors)
names = [ (r, HQ.toString . PPE.termName env . Referent.Ref $ DerivedId r)
| r <- fst <$> Map.elems hashes ]
fieldNames = Map.fromList
[ (r, f) | (r, n) <- names
, typename <- pure (HQ.toString name)
, typename `isPrefixOf` n
, rest <- pure $ drop (length typename + 1) n
, (f, rest) <- pure $ span (/= '.') rest
, rest `elem` ["",".set",".modify"] ]
in if Map.size fieldNames == length names then
Just [ HQ.unsafeFromString name
| v <- vars
, Just (ref, _) <- [Map.lookup (Var.namespaced [HQ.toVar name, v]) hashes]
, Just name <- [Map.lookup ref fieldNames] ]
else Nothing
_ -> Nothing
fieldNames ::
forall v a.
Var v =>
PrettyPrintEnv ->
Reference ->
HashQualified Name ->
DataDeclaration v a ->
Maybe [HashQualified Name]
fieldNames env r name dd = do
typ <- case DD.constructors dd of
[(_, typ)] -> Just typ
_ -> Nothing
let vars :: [v]
vars = [Var.freshenId (fromIntegral n) (Var.named "_") | n <- [0 .. Type.arity typ - 1]]
let accessors :: [(v, Term.Term v ())]
accessors = DD.generateRecordAccessors (map (,()) vars) (HQ.toVar name) r
let typeLookup :: TypeLookup v ()
typeLookup =
TypeLookup
{ TypeLookup.typeOfTerms = mempty,
TypeLookup.dataDecls = Map.singleton r (void dd),
TypeLookup.effectDecls = mempty
}
let typecheckingEnv :: Typechecker.Env v ()
typecheckingEnv =
Typechecker.Env
{ Typechecker._ambientAbilities = mempty,
Typechecker._typeLookup = typeLookup,
Typechecker._termsByShortname = mempty
}
accessorsWithTypes :: [(v, Term.Term v (), Type.Type v ())]
<- for accessors \(v, trm) ->
case Result.result (Typechecker.synthesize typecheckingEnv trm) of
Nothing -> Nothing
Just typ -> Just (v, trm, typ)
let hashes = Hashing.hashTermComponents (Map.fromList . fmap (\(v, trm, typ) -> (v, (trm, typ))) $ accessorsWithTypes)
let names =
[ (r, HQ.toString . PPE.termName env . Referent.Ref $ DerivedId r)
| r <- (\(refId, _trm, _typ) -> refId) <$> Map.elems hashes
]
let fieldNames =
Map.fromList
[ (r, f) | (r, n) <- names, typename <- pure (HQ.toString name), typename `isPrefixOf` n, rest <- pure $ drop (length typename + 1) n, (f, rest) <- pure $ span (/= '.') rest, rest `elem` ["", ".set", ".modify"]
]
if Map.size fieldNames == length names
then
Just
[ HQ.unsafeFromString name
| v <- vars,
Just (ref, _, _) <- [Map.lookup (Var.namespaced [HQ.toVar name, v]) hashes],
Just name <- [Map.lookup ref fieldNames]
]
else Nothing
prettyModifier :: DD.Modifier -> Pretty SyntaxText
prettyModifier DD.Structural = fmt S.DataTypeModifier "structural"

124
parser-typechecker/src/Unison/Hashing/V2/ABT.hs Normal file
View File

@ -0,0 +1,124 @@
{- ORMOLU_DISABLE -}
-- Based on: http://semantic-domain.blogspot.com/2015/03/abstract-binding-trees.html
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE UndecidableInstances #-}
module Unison.Hashing.V2.ABT (Unison.ABT.Term, hash, hashComponents) where
import Unison.Prelude
import Unison.ABT
import Data.List hiding (cycle, find)
import qualified Data.List as List (sort)
import Prelude hiding (abs, cycle)
import Unison.Hashing.V2.Tokenizable (Accumulate, Hashable1, hash1)
import qualified Unison.Hashing.V2.Tokenizable as Hashable
import qualified Data.Map as Map
import qualified Data.Set as Set
-- Hash a strongly connected component and sort its definitions into a canonical order.
hashComponent ::
forall a f h v.
(Functor f, Hashable1 f, Foldable f, Eq v, Show v, Ord v, Ord h, Accumulate h)
=> Map.Map v (Term f v a) -> (h, [(v, Term f v a)])
hashComponent byName = let
ts = Map.toList byName
-- First, compute a canonical hash ordering of the component, as well as an environment in which we can hash
-- individual names.
(hashes, env) = doHashCycle [] ts
-- Construct a list of tokens that is shared by all members of the component. They are disambiguated only by their
-- name that gets tumbled into the hash.
commonTokens :: [Hashable.Token h]
commonTokens = Hashable.Tag 1 : map Hashable.Hashed hashes
-- Use a helper function that hashes a single term given its name, now that we have an environment in which we can
-- look the name up, as well as the common tokens.
hashName :: v -> h
hashName v = Hashable.accumulate (commonTokens ++ [Hashable.Hashed (hash' env (var v :: Term f v ()))])
(hashes', permutedTerms) =
ts
-- Pair each term with its hash
& map (\t -> (hashName (fst t), t))
-- Sort again to get the final canonical ordering
& sortOn fst
& unzip
overallHash = Hashable.accumulate (map Hashable.Hashed hashes')
in (overallHash, permutedTerms)
-- Group the definitions into strongly connected components and hash
-- each component. Substitute the hash of each component into subsequent
-- components (using the `termFromHash` function). Requires that the
-- overall component has no free variables.
hashComponents
:: (Functor f, Hashable1 f, Foldable f, Eq v, Show v, Var v, Ord h, Accumulate h)
=> (h -> Word64 -> Term f v ())
-> Map.Map v (Term f v a)
-> [(h, [(v, Term f v a)])]
hashComponents termFromHash termsByName = let
bound = Set.fromList (Map.keys termsByName)
escapedVars = Set.unions (freeVars <$> Map.elems termsByName) `Set.difference` bound
sccs = components (Map.toList termsByName)
go _ [] = []
go prevHashes (component : rest) = let
sub = substsInheritAnnotation (Map.toList prevHashes)
(h, sortedComponent) = hashComponent $ Map.fromList [ (v, sub t) | (v, t) <- component ]
curHashes = Map.fromList [ (v, termFromHash h i) | ((v, _),i) <- sortedComponent `zip` [0..]]
newHashes = prevHashes `Map.union` curHashes
newHashesL = Map.toList newHashes
sortedComponent' = [ (v, substsInheritAnnotation newHashesL t) | (v, t) <- sortedComponent ]
in (h, sortedComponent') : go newHashes rest
in if Set.null escapedVars then go Map.empty sccs
else error $ "can't hashComponents if bindings have free variables:\n "
++ show (map show (Set.toList escapedVars))
++ "\n " ++ show (map show (Map.keys termsByName))
-- | We ignore annotations in the `Term`, as these should never affect the
-- meaning of the term.
hash :: forall f v a h . (Functor f, Hashable1 f, Eq v, Show v, Ord h, Accumulate h)
=> Term f v a -> h
hash = hash' [] where
hash' :: forall f v a h . (Functor f, Hashable1 f, Eq v, Show v, Ord h, Accumulate h)
=> [Either [v] v] -> Term f v a -> h
hash' env = \case
Var' v -> maybe die hashInt ind
where lookup (Left cycle) = v `elem` cycle
lookup (Right v') = v == v'
ind = findIndex lookup env
hashInt :: Int -> h
hashInt i = Hashable.accumulate [Hashable.Nat $ fromIntegral i]
die = error $ "unknown var in environment: " ++ show v
++ " environment = " ++ show env
Cycle' vs t -> hash1 (hashCycle vs env) undefined t
Abs'' v t -> hash' (Right v : env) t
Tm' t -> hash1 (\ts -> (List.sort (map (hash' env) ts), hash' env)) (hash' env) t
where
hashCycle :: [v] -> [Either [v] v] -> [Term f v a] -> ([h], Term f v a -> h)
hashCycle cycle env ts =
let (ts', env') = doHashCycle env (zip cycle ts)
in (ts', hash' env')
-- | @doHashCycle env terms@ hashes cycle @terms@ in environment @env@, and returns the canonical ordering of the hashes
-- of those terms, as well as an updated environment with each of the terms' bindings in the canonical ordering.
doHashCycle ::
forall a f h v.
(Accumulate h, Eq v, Functor f, Hashable1 f, Ord h, Show v) =>
[Either [v] v] ->
[(v, Term f v a)] ->
([h], [Either [v] v])
doHashCycle env namedTerms =
(map (hash' newEnv) permutedTerms, newEnv)
where
names = map fst namedTerms
-- The environment in which we compute the canonical permutation of terms
permutationEnv = Left names : env
(permutedNames, permutedTerms) =
namedTerms
& sortOn @h (hash' permutationEnv . snd)
& unzip
-- The new environment, which includes the names of all of the terms in the cycle, now that we have computed their
-- canonical ordering
newEnv = map Right permutedNames ++ env

44
parser-typechecker/src/Unison/Hashing/V2/Branch.hs Normal file
View File

@ -0,0 +1,44 @@
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
module Unison.Hashing.V2.Branch (NameSegment (..), Raw (..), MdValues (..), hashBranch) where
import Unison.Hash (Hash)
import Unison.Hashing.V2.Tokenizable (Tokenizable)
import qualified Unison.Hashing.V2.Tokenizable as H
import Unison.Hashing.V2.Reference (Reference)
import Unison.Hashing.V2.Referent (Referent)
import Unison.Prelude
type MetadataValue = Reference
newtype MdValues = MdValues (Set MetadataValue)
deriving (Eq, Ord, Show)
deriving (Tokenizable) via Set MetadataValue
newtype NameSegment = NameSegment Text deriving (Eq, Ord, Show)
hashBranch :: Raw -> Hash
hashBranch = H.hashTokenizable
data Raw = Raw
{ terms :: Map NameSegment (Map Referent MdValues),
types :: Map NameSegment (Map Reference MdValues),
patches :: Map NameSegment Hash,
children :: Map NameSegment Hash -- the Causal Hash
}
instance Tokenizable Raw where
tokens b =
[ H.accumulateToken (terms b),
H.accumulateToken (types b),
H.accumulateToken (children b),
H.accumulateToken (patches b)
]
instance H.Tokenizable NameSegment where
tokens (NameSegment t) = [H.Text t]

23
parser-typechecker/src/Unison/Hashing/V2/Causal.hs Normal file
View File

@ -0,0 +1,23 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
module Unison.Hashing.V2.Causal
( Causal (..),
hashCausal,
)
where
import Data.Set (Set)
import qualified Data.Set as Set
import Unison.Hash (Hash)
import qualified Unison.Hashing.V2.Tokenizable as Tokenizable
import qualified Unison.Hashing.V2.Tokenizable as H
hashCausal :: Causal -> Hash
hashCausal = Tokenizable.hashTokenizable
data Causal = Causal {branchHash :: Hash, parents :: Set Hash}
instance H.Tokenizable Causal where
tokens c = H.tokens $ branchHash c : Set.toList (parents c)

284
parser-typechecker/src/Unison/Hashing/V2/Convert.hs
View File

@ -1,11 +1,17 @@
{- ORMOLU_DISABLE -} -- Remove this when the file is ready to be auto-formatted
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ViewPatterns #-}
module Unison.Hashing.V2.Convert
( ResolutionResult,
hashBranch0,
hashCausal,
hashDataDecls,
hashDecls,
hashPatch,
hashClosedTerm,
hashTermComponents,
hashTermComponentsWithoutTypes,
typeToReference,
typeToReferenceMentions,
)
@ -13,24 +19,52 @@ where
import Control.Lens (over, _3)
import qualified Control.Lens as Lens
import Control.Monad.Trans.Writer.CPS (Writer)
import qualified Control.Monad.Trans.Writer.CPS as Writer
import Data.Bifunctor (bimap)
import Data.Bitraversable (bitraverse)
import Data.Foldable (toList)
import Data.Functor ((<&>))
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Unison.ABT as ABT
import qualified Unison.Codebase.Branch.Type as Memory.Branch
import qualified Unison.Codebase.Causal.Type as Memory.Causal
import qualified Unison.Codebase.Patch as Memory.Patch
import qualified Unison.Codebase.TermEdit as Memory.TermEdit
import qualified Unison.Codebase.TypeEdit as Memory.TypeEdit
import qualified Unison.ConstructorReference as Memory.ConstructorReference
import qualified Unison.ConstructorType as CT
import qualified Unison.ConstructorType as Memory.ConstructorType
import qualified Unison.DataDeclaration as Memory.DD
import Unison.Hash (Hash)
import qualified Unison.Hashing.V2.Branch as Hashing.Branch
import qualified Unison.Hashing.V2.Causal as Hashing.Causal
import qualified Unison.Hashing.V2.DataDeclaration as Hashing.DD
import Unison.Hashing.V2.Hashable (Hashable)
import qualified Unison.Hashing.V2.Hashable as Hashable
import qualified Unison.Hashing.V2.Kind as Hashing.Kind
import qualified Unison.Hashing.V2.Patch as Hashing.Patch
import qualified Unison.Hashing.V2.Pattern as Hashing.Pattern
import qualified Unison.Hashing.V2.Reference as Hashing.Reference
import qualified Unison.Hashing.V2.Referent as Hashing.Referent
import qualified Unison.Hashing.V2.Term as Hashing.Term
import qualified Unison.Hashing.V2.TermEdit as Hashing.TermEdit
import qualified Unison.Hashing.V2.Type as Hashing.Type
import qualified Unison.Hashing.V2.TypeEdit as Hashing.TypeEdit
import qualified Unison.Kind as Memory.Kind
import qualified Unison.NameSegment as Memory.NameSegment
import Unison.Names.ResolutionResult (ResolutionResult)
import qualified Unison.Pattern as Memory.Pattern
import qualified Unison.Reference as Memory.Reference
import qualified Unison.Referent as Memory.Referent
import qualified Unison.Term as Memory.Term
import qualified Unison.Type as Memory.Type
import qualified Unison.Util.Map as Map
import qualified Unison.Util.Relation as Relation
import qualified Unison.Util.Star3 as Memory.Star3
import Unison.Var (Var)
typeToReference :: Var v => Memory.Type.Type v a -> Memory.Reference.Reference
@ -39,40 +73,69 @@ typeToReference = h2mReference . Hashing.Type.toReference . m2hType . Memory.Typ
typeToReferenceMentions :: Var v => Memory.Type.Type v a -> Set Memory.Reference.Reference
typeToReferenceMentions = Set.map h2mReference . Hashing.Type.toReferenceMentions . m2hType . Memory.Type.removeAllEffectVars
hashTermComponents :: Var v => Map v (Memory.Term.Term v a) -> Map v (Memory.Reference.Id, Memory.Term.Term v a)
hashTermComponents = fmap h2mTermResult . Hashing.Term.hashComponents . fmap m2hTerm
-- TODO: remove non-prime version
-- include type in hash
hashTermComponents ::
forall v a.
Var v =>
Map v (Memory.Term.Term v a, Memory.Type.Type v a) ->
Map v (Memory.Reference.Id, Memory.Term.Term v a, Memory.Type.Type v a)
hashTermComponents mTerms =
case Writer.runWriter (traverse (bitraverse m2hTerm (pure . m2hType)) mTerms) of
(hTerms, constructorTypes) -> h2mTermResult (constructorTypes Map.!) <$> Hashing.Term.hashComponents hTerms
where
h2mTermResult :: Ord v => (Hashing.Reference.Id, Hashing.Term.Term v a) -> (Memory.Reference.Id, Memory.Term.Term v a)
h2mTermResult (id, tm) = (h2mReferenceId id, h2mTerm tm)
h2mTermResult ::
Ord v =>
( Memory.Reference.Reference ->
Memory.ConstructorType.ConstructorType
) ->
(Hashing.Reference.Id, Hashing.Term.Term v a, Hashing.Type.Type v a) ->
(Memory.Reference.Id, Memory.Term.Term v a, Memory.Type.Type v a)
h2mTermResult getCtorType (id, tm, typ) = (h2mReferenceId id, h2mTerm getCtorType tm, h2mType typ)
-- | This shouldn't be used when storing terms in the codebase, as it doesn't incorporate the type into the hash.
-- this should only be used in cases where you just need a way to identify some terms that you have, but won't be
-- saving them.
hashTermComponentsWithoutTypes ::
forall v a.
Var v =>
Map v (Memory.Term.Term v a) ->
Map v (Memory.Reference.Id, Memory.Term.Term v a)
hashTermComponentsWithoutTypes mTerms =
case Writer.runWriter (traverse m2hTerm mTerms) of
(hTerms, constructorTypes) -> h2mTermResult (constructorTypes Map.!) <$> Hashing.Term.hashComponentsWithoutTypes hTerms
where
h2mTermResult :: Ord v => (Memory.Reference.Reference -> Memory.ConstructorType.ConstructorType) -> (Hashing.Reference.Id, Hashing.Term.Term v a) -> (Memory.Reference.Id, Memory.Term.Term v a)
h2mTermResult getCtorType (id, tm) = (h2mReferenceId id, h2mTerm getCtorType tm)
hashClosedTerm :: Var v => Memory.Term.Term v a -> Memory.Reference.Id
hashClosedTerm = h2mReferenceId . Hashing.Term.hashClosedTerm . m2hTerm
hashClosedTerm = h2mReferenceId . Hashing.Term.hashClosedTerm . fst . Writer.runWriter . m2hTerm
m2hTerm :: Ord v => Memory.Term.Term v a -> Hashing.Term.Term v a
m2hTerm = ABT.transform \case
Memory.Term.Int i -> Hashing.Term.Int i
Memory.Term.Nat n -> Hashing.Term.Nat n
Memory.Term.Float d -> Hashing.Term.Float d
Memory.Term.Boolean b -> Hashing.Term.Boolean b
Memory.Term.Text t -> Hashing.Term.Text t
Memory.Term.Char c -> Hashing.Term.Char c
Memory.Term.Blank b -> Hashing.Term.Blank b
Memory.Term.Ref r -> Hashing.Term.Ref (m2hReference r)
Memory.Term.Constructor (Memory.ConstructorReference.ConstructorReference r i) -> Hashing.Term.Constructor (m2hReference r) i
Memory.Term.Request (Memory.ConstructorReference.ConstructorReference r i) -> Hashing.Term.Request (m2hReference r) i
Memory.Term.Handle x y -> Hashing.Term.Handle x y
Memory.Term.App f x -> Hashing.Term.App f x
Memory.Term.Ann e t -> Hashing.Term.Ann e (m2hType t)
Memory.Term.List as -> Hashing.Term.List as
Memory.Term.And p q -> Hashing.Term.And p q
Memory.Term.If c t f -> Hashing.Term.If c t f
Memory.Term.Or p q -> Hashing.Term.Or p q
Memory.Term.Lam a -> Hashing.Term.Lam a
Memory.Term.LetRec isTop bs body -> Hashing.Term.LetRec isTop bs body
Memory.Term.Let isTop b body -> Hashing.Term.Let isTop b body
Memory.Term.Match scr cases -> Hashing.Term.Match scr (fmap m2hMatchCase cases)
Memory.Term.TermLink r -> Hashing.Term.TermLink (m2hReferent r)
Memory.Term.TypeLink r -> Hashing.Term.TypeLink (m2hReference r)
m2hTerm :: Ord v => Memory.Term.Term v a -> Writer (Map Memory.Reference.Reference Memory.ConstructorType.ConstructorType) (Hashing.Term.Term v a)
m2hTerm = ABT.transformM \case
Memory.Term.Int i -> pure (Hashing.Term.Int i)
Memory.Term.Nat n -> pure (Hashing.Term.Nat n)
Memory.Term.Float d -> pure (Hashing.Term.Float d)
Memory.Term.Boolean b -> pure (Hashing.Term.Boolean b)
Memory.Term.Text t -> pure (Hashing.Term.Text t)
Memory.Term.Char c -> pure (Hashing.Term.Char c)
Memory.Term.Blank b -> pure (Hashing.Term.Blank b)
Memory.Term.Ref r -> pure (Hashing.Term.Ref (m2hReference r))
Memory.Term.Constructor (Memory.ConstructorReference.ConstructorReference r i) -> pure (Hashing.Term.Constructor (m2hReference r) i)
Memory.Term.Request (Memory.ConstructorReference.ConstructorReference r i) -> pure (Hashing.Term.Request (m2hReference r) i)
Memory.Term.Handle x y -> pure (Hashing.Term.Handle x y)
Memory.Term.App f x -> pure (Hashing.Term.App f x)
Memory.Term.Ann e t -> pure (Hashing.Term.Ann e (m2hType t))
Memory.Term.List as -> pure (Hashing.Term.List as)
Memory.Term.And p q -> pure (Hashing.Term.And p q)
Memory.Term.If c t f -> pure (Hashing.Term.If c t f)
Memory.Term.Or p q -> pure (Hashing.Term.Or p q)
Memory.Term.Lam a -> pure (Hashing.Term.Lam a)
Memory.Term.LetRec isTop bs body -> pure (Hashing.Term.LetRec isTop bs body)
Memory.Term.Let isTop b body -> pure (Hashing.Term.Let isTop b body)
Memory.Term.Match scr cases -> pure (Hashing.Term.Match scr (fmap m2hMatchCase cases))
Memory.Term.TermLink r -> Hashing.Term.TermLink <$> m2hReferent r
Memory.Term.TypeLink r -> pure (Hashing.Term.TypeLink (m2hReference r))
m2hMatchCase :: Memory.Term.MatchCase a a1 -> Hashing.Term.MatchCase a a1
m2hMatchCase (Memory.Term.MatchCase pat m_a1 a1) = Hashing.Term.MatchCase (m2hPattern pat) m_a1 a1
@ -87,11 +150,11 @@ m2hPattern = \case
Memory.Pattern.Float loc f -> Hashing.Pattern.Float loc f
Memory.Pattern.Text loc t -> Hashing.Pattern.Text loc t
Memory.Pattern.Char loc c -> Hashing.Pattern.Char loc c
Memory.Pattern.Constructor loc (Memory.ConstructorReference.ConstructorReference r i) ps ->
Memory.Pattern.Constructor loc (Memory.ConstructorReference.ConstructorReference r i) ps ->
Hashing.Pattern.Constructor loc (m2hReference r) i (fmap m2hPattern ps)
Memory.Pattern.As loc p -> Hashing.Pattern.As loc (m2hPattern p)
Memory.Pattern.EffectPure loc p -> Hashing.Pattern.EffectPure loc (m2hPattern p)
Memory.Pattern.EffectBind loc (Memory.ConstructorReference.ConstructorReference r i) ps k ->
Memory.Pattern.EffectBind loc (Memory.ConstructorReference.ConstructorReference r i) ps k ->
Hashing.Pattern.EffectBind loc (m2hReference r) i (fmap m2hPattern ps) (m2hPattern k)
Memory.Pattern.SequenceLiteral loc ps -> Hashing.Pattern.SequenceLiteral loc (fmap m2hPattern ps)
Memory.Pattern.SequenceOp loc l op r -> Hashing.Pattern.SequenceOp loc (m2hPattern l) (m2hSequenceOp op) (m2hPattern r)
@ -102,13 +165,15 @@ m2hSequenceOp = \case
Memory.Pattern.Snoc -> Hashing.Pattern.Snoc
Memory.Pattern.Concat -> Hashing.Pattern.Concat
m2hReferent :: Memory.Referent.Referent -> Hashing.Referent.Referent
m2hReferent :: Memory.Referent.Referent -> Writer (Map Memory.Reference.Reference Memory.ConstructorType.ConstructorType) Hashing.Referent.Referent
m2hReferent = \case
Memory.Referent.Ref ref -> Hashing.Referent.Ref (m2hReference ref)
Memory.Referent.Con (Memory.ConstructorReference.ConstructorReference ref n) ct -> Hashing.Referent.Con (m2hReference ref) n ct
Memory.Referent.Ref ref -> pure (Hashing.Referent.Ref (m2hReference ref))
Memory.Referent.Con (Memory.ConstructorReference.ConstructorReference ref n) ct -> do
Writer.tell (Map.singleton ref ct)
pure (Hashing.Referent.Con (m2hReference ref) n)
h2mTerm :: Ord v => Hashing.Term.Term v a -> Memory.Term.Term v a
h2mTerm = ABT.transform \case
h2mTerm :: Ord v => (Memory.Reference.Reference -> Memory.ConstructorType.ConstructorType) -> Hashing.Term.Term v a -> Memory.Term.Term v a
h2mTerm getCT = ABT.transform \case
Hashing.Term.Int i -> Memory.Term.Int i
Hashing.Term.Nat n -> Memory.Term.Nat n
Hashing.Term.Float d -> Memory.Term.Float d
@ -130,7 +195,7 @@ h2mTerm = ABT.transform \case
Hashing.Term.LetRec isTop bs body -> Memory.Term.LetRec isTop bs body
Hashing.Term.Let isTop b body -> Memory.Term.Let isTop b body
Hashing.Term.Match scr cases -> Memory.Term.Match scr (h2mMatchCase <$> cases)
Hashing.Term.TermLink r -> Memory.Term.TermLink (h2mReferent r)
Hashing.Term.TermLink r -> Memory.Term.TermLink (h2mReferent getCT r)
Hashing.Term.TypeLink r -> Memory.Term.TypeLink (h2mReference r)
h2mMatchCase :: Hashing.Term.MatchCase a b -> Memory.Term.MatchCase a b
@ -146,11 +211,11 @@ h2mPattern = \case
Hashing.Pattern.Float loc f -> Memory.Pattern.Float loc f
Hashing.Pattern.Text loc t -> Memory.Pattern.Text loc t
Hashing.Pattern.Char loc c -> Memory.Pattern.Char loc c
Hashing.Pattern.Constructor loc r i ps ->
Hashing.Pattern.Constructor loc r i ps ->
Memory.Pattern.Constructor loc (Memory.ConstructorReference.ConstructorReference (h2mReference r) i) (h2mPattern <$> ps)
Hashing.Pattern.As loc p -> Memory.Pattern.As loc (h2mPattern p)
Hashing.Pattern.EffectPure loc p -> Memory.Pattern.EffectPure loc (h2mPattern p)
Hashing.Pattern.EffectBind loc r i ps k ->
Hashing.Pattern.EffectBind loc r i ps k ->
Memory.Pattern.EffectBind loc (Memory.ConstructorReference.ConstructorReference (h2mReference r) i) (h2mPattern <$> ps) (h2mPattern k)
Hashing.Pattern.SequenceLiteral loc ps -> Memory.Pattern.SequenceLiteral loc (h2mPattern <$> ps)
Hashing.Pattern.SequenceOp loc l op r -> Memory.Pattern.SequenceOp loc (h2mPattern l) (h2mSequenceOp op) (h2mPattern r)
@ -161,16 +226,18 @@ h2mSequenceOp = \case
Hashing.Pattern.Snoc -> Memory.Pattern.Snoc
Hashing.Pattern.Concat -> Memory.Pattern.Concat
h2mReferent :: Hashing.Referent.Referent -> Memory.Referent.Referent
h2mReferent = \case
h2mReferent :: (Memory.Reference.Reference -> Memory.ConstructorType.ConstructorType) -> Hashing.Referent.Referent -> Memory.Referent.Referent
h2mReferent getCT = \case
Hashing.Referent.Ref ref -> Memory.Referent.Ref (h2mReference ref)
Hashing.Referent.Con ref n ct -> Memory.Referent.Con (Memory.ConstructorReference.ConstructorReference (h2mReference ref) n) ct
Hashing.Referent.Con ref n ->
let mRef = h2mReference ref
in Memory.Referent.Con (Memory.ConstructorReference.ConstructorReference mRef n) (getCT mRef)
hashDecls ::
hashDataDecls ::
Var v =>
Map v (Memory.DD.DataDeclaration v a) ->
ResolutionResult v a [(v, Memory.Reference.Id, Memory.DD.DataDeclaration v a)]
hashDecls memDecls = do
hashDataDecls memDecls = do
let hashingDecls = fmap m2hDecl memDecls
hashingResult <- Hashing.DD.hashDecls hashingDecls
pure $ map h2mDeclResult hashingResult
@ -178,6 +245,28 @@ hashDecls memDecls = do
h2mDeclResult :: Ord v => (v, Hashing.Reference.Id, Hashing.DD.DataDeclaration v a) -> (v, Memory.Reference.Id, Memory.DD.DataDeclaration v a)
h2mDeclResult (v, id, dd) = (v, h2mReferenceId id, h2mDecl dd)
hashDecls ::
Var v =>
Map v (Memory.DD.Decl v a) ->
ResolutionResult v a [(v, Memory.Reference.Id, Memory.DD.Decl v a)]
hashDecls memDecls = do
-- want to unwrap the decl before doing the rehashing, and then wrap it back up the same way
let howToReassemble =
memDecls <&> \case
Left {} -> CT.Effect
Right {} -> CT.Data
memDeclsAsDDs = Memory.DD.asDataDecl <$> memDecls
result <- hashDataDecls memDeclsAsDDs
pure $
result <&> \(v, id', decl) ->
case Map.lookup v howToReassemble of
Nothing -> error "Unknown v in hashDecls'"
Just ct -> (v, id', retag ct decl)
where
retag :: CT.ConstructorType -> Memory.DD.DataDeclaration v a -> Memory.DD.Decl v a
retag CT.Effect = Left . Memory.DD.EffectDeclaration
retag CT.Data = Right
m2hDecl :: Ord v => Memory.DD.DataDeclaration v a -> Hashing.DD.DataDeclaration v a
m2hDecl (Memory.DD.DataDeclaration mod ann bound ctors) =
Hashing.DD.DataDeclaration (m2hModifier mod) ann bound $ fmap (Lens.over _3 m2hType) ctors
@ -186,20 +275,25 @@ m2hType :: Ord v => Memory.Type.Type v a -> Hashing.Type.Type v a
m2hType = ABT.transform \case
Memory.Type.Ref ref -> Hashing.Type.Ref (m2hReference ref)
Memory.Type.Arrow a1 a1' -> Hashing.Type.Arrow a1 a1'
Memory.Type.Ann a1 ki -> Hashing.Type.Ann a1 ki
Memory.Type.Ann a1 ki -> Hashing.Type.Ann a1 (m2hKind ki)
Memory.Type.App a1 a1' -> Hashing.Type.App a1 a1'
Memory.Type.Effect a1 a1' -> Hashing.Type.Effect a1 a1'
Memory.Type.Effects a1s -> Hashing.Type.Effects a1s
Memory.Type.Forall a1 -> Hashing.Type.Forall a1
Memory.Type.IntroOuter a1 -> Hashing.Type.IntroOuter a1
m2hKind :: Memory.Kind.Kind -> Hashing.Kind.Kind
m2hKind = \case
Memory.Kind.Star -> Hashing.Kind.Star
Memory.Kind.Arrow k1 k2 -> Hashing.Kind.Arrow (m2hKind k1) (m2hKind k2)
m2hReference :: Memory.Reference.Reference -> Hashing.Reference.Reference
m2hReference = \case
Memory.Reference.Builtin t -> Hashing.Reference.Builtin t
Memory.Reference.DerivedId d -> Hashing.Reference.DerivedId (m2hReferenceId d)
m2hReferenceId :: Memory.Reference.Id -> Hashing.Reference.Id
m2hReferenceId (Memory.Reference.Id h i _n) = Hashing.Reference.Id h i _n
m2hReferenceId (Memory.Reference.Id h i) = Hashing.Reference.Id h i
h2mModifier :: Hashing.DD.Modifier -> Memory.DD.Modifier
h2mModifier = \case
@ -219,17 +313,109 @@ h2mType :: Ord v => Hashing.Type.Type v a -> Memory.Type.Type v a
h2mType = ABT.transform \case
Hashing.Type.Ref ref -> Memory.Type.Ref (h2mReference ref)
Hashing.Type.Arrow a1 a1' -> Memory.Type.Arrow a1 a1'
Hashing.Type.Ann a1 ki -> Memory.Type.Ann a1 ki
Hashing.Type.Ann a1 ki -> Memory.Type.Ann a1 (h2mKind ki)
Hashing.Type.App a1 a1' -> Memory.Type.App a1 a1'
Hashing.Type.Effect a1 a1' -> Memory.Type.Effect a1 a1'
Hashing.Type.Effects a1s -> Memory.Type.Effects a1s
Hashing.Type.Forall a1 -> Memory.Type.Forall a1
Hashing.Type.IntroOuter a1 -> Memory.Type.IntroOuter a1
h2mKind :: Hashing.Kind.Kind -> Memory.Kind.Kind
h2mKind = \case
Hashing.Kind.Star -> Memory.Kind.Star
Hashing.Kind.Arrow k1 k2 -> Memory.Kind.Arrow (h2mKind k1) (h2mKind k2)
h2mReference :: Hashing.Reference.Reference -> Memory.Reference.Reference
h2mReference = \case
Hashing.Reference.Builtin t -> Memory.Reference.Builtin t
Hashing.Reference.DerivedId d -> Memory.Reference.DerivedId (h2mReferenceId d)
h2mReferenceId :: Hashing.Reference.Id -> Memory.Reference.Id
h2mReferenceId (Hashing.Reference.Id h i n) = Memory.Reference.Id h i n
h2mReferenceId (Hashing.Reference.Id h i) = Memory.Reference.Id h i
m2hPatch :: Memory.Patch.Patch -> Hashing.Patch.Patch
m2hPatch (Memory.Patch.Patch termEdits typeEdits) =
Hashing.Patch.Patch termEdits' typeEdits'
where
typeEdits' =
Map.fromList
. map (bimap m2hReference (Set.map m2hTypeEdit))
. Map.toList
$ Relation.toMultimap typeEdits
termEdits' =
Map.fromList
. map (bimap (Hashing.Referent.Ref . m2hReference) (Set.map m2hTermEdit))
. Map.toList
$ Relation.toMultimap termEdits
m2hTermEdit = \case
Memory.TermEdit.Replace r _ -> Hashing.TermEdit.Replace (Hashing.Referent.Ref $ m2hReference r)
Memory.TermEdit.Deprecate -> Hashing.TermEdit.Deprecate
m2hTypeEdit = \case
Memory.TypeEdit.Replace r -> Hashing.TypeEdit.Replace (m2hReference r)
Memory.TypeEdit.Deprecate -> Hashing.TypeEdit.Deprecate
hashPatch :: Memory.Patch.Patch -> Hash
hashPatch = Hashing.Patch.hashPatch . m2hPatch
hashBranch0 :: Memory.Branch.Branch0 m -> Hash
hashBranch0 = Hashing.Branch.hashBranch . m2hBranch0
hashCausal :: Hashable e => e -> Set (Memory.Causal.RawHash h) -> Hash
hashCausal e tails =
Hashing.Causal.hashCausal $
Hashing.Causal.Causal (Hashable.hash e) (Set.map Memory.Causal.unRawHash tails)
m2hBranch0 :: Memory.Branch.Branch0 m -> Hashing.Branch.Raw
m2hBranch0 b =
Hashing.Branch.Raw
(doTerms (Memory.Branch._terms b))
(doTypes (Memory.Branch._types b))
(doPatches (Memory.Branch._edits b))
(doChildren (Memory.Branch._children b))
where
-- is there a more readable way to structure these that's also linear?
doTerms ::
Memory.Branch.Star Memory.Referent.Referent Memory.NameSegment.NameSegment ->
Map Hashing.Branch.NameSegment (Map Hashing.Referent.Referent Hashing.Branch.MdValues)
doTerms s =
Map.fromList
[ (m2hNameSegment ns, m2)
| ns <- toList . Relation.ran $ Memory.Star3.d1 s,
let m2 =
Map.fromList
[ (fst (Writer.runWriter (m2hReferent r)), md)
| r <- toList . Relation.lookupRan ns $ Memory.Star3.d1 s,
let mdrefs1to2 (_typeR1, valR1) = m2hReference valR1
md = Hashing.Branch.MdValues . Set.map mdrefs1to2 . Relation.lookupDom r $ Memory.Star3.d3 s
]
]
doTypes ::
Memory.Branch.Star Memory.Reference.Reference Memory.NameSegment.NameSegment ->
Map Hashing.Branch.NameSegment (Map Hashing.Reference.Reference Hashing.Branch.MdValues)
doTypes s =
Map.fromList
[ (m2hNameSegment ns, m2)
| ns <- toList . Relation.ran $ Memory.Star3.d1 s,
let m2 =
Map.fromList
[ (m2hReference r, md)
| r <- toList . Relation.lookupRan ns $ Memory.Star3.d1 s,
let mdrefs1to2 (_typeR1, valR1) = m2hReference valR1
md :: Hashing.Branch.MdValues
md = Hashing.Branch.MdValues . Set.map mdrefs1to2 . Relation.lookupDom r $ Memory.Star3.d3 s
]
]
doPatches ::
Map Memory.NameSegment.NameSegment (Memory.Branch.EditHash, m Memory.Patch.Patch) ->
Map Hashing.Branch.NameSegment Hash
doPatches = Map.bimap m2hNameSegment fst
doChildren ::
Map Memory.NameSegment.NameSegment (Memory.Branch.Branch m) ->
Map Hashing.Branch.NameSegment Hash
doChildren = Map.bimap m2hNameSegment (Memory.Causal.unRawHash . Memory.Branch.headHash)
m2hNameSegment :: Memory.NameSegment.NameSegment -> Hashing.Branch.NameSegment
m2hNameSegment (Memory.NameSegment.NameSegment s) = Hashing.Branch.NameSegment s

41
parser-typechecker/src/Unison/Hashing/V2/DataDeclaration.hs
View File

@ -12,12 +12,6 @@ module Unison.Hashing.V2.DataDeclaration
EffectDeclaration (..),
Decl,
Modifier (..),
asDataDecl,
constructorType,
constructorTypes,
declDependencies,
dependencies,
bindReferences,
hashDecls,
)
where
@ -25,13 +19,11 @@ where
import Control.Lens (over, _3)
import Data.Bifunctor (first, second)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Unison.Var (Var)
import qualified Unison.ABT as ABT
import qualified Unison.ConstructorType as CT
import Unison.Hash (Hash)
import Unison.Hashable (Hashable1)
import qualified Unison.Hashable as Hashable
import qualified Unison.Hashing.V2.ABT as ABT
import Unison.Hashing.V2.Tokenizable (Hashable1)
import qualified Unison.Hashing.V2.Tokenizable as Hashable
import Unison.Hashing.V2.Reference (Reference)
import qualified Unison.Hashing.V2.Reference as Reference
import qualified Unison.Hashing.V2.Reference.Util as Reference.Util
@ -40,21 +32,11 @@ import qualified Unison.Hashing.V2.Type as Type
import qualified Unison.Name as Name
import qualified Unison.Names.ResolutionResult as Names
import Unison.Prelude
import Unison.Var (Var)
import Prelude hiding (cycle)
type Decl v a = Either (EffectDeclaration v a) (DataDeclaration v a)
asDataDecl :: Decl v a -> DataDeclaration v a
asDataDecl = either toDataDecl id
declDependencies :: Ord v => Decl v a -> Set Reference
declDependencies = either (dependencies . toDataDecl) dependencies
constructorType :: Decl v a -> CT.ConstructorType
constructorType = \case
Left {} -> CT.Effect
Right {} -> CT.Data
data Modifier = Structural | Unique Text -- | Opaque (Set Reference)
deriving (Eq, Ord, Show)
@ -77,20 +59,13 @@ constructorTypes = (snd <$>) . constructors
constructors :: DataDeclaration v a -> [(v, Type v a)]
constructors (DataDeclaration _ _ _ ctors) = [(v, t) | (_, v, t) <- ctors]
dependencies :: Ord v => DataDeclaration v a -> Set Reference
dependencies dd =
Set.unions (Type.dependencies <$> constructorTypes dd)
toABT :: Var v => DataDeclaration v () -> ABT.Term F v ()
toABT :: ABT.Var v => DataDeclaration v () -> ABT.Term F v ()
toABT dd = ABT.tm $ Modified (modifier dd) dd'
where
dd' = ABT.absChain (bound dd) $ ABT.cycle
(ABT.absChain
(fst <$> constructors dd)
(ABT.tm . Constructors $ ABT.transform Type <$> constructorTypes dd))
dd' = ABT.absChain (bound dd) (ABT.tm (Constructors (ABT.transform Type <$> constructorTypes dd)))
-- Implementation detail of `hashDecls`, works with unannotated data decls
hashDecls0 :: (Eq v, Var v, Show v) => Map v (DataDeclaration v ()) -> [(v, Reference.Id)]
hashDecls0 :: (Eq v, ABT.Var v, Show v) => Map v (DataDeclaration v ()) -> [(v, Reference.Id)]
hashDecls0 decls =
let abts = toABT <$> decls
ref r = ABT.tm (Type (Type.Ref (Reference.DerivedId r)))
@ -160,6 +135,6 @@ instance Hashable1 F where
Modified m t ->
[tag 3, Hashable.accumulateToken m, hashed $ hash t]
instance Hashable.Hashable Modifier where
instance Hashable.Tokenizable Modifier where
tokens Structural = [Hashable.Tag 0]
tokens (Unique txt) = [Hashable.Tag 1, Hashable.Text txt]

25
parser-typechecker/src/Unison/Hashing/V2/Hashable.hs Normal file
View File

@ -0,0 +1,25 @@
module Unison.Hashing.V2.Hashable
( Hashable (..),
)
where
import Data.Int (Int64)
import Data.Set (Set)
import Unison.Hash (Hash (..))
import qualified Unison.Hashing.V2.Tokenizable as Tokenizable
-- | This typeclass provides a mechanism for obtaining a content-based hash for Unison types &
-- terms.
-- Be wary that Unison requires that these hashes be deterministic, any change to a Hashable
-- instance requires a full codebase migration and should not be taken lightly.
class Hashable t where
hash :: t -> Hash
instance Tokenizable.Tokenizable a => Hashable [a] where
hash = Tokenizable.hashTokenizable
instance Tokenizable.Tokenizable a => Hashable (Set a) where
hash = Tokenizable.hashTokenizable
instance Hashable Int64 where
hash = Tokenizable.hashTokenizable

14
parser-typechecker/src/Unison/Hashing/V2/Kind.hs Normal file
View File

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

57
parser-typechecker/src/Unison/Hashing/V2/LabeledDependency.hs
View File

@ -1,57 +0,0 @@
{- ORMOLU_DISABLE -} -- Remove this when the file is ready to be auto-formatted
{-# LANGUAGE PatternSynonyms #-}
module Unison.Hashing.V2.LabeledDependency
( derivedTerm
, derivedType
, termRef
, typeRef
, referent
, dataConstructor
, effectConstructor
, fold
, referents
, toReference
, LabeledDependency
, partition
) where
import Unison.Prelude hiding (fold)
import qualified Data.Set as Set
import Unison.Hashing.V2.Reference (Id, Reference (DerivedId))
import Unison.Hashing.V2.Referent (ConstructorId, Referent, pattern Con, pattern Ref)
import Unison.ConstructorType (ConstructorType (Data, Effect))
-- dumb constructor name is private
newtype LabeledDependency = X (Either Reference Referent) deriving (Eq, Ord, Show)
derivedType, derivedTerm :: Id -> LabeledDependency
typeRef, termRef :: Reference -> LabeledDependency
referent :: Referent -> LabeledDependency
dataConstructor :: Reference -> ConstructorId -> LabeledDependency
effectConstructor :: Reference -> ConstructorId -> LabeledDependency
derivedType = X . Left . DerivedId
derivedTerm = X . Right . Ref . DerivedId
typeRef = X . Left
termRef = X . Right . Ref
referent = X . Right
dataConstructor r cid = X . Right $ Con r cid Data
effectConstructor r cid = X . Right $ Con r cid Effect
referents :: Foldable f => f Referent -> Set LabeledDependency
referents rs = Set.fromList (map referent $ toList rs)
fold :: (Reference -> a) -> (Referent -> a) -> LabeledDependency -> a
fold f g (X e) = either f g e
partition :: Foldable t => t LabeledDependency -> ([Reference], [Referent])
partition = partitionEithers . map (\(X e) -> e) . toList
-- | Left TypeRef | Right TermRef
toReference :: LabeledDependency -> Either Reference Reference
toReference = \case
X (Left r) -> Left r
X (Right (Ref r)) -> Right r
X (Right (Con r _ _)) -> Left r

29
parser-typechecker/src/Unison/Hashing/V2/Patch.hs Normal file
View File

@ -0,0 +1,29 @@
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Unison.Hashing.V2.Patch (Patch (..), hashPatch) where
import Data.Map (Map)
import Data.Set (Set)
import Unison.Hash (Hash)
import Unison.Hashing.V2.Tokenizable (Tokenizable)
import qualified Unison.Hashing.V2.Tokenizable as H
import Unison.Hashing.V2.Reference (Reference)
import Unison.Hashing.V2.Referent (Referent)
import Unison.Hashing.V2.TermEdit (TermEdit)
import Unison.Hashing.V2.TypeEdit (TypeEdit)
hashPatch :: Patch -> Hash
hashPatch = H.hashTokenizable
data Patch = Patch
{ termEdits :: Map Referent (Set TermEdit),
typeEdits :: Map Reference (Set TypeEdit)
}
instance Tokenizable Patch where
tokens p =
[ H.accumulateToken (termEdits p),
H.accumulateToken (typeEdits p)
]

133
parser-typechecker/src/Unison/Hashing/V2/Pattern.hs
View File

@ -1,18 +1,19 @@
{- ORMOLU_DISABLE -} -- Remove this when the file is ready to be auto-formatted
{-# Language DeriveTraversable, DeriveGeneric, PatternSynonyms, OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
module Unison.Hashing.V2.Pattern where
import Unison.Prelude
import Data.Foldable as Foldable hiding (foldMap')
import Data.List (intercalate)
import qualified Data.Set as Set
import Unison.DataDeclaration.ConstructorId (ConstructorId)
import qualified Unison.Hashing.V2.Tokenizable as H
import Unison.Hashing.V2.Reference (Reference)
import qualified Unison.Hashing.V2.Type as Type
import qualified Unison.Hashable as H
type ConstructorId = Int
import Unison.Prelude
data Pattern loc
= Unbound loc
@ -23,36 +24,37 @@ data Pattern loc
| Float loc !Double
| Text loc !Text
| Char loc !Char
| Constructor loc !Reference !Int [Pattern loc]
| Constructor loc !Reference !ConstructorId [Pattern loc]
| As loc (Pattern loc)
| EffectPure loc (Pattern loc)
| EffectBind loc !Reference !Int [Pattern loc] (Pattern loc)
| EffectBind loc !Reference !ConstructorId [Pattern loc] (Pattern loc)
| SequenceLiteral loc [Pattern loc]
| SequenceOp loc (Pattern loc) !SeqOp (Pattern loc)
deriving (Ord,Generic,Functor,Foldable,Traversable)
deriving (Ord, Generic, Functor, Foldable, Traversable)
data SeqOp = Cons
| Snoc
| Concat
deriving (Eq, Show, Ord, Generic)
data SeqOp
= Cons
| Snoc
| Concat
deriving (Eq, Show, Ord, Generic)
instance H.Hashable SeqOp where
instance H.Tokenizable SeqOp where
tokens Cons = [H.Tag 0]
tokens Snoc = [H.Tag 1]
tokens Concat = [H.Tag 2]
instance Show (Pattern loc) where
show (Unbound _ ) = "Unbound"
show (Var _ ) = "Var"
show (Unbound _) = "Unbound"
show (Var _) = "Var"
show (Boolean _ x) = "Boolean " <> show x
show (Int _ x) = "Int " <> show x
show (Nat _ x) = "Nat " <> show x
show (Float _ x) = "Float " <> show x
show (Text _ t) = "Text " <> show t
show (Char _ c) = "Char " <> show c
show (Int _ x) = "Int " <> show x
show (Nat _ x) = "Nat " <> show x
show (Float _ x) = "Float " <> show x
show (Text _ t) = "Text " <> show t
show (Char _ c) = "Char " <> show c
show (Constructor _ r i ps) =
"Constructor " <> unwords [show r, show i, show ps]
show (As _ p) = "As " <> show p
show (As _ p) = "As " <> show p
show (EffectPure _ k) = "EffectPure " <> show k
show (EffectBind _ r i ps k) =
"EffectBind " <> unwords [show r, show i, show ps, show k]
@ -76,7 +78,7 @@ setLoc p loc = case p of
SequenceOp _ ph op pt -> SequenceOp loc ph op pt
x -> fmap (const loc) x
instance H.Hashable (Pattern p) where
instance H.Tokenizable (Pattern p) where
tokens (Unbound _) = [H.Tag 0]
tokens (Var _) = [H.Tag 1]
tokens (Boolean _ b) = H.Tag 2 : [H.Tag $ if b then 1 else 0]
@ -112,46 +114,47 @@ instance Eq (Pattern loc) where
foldMap' :: Monoid m => (Pattern loc -> m) -> Pattern loc -> m
foldMap' f p = case p of
Unbound _ -> f p
Var _ -> f p
Boolean _ _ -> f p
Int _ _ -> f p
Nat _ _ -> f p
Float _ _ -> f p
Text _ _ -> f p
Char _ _ -> f p
Constructor _ _ _ ps -> f p <> foldMap (foldMap' f) ps
As _ p' -> f p <> foldMap' f p'
EffectPure _ p' -> f p <> foldMap' f p'
EffectBind _ _ _ ps p' -> f p <> foldMap (foldMap' f) ps <> foldMap' f p'
SequenceLiteral _ ps -> f p <> foldMap (foldMap' f) ps
SequenceOp _ p1 _ p2 -> f p <> foldMap' f p1 <> foldMap' f p2
Unbound _ -> f p
Var _ -> f p
Boolean _ _ -> f p
Int _ _ -> f p
Nat _ _ -> f p
Float _ _ -> f p
Text _ _ -> f p
Char _ _ -> f p
Constructor _ _ _ ps -> f p <> foldMap (foldMap' f) ps
As _ p' -> f p <> foldMap' f p'
EffectPure _ p' -> f p <> foldMap' f p'
EffectBind _ _ _ ps p' -> f p <> foldMap (foldMap' f) ps <> foldMap' f p'
SequenceLiteral _ ps -> f p <> foldMap (foldMap' f) ps
SequenceOp _ p1 _ p2 -> f p <> foldMap' f p1 <> foldMap' f p2
generalizedDependencies
:: Ord r
=> (Reference -> r)
-> (Reference -> ConstructorId -> r)
-> (Reference -> r)
-> (Reference -> ConstructorId -> r)
-> (Reference -> r)
-> Pattern loc
-> Set r
generalizedDependencies literalType dataConstructor dataType effectConstructor effectType
= Set.fromList . foldMap'
(\case
Unbound _ -> mempty
Var _ -> mempty
As _ _ -> mempty
Constructor _ r cid _ -> [dataType r, dataConstructor r cid]
EffectPure _ _ -> [effectType Type.effectRef]
EffectBind _ r cid _ _ ->
[effectType Type.effectRef, effectType r, effectConstructor r cid]
SequenceLiteral _ _ -> [literalType Type.listRef]
SequenceOp {} -> [literalType Type.listRef]
Boolean _ _ -> [literalType Type.booleanRef]
Int _ _ -> [literalType Type.intRef]
Nat _ _ -> [literalType Type.natRef]
Float _ _ -> [literalType Type.floatRef]
Text _ _ -> [literalType Type.textRef]
Char _ _ -> [literalType Type.charRef]
)
generalizedDependencies ::
Ord r =>
(Reference -> r) ->
(Reference -> ConstructorId -> r) ->
(Reference -> r) ->
(Reference -> ConstructorId -> r) ->
(Reference -> r) ->
Pattern loc ->
Set r
generalizedDependencies literalType dataConstructor dataType effectConstructor effectType =
Set.fromList
. foldMap'
( \case
Unbound _ -> mempty
Var _ -> mempty
As _ _ -> mempty
Constructor _ r cid _ -> [dataType r, dataConstructor r cid]
EffectPure _ _ -> [effectType Type.effectRef]
EffectBind _ r cid _ _ ->
[effectType Type.effectRef, effectType r, effectConstructor r cid]
SequenceLiteral _ _ -> [literalType Type.listRef]
SequenceOp {} -> [literalType Type.listRef]
Boolean _ _ -> [literalType Type.booleanRef]
Int _ _ -> [literalType Type.intRef]
Nat _ _ -> [literalType Type.natRef]
Float _ _ -> [literalType Type.floatRef]
Text _ _ -> [literalType Type.textRef]
Char _ _ -> [literalType Type.charRef]
)

177
parser-typechecker/src/Unison/Hashing/V2/Reference.hs
View File

@ -5,42 +5,23 @@
{-# LANGUAGE ViewPatterns #-}
module Unison.Hashing.V2.Reference
(Reference,
pattern Builtin,
pattern Derived,
pattern DerivedId,
Id(..),
Pos,
Size,
derivedBase32Hex,
Component, members,
components,
groupByComponent,
componentFor,
unsafeFromText,
idFromText,
isPrefixOf,
fromShortHash,
fromText,
readSuffix,
showShort,
showSuffix,
toId,
toText,
unsafeId,
toShortHash,
idToShortHash) where
( Reference,
pattern Builtin,
pattern Derived,
pattern DerivedId,
Id (..),
components,
)
where
import Unison.Prelude
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Unison.Hash as H
import Unison.Hashable as Hashable
import qualified Data.Text as Text
import qualified Unison.Hash as H
import Unison.Hashing.V2.Tokenizable (Tokenizable)
import qualified Unison.Hashing.V2.Tokenizable as Hashable
import Unison.ShortHash (ShortHash)
import qualified Unison.ShortHash as SH
import Data.Char (isDigit)
-- | Either a builtin or a user defined (hashed) top-level declaration.
--
@ -53,143 +34,37 @@ data Reference
-- The `Pos` refers to a particular element of the component
-- and the `Size` is the number of elements in the component.
-- Using an ugly name so no one tempted to use this
| DerivedId Id deriving (Eq,Ord,Generic)
| DerivedId Id deriving (Eq, Ord)
pattern Derived :: H.Hash -> Pos -> Size -> Reference
pattern Derived h i n = DerivedId (Id h i n)
type Pos = Word64
pattern Derived :: H.Hash -> Pos -> Reference
pattern Derived h i = DerivedId (Id h i)
{-# COMPLETE Builtin, Derived #-}
-- | @Pos@ is a position into a cycle of size @Size@, as cycles are hashed together.
data Id = Id H.Hash Pos Size deriving (Generic)
data Id = Id H.Hash Pos deriving (Eq, Ord)
unsafeId :: Reference -> Id
unsafeId (Builtin b) =
error $ "Tried to get the hash of builtin " <> Text.unpack b <> "."
unsafeId (DerivedId x) = x
idToShortHash :: Id -> ShortHash
idToShortHash = toShortHash . DerivedId
-- todo: move these to ShortHash module?
-- but Show Reference currently depends on SH
-- todo: delete these, but `instance Show Reference` currently depends on SH
toShortHash :: Reference -> ShortHash
toShortHash (Builtin b) = SH.Builtin b
toShortHash (Derived h _ 1) = SH.ShortHash (H.base32Hex h) Nothing Nothing
toShortHash (Derived h i n) = SH.ShortHash (H.base32Hex h) index Nothing
where
-- todo: remove `n` parameter; must also update readSuffix
index = Just $ showSuffix i n
toShortHash (Derived h 0) = SH.ShortHash (H.base32Hex h) Nothing Nothing
toShortHash (Derived h i) = SH.ShortHash (H.base32Hex h) (Just $ showSuffix i) Nothing
-- toShortHash . fromJust . fromShortHash == id and
-- fromJust . fromShortHash . toShortHash == id
-- but for arbitrary ShortHashes which may be broken at the wrong boundary, it
-- may not be possible to base32Hex decode them. These will return Nothing.
-- Also, ShortHashes that include constructor ids will return Nothing;
-- try Referent.fromShortHash
fromShortHash :: ShortHash -> Maybe Reference
fromShortHash (SH.Builtin b) = Just (Builtin b)
fromShortHash (SH.ShortHash prefix cycle Nothing) = do
h <- H.fromBase32Hex prefix
case cycle of
Nothing -> Just (Derived h 0 1)
Just t -> case Text.splitOn "c" t of
[i,n] -> Derived h <$> readMay (Text.unpack i) <*> readMay (Text.unpack n)
_ -> Nothing
fromShortHash (SH.ShortHash _prefix _cycle (Just _cid)) = Nothing
-- (3,10) encoded as "3c10"
-- (0,93) encoded as "0c93"
showSuffix :: Pos -> Size -> Text
showSuffix i n = Text.pack $ show i <> "c" <> show n
-- todo: don't read or return size; must also update showSuffix and fromText
readSuffix :: Text -> Either String (Pos, Size)
readSuffix t = case Text.breakOn "c" t of
(pos, Text.drop 1 -> size)
| Text.all isDigit pos && Text.all isDigit size,
Just pos' <- readMaybe (Text.unpack pos),
Just size' <- readMaybe (Text.unpack size) -> Right (pos', size')
_ -> Left "suffix decoding error"
isPrefixOf :: ShortHash -> Reference -> Bool
isPrefixOf sh r = SH.isPrefixOf sh (toShortHash r)
toText :: Reference -> Text
toText = SH.toText . toShortHash
showShort :: Int -> Reference -> Text
showShort numHashChars = SH.toText . SH.take numHashChars . toShortHash
type Pos = Word64
type Size = Word64
newtype Component = Component { members :: Set Reference }
-- Gives the component (dependency cycle) that the reference is a part of
componentFor :: Reference -> Component
componentFor b@Builtin {} = Component (Set.singleton b)
componentFor (Derived h _ n) =
Component $ Set.fromList [Derived h i n | i <- take (fromIntegral n) [0 ..]]
derivedBase32Hex :: Text -> Pos -> Size -> Reference
derivedBase32Hex b32Hex i n = DerivedId (Id (fromMaybe msg h) i n)
where
msg = error $ "Reference.derivedBase32Hex " <> show h
h = H.fromBase32Hex b32Hex
unsafeFromText :: Text -> Reference
unsafeFromText = either error id . fromText
idFromText :: Text -> Maybe Id
idFromText s = case fromText s of
Left _ -> Nothing
Right (Builtin _) -> Nothing
Right (DerivedId id) -> pure id
toId :: Reference -> Maybe Id
toId (DerivedId id) = Just id
toId Builtin{} = Nothing
-- examples:
-- `##Text.take` — builtins don’t have cycles
-- `#2tWjVAuc7` — derived, no cycle
-- `#y9ycWkiC1.y9` — derived, part of cycle
-- todo: take a (Reference -> CycleSize) so that `readSuffix` doesn't have to parse the size from the text.
fromText :: Text -> Either String Reference
fromText t = case Text.split (=='#') t of
[_, "", b] -> Right (Builtin b)
[_, h] -> case Text.split (=='.') h of
[hash] -> Right (derivedBase32Hex hash 0 1)
[hash, suffix] -> uncurry (derivedBase32Hex hash) <$> readSuffix suffix
_ -> bail
_ -> bail
where bail = Left $ "couldn't parse a Reference from " <> Text.unpack t
showSuffix :: Pos -> Text
showSuffix = Text.pack . show
component :: H.Hash -> [k] -> [(k, Id)]
component h ks = let
size = fromIntegral (length ks)
in [ (k, (Id h i size)) | (k, i) <- ks `zip` [0..]]
in [ (k, (Id h i)) | (k, i) <- ks `zip` [0..]]
components :: [(H.Hash, [k])] -> [(k, Id)]
components sccs = uncurry component =<< sccs
groupByComponent :: [(k, Reference)] -> [[(k, Reference)]]
groupByComponent refs = done $ foldl' insert Map.empty refs
where
insert m (k, r@(Derived h _ _)) =
Map.unionWith (<>) m (Map.fromList [(Right h, [(k,r)])])
insert m (k, r) =
Map.unionWith (<>) m (Map.fromList [(Left r, [(k,r)])])
done m = sortOn snd <$> toList m
instance Show Id where show = SH.toString . SH.take 5 . toShortHash . DerivedId
instance Show Reference where show = SH.toString . SH.take 5 . toShortHash
instance Hashable.Hashable Reference where
instance Tokenizable Reference where
tokens (Builtin txt) = [Hashable.Tag 0, Hashable.Text txt]
tokens (DerivedId (Id h i n)) = [Hashable.Tag 1, Hashable.Bytes (H.toByteString h), Hashable.Nat i, Hashable.Nat n]
-- | Two references mustn't differ in cycle length only.
instance Eq Id where x == y = compare x y == EQ
instance Ord Id where Id h i _ `compare` Id h2 i2 _ = compare h h2 <> compare i i2
tokens (DerivedId (Id h i)) = [Hashable.Tag 1, Hashable.Bytes (H.toByteString h), Hashable.Nat i]

6
parser-typechecker/src/Unison/Hashing/V2/Reference/Util.hs
View File

@ -4,9 +4,9 @@ module Unison.Hashing.V2.Reference.Util where
import Unison.Prelude
import qualified Unison.Hashing.V2.Reference as Reference
import Unison.Hashable (Hashable1)
import Unison.Hashing.V2.Tokenizable (Hashable1)
import Unison.ABT (Var)
import qualified Unison.ABT as ABT
import qualified Unison.Hashing.V2.ABT as ABT
import qualified Data.Map as Map
hashComponents ::
@ -17,4 +17,4 @@ hashComponents ::
hashComponents embedRef tms =
Map.fromList [ (v, (r,e)) | ((v,e), r) <- cs ]
where cs = Reference.components $ ABT.hashComponents ref tms
ref h i n = embedRef (Reference.Id h i n)
ref h i = embedRef (Reference.Id h i)

131
parser-typechecker/src/Unison/Hashing/V2/Referent.hs
View File

@ -2,123 +2,22 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
module Unison.Hashing.V2.Referent where
module Unison.Hashing.V2.Referent
( Referent,
pattern Ref,
pattern Con,
ConstructorId,
)
where
import Unison.Prelude
import Unison.ConstructorReference (GConstructorReference(..))
import Unison.Referent' ( Referent'(..), toReference' )
import qualified Data.Char as Char
import qualified Data.Text as Text
import Unison.DataDeclaration.ConstructorId (ConstructorId)
import Unison.Hashing.V2.Tokenizable (Tokenizable)
import qualified Unison.Hashing.V2.Tokenizable as H
import Unison.Hashing.V2.Reference (Reference)
import qualified Unison.Hashing.V2.Reference as R
import Unison.ShortHash (ShortHash)
import qualified Unison.ShortHash as SH
import Unison.ConstructorType (ConstructorType)
import qualified Unison.ConstructorType as CT
data Referent = Ref Reference | Con Reference ConstructorId
deriving (Show, Ord, Eq)
-- | Specifies a term.
--
-- Either a term 'Reference', a data constructor, or an effect constructor.
--
-- Slightly odd naming. This is the "referent of term name in the codebase",
-- rather than the target of a Reference.
type Referent = Referent' Reference
type ConstructorId = Int
pattern Ref :: Reference -> Referent
pattern Ref r = Ref' r
pattern Con :: Reference -> ConstructorId -> ConstructorType -> Referent
pattern Con r i t = Con' (ConstructorReference r i) t
{-# COMPLETE Ref, Con #-}
-- | Cannot be a builtin.
type Id = Referent' R.Id
-- todo: move these to ShortHash module
toShortHash :: Referent -> ShortHash
toShortHash = \case
Ref r -> R.toShortHash r
Con r i _ -> patternShortHash r i
toShortHashId :: Id -> ShortHash
toShortHashId = toShortHash . fromId
-- also used by HashQualified.fromPattern
patternShortHash :: Reference -> ConstructorId -> ShortHash
patternShortHash r i = (R.toShortHash r) { SH.cid = Just . Text.pack $ show i }
showShort :: Int -> Referent -> Text
showShort numHashChars = SH.toText . SH.take numHashChars . toShortHash
toText :: Referent -> Text
toText = \case
Ref r -> R.toText r
Con r cid ct -> R.toText r <> "#" <> ctorTypeText ct <> Text.pack (show cid)
ctorTypeText :: CT.ConstructorType -> Text
ctorTypeText CT.Effect = EffectCtor
ctorTypeText CT.Data = DataCtor
pattern EffectCtor = "a"
pattern DataCtor = "d"
toString :: Referent -> String
toString = Text.unpack . toText
isConstructor :: Referent -> Bool
isConstructor Con{} = True
isConstructor _ = False
toTermReference :: Referent -> Maybe Reference
toTermReference = \case
Ref r -> Just r
_ -> Nothing
toReference :: Referent -> Reference
toReference = toReference'
fromId :: Id -> Referent
fromId = fmap R.DerivedId
toTypeReference :: Referent -> Maybe Reference
toTypeReference = \case
Con r _i _t -> Just r
_ -> Nothing
isPrefixOf :: ShortHash -> Referent -> Bool
isPrefixOf sh r = SH.isPrefixOf sh (toShortHash r)
unsafeFromText :: Text -> Referent
unsafeFromText = fromMaybe (error "invalid referent") . fromText
-- #abc[.xy][#<T>cid]
fromText :: Text -> Maybe Referent
fromText t = either (const Nothing) Just $
-- if the string has just one hash at the start, it's just a reference
if Text.length refPart == 1 then
Ref <$> R.fromText t
else if Text.all Char.isDigit cidPart then do
r <- R.fromText (Text.dropEnd 1 refPart)
ctorType <- ctorType
let maybeCid = readMaybe (Text.unpack cidPart)
case maybeCid of
Nothing -> Left ("invalid constructor id: " <> Text.unpack cidPart)
Just cid -> Right $ Con r cid ctorType
else
Left ("invalid constructor id: " <> Text.unpack cidPart)
where
ctorType = case Text.take 1 cidPart' of
EffectCtor -> Right CT.Effect
DataCtor -> Right CT.Data
_otherwise ->
Left ("invalid constructor type (expected '"
<> EffectCtor <> "' or '" <> DataCtor <> "'): " <> Text.unpack cidPart')
refPart = Text.dropWhileEnd (/= '#') t
cidPart' = Text.takeWhileEnd (/= '#') t
cidPart = Text.drop 1 cidPart'
fold :: (r -> a) -> (r -> ConstructorId -> ConstructorType -> a) -> Referent' r -> a
fold fr fc = \case
Ref' r -> fr r
Con' (ConstructorReference r i) ct -> fc r i ct
instance Tokenizable Referent where
tokens (Ref r) = [H.Tag 0] ++ H.tokens r
tokens (Con r i) = [H.Tag 2] ++ H.tokens r ++ H.tokens i

243
parser-typechecker/src/Unison/Hashing/V2/Term.hs
View File

@ -2,44 +2,46 @@
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE ViewPatterns #-}
module Unison.Hashing.V2.Term (
Term,
F(..),
MatchCase(..),
hashComponents,
hashClosedTerm,
) where
module Unison.Hashing.V2.Term
( Term,
F (..),
MatchCase (..),
hashClosedTerm,
hashComponents,
hashComponentsWithoutTypes,
)
where
import Unison.Prelude
import Prelude hiding (and,or)
import qualified Data.Text as Text
import qualified Data.Sequence as Sequence
import qualified Data.Text as Text
import qualified Unison.ABT as ABT
import qualified Unison.Blank as B
import Unison.DataDeclaration.ConstructorId (ConstructorId)
import qualified Unison.Hash as Hash
import Unison.Hashable (Hashable1, accumulateToken)
import qualified Unison.Hashable as Hashable
import Unison.Hashing.V2.Pattern (Pattern)
import qualified Unison.Hashing.V2.Pattern as Pattern
import Unison.Hashing.V2.Reference (Reference)
import Unison.Hashing.V2.Tokenizable (Hashable1, accumulateToken)
import qualified Unison.Hashing.V2.Tokenizable as Hashable
import qualified Unison.Hashing.V2.ABT as ABT
import Unison.Hashing.V2.Pattern (Pattern)
import Unison.Hashing.V2.Reference (Reference)
import qualified Unison.Hashing.V2.Reference as Reference
import qualified Unison.Hashing.V2.Reference.Util as ReferenceUtil
import Unison.Hashing.V2.Referent (Referent)
import Unison.Hashing.V2.Type (Type)
import Unison.Var (Var)
-- This gets reexported; should maybe live somewhere other than Pattern, though.
type ConstructorId = Pattern.ConstructorId
import Unison.Hashing.V2.Referent (Referent)
import Unison.Hashing.V2.Type (Type)
import Unison.Prelude
import Unison.Var (Var)
import Prelude hiding (and, or)
import qualified Data.Zip as Zip
data MatchCase loc a = MatchCase (Pattern loc) (Maybe a) a
deriving (Show,Eq,Foldable,Functor,Generic,Generic1,Traversable)
deriving (Show, Eq, Foldable, Functor, Generic, Generic1, Traversable)
-- | Base functor for terms in the Unison language
-- We need `typeVar` because the term and type variables may differ.
@ -52,9 +54,9 @@ data F typeVar typeAnn patternAnn a
| Char Char
| Blank (B.Blank typeAnn)
| Ref Reference
-- First argument identifies the data type,
-- second argument identifies the constructor
| Constructor Reference ConstructorId
| -- First argument identifies the data type,
-- second argument identifies the constructor
Constructor Reference ConstructorId
| Request Reference ConstructorId
| Handle a a
| App a a
@ -64,26 +66,26 @@ data F typeVar typeAnn patternAnn a
| And a a
| Or a a
| Lam a
-- Note: let rec blocks have an outer ABT.Cycle which introduces as many
-- variables as there are bindings
| LetRec IsTop [a] a
-- Note: first parameter is the binding, second is the expression which may refer
-- to this let bound variable. Constructed as `Let b (abs v e)`
| Let IsTop a a
-- Pattern matching / eliminating data types, example:
-- case x of
-- Just n -> rhs1
-- Nothing -> rhs2
--
-- translates to
--
-- Match x
-- [ (Constructor 0 [Var], ABT.abs n rhs1)
-- , (Constructor 1 [], rhs2) ]
| Match a [MatchCase patternAnn a]
| -- Note: let rec blocks have an outer ABT.Cycle which introduces as many
-- variables as there are bindings
LetRec IsTop [a] a
| -- Note: first parameter is the binding, second is the expression which may refer
-- to this let bound variable. Constructed as `Let b (abs v e)`
Let IsTop a a
| -- Pattern matching / eliminating data types, example:
-- case x of
-- Just n -> rhs1
-- Nothing -> rhs2
--
-- translates to
--
-- Match x
-- [ (Constructor 0 [Var], ABT.abs n rhs1)
-- , (Constructor 1 [], rhs2) ]
Match a [MatchCase patternAnn a]
| TermLink Referent
| TypeLink Reference
deriving (Foldable,Functor,Generic,Generic1,Traversable)
deriving (Foldable, Functor, Generic, Generic1, Traversable)
type IsTop = Bool
@ -101,79 +103,110 @@ ref a r = ABT.tm' a (Ref r)
refId :: Ord v => a -> Reference.Id -> Term2 vt at ap v a
refId a = ref a . Reference.DerivedId
hashComponents
:: Var v => Map v (Term v a) -> Map v (Reference.Id, Term v a)
hashComponents = ReferenceUtil.hashComponents $ refId ()
hashComponents ::
forall v a.
Var v => Map v (Term v a, Type v a) -> Map v (Reference.Id, Term v a, Type v a)
hashComponents terms =
Zip.zipWith keepType terms (ReferenceUtil.hashComponents (refId ()) terms')
where
terms' :: Map v (Term v a)
terms' = uncurry incorporateType <$> terms
keepType :: ((Term v a, Type v a) -> (Reference.Id, Term v a) -> (Reference.Id, Term v a, Type v a))
keepType (_oldTrm, typ) (refId, trm) = (refId, trm, typ)
incorporateType :: Term v a -> Type v a -> Term v a
incorporateType a@(ABT.out -> ABT.Tm (Ann e _tp)) typ = ABT.tm' (ABT.annotation a) (Ann e typ)
incorporateType e typ = ABT.tm' (ABT.annotation e) (Ann e typ)
-- keep these until we decide if we want to add the appropriate smart constructors back into this module
-- incorporateType (Term.Ann' e _) typ = Term.ann () e typ
-- incorporateType e typ = Term.ann () e typ
-- Need to insert an "Ann" node inside the 'Tm' ABT wrapper
-- iff there isn't already a top-level annotation.
-- What if there's a top-level Annotation but it doesn't match
-- the type that was provided?
hashComponentsWithoutTypes :: Var v => Map v (Term v a) -> Map v (Reference.Id, Term v a)
hashComponentsWithoutTypes = ReferenceUtil.hashComponents $ refId ()
hashClosedTerm :: Var v => Term v a -> Reference.Id
hashClosedTerm tm = Reference.Id (ABT.hash tm) 0 1
hashClosedTerm tm = Reference.Id (ABT.hash tm) 0
instance Var v => Hashable1 (F v a p) where
hash1 hashCycle hash e
= let (tag, hashed, varint) =
(Hashable.Tag, Hashable.Hashed, Hashable.Nat . fromIntegral)
in
case e of
-- So long as `Reference.Derived` ctors are created using the same
-- hashing function as is used here, this case ensures that references
-- are 'transparent' wrt hash and hashing is unaffected by whether
-- expressions are linked. So for example `x = 1 + 1` and `y = x` hash
-- the same.
Ref (Reference.Derived h 0 1) -> Hashable.fromBytes (Hash.toByteString h)
Ref (Reference.Derived h i n) -> Hashable.accumulate
[ tag 1
, hashed $ Hashable.fromBytes (Hash.toByteString h)
, Hashable.Nat i
, Hashable.Nat n
]
hash1 :: forall h x. (Ord h, Hashable.Accumulate h) => ([x] -> ([h], x -> h)) -> (x -> h) -> (F v a p) x -> h
hash1 hashCycle hash e =
let varint :: Integral i => i -> Hashable.Token h
varint = Hashable.Nat . fromIntegral
tag = Hashable.Tag
hashed = Hashable.Hashed
in case e of
-- So long as `Reference.Derived` ctors are created using the same
-- hashing function as is used here, this case ensures that references
-- are 'transparent' wrt hash and hashing is unaffected by whether
-- expressions are linked. So for example `x = 1 + 1` and `y = x` hash
-- the same.
Ref (Reference.Derived h 0) -> Hashable.fromBytes (Hash.toByteString h)
Ref (Reference.Derived h i) ->
Hashable.accumulate
[ tag 1,
hashed $ Hashable.fromBytes (Hash.toByteString h),
Hashable.Nat i
]
-- Note: start each layer with leading `1` byte, to avoid collisions
-- with types, which start each layer with leading `0`.
-- See `Hashable1 Type.F`
_ ->
Hashable.accumulate
$ tag 1
: case e of
Nat i -> [tag 64, accumulateToken i]
Int i -> [tag 65, accumulateToken i]
Float n -> [tag 66, Hashable.Double n]
Boolean b -> [tag 67, accumulateToken b]
Text t -> [tag 68, accumulateToken t]
Char c -> [tag 69, accumulateToken c]
Blank b -> tag 1 : case b of
Hashable.accumulate $
tag 1 :
case e of
Nat i -> [tag 64, accumulateToken i]
Int i -> [tag 65, accumulateToken i]
Float n -> [tag 66, Hashable.Double n]
Boolean b -> [tag 67, accumulateToken b]
Text t -> [tag 68, accumulateToken t]
Char c -> [tag 69, accumulateToken c]
Blank b ->
tag 1 : case b of
B.Blank -> [tag 0]
B.Recorded (B.Placeholder _ s) ->
[tag 1, Hashable.Text (Text.pack s)]
B.Recorded (B.Resolve _ s) ->
[tag 2, Hashable.Text (Text.pack s)]
Ref (Reference.Builtin name) -> [tag 2, accumulateToken name]
Ref Reference.Derived {} ->
error "handled above, but GHC can't figure this out"
App a a2 -> [tag 3, hashed (hash a), hashed (hash a2)]
Ann a t -> [tag 4, hashed (hash a), hashed (ABT.hash t)]
List as -> tag 5 : varint (Sequence.length as) : map
Ref (Reference.Builtin name) -> [tag 2, accumulateToken name]
Ref Reference.Derived {} ->
error "handled above, but GHC can't figure this out"
App a a2 -> [tag 3, hashed (hash a), hashed (hash a2)]
Ann a t -> [tag 4, hashed (hash a), hashed (ABT.hash t)]
List as ->
tag 5 :
varint (Sequence.length as) :
map
(hashed . hash)
(toList as)
Lam a -> [tag 6, hashed (hash a)]
-- note: we use `hashCycle` to ensure result is independent of
-- let binding order
LetRec _ as a -> case hashCycle as of
(hs, hash) -> tag 7 : hashed (hash a) : map hashed hs
-- here, order is significant, so don't use hashCycle
Let _ b a -> [tag 8, hashed $ hash b, hashed $ hash a]
If b t f ->
[tag 9, hashed $ hash b, hashed $ hash t, hashed $ hash f]
Request r n -> [tag 10, accumulateToken r, varint n]
Constructor r n -> [tag 12, accumulateToken r, varint n]
Match e branches ->
tag 13 : hashed (hash e) : concatMap h branches
where
h (MatchCase pat guard branch) = concat
[ [accumulateToken pat]
, toList (hashed . hash <$> guard)
, [hashed (hash branch)]
]
Handle h b -> [tag 15, hashed $ hash h, hashed $ hash b]
And x y -> [tag 16, hashed $ hash x, hashed $ hash y]
Or x y -> [tag 17, hashed $ hash x, hashed $ hash y]
TermLink r -> [tag 18, accumulateToken r]
TypeLink r -> [tag 19, accumulateToken r]
Lam a -> [tag 6, hashed (hash a)]
-- note: we use `hashCycle` to ensure result is independent of
-- let binding order
LetRec _ as a -> case hashCycle as of
(hs, hash) -> tag 7 : hashed (hash a) : map hashed hs
-- here, order is significant, so don't use hashCycle
Let _ b a -> [tag 8, hashed $ hash b, hashed $ hash a]
If b t f ->
[tag 9, hashed $ hash b, hashed $ hash t, hashed $ hash f]
Request r n -> [tag 10, accumulateToken r, varint n]
Constructor r n -> [tag 12, accumulateToken r, varint n]
Match e branches ->
tag 13 : hashed (hash e) : concatMap h branches
where
h (MatchCase pat guard branch) =
concat
[ [accumulateToken pat],
toList (hashed . hash <$> guard),
[hashed (hash branch)]
]
Handle h b -> [tag 15, hashed $ hash h, hashed $ hash b]
And x y -> [tag 16, hashed $ hash x, hashed $ hash y]
Or x y -> [tag 17, hashed $ hash x, hashed $ hash y]
TermLink r -> [tag 18, accumulateToken r]
TypeLink r -> [tag 19, accumulateToken r]

12
parser-typechecker/src/Unison/Hashing/V2/TermEdit.hs Normal file
View File

@ -0,0 +1,12 @@
module Unison.Hashing.V2.TermEdit (TermEdit (..)) where
import Unison.Hashing.V2.Tokenizable (Tokenizable)
import qualified Unison.Hashing.V2.Tokenizable as H
import Unison.Hashing.V2.Referent (Referent)
data TermEdit = Replace Referent | Deprecate
deriving (Eq, Ord, Show)
instance Tokenizable TermEdit where
tokens (Replace r) = [H.Tag 0] ++ H.tokens r
tokens Deprecate = [H.Tag 1]

176
parser-typechecker/src/Unison/Hashing/V2/Tokenizable.hs Normal file
View File

@ -0,0 +1,176 @@
module Unison.Hashing.V2.Tokenizable
( Tokenizable (..),
Accumulate (..),
Hashable1 (..),
Token (..),
hashTokenizable,
accumulateToken,
)
where
import qualified Crypto.Hash as CH
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import Data.ByteString.Builder (doubleBE, int64BE, toLazyByteString, word64BE)
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as Map
import qualified Data.Set as Set
import U.Util.Hash (Hash)
import qualified U.Util.Hash as Hash
import Unison.Prelude
import Unison.Util.Relation (Relation)
import qualified Unison.Util.Relation as Relation
import Unison.Util.Relation3 (Relation3)
import qualified Unison.Util.Relation3 as Relation3
import Unison.Util.Relation4 (Relation4)
import qualified Unison.Util.Relation4 as Relation4
-- | The version of the current hashing function.
-- This should be incremented every time the hashing function is changed.
--
-- The reasoning is that, if a change to the hashing function changes the hashes for _some_
-- values, it should change it for _all_ values so that we don't have collisions between
-- different hashing function versions. If we don't do this, it's possible for the hashes of
-- simple types (like an Int for example) to keep the same hashes, which would lead to
-- collisions in the `hash` table, since each hash has a different hash version but the same
-- base32 representation.
hashingVersion :: Token h
hashingVersion = Tag 2
data Token h
= Tag !Word8
| Bytes !ByteString
| Int !Int64
| Text !Text
| Double !Double
| Hashed !h
| Nat !Word64
class Accumulate h where
accumulate :: [Token h] -> h
fromBytes :: ByteString -> h
toBytes :: h -> ByteString
accumulateToken :: (Accumulate h, Tokenizable t) => t -> Token h
accumulateToken = Hashed . hashTokenizable
-- | Tokenize then accumulate a type into a Hash.
hashTokenizable :: (Tokenizable t, Accumulate h) => t -> h
hashTokenizable = accumulate . tokens
-- | Tokenizable converts a value into a set of hashing tokens which will later be accumulated
-- into a Hash. Be very careful when adding or altering instances of this typeclass, changing
-- the hash of a value is a major breaking change and requires a complete codebase migration.
--
-- If you simply want to provide a convenience instance for a type which wraps some Hashable
-- type, write an instance of 'Hashable' which calls through to the inner instance instead.
--
-- E.g. If I want to be able to hash a @TaggedBranch@ using its Branch0 hashable instance:
--
-- @@
-- data TaggedBranch = TaggedBranch String Branch
--
-- instance Hashable TaggedBranch where
-- hash (TaggedBranch _ b) = hash b
-- @@
class Tokenizable t where
tokens :: Accumulate h => t -> [Token h]
instance Tokenizable a => Tokenizable [a] where
tokens = map accumulateToken
instance (Tokenizable a, Tokenizable b) => Tokenizable (a, b) where
tokens (a, b) = [accumulateToken a, accumulateToken b]
instance (Tokenizable a) => Tokenizable (Set.Set a) where
tokens = tokens . Set.toList
instance (Tokenizable k, Tokenizable v) => Tokenizable (Map.Map k v) where
tokens = tokens . Map.toList
instance (Tokenizable a, Tokenizable b) => Tokenizable (Relation a b) where
tokens = tokens . Relation.toList
instance (Tokenizable d1, Tokenizable d2, Tokenizable d3) => Tokenizable (Relation3 d1 d2 d3) where
tokens s = [accumulateToken $ Relation3.toNestedList s]
instance (Tokenizable d1, Tokenizable d2, Tokenizable d3, Tokenizable d4) => Tokenizable (Relation4 d1 d2 d3 d4) where
tokens s = [accumulateToken $ Relation4.toNestedList s]
instance Tokenizable () where
tokens _ = []
instance Tokenizable Double where
tokens d = [Double d]
instance Tokenizable Text where
tokens s = [Text s]
instance Tokenizable Char where
tokens c = [Nat $ fromIntegral $ fromEnum c]
instance Tokenizable ByteString where
tokens bs = [Bytes bs]
instance Tokenizable Word64 where
tokens w = [Nat w]
instance Tokenizable Int64 where
tokens w = [Int w]
instance Tokenizable Bool where
tokens b = [Tag . fromIntegral $ fromEnum b]
instance Tokenizable Hash where
tokens h = [Bytes (Hash.toByteString h)]
-- | A class for all types which can accumulate tokens into a hash.
-- If you want to provide an instance for hashing a Unison value, see 'Tokenizable'
-- and 'Hashable' instead.
instance Accumulate Hash where
accumulate = fromBytes . BA.convert . CH.hashFinalize . go CH.hashInit
where
go :: CH.Context CH.SHA3_512 -> [Token Hash] -> CH.Context CH.SHA3_512
go acc tokens = CH.hashUpdates acc (hashingVersion : tokens >>= toBS)
toBS (Tag b) = [B.singleton b]
toBS (Bytes bs) = [encodeLength $ B.length bs, bs]
toBS (Int i) = [BL.toStrict . toLazyByteString . int64BE $ i]
toBS (Nat i) = [BL.toStrict . toLazyByteString . word64BE $ i]
toBS (Double d) = [BL.toStrict . toLazyByteString . doubleBE $ d]
toBS (Text txt) =
let tbytes = encodeUtf8 txt
in [encodeLength (B.length tbytes), tbytes]
toBS (Hashed h) = [Hash.toByteString h]
encodeLength :: Integral n => n -> B.ByteString
encodeLength = BL.toStrict . toLazyByteString . word64BE . fromIntegral
fromBytes = Hash.fromByteString
toBytes = Hash.toByteString
class Hashable1 f where
-- | Produce a hash for an `f a`, given a hashing function for `a`.
-- If there is a notion of order-independence in some aspect of a subterm
-- of `f`, then the first argument (`hashUnordered :: [a] -> ([h], a -> h)`)
-- should be used to impose an order, and then apply that order in further hashing.
-- Otherwise the second argument (`hash :: a -> h`) should be used.
--
-- Example 1: A simple functor with no unordered components. Hashable1 instance
-- just uses `hash`:
--
-- data T a = One a | Two a a deriving Functor
--
-- instance Hashable1 T where
-- hash1 _ hash t = case t of
-- One a -> accumulate [Tag 0, Hashed (hash a)]
-- Two a a2 -> accumulate [Tag 1, Hashed (hash a), Hashed (hash a2)]
--
-- Example 2: A functor with unordered components. For hashing, we need to
-- pick a canonical ordering of the unordered components, so we
-- use `hashUnordered`:
--
-- data U a = U { unordered :: [a], uno :: a, dos :: a } deriving Functor
--
-- instance Hashable1 U where
-- hash1 hashUnordered _ (U unordered uno dos) =
-- let (hs, hash) = hashUnordered unordered
-- in accumulate $ map Hashed hs ++ [Hashed (hash uno), Hashed (hash dos)]
hash1 :: (Ord h, Accumulate h) => ([a] -> ([h], a -> h)) -> (a -> h) -> f a -> h

31
parser-typechecker/src/Unison/Hashing/V2/Type.hs
View File

@ -6,13 +6,11 @@
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ViewPatterns #-}
module Unison.Hashing.V2.Type
(
module Unison.Hashing.V2.Type (
Type,
F(..),
bindExternal,
bindReferences,
dependencies,
-- * find by type index stuff
toReference,
toReferenceMentions,
@ -25,24 +23,22 @@ module Unison.Hashing.V2.Type
listRef,
natRef,
textRef,
)
where
) where
import Unison.Prelude
import qualified Control.Monad.Writer.Strict as Writer
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Unison.ABT as ABT
import Unison.Hashable (Hashable1)
import qualified Unison.Hashable as Hashable
import qualified Unison.Kind as K
import Unison.Hashing.V2.Reference (Reference)
import Unison.Hashing.V2.Tokenizable (Hashable1)
import qualified Unison.Hashing.V2.Tokenizable as Hashable
import qualified Unison.Hashing.V2.ABT as ABT
import Unison.Hashing.V2.Reference (Reference)
import qualified Unison.Hashing.V2.Reference as Reference
import Unison.Var (Var)
import qualified Unison.Names.ResolutionResult as Names
import qualified Unison.Hashing.V2.Kind as K
import qualified Unison.Name as Name
import qualified Unison.Names.ResolutionResult as Names
import Unison.Prelude
import qualified Unison.Util.List as List
import Unison.Var (Var)
-- | Base functor for types in the Unison language
data F a
@ -120,16 +116,11 @@ unforall' :: Type v a -> ([v], Type v a)
unforall' (ForallsNamed' vs t) = (vs, t)
unforall' t = ([], t)
dependencies :: Ord v => Type v a -> Set Reference
dependencies t = Set.fromList . Writer.execWriter $ ABT.visit' f t
where f t@(Ref r) = Writer.tell [r] $> t
f t = pure t
toReference :: (ABT.Var 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 1
toReference t = Reference.Derived (ABT.hash t) 0
toReferenceMentions :: (ABT.Var v, Show v) => Type v a -> Set Reference
toReferenceMentions ty =

12
parser-typechecker/src/Unison/Hashing/V2/TypeEdit.hs Normal file
View File

@ -0,0 +1,12 @@
module Unison.Hashing.V2.TypeEdit (TypeEdit (..)) where
import Unison.Hashing.V2.Tokenizable (Tokenizable)
import qualified Unison.Hashing.V2.Tokenizable as H
import Unison.Hashing.V2.Reference (Reference)
data TypeEdit = Replace Reference | Deprecate
deriving (Eq, Ord, Show)
instance Tokenizable TypeEdit where
tokens (Replace r) = H.Tag 0 : H.tokens r
tokens Deprecate = [H.Tag 1]

23
parser-typechecker/src/Unison/PrettyPrintEnv/Util.hs
View File

@ -3,7 +3,6 @@
module Unison.PrettyPrintEnv.Util (declarationPPE, declarationPPEDecl) where
import qualified Data.Set as Set
import Unison.PrettyPrintEnv (PrettyPrintEnv (..))
import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (suffixifiedPPE, unsuffixifiedPPE))
import Unison.Reference (Reference)
@ -18,20 +17,20 @@ import qualified Unison.Referent as Referent
-- and not
-- foo.bar x = bar x
declarationPPE :: PrettyPrintEnvDecl -> Reference -> PrettyPrintEnv
declarationPPE ppe rd = PrettyPrintEnv tm ty
declarationPPE ppe ref = PrettyPrintEnv tm ty
where
comp = Reference.members (Reference.componentFor rd)
tm r0@(Referent.Ref r) =
if Set.member r comp
then terms (unsuffixifiedPPE ppe) r0
else terms (suffixifiedPPE ppe) r0
rootH = hash ref
hash Reference.Builtin {} = Nothing
hash (Reference.Derived h _) = Just h
tm r0@(Referent.Ref r)
| hash r == rootH = terms (unsuffixifiedPPE ppe) r0
| otherwise = terms (suffixifiedPPE ppe) r0
tm r = terms (suffixifiedPPE ppe) r
ty r =
if Set.member r comp
then types (unsuffixifiedPPE ppe) r
else types (suffixifiedPPE ppe) r
ty r
| hash r == rootH = types (unsuffixifiedPPE ppe) r
| otherwise = types (suffixifiedPPE ppe) r
-- The suffixed names uses the fully-qualified name for `r`
declarationPPEDecl :: PrettyPrintEnvDecl -> Reference -> PrettyPrintEnvDecl
declarationPPEDecl ppe r =
declarationPPEDecl ppe r =
ppe { suffixifiedPPE = declarationPPE ppe r }

16
parser-typechecker/src/Unison/Runtime/ANF.hs
View File

@ -1061,8 +1061,8 @@ anfBlock (Match' scrut cas) = do
, pure . TMatch r
$ MatchDataCover Ty.seqViewRef
(EC.mapFromList
[ (toEnum Ty.seqViewEmpty, ([], em))
, (toEnum Ty.seqViewElem, ([BX,BX], bd))
[ (fromIntegral Ty.seqViewEmpty, ([], em))
, (fromIntegral Ty.seqViewElem, ([BX,BX], bd))
]
)
)
@ -1111,9 +1111,9 @@ anfBlock (Apps' f args) = do
(actx, cas) <- anfArgs args
pure (fctx <> actx, (d, TApp cf cas))
anfBlock (Constructor' (ConstructorReference r t))
= pure (mempty, pure $ TCon r (toEnum t) [])
= pure (mempty, pure $ TCon r (fromIntegral t) [])
anfBlock (Request' (ConstructorReference r t))
= pure (mempty, (Indirect (), TReq r (toEnum t) []))
= pure (mempty, (Indirect (), TReq r (fromIntegral t) []))
anfBlock (Boolean' b)
= pure (mempty, pure $ TCon Ty.booleanRef (if b then 1 else 0) [])
anfBlock (Lit' l@(T _)) =
@ -1175,7 +1175,7 @@ anfInitCase u (MatchCase p guard (ABT.AbsN' vs bd))
| P.Constructor _ (ConstructorReference r t) ps <- p = do
(,) <$> expandBindings ps vs <*> anfBody bd <&> \(us,bd)
-> AccumData r Nothing
. EC.mapSingleton (toEnum t)
. EC.mapSingleton (fromIntegral t)
. (BX<$us,)
. ABTN.TAbss us
$ bd
@ -1193,7 +1193,7 @@ anfInitCase u (MatchCase p guard (ABT.AbsN' vs bd))
jn = Builtin "jumpCont"
in flip AccumRequest Nothing
. Map.singleton r
. EC.mapSingleton (toEnum t)
. EC.mapSingleton (fromIntegral t)
. (BX<$us,)
. ABTN.TAbss us
. TShift r kf
@ -1336,8 +1336,8 @@ anfCases u = getCompose . fmap fold . traverse (anfInitCase u)
anfFunc :: Var v => Term v a -> ANFM v (Ctx v, Directed () (Func v))
anfFunc (Var' v) = pure (mempty, (Indirect (), FVar v))
anfFunc (Ref' r) = pure (mempty, (Indirect (), FComb r))
anfFunc (Constructor' (ConstructorReference r t)) = pure (mempty, (Direct, FCon r $ toEnum t))
anfFunc (Request' (ConstructorReference r t)) = pure (mempty, (Indirect (), FReq r $ toEnum t))
anfFunc (Constructor' (ConstructorReference r t)) = pure (mempty, (Direct, FCon r $ fromIntegral t))
anfFunc (Request' (ConstructorReference r t)) = pure (mempty, (Indirect (), FReq r $ fromIntegral t))
anfFunc tm = do
(fctx, ctm) <- anfBlock tm
(cx, v) <- contextualize ctm

24
parser-typechecker/src/Unison/Runtime/Builtin.hs
View File

@ -187,15 +187,15 @@ fls = TCon Ty.booleanRef 0 []
tru = TCon Ty.booleanRef 1 []
none :: Var v => ANormal v
none = TCon Ty.optionalRef (toEnum Ty.noneId) []
none = TCon Ty.optionalRef (fromIntegral Ty.noneId) []
some, left, right :: Var v => v -> ANormal v
some a = TCon Ty.optionalRef (toEnum Ty.someId) [a]
left x = TCon Ty.eitherRef (toEnum Ty.eitherLeftId) [x]
right x = TCon Ty.eitherRef (toEnum Ty.eitherRightId) [x]
some a = TCon Ty.optionalRef (fromIntegral Ty.someId) [a]
left x = TCon Ty.eitherRef (fromIntegral Ty.eitherLeftId) [x]
right x = TCon Ty.eitherRef (fromIntegral Ty.eitherRightId) [x]
seqViewEmpty :: Var v => ANormal v
seqViewEmpty = TCon Ty.seqViewRef (toEnum Ty.seqViewEmpty) []
seqViewEmpty = TCon Ty.seqViewRef (fromIntegral Ty.seqViewEmpty) []
seqViewElem :: Var v => v -> v -> ANormal v
seqViewElem l r = TCon Ty.seqViewRef (toEnum Ty.seqViewElem) [l,r]
seqViewElem l r = TCon Ty.seqViewRef (fromIntegral Ty.seqViewElem) [l,r]
boolift :: Var v => v -> ANormal v
boolift v
@ -842,10 +842,10 @@ seek'handle instr
(arg1, arg2, arg3, seek, nat, stack1, stack2, stack3, unit, fail, result) = fresh11
no'buf, line'buf, block'buf, sblock'buf :: Enum e => e
no'buf = toEnum Ty.bufferModeNoBufferingId
line'buf = toEnum Ty.bufferModeLineBufferingId
block'buf = toEnum Ty.bufferModeBlockBufferingId
sblock'buf = toEnum Ty.bufferModeSizedBlockBufferingId
no'buf = toEnum $ fromIntegral Ty.bufferModeNoBufferingId
line'buf = toEnum $ fromIntegral Ty.bufferModeLineBufferingId
block'buf = toEnum $ fromIntegral Ty.bufferModeBlockBufferingId
sblock'buf = toEnum $ fromIntegral Ty.bufferModeSizedBlockBufferingId
infixr 0 -->
(-->) :: a -> b -> (a, b)
@ -970,9 +970,9 @@ inMaybeBx arg1 arg2 arg3 mb result cont instr =
. TAbss [arg1, arg2]
. TMatch arg1 . flip (MatchData Ty.optionalRef) Nothing
$ mapFromList
[ (toEnum Ty.noneId, ([], TLetD mb UN (TLit $ I 0)
[ (fromIntegral Ty.noneId, ([], TLetD mb UN (TLit $ I 0)
$ TLetD result UN (TFOp instr [mb, arg2]) cont))
, (toEnum Ty.someId, ([BX], TAbs arg3 . TLetD mb UN (TLit $ I 1) $ TLetD result UN (TFOp instr [mb, arg3, arg2]) cont))
, (fromIntegral Ty.someId, ([BX], TAbs arg3 . TLetD mb UN (TLit $ I 1) $ TLetD result UN (TFOp instr [mb, arg3, arg2]) cont))
]
-- a -> b -> ...

9
parser-typechecker/src/Unison/Runtime/Foreign/Function.hs
View File

@ -301,10 +301,10 @@ instance ( ForeignConvention a
writeForeign ustk bstk a
no'buf, line'buf, block'buf, sblock'buf :: Int
no'buf = Ty.bufferModeNoBufferingId
line'buf = Ty.bufferModeLineBufferingId
block'buf = Ty.bufferModeBlockBufferingId
sblock'buf = Ty.bufferModeSizedBlockBufferingId
no'buf = fromIntegral Ty.bufferModeNoBufferingId
line'buf = fromIntegral Ty.bufferModeLineBufferingId
block'buf = fromIntegral Ty.bufferModeBlockBufferingId
sblock'buf = fromIntegral Ty.bufferModeSizedBlockBufferingId
instance ForeignConvention BufferMode where
readForeign (i:us) bs ustk bstk
@ -383,4 +383,3 @@ instance {-# overlappable #-} BuiltinForeign b => ForeignConvention [b]
foreignCCError :: String -> IO a
foreignCCError nm
= die $ "mismatched foreign calling convention for `" ++ nm ++ "`"

1
parser-typechecker/src/Unison/Runtime/IOSource.hs
View File

@ -283,6 +283,7 @@ constructorNamed ref name =
$ "There's a bug in the Unison runtime. Couldn't find type "
<> show ref
Just decl ->
fromIntegral .
fromMaybe
( error
$ "Unison runtime bug. The type "

3
parser-typechecker/src/Unison/Runtime/Interface.hs
View File

@ -312,7 +312,7 @@ prepareEvaluation ppe tm ctx = do
(rmn, rtms)
| Tm.LetRecNamed' bs mn0 <- tm
, hcs <- fmap (first RF.DerivedId)
. Hashing.hashTermComponents $ Map.fromList bs
. Hashing.hashTermComponentsWithoutTypes $ Map.fromList bs
, mn <- Tm.substs (Map.toList $ Tm.ref () . fst <$> hcs) mn0
, rmn <- RF.DerivedId $ Hashing.hashClosedTerm mn
= (rmn , (rmn, mn) : Map.elems hcs)
@ -607,6 +607,7 @@ buildSCache cs crsrc trsrc ftm fty intsrc rtmsrc rtysrc sndbx
typeRefs = foldMap Set.singleton trs
restrictTmW m = restrictKeys m combKeys
restrictTmR :: Map Reference a -> Map Reference a
restrictTmR m = Map.restrictKeys m termRefs
restrictTyW m = restrictKeys m typeKeys

16
parser-typechecker/src/Unison/Runtime/Machine.hs
View File

@ -1650,15 +1650,23 @@ expandSandbox
:: Map Reference (Set Reference)
-> [(Reference, SuperGroup Symbol)]
-> [(Reference, Set Reference)]
expandSandbox sand = mapMaybe h
expandSandbox sand0 groups = fixed mempty
where
f False r = fromMaybe mempty $ M.lookup r sand
f True _ = mempty
f sand False r = fromMaybe mempty $ M.lookup r sand
f _ True _ = mempty
h (r, groupLinks f -> s)
h sand (r, groupLinks (f sand) -> s)
| S.null s = Nothing
| otherwise = Just (r, s)
fixed extra
| extra == extra' = new
| otherwise = fixed extra'
where
new = mapMaybe (h $ extra <> sand0) groups
extra' = M.fromList new
cacheAdd
:: [(Reference, SuperGroup Symbol)]
-> CCache

8
parser-typechecker/src/Unison/Runtime/Pattern.hs
View File

@ -32,7 +32,7 @@ import Unison.Pattern
import qualified Unison.Pattern as P
import Unison.Reference (Reference(..))
import Unison.Runtime.ANF (internalBug)
import Unison.Term hiding (Term)
import Unison.Term hiding (Term, matchPattern)
import qualified Unison.Term as Tm
import Unison.Var (Var, typed, freshIn, freshenId, Type(Pattern))
@ -161,7 +161,7 @@ decomposePattern (Just rf0) t _ (P.Boolean _ b)
, t == if b then 1 else 0
= [[]]
decomposePattern (Just rf0) t nfields p@(P.Constructor _ (ConstructorReference rf u) ps)
| t == u
| t == fromIntegral u
, rf0 == rf
= if length ps == nfields
then [ps]
@ -170,7 +170,7 @@ decomposePattern (Just rf0) t nfields p@(P.Constructor _ (ConstructorReference r
err = "decomposePattern: wrong number of constructor fields: "
++ show (nfields, p)
decomposePattern (Just rf0) t nfields p@(P.EffectBind _ (ConstructorReference rf u) ps pk)
| t == u
| t == fromIntegral u
, rf0 == rf
= if length ps + 1 == nfields
then [ps ++ [pk]]
@ -664,7 +664,7 @@ buildCase
buildCase spec r eff cons ctx0 (t, vts, m)
= MatchCase pat Nothing . absChain' vs $ compile spec ctx m
where
pat = buildPattern eff (ConstructorReference r t) vs $ cons !! t
pat = buildPattern eff (ConstructorReference r (fromIntegral t)) vs $ cons !! t
vs = ((),) . fst <$> vts
ctx = Map.fromList vts <> ctx0

5
parser-typechecker/src/Unison/Runtime/Serialize.hs
View File

@ -205,18 +205,17 @@ putReference r = case r of
Builtin name -> do
putWord8 0
putText name
Derived hash i n -> do
Derived hash i -> do
putWord8 1
putHash hash
putLength i
putLength n
getReference :: MonadGet m => m Reference
getReference = do
tag <- getWord8
case tag of
0 -> Builtin <$> getText
1 -> DerivedId <$> (Id <$> getHash <*> getLength <*> getLength)
1 -> DerivedId <$> (Id <$> getHash <*> getLength)
_ -> unknownTag "Reference" tag
putConstructorReference :: MonadPut m => ConstructorReference -> m ()

9
parser-typechecker/src/Unison/Runtime/SparseVector.hs
View File

@ -10,6 +10,7 @@ import Data.Bits ((.|.), (.&.))
import qualified Data.Bits as B
import qualified GHC.Exts as Exts
import qualified Data.Vector.Unboxed as UV
import Control.Monad.ST (ST)
-- Denotes a `Nat -> Maybe a`.
-- Representation is a `Vector a` along with a bitset
@ -28,7 +29,8 @@ map f v = v { elements = UV.map f (elements v) }
-- Denotationally, a mask is a `Nat -> Bool`, so this implementation
-- means: `mask ok v n = if ok n then v n else Nothing`
mask :: (UV.Unbox a, B.FiniteBits bits)
mask :: forall a bits.
(UV.Unbox a, B.FiniteBits bits)
=> bits -> SparseVector bits a -> SparseVector bits a
mask bits a =
if indices' == bits then a -- check if mask is a superset
@ -38,6 +40,7 @@ mask bits a =
where
indices' = indices a .&. bits
eas = elements a
go :: MUV.STVector s a -> bits -> bits -> Int -> Int -> ST s (MUV.STVector s a)
go !out !indAs !indBs !i !k =
if indAs == B.zeroBits || indBs == B.zeroBits then pure out
else let
@ -96,7 +99,8 @@ choose bits t f
merge (mask bits t) (mask (B.complement bits) f)
-- Denotationally: `merge a b n = a n <|> b n`
merge :: (B.FiniteBits bits, UV.Unbox a)
merge :: forall a bits.
(B.FiniteBits bits, UV.Unbox a)
=> SparseVector bits a
-> SparseVector bits a
-> SparseVector bits a
@ -107,6 +111,7 @@ merge a b = SparseVector indices' tricky
vec <- MUV.new (B.popCount indices')
go vec (indices a) (indices b) 0 0 0
(!eas, !ebs) = (elements a, elements b)
go :: MUV.STVector s a -> bits -> bits -> Int -> Int -> Int -> ST s (MUV.STVector s a)
go !out !indAs !indBs !i !j !k =
if indAs == B.zeroBits || indBs == B.zeroBits then pure out
else let

25
parser-typechecker/src/Unison/Server/Backend.hs
View File

@ -37,7 +37,7 @@ import qualified Unison.Codebase as Codebase
import Unison.Codebase.Branch (Branch, Branch0)
import qualified Unison.Codebase.Branch as Branch
import qualified Unison.Codebase.Branch.Names as Branch
import qualified Unison.Codebase.Causal (RawHash(RawHash))
import qualified Unison.Codebase.Causal.Type (RawHash(RawHash))
import Unison.Codebase.Editor.DisplayObject
import qualified Unison.Codebase.Metadata as Metadata
import Unison.Codebase.Path (Path)
@ -921,19 +921,25 @@ definitionsBySuffixes ::
m (DefinitionResults Symbol)
definitionsBySuffixes namesScope branch codebase includeCycles query = do
QueryResult misses results <- hqNameQuery namesScope branch codebase query
-- todo: remember to replace this with getting components directly,
-- and maybe even remove getComponentLength from Codebase interface altogether
terms <- do
let termRefsWithoutCycles = searchResultsToTermRefs results
let termRefs =
case includeCycles of
IncludeCycles -> foldMap (Reference.members . Reference.componentFor) termRefsWithoutCycles
DontIncludeCycles -> termRefsWithoutCycles
termRefs <- case includeCycles of
IncludeCycles ->
Monoid.foldMapM
(Codebase.componentReferencesForReference codebase)
termRefsWithoutCycles
DontIncludeCycles -> pure termRefsWithoutCycles
Map.foldMapM (\ref -> (ref,) <$> displayTerm ref) termRefs
types <- do
let typeRefsWithoutCycles = searchResultsToTypeRefs results
let typeRefs =
case includeCycles of
IncludeCycles -> foldMap (Reference.members . Reference.componentFor) typeRefsWithoutCycles
DontIncludeCycles -> typeRefsWithoutCycles
typeRefs <- case includeCycles of
IncludeCycles ->
Monoid.foldMapM
(Codebase.componentReferencesForReference codebase)
typeRefsWithoutCycles
DontIncludeCycles -> pure typeRefsWithoutCycles
Map.foldMapM (\ref -> (ref,) <$> displayType ref) typeRefs
pure (DefinitionResults terms types misses)
where
@ -1042,4 +1048,3 @@ loadTypeDisplayObject c = \case
Reference.DerivedId id ->
maybe (MissingObject $ Reference.idToShortHash id) UserObject
<$> Codebase.getTypeDeclaration c id

26
parser-typechecker/src/Unison/Server/Doc/AsHtml.hs
View File

@ -10,6 +10,7 @@ import Control.Monad.Trans.State (evalStateT)
import Control.Monad.Writer.Class (MonadWriter)
import qualified Control.Monad.Writer.Class as Writer
import Control.Monad.Writer.Lazy (runWriterT)
import qualified Data.Char as Char
import Data.Foldable
import Data.Map (Map)
import qualified Data.Map as Map
@ -348,8 +349,13 @@ toHtml docNamesByRef document =
in ol_ [start_ $ Text.pack $ show startNum]
<$> renderSequence itemToHtml (mergeWords " " items)
Section title docs -> do
let sectionId =
Text.toLower $
Text.filter (\c -> c == '-' || Char.isAlphaNum c) $
toText "-" title
titleEl <-
h sectionLevel <$> currentSectionLevelToHtml title
h sectionLevel sectionId <$> currentSectionLevelToHtml title
docs' <- renderSequence (sectionContentToHtml (toHtml_ (sectionLevel + 1))) docs
@ -454,16 +460,16 @@ toHtml docNamesByRef document =
-- | Unison Doc allows endlessly deep section nesting with
-- titles, but HTML only supports to h1-h6, so we clamp
-- the sectionLevel when converting
h :: Nat -> (Html () -> Html ())
h n =
h :: Nat -> Text -> (Html () -> Html ())
h n anchorId =
case n of
1 -> h1_
2 -> h2_
3 -> h3_
4 -> h4_
5 -> h5_
6 -> h6_
_ -> h6_
1 -> h1_ [id_ anchorId]
2 -> h2_ [id_ anchorId]
3 -> h3_ [id_ anchorId]
4 -> h4_ [id_ anchorId]
5 -> h5_ [id_ anchorId]
6 -> h6_ [id_ anchorId]
_ -> h6_ [id_ anchorId]
badge :: Html () -> Html ()
badge =

12
parser-typechecker/src/Unison/TermPrinter.hs
View File

@ -258,7 +258,7 @@ pretty0
List' xs -> PP.group $
(fmt S.DelimiterChar $ l "[") <> optSpace
<> intercalateMap ((fmt S.DelimiterChar $ l ",") <> PP.softbreak <> optSpace <> optSpace)
(pretty0 n (ac 0 Normal im doc))
(PP.indentNAfterNewline 2 . pretty0 n (ac 0 Normal im doc))
xs
<> optSpace <> (fmt S.DelimiterChar $ l "]")
where optSpace = PP.orElse "" " "
@ -327,6 +327,7 @@ pretty0
t -> l "error: " <> l (show t)
where
goNormal prec tm = pretty0 n (ac prec Normal im doc) tm
specialCases term _go | Just p <- prettyDoc2 n a term = p
specialCases term go = case (term, binaryOpsPred) of
(DD.Doc, _) | doc == MaybeDoc ->
@ -345,7 +346,10 @@ pretty0
(TupleTerm' xs, _) ->
let tupleLink p = fmt (S.TypeReference DD.unitRef) p
in PP.group (tupleLink "(" <> commaList xs <> tupleLink ")")
(App' f@(Builtin' "Any.Any") arg, _) ->
paren (p >= 10) $ goNormal 9 f `PP.hang` goNormal 10 arg
(Apps' f@(Constructor' _) args, _) ->
paren (p >= 10) $ goNormal 9 f `PP.hang` PP.spacedMap (goNormal 10) args
(Bytes' bs, _) ->
fmt S.BytesLiteral "0xs" <> (PP.shown $ Bytes.fromWord8s (map fromIntegral bs))
BinaryAppsPred' apps lastArg -> paren (p >= 3) $
@ -1579,8 +1583,8 @@ toDocEval _ _ = Nothing
--
-- See https://github.com/unisonweb/unison/issues/2238
_oldDocEval, _oldDocEvalInline :: Reference
_oldDocEval = Reference.unsafeFromText "#0ua7gqa7kqnj80ulhmtcqsfgalmh4g9kg198dt2uen0s0jeebbo4ljnj4133cn1kbm38i2q3joivodtfei3jfln5scof0r0381k8dm0"
_oldDocEvalInline = Reference.unsafeFromText "#maleg6fmu3j0k0vgm99lgrsnhio3ba750hcainuv5jdi9scdsg43hpicmf6lovsa0mnaija7bjebnr5nas3qsj4r087hur1jh0rsfso"
_oldDocEval = Reference.unsafeFromText "#m2bmkdos2669tt46sh2gf6cmb4td5le8lcqnmsl9nfaqiv7s816q8bdtjdbt98tkk11ejlesepe7p7u8p0asu9758gdseffh0t78m2o"
_oldDocEvalInline = Reference.unsafeFromText "#7pjlvdu42gmfvfntja265dmi08afk08l54kpsuu55l9hq4l32fco2jlrm8mf2jbn61esfsi972b6e66d9on4i5bkmfchjdare1v5npg"
toDocEvalInline :: Ord v => PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocEvalInline ppe (App' (Ref' r) (Delay' tm))

91
parser-typechecker/src/Unison/Typechecker/Context.hs
View File

@ -71,6 +71,7 @@ import Unison.DataDeclaration ( DataDeclaration
, EffectDeclaration
)
import qualified Unison.DataDeclaration as DD
import Unison.DataDeclaration.ConstructorId (ConstructorId)
import Unison.Pattern ( Pattern )
import qualified Unison.Pattern as Pattern
import Unison.Reference ( Reference )
@ -260,7 +261,6 @@ data PathElement v loc
type ExpectedArgCount = Int
type ActualArgCount = Int
type ConstructorId = Int
data SuggestionMatch = Exact | WrongType | WrongName
deriving (Ord, Eq, Show)
@ -728,7 +728,7 @@ getConstructorType' :: Var v
-> M v loc (Type v loc)
getConstructorType' kind get (ConstructorReference r cid) = do
decl <- get r
case drop cid (DD.constructors decl) of
case drop (fromIntegral cid) (DD.constructors decl) of
[] -> compilerCrash $ UnknownConstructor kind (ConstructorReference r cid) decl
(_v, typ) : _ -> pure $ ABT.vmap TypeVar.Universal typ
@ -1513,13 +1513,90 @@ ungeneralize :: (Var v, Ord loc) => Type v loc -> M v loc (Type v loc)
ungeneralize t = snd <$> ungeneralize' t
ungeneralize' :: (Var v, Ord loc) => Type v loc -> M v loc ([v], Type v loc)
ungeneralize' (Type.Forall' t) = do
v <- ABT.freshen t freshenTypeVar
appendContext [existential v]
t <- pure $ ABT.bindInheritAnnotation t (existential' () B.Blank v)
first (v:) <$> ungeneralize' t
ungeneralize' (Type.ForallNamed' v t) = do
(vs, t) <- tweakEffects v t
first (vs++) <$> ungeneralize' t
ungeneralize' t = pure ([], t)
-- Tries to massage types like:
--
-- (a ->{e} b ->{e} c) ->{e} d
--
-- by rewriting them into:
--
-- (a ->{e1} b ->{e2} c) ->{e1,e2} d
--
-- The strategy is to find all negative occurrences of `e` and
-- introduce a new variable for each, and then replace any
-- non-negative occurrences with the row of all negative
-- variables. The reason this is valid is that `e` can be
-- instantiated with the entire row, and then all the negative
-- rows can be pared down to the single variable via subtyping.
--
-- This is meant to occur when a polymorphic type is
-- de-generalized, and replaces simple freshening of the
-- polymorphic variable.
tweakEffects
:: Var v
=> Ord loc
=> TypeVar v loc
-> Type v loc
-> M v loc ([v], Type v loc)
tweakEffects v0 t0
| isEffectVar v0 t0 = rewrite (Just False) t0 >>= \case
([], ty) ->
freshenTypeVar v0 >>= \out -> finish [out] ty
(vs, ty) -> finish vs ty
| otherwise
= freshenTypeVar v0 >>= \out -> finish [out] t0
where
negative = fromMaybe False
typ [v] = existential' () B.Blank v
typ vs = Type.effects () $ existential' () B.Blank <$> vs
finish vs ty = do
appendContext (existential <$> vs)
pure (vs, ABT.substInheritAnnotation v0 (typ vs) ty)
rewrite p ty
| Type.ForallNamed' v t <- ty
, v0 /= v
= second (Type.forall a v) <$> rewrite p t
| Type.Arrow' i o <- ty = do
(vis, i) <- rewrite (not <$> p) i
(vos, o) <- rewrite p o
pure (vis ++ vos, Type.arrow a i o)
| Type.Effect1' e t <- ty = do
(ves, e) <- rewrite p e
(vts, t) <- rewrite p t
pure (ves ++ vts, Type.effect1 a e t)
| Type.Effects' es <- ty = do
ess <- traverse (rewrite p) es
let es = snd <$> ess ; ves = fst =<< ess
pure (ves, Type.effects a es)
| Type.Var' v <- ty
, v0 == v && negative p = do
u <- freshenTypeVar v0
pure ([u], existential' (loc ty) B.Blank u)
| Type.App' f x <- ty = do
(vfs, f) <- rewrite p f
(vxs, x) <- rewrite Nothing x
pure (vfs ++ vxs, Type.app (loc ty) f x)
| otherwise = pure ([], ty)
where a = loc ty
isEffectVar :: Var v => TypeVar v loc -> Type v loc -> Bool
isEffectVar u (Type.ForallNamed' v t)
| u == v = False
| otherwise = isEffectVar u t
isEffectVar u (Type.Arrow'' i es o) =
any p es || isEffectVar u i || isEffectVar u o
where
p (Type.Var' v) = v == u
p _ = False
isEffectVar _ _ = False
skolemize
:: Var v
=> Ord loc

12
parser-typechecker/src/Unison/Typechecker/TypeLookup.hs
View File

@ -3,15 +3,15 @@ module Unison.Typechecker.TypeLookup where
import Unison.Prelude
import Unison.ConstructorReference (ConstructorReference, GConstructorReference(..))
import qualified Data.Map as Map
import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..))
import qualified Unison.ConstructorType as CT
import Unison.DataDeclaration (DataDeclaration, EffectDeclaration)
import qualified Unison.DataDeclaration as DD
import Unison.Reference (Reference)
import Unison.Referent (Referent)
import Unison.Type (Type)
import qualified Data.Map as Map
import qualified Unison.ConstructorType as CT
import qualified Unison.DataDeclaration as DD
import Unison.DataDeclaration (EffectDeclaration, DataDeclaration)
import qualified Unison.Referent as Referent
import Unison.Type (Type)
-- Used for typechecking.
data TypeLookup v a =

5
parser-typechecker/src/Unison/UnisonFile.hs
View File

@ -115,11 +115,10 @@ typecheckedUnisonFile datas effects tlcs watches =
watchKinds = Map.fromList $
[(v,Nothing) | (v,_e,_t) <- join tlcs]
++ [(v, Just wk) | (wk, wkTerms) <- watches, (v, _e, _t) <- wkTerms ]
-- good spot incorporate type of term into its hash, if not already present as an annotation (#2276)
hcs = Hashing.hashTermComponents $ Map.fromList $ (\(v, e, _t) -> (v, e)) <$> allTerms
hcs = Hashing.hashTermComponents $ Map.fromList $ (\(v, e, t) -> (v, (e, t))) <$> allTerms
in Map.fromList
[ (v, (r, wk, e, t))
| (v, (r, e)) <- Map.toList hcs
| (v, (r, e, _typ)) <- Map.toList hcs
, Just t <- [Map.lookup v types]
, wk <- [Map.findWithDefault (error $ show v ++ " missing from watchKinds") v watchKinds]]

2
parser-typechecker/src/Unison/UnisonFile/Names.hs
View File

@ -98,7 +98,7 @@ environmentFor names dataDecls0 effectDecls0 = do
traverse (DD.withEffectDeclM (DD.Names.bindNames locallyBoundTypes names)) effectDecls0
let allDecls0 :: Map v (DataDeclaration v a)
allDecls0 = Map.union dataDecls (toDataDecl <$> effectDecls)
hashDecls' :: [(v, Reference.Id, DataDeclaration v a)] <- Hashing.hashDecls allDecls0
hashDecls' :: [(v, Reference.Id, DataDeclaration v a)] <- Hashing.hashDataDecls allDecls0
-- then we have to pick out the dataDecls from the effectDecls
let
allDecls = Map.fromList [ (v, (r, de)) | (v, r, de) <- hashDecls' ]

9
parser-typechecker/src/Unison/Util/Star3.hs
View File

@ -7,7 +7,6 @@ import Unison.Prelude
import Unison.Util.Relation (Relation)
import qualified Data.Set as Set
import qualified Unison.Hashable as H
import qualified Unison.Util.Relation as R
import qualified Data.Map as Map
@ -236,11 +235,3 @@ instance (Ord fact, Ord d1, Ord d2, Ord d3) => Monoid (Star3 fact d1 d2 d3) wher
d1' = d1 s1 <> d1 s2
d2' = d2 s1 <> d2 s2
d3' = d3 s1 <> d3 s2
instance (H.Hashable fact, H.Hashable d1, H.Hashable d2, H.Hashable d3)
=> H.Hashable (Star3 fact d1 d2 d3) where
tokens s =
[ H.accumulateToken (fact s)
, H.accumulateToken (d1 s)
, H.accumulateToken (d2 s)
, H.accumulateToken (d3 s) ]

1
parser-typechecker/tests/Suite.hs
View File

@ -37,7 +37,6 @@ import qualified Unison.Test.Var as Var
import qualified Unison.Test.ANF as ANF
import qualified Unison.Test.MCode as MCode
import qualified Unison.Test.CodebaseInit as CodebaseInit
-- import qualified Unison.Test.BaseUpgradePushPullTest as BaseUpgradePushPullTest
test :: Test ()
test = tests

4
parser-typechecker/tests/Unison/Test/ANF.hs
View File

@ -149,7 +149,7 @@ denormalizeMatch b
ipat r _ i
| r == Ty.natRef = P.Nat () $ fromIntegral i
| otherwise = P.Int () $ fromIntegral i
dpat r n t = P.Constructor () (ConstructorReference r (fromEnum t)) (replicate n $ P.Var ())
dpat r n t = P.Constructor () (ConstructorReference r (fromIntegral (fromEnum t))) (replicate n $ P.Var ())
denormalizeBranch :: (Num a, Var v) =>
Term ANormalF v -> (a, ABT.Term (Term.F v () ()) v ())
@ -173,7 +173,7 @@ denormalizeHandler cs df = dcs
where (_, db) = denormalizeBranch df
rf r rcs = foldMapWithKey (cf r) rcs
cf r t b = [ Term.MatchCase
(P.EffectBind () (ConstructorReference r (fromEnum t))
(P.EffectBind () (ConstructorReference r (fromIntegral (fromEnum t)))
(replicate n $ P.Var ()) (P.Var ()))
Nothing
db

14
parser-typechecker/tests/Unison/Test/DataDeclaration.hs
View File

@ -24,7 +24,7 @@ import qualified Unison.Var.RefNamed as Var
test :: Test ()
test = scope "datadeclaration" $
let Right hashes = Hashing.hashDecls . (snd <$>) . dataDeclarationsId $ file
let Right hashes = Hashing.hashDataDecls . (snd <$>) . dataDeclarationsId $ file
hashMap = Map.fromList $ fmap (\(a,b,_) -> (a,b)) hashes
hashOf k = Map.lookup (Var.named k) hashMap
in tests [
@ -90,13 +90,13 @@ unhashComponentTest = tests
forall = Type.forall ()
(-->) = Type.arrow ()
h = Hash.fromByteString (encodeUtf8 "abcd")
ref = R.Derived h 0 1
a = Var.refNamed ref
ref = R.Id h 0
a = Var.refIdNamed ref
b = Var.named "b"
nil = Var.named "Nil"
cons = Var.refNamed ref
cons = Var.refIdNamed ref
listRef = ref
listType = Type.ref () listRef
listType = Type.refId () listRef
listDecl = DataDeclaration {
modifier = DD.Structural,
annotation = (),
@ -106,9 +106,9 @@ unhashComponentTest = tests
, ((), cons, forall b (var b --> listType `app` var b --> listType `app` var b))
]
}
component :: Map R.Reference (Decl Symbol ())
component :: Map R.Id (Decl Symbol ())
component = Map.singleton listRef (Right listDecl)
component' :: Map R.Reference (Symbol, Decl Symbol ())
component' :: Map R.Id (Symbol, Decl Symbol ())
component' = DD.unhashComponent component
(listVar, Right listDecl') = component' ! listRef
listType' = var listVar

4
parser-typechecker/tests/Unison/Test/Referent.hs
View File

@ -62,8 +62,8 @@ test = scope "hashparsing" . tests $
]
where
h = "#1tdqrgl90qnmqvrff0j76kg2rnajq7n8j54e9cbk4p8pdi41q343bnh8h2rv6nadhlin8teg8371d445pvo0as7j2sav8k401d2s3no"
suffix1 = Rf.showSuffix 0 10
suffix2 = Rf.showSuffix 3 6
suffix1 = Rf.showSuffix 0
suffix2 = Rf.showSuffix 3
ref txt = scope (Text.unpack txt) $ case Rf.fromText txt of
Left e -> fail e
Right r1 -> case Rf.fromText (Rf.toText r1) of

6
parser-typechecker/tests/Unison/Test/Term.hs
View File

@ -43,10 +43,10 @@ test = scope "term" $ tests
ok
, scope "Term.unhashComponent" $
let h = Hash.fromByteString (encodeUtf8 "abcd")
ref = R.Derived h 0 1
v1 = Var.refNamed @Symbol ref
ref = R.Id h 0
v1 = Var.refIdNamed @Symbol ref
-- input component: `ref = \v1 -> ref`
component = Map.singleton ref (Term.lam () v1 (Term.ref () ref))
component = Map.singleton ref (Term.lam () v1 (Term.refId () ref))
component' = Term.unhashComponent component
-- expected unhashed component: `v2 = \v1 -> v2`, where `v2 /= v1`,
-- i.e. `v2` cannot be just `ref` converted to a ref-named variable,

17
parser-typechecker/unison-parser-typechecker.cabal
View File

@ -28,13 +28,17 @@ library
Unison.Builtin.Terms
Unison.Codebase
Unison.Codebase.Branch
Unison.Codebase.Branch.BranchDiff
Unison.Codebase.Branch.Merge
Unison.Codebase.Branch.Names
Unison.Codebase.Branch.Raw
Unison.Codebase.Branch.Type
Unison.Codebase.BranchDiff
Unison.Codebase.BranchUtil
Unison.Codebase.BuiltinAnnotation
Unison.Codebase.Causal
Unison.Codebase.Causal.FoldHistory
Unison.Codebase.Causal.Type
Unison.Codebase.CodeLookup
Unison.Codebase.CodeLookup.Util
Unison.Codebase.Editor.DisplayObject
@ -61,6 +65,8 @@ library
Unison.Codebase.SqliteCodebase.Branch.Dependencies
Unison.Codebase.SqliteCodebase.Conversions
Unison.Codebase.SqliteCodebase.GitError
Unison.Codebase.SqliteCodebase.MigrateSchema12
Unison.Codebase.SqliteCodebase.MigrateSchema12.DbHelpers
Unison.Codebase.SqliteCodebase.SyncEphemeral
Unison.Codebase.SyncMode
Unison.Codebase.TermEdit
@ -73,15 +79,23 @@ library
Unison.DeclPrinter
Unison.FileParser
Unison.FileParsers
Unison.Hashing.V2.ABT
Unison.Hashing.V2.Branch
Unison.Hashing.V2.Causal
Unison.Hashing.V2.Convert
Unison.Hashing.V2.DataDeclaration
Unison.Hashing.V2.LabeledDependency
Unison.Hashing.V2.Hashable
Unison.Hashing.V2.Kind
Unison.Hashing.V2.Patch
Unison.Hashing.V2.Pattern
Unison.Hashing.V2.Reference
Unison.Hashing.V2.Reference.Util
Unison.Hashing.V2.Referent
Unison.Hashing.V2.Term
Unison.Hashing.V2.TermEdit
Unison.Hashing.V2.Tokenizable
Unison.Hashing.V2.Type
Unison.Hashing.V2.TypeEdit
Unison.Lexer
Unison.Lexer.Pos
Unison.NamePrinter
@ -224,6 +238,7 @@ library
, fingertree
, fsnotify
, fuzzyfind
, generic-lens
, generic-monoid
, hashable
, hashtables

2
stack.yaml
View File

@ -35,6 +35,8 @@ extra-deps:
commit: 2944b11d19ee034c48276edc991736105c9d6143
- github: unisonweb/megaparsec
commit: c4463124c578e8d1074c04518779b5ce5957af6b
- github: unisonweb/shellmet
commit: 2fd348592c8f51bb4c0ca6ba4bc8e38668913746
- guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078
- prelude-extras-0.4.0.3@sha256:1c10b0123ea13a6423d74a8fcbaeb2d5249b472588abde418a36b47b7c4f48c8,1163
- sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010

Some files were not shown because too many files have changed in this diff Show More