Ord.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

{-|
Module      : Data.JoinSemilattice.Class.Ord
Description : Relationships between values and their comparison results.
Copyright   : (c) Tom Harding, 2020
License     : MIT
-}
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)

-- | Comparison relationships between two values and their comparison result.
-- See 'Data.JoinSemilattice.Class.Eq.EqR' for more information on the design
-- of this class, and a full apology for the constraints involved.
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

  -- | A relationship between two values and whether the left is less than or
  -- equal to the right.
  lteR :: OrdC f x => ( f x, f x, f Bool ) -> ( f x, f x, f Bool )

-- | Comparison between two values and their '(>)' result.
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' )

-- | Comparison between two values and their '(>=)' result.
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' )

-- | Comparison between two values and their '(<)' result.
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
      )