module Network.Wai.Routing.Predicate.Predicate
( Delta
, Boolean (..)
, Predicate (..)
, (:|:) (..)
, (:&:) (..)
, (:||:) (..)
, (:::) (..)
, (:+:)
, Const
, Fail
, Opt
, Def
, PMap
, PMapT
, PMapF
, constant
, failure
, true
, opt
, def
, pmap
, pmapT
, pmapF
, with
) where
import Prelude hiding (and, or)
type Delta = Double
data Boolean f t
= F f
| T Delta t
deriving (Eq, Show)
class Predicate p a where
type FVal p
type TVal p
apply :: p -> a -> Boolean (FVal p) (TVal p)
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 0 a
constant :: t -> Const f t
constant = Const
true :: Const a ()
true = Const ()
data Fail f t where
Fail :: f -> Fail f t
failure :: f -> Fail f t
failure = Fail
instance Predicate (Fail f t) a where
type FVal (Fail f t) = f
type TVal (Fail f t) = t
apply (Fail a) _ = F 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 `or` apply b r
where
or x@(T d0 _) y@(T d1 _) = if d1 < d0 then y else x
or x@(T _ _) (F _) = x
or (F _) x@(T _ _) = x
or (F _) x@(F _) = x
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 = apply a r `or` apply b r
where
or (T d0 t0) (T d1 t1) = if d1 < d0 then T d1 (Right t1) else T d0 (Left t0)
or (T d t) (F _) = T d (Left t)
or (F _) (T d t) = T d (Right t)
or (F _) (F f) = F f
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 `and` apply b r
where
and (T d x) (T w y) = T (d + w) (x ::: y)
and (T _ _) (F f) = F f
and (F f) _ = F f
newtype Opt a = Opt a
opt :: a -> Opt a
opt = Opt
instance (Predicate a b) => Predicate (Opt a) b where
type FVal (Opt a) = FVal a
type TVal (Opt a) = Maybe (TVal a)
apply (Opt a) r = case apply a r of
T d x -> T d (Just x)
F _ -> T 0 Nothing
data Def d a = Def d a
def :: d -> a -> Def d a
def = Def
instance (Predicate a b, d ~ TVal a) => Predicate (Def d a) b where
type FVal (Def d a) = FVal a
type TVal (Def d a) = TVal a
apply (Def d a) r = case apply a r of
T n x -> T n x
F _ -> T 0 d
data PMap a f t = PMap (Boolean (FVal a) (TVal a) -> Boolean f t) a
pmap :: (Boolean (FVal a) (TVal a) -> Boolean f t) -> a -> PMap a f t
pmap = PMap
instance (Predicate a b) => Predicate (PMap a f t) b where
type FVal (PMap a f t) = f
type TVal (PMap a f t) = t
apply (PMap f a) r = f $ apply a r
data PMapT a t = PMapT (TVal a -> Boolean (FVal a) t) a
pmapT :: (TVal a -> Boolean (FVal a) t) -> a -> PMapT a t
pmapT = PMapT
instance (Predicate a b) => Predicate (PMapT a t) b where
type FVal (PMapT a t) = FVal a
type TVal (PMapT a t) = t
apply (PMapT f a) r = case apply a r of
(T _ x) -> f x
(F x) -> F x
data PMapF a f = PMapF (FVal a -> Boolean f (TVal a)) a
pmapF :: (FVal a -> Boolean f (TVal a)) -> a -> PMapF a f
pmapF = PMapF
instance (Predicate a b) => Predicate (PMapF a f) b where
type FVal (PMapF a f) = f
type TVal (PMapF a f) = TVal a
apply (PMapF f a) r = case apply a r of
(F x) -> f x
(T d x) -> T d x
with :: (Monad m, Predicate p a) => p -> a -> (TVal p -> m ()) -> m ()
with p a f = case apply p a of
T _ x -> f x
_ -> return ()