@@ -36,10 +36,11 @@ import Data.Function (on)
3636import Data.Kind (Type)
3737import Data.Type.Equality ((:~:) (..), TestEquality (..))
3838import Data.List (intercalate, nubBy)
39+import Data.Maybe (fromMaybe)
3940import Data.Primitive.Array (Array, MutableArray, indexArray, mapArray', readArray, sizeofArray,
4041 thawArray, unsafeFreezeArray, writeArray)
4142import Data.Primitive.PrimArray (PrimArray, indexPrimArray, sizeofPrimArray)
42−import Data.Semigroup (Semigroup (..))
43+import Data.Semigroup (Semigroup (..), All(..))
4344import GHC.Base (Any, Int (..), Int#, (*#), (+#), (<#))
4445import GHC.Exts (IsList (..), inline, sortWith)
4546import GHC.Fingerprint (Fingerprint (..))
@@ -448,3 +449,62 @@ fromSortedList l = runST $ do
448449 newFirst <- loop (2 * i + 1) first
449450 writeArray result i (indexArray origin newFirst)
450451 loop (2 * i + 2) (newFirst + 1)
452+
453+----------------------------------------------------------------------------
454+-- Helper functions.
455+----------------------------------------------------------------------------
456+
457+-- | Check that invariant of the structure is hold.
458+-- The structure maintains the following invariant.
459+-- For each element @A@ at index @i@:
460+--
461+-- 1. if there is an element @B@ at index @2*i+1@,
462+-- then @B < A@.
463+--
464+-- 2. if there is an element @C@ at index @2*i+2@,
465+-- then @A < C@.
466+--
467+invariantCheck :: TypeRepMap f -> Bool
468+invariantCheck TypeRepMap{..} = getAll (check 0)
469+ where
470+ lastMay [] = Nothing
471+ lastMay [x] = Just x
472+ lastMay (_:xs) = lastMay xs
473+ sz = sizeofPrimArray fingerprintAs
474+ check i | i >= sz = All True
475+ | otherwise =
476+ let left = i*2+1
477+ right = i*2+2
478+ -- maximum value in the left branch
479+ leftMax =
480+ fmap (\j -> (indexPrimArray fingerprintAs j, indexPrimArray fingerprintBs j))
481+ $ lastMay
482+ $ takeWhile (<sz)
483+ $ iterate (\j -> j*2+2) left
484+ -- minimum value in the right branch
485+ rightMin =
486+ fmap (\j -> (indexPrimArray fingerprintAs j, indexPrimArray fingerprintBs j))
487+ $ lastMay
488+ $ takeWhile (<sz)
489+ $ iterate (\j -> j*2+1) right
490+ in mconcat
491+ [ All $
492+ if left < sz
493+ then
494+ case indexPrimArray fingerprintAs i `compare` indexPrimArray fingerprintAs left of
495+ LT -> False
496+ EQ -> indexPrimArray fingerprintBs i >= indexPrimArray fingerprintBs left
497+ GT -> True
498+ else True
499+ , All $
500+ if right < sz
501+ then
502+ case indexPrimArray fingerprintAs i `compare` indexPrimArray fingerprintAs right of
503+ LT -> True
504+ EQ -> indexPrimArray fingerprintBs i <= indexPrimArray fingerprintBs right
505+ GT -> False
506+ else True
507+ , All $ fromMaybe True $ (<=) <$> leftMax <*> rightMin
508+ , check (i+1)
509+ ]
510+