module Data.Cond
( CondT(..), Cond
, runCondT, runCond, applyCondT, applyCond
, guardM, guard_, guardM_, apply, consider
, matches, if_, when_, unless_, or_, and_, not_
, ignore, norecurse, prune
, recurse, test
, CondEitherT(..), fromCondT, toCondT
) where
import Control.Applicative
import Control.Arrow (first)
import Control.Monad hiding (mapM_, sequence_)
import Control.Monad.Base
import Control.Monad.Catch
import Control.Monad.Morph
import Control.Monad.Reader.Class
import Control.Monad.State.Class
import Control.Monad.Trans
import Control.Monad.Trans.Control
import Control.Monad.Trans.Either
import Control.Monad.Trans.State (StateT(..), withStateT, evalStateT)
import Data.Foldable
import Data.Functor.Identity
import Data.Maybe (fromMaybe, isJust)
import Data.Monoid hiding ((<>))
import Data.Semigroup
import Prelude hiding (mapM_, foldr1, sequence_)
data Result a m b = Ignore
| Keep b
| RecurseOnly (Maybe (CondT a m b))
| KeepAndRecurse b (Maybe (CondT a m b))
instance Show b => Show (Result a m b) where
show Ignore = "Ignore"
show (Keep a) = "Keep " ++ show a
show (RecurseOnly _) = "RecurseOnly"
show (KeepAndRecurse a _) = "KeepAndRecurse " ++ show a
instance Monad m => Functor (Result a m) where
fmap _ Ignore = Ignore
fmap f (Keep a) = Keep (f a)
fmap f (RecurseOnly l) = RecurseOnly (liftM (fmap f) l)
fmap f (KeepAndRecurse a l) = KeepAndRecurse (f a) (liftM (fmap f) l)
instance MFunctor (Result a) where
hoist _ Ignore = Ignore
hoist _ (Keep a) = Keep a
hoist nat (RecurseOnly l) = RecurseOnly (fmap (hoist nat) l)
hoist nat (KeepAndRecurse a l) = KeepAndRecurse a (fmap (hoist nat) l)
instance Semigroup (Result a m b) where
Ignore <> _ = Ignore
_ <> Ignore = Ignore
RecurseOnly _ <> Keep _ = Ignore
RecurseOnly _ <> KeepAndRecurse _ m = RecurseOnly m
RecurseOnly m <> _ = RecurseOnly m
Keep _ <> RecurseOnly _ = Ignore
_ <> RecurseOnly m = RecurseOnly m
_ <> Keep b = Keep b
Keep _ <> KeepAndRecurse b _ = Keep b
_ <> KeepAndRecurse b m = KeepAndRecurse b m
instance Monoid b => Monoid (Result a m b) where
mempty = KeepAndRecurse mempty Nothing
mappend = (<>)
getResult :: Result a m b -> (Maybe b, Maybe (CondT a m b))
getResult Ignore = (Nothing, Nothing)
getResult (Keep b) = (Just b, Nothing)
getResult (RecurseOnly c) = (Nothing, c)
getResult (KeepAndRecurse b c) = (Just b, c)
setRecursion :: CondT a m b -> Result a m b -> Result a m b
setRecursion _ Ignore = Ignore
setRecursion _ (Keep b) = Keep b
setRecursion c (RecurseOnly _) = RecurseOnly (Just c)
setRecursion c (KeepAndRecurse b _) = KeepAndRecurse b (Just c)
accept' :: b -> Result a m b
accept' = flip KeepAndRecurse Nothing
recurse' :: Result a m b
recurse' = RecurseOnly Nothing
maybeToResult :: Maybe a -> Result r m a
maybeToResult Nothing = recurse'
maybeToResult (Just a) = accept' a
maybeFromResult :: Result r m a -> Maybe a
maybeFromResult Ignore = Nothing
maybeFromResult (Keep a) = Just a
maybeFromResult (RecurseOnly _) = Nothing
maybeFromResult (KeepAndRecurse a _) = Just a
newtype CondT a m b = CondT { getCondT :: StateT a m (Result a m b) }
type Cond a = CondT a Identity
instance Show (CondT a m b) where
show _ = "CondT"
instance (Monad m, Semigroup b) => Semigroup (CondT a m b) where
(<>) = liftM2 (<>)
instance (Monad m, Monoid b) => Monoid (CondT a m b) where
mempty = CondT $ return $ accept' mempty
mappend = liftM2 mappend
instance Monad m => Functor (CondT a m) where
#if __GLASGOW_HASKELL__ < 710
fmap f (CondT g) = CondT (liftM (fmap f) g)
#else
fmap f (CondT g) = CondT (liftA (fmap f) g)
#endif
instance Monad m => Applicative (CondT a m) where
pure = return
(<*>) = ap
instance Monad m => Monad (CondT a m) where
return = CondT . return . accept'
fail _ = mzero
CondT f >>= k = CondT $ do
r <- f
case r of
Ignore -> return Ignore
Keep b -> do
n <- getCondT (k b)
return $ case n of
RecurseOnly _ -> Ignore
KeepAndRecurse c _ -> Keep c
_ -> n
RecurseOnly l -> return $ RecurseOnly (fmap (>>= k) l)
KeepAndRecurse b _ -> getCondT (k b)
instance Monad m => MonadReader a (CondT a m) where
ask = CondT $ gets accept'
local f (CondT m) = CondT $ withStateT f m
reader f = liftM f ask
instance Monad m => MonadState a (CondT a m) where
get = CondT $ gets accept'
put s = CondT $ liftM accept' $ put s
state f = CondT $ state (fmap (first accept') f)
instance Monad m => Alternative (CondT a m) where
empty = CondT $ return recurse'
CondT f <|> CondT g = CondT $ do
r <- f
case r of
x@(Keep _) -> return x
x@(KeepAndRecurse _ _) -> return x
_ -> g
instance Monad m => MonadPlus (CondT a m) where
mzero = empty
mplus = (<|>)
instance MonadThrow m => MonadThrow (CondT a m) where
throwM = CondT . throwM
instance MonadCatch m => MonadCatch (CondT a m) where
catch (CondT m) c = CondT $ m `catch` \e -> getCondT (c e)
instance MonadMask m => MonadMask (CondT a m) where
mask a = CondT $ mask $ \u -> getCondT (a $ q u)
where q u = CondT . u . getCondT
uninterruptibleMask a =
CondT $ uninterruptibleMask $ \u -> getCondT (a $ q u)
where q u = CondT . u . getCondT
instance MonadBase b m => MonadBase b (CondT a m) where
liftBase m = CondT $ liftM accept' $ liftBase m
instance MonadIO m => MonadIO (CondT a m) where
liftIO m = CondT $ liftM accept' $ liftIO m
instance MonadTrans (CondT a) where
lift m = CondT $ liftM accept' $ lift m
instance MonadBaseControl b m => MonadBaseControl b (CondT r m) where
type StM (CondT r m) a = StM m (Result r m a, r)
liftBaseWith f = CondT $ StateT $ \s ->
liftM (\x -> (accept' x, s)) $ liftBaseWith $ \runInBase -> f $ \k ->
runInBase $ runStateT (getCondT k) s
restoreM = CondT . StateT . const . restoreM
instance MFunctor (CondT a) where
hoist nat (CondT m) = CondT $ hoist nat (liftM (hoist nat) m)
runCondT :: Monad m => CondT a m b -> a -> m (Maybe b)
runCondT (CondT f) a = maybeFromResult `liftM` evalStateT f a
runCond :: Cond a b -> a -> Maybe b
runCond = (runIdentity .) . runCondT
applyCondT :: Monad m
=> a
-> CondT a m b
-> m ((Maybe b, Maybe (CondT a m b)), a)
applyCondT a cond = do
(r, a') <- runStateT (getCondT cond) a
return (fmap (Just . fromMaybe cond) (getResult r), a')
applyCond :: a -> Cond a b -> ((Maybe b, Maybe (Cond a b)), a)
applyCond a cond = first (fmap (Just . fromMaybe cond) . getResult)
(runIdentity (runStateT (getCondT cond) a))
guardM :: Monad m => m Bool -> CondT a m ()
guardM m = lift m >>= guard
guard_ :: Monad m => (a -> Bool) -> CondT a m ()
guard_ f = asks f >>= guard
guardM_ :: Monad m => (a -> m Bool) -> CondT a m ()
guardM_ f = ask >>= lift . f >>= guard
apply :: Monad m => (a -> m (Maybe b)) -> CondT a m b
apply f = CondT $ get >>= liftM maybeToResult . lift . f
consider :: Monad m => (a -> m (Maybe (b, a))) -> CondT a m b
consider f = CondT $ do
mres <- lift . f =<< get
case mres of
Nothing -> return Ignore
Just (b, a') -> put a' >> return (accept' b)
matches :: Monad m => CondT a m b -> CondT a m Bool
matches = fmap isJust . optional
if_ :: Monad m => CondT a m r -> CondT a m b -> CondT a m b -> CondT a m b
if_ c x y =
CondT $ getCondT . maybe y (const x) . maybeFromResult =<< getCondT c
when_ :: Monad m => CondT a m r -> CondT a m () -> CondT a m ()
when_ c x = if_ c (void x) (return ())
unless_ :: Monad m => CondT a m r -> CondT a m () -> CondT a m ()
unless_ c = if_ c (return ()) . void
or_ :: Monad m => [CondT a m b] -> CondT a m b
or_ = asum
and_ :: Monad m => [CondT a m b] -> CondT a m ()
and_ = sequence_
not_ :: Monad m => CondT a m b -> CondT a m ()
not_ c = when_ c ignore
ignore :: Monad m => CondT a m b
ignore = mzero
norecurse :: Monad m => CondT a m ()
norecurse = CondT $ return $ Keep ()
prune :: Monad m => CondT a m b
prune = CondT $ return Ignore
recurse :: Monad m => CondT a m b -> CondT a m b
recurse c = CondT $ setRecursion c `liftM` getCondT c
test :: Monad m => a -> CondT a m b -> m Bool
test = (liftM isJust .) . flip runCondT
newtype CondEitherT a m b = CondEitherT
(StateT a (EitherT (Maybe (Maybe (CondEitherT a m b))) m)
(b, Maybe (Maybe (CondEitherT a m b))))
fromCondT :: Monad m => CondT a m b -> CondEitherT a m b
fromCondT (CondT f) = CondEitherT $ do
s <- get
(r, s') <- lift $ lift $ runStateT f s
case r of
Ignore -> lift $ left Nothing
Keep a -> put s' >> return (a, Nothing)
RecurseOnly m -> lift $ left (Just (fmap fromCondT m))
KeepAndRecurse a m -> put s' >> return (a, Just (fmap fromCondT m))
toCondT :: Monad m => CondEitherT a m b -> CondT a m b
toCondT (CondEitherT f) = CondT $ do
s <- get
eres <- lift $ runEitherT $ runStateT f s
case eres of
Left Nothing -> return Ignore
Right ((a, Nothing), s') -> put s' >> return (Keep a)
Left (Just m) -> return $ RecurseOnly (fmap toCondT m)
Right ((a, Just m), s') ->
put s' >> return (KeepAndRecurse a (fmap toCondT m))