{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiWayIf #-}
module Data.JoinSemilattice.Class.Boolean where
import Control.Applicative (liftA2)
import Data.JoinSemilattice.Class.Merge (Merge)
import Data.JoinSemilattice.Defined (Defined (..))
import Data.JoinSemilattice.Intersect (Intersect (..))
import qualified Data.JoinSemilattice.Intersect as Intersect
import Data.Kind (Type)
class Merge (f Bool) => BooleanR (f :: Type -> Type) where
falseR :: f Bool
trueR :: f Bool
notR :: ( f Bool, f Bool ) -> ( f Bool, f Bool )
andR :: ( f Bool, f Bool, f Bool ) -> ( f Bool, f Bool, f Bool )
orR :: ( f Bool, f Bool, f Bool ) -> ( f Bool, f Bool, f Bool )
instance BooleanR Defined where
falseR = Exactly False
trueR = Exactly True
notR (x, y) = ( fmap not y, fmap not x )
andR (x, y, z)
= ( if | z == trueR -> trueR
| z == falseR && y == trueR -> falseR
| otherwise -> mempty
, if | z == trueR -> trueR
| z == falseR && x == trueR -> falseR
| otherwise -> mempty
, liftA2 (&&) x y
)
orR (x, y, z)
= ( if | z == falseR -> falseR
| z == trueR && y == falseR -> trueR
| otherwise -> mempty
, if | z == falseR -> falseR
| z == trueR && x == falseR -> trueR
| otherwise -> mempty
, liftA2 (||) x y
)
instance BooleanR Intersect where
falseR = Intersect.singleton False
trueR = Intersect.singleton True
notR (x, y) = ( Intersect.map not y, Intersect.map not x )
andR (x, y, z)
= ( if | z == trueR -> trueR
| z == falseR && y == trueR -> falseR
| otherwise -> mempty
, if | z == trueR -> trueR
| z == falseR && x == trueR -> falseR
| otherwise -> mempty
, Intersect.lift2 (&&) x y
)
orR (x, y, z)
= ( if | z == falseR -> falseR
| z == trueR && y == falseR -> trueR
| otherwise -> mempty
, if | z == falseR -> falseR
| z == trueR && x == falseR -> trueR
| otherwise -> mempty
, Intersect.lift2 (||) x y
)