{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.JoinSemilattice.Class.Ord where
import Control.Applicative (liftA2)
import Data.JoinSemilattice.Defined (Defined (..))
import Data.JoinSemilattice.Intersect (Intersect (..), Intersectable)
import qualified Data.JoinSemilattice.Intersect as Intersect
import Data.JoinSemilattice.Class.Boolean (BooleanR (..))
import Data.JoinSemilattice.Class.Eq (EqR (..), EqC')
import Data.Kind (Constraint, Type)
class (EqR f, forall x. OrdC f x => EqC' f x) => OrdR (f :: Type -> Type) where
type OrdC f :: Type -> Constraint
type OrdC f = EqC f
lteR :: OrdC f x => ( f x, f x, f Bool ) -> ( f x, f x, f Bool )
gtR :: (OrdR f, OrdC f x) => ( f x, f x, f Bool ) -> ( f x, f x, f Bool )
gtR ( x, y, z ) = let ( y', x', z' ) = ltR ( y, x, z ) in ( x', y', z' )
gteR :: (OrdR f, OrdC f x) => ( f x, f x, f Bool ) -> ( f x, f x, f Bool )
gteR ( x, y, z ) = let ( y', x', z' ) = lteR ( y, x, z ) in ( x', y', z' )
ltR :: (OrdR f, OrdC f x) => ( f x, f x, f Bool ) -> ( f x, f x, f Bool )
ltR ( x, y, z )
= let ( notZ', _ ) = notR ( mempty, z )
( x', y', notZR ) = gteR ( x, y, notZ' )
( _, z' ) = notR ( notZR, mempty )
in ( x', y', z' )
instance OrdR Defined where
type OrdC Defined = Ord
lteR ( x, y, _ ) = ( mempty, mempty, liftA2 (<=) x y )
class (Ord x, Intersectable x) => OrdIntersectable (x :: Type)
instance (Ord x, Intersectable x) => OrdIntersectable x
instance OrdR Intersect where
type OrdC Intersect = OrdIntersectable
lteR ( x, y, z )
= ( if | z == trueR -> Intersect.filter (<= maximum y) x
| z == falseR -> Intersect.filter ( > minimum y) x
| otherwise -> mempty
, if | z == trueR -> Intersect.filter (>= minimum x) y
| z == falseR -> Intersect.filter ( < maximum x) y
| otherwise -> mempty
, Intersect.lift2 (<=) x y
)