{-# LANGUAGE OverloadedStrings #-}

module Hedgehog.Laws.Ord where

import Hedgehog qualified
import Hedgehog.Laws.Common
import Prelude
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.Hedgehog (testProperty)

-- There is no typeclass for this, sadly
partialOrderLaws :: (Show a, Eq a) => Hedgehog.Gen a -> (a -> a -> Bool) -> TestTree
partialOrderLaws :: forall a. (Show a, Eq a) => Gen a -> (a -> a -> Bool) -> TestTree
partialOrderLaws Gen a
g a -> a -> Bool
op =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"partial ordering laws"
    [ TestName -> Property -> TestTree
testProperty TestName
"reflexive" (Gen a -> (a -> a -> Bool) -> Property
forall a. Show a => Gen a -> (a -> a -> Bool) -> Property
prop_reflexive Gen a
g a -> a -> Bool
op)
    , TestName -> Property -> TestTree
testProperty TestName
"transitive" (Gen a -> (a -> a -> Bool) -> Property
forall a. (Show a, Eq a) => Gen a -> (a -> a -> Bool) -> Property
prop_transitive Gen a
g a -> a -> Bool
op)
    , TestName -> Property -> TestTree
testProperty TestName
"antisymmetric" (Gen a -> (a -> a -> Bool) -> Property
forall a. (Show a, Eq a) => Gen a -> (a -> a -> Bool) -> Property
prop_antisymmetric Gen a
g a -> a -> Bool
op)
    ]

ordLaws :: (Show a, Ord a) => Hedgehog.Gen a -> TestTree
ordLaws :: forall a. (Show a, Ord a) => Gen a -> TestTree
ordLaws Gen a
g =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"total ordering laws"
    [ Gen a -> (a -> a -> Bool) -> TestTree
forall a. (Show a, Eq a) => Gen a -> (a -> a -> Bool) -> TestTree
partialOrderLaws Gen a
g a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<=)
    , TestName -> Property -> TestTree
testProperty TestName
"total" (Gen a -> (a -> a -> Bool) -> Property
forall a. (Show a, Eq a) => Gen a -> (a -> a -> Bool) -> Property
prop_total Gen a
g a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<=))
    ]