Marking.hs

module TestSuite.Prop.Generator.Marking (tests) where

import Control.Monad
import Data.Map (Map)
import Data.Maybe (catMaybes)
import Data.Word
import Test.Tasty
import Test.Tasty.Falsify

import qualified Data.Map as Map
import qualified Data.Set as Set

import Test.Falsify.Generator (Marked(..), Mark(..))

import qualified Test.Falsify.Generator as Gen hiding (mark)
import qualified Test.Falsify.Predicate as P

import TestSuite.Util.List

tests :: TestTree
tests = testGroup "TestSuite.Prop.Generator.Marking" [
      testGroup "list" [
          testProperty "shrinking" prop_list_shrinking
        , testProperty "minimum"   prop_list_minimum
        ]
    ]

{-------------------------------------------------------------------------------
  Marking
-------------------------------------------------------------------------------}

-- | Mark an element
--
-- Marks as 'Drop' with 50% probability.
--
-- We avoid using 'Gen.mark' here, which depends on @shrinkTo@. This version
-- uses only 'Gen.prim'; the difference in behaviour is that this version of
-- @mark@ can produce elements that are marked as drop from the get-go.
mark :: Gen a -> Gen (Marked Gen a)
mark x = flip Marked x <$> (aux <$> Gen.prim)
  where
    aux :: Word64 -> Mark
    aux n = if n >= maxBound `div` 2 then Keep else Drop

{-------------------------------------------------------------------------------
  List
-------------------------------------------------------------------------------}

genMarkedList :: Gen [(Word, Word64)]
genMarkedList = do
    xs <- forM [0 .. 9] (\i -> mark ((i, ) <$> Gen.prim))
    catMaybes <$> Gen.selectAllKept xs

prop_list_shrinking :: Property ()
prop_list_shrinking =
    testShrinkingOfGen
      (        mconcat [
                          P.flip (P.relatedBy ("isSubsetOf", Set.isSubsetOf))
                   `P.on` P.fn ("keysSet", Map.keysSet)
                 , P.relatedBy ("shrunkCod", shrunkCod)
                 ]
        `P.on` P.transparent Map.fromList
      )
      genMarkedList
  where
    shrunkCod :: Map Word Word64 -> Map Word Word64 -> Bool
    shrunkCod orig shrunk = and [
          -- The 'shrunkDom' check justifies the use of @(!)@ here
          orig Map.! k >= v
        | (k, v) <- Map.toList shrunk
        ]

prop_list_minimum :: Property ()
prop_list_minimum =
    testMinimum (P.satisfies ("expected", expected)) $ do
      xs <- gen $ genMarkedList
      case xs of
        (0, _):_   -> discard
        _otherwise -> return ()
      unless (pairwiseAll (==) $ map snd xs) $ testFailed xs
  where
    expected :: [(Word, Word64)] -> Bool
    expected [(i, 0), (j, 1)] | i < j = True
    expected _otherwise               = False