Move debugging facilities to D.HM.I.Debug

Author: sjakobi

Data/HashMap/Internal.hs

@@ -108,13 +108,6 @@ module Data.HashMap.Internal
     , fromListWith
     , fromListWithKey
 
-      -- * Debugging
-    , valid
-    , Validity(..)
-    , Error(..)
-    , SubHash
-    , SubHashPath
-
       -- ** Internals used by the strict version
     , Hash
     , Bitmap
@@ -125,7 +118,10 @@ module Data.HashMap.Internal
     , mask
     , index
     , bitsPerSubkey
+    , maxChildren
+    , isLeafOrCollision
     , fullBitmap
+    , subkeyMask
     , nextShift
     , sparseIndex
     , two
@@ -165,8 +161,7 @@ import Data.Functor.Identity      (Identity (..))
 import Data.Hashable              (Hashable)
 import Data.Hashable.Lifted       (Hashable1, Hashable2)
 import Data.HashMap.Internal.List (isPermutationBy, unorderedCompare)
-import Data.Semigroup             (Semigroup (..), Sum (..),
-                                   stimesIdempotentMonoid)
+import Data.Semigroup             (Semigroup (..), stimesIdempotentMonoid)
 import GHC.Exts                   (Int (..), Int#, TYPE, (==#))
 import GHC.Stack                  (HasCallStack)
 import Prelude                    hiding (filter, foldl, foldr, lookup, map,
@@ -2465,89 +2460,3 @@ instance (Eq k, Hashable k) => Exts.IsList (HashMap k v) where
     type Item (HashMap k v) = (k, v)
     fromList = fromList
     toList   = toList
-
-------------------------------------------------------------------------
--- Debugging
-
-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 = (<>)
-
-data Error k
-  = INV1_internal_Empty
-  | INV2_misplaced_hash !Hash
-  | INV3_key_hash_mismatch k !Hash
-  | INV4_Collision_size !Int
-  | INV5_Collision_duplicate_key k !Hash
-  | INV6_bad_BitmapIndexed_size !Int
-  | INV7_bitmap_array_size_mismatch !Bitmap !Int
-  | INV8_BitmapIndexed_invalid_single_subtree
-  | INV9_bad_Full_size !Int
-  deriving (Eq, Show)
-
--- | A part of a 'Hash' with 'bitsPerSubkey' bits.
-type SubHash = Word
-
-type SubHashPath = [SubHash]
-
-valid :: Hashable k => HashMap k v -> Validity k
-valid Empty = Valid
-valid t     = validInternal [] 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 p0 h0 = go (reverse p0) h0
-      where
-        go [] !_ = Valid
-        go (sh:p) h | h .&. subkeyMask == sh = go p (h `unsafeShiftR` bitsPerSubkey)
-                    | otherwise              = Invalid (INV2_misplaced_hash h0) p0
-
-    validLeaf p h (L k _) | hash k == h = Valid
-                          | otherwise   = Invalid (INV3_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 (INV4_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 (INV5_Collision_duplicate_key k h) p
-
-    validBitmapIndexed p b ary = validArraySize <> validSubTrees p b ary
-      where
-        n = A.length ary
-        validArraySize | n < 1 || n >= maxChildren = Invalid (INV6_bad_BitmapIndexed_size n) p
-                       | popCount b == n           = Valid
-                       | otherwise                 = Invalid (INV7_bitmap_array_size_mismatch b n) p
-
-    validSubTrees p b ary
-      | A.length ary == 1
-      , isLeafOrCollision (A.index ary 0)
-      = Invalid INV8_BitmapIndexed_invalid_single_subtree p
-      | otherwise = go b
-      where
-        go 0  = Valid
-        go b' = validInternal (fromIntegral c : p) (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 (INV9_bad_Full_size n) p

tests/Properties/HashMapLazy.hs

@@ -14,24 +14,24 @@
 
 module MODULE_NAME (tests) where
 
-import Control.Applicative      (Const (..))
-import Control.Monad            (guard)
+import Control.Applicative         (Const (..))
+import Control.Monad               (guard)
 import Data.Bifoldable
-import Data.Function            (on)
-import Data.Functor.Identity    (Identity (..))
-import Data.Hashable            (Hashable (hashWithSalt))
-import Data.Ord                 (comparing)
-import Test.QuickCheck          (Arbitrary (..), Property, elements, forAll,
-                                 property, (===), (==>))
-import Test.QuickCheck.Function (Fun, apply)
-import Test.QuickCheck.Poly     (A, B)
-import Test.Tasty               (TestTree, testGroup)
-import Test.Tasty.QuickCheck    (testProperty)
-import Util.Key                 (Key, keyToInt)
-
-import qualified Data.Foldable         as Foldable
-import qualified Data.HashMap.Internal as HMI
-import qualified Data.List             as List
+import Data.Function               (on)
+import Data.Functor.Identity       (Identity (..))
+import Data.Hashable               (Hashable (hashWithSalt))
+import Data.HashMap.Internal.Debug (Validity (..), valid)
+import Data.Ord                    (comparing)
+import Test.QuickCheck             (Arbitrary (..), Property, elements, forAll,
+                                    property, (===), (==>))
+import Test.QuickCheck.Function    (Fun, apply)
+import Test.QuickCheck.Poly        (A, B)
+import Test.Tasty                  (TestTree, testGroup)
+import Test.Tasty.QuickCheck       (testProperty)
+import Util.Key                    (Key, keyToInt)
+
+import qualified Data.Foldable as Foldable
+import qualified Data.List     as List
 
 #if defined(STRICT)
 import           Data.HashMap.Strict (HashMap)
@@ -321,7 +321,7 @@ pIntersection xs ys =
     $ ys
 
 pIntersectionValid :: HashMap Key () -> HashMap Key () -> Property
-pIntersectionValid x y = HMI.valid (HM.intersection x y) === HMI.Valid
+pIntersectionValid x y = valid (HM.intersection x y) === Valid
 
 pIntersectionWith :: [(Key, Int)] -> [(Key, Int)] -> Property
 pIntersectionWith xs ys = M.intersectionWith (-) (M.fromList xs) `eq_`

unordered-containers.cabal

@@ -45,6 +45,7 @@ library
   exposed-modules:
     Data.HashMap.Internal
     Data.HashMap.Internal.Array
+    Data.HashMap.Internal.Debug
     Data.HashMap.Internal.List
     Data.HashMap.Internal.Strict
     Data.HashMap.Lazy