unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-09-11 10:35:57 +03:00
Code Issues Projects Releases Wiki Activity

⅄ trunk → 22-12-14-tidy-up-hashing-package

Browse Source
This commit is contained in:
Mitchell Rosen 2022-12-14 21:15:35 -05:00
commit 4be5ff5346
61 changed files with 548 additions and 574 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
codebase2/codebase-sqlite-hashing-v2/package.yaml
View File

@ -26,6 +26,8 @@ dependencies:
library:
source-dirs: src
exposed-modules:
- U.Codebase.Sqlite.V2.HashHandle
when:
- condition: false
other-modules: Paths_unison_codebase_sqlite_hashing_v2

24
codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Sqlite/V2/Decl.hs
View File

@ -1,24 +0,0 @@
module U.Codebase.Sqlite.V2.Decl
( saveDeclComponent,
)
where
import qualified U.Codebase.Decl as V2
import U.Codebase.Sqlite.DbId (ObjectId)
import qualified U.Codebase.Sqlite.Queries as U.Sqlite
import U.Codebase.Sqlite.Symbol (Symbol)
import U.Codebase.Sqlite.V2.HashHandle
import U.Util.Hash (Hash)
import Unison.Prelude
import Unison.Sqlite
saveDeclComponent ::
-- | The serialized decl component if we already have it e.g. via sync
Maybe ByteString ->
-- | decl component hash
Hash ->
-- | decl component
[V2.Decl Symbol] ->
Transaction ObjectId
saveDeclComponent =
U.Sqlite.saveDeclComponent v2HashHandle

11
codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Sqlite/V2/SyncEntity.hs
View File

@ -1,11 +0,0 @@
module U.Codebase.Sqlite.V2.SyncEntity where
import qualified U.Codebase.Sqlite.DbId as Db
import U.Codebase.Sqlite.Entity (SyncEntity)
import qualified U.Codebase.Sqlite.Queries as Q
import U.Codebase.Sqlite.V2.HashHandle
import U.Util.Hash32 (Hash32)
import Unison.Sqlite
saveSyncEntity :: Hash32 -> SyncEntity -> Transaction (Either Db.CausalHashId Db.ObjectId)
saveSyncEntity = Q.saveSyncEntity v2HashHandle

24
codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Sqlite/V2/Term.hs
View File

@ -1,24 +0,0 @@
module U.Codebase.Sqlite.V2.Term
( saveTermComponent,
)
where
import U.Codebase.Sqlite.DbId (ObjectId)
import qualified U.Codebase.Sqlite.Queries as U.Sqlite
import U.Codebase.Sqlite.Symbol (Symbol)
import U.Codebase.Sqlite.V2.HashHandle
import qualified U.Codebase.Term as V2
import U.Util.Hash (Hash)
import Unison.Prelude
import Unison.Sqlite
saveTermComponent ::
-- | The serialized term component if we already have it e.g. via sync
Maybe ByteString ->
-- | term component hash
Hash ->
-- | term component
[(V2.Term Symbol, V2.Type Symbol)] ->
Transaction ObjectId
saveTermComponent =
U.Sqlite.saveTermComponent v2HashHandle

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

