2aff258 · typerep-map · git.iko.soy

git.iko.soy/typerep-map

on main help sign in

Introduce invariant check. (#63)

2aff258Alexander Vershilov7 years ago

src/Data/TypeRepMap/Internal.hs+61−1

compare with main

unifiedsplit

@@ -36,10 +36,11 @@ import Data.Function (on)

36import Data.Kind (Type)

37import Data.Type.Equality ((:~:) (..), TestEquality (..))

38import Data.List (intercalate, nubBy)

39+import Data.Maybe (fromMaybe)

39import Data.Primitive.Array (Array, MutableArray, indexArray, mapArray', readArray, sizeofArray,

40import Data.Primitive.Array (Array, MutableArray, indexArray, mapArray', readArray, sizeofArray,

40 thawArray, unsafeFreezeArray, writeArray)

41 thawArray, unsafeFreezeArray, writeArray)

41import Data.Primitive.PrimArray (PrimArray, indexPrimArray, sizeofPrimArray)

42import Data.Primitive.PrimArray (PrimArray, indexPrimArray, sizeofPrimArray)

42−import Data.Semigroup (Semigroup (..))

43+import Data.Semigroup (Semigroup (..), All(..))

43import GHC.Base (Any, Int (..), Int#, (*#), (+#), (<#))

44import GHC.Base (Any, Int (..), Int#, (*#), (+#), (<#))

44import GHC.Exts (IsList (..), inline, sortWith)

45import GHC.Exts (IsList (..), inline, sortWith)

45import GHC.Fingerprint (Fingerprint (..))

46import GHC.Fingerprint (Fingerprint (..))

@@ -448,3 +449,62 @@ fromSortedList l = runST $ do

448 newFirst <- loop (2 * i + 1) first

449 newFirst <- loop (2 * i + 1) first

449 writeArray result i (indexArray origin newFirst)

450 writeArray result i (indexArray origin newFirst)

450 loop (2 * i + 2) (newFirst + 1)

451 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+

test/Test/TypeRep/MapProperty.hs+14−3

@@ -15,11 +15,11 @@ import Data.Semigroup (Semigroup (..))

15import GHC.Exts (fromList)

16import GHC.Stack (HasCallStack)

17import GHC.TypeLits (Nat, SomeNat (..), someNatVal)

18−import Hedgehog (MonadGen, PropertyT, forAll, property, (===))

18+import Hedgehog (MonadGen, PropertyT, forAll, property, (===), assert)

19import Test.Tasty (TestName, TestTree)

20import Test.Tasty.Hedgehog (testProperty)

22−import Data.TypeRepMap.Internal (TypeRepMap (..), WrapTypeable (..), delete, insert, lookup, member)

22+import Data.TypeRepMap.Internal (TypeRepMap (..), WrapTypeable (..), delete, insert, lookup, member, invariantCheck)

24import qualified Hedgehog.Gen as Gen

25import qualified Hedgehog.Range as Range

@@ -41,7 +41,6 @@ test_InsertLookup :: PropertyTest

41test_InsertLookup = prop "lookup k (insert k v m) == Just v" $ do

42 m <- forAll genMap

43 WrapTypeable (proxy :: IntProxy n) <- forAll genTF

44−

45 lookup @n @IntProxy (insert proxy m) === Just proxy

44 lookup @n @IntProxy (insert proxy m) === Just proxy

47test_InsertInsert :: PropertyTest

46test_InsertInsert :: PropertyTest

@@ -62,6 +61,18 @@ test_DeleteMember = prop "member k . delete k == False" $ do

62 else

61 else

63 member @n (delete @n m) === False

62 member @n (delete @n m) === False

64+test_InsertInvariant :: PropertyTest

65+test_InsertInvariant = prop "invariantCheck (insert k b) == True" $ do

66+ m <- forAll genMap

67+ WrapTypeable a <- forAll genTF

68+ assert $ invariantCheck (insert a m)

69+

70+test_DeleteInvariant :: PropertyTest

71+test_DeleteInvariant = prop "invariantCheck (delete k b) == True" $ do

72+ m <- forAll genMap

73+ WrapTypeable (_ :: IntProxy n) <- forAll genTF

74+ assert $ invariantCheck (delete @n m)

75+

65----------------------------------------------------------------------------

76----------------------------------------------------------------------------

66-- Semigroup and Monoid laws

77-- Semigroup and Monoid laws

67----------------------------------------------------------------------------

78----------------------------------------------------------------------------