Skip to content

Commit b03df23

Browse files
sjakobisjakobi
committed
Move debugging facilities to D.HM.I.Debug
1 parent 214711c commit b03df23

File tree

4 files changed

+143
-113
lines changed

4 files changed

+143
-113
lines changed

‎Data/HashMap/Internal.hs

Lines changed: 4 additions & 95 deletions
Original file line numberDiff line numberDiff line change
@@ -108,13 +108,6 @@ module Data.HashMap.Internal
108108
, fromListWith
109109
, fromListWithKey
110110

111-
-- * Debugging
112-
, valid
113-
, Validity(..)
114-
, Error(..)
115-
, SubHash
116-
, SubHashPath
117-
118111
-- ** Internals used by the strict version
119112
, Hash
120113
, Bitmap
@@ -125,7 +118,10 @@ module Data.HashMap.Internal
125118
, mask
126119
, index
127120
, bitsPerSubkey
121+
, maxChildren
122+
, isLeafOrCollision
128123
, fullBitmap
124+
, subkeyMask
129125
, nextShift
130126
, sparseIndex
131127
, two
@@ -165,8 +161,7 @@ import Data.Functor.Identity (Identity (..))
165161
import Data.Hashable (Hashable)
166162
import Data.Hashable.Lifted (Hashable1, Hashable2)
167163
import Data.HashMap.Internal.List (isPermutationBy, unorderedCompare)
168-
import Data.Semigroup (Semigroup (..), Sum (..),
169-
stimesIdempotentMonoid)
164+
import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid)
170165
import GHC.Exts (Int (..), Int#, TYPE, (==#))
171166
import GHC.Stack (HasCallStack)
172167
import Prelude hiding (filter, foldl, foldr, lookup, map,
@@ -2465,89 +2460,3 @@ instance (Eq k, Hashable k) => Exts.IsList (HashMap k v) where
24652460
type Item (HashMap k v) = (k, v)
24662461
fromList = fromList
24672462
toList = toList
2468-
2469-
------------------------------------------------------------------------
2470-
-- Debugging
2471-
2472-
data Validity k = Invalid (Error k) SubHashPath | Valid
2473-
deriving (Eq, Show)
2474-
2475-
instance Semigroup (Validity k) where
2476-
Valid <> y = y
2477-
x <> _ = x
2478-
2479-
instance Monoid (Validity k) where
2480-
mempty = Valid
2481-
mappend = (<>)
2482-
2483-
data Error k
2484-
= INV1_internal_Empty
2485-
| INV2_misplaced_hash !Hash
2486-
| INV3_key_hash_mismatch k !Hash
2487-
| INV4_Collision_size !Int
2488-
| INV5_Collision_duplicate_key k !Hash
2489-
| INV6_bad_BitmapIndexed_size !Int
2490-
| INV7_bitmap_array_size_mismatch !Bitmap !Int
2491-
| INV8_BitmapIndexed_invalid_single_subtree
2492-
| INV9_bad_Full_size !Int
2493-
deriving (Eq, Show)
2494-
2495-
-- | A part of a 'Hash' with 'bitsPerSubkey' bits.
2496-
type SubHash = Word
2497-
2498-
type SubHashPath = [SubHash]
2499-
2500-
valid :: Hashable k => HashMap k v -> Validity k
2501-
valid Empty = Valid
2502-
valid t = validInternal [] t
2503-
where
2504-
validInternal p Empty = Invalid INV1_internal_Empty p
2505-
validInternal p (Leaf h l) = validHash p h <> validLeaf p h l
2506-
validInternal p (Collision h ary) = validHash p h <> validCollision p h ary
2507-
validInternal p (BitmapIndexed b ary) = validBitmapIndexed p b ary
2508-
validInternal p (Full ary) = validFull p ary
2509-
2510-
validHash p0 h0 = go (reverse p0) h0
2511-
where
2512-
go [] !_ = Valid
2513-
go (sh:p) h | h .&. subkeyMask == sh = go p (h `unsafeShiftR` bitsPerSubkey)
2514-
| otherwise = Invalid (INV2_misplaced_hash h0) p0
2515-
2516-
validLeaf p h (L k _) | hash k == h = Valid
2517-
| otherwise = Invalid (INV3_key_hash_mismatch k h) p
2518-
2519-
validCollision p h ary = validCollisionSize <> A.foldMap (validLeaf p h) ary <> distinctKeys
2520-
where
2521-
n = A.length ary
2522-
validCollisionSize | n < 2 = Invalid (INV4_Collision_size n) p
2523-
| otherwise = Valid
2524-
distinctKeys = A.foldMap (\(L k _) -> appearsOnce k) ary
2525-
appearsOnce k | A.foldMap (\(L k' _) -> if k' == k then Sum @Int 1 else Sum 0) ary == 1 = Valid
2526-
| otherwise = Invalid (INV5_Collision_duplicate_key k h) p
2527-
2528-
validBitmapIndexed p b ary = validArraySize <> validSubTrees p b ary
2529-
where
2530-
n = A.length ary
2531-
validArraySize | n < 1 || n >= maxChildren = Invalid (INV6_bad_BitmapIndexed_size n) p
2532-
| popCount b == n = Valid
2533-
| otherwise = Invalid (INV7_bitmap_array_size_mismatch b n) p
2534-
2535-
validSubTrees p b ary
2536-
| A.length ary == 1
2537-
, isLeafOrCollision (A.index ary 0)
2538-
= Invalid INV8_BitmapIndexed_invalid_single_subtree p
2539-
| otherwise = go b
2540-
where
2541-
go 0 = Valid
2542-
go b' = validInternal (fromIntegral c : p) (A.index ary i) <> go b''
2543-
where
2544-
c = countTrailingZeros b'
2545-
m = 1 `unsafeShiftL` c
2546-
i = sparseIndex b m
2547-
b'' = b' .&. complement m
2548-
2549-
validFull p ary = validArraySize <> validSubTrees p fullBitmap ary
2550-
where
2551-
n = A.length ary
2552-
validArraySize | n == maxChildren = Valid
2553-
| otherwise = Invalid (INV9_bad_Full_size n) p

‎Data/HashMap/Internal/Debug.hs

Lines changed: 120 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,120 @@
1+
{-# LANGUAGE BangPatterns #-}
2+
{-# LANGUAGE TypeApplications #-}
3+
4+
-- | = WARNING
5+
--
6+
-- This module is considered __internal__.
7+
--
8+
-- The Package Versioning Policy __does not apply__.
9+
--
10+
-- The contents of this module may change __in any way whatsoever__
11+
-- and __without any warning__ between minor versions of this package.
12+
--
13+
-- Authors importing this module are expected to track development
14+
-- closely.
15+
--
16+
-- = Description
17+
--
18+
-- Debugging utilities for 'HashMap's.
19+
20+
module Data.HashMap.Internal.Debug
21+
( valid
22+
, Validity(..)
23+
, Error(..)
24+
, SubHash
25+
, SubHashPath
26+
) where
27+
28+
import Data.Bits (complement, countTrailingZeros, popCount,
29+
unsafeShiftL, unsafeShiftR, (.&.))
30+
import Data.Hashable (Hashable)
31+
import Data.HashMap.Internal (Bitmap, Hash, HashMap (..), Leaf (..),
32+
bitsPerSubkey, fullBitmap, hash,
33+
isLeafOrCollision, maxChildren, sparseIndex,
34+
subkeyMask)
35+
import Data.Semigroup (Sum (..))
36+
37+
import qualified Data.HashMap.Internal.Array as A
38+
39+
data Validity k = Invalid (Error k) SubHashPath | Valid
40+
deriving (Eq, Show)
41+
42+
instance Semigroup (Validity k) where
43+
Valid <> y = y
44+
x <> _ = x
45+
46+
instance Monoid (Validity k) where
47+
mempty = Valid
48+
mappend = (<>)
49+
50+
data Error k
51+
= INV1_internal_Empty
52+
| INV2_misplaced_hash !Hash
53+
| INV3_key_hash_mismatch k !Hash
54+
| INV4_Collision_size !Int
55+
| INV5_Collision_duplicate_key k !Hash
56+
| INV6_bad_BitmapIndexed_size !Int
57+
| INV7_bitmap_array_size_mismatch !Bitmap !Int
58+
| INV8_BitmapIndexed_invalid_single_subtree
59+
| INV9_bad_Full_size !Int
60+
deriving (Eq, Show)
61+
62+
-- | A part of a 'Hash' with 'bitsPerSubkey' bits.
63+
type SubHash = Word
64+
65+
type SubHashPath = [SubHash]
66+
67+
valid :: Hashable k => HashMap k v -> Validity k
68+
valid Empty = Valid
69+
valid t = validInternal [] t
70+
where
71+
validInternal p Empty = Invalid INV1_internal_Empty p
72+
validInternal p (Leaf h l) = validHash p h <> validLeaf p h l
73+
validInternal p (Collision h ary) = validHash p h <> validCollision p h ary
74+
validInternal p (BitmapIndexed b ary) = validBitmapIndexed p b ary
75+
validInternal p (Full ary) = validFull p ary
76+
77+
validHash p0 h0 = go (reverse p0) h0
78+
where
79+
go [] !_ = Valid
80+
go (sh:p) h | h .&. subkeyMask == sh = go p (h `unsafeShiftR` bitsPerSubkey)
81+
| otherwise = Invalid (INV2_misplaced_hash h0) p0
82+
83+
validLeaf p h (L k _) | hash k == h = Valid
84+
| otherwise = Invalid (INV3_key_hash_mismatch k h) p
85+
86+
validCollision p h ary = validCollisionSize <> A.foldMap (validLeaf p h) ary <> distinctKeys
87+
where
88+
n = A.length ary
89+
validCollisionSize | n < 2 = Invalid (INV4_Collision_size n) p
90+
| otherwise = Valid
91+
distinctKeys = A.foldMap (\(L k _) -> appearsOnce k) ary
92+
appearsOnce k | A.foldMap (\(L k' _) -> if k' == k then Sum @Int 1 else Sum 0) ary == 1 = Valid
93+
| otherwise = Invalid (INV5_Collision_duplicate_key k h) p
94+
95+
validBitmapIndexed p b ary = validArraySize <> validSubTrees p b ary
96+
where
97+
n = A.length ary
98+
validArraySize | n < 1 || n >= maxChildren = Invalid (INV6_bad_BitmapIndexed_size n) p
99+
| popCount b == n = Valid
100+
| otherwise = Invalid (INV7_bitmap_array_size_mismatch b n) p
101+
102+
validSubTrees p b ary
103+
| A.length ary == 1
104+
, isLeafOrCollision (A.index ary 0)
105+
= Invalid INV8_BitmapIndexed_invalid_single_subtree p
106+
| otherwise = go b
107+
where
108+
go 0 = Valid
109+
go b' = validInternal (fromIntegral c : p) (A.index ary i) <> go b''
110+
where
111+
c = countTrailingZeros b'
112+
m = 1 `unsafeShiftL` c
113+
i = sparseIndex b m
114+
b'' = b' .&. complement m
115+
116+
validFull p ary = validArraySize <> validSubTrees p fullBitmap ary
117+
where
118+
n = A.length ary
119+
validArraySize | n == maxChildren = Valid
120+
| otherwise = Invalid (INV9_bad_Full_size n) p

‎tests/Properties/HashMapLazy.hs

Lines changed: 18 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -14,24 +14,24 @@
1414

1515
module MODULE_NAME (tests) where
1616

17-
import Control.Applicative (Const (..))
18-
import Control.Monad (guard)
17+
import Control.Applicative (Const (..))
18+
import Control.Monad (guard)
1919
import Data.Bifoldable
20-
import Data.Function (on)
21-
import Data.Functor.Identity (Identity (..))
22-
import Data.Hashable (Hashable (hashWithSalt))
23-
import Data.Ord (comparing)
24-
import Test.QuickCheck (Arbitrary (..), Property, elements, forAll,
25-
property, (===), (==>))
26-
import Test.QuickCheck.Function (Fun, apply)
27-
import Test.QuickCheck.Poly (A, B)
28-
import Test.Tasty (TestTree, testGroup)
29-
import Test.Tasty.QuickCheck (testProperty)
30-
import Util.Key (Key, keyToInt)
31-
32-
import qualified Data.Foldable as Foldable
33-
import qualified Data.HashMap.Internal as HMI
34-
import qualified Data.List as List
20+
import Data.Function (on)
21+
import Data.Functor.Identity (Identity (..))
22+
import Data.Hashable (Hashable (hashWithSalt))
23+
import Data.HashMap.Internal.Debug (Validity (..), valid)
24+
import Data.Ord (comparing)
25+
import Test.QuickCheck (Arbitrary (..), Property, elements, forAll,
26+
property, (===), (==>))
27+
import Test.QuickCheck.Function (Fun, apply)
28+
import Test.QuickCheck.Poly (A, B)
29+
import Test.Tasty (TestTree, testGroup)
30+
import Test.Tasty.QuickCheck (testProperty)
31+
import Util.Key (Key, keyToInt)
32+
33+
import qualified Data.Foldable as Foldable
34+
import qualified Data.List as List
3535

3636
#if defined(STRICT)
3737
import Data.HashMap.Strict (HashMap)
@@ -321,7 +321,7 @@ pIntersection xs ys =
321321
$ ys
322322

323323
pIntersectionValid :: HashMap Key () -> HashMap Key () -> Property
324-
pIntersectionValid x y = HMI.valid (HM.intersection x y) === HMI.Valid
324+
pIntersectionValid x y = valid (HM.intersection x y) === Valid
325325

326326
pIntersectionWith :: [(Key, Int)] -> [(Key, Int)] -> Property
327327
pIntersectionWith xs ys = M.intersectionWith (-) (M.fromList xs) `eq_`

‎unordered-containers.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -45,6 +45,7 @@ library
4545
exposed-modules:
4646
Data.HashMap.Internal
4747
Data.HashMap.Internal.Array
48+
Data.HashMap.Internal.Debug
4849
Data.HashMap.Internal.List
4950
Data.HashMap.Internal.Strict
5051
Data.HashMap.Lazy

0 commit comments

Comments
 (0)