{-# LANGUAGE FlexibleInstances #-}
module Control.Conditional
(
ToBool(..)
, if', (??), bool
, ifM, (<||>), (<&&>), notM, xorM
, cond, condDefault, condPlus, condM, condPlusM, otherwiseM
, (?.)
, (?<>)
, select, selectM
, (?)
, (|>), (<|)
, (|>>), (<<|)
, (⊳), (⊲)
, guard, guardM, when, whenM, unless, unlessM,
) where
import Data.Algebra.Boolean
import Control.Monad hiding (guard, when, unless)
import Control.Category
import Data.Monoid
import Data.Maybe
import Prelude hiding ((.), id, (&&), (||), not)
infixr 0 <|, |>, ⊳, ⊲, ?, <<|, |>>
infixr 1 ??
infixr 2 <||>
infixr 3 <&&>
infixr 7 ?<>
infixr 9 ?.
class ToBool bool where
toBool :: bool -> Bool
instance ToBool Bool where toBool :: Bool -> Bool
toBool = Bool -> Bool
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
instance ToBool Any where toBool :: Any -> Bool
toBool = Any -> Bool
getAny
instance ToBool All where toBool :: All -> Bool
toBool = All -> Bool
getAll
instance ToBool (Dual Bool) where toBool :: Dual Bool -> Bool
toBool = Dual Bool -> Bool
forall a. Dual a -> a
getDual
if' :: ToBool bool => bool -> a -> a -> a
if' :: bool -> a -> a -> a
if' p :: bool
p t :: a
t f :: a
f = if bool -> Bool
forall bool. ToBool bool => bool -> Bool
toBool bool
p then a
t else a
f
{-# INLINE if' #-}
(??) :: ToBool bool => a -> a -> bool -> a
?? :: a -> a -> bool -> a
(??) t :: a
t f :: a
f p :: bool
p = bool -> a -> a -> a
forall bool a. ToBool bool => bool -> a -> a -> a
if' bool
p a
t a
f
{-# INLINE (??) #-}
bool :: (ToBool bool) => a -> a -> bool -> a
bool :: a -> a -> bool -> a
bool f :: a
f t :: a
t p :: bool
p = bool -> a -> a -> a
forall bool a. ToBool bool => bool -> a -> a -> a
if' bool
p a
t a
f
{-# INLINE bool #-}
cond :: ToBool bool => [(bool, a)] -> a
cond :: [(bool, a)] -> a
cond [] = [Char] -> a
forall a. HasCallStack => [Char] -> a
error "cond: no matching conditions"
cond ((p :: bool
p,v :: a
v):ls :: [(bool, a)]
ls) = bool -> a -> a -> a
forall bool a. ToBool bool => bool -> a -> a -> a
if' bool
p a
v ([(bool, a)] -> a
forall bool a. ToBool bool => [(bool, a)] -> a
cond [(bool, a)]
ls)
condDefault :: ToBool bool => a -> [(bool, a)] -> a
condDefault :: a -> [(bool, a)] -> a
condDefault = ((Maybe a -> a) -> ([(bool, a)] -> Maybe a) -> [(bool, a)] -> a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [(bool, a)] -> Maybe a
forall bool (m :: * -> *) a.
(ToBool bool, MonadPlus m) =>
[(bool, a)] -> m a
condPlus) ((Maybe a -> a) -> [(bool, a)] -> a)
-> (a -> Maybe a -> a) -> a -> [(bool, a)] -> a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Maybe a -> a
forall a. a -> Maybe a -> a
(<|)
{-# INLINE condDefault #-}
condPlus :: (ToBool bool, MonadPlus m) => [(bool, a)] -> m a
condPlus :: [(bool, a)] -> m a
condPlus [] = m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
condPlus ((p :: bool
p,v :: a
v):ls :: [(bool, a)]
ls) = bool -> m a -> m a -> m a
forall bool a. ToBool bool => bool -> a -> a -> a
if' bool
p (a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v) ([(bool, a)] -> m a
forall bool (m :: * -> *) a.
(ToBool bool, MonadPlus m) =>
[(bool, a)] -> m a
condPlus [(bool, a)]
ls)
(?.) :: (ToBool bool, Category cat) => bool -> cat a a -> cat a a
p :: bool
p ?. :: bool -> cat a a -> cat a a
?. c :: cat a a
c = bool -> cat a a -> cat a a -> cat a a
forall bool a. ToBool bool => bool -> a -> a -> a
if' bool
p cat a a
c cat a a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
{-# INLINE (?.) #-}
select :: ToBool bool => (a -> bool) -> (a -> b) -> (a -> b) -> (a -> b)
select :: (a -> bool) -> (a -> b) -> (a -> b) -> a -> b
select p :: a -> bool
p t :: a -> b
t f :: a -> b
f x :: a
x = bool -> b -> b -> b
forall bool a. ToBool bool => bool -> a -> a -> a
if' (a -> bool
p a
x) (a -> b
t a
x) (a -> b
f a
x)
{-# INLINE select #-}
ifM :: (ToBool bool, Monad m) => m bool -> m a -> m a -> m a
ifM :: m bool -> m a -> m a -> m a
ifM p :: m bool
p t :: m a
t f :: m a
f = m bool
p m bool -> (bool -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m a -> m a -> bool -> m a
forall bool a. ToBool bool => a -> a -> bool -> a
bool m a
f m a
t
{-# INLINE ifM #-}
(<||>) :: (ToBool bool, Boolean bool, Monad m) => m bool -> m bool -> m bool
<||> :: m bool -> m bool -> m bool
(<||>) t :: m bool
t f :: m bool
f = m bool -> m bool -> m bool -> m bool
forall bool (m :: * -> *) a.
(ToBool bool, Monad m) =>
m bool -> m a -> m a -> m a
ifM m bool
t (bool -> m bool
forall (m :: * -> *) a. Monad m => a -> m a
return bool
forall b. Boolean b => b
true) m bool
f
{-# INLINE (<||>) #-}
(<&&>) :: (ToBool bool, Boolean bool, Monad m) => m bool -> m bool -> m bool
<&&> :: m bool -> m bool -> m bool
(<&&>) t :: m bool
t f :: m bool
f = m bool -> m bool -> m bool -> m bool
forall bool (m :: * -> *) a.
(ToBool bool, Monad m) =>
m bool -> m a -> m a -> m a
ifM m bool
t m bool
f (bool -> m bool
forall (m :: * -> *) a. Monad m => a -> m a
return bool
forall b. Boolean b => b
false)
{-# INLINE (<&&>) #-}
notM :: (Boolean bool, Monad m) => m bool -> m bool
notM :: m bool -> m bool
notM = (bool -> bool) -> m bool -> m bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM bool -> bool
forall b. Boolean b => b -> b
not
{-# INLINE notM #-}
xorM :: (Boolean bool, Monad m) => m bool -> m bool -> m bool
xorM :: m bool -> m bool -> m bool
xorM = (bool -> bool -> bool) -> m bool -> m bool -> m bool
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 bool -> bool -> bool
forall b. Boolean b => b -> b -> b
xor
condM :: (ToBool bool, Monad m) => [(m bool, m a)] -> m a
condM :: [(m bool, m a)] -> m a
condM [] = [Char] -> m a
forall a. HasCallStack => [Char] -> a
error "condM: no matching conditions"
condM ((p :: m bool
p, v :: m a
v):ls :: [(m bool, m a)]
ls) = m bool -> m a -> m a -> m a
forall bool (m :: * -> *) a.
(ToBool bool, Monad m) =>
m bool -> m a -> m a -> m a
ifM m bool
p m a
v ([(m bool, m a)] -> m a
forall bool (m :: * -> *) a.
(ToBool bool, Monad m) =>
[(m bool, m a)] -> m a
condM [(m bool, m a)]
ls)
condPlusM :: (ToBool bool, MonadPlus m) => [(m bool, m a)] -> m a
condPlusM :: [(m bool, m a)] -> m a
condPlusM [] = m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
condPlusM ((p :: m bool
p, v :: m a
v):ls :: [(m bool, m a)]
ls) = m bool -> m a -> m a -> m a
forall bool (m :: * -> *) a.
(ToBool bool, Monad m) =>
m bool -> m a -> m a -> m a
ifM m bool
p m a
v ([(m bool, m a)] -> m a
forall bool (m :: * -> *) a.
(ToBool bool, MonadPlus m) =>
[(m bool, m a)] -> m a
condPlusM [(m bool, m a)]
ls)
otherwiseM :: (Boolean bool, Monad m) => m bool
otherwiseM :: m bool
otherwiseM = bool -> m bool
forall (m :: * -> *) a. Monad m => a -> m a
return bool
forall b. Boolean b => b
true
guard :: (ToBool bool, MonadPlus m) => bool -> m ()
guard :: bool -> m ()
guard p :: bool
p = bool -> m () -> m () -> m ()
forall bool a. ToBool bool => bool -> a -> a -> a
if' bool
p (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) m ()
forall (m :: * -> *) a. MonadPlus m => m a
mzero
{-# INLINE guard #-}
when :: (ToBool bool, Monad m) => bool -> m () -> m ()
when :: bool -> m () -> m ()
when p :: bool
p m :: m ()
m = bool -> m () -> m () -> m ()
forall bool a. ToBool bool => bool -> a -> a -> a
if' bool
p m ()
m (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
{-# INLINE when #-}
unless :: (Boolean bool, ToBool bool, Monad m) => bool -> m() -> m()
unless :: bool -> m () -> m ()
unless p :: bool
p m :: m ()
m = bool -> m () -> m () -> m ()
forall bool a. ToBool bool => bool -> a -> a -> a
if' (bool -> bool
forall b. Boolean b => b -> b
not bool
p) m ()
m (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
{-# INLINE unless #-}
whenM :: (ToBool bool, Monad m) => m bool -> m () -> m ()
whenM :: m bool -> m () -> m ()
whenM p :: m bool
p m :: m ()
m = m bool -> m () -> m () -> m ()
forall bool (m :: * -> *) a.
(ToBool bool, Monad m) =>
m bool -> m a -> m a -> m a
ifM m bool
p m ()
m (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
{-# INLINE whenM #-}
unlessM :: (ToBool bool, Boolean bool, Monad m) => m bool -> m () -> m ()
unlessM :: m bool -> m () -> m ()
unlessM p :: m bool
p m :: m ()
m = m bool -> m () -> m () -> m ()
forall bool (m :: * -> *) a.
(ToBool bool, Monad m) =>
m bool -> m a -> m a -> m a
ifM (m bool -> m bool
forall bool (m :: * -> *).
(Boolean bool, Monad m) =>
m bool -> m bool
notM m bool
p) m ()
m (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
{-# INLINE unlessM #-}
guardM :: (ToBool bool, MonadPlus m) => m bool -> m ()
guardM :: m bool -> m ()
guardM = (bool -> m ()
forall bool (m :: * -> *).
(ToBool bool, MonadPlus m) =>
bool -> m ()
guard (bool -> m ()) -> m bool -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<)
{-# INLINE guardM #-}
selectM :: (ToBool bool, Monad m) =>
(a -> m bool) -> (a -> m b) -> (a -> m b) -> (a -> m b)
selectM :: (a -> m bool) -> (a -> m b) -> (a -> m b) -> a -> m b
selectM p :: a -> m bool
p t :: a -> m b
t f :: a -> m b
f x :: a
x = m bool -> m b -> m b -> m b
forall bool (m :: * -> *) a.
(ToBool bool, Monad m) =>
m bool -> m a -> m a -> m a
ifM (a -> m bool
p a
x) (a -> m b
t a
x) (a -> m b
f a
x)
{-# INLINE selectM #-}
(?<>) :: (ToBool bool, Monoid a) => bool -> a -> a
p :: bool
p ?<> :: bool -> a -> a
?<> m :: a
m = bool -> a -> a -> a
forall bool a. ToBool bool => bool -> a -> a -> a
if' bool
p a
m a
forall a. Monoid a => a
mempty
{-# INLINE (?<>) #-}
(?) :: b -> (b -> a) -> a
p :: b
p ? :: b -> (b -> a) -> a
? f :: b -> a
f = b -> a
f b
p
{-# INLINE (?) #-}
(|>) :: ToBool bool => bool -> a -> Maybe a
p :: bool
p |> :: bool -> a -> Maybe a
|> v :: a
v = bool -> Maybe a -> Maybe a -> Maybe a
forall bool a. ToBool bool => bool -> a -> a -> a
if' bool
p Maybe a
forall a. Maybe a
Nothing (a -> Maybe a
forall a. a -> Maybe a
Just a
v)
{-# INLINE (|>) #-}
(<|) :: a -> Maybe a -> a
t :: a
t <| :: a -> Maybe a -> a
<| Nothing = a
t
_ <| Just f :: a
f = a
f
{-# INLINE (<|) #-}
(|>>) :: (ToBool bool, Monad m) => m bool -> m a -> m (Maybe a)
p :: m bool
p |>> :: m bool -> m a -> m (Maybe a)
|>> v :: m a
v = m bool -> m (Maybe a) -> m (Maybe a) -> m (Maybe a)
forall bool (m :: * -> *) a.
(ToBool bool, Monad m) =>
m bool -> m a -> m a -> m a
ifM m bool
p (Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing) ((a -> Maybe a) -> m a -> m (Maybe a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Maybe a
forall a. a -> Maybe a
Just m a
v)
{-# INLINE (|>>) #-}
(<<|) :: Monad m => m a -> m (Maybe a) -> m a
v :: m a
v <<| :: m a -> m (Maybe a) -> m a
<<| mv :: m (Maybe a)
mv = (a -> Maybe a -> a) -> m a -> m (Maybe a) -> m a
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe m a
v m (Maybe a)
mv
{-# INLINE (<<|) #-}
(⊲) :: a -> Maybe a -> a
⊲ :: a -> Maybe a -> a
(⊲) = a -> Maybe a -> a
forall a. a -> Maybe a -> a
(<|)
(⊳) :: ToBool bool => bool -> a -> Maybe a
⊳ :: bool -> a -> Maybe a
(⊳) = bool -> a -> Maybe a
forall bool a. ToBool bool => bool -> a -> Maybe a
(|>)