{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies,
UndecidableInstances, ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies, FlexibleContexts, CPP #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
module Data.Boolean
( Boolean(..), BooleanOf, IfB(..)
, boolean, cond, crop
, EqB(..), OrdB(..)
, minB, maxB, sort2B
, guardedB, caseB
) where
#if MIN_VERSION_base(4,8,0)
import Prelude hiding ((<*))
#endif
import Data.Monoid (Monoid,mempty)
import Control.Applicative (Applicative(pure),liftA2,liftA3)
infixr 3 &&*
infixr 2 ||*
class Boolean b where
true, false :: b
notB :: b -> b
(&&*), (||*) :: b -> b -> b
instance Boolean Bool where
true = True
false = False
notB = not
(&&*) = (&&)
(||*) = (||)
type family BooleanOf a
class Boolean (BooleanOf a) => IfB a where
ifB :: (bool ~ BooleanOf a) => bool -> a -> a -> a
boolean :: (IfB a, bool ~ BooleanOf a) => a -> a -> bool -> a
boolean t e bool = ifB bool t e
cond :: (Applicative f, IfB a, bool ~ BooleanOf a) => f bool -> f a -> f a -> f a
cond = liftA3 ifB
crop :: (Applicative f, Monoid (f a), IfB a, bool ~ BooleanOf a) => f bool -> f a -> f a
crop r f = cond r f mempty
guardedB :: (IfB b, bool ~ BooleanOf b) => bool -> [(bool,b)] -> b -> b
guardedB _ [] e = e
guardedB a ((c,b):l) e = ifB c b (guardedB a l e)
caseB :: (IfB b, bool ~ BooleanOf b) => a -> [(a -> bool, b)] -> b -> b
caseB _ [] e = e
caseB x ((p,b):l) e = ifB (p x) b (caseB x l e)
infix 4 ==*, /=*
class Boolean (BooleanOf a) => EqB a where
(==*), (/=*) :: (bool ~ BooleanOf a) => a -> a -> bool
u /=* v = notB (u ==* v)
infix 4 <*, <=*, >=*, >*
class Boolean (BooleanOf a) => OrdB a where
(<*), (<=*), (>*), (>=*) :: (bool ~ BooleanOf a) => a -> a -> bool
u >* v = v <* u
u >=* v = notB (u <* v)
u <=* v = v >=* u
minB :: (IfB a, OrdB a) => a -> a -> a
u `minB` v = ifB (u <=* v) u v
maxB :: (IfB a, OrdB a) => a -> a -> a
u `maxB` v = ifB (u >=* v) u v
sort2B :: (IfB a, OrdB a) => (a,a) -> (a,a)
sort2B (u,v) = ifB (u <=* v) (u,v) (v,u)
ife :: Bool -> a -> a -> a
ife c t e = if c then t else e
#define SimpleInstances(Ty) \
instance IfB (Ty) where { ifB = ife } ;\
instance EqB (Ty) where { (==*) = (==) ; (/=*) = (/=) } ;\
instance OrdB (Ty) where { (<*) = (<) ; (<=*) = (<=) }
#define SimpleTy(Ty) \
type instance BooleanOf (Ty) = Bool ;\
SimpleInstances(Ty)
SimpleTy(Int)
SimpleTy(Integer)
SimpleTy(Float)
SimpleTy(Double)
SimpleTy(Bool)
SimpleTy(Char)
type instance BooleanOf [a] = BooleanOf a
type instance BooleanOf (a,b) = BooleanOf a
type instance BooleanOf (a,b,c) = BooleanOf a
type instance BooleanOf (a,b,c,d) = BooleanOf a
type instance BooleanOf (z -> a) = z -> BooleanOf a
instance (Boolean (BooleanOf a),BooleanOf a ~ Bool) => IfB [a] where { ifB = ife }
instance (bool ~ BooleanOf p, bool ~ BooleanOf q
,IfB p, IfB q) => IfB (p,q) where
ifB w (p,q) (p',q') = (ifB w p p', ifB w q q')
instance (bool ~ BooleanOf p, bool ~ BooleanOf q, bool ~ BooleanOf r
,IfB p, IfB q, IfB r)
=> IfB (p,q,r) where
ifB w (p,q,r) (p',q',r') = (ifB w p p', ifB w q q', ifB w r r')
instance (bool ~ BooleanOf p, bool ~ BooleanOf q, bool ~ BooleanOf r, bool ~ BooleanOf s
,IfB p, IfB q, IfB r, IfB s) => IfB (p,q,r,s) where
ifB w (p,q,r,s) (p',q',r',s') =
(ifB w p p', ifB w q q', ifB w r r', ifB w s s')
instance Boolean bool => Boolean (z -> bool) where
true = pure true
false = pure false
notB = fmap notB
(&&*) = liftA2 (&&*)
(||*) = liftA2 (||*)
instance IfB a => IfB (z -> a) where
ifB = cond
instance EqB a => EqB (z -> a) where
{ (==*) = liftA2 (==*) ; (/=*) = liftA2 (/=*) }
instance OrdB a => OrdB (z -> a) where
{ (<*) = liftA2 (<*) ; (<=*) = liftA2 (<=*) }