{-# 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
(<=))
  ]