Skip to content

Commit d519dbd

Browse files
ChrisPennerChrisPenner
committed
Thread in check for ambiguously ordered components
1 parent 177d063 commit d519dbd

File tree

11 files changed

+103
-56
lines changed

11 files changed

+103
-56
lines changed

‎codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Term/Hashing.hs‎

Lines changed: 22 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -5,7 +5,7 @@ import Data.Foldable qualified as Foldable
55
import Data.Map qualified as Map
66
import U.Codebase.HashTags
77
import U.Codebase.Reference qualified as Reference
8-
import U.Codebase.Sqlite.HashHandle (HashMismatch (..))
8+
import U.Codebase.Sqlite.HashHandle (HashMismatch (..), HashValidationError (..), IncompleteElementOrderingError (..))
99
import U.Codebase.Sqlite.LocalIds qualified as LocalIds
1010
import U.Codebase.Sqlite.Queries qualified as Q
1111
import U.Codebase.Sqlite.Symbol qualified as S
@@ -23,23 +23,29 @@ import Unison.Prelude
2323
import Unison.Symbol qualified as Unison
2424
import Unison.Var qualified as Var
2525

26-
verifyTermFormatHash :: ComponentHash -> TermFormat.HashTermFormat -> Maybe (HashMismatch)
27-
verifyTermFormatHash (ComponentHash hash) (TermFormat.Term (TermFormat.LocallyIndexedComponent elements)) =
28-
Foldable.toList elements
29-
& fmap s2cTermWithType
30-
& Reference.component hash
31-
& fmap (\((tm, typ), refId) -> (refId, ((mapTermV tm), (mapTypeV typ))))
32-
& Map.fromList
33-
& C.Term.unhashComponent hash Var.unnamedRef
34-
& Map.toList
35-
& fmap (\(_refId, (v, trm, typ)) -> (v, (H2.v2ToH2Term trm, H2.v2ToH2Type typ, ())))
36-
& Map.fromList
37-
& H2.hashTermComponents
38-
& altMap \(H2.ReferenceId hash' _, _trm, _typ, _extra) ->
26+
verifyTermFormatHash :: ComponentHash -> TermFormat.HashTermFormat -> Maybe HashValidationError
27+
verifyTermFormatHash (ComponentHash hash) (TermFormat.Term (TermFormat.LocallyIndexedComponent elements)) = toMaybe $ do
28+
r <-
29+
Foldable.toList elements
30+
& fmap s2cTermWithType
31+
& Reference.component hash
32+
& fmap (\((tm, typ), refId) -> (refId, ((mapTermV tm), (mapTypeV typ))))
33+
& Map.fromList
34+
& C.Term.unhashComponent hash Var.unnamedRef
35+
& Map.toList
36+
& fmap (\(_refId, (v, trm, typ)) -> (v, (H2.v2ToH2Term trm, H2.v2ToH2Type typ, ())))
37+
& Map.fromList
38+
& H2.hashTermComponents
39+
& mapLeft (const $ HashValidationIncompleteElementOrdering $ IncompleteElementOrderingError $ ComponentHash hash)
40+
r
41+
& traverse_ \(H2.ReferenceId hash' _, _trm, _typ, _extra) ->
3942
if hash == hash'
40-
then Nothing
41-
else Just (HashMismatch hash hash')
43+
then pure ()
44+
else Left . HashValidationMismatch $ (HashMismatch hash hash')
4245
where
46+
toMaybe = \case
47+
Left e -> Just e
48+
Right () -> Nothing
4349
mapTermV ::
4450
ABT.Term (C.Term.F' text' termRef' typeRef' termLink' typeLink' S.Symbol) S.Symbol a ->
4551
ABT.Term (C.Term.F' text' termRef' typeRef' termLink' typeLink' Unison.Symbol) Unison.Symbol a

‎codebase2/codebase-sqlite/U/Codebase/Sqlite/HashHandle.hs‎

Lines changed: 10 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,8 @@
11
module U.Codebase.Sqlite.HashHandle
22
( HashHandle (..),
33
HashMismatch (..),
4+
HashValidationError (..),
5+
IncompleteElementOrderingError (..),
46
DeclHashingError (..),
57
)
68
where
@@ -26,6 +28,13 @@ data HashMismatch = HashMismatch
2628
actualHash :: Hash
2729
}
2830

31+
data IncompleteElementOrderingError = IncompleteElementOrderingError ComponentHash
32+
deriving (Eq, Show, Ord)
33+
34+
data HashValidationError
35+
= HashValidationMismatch HashMismatch
36+
| HashValidationIncompleteElementOrdering IncompleteElementOrderingError
37+
2938
data DeclHashingError
3039
= DeclHashMismatch HashMismatch
3140
| DeclHashResolutionFailure
@@ -58,7 +67,7 @@ data HashHandle = HashHandle
5867
verifyTermFormatHash ::
5968
ComponentHash ->
6069
TermFormat.HashTermFormat ->
61-
Maybe (HashMismatch),
70+
Maybe HashValidationError,
6271
verifyDeclFormatHash ::
6372
ComponentHash ->
6473
DeclFormat.HashDeclFormat ->

‎parser-typechecker/src/Unison/Hashing/V2/Convert.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -65,7 +65,7 @@ hashTermComponents ::
6565
Map v (Memory.Reference.TermReferenceId, Memory.Term.Term v a, Memory.Type.Type v a, extra)
6666
hashTermComponents mTerms =
6767
case h2mTermMap mTerms of
68-
(hTerms, constructorTypes) -> h2mTermResult (constructorTypes Map.!) <$> Hashing.hashTermComponents hTerms
68+
(hTerms, constructorTypes) -> h2mTermResult (constructorTypes Map.!) <$> (fromRight (error "hashTermComponents encountered unexpected ABT.IncompleteElementOrderingError") $ Hashing.hashTermComponents hTerms)
6969
where
7070
h2mTermMap m =
7171
m

‎unison-cli/src/Unison/Share/Sync.hs‎

Lines changed: 10 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -40,6 +40,7 @@ import Servant.Client (BaseUrl)
4040
import Servant.Client qualified as Servant
4141
import System.Environment (lookupEnv)
4242
import U.Codebase.HashTags (CausalHash)
43+
import U.Codebase.Sqlite.HashHandle qualified as HH
4344
import U.Codebase.Sqlite.Queries qualified as Q
4445
import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle)
4546
import Unison.Auth.HTTPClient (AuthenticatedHttpClient)
@@ -181,7 +182,14 @@ validateEntities entities =
181182
let entityWithHashes = entity & Share.entityHashes_ %~ Share.hashJWTHash
182183
case EV.validateEntity hash entityWithHashes of
183184
Nothing -> pure ()
184-
Just err@(Share.EntityHashMismatch et (Share.HashMismatchForEntity {supplied, computed})) ->
185+
Just (Left err@(HH.IncompleteElementOrderingError _componentHash)) ->
186+
error $
187+
"Unexpected incomplete element ordering error during entity validation for hash "
188+
<> show hash
189+
<> ": "
190+
<> show err
191+
<> ". This should never happen during normal operation. Please report this as a bug."
192+
Just (Right err@(Share.EntityHashMismatch et (Share.HashMismatchForEntity {supplied, computed}))) ->
185193
let expectedMismatches = case et of
186194
Share.TermComponentType -> expectedComponentHashMismatches
187195
Share.DeclComponentType -> expectedComponentHashMismatches
@@ -192,7 +200,7 @@ validateEntities entities =
192200
| expected == computed -> pure ()
193201
_ -> do
194202
Left err
195-
Just err -> do
203+
Just (Right err) -> do
196204
Left err
197205

198206
-- | Validate entities received from the server unless this flag is set to false.

‎unison-cli/src/Unison/Share/SyncV2.hs‎

Lines changed: 5 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -44,6 +44,7 @@ import Servant.Types.SourceT qualified as Servant
4444
import System.Console.Regions qualified as Console.Regions
4545
import U.Codebase.HashTags (CausalHash)
4646
import U.Codebase.Sqlite.DbId (CausalHashId)
47+
import U.Codebase.Sqlite.HashHandle qualified as HH
4748
import U.Codebase.Sqlite.Queries qualified as Q
4849
import U.Codebase.Sqlite.TempEntity (TempEntity)
4950
import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle)
@@ -214,7 +215,9 @@ batchValidateEntities entities = do
214215
mismatches <- fmap Vector.catMaybes $ liftIO $ IO.pooledForConcurrently entities \(hash, entity) -> do
215216
IO.evaluate $ EV.validateTempEntity hash entity
216217
for_ mismatches \case
217-
err@(Share.EntityHashMismatch et (Share.HashMismatchForEntity {supplied, computed})) ->
218+
Left err@(HH.IncompleteElementOrderingError _componentHash) ->
219+
error $ "Unexpected IncompleteElementOrderingError during sync validation for hash: " <> show err
220+
Right err@(Share.EntityHashMismatch et (Share.HashMismatchForEntity {supplied, computed})) ->
218221
let expectedMismatches = case et of
219222
Share.TermComponentType -> expectedComponentHashMismatches
220223
Share.DeclComponentType -> expectedComponentHashMismatches
@@ -225,7 +228,7 @@ batchValidateEntities entities = do
225228
| expected == computed -> pure ()
226229
_ -> do
227230
throwError . SyncError . SyncV2.PullError'DownloadEntities . SyncV2.DownloadEntitiesEntityValidationFailure $ err
228-
err -> do
231+
Right err -> do
229232
throwError . SyncError . SyncV2.PullError'DownloadEntities . SyncV2.DownloadEntitiesEntityValidationFailure $ err
230233

231234
-- | Syncs a stream which could send entities in any order.

‎unison-hashing-v2/src/Unison/Hashing/V2.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -27,6 +27,7 @@ module Unison.Hashing.V2
2727
Type,
2828
TypeEdit (..),
2929
TypeF (..),
30+
IncompleteElementOrderingError (..),
3031
hashClosedTerm,
3132
hashDecls,
3233
hashTermComponents,
@@ -40,6 +41,7 @@ module Unison.Hashing.V2
4041
where
4142

4243
import Unison.Hashing.ContentAddressable (ContentAddressable (..))
44+
import Unison.Hashing.V2.ABT (IncompleteElementOrderingError (..))
4345
import Unison.Hashing.V2.Branch (Branch (..), MdValues (..))
4446
import Unison.Hashing.V2.Causal (Causal (..))
4547
import Unison.Hashing.V2.DataDeclaration (DataDeclaration (..), Decl, EffectDeclaration (..), Modifier (..), hashDecls)

‎unison-hashing-v2/src/Unison/Hashing/V2/ABT.hs‎

Lines changed: 29 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -7,8 +7,15 @@
77
{-# LANGUAGE UndecidableInstances #-}
88
{-# LANGUAGE ViewPatterns #-}
99

10-
module Unison.Hashing.V2.ABT (Unison.ABT.Term, hash, hashComponents) where
10+
module Unison.Hashing.V2.ABT
11+
( Unison.ABT.Term,
12+
IncompleteElementOrderingError (..),
13+
hash,
14+
hashComponents,
15+
)
16+
where
1117

18+
import Data.Containers.ListUtils qualified as List
1219
import Data.List hiding (cycle, find)
1320
import Data.List qualified as List (sort)
1421
import Data.Map qualified as Map
@@ -20,20 +27,25 @@ import Unison.Hashing.V2.Tokenizable qualified as Hashable
2027
import Unison.Prelude
2128
import Prelude hiding (abs, cycle)
2229

30+
data IncompleteElementOrderingError = IncompleteElementOrderingError
31+
deriving (Show, Eq, Ord)
32+
2333
-- Hash a strongly connected component and sort its definitions into a canonical order.
2434
hashComponent ::
2535
forall a f v.
2636
(Functor f, Hashable1 f, Foldable f, Eq v, Show v, Ord v) =>
2737
Map.Map v (Term f v a) ->
28-
(Hash, [(v, Term f v a)])
29-
hashComponent byName =
38+
Either IncompleteElementOrderingError (Hash, [(v, Term f v a)])
39+
hashComponent byName = do
3040
let ts = Map.toList byName
3141
-- First, compute a canonical hash ordering of the component, as well as an environment in which we can hash
3242
-- individual names.
3343
(hashes, env) = doHashCycle [] ts
34-
-- Construct a list of tokens that is shared by all members of the component. They are disambiguated only by their
35-
-- name that gets tumbled into the hash.
36-
commonTokens :: [Hashable.Token]
44+
when (List.nubOrd hashes /= hashes) $ do
45+
Left IncompleteElementOrderingError
46+
-- Construct a list of tokens that is shared by all members of the component. They are disambiguated only by their
47+
-- name that gets tumbled into the hash.
48+
let commonTokens :: [Hashable.Token]
3749
commonTokens = Hashable.Tag 1 : map Hashable.Hashed hashes
3850
-- Use a helper function that hashes a single term given its name, now that we have an environment in which we can
3951
-- look the name up, as well as the common tokens.
@@ -47,30 +59,33 @@ hashComponent byName =
4759
& sortOn fst
4860
& unzip
4961
overallHash = Hashable.accumulate (map Hashable.Hashed hashes')
50-
in (overallHash, permutedTerms)
62+
pure (overallHash, permutedTerms)
5163

5264
-- Group the definitions into strongly connected components and hash
5365
-- each component. Substitute the hash of each component into subsequent
5466
-- components (using the `termFromHash` function). Requires that the
5567
-- overall component has no free variables.
5668
hashComponents ::
69+
forall f v a.
5770
(Functor f, Hashable1 f, Foldable f, Eq v, Show v, Var v) =>
5871
(Hash -> Word64 -> Term f v ()) ->
5972
Map.Map v (Term f v a) ->
60-
[(Hash, [(v, Term f v a)])]
61-
hashComponents termFromHash termsByName =
73+
Either IncompleteElementOrderingError [(Hash, [(v, Term f v a)])]
74+
hashComponents termFromHash termsByName = do
6275
let bound = Set.fromList (Map.keys termsByName)
6376
escapedVars = Set.unions (freeVars <$> Map.elems termsByName) `Set.difference` bound
6477
sccs = components (Map.toList termsByName)
65-
go _ [] = []
66-
go prevHashes (component : rest) =
78+
go :: Map v (Term f v ()) -> [[(v, Term f v a)]] -> Either IncompleteElementOrderingError [(Hash, [(v, Term f v a)])]
79+
go _ [] = pure $ []
80+
go prevHashes (component : rest) = do
6781
let sub = substsInheritAnnotation (Map.toList prevHashes)
68-
(h, sortedComponent) = hashComponent $ Map.fromList [(v, sub t) | (v, t) <- component]
69-
curHashes = Map.fromList [(v, termFromHash h i) | ((v, _), i) <- sortedComponent `zip` [0 ..]]
82+
(h, sortedComponent) <- hashComponent $ Map.fromList [(v, sub t) | (v, t) <- component]
83+
let curHashes = Map.fromList [(v, termFromHash h i) | ((v, _), i) <- sortedComponent `zip` [0 ..]]
7084
newHashes = prevHashes `Map.union` curHashes
7185
newHashesL = Map.toList newHashes
7286
sortedComponent' = [(v, substsInheritAnnotation newHashesL t) | (v, t) <- sortedComponent]
73-
in (h, sortedComponent') : go newHashes rest
87+
sortedRest <- go newHashes rest
88+
pure $ ((h, sortedComponent') : sortedRest)
7489
in if Set.null escapedVars
7590
then go Map.empty sccs
7691
else

‎unison-hashing-v2/src/Unison/Hashing/V2/DataDeclaration.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -58,7 +58,7 @@ hashDecls0 :: (Eq v, ABT.Var v, Show v) => Map v (DataDeclaration v ()) -> [(v,
5858
hashDecls0 decls =
5959
let abts = toABT <$> decls
6060
ref r = ABT.tm (Type (Type.TypeRef (ReferenceDerivedId r)))
61-
cs = Reference.Util.hashComponents ref abts
61+
cs = fromRight (error "hashDecls0 got unexpected IncompleteElementOrderingError") $ Reference.Util.hashComponents ref abts
6262
in [(v, r) | (v, (r, _)) <- Map.toList cs]
6363

6464
-- | compute the hashes of these user defined types and update any free vars

‎unison-hashing-v2/src/Unison/Hashing/V2/Reference/Util.hs‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -15,9 +15,9 @@ hashComponents ::
1515
(Functor f, Hashable1 f, Foldable f, Eq v, Show v, Var v) =>
1616
(ReferenceId -> ABT.Term f v ()) ->
1717
Map v (ABT.Term f v a) ->
18-
Map v (ReferenceId, ABT.Term f v a)
19-
hashComponents embedRef tms =
20-
Map.fromList [(v, (r, e)) | ((v, e), r) <- cs]
18+
Either ABT.IncompleteElementOrderingError (Map v (ReferenceId, ABT.Term f v a))
19+
hashComponents embedRef tms = do
20+
cs <- Reference.components <$> ABT.hashComponents ref tms
21+
pure $ Map.fromList [(v, (r, e)) | ((v, e), r) <- cs]
2122
where
22-
cs = Reference.components $ ABT.hashComponents ref tms
2323
ref h i = embedRef (ReferenceId h i)

‎unison-hashing-v2/src/Unison/Hashing/V2/Term.hs‎

Lines changed: 7 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -93,9 +93,10 @@ hashTermComponents ::
9393
forall v a extra.
9494
(Var v) =>
9595
Map v (Term v a, Type v a, extra) ->
96-
Map v (ReferenceId, Term v a, Type v a, extra)
97-
hashTermComponents terms =
98-
Zip.zipWith keepExtra terms (ReferenceUtil.hashComponents (refId ()) terms')
96+
Either ABT.IncompleteElementOrderingError (Map v (ReferenceId, Term v a, Type v a, extra))
97+
hashTermComponents terms = do
98+
hashed <- ReferenceUtil.hashComponents (refId ()) terms'
99+
pure $ Zip.zipWith keepExtra terms hashed
99100
where
100101
terms' :: Map v (Term v a)
101102
terms' = incorporateType <$> terms
@@ -117,7 +118,9 @@ hashTermComponents terms =
117118
-- the type that was provided?
118119

119120
hashTermComponentsWithoutTypes :: (Var v) => Map v (Term v a) -> Map v (ReferenceId, Term v a)
120-
hashTermComponentsWithoutTypes = ReferenceUtil.hashComponents $ refId ()
121+
hashTermComponentsWithoutTypes terms =
122+
ReferenceUtil.hashComponents (refId ()) terms
123+
& fromRight (error "hashTermComponentsWithoutTypes got unexpected IncompleteElementOrderingError")
121124

122125
hashClosedTerm :: (Var v) => Term v a -> ReferenceId
123126
hashClosedTerm tm = ReferenceId (ABT.hash tm) 0

0 commit comments

Comments
 (0)