1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeApplications #-}
-- | = WARNING
--
-- This module is considered __internal__.
--
-- The Package Versioning Policy __does not apply__.
--
-- The contents of this module may change __in any way whatsoever__
-- and __without any warning__ between minor versions of this package.
--
-- Authors importing this module are expected to track development
-- closely.
--
-- = Description
--
-- Debugging utilities for 'HashMap's.
module Data.HashMap.Internal.Debug
( valid
, Validity(..)
, Error(..)
, SubHash
, SubHashPath
) where
import Data.Bits (complement, countTrailingZeros, popCount, shiftL,
unsafeShiftL, (.&.), (.|.))
import Data.Hashable (Hashable)
import Data.HashMap.Internal (Bitmap, Hash, HashMap (..), Leaf (..),
bitsPerSubkey, fullBitmap, hash,
isLeafOrCollision, maxChildren, sparseIndex)
import Data.Semigroup (Sum (..))
import qualified Data.HashMap.Internal.Array as A
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup (Semigroup (..))
#endif
data Validity k = Invalid (Error k) SubHashPath | Valid
deriving (Eq, Show)
instance Semigroup (Validity k) where
Valid <> y = y
x <> _ = x
instance Monoid (Validity k) where
mempty = Valid
mappend = (<>)
-- | An error corresponding to a broken invariant.
--
-- See 'HashMap' for the documentation of the invariants.
data Error k
= INV1_internal_Empty
| INV2_Bitmap_unexpected_1_bits !Bitmap
| INV3_bad_BitmapIndexed_size !Int
| INV4_bitmap_array_size_mismatch !Bitmap !Int
| INV5_BitmapIndexed_invalid_single_subtree
| INV6_misplaced_hash !Hash
| INV7_key_hash_mismatch k !Hash
| INV8_bad_Full_size !Int
| INV9_Collision_size !Int
| INV10_Collision_duplicate_key k !Hash
deriving (Eq, Show)
-- TODO: Name this 'Index'?!
-- (https://github.com/haskell-unordered-containers/unordered-containers/issues/425)
-- | A part of a 'Hash' with 'bitsPerSubkey' bits.
type SubHash = Word
data SubHashPath = SubHashPath
{ partialHash :: !Word
-- ^ The bits we already know, starting from the lower bits.
-- The unknown upper bits are @0@.
, lengthInBits :: !Int
-- ^ The number of bits known.
} deriving (Eq, Show)
initialSubHashPath :: SubHashPath
initialSubHashPath = SubHashPath 0 0
addSubHash :: SubHashPath -> SubHash -> SubHashPath
addSubHash (SubHashPath ph l) sh =
SubHashPath (ph .|. (sh `unsafeShiftL` l)) (l + bitsPerSubkey)
hashMatchesSubHashPath :: SubHashPath -> Hash -> Bool
hashMatchesSubHashPath (SubHashPath ph l) h = maskToLength h l == ph
where
-- Note: This needs to use `shiftL` instead of `unsafeShiftL` because
-- @l'@ may be greater than 32/64 at the deepest level.
maskToLength h' l' = h' .&. complement (complement 0 `shiftL` l')
valid :: Hashable k => HashMap k v -> Validity k
valid Empty = Valid
valid t = validInternal initialSubHashPath t
where
validInternal p Empty = Invalid INV1_internal_Empty p
validInternal p (Leaf h l) = validHash p h <> validLeaf p h l
validInternal p (Collision h ary) = validHash p h <> validCollision p h ary
validInternal p (BitmapIndexed b ary) = validBitmapIndexed p b ary
validInternal p (Full ary) = validFull p ary
validHash p h | hashMatchesSubHashPath p h = Valid
| otherwise = Invalid (INV6_misplaced_hash h) p
validLeaf p h (L k _) | hash k == h = Valid
| otherwise = Invalid (INV7_key_hash_mismatch k h) p
validCollision p h ary = validCollisionSize <> A.foldMap (validLeaf p h) ary <> distinctKeys
where
n = A.length ary
validCollisionSize | n < 2 = Invalid (INV9_Collision_size n) p
| otherwise = Valid
distinctKeys = A.foldMap (\(L k _) -> appearsOnce k) ary
appearsOnce k | A.foldMap (\(L k' _) -> if k' == k then Sum @Int 1 else Sum 0) ary == 1 = Valid
| otherwise = Invalid (INV10_Collision_duplicate_key k h) p
validBitmapIndexed p b ary = validBitmap <> validArraySize <> validSubTrees p b ary
where
validBitmap | b .&. complement fullBitmap == 0 = Valid
| otherwise = Invalid (INV2_Bitmap_unexpected_1_bits b) p
n = A.length ary
validArraySize | n < 1 || n >= maxChildren = Invalid (INV3_bad_BitmapIndexed_size n) p
| popCount b == n = Valid
| otherwise = Invalid (INV4_bitmap_array_size_mismatch b n) p
validSubTrees p b ary
| A.length ary == 1
, isLeafOrCollision (A.index ary 0)
= Invalid INV5_BitmapIndexed_invalid_single_subtree p
| otherwise = go b
where
go 0 = Valid
go b' = validInternal (addSubHash p (fromIntegral c)) (A.index ary i) <> go b''
where
c = countTrailingZeros b'
m = 1 `unsafeShiftL` c
i = sparseIndex b m
b'' = b' .&. complement m
validFull p ary = validArraySize <> validSubTrees p fullBitmap ary
where
n = A.length ary
validArraySize | n == maxChildren = Valid
| otherwise = Invalid (INV8_bad_Full_size n) p
|