@ -1,7 +1,6 @@
-- | Description: Converts V2 types to the V2 hashing types
module Unison.Hashing.V2.Convert2
( v2ToH2Term,
v2ToH2Type,
( v2ToH2Type,
v2ToH2TypeD,
h2ToV2Reference,
)
@ -9,75 +8,13 @@ where
import qualified U.Codebase.Kind as V2
import qualified U.Codebase.Reference as V2
import qualified U.Codebase.Referent as V2.Referent
import qualified U.Codebase.Term as V2 (F, F' (..), MatchCase (..), Pattern (..), SeqOp (..), TermRef, TypeRef)
import qualified U.Codebase.Term as V2 (TypeRef)
import qualified U.Codebase.Type as V2.Type
import qualified U.Core.ABT as ABT
import Unison.Hash (Hash)
import qualified Unison.Hashing.V2 as H2
import Unison.Prelude
v2ToH2Term :: forall v. Ord v => Hash -> ABT.Term (V2.F v) v () -> H2.Term v ()
v2ToH2Term thisTermComponentHash = ABT.transform convertF
where
convertF :: forall x. V2.F v x -> H2.TermF v () () x
convertF = \case
V2.Int x -> H2.TermInt x
V2.Nat x -> H2.TermNat x
V2.Float x -> H2.TermFloat x
V2.Boolean x -> H2.TermBoolean x
V2.Text x -> H2.TermText x
V2.Char x -> H2.TermChar x
V2.Ref x -> H2.TermRef (convertTermRef thisTermComponentHash x)
V2.Constructor a b -> H2.TermConstructor (convertReference a) b
V2.Request a b -> H2.TermRequest (convertReference a) b
V2.Handle a b -> H2.TermHandle a b
V2.App a b -> H2.TermApp a b
V2.Ann a b -> H2.TermAnn a (v2ToH2Type b)
V2.List a -> H2.TermList a
V2.If a b c -> H2.TermIf a b c
V2.And a b -> H2.TermAnd a b
V2.Or a b -> H2.TermOr a b
V2.Lam a -> H2.TermLam a
V2.LetRec a b -> H2.TermLetRec a b
V2.Let a b -> H2.TermLet a b
V2.Match a b -> H2.TermMatch a (map convertMatchCase b)
V2.TermLink a -> H2.TermTermLink (convertReferent thisTermComponentHash a)
V2.TypeLink a -> H2.TermTypeLink (convertReference a)
convertMatchCase :: V2.MatchCase Text V2.TypeRef x -> H2.MatchCase () x
convertMatchCase (V2.MatchCase pat a b) = H2.MatchCase (convertPattern pat) a b
convertPattern :: V2.Pattern Text V2.TypeRef -> H2.Pattern ()
convertPattern = \case
V2.PUnbound -> H2.PatternUnbound ()
V2.PVar -> H2.PatternVar ()
V2.PBoolean a -> H2.PatternBoolean () a
V2.PInt a -> H2.PatternInt () a
V2.PNat a -> H2.PatternNat () a
V2.PFloat a -> H2.PatternFloat () a
V2.PText a -> H2.PatternText () a
V2.PChar a -> H2.PatternChar () a
V2.PConstructor a b c -> H2.PatternConstructor () (convertReference a) b (map convertPattern c)
V2.PAs a -> H2.PatternAs () (convertPattern a)
V2.PEffectPure a -> H2.PatternEffectPure () (convertPattern a)
V2.PEffectBind a b c d -> H2.PatternEffectBind () (convertReference a) b (map convertPattern c) (convertPattern d)
V2.PSequenceLiteral a -> H2.PatternSequenceLiteral () (map convertPattern a)
V2.PSequenceOp a b c -> H2.PatternSequenceOp () (convertPattern a) (convertSeqOp b) (convertPattern c)
where
convertSeqOp = \case
V2.PCons -> H2.Cons
V2.PSnoc -> H2.Snoc
V2.PConcat -> H2.Concat
convertReferent ::
Hash ->
V2.Referent.Referent' (V2.Reference' Text (Maybe Hash)) (V2.Reference' Text Hash) ->
H2.Referent
convertReferent defaultHash = \case
V2.Referent.Ref x -> H2.ReferentRef (convertTermRef defaultHash x)
V2.Referent.Con x cid -> H2.ReferentCon (convertReference x) cid
convertId :: Hash -> V2.Id' (Maybe Hash) -> H2.ReferenceId
convertId defaultHash = \case
V2.Id m p -> H2.ReferenceId (fromMaybe defaultHash m) p
@ -85,9 +22,6 @@ convertId defaultHash = \case
convertReference :: V2.Reference -> H2.Reference
convertReference = convertReference' (\(V2.Id a b) -> H2.ReferenceId a b)
convertTermRef :: Hash -> V2.TermRef -> H2.Reference
convertTermRef = convertReference' . convertId
convertReference' :: (V2.Id' hash -> H2.ReferenceId) -> V2.Reference' Text hash -> H2.Reference
convertReference' idConv = \case
V2.ReferenceBuiltin x -> H2.ReferenceBuiltin x

4
codebase2/codebase-sqlite-hashing-v2/unison-codebase-sqlite-hashing-v2.cabal
View File

@ -17,10 +17,8 @@ source-repository head
library
exposed-modules:
U.Codebase.Sqlite.V2.Decl
U.Codebase.Sqlite.V2.HashHandle
U.Codebase.Sqlite.V2.SyncEntity
U.Codebase.Sqlite.V2.Term
other-modules:
Unison.Hashing.V2.Convert2
hs-source-dirs:
src

1
codebase2/codebase-sqlite/U/Codebase/Branch.hs
View File

@ -9,6 +9,7 @@ where
import U.Codebase.Branch.Type as X
import qualified U.Codebase.Causal as Causal
import qualified U.Codebase.Sqlite.Operations as Ops
import Unison.NameSegment (NameSegment)
import Unison.Prelude
import Unison.Sqlite (Transaction)

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

@ -166,6 +166,8 @@ import qualified U.Util.Base32Hex as Base32Hex
import qualified U.Util.Hash as H
import qualified U.Util.Hash32 as Hash32
import qualified U.Util.Serialization as S
import Unison.NameSegment (NameSegment (NameSegment))
import qualified Unison.NameSegment as NameSegment
import Unison.Prelude
import Unison.Sqlite
import qualified Unison.Util.Map as Map
@ -513,35 +515,35 @@ s2cBranch (S.Branch.Full.Branch tms tps patches children) =
doTerms ::
Map Db.TextId (Map S.Referent S.DbMetadataSet) ->
Transaction (Map C.Branch.NameSegment (Map C.Referent (Transaction C.Branch.MdValues)))
Transaction (Map NameSegment (Map C.Referent (Transaction C.Branch.MdValues)))
doTerms =
Map.bitraverse
(fmap C.Branch.NameSegment . Q.expectText)
(fmap NameSegment . Q.expectText)
( Map.bitraverse s2cReferent \case
S.MetadataSet.Inline rs ->
pure $ C.Branch.MdValues <$> loadTypesForMetadata rs
)
doTypes ::
Map Db.TextId (Map S.Reference S.DbMetadataSet) ->
Transaction (Map C.Branch.NameSegment (Map C.Reference (Transaction C.Branch.MdValues)))
Transaction (Map NameSegment (Map C.Reference (Transaction C.Branch.MdValues)))
doTypes =
Map.bitraverse
(fmap C.Branch.NameSegment . Q.expectText)
(fmap NameSegment . Q.expectText)
( Map.bitraverse s2cReference \case
S.MetadataSet.Inline rs ->
pure $ C.Branch.MdValues <$> loadTypesForMetadata rs
)
doPatches ::
Map Db.TextId Db.PatchObjectId ->
Transaction (Map C.Branch.NameSegment (PatchHash, Transaction C.Branch.Patch))
doPatches = Map.bitraverse (fmap C.Branch.NameSegment . Q.expectText) \patchId -> do
Transaction (Map NameSegment (PatchHash, Transaction C.Branch.Patch))
doPatches = Map.bitraverse (fmap NameSegment . Q.expectText) \patchId -> do
h <- PatchHash <$> (Q.expectPrimaryHashByObjectId . Db.unPatchObjectId) patchId
pure (h, expectPatch patchId)
doChildren ::
Map Db.TextId (Db.BranchObjectId, Db.CausalHashId) ->
Transaction (Map C.Branch.NameSegment (C.Causal Transaction CausalHash BranchHash (C.Branch.Branch Transaction)))
doChildren = Map.bitraverse (fmap C.Branch.NameSegment . Q.expectText) \(boId, chId) ->
Transaction (Map NameSegment (C.Causal Transaction CausalHash BranchHash (C.Branch.Branch Transaction)))
doChildren = Map.bitraverse (fmap NameSegment . Q.expectText) \(boId, chId) ->
C.Causal <$> Q.expectCausalHash chId
<*> expectValueHashByCausalHashId chId
<*> headParents chId
@ -671,8 +673,8 @@ saveBranch hh (C.Causal hc he parents me) = do
<*> Map.bitraverse saveNameSegment savePatchObjectId patches
<*> Map.bitraverse saveNameSegment (saveBranch hh) children
saveNameSegment :: C.Branch.NameSegment -> Transaction Db.TextId
saveNameSegment = Q.saveText . C.Branch.unNameSegment
saveNameSegment :: NameSegment -> Transaction Db.TextId
saveNameSegment = Q.saveText . NameSegment.toText
c2sMetadata :: Transaction C.Branch.MdValues -> Transaction S.Branch.Full.DbMetadataSet
c2sMetadata mm = do
@ -1081,9 +1083,7 @@ updateNameIndex (newTermNames, removedTermNames) (newTypeNames, removedTypeNames
data NamesByPath = NamesByPath
{ termNamesInPath :: [S.NamedRef (C.Referent, Maybe C.ConstructorType)],
termNamesExternalToPath :: [S.NamedRef (C.Referent, Maybe C.ConstructorType)],
typeNamesInPath :: [S.NamedRef C.Reference],
typeNamesExternalToPath :: [S.NamedRef C.Reference]
typeNamesInPath :: [S.NamedRef C.Reference]
}
-- | Get all the term and type names for the root namespace from the lookup table.
@ -1092,14 +1092,12 @@ rootNamesByPath ::
Maybe Text ->
Transaction NamesByPath
rootNamesByPath path = do
(termNamesInPath, termNamesExternalToPath) <- Q.rootTermNamesByPath path
(typeNamesInPath, typeNamesExternalToPath) <- Q.rootTypeNamesByPath path
termNamesInPath <- Q.rootTermNamesByPath path
typeNamesInPath <- Q.rootTypeNamesByPath path
pure $
NamesByPath
{ termNamesInPath = convertTerms <$> termNamesInPath,
termNamesExternalToPath = convertTerms <$> termNamesExternalToPath,
typeNamesInPath = convertTypes <$> typeNamesInPath,
typeNamesExternalToPath = convertTypes <$> typeNamesExternalToPath
typeNamesInPath = convertTypes <$> typeNamesInPath
}
where
convertTerms = fmap (bimap s2cTextReferent (fmap s2cConstructorType))

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

@ -1750,37 +1750,35 @@ insertTypeNames names =
|]
-- | Get the list of a term names in the root namespace according to the name lookup index
rootTermNamesByPath :: Maybe Text -> Transaction ([NamedRef (Referent.TextReferent, Maybe NamedRef.ConstructorType)], [NamedRef (Referent.TextReferent, Maybe NamedRef.ConstructorType)])
rootTermNamesByPath :: Maybe Text -> Transaction [NamedRef (Referent.TextReferent, Maybe NamedRef.ConstructorType)]
rootTermNamesByPath mayNamespace = do
let (namespace, subnamespace) = case mayNamespace of
Nothing -> ("", "*")
Just namespace -> (namespace, globEscape namespace <> ".*")
results :: [Only Bool :. NamedRef (Referent.TextReferent :. Only (Maybe NamedRef.ConstructorType))] <- queryListRow sql (subnamespace, namespace, subnamespace, namespace)
let (namesInNamespace, namesOutsideNamespace) = span (\(Only inNamespace :. _) -> inNamespace) results
pure (fmap unRow . dropTag <$> namesInNamespace, fmap unRow . dropTag <$> namesOutsideNamespace)
results :: [NamedRef (Referent.TextReferent :. Only (Maybe NamedRef.ConstructorType))] <- queryListRow sql (subnamespace, namespace, subnamespace, namespace)
pure (fmap unRow <$> results)
where
dropTag (_ :. name) = name
unRow (a :. Only b) = (a, b)
sql =
[here|
SELECT namespace GLOB ? OR namespace = ?, reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type FROM term_name_lookup
SELECT reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type FROM term_name_lookup
WHERE (namespace GLOB ? OR namespace = ?)
ORDER BY (namespace GLOB ? OR namespace = ?) DESC
|]
-- | Get the list of a type names in the root namespace according to the name lookup index
rootTypeNamesByPath :: Maybe Text -> Transaction ([NamedRef Reference.TextReference], [NamedRef Reference.TextReference])
rootTypeNamesByPath :: Maybe Text -> Transaction [NamedRef Reference.TextReference]
rootTypeNamesByPath mayNamespace = do
let (namespace, subnamespace) = case mayNamespace of
Nothing -> ("", "*")
Just namespace -> (namespace, globEscape namespace <> ".*")
results :: [Only Bool :. NamedRef Reference.TextReference] <- queryListRow sql (subnamespace, namespace, subnamespace, namespace)
let (namesInNamespace, namesOutsideNamespace) = span (\(Only inNamespace :. _) -> inNamespace) results
pure (dropTag <$> namesInNamespace, dropTag <$> namesOutsideNamespace)
results :: [NamedRef Reference.TextReference] <- queryListRow sql (subnamespace, namespace, subnamespace, namespace)
pure results
where
dropTag (_ :. name) = name
sql =
[here|
SELECT namespace GLOB ? OR namespace = ?, reversed_name, reference_builtin, reference_component_hash, reference_component_index FROM type_name_lookup
SELECT reversed_name, reference_builtin, reference_component_hash, reference_component_index FROM type_name_lookup
WHERE namespace GLOB ? OR namespace = ?
ORDER BY (namespace GLOB ? OR namespace = ?) DESC
|]

5
codebase2/codebase/U/Codebase/Branch/Type.hs
View File

@ -8,8 +8,6 @@ module U.Codebase.Branch.Type
MetadataType,
MetadataValue,
MdValues (..),
NameSegment (..),
CausalHash,
NamespaceStats (..),
hasDefinitions,
childAt,
@ -29,10 +27,9 @@ import U.Codebase.Reference (Reference)
import U.Codebase.Referent (Referent)
import U.Codebase.TermEdit (TermEdit)
import U.Codebase.TypeEdit (TypeEdit)
import Unison.NameSegment (NameSegment)
import Unison.Prelude
newtype NameSegment = NameSegment {unNameSegment :: Text} deriving (Eq, Ord, Show)
type MetadataType = Reference
type MetadataValue = Reference

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

@ -19,7 +19,6 @@ library
U.Codebase.Branch.Type
U.Codebase.Causal
U.Codebase.Decl
U.Codebase.HashTags
U.Codebase.Kind
U.Codebase.Reference
U.Codebase.Referent

11
codebase2/codebase/U/Codebase/HashTags.hs → codebase2/core/U/Codebase/HashTags.hs
View File

@ -4,14 +4,11 @@ import U.Util.Hash (Hash)
newtype BranchHash = BranchHash {unBranchHash :: Hash} deriving (Eq, Ord)
-- | Represents a hash of a causal containing values of the provided type.
newtype CausalHash = CausalHash {unCausalHash :: Hash} deriving (Eq, Ord)
newtype EditHash = EditHash {unEditHash :: Hash} deriving (Eq, Ord)
newtype PatchHash = PatchHash {unPatchHash :: Hash} deriving (Eq, Ord)
newtype DefnHash = DefnHash {unDefnHash :: Hash} deriving (Eq, Ord)
instance Show BranchHash where
show h = "BranchHash (" ++ show (unBranchHash h) ++ ")"
@ -20,9 +17,3 @@ instance Show CausalHash where
instance Show PatchHash where
show h = "PatchHash (" ++ show (unPatchHash h) ++ ")"
instance Show EditHash where
show h = "EditHash (" ++ show (unEditHash h) ++ ")"
instance Show DefnHash where
show h = "DefnHash (" ++ show (unDefnHash h) ++ ")"

0
unison-core/src/Unison/NameSegment.hs → codebase2/core/Unison/NameSegment.hs
View File

0
unison-core/src/Unison/Util/Alphabetical.hs → codebase2/core/Unison/Util/Alphabetical.hs
View File

4
codebase2/core/package.yaml
View File

@ -10,7 +10,11 @@ library:
dependencies:
- base
- containers
- rfc5051
- text
- vector
- unison-hash
- unison-prelude
- unison-util
- unison-util-base32hex

7
codebase2/core/unison-core.cabal
View File

@ -16,8 +16,11 @@ source-repository head
library
exposed-modules:
U.Codebase.HashTags
U.Core.ABT
U.Core.ABT.Var
Unison.NameSegment
Unison.Util.Alphabetical
hs-source-dirs:
./
default-extensions:
@ -49,6 +52,10 @@ library
build-depends:
base
, containers
, rfc5051
, text
, unison-hash
, unison-prelude
, unison-util
, unison-util-base32hex
, vector

8
parser-typechecker/src/U/Codebase/Branch/Diff.hs
View File

@ -20,9 +20,9 @@ import qualified U.Codebase.Branch.Type as Branch
import qualified U.Codebase.Causal as Causal
import U.Codebase.Reference (Reference)
import U.Codebase.Referent (Referent)
import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv
import Unison.Name (Name)
import qualified Unison.Name as Name
import Unison.NameSegment (NameSegment)
import Unison.Prelude
data Diff a = Diff
@ -163,10 +163,10 @@ nameChanges namePrefix (TreeDiff (DefinitionDiffs {termDiffs, typeDiffs} :< chil
in NameChanges {termNameAdds, termNameRemovals, typeNameAdds, typeNameRemovals} <> childNameChanges
where
appendName :: NameSegment -> Name
appendName ns =
appendName =
case namePrefix of
Nothing -> Name.fromSegment . Cv.namesegment2to1 $ ns
Just prefix -> prefix Lens.|> Cv.namesegment2to1 ns
Nothing -> Name.fromSegment
Just prefix -> (prefix Lens.|>)
listifyNames :: (Name -> Set ref -> [(Name, ref)])
listifyNames name xs =
xs

40
parser-typechecker/src/U/Codebase/Projects.hs Normal file
View File

@ -0,0 +1,40 @@
module U.Codebase.Projects where
import qualified Control.Lens.Cons as Cons
import Control.Monad.Reader
import Control.Monad.Writer.Strict (WriterT, execWriterT, tell)
import qualified Data.Map as Map
import Data.Monoid (Last (..))
import U.Codebase.Branch
import qualified U.Codebase.Causal as Causal
import Unison.Codebase.Path
import qualified Unison.Codebase.Path as Path
import Unison.NameSegment (NameSegment (..))
import Unison.Prelude
import qualified Unison.Sqlite as Sqlite
libSegment :: NameSegment
libSegment = NameSegment "lib"
-- | Infers path to use for loading names.
-- Currently this means finding the closest parent with a "lib" child.
inferNamesRoot :: Path -> Branch Sqlite.Transaction -> Sqlite.Transaction (Maybe Path)
inferNamesRoot p _b | Just match <- specialCases p = pure $ Just match
where
specialCases :: Path -> Maybe Path
specialCases ("public" Cons.:< "base" Cons.:< release Cons.:< _rest) = Just (Path.fromList ["public", "base", release])
specialCases _ = Nothing
inferNamesRoot p b = getLast <$> execWriterT (runReaderT (go p b) Path.empty)
where
go :: Path -> Branch Sqlite.Transaction -> ReaderT Path (WriterT (Last Path) Sqlite.Transaction) ()
go p b = do
childMap <- lift . lift $ nonEmptyChildren b
when (isJust $ Map.lookup libSegment childMap) $ ask >>= tell . Last . Just
case p of
Empty -> pure ()
(nextChild Cons.:< pathRemainder) ->
case Map.lookup (coerce nextChild) childMap of
Nothing -> pure ()
Just childCausal -> do
childBranch <- lift . lift $ Causal.value childCausal
local (Cons.|> nextChild) (go pathRemainder childBranch)

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

@ -118,6 +118,7 @@ import qualified Data.Set as Set
import qualified U.Codebase.Branch as V2
import qualified U.Codebase.Branch as V2Branch
import qualified U.Codebase.Causal as V2Causal
import U.Codebase.HashTags (CausalHash)
import qualified U.Codebase.Referent as V2
import qualified U.Codebase.Sqlite.Operations as Operations
import qualified U.Codebase.Sqlite.Queries as Queries
@ -175,7 +176,7 @@ runTransaction Codebase {withConnection} action =
getShallowCausalFromRoot ::
-- Optional root branch, if Nothing use the codebase's root branch.
Maybe V2.CausalHash ->
Maybe CausalHash ->
Path.Path ->
Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
getShallowCausalFromRoot mayRootHash p = do
@ -207,9 +208,9 @@ getShallowCausalAtPath path mayCausal = do
causal <- whenNothing mayCausal getShallowRootCausal
case path of
Path.Empty -> pure causal
(ns Path.:< p) -> do
ns Path.:< p -> do
b <- V2Causal.value causal
case (V2Branch.childAt (Cv.namesegment1to2 ns) b) of
case V2Branch.childAt ns b of
Nothing -> pure (Cv.causalbranch1to2 Branch.empty)
Just childCausal -> getShallowCausalAtPath p (Just childCausal)
@ -223,15 +224,15 @@ getShallowBranchAtPath path mayBranch = do
branch <- whenNothing mayBranch (getShallowRootCausal >>= V2Causal.value)
case path of
Path.Empty -> pure branch
(ns Path.:< p) -> do
case (V2Branch.childAt (Cv.namesegment1to2 ns) branch) of
ns Path.:< p -> do
case V2Branch.childAt ns branch of
Nothing -> pure V2Branch.empty
Just childCausal -> do
childBranch <- V2Causal.value childCausal
getShallowBranchAtPath p (Just childBranch)
-- | Get a branch from the codebase.
getBranchForHash :: Monad m => Codebase m v a -> Branch.CausalHash -> m (Maybe (Branch m))
getBranchForHash :: Monad m => Codebase m v a -> CausalHash -> m (Maybe (Branch m))
getBranchForHash codebase h =
-- Attempt to find the Branch in the current codebase cache and root up to 3 levels deep
-- If not found, attempt to find it in the Codebase (sqlite)
@ -270,7 +271,7 @@ lca code b1@(Branch.headHash -> h1) b2@(Branch.headHash -> h2) = do
eb2 <- SqliteCodebase.Operations.branchExists h2
if eb1 && eb2
then do
SqliteCodebase.Operations.sqlLca h1 h2 >>= \case
Operations.lca h1 h2 >>= \case
Just h -> pure (getBranchForHash code h)
Nothing -> pure (pure Nothing) -- no common ancestor
else pure (Branch.lca b1 b2)
@ -360,7 +361,7 @@ typeLookupForDependencies codebase s = do
toCodeLookup :: MonadIO m => Codebase m Symbol Parser.Ann -> CL.CodeLookup Symbol m Parser.Ann
toCodeLookup c =
CL.CodeLookup (getTerm c) (runTransaction c . getTypeDeclaration c)
CL.CodeLookup (runTransaction c . getTerm c) (runTransaction c . getTypeDeclaration c)
<> Builtin.codeLookup
<> IOSource.codeLookupM
@ -499,7 +500,7 @@ unsafeGetComponentLength h =
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 :: HasCallStack => Codebase m v a -> Reference.Id -> Sqlite.Transaction (Term v a)
unsafeGetTerm codebase rid =
getTerm codebase rid >>= \case
Nothing -> error (reportBug "E520818" ("term " ++ show rid ++ " not found"))
@ -520,7 +521,7 @@ unsafeGetTypeOfTermById codebase rid =
Just ty -> pure ty
-- | Like 'unsafeGetTerm', but returns the type of the term, too.
unsafeGetTermWithType :: (HasCallStack, MonadIO m) => Codebase m v a -> Reference.Id -> m (Term v a, Type v a)
unsafeGetTermWithType :: HasCallStack => Codebase m v a -> Reference.Id -> Sqlite.Transaction (Term v a, Type v a)
unsafeGetTermWithType codebase rid = do
term <- unsafeGetTerm codebase rid
ty <-
@ -528,7 +529,7 @@ unsafeGetTermWithType codebase rid = do
-- inferred type). In this case, we can avoid looking up the type separately.
case term of
Term.Ann' _ ty -> pure ty
_ -> runTransaction codebase (unsafeGetTypeOfTermById codebase rid)
_ -> unsafeGetTypeOfTermById codebase rid
pure (term, ty)
-- | Like 'getTermComponentWithTypes', for when the term component is known to exist in the codebase.

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

@ -12,8 +12,6 @@ module Unison.Codebase.Branch
Raw,
Star,
NamespaceHash,
CausalHash,
EditHash,
-- * Branch construction
branch0,
@ -94,12 +92,11 @@ import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import Data.These (These (..))
import U.Codebase.Branch.Type (NamespaceStats (..))
import U.Codebase.HashTags (PatchHash (..))
import Unison.Codebase.Branch.Raw (Raw)
import Unison.Codebase.Branch.Type
( Branch (..),
Branch0 (..),
CausalHash (..),
EditHash,
NamespaceHash,
Star,
UnwrappedBranch,
@ -189,7 +186,7 @@ branch0 ::
Metadata.Star Referent NameSegment ->
Metadata.Star TypeReference NameSegment ->
Map NameSegment (Branch m) ->
Map NameSegment (EditHash, m Patch) ->
Map NameSegment (PatchHash, m Patch) ->
Branch0 m
branch0 terms types children edits =
Branch0
@ -330,13 +327,13 @@ deriveDeepEdits :: forall m. Branch0 m -> Branch0 m
deriveDeepEdits branch =
branch {deepEdits = makeDeepEdits branch}
where
makeDeepEdits :: Branch0 m -> Map Name EditHash
makeDeepEdits :: Branch0 m -> Map Name PatchHash
makeDeepEdits branch = State.evalState (go (Seq.singleton ([], 0, branch)) mempty) Set.empty
where
go :: (Seq (DeepChildAcc m)) -> Map Name EditHash -> DeepState m (Map Name EditHash)
go :: (Seq (DeepChildAcc m)) -> Map Name PatchHash -> DeepState m (Map Name PatchHash)
go Seq.Empty acc = pure acc
go (e@(reversePrefix, _, b0) Seq.:<| work) acc = do
let edits :: Map Name EditHash
let edits :: Map Name PatchHash
edits =
Map.mapKeysMonotonic
(Name.fromReverseSegments . (NonEmpty.:| reversePrefix))
@ -378,16 +375,16 @@ head_ :: Lens' (Branch m) (Branch0 m)
head_ = history . Causal.head_
-- | a version of `deepEdits` that returns the `m Patch` as well.
deepEdits' :: Branch0 m -> Map Name (EditHash, m Patch)
deepEdits' :: Branch0 m -> Map Name (PatchHash, m Patch)
deepEdits' = go id
where
-- can change this to an actual prefix once Name is a [NameSegment]
go :: (Name -> Name) -> Branch0 m -> Map Name (EditHash, m Patch)
go :: (Name -> Name) -> Branch0 m -> Map Name (PatchHash, m Patch)
go addPrefix Branch0 {_children, _edits} =
Map.mapKeys (addPrefix . Name.fromSegment) _edits
<> foldMap f (Map.toList _children)
where
f :: (NameSegment, Branch m) -> Map Name (EditHash, m Patch)
f :: (NameSegment, Branch m) -> Map Name (PatchHash, m Patch)
f (c, b) = go (addPrefix . Name.cons c) (head b)
-- | Discards the history of a Branch0's children, recursively
@ -555,10 +552,10 @@ modifyPatches seg f = mapMOf edits update
Nothing -> pure $ f Patch.empty
Just (_, p) -> f <$> p
let h = H.hashPatch p'
pure $ Map.insert seg (h, pure p') m
pure $ Map.insert seg (PatchHash h, pure p') m
replacePatch :: Applicative m => NameSegment -> Patch -> Branch0 m -> Branch0 m
replacePatch n p = over edits (Map.insert n (H.hashPatch p, pure p))
replacePatch n p = over edits (Map.insert n (PatchHash (H.hashPatch p), pure p))
deletePatch :: NameSegment -> Branch0 m -> Branch0 m
deletePatch n = over edits (Map.delete n)

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

@ -12,10 +12,10 @@ where
import qualified Data.Map as Map
import qualified Data.Map.Merge.Lazy as Map
import U.Codebase.HashTags (PatchHash (..))
import Unison.Codebase.Branch
( Branch (..),
Branch0 (_children, _edits, _terms, _types),
EditHash,
branch0,
cons,
discardHistory0,
@ -88,7 +88,7 @@ merge'' lca mode (Branch x) (Branch y) =
let newPatches = makePatch <$> Map.difference changedPatches (_edits b0)
makePatch Patch.PatchDiff {..} =
let p = Patch.Patch _addedTermEdits _addedTypeEdits
in (H.hashPatch p, pure p)
in (PatchHash (H.hashPatch p), pure p)
pure $
branch0
(Star3.difference (_terms b0) removedTerms <> addedTerms)
@ -107,7 +107,7 @@ merge'' lca mode (Branch x) (Branch y) =
R.difference (Patch._typeEdits p) _removedTypeEdits
<> _addedTypeEdits
}
pure (H.hashPatch np, pure np)
pure (PatchHash (H.hashPatch np), pure np)
merge0 ::
forall m.
@ -127,10 +127,10 @@ merge0 lca mode b1 b2 = do
c3
e3
where
g :: (EditHash, m Patch) -> (EditHash, m Patch) -> m (EditHash, m Patch)
g :: (PatchHash, m Patch) -> (PatchHash, m Patch) -> m (PatchHash, m Patch)
g (h1, m1) (h2, _) | h1 == h2 = pure (h1, m1)
g (_, m1) (_, m2) = do
e1 <- m1
e2 <- m2
let e3 = e1 <> e2
pure (H.hashPatch e3, pure e3)
pure (PatchHash (H.hashPatch e3), pure e3)

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

@ -2,7 +2,6 @@
module Unison.Codebase.Branch.Type
( NamespaceHash,
CausalHash (..),
head,
headHash,
namespaceHash,
@ -11,7 +10,6 @@ module Unison.Codebase.Branch.Type
history,
edits,
Star,
EditHash,
UnwrappedBranch,
)
where
@ -19,7 +17,8 @@ where
import Control.Lens
import Data.Map (Map)
import Data.Set (Set)
import Unison.Codebase.Causal.Type (Causal, CausalHash)
import U.Codebase.HashTags (CausalHash, PatchHash)
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)
@ -42,8 +41,6 @@ type UnwrappedBranch m = Causal m (Branch0 m)
-- | A Hash for a namespace itself, it doesn't incorporate any history.
type NamespaceHash m = Hash.HashFor (Branch0 m)
type EditHash = Hash.Hash
type Star r n = Metadata.Star r n
head :: Branch m -> Branch0 m
@ -69,7 +66,7 @@ data Branch0 m = Branch0
-- | 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),
_edits :: Map NameSegment (PatchHash, m Patch),
-- | True if a branch and its children have no definitions or edits in them.
-- (Computed recursively, and small enough to justify storing here to avoid computing more than once.)
isEmpty0 :: Bool,
@ -80,7 +77,7 @@ data Branch0 m = Branch0
deepTermMetadata :: Metadata.R4 Referent Name,
deepTypeMetadata :: Metadata.R4 Reference Name,
deepPaths :: Set Path,
deepEdits :: Map Name EditHash
deepEdits :: Map Name PatchHash
}
instance Eq (Branch0 m) where
@ -93,5 +90,5 @@ instance Eq (Branch0 m) where
history :: Iso' (Branch m) (UnwrappedBranch m)
history = iso _history Branch
edits :: Lens' (Branch0 m) (Map NameSegment (EditHash, m Patch))
edits :: Lens' (Branch0 m) (Map NameSegment (PatchHash, m Patch))
edits = lens _edits (\b0 e -> b0 {_edits = e})

3
parser-typechecker/src/Unison/Codebase/BranchDiff.hs
View File

@ -2,6 +2,7 @@ module Unison.Codebase.BranchDiff where
import qualified Data.Map as Map
import qualified Data.Set as Set
import U.Codebase.HashTags (PatchHash)
import Unison.Codebase.Branch (Branch0 (..))
import qualified Unison.Codebase.Branch as Branch
import qualified Unison.Codebase.Metadata as Metadata
@ -57,7 +58,7 @@ diff0 old new = BranchDiff terms types <$> patchDiff old new
patchDiff :: forall m. Monad m => Branch0 m -> Branch0 m -> m (Map Name (DiffType PatchDiff))
patchDiff old new = do
let oldDeepEdits, newDeepEdits :: Map Name (Branch.EditHash, m Patch)
let oldDeepEdits, newDeepEdits :: Map Name (PatchHash, m Patch)
oldDeepEdits = Branch.deepEdits' old
newDeepEdits = Branch.deepEdits' new
added <- do

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

@ -8,7 +8,6 @@ module Unison.Codebase.Causal
pattern One,
pattern Cons,
pattern Merge,
CausalHash (..),
head_,
one,
cons,
@ -34,6 +33,7 @@ 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 U.Codebase.HashTags (CausalHash)
import Unison.Codebase.Causal.Type
( Causal
( UnsafeCons,
@ -44,7 +44,6 @@ import Unison.Codebase.Causal.Type
tail,
tails
),
CausalHash (..),
before,
lca,
predecessors,

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

@ -6,7 +6,8 @@ module Unison.Codebase.Causal.FoldHistory (FoldHistoryResult (..), foldHistoryUn
import qualified Data.Map as Map
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import Unison.Codebase.Causal (Causal (..), CausalHash, pattern Cons, pattern Merge, pattern One)
import U.Codebase.HashTags (CausalHash)
import Unison.Codebase.Causal (Causal (..), pattern Cons, pattern Merge, pattern One)
import Unison.Prelude
import Prelude hiding (head, tail)
@ -33,7 +34,7 @@ foldHistoryUntil f a c = step a mempty (pure c)
step a _seen Seq.Empty = pure (Unsatisfied a)
step a seen (c Seq.:<| rest)
| currentHash c `Set.member` seen =
step a seen rest
step a seen rest
step a seen (c Seq.:<| rest) = case f a (head c) of
(a, True) -> pure (Satisfied a)
(a, False) -> do

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

@ -4,7 +4,6 @@
module Unison.Codebase.Causal.Type
( Causal (..),
CausalHash (..),
pattern One,
pattern Cons,
pattern Merge,
@ -17,7 +16,8 @@ where
import qualified Data.Map as Map
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import Unison.Hash (Hash, HashFor (..))
import U.Codebase.HashTags (CausalHash)
import Unison.Hash (HashFor (..))
import Unison.Prelude
import Prelude hiding (head, read, tail)
@ -41,11 +41,6 @@ import Prelude hiding (head, read, tail)
* `head (sequence c1 c2) == head c2`
-}
-- | Represents a hash of a causal containing values of the provided type.
newtype CausalHash = CausalHash {unCausalHash :: Hash}
deriving newtype (Show)
deriving stock (Eq, Ord, Generic)
instance (Show e) => Show (Causal m e) where
show = \case
UnsafeOne h eh e -> "One " ++ (take 3 . show) h ++ " " ++ (take 3 . show) eh ++ " " ++ show e

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

@ -27,7 +27,7 @@ import qualified System.Console.ANSI as ANSI
import System.FileLock (SharedExclusive (Exclusive), withTryFileLock)
import qualified System.FilePath as FilePath
import qualified System.FilePath.Posix as FilePath.Posix
import U.Codebase.HashTags (BranchHash, CausalHash (CausalHash))
import U.Codebase.HashTags (BranchHash, CausalHash, PatchHash (..))
import qualified U.Codebase.Reflog as Reflog
import qualified U.Codebase.Sqlite.Operations as Ops
import qualified U.Codebase.Sqlite.Queries as Q
@ -39,7 +39,6 @@ import Unison.Codebase (Codebase, CodebasePath)
import qualified Unison.Codebase as Codebase1
import Unison.Codebase.Branch (Branch (..))
import qualified Unison.Codebase.Branch as Branch
import qualified Unison.Codebase.Causal.Type as Causal
import Unison.Codebase.Editor.Git (gitIn, gitInCaptured, gitTextIn, withRepo)
import qualified Unison.Codebase.Editor.Git as Git
import Unison.Codebase.Editor.RemoteRepo
@ -236,9 +235,7 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action
printBuffer "Terms:" terms
flip finally finalizer do
getTermTransaction <- CodebaseOps.makeMaybeCachedTransaction 8192 (CodebaseOps.getTerm getDeclType)
let getTerm id = runTransaction (getTermTransaction id)
getTerm <- CodebaseOps.makeMaybeCachedTransaction 8192 (CodebaseOps.getTerm getDeclType)
getTypeOfTermImpl <- CodebaseOps.makeMaybeCachedTransaction 8192 (CodebaseOps.getTypeOfTermImpl)
getTypeDeclaration <- CodebaseOps.makeMaybeCachedTransaction 1024 CodebaseOps.getTypeDeclaration
@ -287,9 +284,9 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action
-- Transaction is applied to the same db connection.
let branch1Trans = Branch.transform (Sqlite.unsafeIO . runInIO) branch1
putRootBranchTrans :: Sqlite.Transaction () = do
let emptyCausalHash = Cv.causalHash1to2 (Branch.headHash Branch.empty)
let emptyCausalHash = Branch.headHash Branch.empty
fromRootCausalHash <- fromMaybe emptyCausalHash <$> Ops.loadRootCausalHash
let toRootCausalHash = Cv.causalHash1to2 (Branch.headHash branch1)
let toRootCausalHash = Branch.headHash branch1
CodebaseOps.putRootBranch branch1Trans
Ops.appendReflog (Reflog.Entry {time = now, fromRootCausalHash, toRootCausalHash, reason})
@ -303,7 +300,7 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action
-- if this blows up on cromulent hashes, then switch from `hashToHashId`
-- to one that returns Maybe.
getBranchForHash :: Branch.CausalHash -> m (Maybe (Branch m))
getBranchForHash :: CausalHash -> m (Maybe (Branch m))
getBranchForHash h =
fmap (Branch.transform runTransaction) <$> runTransaction (CodebaseOps.getBranchForHash branchCache getDeclType h)
@ -343,9 +340,9 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action
termsMentioningTypeImpl =
CodebaseOps.termsMentioningTypeImpl getDeclType
referentsByPrefix :: ShortHash -> m (Set Referent.Id)
referentsByPrefix sh =
runTransaction (CodebaseOps.referentsByPrefix getDeclType sh)
referentsByPrefix :: ShortHash -> Sqlite.Transaction (Set Referent.Id)
referentsByPrefix =
CodebaseOps.referentsByPrefix getDeclType
updateNameLookup :: Path -> Maybe BranchHash -> BranchHash -> Sqlite.Transaction ()
updateNameLookup =
@ -435,8 +432,7 @@ syncInternal progress runSrc runDest b = time "syncInternal" do
processBranches rest
do
when debugProcessBranches $ traceM $ " " ++ show b0 ++ " doesn't exist in dest db"
let h2 = CausalHash $ Causal.unCausalHash h
runSrc (Q.loadCausalHashIdByCausalHash h2) >>= \case
runSrc (Q.loadCausalHashIdByCausalHash h) >>= \case
Just chId -> do
when debugProcessBranches $ traceM $ " " ++ show b0 ++ " exists in source db, so delegating to direct sync"
doSync [Sync22.C chId]
@ -462,7 +458,7 @@ syncInternal progress runSrc runDest b = time "syncInternal" do
processBranches rest
else do
let bs = map (uncurry B) cs
os = map O (es <> ts <> ds)
os = map O (coerce @[PatchHash] @[Hash] es <> ts <> ds)
processBranches (os ++ bs ++ b0 : rest)
O h : rest -> do
when debugProcessBranches $ traceM $ "processBranches O " ++ take 10 (show h)
@ -473,7 +469,7 @@ syncInternal progress runSrc runDest b = time "syncInternal" do
time "SyncInternal.processBranches" $ processBranches [B bHash (pure b)]
data Entity m
= B Branch.CausalHash (m (Branch m))
= B CausalHash (m (Branch m))
| O Hash
instance Show (Entity m) where
@ -672,7 +668,7 @@ pushGitBranch srcConn repo (PushGitBranchOpts behavior _syncMode) action = Unlif
runDest Ops.loadRootCausalHash >>= \case
Nothing -> pure ()
Just oldRootHash -> do
runDest (CodebaseOps.before (Cv.causalHash2to1 oldRootHash) newBranchHash) >>= \case
runDest (CodebaseOps.before oldRootHash newBranchHash) >>= \case
False -> throwIO . C.GitProtocolError $ GitError.PushDestinationHasNewStuff repo
True -> pure ()
CreatedCodebase -> pure ()
@ -681,11 +677,10 @@ pushGitBranch srcConn repo (PushGitBranchOpts behavior _syncMode) action = Unlif
C.GitPushBehaviorGist -> pure ()
C.GitPushBehaviorFf -> overwriteRoot False
C.GitPushBehaviorForce -> overwriteRoot True
setRepoRoot :: Branch.CausalHash -> Sqlite.Transaction ()
setRepoRoot :: CausalHash -> Sqlite.Transaction ()
setRepoRoot h = do
let h2 = Cv.causalHash1to2 h
err = error $ "Called SqliteCodebase.setNamespaceRoot on unknown causal hash " ++ show h2
chId <- fromMaybe err <$> Q.loadCausalHashIdByCausalHash h2
let err = error $ "Called SqliteCodebase.setNamespaceRoot on unknown causal hash " ++ show h
chId <- fromMaybe err <$> Q.loadCausalHashIdByCausalHash h
Q.setNamespaceRoot chId
-- This function makes sure that the result of git status is valid.

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

@ -12,6 +12,7 @@ import Data.Monoid.Generic (GenericMonoid (..), GenericSemigroup (..))
import Data.Set (Set)
import qualified Data.Set as Set
import GHC.Generics (Generic)
import U.Codebase.HashTags (CausalHash, PatchHash)
import Unison.Codebase.Branch.Type as Branch
import qualified Unison.Codebase.Causal as Causal
import Unison.Codebase.Patch (Patch)
@ -24,10 +25,10 @@ import qualified Unison.Referent as Referent
import qualified Unison.Util.Relation as R
import qualified Unison.Util.Star3 as Star3
type Branches m = [(Branch.CausalHash, m (Branch m))]
type Branches m = [(CausalHash, m (Branch m))]
data Dependencies = Dependencies
{ patches :: Set EditHash,
{ patches :: Set PatchHash,
terms :: Set Hash,
decls :: Set Hash
}
@ -37,7 +38,7 @@ data Dependencies = Dependencies
deriving (Monoid) via GenericMonoid Dependencies
data Dependencies' = Dependencies'
{ patches' :: [EditHash],
{ patches' :: [PatchHash],
terms' :: [Hash],
decls' :: [Hash]
}
@ -86,5 +87,5 @@ fromBranch0 b =
where
terms = Set.fromList [h | (Derived h _) <- mdValues s]
decls = Set.fromList [h | (Derived h _) <- references s]
fromEdits :: Map NameSegment (EditHash, m Patch) -> Dependencies
fromEdits :: Map NameSegment (PatchHash, m Patch) -> Dependencies
fromEdits m = Dependencies (Set.fromList . fmap fst $ toList m) mempty mempty

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

@ -9,7 +9,7 @@ import Data.Text (pack, unpack)
import qualified U.Codebase.Branch as V2.Branch
import qualified U.Codebase.Causal as V2
import qualified U.Codebase.Decl as V2.Decl
import qualified U.Codebase.HashTags as V2
import U.Codebase.HashTags
import qualified U.Codebase.Kind as V2.Kind
import qualified U.Codebase.Reference as V2
import qualified U.Codebase.Reference as V2.Reference
@ -38,7 +38,7 @@ import qualified Unison.DataDeclaration as V1.Decl
import Unison.Hash (Hash, base32Hex)
import qualified Unison.Hash as V1
import qualified Unison.Kind as V1.Kind
import qualified Unison.NameSegment as V1
import Unison.NameSegment (NameSegment)
import Unison.Parser.Ann (Ann)
import qualified Unison.Parser.Ann as Ann
import qualified Unison.Pattern as V1.Pattern
@ -273,14 +273,11 @@ rreferenceid1to2 h (V1.Reference.Id h' i) = V2.Reference.Id oh i
where
oh = if h == h' then Nothing else Just h'
branchHash1to2 :: V1.Branch.NamespaceHash m -> V2.BranchHash
branchHash1to2 = V2.BranchHash . V1.genericHash
branchHash1to2 :: V1.Branch.NamespaceHash m -> BranchHash
branchHash1to2 = BranchHash . V1.genericHash
branchHash2to1 :: forall m. V2.BranchHash -> V1.Branch.NamespaceHash m
branchHash2to1 = V1.HashFor . V2.unBranchHash
patchHash1to2 :: V1.Branch.EditHash -> V2.PatchHash
patchHash1to2 = V2.PatchHash
branchHash2to1 :: forall m. BranchHash -> V1.Branch.NamespaceHash m
branchHash2to1 = V1.HashFor . unBranchHash
reference2to1 :: V2.Reference -> V1.Reference
reference2to1 = \case
@ -334,12 +331,6 @@ constructorType2to1 = \case
V2.DataConstructor -> CT.Data
V2.EffectConstructor -> CT.Effect
causalHash2to1 :: V2.CausalHash -> V1.Branch.CausalHash
causalHash2to1 = V1.Causal.CausalHash . V2.unCausalHash
causalHash1to2 :: V1.Branch.CausalHash -> V2.CausalHash
causalHash1to2 = V2.CausalHash . V1.Causal.unCausalHash
ttype2to1 :: V2.Term.Type V2.Symbol -> V1.Type.Type V1.Symbol Ann
ttype2to1 = type2to1' reference2to1
@ -406,30 +397,28 @@ causalbranch2to1 branchCache lookupCT cb = do
pure b
causalbranch2to1' :: Monad m => BranchCache m -> (V2.Reference -> m CT.ConstructorType) -> V2.Branch.CausalBranch m -> m (V1.Branch.UnwrappedBranch m)
causalbranch2to1' branchCache lookupCT (V2.Causal hc eh (Map.toList -> parents) me) = do
let currentHash = causalHash2to1 hc
branchHash = branchHash2to1 eh
causalbranch2to1' branchCache lookupCT (V2.Causal currentHash eh (Map.toList -> parents) me) = do
let branchHash = branchHash2to1 eh
case parents of
[] -> V1.Causal.UnsafeOne currentHash branchHash <$> (me >>= branch2to1 branchCache lookupCT)
[(hp, mp)] -> do
let parentHash = causalHash2to1 hp
[(parentHash, mp)] -> do
V1.Causal.UnsafeCons currentHash branchHash
<$> (me >>= branch2to1 branchCache lookupCT)
<*> pure (parentHash, causalbranch2to1' branchCache lookupCT =<< mp)
merge -> do
let tailsList = map (bimap causalHash2to1 (causalbranch2to1' branchCache lookupCT =<<)) merge
let tailsList = map (fmap (causalbranch2to1' branchCache lookupCT =<<)) merge
e <- me
V1.Causal.UnsafeMerge currentHash branchHash <$> branch2to1 branchCache lookupCT e <*> pure (Map.fromList tailsList)
causalbranch1to2 :: forall m. Monad m => V1.Branch.Branch m -> V2.Branch.CausalBranch m
causalbranch1to2 (V1.Branch.Branch c) =
causal1to2 causalHash1to2 branchHash1to2 branch1to2 c
causal1to2 branchHash1to2 branch1to2 c
where
causal1to2 :: forall m h2c h2e e e2. (Monad m, Ord h2c) => (V1.Causal.CausalHash -> h2c) -> (V1.HashFor e -> h2e) -> (e -> m e2) -> V1.Causal.Causal m e -> V2.Causal m h2c h2e e2
causal1to2 h1to2 eh1to2 e1to2 = \case
V1.Causal.One hc eh e -> V2.Causal (h1to2 hc) (eh1to2 eh) Map.empty (e1to2 e)
V1.Causal.Cons hc eh e (ht, mt) -> V2.Causal (h1to2 hc) (eh1to2 eh) (Map.singleton (h1to2 ht) (causal1to2 h1to2 eh1to2 e1to2 <$> mt)) (e1to2 e)
V1.Causal.Merge hc eh e parents -> V2.Causal (h1to2 hc) (eh1to2 eh) (Map.bimap h1to2 (causal1to2 h1to2 eh1to2 e1to2 <$>) parents) (e1to2 e)
causal1to2 :: forall m h2e e e2. Monad m => (V1.HashFor e -> h2e) -> (e -> m e2) -> V1.Causal.Causal m e -> V2.Causal m CausalHash h2e e2
causal1to2 eh1to2 e1to2 = \case
V1.Causal.One hc eh e -> V2.Causal hc (eh1to2 eh) Map.empty (e1to2 e)
V1.Causal.Cons hc eh e (ht, mt) -> V2.Causal hc (eh1to2 eh) (Map.singleton ht (causal1to2 eh1to2 e1to2 <$> mt)) (e1to2 e)
V1.Causal.Merge hc eh e parents -> V2.Causal hc (eh1to2 eh) (Map.map (causal1to2 eh1to2 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)
@ -442,10 +431,10 @@ causalbranch1to2 (V1.Branch.Branch c) =
(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))
doTerms :: V1.Branch.Star V1.Referent.Referent NameSegment -> Map NameSegment (Map V2.Referent.Referent (m V2.Branch.MdValues))
doTerms s =
Map.fromList
[ (namesegment1to2 ns, m2)
[ (ns, m2)
| ns <- toList . Relation.ran $ V1.Star3.d1 s,
let m2 =
Map.fromList
@ -456,10 +445,10 @@ causalbranch1to2 (V1.Branch.Branch c) =
]
]
doTypes :: V1.Branch.Star V1.Reference.Reference V1.NameSegment -> Map V2.Branch.NameSegment (Map V2.Reference.Reference (m V2.Branch.MdValues))
doTypes :: V1.Branch.Star V1.Reference.Reference NameSegment -> Map NameSegment (Map V2.Reference.Reference (m V2.Branch.MdValues))
doTypes s =
Map.fromList
[ (namesegment1to2 ns, m2)
[ (ns, m2)
| ns <- toList . Relation.ran $ V1.Star3.d1 s,
let m2 =
Map.fromList
@ -470,11 +459,11 @@ causalbranch1to2 (V1.Branch.Branch c) =
]
]
doPatches :: Map V1.NameSegment (V1.Branch.EditHash, m V1.Patch) -> Map V2.Branch.NameSegment (V2.PatchHash, m V2.Branch.Patch)
doPatches = Map.bimap namesegment1to2 (bimap edithash1to2 (fmap patch1to2))
doPatches :: Map NameSegment (PatchHash, m V1.Patch) -> Map NameSegment (PatchHash, m V2.Branch.Patch)
doPatches = Map.map (fmap (fmap patch1to2))
doChildren :: Map V1.NameSegment (V1.Branch.Branch m) -> Map V2.Branch.NameSegment (V2.Branch.CausalBranch m)
doChildren = Map.bimap namesegment1to2 causalbranch1to2
doChildren :: Map NameSegment (V1.Branch.Branch m) -> Map NameSegment (V2.Branch.CausalBranch m)
doChildren = Map.map causalbranch1to2
patch2to1 :: V2.Branch.Patch -> V1.Patch
patch2to1 (V2.Branch.Patch v2termedits v2typeedits) =
@ -519,18 +508,6 @@ patch1to2 (V1.Patch v1termedits v1typeedits) = V2.Branch.Patch v2termedits v2typ
V1.TermEdit.Subtype -> V2.TermEdit.Subtype
V1.TermEdit.Different -> V2.TermEdit.Different
edithash2to1 :: V2.PatchHash -> V1.Branch.EditHash
edithash2to1 = V2.unPatchHash
edithash1to2 :: V1.Branch.EditHash -> V2.PatchHash
edithash1to2 = V2.PatchHash
namesegment2to1 :: V2.Branch.NameSegment -> V1.NameSegment
namesegment2to1 (V2.Branch.NameSegment t) = V1.NameSegment t
namesegment1to2 :: V1.NameSegment -> V2.Branch.NameSegment
namesegment1to2 (V1.NameSegment t) = V2.Branch.NameSegment t
branch2to1 ::
Monad m =>
BranchCache m ->
@ -538,12 +515,12 @@ branch2to1 ::
V2.Branch.Branch m ->
m (V1.Branch.Branch0 m)
branch2to1 branchCache 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 branchCache lookupCT) v2children
v1terms <- toStar reference2to1 <$> traverse (Map.bitraverse (referent2to1 lookupCT) id) v2terms
v1types <- toStar reference2to1 <$> traverse (Map.bitraverse (pure . reference2to1) id) v2types
v1children <- traverse (causalbranch2to1 branchCache lookupCT) v2children
pure $ V1.Branch.branch0 v1terms v1types v1children v1patches
where
v1patches = Map.bimap namesegment2to1 (bimap edithash2to1 (fmap patch2to1)) v2patches
v1patches = Map.map (fmap (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

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

@ -20,7 +20,7 @@ import qualified Data.Text as Text
import qualified U.Codebase.Branch as V2Branch
import qualified U.Codebase.Branch.Diff as BranchDiff
import qualified U.Codebase.Causal as V2Causal
import U.Codebase.HashTags (BranchHash, CausalHash (unCausalHash))
import U.Codebase.HashTags (BranchHash, CausalHash (unCausalHash), PatchHash)
import qualified U.Codebase.Reference as C.Reference
import qualified U.Codebase.Referent as C.Referent
import U.Codebase.Sqlite.DbId (ObjectId)
@ -29,16 +29,13 @@ import qualified U.Codebase.Sqlite.ObjectType as OT
import U.Codebase.Sqlite.Operations (NamesByPath (..))
import qualified U.Codebase.Sqlite.Operations as Ops
import qualified U.Codebase.Sqlite.Queries as Q
import U.Codebase.Sqlite.V2.Decl (saveDeclComponent)
import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle)
import U.Codebase.Sqlite.V2.Term (saveTermComponent)
import qualified U.Util.Cache as Cache
import qualified U.Util.Hash as H2
import qualified Unison.Builtin as Builtins
import Unison.Codebase.Branch (Branch (..))
import qualified Unison.Codebase.Branch as Branch
import qualified Unison.Codebase.Branch.Names as V1Branch
import qualified Unison.Codebase.Causal.Type as Causal
import Unison.Codebase.Patch (Patch)
import Unison.Codebase.Path (Path)
import qualified Unison.Codebase.Path as Path
@ -296,7 +293,7 @@ tryFlushTermBuffer termBuffer =
let loop h =
tryFlushBuffer
termBuffer
(\h2 component -> void $ saveTermComponent Nothing h2 (Cv.termComponent1to2 h component))
(\h2 component -> void $ Q.saveTermComponent v2HashHandle Nothing h2 (Cv.termComponent1to2 h component))
loop
h
in loop
@ -367,7 +364,8 @@ tryFlushDeclBuffer termBuffer declBuffer =
declBuffer
( \h2 component ->
void $
saveDeclComponent
Q.saveDeclComponent
v2HashHandle
Nothing
h2
(fmap (Cv.decl1to2 h) component)
@ -401,10 +399,10 @@ getBranchForHash ::
-- | A 'getDeclType'-like lookup, possibly backed by a cache.
BranchCache Sqlite.Transaction ->
(C.Reference.Reference -> Transaction CT.ConstructorType) ->
Branch.CausalHash ->
CausalHash ->
Transaction (Maybe (Branch Transaction))
getBranchForHash branchCache doGetDeclType h = do
Ops.loadCausalBranchByCausalHash (Cv.causalHash1to2 h) >>= \case
Ops.loadCausalBranchByCausalHash h >>= \case
Nothing -> pure Nothing
Just causal2 -> do
branch1 <- Cv.causalbranch2to1 branchCache doGetDeclType causal2
@ -415,29 +413,29 @@ putBranch =
void . Ops.saveBranch v2HashHandle . Cv.causalbranch1to2
-- | Check whether the given branch exists in the codebase.
branchExists :: Branch.CausalHash -> Transaction Bool
branchExists (Causal.CausalHash h) =
Q.loadHashIdByHash h >>= \case
branchExists :: CausalHash -> Transaction Bool
branchExists h =
Q.loadHashIdByHash (unCausalHash h) >>= \case
Nothing -> pure False
Just hId -> Q.isCausalHash hId
getPatch :: Branch.EditHash -> Transaction (Maybe Patch)
getPatch :: PatchHash -> Transaction (Maybe Patch)
getPatch h =
runMaybeT do
patchId <- MaybeT (Q.loadPatchObjectIdForPrimaryHash (Cv.patchHash1to2 h))
patchId <- MaybeT (Q.loadPatchObjectIdForPrimaryHash h)
patch <- lift (Ops.expectPatch patchId)
pure (Cv.patch2to1 patch)
-- | Put a patch into the codebase.
--
-- Note that 'putBranch' may also put patches.
putPatch :: Branch.EditHash -> Patch -> Transaction ()
putPatch :: PatchHash -> Patch -> Transaction ()
putPatch h p =
void $ Ops.savePatch v2HashHandle (Cv.patchHash1to2 h) (Cv.patch1to2 p)
void $ Ops.savePatch v2HashHandle h (Cv.patch1to2 p)
-- | Check whether the given patch exists in the codebase.
patchExists :: Branch.EditHash -> Transaction Bool
patchExists h = fmap isJust $ Q.loadPatchObjectIdForPrimaryHash (Cv.patchHash1to2 h)
patchExists :: PatchHash -> Transaction Bool
patchExists h = fmap isJust $ Q.loadPatchObjectIdForPrimaryHash h
dependentsImpl :: Q.DependentsSelector -> Reference -> Transaction (Set Reference.Id)
dependentsImpl selector r =
@ -555,22 +553,12 @@ referentsByPrefix doGetDeclType (SH.ShortHash prefix (fmap Cv.shortHashSuffix1to
pure . Set.fromList $ termReferents <> declReferents
-- | Get the set of branches whose hash matches the given prefix.
causalHashesByPrefix :: ShortCausalHash -> Transaction (Set Branch.CausalHash)
causalHashesByPrefix :: ShortCausalHash -> Transaction (Set CausalHash)
causalHashesByPrefix sh = do
-- given that a Branch is shallow, it's really `CausalHash` that you'd
-- refer to to specify a full namespace w/ history.
-- but do we want to be able to refer to a namespace without its history?
cs <- Ops.causalHashesByPrefix (Cv.sch1to2 sh)
pure $ Set.map (Causal.CausalHash . unCausalHash) cs
-- returns `Nothing` to not implemented, fallback to in-memory
-- also `Nothing` if no LCA
-- The result is undefined if the two hashes are not in the codebase.
-- Use `Codebase.lca` which wraps this in a nice API.
sqlLca :: Branch.CausalHash -> Branch.CausalHash -> Transaction (Maybe Branch.CausalHash)
sqlLca h1 h2 = do
h3 <- Ops.lca (Cv.causalHash1to2 h1) (Cv.causalHash1to2 h2)
pure (Cv.causalHash2to1 <$> h3)
Ops.causalHashesByPrefix (Cv.sch1to2 sh)
-- well one or the other. :zany_face: the thinking being that they wouldn't hash-collide
termExists, declExists :: Hash -> Transaction Bool
@ -578,9 +566,9 @@ termExists = fmap isJust . Q.loadObjectIdForPrimaryHash
declExists = termExists
-- `before b1 b2` is undefined if `b2` not in the codebase
before :: Branch.CausalHash -> Branch.CausalHash -> Transaction Bool
before :: CausalHash -> CausalHash -> Transaction Bool
before h1 h2 =
fromJust <$> Ops.before (Cv.causalHash1to2 h1) (Cv.causalHash1to2 h2)
fromJust <$> Ops.before h1 h2
-- | Construct a 'ScopedNames' which can produce names which are relative to the provided
-- Path.
@ -588,35 +576,30 @@ before h1 h2 =
-- NOTE: this method requires an up-to-date name lookup index, which is
-- currently not kept up-to-date automatically (because it's slow to do so).
namesAtPath ::
-- Include ALL names within this path
Path ->
-- Make names within this path relative to this path, other names will be absolute.
Path ->
Transaction ScopedNames
namesAtPath path = do
let namespace = if path == Path.empty then Nothing else Just $ tShow path
NamesByPath {termNamesInPath, termNamesExternalToPath, typeNamesInPath, typeNamesExternalToPath} <- Ops.rootNamesByPath namespace
namesAtPath namesRootPath relativeToPath = do
let namesRoot = if namesRootPath == Path.empty then Nothing else Just $ tShow namesRootPath
NamesByPath {termNamesInPath, typeNamesInPath} <- Ops.rootNamesByPath namesRoot
let termsInPath = convertTerms termNamesInPath
let typesInPath = convertTypes typeNamesInPath
let termsOutsidePath = convertTerms termNamesExternalToPath
let typesOutsidePath = convertTypes typeNamesExternalToPath
let allTerms :: [(Name, Referent.Referent)]
allTerms = termsInPath <> termsOutsidePath
let allTypes :: [(Name, Reference.Reference)]
allTypes = typesInPath <> typesOutsidePath
let rootTerms = Rel.fromList allTerms
let rootTypes = Rel.fromList allTypes
let rootTerms = Rel.fromList termsInPath
let rootTypes = Rel.fromList typesInPath
let absoluteRootNames = Names.makeAbsolute $ Names {terms = rootTerms, types = rootTypes}
let absoluteExternalNames = Names.makeAbsolute $ Names {terms = Rel.fromList termsOutsidePath, types = Rel.fromList typesOutsidePath}
let relativeScopedNames =
case path of
case relativeToPath of
Path.Empty -> (Names.makeRelative $ absoluteRootNames)
p ->
let reversedPathSegments = reverse . Path.toList $ p
relativeTerms = stripPathPrefix reversedPathSegments <$> termsInPath
relativeTypes = stripPathPrefix reversedPathSegments <$> typesInPath
relativeTerms = mapMaybe (stripPathPrefix reversedPathSegments) termsInPath
relativeTypes = mapMaybe (stripPathPrefix reversedPathSegments) typesInPath
in (Names {terms = Rel.fromList relativeTerms, types = Rel.fromList relativeTypes})
pure $
ScopedNames
{ absoluteExternalNames,
relativeScopedNames,
{ relativeScopedNames,
absoluteRootNames
}
where
@ -632,11 +615,11 @@ namesAtPath path = do
-- on the left, otherwise it's left as-is and collected on the right.
-- >>> stripPathPrefix ["b", "a"] ("a.b.c", ())
-- ([(c,())])
stripPathPrefix :: [NameSegment] -> (Name, r) -> (Name, r)
stripPathPrefix :: [NameSegment] -> (Name, r) -> Maybe (Name, r)
stripPathPrefix reversedPathSegments (n, ref) =
case Name.stripReversedPrefix n reversedPathSegments of
Nothing -> error $ "Expected name to be in namespace" <> show (n, reverse reversedPathSegments)
Just stripped -> (Name.makeRelative stripped, ref)
Nothing -> Nothing
Just stripped -> Just (Name.makeRelative stripped, ref)
-- | Update the root namespace names index which is used by the share server for serving api
-- requests.
@ -739,7 +722,7 @@ initializeNameLookupIndexFromV2Root getDeclType = do
-- Collects two maps, one with all term names and one with all type names.
-- Note that unlike the `Name` type in `unison-core1`, this list of name segments is
-- in reverse order, e.g. `["map", "List", "base"]`
nameMapsFromV2Branch :: Monad m => [V2Branch.NameSegment] -> V2Branch.CausalBranch m -> m (Map (NonEmpty V2Branch.NameSegment) (Set C.Referent.Referent), Map (NonEmpty V2Branch.NameSegment) (Set C.Reference.Reference))
nameMapsFromV2Branch :: Monad m => [NameSegment] -> V2Branch.CausalBranch m -> m (Map (NonEmpty NameSegment) (Set C.Referent.Referent), Map (NonEmpty NameSegment) (Set C.Reference.Reference))
nameMapsFromV2Branch reversedNamePrefix cb = do
b <- V2Causal.value cb
let (shallowTermNames, shallowTypeNames) = (Map.keysSet <$> V2Branch.terms b, Map.keysSet <$> V2Branch.types b)

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

@ -13,10 +13,9 @@ module Unison.Codebase.Type
)
where
import U.Codebase.HashTags (BranchHash)
import U.Codebase.HashTags (BranchHash, CausalHash)
import qualified U.Codebase.Reference as V2
import Unison.Codebase.Branch (Branch)
import qualified Unison.Codebase.Branch as Branch
import qualified Unison.Codebase.Editor.Git as Git
import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadGitRepo, WriteGitRepo)
import Unison.Codebase.GitError (GitCodebaseError, GitProtocolError)
@ -50,7 +49,7 @@ data Codebase m v a = Codebase
--
-- Note that it is possible to call 'putTerm', then 'getTerm', and receive @Nothing@, per the semantics of
-- 'putTerm'.
getTerm :: Reference.Id -> m (Maybe (Term v a)),
getTerm :: Reference.Id -> Sqlite.Transaction (Maybe (Term v a)),
-- | Get the type of a user-defined term.
--
-- Note that it is possible to call 'putTerm', then 'getTypeOfTermImpl', and receive @Nothing@, per the semantics of
@ -81,7 +80,7 @@ data Codebase m v a = Codebase
Text -> -- Reason for the change, will be recorded in the reflog
Branch m ->
m (),
getBranchForHashImpl :: Branch.CausalHash -> m (Maybe (Branch m)),
getBranchForHashImpl :: CausalHash -> m (Maybe (Branch m)),
-- | Put a branch into the codebase, which includes its children, its patches, and the branch itself, if they don't
-- already exist.
--
@ -101,7 +100,7 @@ data Codebase m v a = Codebase
-- | Get the set of user-defined terms-or-constructors mention the given type anywhere in their signature.
termsMentioningTypeImpl :: Reference -> Sqlite.Transaction (Set Referent.Id),
-- | Get the set of user-defined terms-or-constructors whose hash matches the given prefix.
termReferentsByPrefix :: ShortHash -> m (Set Referent.Id),
termReferentsByPrefix :: ShortHash -> Sqlite.Transaction (Set Referent.Id),
-- Updates the root namespace names index from an old BranchHash to a new one.
-- This isn't run automatically because it can be a bit slow.
updateNameLookup ::
@ -144,7 +143,7 @@ data GitPushBehavior
data GitError
= GitProtocolError GitProtocolError
| GitCodebaseError (GitCodebaseError Branch.CausalHash)
| GitCodebaseError (GitCodebaseError CausalHash)
| GitSqliteCodebaseError GitSqliteCodebaseError
deriving (Show)

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

@ -28,9 +28,9 @@ import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import U.Codebase.HashTags (CausalHash (..), PatchHash (..))
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
@ -349,12 +349,12 @@ hashPatch = contentHash . m2hPatch
hashBranch0 :: Memory.Branch.Branch0 m -> Hash
hashBranch0 = contentHash . m2hBranch0
hashCausal :: ContentAddressable e => e -> Set Memory.Causal.CausalHash -> (Memory.Causal.CausalHash, HashFor e)
hashCausal :: ContentAddressable e => e -> Set CausalHash -> (CausalHash, HashFor e)
hashCausal e tails =
let valueHash = contentHash e
causalHash =
Memory.Causal.CausalHash . contentHash $
Hashing.Causal valueHash (Set.map Memory.Causal.unCausalHash tails)
CausalHash . contentHash $
Hashing.Causal valueHash (Set.map unCausalHash tails)
in (causalHash, HashFor valueHash)
m2hBranch0 :: Memory.Branch.Branch0 m -> Hashing.Branch
@ -400,14 +400,14 @@ m2hBranch0 b =
]
doPatches ::
Map Memory.NameSegment.NameSegment (Memory.Branch.EditHash, m Memory.Patch.Patch) ->
Map Memory.NameSegment.NameSegment (PatchHash, m Memory.Patch.Patch) ->
Map Hashing.NameSegment Hash
doPatches = Map.bimap m2hNameSegment fst
doPatches = Map.bimap m2hNameSegment (unPatchHash . fst)
doChildren ::
Map Memory.NameSegment.NameSegment (Memory.Branch.Branch m) ->
Map Hashing.NameSegment Hash
doChildren = Map.bimap m2hNameSegment (Memory.Causal.unCausalHash . Memory.Branch.headHash)
doChildren = Map.bimap m2hNameSegment (unCausalHash . Memory.Branch.headHash)
m2hNameSegment :: Memory.NameSegment.NameSegment -> Hashing.NameSegment
m2hNameSegment (Memory.NameSegment.NameSegment s) = Hashing.NameSegment s

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

@ -24,6 +24,7 @@ flag optimized
library
exposed-modules:
U.Codebase.Branch.Diff
U.Codebase.Projects
Unison.Builtin
Unison.Builtin.Decls
Unison.Builtin.Terms

1
unison-cli/package.yaml
View File

@ -70,6 +70,7 @@ dependencies:
- unison-codebase
- unison-codebase-sqlite
- unison-codebase-sqlite-hashing-v2
- unison-core
- unison-core1
- unison-hash
- unison-parser-typechecker

6
unison-cli/src/Unison/Cli/Monad.hs
View File

@ -60,7 +60,7 @@ import Data.Unique (Unique, newUnique)
import GHC.OverloadedLabels (IsLabel (..))
import System.CPUTime (getCPUTime)
import Text.Printf (printf)
import qualified U.Codebase.Branch as V2Branch
import U.Codebase.HashTags (CausalHash)
import Unison.Auth.CredentialManager (CredentialManager)
import Unison.Auth.HTTPClient (AuthenticatedHttpClient)
import Unison.Codebase (Codebase)
@ -166,7 +166,7 @@ data Env = Env
-- There's an additional pseudo @"currentPath"@ field lens, for convenience.
data LoopState = LoopState
{ root :: TMVar (Branch IO),
lastSavedRootHash :: V2Branch.CausalHash,
lastSavedRootHash :: CausalHash,
-- the current position in the namespace
currentPathStack :: List.NonEmpty Path.Absolute,
-- TBD
@ -204,7 +204,7 @@ instance
)
-- | Create an initial loop state given a root branch and the current path.
loopState0 :: V2Branch.CausalHash -> TMVar (Branch IO) -> Path.Absolute -> LoopState
loopState0 :: CausalHash -> TMVar (Branch IO) -> Path.Absolute -> LoopState
loopState0 lastSavedRootHash b p = do
LoopState
{ root = b,

11
unison-cli/src/Unison/Cli/MonadUtils.hs
View File

@ -80,13 +80,13 @@ import qualified Data.Configurator.Types as Configurator
import qualified Data.Set as Set
import qualified U.Codebase.Branch as V2Branch
import qualified U.Codebase.Causal as V2Causal
import U.Codebase.HashTags (CausalHash (..))
import Unison.Cli.Monad (Cli)
import qualified Unison.Cli.Monad as Cli
import qualified Unison.Codebase as Codebase
import Unison.Codebase.Branch (Branch (..), Branch0 (..))
import qualified Unison.Codebase.Branch as Branch
import qualified Unison.Codebase.BranchUtil as BranchUtil
import qualified Unison.Codebase.Causal as Causal
import qualified Unison.Codebase.Editor.Input as Input
import qualified Unison.Codebase.Editor.Output as Output
import Unison.Codebase.Patch (Patch (..))
@ -95,7 +95,6 @@ import Unison.Codebase.Path (Path, Path' (..))
import qualified Unison.Codebase.Path as Path
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
import qualified Unison.Codebase.ShortCausalHash as SCH
import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv
import qualified Unison.HashQualified' as HQ'
import Unison.NameSegment (NameSegment)
import Unison.Parser.Ann (Ann (..))
@ -147,7 +146,7 @@ resolveAbsBranchId = \case
-- | Resolve a @BranchId@ to the corresponding @Branch IO@, or fail if no such branch hash is found. (Non-existent
-- branches by path are OK - the empty branch will be returned).
resolveBranchId :: Input.BranchId -> Cli (Branch IO)
resolveBranchId :: Input.BranchId -> Cli (Branch IO)
resolveBranchId branchId = do
absBranchId <- traverseOf _Right resolvePath' branchId
resolveAbsBranchId absBranchId
@ -212,13 +211,13 @@ getCurrentBranch0 = do
Branch.head <$> getCurrentBranch
-- | Get the last saved root hash.
getLastSavedRootHash :: Cli V2Branch.CausalHash
getLastSavedRootHash :: Cli CausalHash
getLastSavedRootHash = do
use #lastSavedRootHash
-- | Set a new root branch.
-- Note: This does _not_ update the codebase, the caller is responsible for that.
setLastSavedRootHash :: V2Branch.CausalHash -> Cli ()
setLastSavedRootHash :: CausalHash -> Cli ()
setLastSavedRootHash ch = do
#lastSavedRootHash .= ch
@ -384,7 +383,7 @@ updateRoot :: Branch IO -> Text -> Cli ()
updateRoot new reason =
Cli.time "updateRoot" do
Cli.Env {codebase} <- ask
let newHash = Cv.causalHash1to2 $ Branch.headHash new
let newHash = Branch.headHash new
oldHash <- getLastSavedRootHash
when (oldHash /= newHash) do
setRootBranch new

86
unison-cli/src/Unison/Codebase/Editor/HandleInput.hs
View File

@ -118,7 +118,6 @@ import Unison.Codebase.PushBehavior (PushBehavior)
import qualified Unison.Codebase.PushBehavior as PushBehavior
import qualified Unison.Codebase.Runtime as Runtime
import qualified Unison.Codebase.ShortCausalHash as SCH
import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv
import qualified Unison.Codebase.SyncMode as SyncMode
import Unison.Codebase.TermEdit (TermEdit (..))
import qualified Unison.Codebase.TermEdit as TermEdit
@ -565,7 +564,7 @@ loop e = do
history <- liftIO (doHistory schLength 0 branch [])
Cli.respondNumbered history
where
doHistory :: Int -> Int -> Branch IO -> [(Causal.CausalHash, NamesWithHistory.Diff)] -> IO NumberedOutput
doHistory :: Int -> Int -> Branch IO -> [(CausalHash, NamesWithHistory.Diff)] -> IO NumberedOutput
doHistory schLength !n b acc =
if maybe False (n >=) resultsCap
then pure (History diffCap schLength acc (PageEnd (Branch.headHash b) n))
@ -604,7 +603,7 @@ loop e = do
src <- traverseOf _Right Cli.resolveSplit' src'
srcTerms <-
either
(liftIO . Backend.termReferentsByShortHash codebase)
(Cli.runTransaction . Backend.termReferentsByShortHash codebase)
Cli.getTermsAt
src
srcTerm <-
@ -1288,23 +1287,24 @@ loop e = do
rootBranch <- Cli.getRootBranch
for_ lds \ld -> do
dependencies :: Set Reference <-
let tp r@(Reference.DerivedId i) =
Codebase.getTypeDeclaration codebase i <&> \case
Nothing -> error $ "What happened to " ++ show i ++ "?"
Just decl -> Set.delete r . DD.dependencies $ DD.asDataDecl decl
tp _ = pure mempty
tm (Referent.Ref r@(Reference.DerivedId i)) =
liftIO (Codebase.getTerm codebase i) <&> \case
Nothing -> error $ "What happened to " ++ show i ++ "?"
Just tm -> Set.delete r $ Term.dependencies tm
tm con@(Referent.Con (ConstructorReference (Reference.DerivedId i) cid) _ct) =
Cli.runTransaction (Codebase.getTypeDeclaration codebase i) <&> \case
Nothing -> error $ "What happened to " ++ show i ++ "?"
Just decl -> case DD.typeOfConstructor (DD.asDataDecl decl) cid of
Nothing -> error $ "What happened to " ++ show con ++ "?"
Just tp -> Type.dependencies tp
tm _ = pure mempty
in LD.fold (Cli.runTransaction . tp) tm ld
Cli.runTransaction do
let tp r@(Reference.DerivedId i) =
Codebase.getTypeDeclaration codebase i <&> \case
Nothing -> error $ "What happened to " ++ show i ++ "?"
Just decl -> Set.delete r . DD.dependencies $ DD.asDataDecl decl
tp _ = pure mempty
tm (Referent.Ref r@(Reference.DerivedId i)) =
Codebase.getTerm codebase i <&> \case
Nothing -> error $ "What happened to " ++ show i ++ "?"
Just tm -> Set.delete r $ Term.dependencies tm
tm con@(Referent.Con (ConstructorReference (Reference.DerivedId i) cid) _ct) =
Codebase.getTypeDeclaration codebase i <&> \case
Nothing -> error $ "What happened to " ++ show i ++ "?"
Just decl -> case DD.typeOfConstructor (DD.asDataDecl decl) cid of
Nothing -> error $ "What happened to " ++ show con ++ "?"
Just tp -> Type.dependencies tp
tm _ = pure mempty
in LD.fold tp tm ld
(missing, names0) <- liftIO (Branch.findHistoricalRefs' dependencies rootBranch)
let types = R.toList $ Names.types names0
let terms = fmap (second Referent.toReference) $ R.toList $ Names.terms names0
@ -1312,11 +1312,13 @@ loop e = do
#numberedArgs .= fmap (Text.unpack . Reference.toText) ((fmap snd names) <> toList missing)
Cli.respond $ ListDependencies hqLength ld names missing
NamespaceDependenciesI namespacePath' -> do
Cli.Env {codebase} <- ask
path <- maybe Cli.getCurrentPath Cli.resolvePath' namespacePath'
Cli.getMaybeBranchAt path >>= \case
Nothing -> Cli.respond $ BranchEmpty (Right (Path.absoluteToPath' path))
Just b -> do
externalDependencies <- NamespaceDependencies.namespaceDependencies (Branch.head b)
externalDependencies <-
Cli.runTransaction (NamespaceDependencies.namespaceDependencies codebase (Branch.head b))
ppe <- PPE.unsuffixifiedPPE <$> currentPrettyPrintEnvDecl Backend.Within
Cli.respond $ ListNamespaceDependencies ppe path externalDependencies
DebugNumberedArgsI -> do
@ -1340,7 +1342,7 @@ loop e = do
let seen h = State.gets (Set.member h)
set h = State.modify (Set.insert h)
getCausal b = (Branch.headHash b, pure $ Branch._history b)
goCausal :: forall m. Monad m => [(Branch.CausalHash, m (Branch.UnwrappedBranch m))] -> StateT (Set Branch.CausalHash) m ()
goCausal :: forall m. Monad m => [(CausalHash, m (Branch.UnwrappedBranch m))] -> StateT (Set CausalHash) m ()
goCausal [] = pure ()
goCausal ((h, mc) : queue) = do
ifM (seen h) (goCausal queue) do
@ -1348,7 +1350,7 @@ loop e = do
Causal.One h _bh b -> goBranch h b mempty queue
Causal.Cons h _bh b tail -> goBranch h b [fst tail] (tail : queue)
Causal.Merge h _bh b (Map.toList -> tails) -> goBranch h b (map fst tails) (tails ++ queue)
goBranch :: forall m. Monad m => Branch.CausalHash -> Branch0 m -> [Branch.CausalHash] -> [(Branch.CausalHash, m (Branch.UnwrappedBranch m))] -> StateT (Set Branch.CausalHash) m ()
goBranch :: forall m. Monad m => CausalHash -> Branch0 m -> [CausalHash] -> [(CausalHash, m (Branch.UnwrappedBranch m))] -> StateT (Set CausalHash) m ()
goBranch h b (Set.fromList -> causalParents) queue = case b of
Branch0 terms0 types0 children0 patches0 _ _ _ _ _ _ _ ->
let wrangleMetadata :: (Ord r, Ord n) => Metadata.Star r n -> r -> (r, (Set n, Set Metadata.Value))
@ -1408,8 +1410,8 @@ loop e = do
([fromCH], [toCH]) -> pure (fromCH, toCH)
output <-
Cli.runTransaction do
fromBranch <- (Codebase.expectCausalBranchByCausalHash $ Cv.causalHash1to2 fromCH) >>= V2Causal.value
toBranch <- (Codebase.expectCausalBranchByCausalHash $ Cv.causalHash1to2 toCH) >>= V2Causal.value
fromBranch <- (Codebase.expectCausalBranchByCausalHash fromCH) >>= V2Causal.value
toBranch <- (Codebase.expectCausalBranchByCausalHash toCH) >>= V2Causal.value
treeDiff <- V2Branch.diffBranches fromBranch toBranch
let nameChanges = V2Branch.nameChanges Nothing treeDiff
pure (DisplayDebugNameDiff nameChanges)
@ -2071,7 +2073,7 @@ handleShowDefinition outputLoc showDefinitionScope inputQuery = do
pure (currentNames, ppe)
Backend.DefinitionResults terms types misses <- do
let nameSearch = Backend.makeNameSearch hqLength names
liftIO (Backend.definitionsBySuffixes codebase nameSearch includeCycles query)
Cli.runTransaction (Backend.definitionsBySuffixes codebase nameSearch includeCycles query)
outputPath <- getOutputPath
when (not (null types && null terms)) do
let ppe = PPED.biasTo (mapMaybe HQ.toName inputQuery) unbiasedPPE
@ -2153,7 +2155,7 @@ handleTest TestInput {includeLibNamespace, showFailures, showSuccesses} = do
computedTests <- fmap join . for (toList toCompute `zip` [1 ..]) $ \(r, n) ->
case r of
Reference.DerivedId rid ->
liftIO (Codebase.getTerm codebase rid) >>= \case
Cli.runTransaction (Codebase.getTerm codebase rid) >>= \case
Nothing -> do
hqLength <- Cli.runTransaction Codebase.hashLength
Cli.respond (TermNotFound' . SH.take hqLength . Reference.toShortHash $ Reference.DerivedId rid)
@ -2264,7 +2266,7 @@ importRemoteShareBranch rrn@(ReadShareRemoteNamespace {server, repo, path}) = do
(Cli.returnEarly . Output.ShareError) case err0 of
Share.SyncError err -> Output.ShareErrorPull err
Share.TransportError err -> Output.ShareErrorTransport err
liftIO (Codebase.getBranchForHash codebase (Cv.causalHash2to1 causalHash)) & onNothingM do
liftIO (Codebase.getBranchForHash codebase causalHash) & onNothingM do
error $ reportBug "E412939" "`pull` \"succeeded\", but I can't find the result in the codebase. (This is a bug.)"
where
-- Provide the given action a callback that display to the terminal.
@ -2300,8 +2302,11 @@ resolveHQToLabeledDependencies = \case
where
resolveHashOnly sh = do
Cli.Env {codebase} <- ask
terms <- liftIO (Backend.termReferentsByShortHash codebase sh)
types <- Cli.runTransaction (Backend.typeReferencesByShortHash sh)
(terms, types) <-
Cli.runTransaction do
terms <- Backend.termReferentsByShortHash codebase sh
types <- Backend.typeReferencesByShortHash sh
pure (terms, types)
pure $ Set.map LD.referent terms <> Set.map LD.typeRef types
doDisplay :: OutputLocation -> NamesWithHistory -> Term Symbol () -> Cli ()
@ -2320,23 +2325,23 @@ doDisplay outputLoc names tm = do
fmap ErrorUtil.hush . fmap (fmap Term.unannotate) $
evalUnisonTermE True (PPE.suffixifiedPPE ppe) useCache (Term.amap (const External) tm)
loadTerm (Reference.DerivedId r) = case Map.lookup r tms of
Nothing -> fmap (fmap Term.unannotate) $ liftIO (Codebase.getTerm codebase r)
Nothing -> fmap (fmap Term.unannotate) $ Cli.runTransaction (Codebase.getTerm codebase r)
Just (tm, _) -> pure (Just $ Term.unannotate tm)
loadTerm _ = pure Nothing
loadDecl (Reference.DerivedId r) = case Map.lookup r typs of
Nothing -> fmap (fmap $ DD.amap (const ())) $ Codebase.getTypeDeclaration codebase r
Nothing -> fmap (fmap $ DD.amap (const ())) $ Cli.runTransaction $ Codebase.getTypeDeclaration codebase r
Just decl -> pure (Just $ DD.amap (const ()) decl)
loadDecl _ = pure Nothing
loadTypeOfTerm' (Referent.Ref (Reference.DerivedId r))
| Just (_, ty) <- Map.lookup r tms = pure $ Just (void ty)
loadTypeOfTerm' r = fmap (fmap void) . loadTypeOfTerm codebase $ r
loadTypeOfTerm' r = fmap (fmap void) . Cli.runTransaction . loadTypeOfTerm codebase $ r
rendered <-
DisplayValues.displayTerm
ppe
(liftIO . loadTerm)
(Cli.runTransaction . loadTypeOfTerm')
loadTerm
loadTypeOfTerm'
evalTerm
(Cli.runTransaction . loadDecl)
loadDecl
tm
Cli.respond $ DisplayRendered loc rendered
@ -3197,10 +3202,11 @@ hqNameQuery query = do
Cli.Env {codebase} <- ask
root' <- Cli.getRootBranch
currentPath <- Cli.getCurrentPath
hqLength <- Cli.runTransaction Codebase.hashLength
let parseNames = Backend.parseNamesForBranch root' (Backend.AllNames (Path.unabsolute currentPath))
let nameSearch = Backend.makeNameSearch hqLength (NamesWithHistory.fromCurrentNames parseNames)
liftIO (Backend.hqNameQuery codebase nameSearch query)
Cli.runTransaction do
hqLength <- Codebase.hashLength
let parseNames = Backend.parseNamesForBranch root' (Backend.AllNames (Path.unabsolute currentPath))
let nameSearch = Backend.makeNameSearch hqLength (NamesWithHistory.fromCurrentNames parseNames)
Backend.hqNameQuery codebase nameSearch query
-- | Select a definition from the given branch.
-- Returned names will match the provided 'Position' type.

2
unison-cli/src/Unison/Codebase/Editor/HandleInput/MetadataUtils.hs
View File

@ -171,4 +171,4 @@ getHQTerms = \case
where
hashOnly sh = do
Cli.Env {codebase} <- ask
liftIO (Backend.termReferentsByShortHash codebase sh)
Cli.runTransaction (Backend.termReferentsByShortHash codebase sh)

25
unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs
View File

@ -3,12 +3,10 @@ module Unison.Codebase.Editor.HandleInput.NamespaceDependencies
)
where
import Control.Monad.Reader (ask)
import Control.Monad.Trans.Maybe
import qualified Data.Map as Map
import qualified Data.Set as Set
import Unison.Cli.Monad (Cli, Env (..))
import qualified Unison.Cli.Monad as Cli
import Unison.Codebase (Codebase)
import qualified Unison.Codebase as Codebase
import Unison.Codebase.Branch (Branch0)
import qualified Unison.Codebase.Branch as Branch
@ -21,6 +19,8 @@ import Unison.Reference (Reference)
import qualified Unison.Reference as Reference
import Unison.Referent (Referent)
import qualified Unison.Referent as Referent
import qualified Unison.Sqlite as Sqlite
import Unison.Symbol (Symbol)
import qualified Unison.Term as Term
import qualified Unison.Util.Relation as Relation
import qualified Unison.Util.Relation3 as Relation3
@ -38,21 +38,18 @@ import qualified Unison.Util.Relation4 as Relation4
--
-- Returns a Set of names rather than using the PPE since we already have the correct names in
-- scope on this branch, and also want to list ALL names of dependents, including aliases.
namespaceDependencies :: Branch0 m -> Cli (Map LabeledDependency (Set Name))
namespaceDependencies branch = do
Env {codebase} <- ask
namespaceDependencies :: Codebase m Symbol a -> Branch0 m -> Sqlite.Transaction (Map LabeledDependency (Set Name))
namespaceDependencies codebase branch = do
typeDeps <-
Cli.runTransaction do
for (Map.toList currentBranchTypeRefs) $ \(typeRef, names) -> fmap (fromMaybe Map.empty) . runMaybeT $ do
refId <- MaybeT . pure $ Reference.toId typeRef
decl <- MaybeT $ Codebase.getTypeDeclaration codebase refId
let typeDeps = Set.map LD.typeRef $ DD.dependencies (DD.asDataDecl decl)
pure $ foldMap (`Map.singleton` names) typeDeps
for (Map.toList currentBranchTypeRefs) $ \(typeRef, names) -> fmap (fromMaybe Map.empty) . runMaybeT $ do
refId <- MaybeT . pure $ Reference.toId typeRef
decl <- MaybeT $ Codebase.getTypeDeclaration codebase refId
let typeDeps = Set.map LD.typeRef $ DD.dependencies (DD.asDataDecl decl)
pure $ foldMap (`Map.singleton` names) typeDeps
termDeps <- for (Map.toList currentBranchTermRefs) $ \(termRef, names) -> fmap (fromMaybe Map.empty) . runMaybeT $ do
refId <- MaybeT . pure $ Referent.toReferenceId termRef
term <- MaybeT $ liftIO (Codebase.getTerm codebase refId)
term <- MaybeT $ Codebase.getTerm codebase refId
let termDeps = Term.labeledDependencies term
pure $ foldMap (`Map.singleton` names) termDeps

4
unison-cli/src/Unison/Codebase/Editor/Input.hs
View File

@ -24,7 +24,7 @@ module Unison.Codebase.Editor.Input
where
import qualified Data.Text as Text
import qualified Unison.Codebase.Branch as Branch
import U.Codebase.HashTags (CausalHash)
import qualified Unison.Codebase.Branch.Merge as Branch
import Unison.Codebase.Editor.RemoteRepo
import Unison.Codebase.Path (Path')
@ -44,7 +44,7 @@ import qualified Unison.Util.Pretty as P
data Event
= UnisonFileChanged SourceName Source
| IncomingRootBranch (Set Branch.CausalHash)
| IncomingRootBranch (Set CausalHash)
type Source = Text -- "id x = x\nconst a b = a"

14
unison-cli/src/Unison/Codebase/Editor/Output.hs
View File

@ -21,8 +21,8 @@ import Data.Time (UTCTime)
import Network.URI (URI)
import qualified System.Console.Haskeline as Completion
import U.Codebase.Branch.Diff (NameChanges)
import U.Codebase.HashTags (CausalHash)
import Unison.Auth.Types (CredentialFailure)
import qualified Unison.Codebase.Branch as Branch
import Unison.Codebase.Editor.DisplayObject (DisplayObject)
import Unison.Codebase.Editor.Input
import Unison.Codebase.Editor.Output.BranchDiff (BranchDiffOutput)
@ -104,7 +104,7 @@ data NumberedOutput
History
(Maybe Int) -- Amount of history to print
HashLength
[(Branch.CausalHash, Names.Diff)]
[(CausalHash, Names.Diff)]
HistoryTail -- 'origin point' of this view of history.
| ListEdits Patch PPE.PrettyPrintEnv
@ -257,11 +257,11 @@ data Output
Path.Absolute -- The namespace we're checking dependencies for.
(Map LabeledDependency (Set Name)) -- Mapping of external dependencies to their local dependents.
| DumpNumberedArgs NumberedArgs
| DumpBitBooster Branch.CausalHash (Map Branch.CausalHash [Branch.CausalHash])
| DumpBitBooster CausalHash (Map CausalHash [CausalHash])
| DumpUnisonFileHashes Int [(Name, Reference.Id)] [(Name, Reference.Id)] [(Name, Reference.Id)]
| BadName String
| DefaultMetadataNotification
| CouldntLoadBranch Branch.CausalHash
| CouldntLoadBranch CausalHash
| HelpMessage Input.InputPattern
| NamespaceEmpty (NonEmpty AbsBranchId)
| NoOp
@ -286,9 +286,9 @@ data ShareError
| ShareErrorTransport Sync.CodeserverTransportError
data HistoryTail
= EndOfLog Branch.CausalHash
| MergeTail Branch.CausalHash [Branch.CausalHash]
| PageEnd Branch.CausalHash Int -- PageEnd nextHash nextIndex
= EndOfLog CausalHash
| MergeTail CausalHash [CausalHash]
| PageEnd CausalHash Int -- PageEnd nextHash nextIndex
deriving (Show)
data TestReportStats

11
unison-cli/src/Unison/Codebase/Editor/Output/DumpNamespace.hs
View File

@ -1,17 +1,16 @@
module Unison.Codebase.Editor.Output.DumpNamespace where
import Data.Map (Map)
import Data.Set (Set)
import qualified Unison.Codebase.Branch as Branch
import U.Codebase.HashTags (CausalHash, PatchHash)
import Unison.NameSegment (NameSegment)
import Unison.Prelude
import Unison.Reference (Reference)
import Unison.Referent (Referent)
data DumpNamespace = DumpNamespace
{ terms :: Map Referent (Set NameSegment, Set Reference),
types :: Map Reference (Set NameSegment, Set Reference),
patches :: Map NameSegment Branch.EditHash,
children :: Map NameSegment Branch.CausalHash,
causalParents :: Set Branch.CausalHash
patches :: Map NameSegment PatchHash,
children :: Map NameSegment CausalHash,
causalParents :: Set CausalHash
}
deriving (Show)

18
unison-cli/src/Unison/CommandLine/Completion.hs
View File

@ -166,7 +166,7 @@ completeWithinNamespace compTypes query currentPath = do
case querySuffix of
"" -> pure []
suffix -> do
case Map.lookup (Cv.namesegment1to2 suffix) nonEmptyChildren of
case Map.lookup suffix nonEmptyChildren of
Nothing -> pure []
Just childCausal -> do
childBranch <- V2Causal.value childCausal
@ -181,29 +181,29 @@ completeWithinNamespace compTypes query currentPath = do
namesInBranch :: Int -> V2Branch.Branch Sqlite.Transaction -> Sqlite.Transaction [(Bool, Text)]
namesInBranch hashLen b = do
nonEmptyChildren <- V2Branch.nonEmptyChildren b
let textifyHQ :: (V2Branch.NameSegment -> r -> HQ'.HashQualified V2Branch.NameSegment) -> Map V2Branch.NameSegment (Map r metadata) -> [(Bool, Text)]
let textifyHQ :: (NameSegment -> r -> HQ'.HashQualified NameSegment) -> Map NameSegment (Map r metadata) -> [(Bool, Text)]
textifyHQ f xs =
xs
& hashQualifyCompletions f
& fmap (HQ'.toTextWith V2Branch.unNameSegment)
& fmap (HQ'.toTextWith NameSegment.toText)
& fmap (True,)
pure $
((False,) <$> dotifyNamespaces (fmap V2Branch.unNameSegment . Map.keys $ nonEmptyChildren))
((False,) <$> dotifyNamespaces (fmap NameSegment.toText . Map.keys $ nonEmptyChildren))
<> Monoid.whenM (NESet.member TermCompletion compTypes) (textifyHQ (hqFromNamedV2Referent hashLen) $ V2Branch.terms b)
<> Monoid.whenM (NESet.member TypeCompletion compTypes) (textifyHQ (hqFromNamedV2Reference hashLen) $ V2Branch.types b)
<> Monoid.whenM (NESet.member PatchCompletion compTypes) (fmap ((True,) . V2Branch.unNameSegment) . Map.keys $ V2Branch.patches b)
<> Monoid.whenM (NESet.member PatchCompletion compTypes) (fmap ((True,) . NameSegment.toText) . Map.keys $ V2Branch.patches b)
-- Regrettably there'shqFromNamedV2Referencenot a great spot to combinators for V2 references and shorthashes right now.
hqFromNamedV2Referent :: Int -> V2Branch.NameSegment -> Referent.Referent -> HQ'.HashQualified V2Branch.NameSegment
hqFromNamedV2Referent :: Int -> NameSegment -> Referent.Referent -> HQ'.HashQualified NameSegment
hqFromNamedV2Referent hashLen n r = HQ'.HashQualified n (Cv.referent2toshorthash1 (Just hashLen) r)
hqFromNamedV2Reference :: Int -> V2Branch.NameSegment -> Reference.Reference -> HQ'.HashQualified V2Branch.NameSegment
hqFromNamedV2Reference :: Int -> NameSegment -> Reference.Reference -> HQ'.HashQualified NameSegment
hqFromNamedV2Reference hashLen n r = HQ'.HashQualified n (Cv.reference2toshorthash1 (Just hashLen) r)
hashQualifyCompletions :: forall r metadata. (V2Branch.NameSegment -> r -> HQ'.HashQualified V2Branch.NameSegment) -> Map V2Branch.NameSegment (Map r metadata) -> [HQ'.HashQualified V2Branch.NameSegment]
hashQualifyCompletions :: forall r metadata. (NameSegment -> r -> HQ'.HashQualified NameSegment) -> Map NameSegment (Map r metadata) -> [HQ'.HashQualified NameSegment]
hashQualifyCompletions qualify defs = ifoldMap qualifyRefs defs
where
-- Qualify any conflicted definitions. If the query has a "#" in it, then qualify ALL
-- completions.
qualifyRefs :: V2Branch.NameSegment -> (Map r metadata) -> [HQ'.HashQualified V2Branch.NameSegment]
qualifyRefs :: NameSegment -> (Map r metadata) -> [HQ'.HashQualified NameSegment]
qualifyRefs n refs
| ((Text.isInfixOf "#" . NameSegment.toText) querySuffix) || length refs > 1 =
refs

23
unison-cli/src/Unison/CommandLine/OutputMessages.hs
View File

@ -38,6 +38,7 @@ import System.Directory
)
import U.Codebase.Branch (NamespaceStats (..))
import U.Codebase.Branch.Diff (NameChanges (..))
import U.Codebase.HashTags (CausalHash (..))
import U.Codebase.Sqlite.DbId (SchemaVersion (SchemaVersion))
import U.Util.Base32Hex (Base32Hex)
import qualified U.Util.Base32Hex as Base32Hex
@ -48,8 +49,6 @@ import qualified U.Util.Monoid as Monoid
import qualified Unison.ABT as ABT
import qualified Unison.Auth.Types as Auth
import qualified Unison.Builtin.Decls as DD
import qualified Unison.Codebase.Branch as Branch
import qualified Unison.Codebase.Causal as Causal
import Unison.Codebase.Editor.DisplayObject (DisplayObject (BuiltinObject, MissingObject, UserObject))
import qualified Unison.Codebase.Editor.Input as Input
import Unison.Codebase.Editor.Output
@ -367,16 +366,16 @@ notifyNumbered o = case o of
"",
tailMsg
]
branchHashes :: [Branch.CausalHash]
branchHashes :: [CausalHash]
branchHashes = (fst <$> reversedHistory) <> tailHashes
in (msg, displayBranchHash <$> branchHashes)
where
toSCH :: Branch.CausalHash -> ShortCausalHash
toSCH :: CausalHash -> ShortCausalHash
toSCH h = SCH.fromHash schLength h
reversedHistory = reverse history
showNum :: Int -> Pretty
showNum n = P.shown n <> ". "
handleTail :: Int -> (Pretty, [Branch.CausalHash])
handleTail :: Int -> (Pretty, [CausalHash])
handleTail n = case tail of
E.EndOfLog h ->
( P.lines
@ -1233,7 +1232,7 @@ notifyUser dir o = case o of
CouldntLoadRootBranch repo hash ->
P.wrap $
"I couldn't load the designated root hash"
<> P.group ("(" <> P.text (Hash.base32Hex $ Causal.unCausalHash hash) <> ")")
<> P.group ("(" <> P.text (Hash.base32Hex $ unCausalHash hash) <> ")")
<> "from the repository at"
<> prettyReadGitRepo repo
CouldntLoadSyncedBranch ns h ->
@ -1528,10 +1527,10 @@ notifyUser dir o = case o of
Nothing -> go (renderLine head [] : output) queue
Just tails -> go (renderLine head tails : output) (queue ++ tails)
where
renderHash = take 10 . Text.unpack . Hash.base32Hex . Causal.unCausalHash
renderHash = take 10 . Text.unpack . Hash.base32Hex . unCausalHash
renderLine head tail =
(renderHash head) ++ "|" ++ intercalateMap " " renderHash tail
++ case Map.lookup (Hash.base32Hex . Causal.unCausalHash $ head) tags of
++ case Map.lookup (Hash.base32Hex . unCausalHash $ head) tags of
Just t -> "|tag: " ++ t
Nothing -> ""
-- some specific hashes that we want to label in the output
@ -1929,8 +1928,8 @@ prettyAbsolute = P.blue . P.shown
prettySCH :: IsString s => ShortCausalHash -> P.Pretty s
prettySCH hash = P.group $ "#" <> P.text (SCH.toText hash)
prettyCausalHash :: IsString s => Causal.CausalHash -> P.Pretty s
prettyCausalHash hash = P.group $ "#" <> P.text (Hash.toBase32HexText . Causal.unCausalHash $ hash)
prettyCausalHash :: IsString s => CausalHash -> P.Pretty s
prettyCausalHash hash = P.group $ "#" <> P.text (Hash.toBase32HexText . unCausalHash $ hash)
prettyBase32Hex :: IsString s => Base32Hex -> P.Pretty s
prettyBase32Hex = P.text . Base32Hex.toText
@ -3213,8 +3212,8 @@ endangeredDependentsTable ppeDecl m =
& P.lines
-- | Displays a full, non-truncated Branch.CausalHash to a string, e.g. #abcdef
displayBranchHash :: Branch.CausalHash -> String
displayBranchHash = ("#" <>) . Text.unpack . Hash.base32Hex . Causal.unCausalHash
displayBranchHash :: CausalHash -> String
displayBranchHash = ("#" <>) . Text.unpack . Hash.base32Hex . unCausalHash
prettyHumanReadableTime :: UTCTime -> UTCTime -> Pretty
prettyHumanReadableTime now time =

5
unison-cli/unison-cli.cabal
View File

@ -184,6 +184,7 @@ library
, unison-codebase
, unison-codebase-sqlite
, unison-codebase-sqlite-hashing-v2
, unison-core
, unison-core1
, unison-hash
, unison-parser-typechecker
@ -311,6 +312,7 @@ executable cli-integration-tests
, unison-codebase
, unison-codebase-sqlite
, unison-codebase-sqlite-hashing-v2
, unison-core
, unison-core1
, unison-hash
, unison-parser-typechecker
@ -432,6 +434,7 @@ executable transcripts
, unison-codebase
, unison-codebase-sqlite
, unison-codebase-sqlite-hashing-v2
, unison-core
, unison-core1
, unison-hash
, unison-parser-typechecker
@ -560,6 +563,7 @@ executable unison
, unison-codebase
, unison-codebase-sqlite
, unison-codebase-sqlite-hashing-v2
, unison-core
, unison-core1
, unison-hash
, unison-parser-typechecker
@ -691,6 +695,7 @@ test-suite cli-tests
, unison-codebase
, unison-codebase-sqlite
, unison-codebase-sqlite-hashing-v2
, unison-core
, unison-core1
, unison-hash
, unison-parser-typechecker

6
unison-core/src/Unison/Names/Scoped.hs
View File

@ -1,12 +1,10 @@
module Unison.Names.Scoped where
import Unison.Names (Names)
import qualified Unison.Names as Names
-- | Contains all useful permutations of names scoped to a given branch.
data ScopedNames = ScopedNames
{ absoluteExternalNames :: Names,
relativeScopedNames :: Names,
{ relativeScopedNames :: Names,
absoluteRootNames :: Names
}
@ -21,4 +19,4 @@ parseNames (ScopedNames {relativeScopedNames, absoluteRootNames}) = relativeScop
-- | Includes includes relative names for anything in the path, and absolute names for
-- everything else.
prettyNames :: ScopedNames -> Names
prettyNames (ScopedNames {relativeScopedNames, absoluteExternalNames}) = relativeScopedNames `Names.unionLeft` absoluteExternalNames
prettyNames (ScopedNames {relativeScopedNames}) = relativeScopedNames

2
unison-core/unison-core1.cabal
View File

@ -41,7 +41,6 @@ library
Unison.Names
Unison.Names.ResolutionResult
Unison.Names.Scoped
Unison.NameSegment
Unison.NamesWithHistory
Unison.Pattern
Unison.Position
@ -54,7 +53,6 @@ library
Unison.Term
Unison.Type
Unison.Type.Names
Unison.Util.Alphabetical
Unison.Util.Components
Unison.Util.List
Unison.Var

1
unison-share-api/package.yaml
View File

@ -42,6 +42,7 @@ dependencies:
- transformers
- unison-codebase
- unison-codebase-sqlite
- unison-core
- unison-core1
- unison-hash
- unison-hash-orphans-aeson

106
unison-share-api/src/Unison/Server/Backend.hs
View File

@ -31,6 +31,8 @@ import qualified Text.FuzzyFind as FZF
import U.Codebase.Branch (NamespaceStats (..))
import qualified U.Codebase.Branch as V2Branch
import qualified U.Codebase.Causal as V2Causal
import U.Codebase.HashTags (CausalHash (..))
import U.Codebase.Projects as Projects
import qualified U.Codebase.Referent as V2Referent
import qualified U.Codebase.Sqlite.Operations as Operations
import qualified Unison.ABT as ABT
@ -41,7 +43,6 @@ import qualified Unison.Codebase as Codebase
import Unison.Codebase.Branch (Branch)
import qualified Unison.Codebase.Branch as Branch
import qualified Unison.Codebase.Branch.Names as Branch
import qualified Unison.Codebase.Causal.Type as Causal
import Unison.Codebase.Editor.DisplayObject
import qualified Unison.Codebase.Editor.DisplayObject as DisplayObject
import Unison.Codebase.Path (Path)
@ -119,7 +120,7 @@ type SyntaxText = UST.SyntaxText' Reference
data ShallowListEntry v a
= ShallowTermEntry (TermEntry v a)
| ShallowTypeEntry TypeEntry
| ShallowBranchEntry NameSegment Branch.CausalHash NamespaceStats
| ShallowBranchEntry NameSegment CausalHash NamespaceStats
| ShallowPatchEntry NameSegment
deriving (Eq, Ord, Show, Generic)
@ -141,8 +142,8 @@ data BackendError
| CouldntExpandBranchHash ShortCausalHash
| AmbiguousBranchHash ShortCausalHash (Set ShortCausalHash)
| AmbiguousHashForDefinition ShortHash
| NoBranchForHash Branch.CausalHash
| CouldntLoadBranch Branch.CausalHash
| NoBranchForHash CausalHash
| CouldntLoadBranch CausalHash
| MissingSignatureForTerm Reference
| NoSuchDefinition (HQ.HashQualified Name)
deriving stock (Show)
@ -227,13 +228,13 @@ shallowNames :: forall m v a. Monad m => Codebase m v a -> V2Branch.Branch m ->
shallowNames codebase b = do
newTerms <-
V2Branch.terms b
& Map.mapKeys (Name.fromSegment . Cv.namesegment2to1)
& Map.mapKeys Name.fromSegment
& fmap Map.keysSet
& traverse . Set.traverse %%~ Cv.referent2to1 (Codebase.getDeclType codebase)
let newTypes =
V2Branch.types b
& Map.mapKeys (Name.fromSegment . Cv.namesegment2to1)
& Map.mapKeys Name.fromSegment
& fmap Map.keysSet
& traverse . Set.traverse %~ Cv.reference2to1
pure (Names (R.fromMultimap newTerms) (R.fromMultimap newTypes))
@ -361,7 +362,7 @@ findShallowReadmeInBranchAndRender width runtime codebase ppe namespaceBranch =
-- choose the first term (among conflicted terms) matching any of these names, in this order.
-- we might later want to return all of them to let the front end decide
toCheck = V2Branch.NameSegment <$> ["README", "Readme", "ReadMe", "readme"]
toCheck = NameSegment <$> ["README", "Readme", "ReadMe", "readme"]
readme :: Maybe Reference
readme = listToMaybe $ do
name <- toCheck
@ -427,7 +428,7 @@ termListEntry codebase branch (ExactName nameSegment ref) = do
isConflicted =
branch
& V2Branch.terms
& Map.lookup (coerce @NameSegment @V2Branch.NameSegment nameSegment)
& Map.lookup nameSegment
& maybe 0 Map.size
& (> 1)
@ -495,7 +496,7 @@ typeListEntry codebase b (ExactName nameSegment ref) = do
isConflicted =
b
& V2Branch.types
& Map.lookup (coerce @NameSegment @V2Branch.NameSegment nameSegment)
& Map.lookup nameSegment
& maybe 0 Map.size
& (> 1)
@ -554,26 +555,26 @@ lsBranch ::
V2Branch.Branch n ->
m [ShallowListEntry Symbol Ann]
lsBranch codebase b0 = do
let flattenRefs :: Map V2Branch.NameSegment (Map ref v) -> [(ref, V2Branch.NameSegment)]
let flattenRefs :: Map NameSegment (Map ref v) -> [(ref, NameSegment)]
flattenRefs m = do
(ns, refs) <- Map.toList m
r <- Map.keys refs
pure (r, ns)
termEntries <- for (flattenRefs $ V2Branch.terms b0) $ \(r, ns) -> do
ShallowTermEntry <$> termListEntry codebase b0 (ExactName (coerce @V2Branch.NameSegment ns) r)
ShallowTermEntry <$> termListEntry codebase b0 (ExactName ns r)
typeEntries <-
Codebase.runTransaction codebase do
for (flattenRefs $ V2Branch.types b0) \(r, ns) -> do
let v1Ref = Cv.reference2to1 r
ShallowTypeEntry <$> typeListEntry codebase b0 (ExactName (coerce @V2Branch.NameSegment ns) v1Ref)
ShallowTypeEntry <$> typeListEntry codebase b0 (ExactName ns v1Ref)
childrenWithStats <- Codebase.runTransaction codebase (V2Branch.childStats b0)
let branchEntries :: [ShallowListEntry Symbol Ann] = do
(ns, (h, stats)) <- Map.toList $ childrenWithStats
guard $ V2Branch.hasDefinitions stats
pure $ ShallowBranchEntry (Cv.namesegment2to1 ns) (Cv.causalHash2to1 . V2Causal.causalHash $ h) stats
pure $ ShallowBranchEntry ns (V2Causal.causalHash h) stats
patchEntries :: [ShallowListEntry Symbol Ann] = do
(ns, _h) <- Map.toList $ V2Branch.patches b0
pure $ ShallowPatchEntry (Cv.namesegment2to1 ns)
pure $ ShallowPatchEntry ns
pure . List.sortOn listEntryName $
termEntries
++ typeEntries
@ -600,7 +601,7 @@ termReferencesByShortHash sh = do
pure (fromBuiltins <> Set.mapMonotonic Reference.DerivedId fromCodebase)
-- | Look up terms in the codebase by short hash, and include builtins.
termReferentsByShortHash :: Monad m => Codebase m v a -> ShortHash -> m (Set Referent)
termReferentsByShortHash :: Codebase m v a -> ShortHash -> Sqlite.Transaction (Set Referent)
termReferentsByShortHash codebase sh = do
fromCodebase <- Codebase.termReferentsByPrefix codebase sh
let fromBuiltins =
@ -721,11 +722,10 @@ applySearch Search {lookupNames, lookupRelativeHQRefs', makeResult, matchesNamed
in makeResult (HQ'.toHQ primaryName) ref aliases
hqNameQuery ::
MonadIO m =>
Codebase m v Ann ->
NameSearch ->
[HQ.HashQualified Name] ->
m QueryResult
Sqlite.Transaction QueryResult
hqNameQuery codebase NameSearch {typeSearch, termSearch} hqs = do
-- Split the query into hash-only and hash-qualified-name queries.
let (hashes, hqnames) = partitionEithers (map HQ'.fromHQ2 hqs)
@ -737,11 +737,10 @@ hqNameQuery codebase NameSearch {typeSearch, termSearch} hqs = do
hashes
-- Find types with those hashes.
typeRefs <-
Codebase.runTransaction codebase do
filter (not . Set.null . snd) . zip hashes
<$> traverse
typeReferencesByShortHash
hashes
filter (not . Set.null . snd) . zip hashes
<$> traverse
typeReferencesByShortHash
hashes
-- Now do the name queries.
let mkTermResult sh r = SR.termResult (HQ.HashOnly sh) r Set.empty
mkTypeResult sh r = SR.typeResult (HQ.HashOnly sh) r Set.empty
@ -785,7 +784,7 @@ data DefinitionResults v = DefinitionResults
noResults :: [HQ.HashQualified Name]
}
expandShortCausalHash :: ShortCausalHash -> Backend Sqlite.Transaction Branch.CausalHash
expandShortCausalHash :: ShortCausalHash -> Backend Sqlite.Transaction CausalHash
expandShortCausalHash hash = do
hashSet <- lift $ Codebase.causalHashesByPrefix hash
len <- lift $ Codebase.branchHashLength
@ -797,13 +796,13 @@ expandShortCausalHash hash = do
-- | Efficiently resolve a root hash and path to a shallow branch's causal.
getShallowCausalAtPathFromRootHash ::
Maybe Branch.CausalHash ->
Maybe CausalHash ->
Path ->
Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
getShallowCausalAtPathFromRootHash mayRootHash path = do
shallowRoot <- case mayRootHash of
Nothing -> Codebase.getShallowRootCausal
Just h -> Codebase.expectCausalBranchByCausalHash (Cv.causalHash1to2 h)
Just h -> Codebase.expectCausalBranchByCausalHash h
Codebase.getShallowCausalAtPath path (Just shallowRoot)
formatType' :: Var v => PPE.PrettyPrintEnv -> Width -> Type v a -> SyntaxText
@ -832,7 +831,7 @@ prettyDefinitionsForHQName ::
-- this path.
Path ->
-- | The root branch to use
Maybe Branch.CausalHash ->
Maybe CausalHash ->
Maybe Width ->
-- | Whether to suffixify bindings in the rendered syntax
Suffixify ->
@ -845,7 +844,7 @@ prettyDefinitionsForHQName ::
prettyDefinitionsForHQName path mayRoot renderWidth suffixifyBindings rt codebase query = do
(shallowRoot, hqLength) <-
(lift . Codebase.runTransaction codebase) do
shallowRoot <- resolveCausalHashV2 (fmap Cv.causalHash1to2 mayRoot)
shallowRoot <- resolveCausalHashV2 mayRoot
hqLength <- Codebase.hashLength
pure (shallowRoot, hqLength)
(localNamesOnly, unbiasedPPE) <- scopedNamesForBranchHash codebase (Just shallowRoot) path
@ -862,11 +861,13 @@ prettyDefinitionsForHQName path mayRoot renderWidth suffixifyBindings rt codebas
fqnPPE = PPED.unsuffixifiedPPE pped
let nameSearch :: NameSearch
nameSearch = makeNameSearch hqLength (NamesWithHistory.fromCurrentNames localNamesOnly)
DefinitionResults terms types misses <- lift (definitionsBySuffixes codebase nameSearch DontIncludeCycles [query])
branchAtPath <- do
(DefinitionResults terms types misses, branchAtPath) <-
(lift . Codebase.runTransaction codebase) do
causalAtPath <- Codebase.getShallowCausalAtPath path (Just shallowRoot)
V2Causal.value causalAtPath
results <- definitionsBySuffixes codebase nameSearch DontIncludeCycles [query]
branchAtPath <- do
causalAtPath <- Codebase.getShallowCausalAtPath path (Just shallowRoot)
V2Causal.value causalAtPath
pure (results, branchAtPath)
let width = mayDefaultWidth renderWidth
-- Return only references which refer to docs.
filterForDocs :: [Referent] -> Sqlite.Transaction [TermReference]
@ -976,16 +977,16 @@ renderDoc ppe width rt codebase r = do
in Doc.renderDoc
ppe
terms
(Codebase.runTransaction codebase . typeOf)
typeOf
eval
(Codebase.runTransaction codebase . decls)
decls
tm
where
terms r@(Reference.Builtin _) = pure (Just (Term.ref () r))
terms (Reference.DerivedId r) =
fmap Term.unannotate <$> Codebase.getTerm codebase r
fmap Term.unannotate <$> Codebase.runTransaction codebase (Codebase.getTerm codebase r)
typeOf r = fmap void <$> Codebase.getTypeOfReferent codebase r
typeOf r = fmap void <$> Codebase.runTransaction codebase (Codebase.getTypeOfReferent codebase r)
eval (Term.amap (const mempty) -> tm) = do
let ppes = PPED.suffixifiedPPE ppe
let codeLookup = Codebase.toCodeLookup codebase
@ -1001,7 +1002,8 @@ renderDoc ppe width rt codebase r = do
Nothing -> pure ()
pure $ r <&> Term.amap (const mempty)
decls (Reference.DerivedId r) = fmap (DD.amap (const ())) <$> Codebase.getTypeDeclaration codebase r
decls (Reference.DerivedId r) =
fmap (DD.amap (const ())) <$> Codebase.runTransaction codebase (Codebase.getTypeDeclaration codebase r)
decls _ = pure Nothing
docsInBranchToHtmlFiles ::
@ -1124,19 +1126,19 @@ scopedNamesForBranchHash codebase mbh path = do
hashLen <- lift $ Codebase.runTransaction codebase Codebase.hashLength
(parseNames, localNames) <- case mbh of
Nothing
| shouldUseNamesIndex -> lift $ Codebase.runTransaction codebase indexNames
| shouldUseNamesIndex -> do
lift $ Codebase.runTransaction codebase indexNames
| otherwise -> do
rootBranch <- lift $ Codebase.getRootBranch codebase
let (parseNames, _prettyNames, localNames) = namesForBranch rootBranch (AllNames path)
pure (parseNames, localNames)
Just rootCausal -> do
let ch = V2Causal.causalHash rootCausal
let v1CausalHash = Cv.causalHash2to1 ch
rootHash <- lift $ Codebase.runTransaction codebase Operations.expectRootCausalHash
if (ch == rootHash) && shouldUseNamesIndex
then lift $ Codebase.runTransaction codebase indexNames
else do
(parseNames, _pretty, localNames) <- flip namesForBranch (AllNames path) <$> resolveCausalHash (Just v1CausalHash) codebase
(parseNames, _pretty, localNames) <- flip namesForBranch (AllNames path) <$> resolveCausalHash (Just ch) codebase
pure (parseNames, localNames)
let localPPE = PPED.fromNamesDecl hashLen (NamesWithHistory.fromCurrentNames localNames)
@ -1150,18 +1152,21 @@ scopedNamesForBranchHash codebase mbh path = do
(PPED.suffixifiedPPE primary `PPE.addFallback` PPED.suffixifiedPPE addFallback)
indexNames :: Sqlite.Transaction (Names, Names)
indexNames = do
scopedNames <- Codebase.namesAtPath path
branch <- Codebase.getShallowRootBranch
mayProjectRoot <- Projects.inferNamesRoot path branch
let namesRoot = fromMaybe path mayProjectRoot
scopedNames <- Codebase.namesAtPath namesRoot path
pure (ScopedNames.parseNames scopedNames, ScopedNames.namesAtPath scopedNames)
resolveCausalHash ::
Monad m => Maybe Branch.CausalHash -> Codebase m v a -> Backend m (Branch m)
Monad m => Maybe CausalHash -> Codebase m v a -> Backend m (Branch m)
resolveCausalHash h codebase = case h of
Nothing -> lift (Codebase.getRootBranch codebase)
Just bhash -> do
mayBranch <- lift $ Codebase.getBranchForHash codebase bhash
whenNothing mayBranch (throwError $ NoBranchForHash bhash)
resolveCausalHashV2 :: Maybe V2Branch.CausalHash -> Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
resolveCausalHashV2 :: Maybe CausalHash -> Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
resolveCausalHashV2 h = case h of
Nothing -> Codebase.getShallowRootCausal
Just ch -> Codebase.expectCausalBranchByCausalHash ch
@ -1180,7 +1185,7 @@ resolveRootBranchHashV2 ::
resolveRootBranchHashV2 mayRoot = case mayRoot of
Nothing -> lift Codebase.getShallowRootCausal
Just sch -> do
h <- Cv.causalHash1to2 <$> expandShortCausalHash sch
h <- expandShortCausalHash sch
lift (resolveCausalHashV2 (Just h))
-- | Determines whether we include full cycles in the results, (e.g. if I search for `isEven`, will I find `isOdd` too?)
@ -1195,13 +1200,11 @@ data IncludeCycles
| DontIncludeCycles
definitionsBySuffixes ::
forall m.
MonadIO m =>
Codebase m Symbol Ann ->
NameSearch ->
IncludeCycles ->
[HQ.HashQualified Name] ->
m (DefinitionResults Symbol)
Sqlite.Transaction (DefinitionResults Symbol)
definitionsBySuffixes codebase nameSearch includeCycles query = do
QueryResult misses results <- hqNameQuery codebase nameSearch query
-- todo: remember to replace this with getting components directly,
@ -1211,12 +1214,11 @@ definitionsBySuffixes codebase nameSearch includeCycles query = do
let typeRefsWithoutCycles = searchResultsToTypeRefs results
typeRefs <- case includeCycles of
IncludeCycles ->
Codebase.runTransaction codebase do
Monoid.foldMapM
Codebase.componentReferencesForReference
typeRefsWithoutCycles
Monoid.foldMapM
Codebase.componentReferencesForReference
typeRefsWithoutCycles
DontIncludeCycles -> pure typeRefsWithoutCycles
Codebase.runTransaction codebase (Map.foldMapM (\ref -> (ref,) <$> displayType codebase ref) typeRefs)
Map.foldMapM (\ref -> (ref,) <$> displayType codebase ref) typeRefs
pure (DefinitionResults terms types misses)
where
searchResultsToTermRefs :: [SR.SearchResult] -> Set Reference
@ -1232,7 +1234,7 @@ definitionsBySuffixes codebase nameSearch includeCycles query = do
SR.Tp' _ r _ -> Just r
_ -> Nothing
displayTerm :: MonadIO m => Codebase m Symbol Ann -> Reference -> m (DisplayObject (Type Symbol Ann) (Term Symbol Ann))
displayTerm :: Codebase m Symbol Ann -> Reference -> Sqlite.Transaction (DisplayObject (Type Symbol Ann) (Term Symbol Ann))
displayTerm codebase = \case
ref@(Reference.Builtin _) -> do
pure case Map.lookup ref B.termRefTypes of

2
unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs
View File

@ -141,7 +141,7 @@ serveFuzzyFind codebase mayRoot relativeTo limit typeWidth query = do
rootCausal <-
Backend.hoistBackend (Codebase.runTransaction codebase) do
rootHash <- traverse Backend.expandShortCausalHash mayRoot
lift (Backend.resolveCausalHashV2 (Cv.causalHash1to2 <$> rootHash))
lift (Backend.resolveCausalHashV2 rootHash)
(localNamesOnly, ppe) <- Backend.scopedNamesForBranchHash codebase (Just rootCausal) path
relativeToBranch <- do
(lift . Codebase.runTransaction codebase) do

18
unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs
View File

@ -25,18 +25,14 @@ import Servant.Docs
)
import Servant.OpenApi ()
import U.Codebase.Branch (NamespaceStats (..))
import qualified U.Codebase.Branch as V2Causal
import qualified U.Codebase.Causal as V2Causal
import U.Codebase.HashTags (CausalHash (..))
import qualified U.Codebase.Sqlite.Operations as Operations
import qualified U.Util.Hash as Hash
import Unison.Codebase (Codebase)
import qualified Unison.Codebase as Codebase
import qualified Unison.Codebase.Branch as Branch
import qualified Unison.Codebase.Causal as Causal
import qualified Unison.Codebase.Path as Path
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
import Unison.Codebase.SqliteCodebase.Conversions (causalHash2to1)
import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv
import qualified Unison.NameSegment as NameSegment
import Unison.Parser.Ann (Ann)
import Unison.Prelude
@ -157,7 +153,7 @@ backendListEntryToNamespaceObject ppe typeWidth = \case
Subnamespace $
NamedNamespace
{ namespaceName = NameSegment.toText name,
namespaceHash = "#" <> Hash.toBase32HexText (Causal.unCausalHash hash),
namespaceHash = "#" <> Hash.toBase32HexText (unCausalHash hash),
namespaceSize = numContainedTerms + numContainedTypes + numContainedPatches
}
Backend.ShallowPatchEntry name ->
@ -199,12 +195,12 @@ serve codebase maySCH mayRelativeTo mayNamespaceName = do
(True, Nothing) ->
serveFromIndex codebase mayRootHash path'
(True, Just rh)
| rh == causalHash2to1 codebaseRootHash ->
| rh == codebaseRootHash ->
serveFromIndex codebase mayRootHash path'
| otherwise -> do
serveFromBranch codebase path' (Cv.causalHash1to2 rh)
serveFromBranch codebase path' rh
(False, Just rh) -> do
serveFromBranch codebase path' (Cv.causalHash1to2 rh)
serveFromBranch codebase path' rh
(False, Nothing) -> do
ch <- liftIO $ Codebase.runTransaction codebase Operations.expectRootCausalHash
serveFromBranch codebase path' ch
@ -212,7 +208,7 @@ serve codebase maySCH mayRelativeTo mayNamespaceName = do
serveFromBranch ::
Codebase IO Symbol Ann ->
Path.Path' ->
V2Causal.CausalHash ->
CausalHash ->
Backend.Backend IO NamespaceListing
serveFromBranch codebase path' rootHash = do
let absPath = Path.Absolute . Path.fromPath' $ path'
@ -233,7 +229,7 @@ serveFromBranch codebase path' rootHash = do
serveFromIndex ::
Codebase IO Symbol Ann ->
Maybe Branch.CausalHash ->
Maybe CausalHash ->
Path.Path' ->
Backend.Backend IO NamespaceListing
serveFromIndex codebase mayRootHash path' = do

7
unison-share-api/src/Unison/Server/Endpoints/Projects.hs
View File

@ -26,14 +26,13 @@ import Servant.Docs
)
import qualified U.Codebase.Branch as V2Branch
import qualified U.Codebase.Causal as V2Causal
import U.Codebase.HashTags (CausalHash (..))
import qualified U.Util.Hash as Hash
import Unison.Codebase (Codebase)
import qualified Unison.Codebase as Codebase
import qualified Unison.Codebase.Causal.Type as Causal
import qualified Unison.Codebase.Path as Path
import qualified Unison.Codebase.Path.Parse as Path
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv
import qualified Unison.NameSegment as NameSegment
import Unison.Parser.Ann (Ann)
import Unison.Prelude
@ -111,7 +110,7 @@ backendListEntryToProjectListing owner = \case
ProjectListing
{ owner = owner,
name = NameSegment.toText name,
hash = "#" <> Hash.toBase32HexText (Causal.unCausalHash hash)
hash = "#" <> Hash.toBase32HexText (unCausalHash hash)
}
_ -> Nothing
@ -141,7 +140,7 @@ serve codebase mayRoot mayOwner = projects
Just sch -> do
h <- Backend.expandShortCausalHash sch
-- TODO: can this ever be missing?
causal <- lift $ Codebase.expectCausalBranchByCausalHash (Cv.causalHash1to2 h)
causal <- lift $ Codebase.expectCausalBranchByCausalHash h
lift $ V2Causal.value causal
ownerEntries <- lift $ Backend.lsBranch codebase shallowRootBranch

4
unison-share-api/src/Unison/Server/Errors.hs
View File

@ -10,7 +10,7 @@ import qualified Data.Set as Set
import qualified Data.Text.Lazy as Text
import qualified Data.Text.Lazy.Encoding as Text
import Servant (ServerError (..), err400, err404, err409, err500)
import qualified Unison.Codebase.Causal as Causal
import U.Codebase.HashTags (CausalHash)
import qualified Unison.Codebase.Path as Path
import qualified Unison.Codebase.ShortCausalHash as SCH
import qualified Unison.HashQualified as HQ
@ -67,7 +67,7 @@ noSuchNamespace :: HashQualifiedName -> ServerError
noSuchNamespace namespace =
err404 {errBody = "The namespace " <> munge namespace <> " does not exist."}
couldntLoadBranch :: Causal.CausalHash -> ServerError
couldntLoadBranch :: CausalHash -> ServerError
couldntLoadBranch h =
err404
{ errBody =

7
unison-share-api/src/Unison/Server/Types.hs
View File

@ -39,9 +39,8 @@ import Servant.Docs (DocCapture (..), DocQueryParam (..), ParamKind (..), ToPara
import qualified Servant.Docs as Docs
import qualified U.Codebase.Branch as V2Branch
import qualified U.Codebase.Causal as V2Causal
import qualified U.Codebase.HashTags as V2
import U.Codebase.HashTags
import qualified Unison.Codebase.Branch as Branch
import qualified Unison.Codebase.Causal as Causal
import Unison.Codebase.Editor.DisplayObject
( DisplayObject,
)
@ -316,8 +315,8 @@ setCacheControl = addHeader @"Cache-Control" "public"
branchToUnisonHash :: Branch.Branch m -> UnisonHash
branchToUnisonHash b =
("#" <>) . Hash.base32Hex . Causal.unCausalHash $ Branch.headHash b
("#" <>) . Hash.base32Hex . unCausalHash $ Branch.headHash b
v2CausalBranchToUnisonHash :: V2Branch.CausalBranch m -> UnisonHash
v2CausalBranchToUnisonHash b =
("#" <>) . Hash.base32Hex . V2.unCausalHash $ V2Causal.causalHash b
("#" <>) . Hash.base32Hex . unCausalHash $ V2Causal.causalHash b

1
unison-share-api/unison-share-api.cabal
View File

@ -101,6 +101,7 @@ library
, transformers
, unison-codebase
, unison-codebase-sqlite
, unison-core
, unison-core1
, unison-hash
, unison-hash-orphans-aeson

53
unison-src/transcripts-manual/benchmarks/output.bench.txt
View File

@ -1,27 +1,28 @@
Each 111202 # 111.202ms
List.map 38240 # 38.24ms
List.filter 39300 # 39.3ms
random 80965 # 80.965ms
simple_loop 93465 # 93.465ms
fibonacci 48050 # 48.05ms
Map 50077 # 50.077ms
NatMap 54566 # 54.566ms
stm_loop 241047 # 241.047ms
encodeNat64be 40531 # 40.531ms
TMap 893535 # 893.535ms
TMap2 2439804 # 2.439804s
TMap3 1475987 # 1.475987s
TMap4 1767079 # 1.767079s
TMap.empty 119670 # 119.67ms
TVar Map concurrent (2) 3158616 # 3.158616s
TVar Map concurrent (4) 5732858 # 5.732858s
TVar Map concurrent (8) 12333688 # 12.333688s
TVar Map concurrent (16) 25708170 # 25.70817s
TVar Map concurrent (32) 55115180 # 55.11518s
TMap.concurrent(2) 1098109 # 1.098109s
TMap.concurrent(4) 1272848 # 1.272848s
TMap.concurrent(8) 3273686 # 3.273686s
TMap.concurrent(16) 5473991 # 5.473991s
TMap.concurrent(32) 11992583 # 11.992583s
array_sort 103266 # 103.266ms
Each 117847 # 117.847ms
List.map 40716 # 40.716ms
List.filter 41946 # 41.946ms
random 89320 # 89.32ms
simple_loop 103033 # 103.033ms
fibonacci 52511 # 52.511ms
Map 54995 # 54.995ms
NatMap 59753 # 59.753ms
stm_loop 258013 # 258.013ms
encodeNat64be 44693 # 44.693ms
forkbomb (40k threads) 875093 # 875.093ms
TMap 1023223 # 1.023223s
TMap2 2816747 # 2.816747s
TMap3 1683270 # 1.68327s
TMap4 2031843 # 2.031843s
TMap.empty 140388 # 140.388ms
TVar Map concurrent (2) 3576610 # 3.57661s
TVar Map concurrent (4) 6386835 # 6.386835s
TVar Map concurrent (8) 12993929 # 12.993929s
TVar Map concurrent (16) 27345687 # 27.345687s
TVar Map concurrent (32) 60121265 # 1m
TMap.concurrent(2) 1235590 # 1.23559s
TMap.concurrent(4) 1501582 # 1.501582s
TMap.concurrent(8) 3565150 # 3.56515s
TMap.concurrent(16) 6214075 # 6.214075s
TMap.concurrent(32) 12510994 # 12.510994s
array_sort 141998 # 141.998ms

9
unison-src/transcripts-manual/benchmarks/tmap.u
View File

@ -3,6 +3,7 @@ N = 20000
main = do
_baseline = timeit "encodeNat64be" '(baseline 0xs N)
_a0 = timeit "forkbomb (40k threads)" '(forkbomb 40000)
_a1 = timeit "TMap" '(go (atomically TMap.empty) N)
_a2 = timeit "TMap2" '(go2 (atomically TMap2.empty) N)
_a3 = timeit "TMap3" '(go3 (atomically TMap3.empty) N)
@ -64,6 +65,14 @@ gos_TVar_Map k m n = match k with
gos_TVar_Map (k-1) m n
MVar.take lock
forkbomb k = match k with
0 -> ()
_ ->
lock = !MVar.newEmpty
goWrap = do MVar.put lock ()
tid = fork '(catch goWrap)
forkbomb (k-1)
MVar.take lock
go2 m n =
if n == 0 then atomically '(TMap2.lookup (encodeNat64be n) m)

44
unison-src/transcripts/diff-namespace-to-patch.md Normal file
View File

@ -0,0 +1,44 @@
We can create a patch from the diff between two namespaces.
```ucm:hide
.> builtins.merge
```
```unison:hide
one.a = 1
one.b = 2
oneconflicts.b = 20
one.c = 3
one.d = 4
one.e = 4
two.a = 100
two.b = 200
two.c = 300
twoconflicts.c = 30
two.d = 5
two.e = 6
```
```ucm:hide
.> add
.> merge oneconflicts one
.> merge twoconflicts two
.> delete.namespace oneconflicts
.> delete.namespace twoconflicts
```
```ucm
.> find one.
.> find two.
.> diff.namespace.to-patch one two thepatch
```
A summary of the diff:
* `one.a` -> `two.a` is a normal update.
* Even though `one.b` is conflicted, both `one.b#hash1` and `one.b#hash2` get mapped to `two.b`.
* Because `two.c` is conflicted, `one.c` doesn't end up on the left-hand side of the patch.
* Oops, a similar case slipped by - `one.d` and `one.e` map to `two.d` and `two.e` respectively, but because `one.d` and
`one.e` were aliases, we end up with a busted patch that isn't a function. This is a bug.
* Neither `one.f` nor `two.g` end up in the patch because the names `f` and `g` are not common to both namespaces.

60
unison-src/transcripts/diff-namespace-to-patch.output.md Normal file
View File

@ -0,0 +1,60 @@
We can create a patch from the diff between two namespaces.
```unison
one.a = 1
one.b = 2
oneconflicts.b = 20
one.c = 3
one.d = 4
one.e = 4
two.a = 100
two.b = 200
two.c = 300
twoconflicts.c = 30
two.d = 5
two.e = 6
```
```ucm
.> find one.
1. one.a : Nat
2. one.b#cp6 : Nat
3. one.b#dcg : Nat
4. one.c : Nat
5. one.d : Nat
.> find two.
1. two.a : Nat
2. two.b : Nat
3. two.c#k86 : Nat
4. two.c#qpo : Nat
5. two.d : Nat
6. two.e : Nat
.> diff.namespace.to-patch one two thepatch
Edited Terms:
1. one.b#cp6ri8mtg0 -> 6. two.b
2. one.b#dcgdua2lj6 -> 7. two.b
3. one.a -> 8. two.a
4. one.d -> 9. two.d
5. one.d -> 10. two.e
Tip: To remove entries from a patch, use
delete.term-replacement or delete.type-replacement, as
appropriate.
```
A summary of the diff:
* `one.a` -> `two.a` is a normal update.
* Even though `one.b` is conflicted, both `one.b#hash1` and `one.b#hash2` get mapped to `two.b`.
* Because `two.c` is conflicted, `one.c` doesn't end up on the left-hand side of the patch.
* Oops, a similar case slipped by - `one.d` and `one.e` map to `two.d` and `two.e` respectively, but because `one.d` and
`one.e` were aliases, we end up with a busted patch that isn't a function. This is a bug.
* Neither `one.f` nor `two.g` end up in the patch because the names `f` and `g are not common to both namespaces.

1
unison-syntax/package.yaml
View File

@ -13,6 +13,7 @@ dependencies:
- megaparsec
- mtl
- text
- unison-core
- unison-core1
- unison-hash
- unison-prelude

2
unison-syntax/unison-syntax.cabal
View File

@ -66,6 +66,7 @@ library
, megaparsec
, mtl
, text
, unison-core
, unison-core1
, unison-hash
, unison-prelude
@ -119,6 +120,7 @@ test-suite syntax-tests
, megaparsec
, mtl
, text
, unison-core
, unison-core1
, unison-hash
, unison-prelude