TypeRepMapProperty.hs

{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PolyKinds                  #-}

{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}

module Test.TypeRep.TypeRepMapProperty
    ( typeRepMapPropertySpec
    ) where

import Prelude hiding (lookup)

import Data.Proxy (Proxy (..))
import GHC.Exts (fromList)
import GHC.TypeLits (Nat, SomeNat (..), someNatVal)
import Hedgehog (MonadGen, assert, forAll, (===))
import Test.Hspec (Arg, Expectation, Spec, SpecWith, describe, it)
import Test.Hspec.Hedgehog (hedgehog)

import Data.TypeRepMap.Internal (TypeRepMap (..), WrapTypeable (..), delete, insert, invariantCheck,
                                 lookup, member, union, generateOrderMapping, fromSortedList,
                                 adjust, alter, intersection)

import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range


typeRepMapPropertySpec :: Spec
typeRepMapPropertySpec = describe "TypeRepMap Property tests" $ do
    describe "Map modification properties" $ do
        insertLookupSpec
        insertInsertSpec
        deleteMemberSpec
        insertInvariantSpec
        deleteInvariantSpec
        alterInsertSpec
        alterDeleteSpec
        alterAdjustSpec
        alterModifySpec
        intersectionSpec
    describe "Internal helpers" $ do
        generateOrderMappingInvariantSpec
    describe "Instance Laws" $ do
        semigroupAssocSpec
        monoidIdentitySpec

----------------------------------------------------------------------------
-- Map modification properties
----------------------------------------------------------------------------

type Property = SpecWith (Arg Expectation)

insertLookupSpec :: Property
insertLookupSpec = it "lookup k (insert k v m) == Just v" $ hedgehog $ do
    m <- forAll genMap
    WrapTypeable (proxy :: IntProxy n) <- forAll genTF
    lookup @n @IntProxy (insert proxy m) === Just proxy

insertInsertSpec :: Property
insertInsertSpec = it "insert k b . insert k a == insert k b" $ hedgehog $ do
    m <- forAll genMap
    WrapTypeable a@(IntProxy (proxy :: Proxy n) i) <- forAll genTF
    let b = IntProxy proxy (i + 1)
    lookup @n @IntProxy (insert b $ insert a m) === Just b

deleteMemberSpec :: Property
deleteMemberSpec = it "member k . delete k == False" $ hedgehog $ do
    m <- forAll genMap
    WrapTypeable (proxy :: IntProxy n) <- forAll genTF
    shouldInsert <- forAll Gen.bool

    if shouldInsert then
        member @n (delete @n $ insert proxy m) === False
    else
        member @n (delete @n m) === False

insertInvariantSpec :: Property
insertInvariantSpec = it "invariantCheck (insert k b) == True" $ hedgehog $ do
    m <- forAll genMap
    WrapTypeable a <- forAll genTF
    assert $ invariantCheck (insert a m)

deleteInvariantSpec :: Property
deleteInvariantSpec = it "invariantCheck (delete k b) == True" $ hedgehog $ do
    m <- forAll genMap
    WrapTypeable (_ :: IntProxy n) <- forAll genTF
    assert $ invariantCheck (delete @n m)

alterInsertSpec :: Property
alterInsertSpec = it "insert proxy m === alter (const (Just proxy)) m" $ hedgehog $ do
    m <- forAll genMap
    WrapTypeable (proxy :: IntProxy n) <- forAll genTF
    insert proxy m === alter (const (Just proxy)) m

alterDeleteSpec :: Property
alterDeleteSpec = it "delete proxy m === alter (const Nothing) m" $ hedgehog $ do
    WrapTypeable (proxy :: IntProxy n) <- forAll genTF
    m <- insert proxy <$> forAll genMap
    delete @n @IntProxy m === alter @n @IntProxy (const Nothing) m

alterAdjustSpec :: Property
alterAdjustSpec = it "adjust f m == alter (fmap f) m" $ hedgehog $ do
    m <- forAll genMap
    WrapTypeable (_ :: IntProxy n) <- forAll genTF
    let f (IntProxy p n) = IntProxy p (n * 10)
    adjust @n @IntProxy f m === alter @n @IntProxy (fmap f) m

alterModifySpec :: Property
alterModifySpec = it "lookup k (alter f) == f (lookup k m)" $ hedgehog $ do
    m <- forAll genMap
    WrapTypeable (_ :: IntProxy n) <- forAll genTF
    randInt <- forAll (Gen.int Range.constantBounded)
    -- Function with some interesting behaviour, which inserts, seletes and modifies
    let f Nothing = Just (IntProxy Proxy randInt)
        f (Just (IntProxy p n))
          | even n = Nothing
          | otherwise = Just $ IntProxy p (n * 10)
    lookup @n @IntProxy (alter @n f m) === f (lookup @n @IntProxy m)

intersectionSpec :: Property
intersectionSpec = it "m `intersection` (m `union` n) == m" $ hedgehog $ do
    m <- forAll genMap
    n <- forAll genMap
    m `intersection` (m `union` n) === m

----------------------------------------------------------------------------
-- Internal helpers
----------------------------------------------------------------------------
generateOrderMappingInvariantSpec :: Property
generateOrderMappingInvariantSpec =
    it "fmap (fromSortedList [1 .. n] !!) (generateOrderMapping n) == [1 .. n]" $ hedgehog $ do
        n <- forAll $ Gen.int (Range.linear 0 100)
        fmap (fromSortedList [1 .. n] !!) (generateOrderMapping n) === [1 .. n]

----------------------------------------------------------------------------
-- Semigroup and Monoid laws
----------------------------------------------------------------------------

semigroupAssocSpec :: Property
semigroupAssocSpec = it "x <> (y <> z) == (x <> y) <> z" $ hedgehog $ do
    x <- forAll genMap
    y <- forAll genMap
    z <- forAll genMap
    (x <> (y <> z)) === ((x <> y) <> z)

monoidIdentitySpec :: Property
monoidIdentitySpec = it "x <> mempty == mempty <> x == x" $ hedgehog $ do
    x <- forAll genMap
    x <> mempty === x
    mempty <> x === x

----------------------------------------------------------------------------
-- Generators
----------------------------------------------------------------------------

data IntProxy (n :: Nat) = IntProxy (Proxy n) Int
    deriving stock (Show, Eq)

genMap :: MonadGen m => m (TypeRepMap IntProxy)
genMap = fromList <$> Gen.list (Range.linear 0 1000) genTF

genTF :: MonadGen m => m (WrapTypeable IntProxy)
genTF = do
    randNat :: Integer <- Gen.integral (Range.linear 0 10000)
    randInt <- Gen.int Range.constantBounded
    case someNatVal randNat of
        Just (SomeNat proxyNat) -> pure $ WrapTypeable $ IntProxy proxyNat randInt
        Nothing                 -> error "Invalid test generator"