module Data.Predicate where
import Control.Applicative hiding (Const)
import Control.Monad
data Boolean f t =
F (Maybe f)
| T t
deriving (Eq, Show)
class Predicate p a where
type FVal p
type TVal p
apply :: p -> a -> Boolean (FVal p) (TVal p)
instance Monad (Boolean f) where
return = T
(T x) >>= g = g x
(F x) >>= _ = F x
instance MonadPlus (Boolean f) where
mzero = F Nothing
(F _) `mplus` b = b
b `mplus` _ = b
instance Functor (Boolean f) where
fmap = liftM
instance Applicative (Boolean f) where
pure = return
(<*>) = ap
instance Alternative (Boolean f) where
empty = mzero
(<|>) = mplus
data Const f t where
Const :: t -> Const f t
instance Predicate (Const f t) a where
type FVal (Const f t) = f
type TVal (Const f t) = t
apply (Const a) _ = T a
instance Show t => Show (Const f t) where
show (Const a) = "Const " ++ show a
data Fail f t where
Fail :: f -> Fail f t
instance Predicate (Fail f t) a where
type FVal (Fail f t) = f
type TVal (Fail f t) = t
apply (Fail a) _ = F $ Just a
instance Show f => Show (Fail f t) where
show (Fail a) = "Fail " ++ show a
data a :|: b = a :|: b
instance (Predicate a c, Predicate b c, TVal a ~ TVal b, FVal a ~ FVal b) => Predicate (a :|: b) c
where
type FVal (a :|: b) = FVal a
type TVal (a :|: b) = TVal a
apply (a :|: b) r = apply a r <|> apply b r
instance (Show a, Show b) => Show (a :|: b) where
show (a :|: b) = "(" ++ show a ++ " | " ++ show b ++ ")"
type a :+: b = Either a b
data a :||: b = a :||: b
instance (Predicate a c, Predicate b c, FVal a ~ FVal b) => Predicate (a :||: b) c
where
type FVal (a :||: b) = FVal a
type TVal (a :||: b) = TVal a :+: TVal b
apply (a :||: b) r = (Left <$> apply a r) <|> (Right <$> apply b r)
instance (Show a, Show b) => Show (a :||: b) where
show (a :||: b) = "(" ++ show a ++ " || " ++ show b ++ ")"
data a :*: b = a :*: b deriving (Eq, Show)
data a :&: b = a :&: b
instance (Predicate a c, Predicate b c, FVal a ~ FVal b) => Predicate (a :&: b) c
where
type FVal (a :&: b) = FVal a
type TVal (a :&: b) = TVal a :*: TVal b
apply (a :&: b) r = (:*:) <$> apply a r <*> apply b r
instance (Show a, Show b) => Show (a :&: b) where
show (a :&: b) = "(" ++ show a ++ " & " ++ show b ++ ")"