{-# 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 (Validity k -> Validity k -> Bool
(Validity k -> Validity k -> Bool)
-> (Validity k -> Validity k -> Bool) -> Eq (Validity k)
forall k. Eq k => Validity k -> Validity k -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall k. Eq k => Validity k -> Validity k -> Bool
== :: Validity k -> Validity k -> Bool
$c/= :: forall k. Eq k => Validity k -> Validity k -> Bool
/= :: Validity k -> Validity k -> Bool
Eq, Int -> Validity k -> ShowS
[Validity k] -> ShowS
Validity k -> String
(Int -> Validity k -> ShowS)
-> (Validity k -> String)
-> ([Validity k] -> ShowS)
-> Show (Validity k)
forall k. Show k => Int -> Validity k -> ShowS
forall k. Show k => [Validity k] -> ShowS
forall k. Show k => Validity k -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall k. Show k => Int -> Validity k -> ShowS
showsPrec :: Int -> Validity k -> ShowS
$cshow :: forall k. Show k => Validity k -> String
show :: Validity k -> String
$cshowList :: forall k. Show k => [Validity k] -> ShowS
showList :: [Validity k] -> ShowS
Show)

instance Semigroup (Validity k) where
  Validity k
Valid <> :: Validity k -> Validity k -> Validity k
<> Validity k
y = Validity k
y
  Validity k
x     <> Validity k
_ = Validity k
x

instance Monoid (Validity k) where
  mempty :: Validity k
mempty = Validity k
forall k. Validity k
Valid
  mappend :: Validity k -> Validity k -> Validity k
mappend = Validity k -> Validity k -> Validity k
forall a. Semigroup a => a -> a -> a
(<>)

