prop-unit-0.2.0: test/Main.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE UndecidableInstances #-}

module Main (main) where

import Control.Monad (replicateM)
import Data.Proxy (Proxy (..))
import qualified Data.Set as Set
import GHC.Exts (IsList, IsString)
import GHC.Generics (Generic)
import Hedgehog (Gen)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import PropUnit
  ( GenDefault (..)
  , Std
  , TestLimit
  , TestTree
  , assert
  , forAll
  , genDefaultEnum
  , genDefaultGeneric
  , genDefaultList
  , genDefaultString
  , genDefaultTag
  , testGroup
  , testMain
  , testProp
  , testUnit
  , (===)
  )

testAsUnit :: TestTree
testAsUnit = testUnit "as unit" $ do
  let actual = (1 + 1) :: Int
      expected = 2 :: Int
  actual === expected

testAsProp :: TestLimit -> TestTree
testAsProp lim = testProp "as gen" lim $ do
  x <- forAll (Gen.int (Range.constant 1 10))
  abs x * abs x === x * x

testBasic :: TestLimit -> TestTree
testBasic lim =
  testGroup
    "basic"
    [ testAsUnit
    , testAsProp lim
    ]

data Tag

instance GenDefault Tag Int where genDefault = genDefaultTag (Proxy @Std)

instance GenDefault Tag Char where genDefault = genDefaultTag (Proxy @Std)

newtype AList a = AList [a]
  deriving newtype (Eq, Ord, Show, IsList)

instance (GenDefault Tag a) => GenDefault Tag (AList a) where genDefault = genDefaultList (Proxy @0) (Proxy @2)

newtype AString = AString String
  deriving newtype (Eq, Ord, Show, IsString)

instance GenDefault Tag AString where genDefault = genDefaultString (Proxy @0) (Proxy @2)

data Choice = ChoiceA | ChoiceB
  deriving stock (Eq, Ord, Show, Enum, Bounded)

instance GenDefault Tag Choice where genDefault = genDefaultEnum

instance (GenDefault Tag a) => GenDefault Tag (Maybe a) where genDefault = genDefaultGeneric

data Record = Record !Int !(Maybe Record)
  deriving stock (Eq, Ord, Show, Generic)

instance GenDefault Tag Record where genDefault = genDefaultGeneric

data GenCase where
  GenCase :: (Ord a) => String -> Gen a -> GenCase

genDefaultByProxy :: (GenDefault Tag a) => Proxy a -> Gen a
genDefaultByProxy _ = genDefault (Proxy @Tag)

mkGenCase :: (Ord a, GenDefault Tag a) => String -> Proxy a -> GenCase
mkGenCase name = GenCase name . genDefaultByProxy

genCases :: [GenCase]
genCases =
  [ mkGenCase "Int" (Proxy @Int)
  , mkGenCase "Char" (Proxy @Char)
  , mkGenCase "Choice" (Proxy @Choice)
  , mkGenCase "AList" (Proxy @(AList Char))
  , mkGenCase "AString" (Proxy @AString)
  , mkGenCase "Record" (Proxy @Record)
  ]

testGenCase :: GenCase -> TestTree
testGenCase (GenCase name gen) = testUnit name $ do
  xs <- fmap Set.fromList (replicateM 10 (Gen.sample gen))
  assert (Set.size xs > 1)

testDerive :: TestTree
testDerive = testGroup "derive" (fmap testGenCase genCases)

main :: IO ()
main = testMain $ \lim ->
  testGroup
    "PropUnit"
    [ testBasic lim
    , testDerive
    ]