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

added more error info for getCycleLen

Browse Source
This commit is contained in:
Arya Irani 2021-04-27 14:00:38 -06:00
parent 30c8881c36
commit 8882687d5d
3 changed files with 27 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -90,6 +90,7 @@ data Integrity
| UnknownHash Hash
| UnknownText Text
| NoObjectForHashId HashId
| NoObjectForPrimaryHashId HashId
| NoNamespaceRoot
| MultipleNamespaceRoots [CausalHashId]
| NoTypeIndexForTerm Referent.Id
@ -254,7 +255,7 @@ loadObjectWithHashIdAndTypeById oId = queryMaybe sql (Only oId) >>= orError (Unk
-- |Not all hashes have corresponding objects; e.g., hashes of term types
expectObjectIdForPrimaryHashId :: EDB m => HashId -> m ObjectId
expectObjectIdForPrimaryHashId h =
maybeObjectIdForPrimaryHashId h >>= orError (UnknownHashId h)
maybeObjectIdForPrimaryHashId h >>= orError (NoObjectForPrimaryHashId h)
maybeObjectIdForPrimaryHashId :: DB m => HashId -> m (Maybe ObjectId)
maybeObjectIdForPrimaryHashId h = queryAtom sql (Only h) where sql = [here|

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

@ -264,10 +264,13 @@ sqliteCodebase root = do
getTerm (Reference.Id h1@(Cv.hash1to2 -> h2) i _n) =
runDB' conn do
term2 <- Ops.loadTermByReference (C.Reference.Id h2 i)
Cv.term2to1 h1 getCycleLen getDeclType term2
Cv.term2to1 h1 (getCycleLen "getTerm") getDeclType term2
getCycleLen :: EDB m => Hash -> m Reference.Size
getCycleLen = Ops.getCycleLen . Cv.hash1to2
getCycleLen :: EDB m => String -> Hash -> m Reference.Size
getCycleLen source h = do
(Ops.getCycleLen . Cv.hash1to2) h `Except.catchError` \case
e@(Ops.DatabaseIntegrityError (Q.NoObjectForPrimaryHashId {})) -> error $ show e ++ " in " ++ source
e -> Except.throwError e
getDeclType :: EDB m => C.Reference.Reference -> m CT.ConstructorType
getDeclType = \case
@ -289,13 +292,13 @@ sqliteCodebase root = do
getTypeOfTermImpl (Reference.Id (Cv.hash1to2 -> h2) i _n) =
runDB' conn do
type2 <- Ops.loadTypeOfTermByTermReference (C.Reference.Id h2 i)
Cv.ttype2to1 getCycleLen type2
Cv.ttype2to1 (getCycleLen "getTypeOfTermImpl") type2
getTypeDeclaration :: MonadIO m => Reference.Id -> m (Maybe (Decl Symbol Ann))
getTypeDeclaration (Reference.Id h1@(Cv.hash1to2 -> h2) i _n) =
runDB' conn do
decl2 <- Ops.loadDeclByReference (C.Reference.Id h2 i)
Cv.decl2to1 h1 getCycleLen decl2
Cv.decl2to1 h1 (getCycleLen "getTypeDeclaration") decl2
putTerm :: MonadIO m => Reference.Id -> Term Symbol Ann -> Type Symbol Ann -> m ()
putTerm id tm tp | debug && trace (show "SqliteCodebase.putTerm " ++ show id ++ " " ++ show tm ++ " " ++ show tp) False = undefined
@ -566,7 +569,7 @@ sqliteCodebase root = do
dependentsImpl :: MonadIO m => Reference -> m (Set Reference.Id)
dependentsImpl r =
runDB conn $
Set.traverse (Cv.referenceid2to1 getCycleLen)
Set.traverse (Cv.referenceid2to1 (getCycleLen "dependentsImpl"))
=<< Ops.dependents (Cv.reference1to2 r)
syncFromDirectory :: MonadIO m => Codebase1.CodebasePath -> SyncMode -> Branch m -> m ()
@ -585,14 +588,14 @@ sqliteCodebase root = do
watches w =
runDB conn $
Ops.listWatches (Cv.watchKind1to2 w)
>>= traverse (Cv.referenceid2to1 getCycleLen)
>>= traverse (Cv.referenceid2to1 (getCycleLen "watches"))
getWatch :: MonadIO m => UF.WatchKind -> Reference.Id -> m (Maybe (Term Symbol Ann))
getWatch k r@(Reference.Id h _i _n)
| elem k standardWatchKinds =
runDB' conn $
Ops.loadWatch (Cv.watchKind1to2 k) (Cv.referenceid1to2 r)
>>= Cv.term2to1 h getCycleLen getDeclType
>>= Cv.term2to1 h (getCycleLen "getWatch") getDeclType
getWatch _unknownKind _ = pure Nothing
standardWatchKinds = [UF.RegularWatch, UF.TestWatch]
@ -638,13 +641,13 @@ sqliteCodebase root = do
termsOfTypeImpl r =
runDB conn $
Ops.termsHavingType (Cv.reference1to2 r)
>>= Set.traverse (Cv.referentid2to1 getCycleLen getDeclType)
>>= Set.traverse (Cv.referentid2to1 (getCycleLen "termsOfTypeImpl") getDeclType)
termsMentioningTypeImpl :: MonadIO m => Reference -> m (Set Referent.Id)
termsMentioningTypeImpl r =
runDB conn $
Ops.termsMentioningType (Cv.reference1to2 r)
>>= Set.traverse (Cv.referentid2to1 getCycleLen getDeclType)
>>= Set.traverse (Cv.referentid2to1 (getCycleLen "termsMentioningTypeImpl") getDeclType)
hashLength :: Applicative m => m Int
hashLength = pure 10
@ -661,7 +664,7 @@ sqliteCodebase root = do
>>= traverse (C.Reference.idH Ops.loadHashByObjectId)
>>= pure . Set.fromList
Set.fromList <$> traverse (Cv.referenceid2to1 getCycleLen) (Set.toList refs)
Set.fromList <$> traverse (Cv.referenceid2to1 (getCycleLen "defnReferencesByPrefix")) (Set.toList refs)
termReferencesByPrefix :: MonadIO m => ShortHash -> m (Set Reference.Id)
termReferencesByPrefix = defnReferencesByPrefix OT.TermComponent
@ -674,7 +677,7 @@ sqliteCodebase root = do
referentsByPrefix (SH.ShortHash prefix (fmap Cv.shortHashSuffix1to2 -> cycle) cid) = runDB conn do
termReferents <-
Ops.termReferentsByPrefix prefix cycle
>>= traverse (Cv.referentid2to1 getCycleLen getDeclType)
>>= traverse (Cv.referentid2to1 (getCycleLen "referentsByPrefix") getDeclType)
declReferents' <- Ops.declReferentsByPrefix prefix cycle (read . Text.unpack <$> cid)
let declReferents =
[ Referent.Con' (Reference.Id (Cv.hash2to1 h) pos len) (fromIntegral cid) (Cv.decltype2to1 ct)

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

@ -415,10 +415,10 @@ type1to2' convertRef =
V1.Kind.Arrow i o -> V2.Kind.Arrow (convertKind i) (convertKind o)
-- | forces loading v1 branches even if they may not exist
causalbranch2to1 :: Monad m => (Hash -> m V1.Reference.Size) -> (V2.Reference -> m CT.ConstructorType) -> V2.Branch.Causal m -> m (V1.Branch.Branch m)
causalbranch2to1 :: Monad m => (String -> Hash -> m V1.Reference.Size) -> (V2.Reference -> m CT.ConstructorType) -> V2.Branch.Causal m -> m (V1.Branch.Branch m)
causalbranch2to1 lookupSize lookupCT = fmap V1.Branch.Branch . causalbranch2to1' lookupSize lookupCT
causalbranch2to1' :: Monad m => (Hash -> m V1.Reference.Size) -> (V2.Reference -> m CT.ConstructorType) -> V2.Branch.Causal m -> m (V1.Branch.UnwrappedBranch m)
causalbranch2to1' :: Monad m => (String -> Hash -> m V1.Reference.Size) -> (V2.Reference -> m CT.ConstructorType) -> V2.Branch.Causal m -> m (V1.Branch.UnwrappedBranch m)
causalbranch2to1' lookupSize lookupCT (V2.Causal hc _he (Map.toList -> parents) me) = do
let currentHash = causalHash2to1 hc
case parents of
@ -502,27 +502,27 @@ causalbranch1to2 (V1.Branch.Branch c) = causal1to2' hash1to2cb hash1to2c branch1
patch2to1 ::
forall m.
Monad m =>
(Hash -> m V1.Reference.Size) ->
(String -> Hash -> m V1.Reference.Size) ->
V2.Branch.Patch ->
m V1.Patch
patch2to1 lookupSize (V2.Branch.Patch v2termedits v2typeedits) = do
termEdits <- Map.bitraverse referent2to1' (Set.traverse termedit2to1) v2termedits
typeEdits <- Map.bitraverse (reference2to1 lookupSize) (Set.traverse typeedit2to1) v2typeedits
typeEdits <- Map.bitraverse (reference2to1 (lookupSize "patch->old type")) (Set.traverse typeedit2to1) v2typeedits
pure $ V1.Patch (Relation.fromMultimap termEdits) (Relation.fromMultimap typeEdits)
where
referent2to1' :: V2.Referent -> m V1.Reference
referent2to1' = \case
V2.Referent.Ref r -> reference2to1 lookupSize r
V2.Referent.Ref r -> reference2to1 (lookupSize "patch->old term") r
V2.Referent.Con {} -> error "found referent on LHS when converting patch2to1"
termedit2to1 :: V2.TermEdit.TermEdit -> m V1.TermEdit.TermEdit
termedit2to1 = \case
V2.TermEdit.Replace (V2.Referent.Ref r) t ->
V1.TermEdit.Replace <$> reference2to1 lookupSize r <*> typing2to1 t
V1.TermEdit.Replace <$> reference2to1 (lookupSize "patch->new term") r <*> typing2to1 t
V2.TermEdit.Replace {} -> error "found referent on RHS when converting patch2to1"
V2.TermEdit.Deprecate -> pure V1.TermEdit.Deprecate
typeedit2to1 :: V2.TypeEdit.TypeEdit -> m V1.TypeEdit.TypeEdit
typeedit2to1 = \case
V2.TypeEdit.Replace r -> V1.TypeEdit.Replace <$> reference2to1 lookupSize r
V2.TypeEdit.Replace r -> V1.TypeEdit.Replace <$> reference2to1 (lookupSize "patch->new type") r
V2.TypeEdit.Deprecate -> pure V1.TypeEdit.Deprecate
typing2to1 t = pure $ case t of
V2.TermEdit.Same -> V1.TermEdit.Same
@ -561,13 +561,13 @@ namesegment1to2 (V1.NameSegment t) = V2.Branch.NameSegment t
branch2to1 ::
Monad m =>
(Hash -> m V1.Reference.Size) ->
(String -> Hash -> m V1.Reference.Size) ->
(V2.Reference -> m CT.ConstructorType) ->
V2.Branch.Branch m ->
m (V1.Branch.Branch0 m)
branch2to1 lookupSize lookupCT (V2.Branch.Branch v2terms v2types v2patches v2children) = do
v1terms <- toStar (reference2to1 lookupSize) =<< Map.bitraverse (pure . namesegment2to1) (Map.bitraverse (referent2to1 lookupSize lookupCT) id) v2terms
v1types <- toStar (reference2to1 lookupSize) =<< Map.bitraverse (pure . namesegment2to1) (Map.bitraverse (reference2to1 lookupSize) id) v2types
v1terms <- toStar (reference2to1 $ lookupSize "term metadata") =<< Map.bitraverse (pure . namesegment2to1) (Map.bitraverse (referent2to1 (lookupSize "term") lookupCT) id) v2terms
v1types <- toStar (reference2to1 $ lookupSize "type metadata") =<< Map.bitraverse (pure . namesegment2to1) (Map.bitraverse (reference2to1 (lookupSize "type")) id) v2types
v1patches <- Map.bitraverse (pure . namesegment2to1) (bitraverse (pure . edithash2to1) (fmap (patch2to1 lookupSize))) v2patches
v1children <- Map.bitraverse (pure . namesegment2to1) (causalbranch2to1 lookupSize lookupCT) v2children
pure $ V1.Branch.branch0 v1terms v1types v1children v1patches