-- | 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 (Error k -> Error k -> Bool
(Error k -> Error k -> Bool)
-> (Error k -> Error k -> Bool) -> Eq (Error k)
forall k. Eq k => Error k -> Error k -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall k. Eq k => Error k -> Error k -> Bool
== :: Error k -> Error k -> Bool
$c/= :: forall k. Eq k => Error k -> Error k -> Bool
/= :: Error k -> Error k -> Bool
Eq, Int -> Error k -> ShowS
[Error k] -> ShowS
Error k -> String
(Int -> Error k -> ShowS)
-> (Error k -> String) -> ([Error k] -> ShowS) -> Show (Error k)
forall k. Show k => Int -> Error k -> ShowS
forall k. Show k => [Error k] -> ShowS
forall k. Show k => Error k -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall k. Show k => Int -> Error k -> ShowS
showsPrec :: Int -> Error k -> ShowS
$cshow :: forall k. Show k => Error k -> String
show :: Error k -> String
$cshowList :: forall k. Show k => [Error k] -> ShowS
showList :: [Error k] -> ShowS
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
  { SubHashPath -> Hash
partialHash :: !Word
    -- ^ The bits we already know, starting from the lower bits.
    -- The unknown upper bits are @0@.
  , SubHashPath -> Int
lengthInBits :: !Int
    -- ^ The number of bits known.
  } deriving (SubHashPath -> SubHashPath -> Bool
(SubHashPath -> SubHashPath -> Bool)
-> (SubHashPath -> SubHashPath -> Bool) -> Eq SubHashPath
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SubHashPath -> SubHashPath -> Bool
== :: SubHashPath -> SubHashPath -> Bool
$c/= :: SubHashPath -> SubHashPath -> Bool
/= :: SubHashPath -> SubHashPath -> Bool
Eq, Int -> SubHashPath -> ShowS
[SubHashPath] -> ShowS
SubHashPath -> String
(Int -> SubHashPath -> ShowS)
-> (SubHashPath -> String)
-> ([SubHashPath] -> ShowS)
-> Show SubHashPath
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SubHashPath -> ShowS
showsPrec :: Int -> SubHashPath -> ShowS
$cshow :: SubHashPath -> String
show :: SubHashPath -> String
$cshowList :: [SubHashPath] -> ShowS
showList :: [SubHashPath] -> ShowS
Show)

initialSubHashPath :: SubHashPath
initialSubHashPath :: SubHashPath
initialSubHashPath = Hash -> Int -> SubHashPath
SubHashPath Hash
0 Int
0

addSubHash :: SubHashPath -> SubHash -> SubHashPath
addSubHash :: SubHashPath -> Hash -> SubHashPath
addSubHash (SubHashPath Hash
ph Int
l) Hash
sh =
  Hash -> Int -> SubHashPath
SubHashPath (Hash
ph Hash -> Hash -> Hash
forall a. Bits a => a -> a -> a
.|. (Hash
sh Hash -> Int -> Hash
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
l)) (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bitsPerSubkey)

hashMatchesSubHashPath :: SubHashPath -> Hash -> Bool
hashMatchesSubHashPath :: SubHashPath -> Hash -> Bool
hashMatchesSubHashPath (SubHashPath Hash
ph Int
l) Hash
h = Hash -> Int -> Hash
forall {a}. (Bits a, Num a) => a -> Int -> a
maskToLength Hash
h Int
l Hash -> Hash -> Bool
forall a. Eq a => a -> a -> Bool
== Hash
ph
  where
    -- Note: This needs to use `shiftL` instead of `unsafeShiftL` because
    -- @l'@ may be greater than 32/64 at the deepest level.
    maskToLength :: a -> Int -> a
maskToLength a
h' Int
l' = a
h' a -> a -> a
forall a. Bits a => a -> a -> a
.&. a -> a
forall a. Bits a => a -> a
complement (a -> a
forall a. Bits a => a -> a
complement a
0 a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
l')

valid :: Hashable k => HashMap k v -> Validity k
valid :: forall k v. Hashable k => HashMap k v -> Validity k
valid HashMap k v
Empty = Validity k
forall k. Validity k
Valid
valid HashMap k v
t     = SubHashPath -> HashMap k v -> Validity k
forall {k} {v}.
Hashable k =>
SubHashPath -> HashMap k v -> Validity k
validInternal SubHashPath
initialSubHashPath HashMap k v
t
  where
    validInternal :: SubHashPath -> HashMap k v -> Validity k
validInternal SubHashPath
p HashMap k v
Empty                 = Error k -> SubHashPath -> Validity k
forall k. Error k -> SubHashPath -> Validity k
Invalid Error k
forall k. Error k
INV1_internal_Empty SubHashPath
p
    validInternal SubHashPath
p (Leaf Hash
h Leaf k v
l)            = SubHashPath -> Hash -> Validity k
forall {k}. SubHashPath -> Hash -> Validity k
validHash SubHashPath
p Hash
h Validity k -> Validity k -> Validity k
forall a. Semigroup a => a -> a -> a
<> SubHashPath -> Hash -> Leaf k v -> Validity k
forall {k} {v}.
Hashable k =>
SubHashPath -> Hash -> Leaf k v -> Validity k
validLeaf SubHashPath
p Hash
h Leaf k v
l
    validInternal SubHashPath
p (Collision Hash
h Array (Leaf k v)
ary)     = SubHashPath -> Hash -> Validity k
forall {k}. SubHashPath -> Hash -> Validity k
validHash SubHashPath
p Hash
h Validity k -> Validity k -> Validity k
forall a. Semigroup a => a -> a -> a
<> SubHashPath -> Hash -> Array (Leaf k v) -> Validity k
forall {k} {v}.
Hashable k =>
SubHashPath -> Hash -> Array (Leaf k v) -> Validity k
validCollision SubHashPath
p Hash
h Array (Leaf k v)
ary
    validInternal SubHashPath
p (BitmapIndexed Hash
b Array (HashMap k v)
ary) = SubHashPath -> Hash -> Array (HashMap k v) -> Validity k
validBitmapIndexed SubHashPath
p Hash
b Array (HashMap k v)
ary
    validInternal SubHashPath
p (Full Array (HashMap k v)
ary)            = SubHashPath -> Array (HashMap k v) -> Validity k
validFull SubHashPath
p Array (HashMap k v)
ary

    validHash :: SubHashPath -> Hash -> Validity k
validHash SubHashPath
p Hash
h | SubHashPath -> Hash -> Bool
hashMatchesSubHashPath SubHashPath
p Hash
h = Validity k
forall k. Validity k
Valid
                  | Bool
otherwise                  = Error k -> SubHashPath -> Validity k
forall k. Error k -> SubHashPath -> Validity k
Invalid (Hash -> Error k
forall k. Hash -> Error k
INV6_misplaced_hash Hash
h) SubHashPath
p

    validLeaf :: SubHashPath -> Hash -> Leaf k v -> Validity k
validLeaf SubHashPath
p Hash
h (L k
k v
_) | k -> Hash
forall a. Hashable a => a -> Hash
hash k
k Hash -> Hash -> Bool
forall a. Eq a => a -> a -> Bool
== Hash
h = Validity k
forall k. Validity k
Valid
                          | Bool
otherwise   = Error k -> SubHashPath -> Validity k
forall k. Error k -> SubHashPath -> Validity k
Invalid (k -> Hash -> Error k
forall k. k -> Hash -> Error k
INV7_key_hash_mismatch k
k Hash
h) SubHashPath
p

    validCollision :: SubHashPath -> Hash -> Array (Leaf k v) -> Validity k
validCollision SubHashPath
p Hash
h Array (Leaf k v)
ary = Validity k
forall k. Validity k
validCollisionSize Validity k -> Validity k -> Validity k
forall a. Semigroup a => a -> a -> a
<> (Leaf k v -> Validity k) -> Array (Leaf k v) -> Validity k
forall m a. Monoid m => (a -> m) -> Array a -> m
A.foldMap (SubHashPath -> Hash -> Leaf k v -> Validity k
forall {k} {v}.
Hashable k =>
SubHashPath -> Hash -> Leaf k v -> Validity k
validLeaf SubHashPath
p Hash
h) Array (Leaf k v)
ary Validity k -> Validity k -> Validity k
forall a. Semigroup a => a -> a -> a
<> Validity k
distinctKeys
      where
        n :: Int
n = Array (Leaf k v) -> Int
forall a. Array a -> Int
A.length Array (Leaf k v)
ary
        validCollisionSize :: Validity k
validCollisionSize | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2     = Error k -> SubHashPath -> Validity k
forall k. Error k -> SubHashPath -> Validity k
Invalid (Int -> Error k
forall k. Int -> Error k
INV9_Collision_size Int
n) SubHashPath
p
                           | Bool
otherwise = Validity k
forall k. Validity k
Valid
        distinctKeys :: Validity k
distinctKeys = (Leaf k v -> Validity k) -> Array (Leaf k v) -> Validity k
forall m a. Monoid m => (a -> m) -> Array a -> m
A.foldMap (\(L k
k v
_) -> k -> Validity k
appearsOnce k
k) Array (Leaf k v)
ary
        appearsOnce :: k -> Validity k
appearsOnce k
k | (Leaf k v -> Sum Int) -> Array (Leaf k v) -> Sum Int
forall m a. Monoid m => (a -> m) -> Array a -> m
A.foldMap (\(L k
k' v
_) -> if k
k' k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
k then forall a. a -> Sum a
Sum @Int Int
1 else Int -> Sum Int
forall a. a -> Sum a
Sum Int
0) Array (Leaf k v)
ary Sum Int -> Sum Int -> Bool
forall a. Eq a => a -> a -> Bool
== Sum Int
1 = Validity k
forall k. Validity k
Valid
                      | Bool
otherwise = Error k -> SubHashPath -> Validity k
forall k. Error k -> SubHashPath -> Validity k
Invalid (k -> Hash -> Error k
forall k. k -> Hash -> Error k
INV10_Collision_duplicate_key k
k Hash
h) SubHashPath
p

    validBitmapIndexed :: SubHashPath -> Hash -> Array (HashMap k v) -> Validity k
validBitmapIndexed SubHashPath
p Hash
b Array (HashMap k v)
ary = Validity k
forall k. Validity k
validBitmap Validity k -> Validity k -> Validity k
forall a. Semigroup a => a -> a -> a
<> Validity k
forall k. Validity k
validArraySize Validity k -> Validity k -> Validity k
forall a. Semigroup a => a -> a -> a
<> SubHashPath -> Hash -> Array (HashMap k v) -> Validity k
validSubTrees SubHashPath
p Hash
b Array (HashMap k v)
ary
      where
        validBitmap :: Validity k
validBitmap | Hash
b Hash -> Hash -> Hash
forall a. Bits a => a -> a -> a
.&. Hash -> Hash
forall a. Bits a => a -> a
complement Hash
fullBitmap Hash -> Hash -> Bool
forall a. Eq a => a -> a -> Bool
== Hash
0 = Validity k
forall k. Validity k
Valid
                    | Bool
otherwise                        = Error k -> SubHashPath -> Validity k
forall k. Error k -> SubHashPath -> Validity k
Invalid (Hash -> Error k
forall k. Hash -> Error k
INV2_Bitmap_unexpected_1_bits Hash
b) SubHashPath
p
        n :: Int
n = Array (HashMap k v) -> Int
forall a. Array a -> Int
A.length Array (HashMap k v)
ary
        validArraySize :: Validity k
validArraySize | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 Bool -> Bool -> Bool
|| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxChildren = Error k -> SubHashPath -> Validity k
forall k. Error k -> SubHashPath -> Validity k
Invalid (Int -> Error k
forall k. Int -> Error k
INV3_bad_BitmapIndexed_size Int
n) SubHashPath
p
                       | Hash -> Int
forall a. Bits a => a -> Int
popCount Hash
b Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n           = Validity k
forall k. Validity k
Valid
                       | Bool
otherwise                 = Error k -> SubHashPath -> Validity k
forall k. Error k -> SubHashPath -> Validity k
Invalid (Hash -> Int -> Error k
forall k. Hash -> Int -> Error k
INV4_bitmap_array_size_mismatch Hash
b Int
n) SubHashPath
p

    validSubTrees :: SubHashPath -> Hash -> Array (HashMap k v) -> Validity k
validSubTrees SubHashPath
p Hash
b Array (HashMap k v)
ary
      | Array (HashMap k v) -> Int
forall a. Array a -> Int
A.length Array (HashMap k v)
ary Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
      , HashMap k v -> Bool
forall k v. HashMap k v -> Bool
isLeafOrCollision (Array (HashMap k v) -> Int -> HashMap k v
forall a. Array a -> Int -> a
A.index Array (HashMap k v)
ary Int
0)
      = Error k -> SubHashPath -> Validity k
forall k. Error k -> SubHashPath -> Validity k
Invalid Error k
forall k. Error k
INV5_BitmapIndexed_invalid_single_subtree SubHashPath
p
      | Bool
otherwise = Hash -> Validity k
go Hash
b
      where
        go :: Hash -> Validity k
go Hash
0  = Validity k
forall k. Validity k
Valid
        go Hash
b' = SubHashPath -> HashMap k v -> Validity k
validInternal (SubHashPath -> Hash -> SubHashPath
addSubHash SubHashPath
p (Int -> Hash
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
c)) (Array (HashMap k v) -> Int -> HashMap k v
forall a. Array a -> Int -> a
A.index Array (HashMap k v)
ary Int
i) Validity k -> Validity k -> Validity k
forall a. Semigroup a => a -> a -> a
<> Hash -> Validity k
go Hash
b''
          where
            c :: Int
c = Hash -> Int
forall b. FiniteBits b => b -> Int
countTrailingZeros Hash
b'
            m :: Hash
m = Hash
1 Hash -> Int -> Hash
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
c
            i :: Int
i = Hash -> Hash -> Int
sparseIndex Hash
b Hash
m
            b'' :: Hash
b'' = Hash
b' Hash -> Hash -> Hash
forall a. Bits a => a -> a -> a
.&. Hash -> Hash
forall a. Bits a => a -> a
complement Hash
m

    validFull :: SubHashPath -> Array (HashMap k v) -> Validity k
validFull SubHashPath
p Array (HashMap k v)
ary = Validity k
forall k. Validity k
validArraySize Validity k -> Validity k -> Validity k
forall a. Semigroup a => a -> a -> a
<> SubHashPath -> Hash -> Array (HashMap k v) -> Validity k
validSubTrees SubHashPath
p Hash
fullBitmap Array (HashMap k v)
ary
      where
        n :: Int
n = Array (HashMap k v) -> Int
forall a. Array a -> Int
A.length Array (HashMap k v)
ary
        validArraySize :: Validity k
validArraySize | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
maxChildren = Validity k
forall k. Validity k
Valid
                       | Bool
otherwise        = Error k -> SubHashPath -> Validity k
forall k. Error k -> SubHashPath -> Validity k
Invalid (Int -> Error k
forall k. Int -> Error k
INV8_bad_Full_size Int
n) SubHashPath
p