module Data.List.Cut
(
CutListT'(..),
CutListT(..),
retract,
CutList,
cutToList,
cutFromList,
cut,
cutFail,
scope,
)
where
import Control.Applicative (Alternative(..), Applicative(..), (<$>))
import Control.Monad (liftM, MonadPlus(..), ap)
import Control.Monad.Trans (MonadTrans(..))
import Control.Monad.Identity (Identity(..))
import Data.Foldable (Foldable(..))
import Data.Traversable (Traversable(..))
import Data.Monoid (Monoid(..))
import Data.Monoid.Zero (MonoidRZero(..))
data CutListT' m a = CCons a (m (CutListT' m a)) | CNil | CCut
deriving (Functor)
instance (Foldable m) => Foldable (CutListT' m) where
foldMap f (CCons a m) = f a `mappend` foldMap (foldMap f) m
foldMap f _ = mempty
instance (Traversable m) => Traversable (CutListT' m) where
traverse f (CCons a m) = CCons <$> f a <*> traverse (traverse f) m
traverse f CNil = pure CNil
traverse f CCut = pure CCut
newtype CutListT m a = CutListT { unCutListT :: m (CutListT' m a) }
deriving (Functor)
instance (Monad m) => Monad (CutListT m) where
return a = CutListT $ return $ CCons a $ return CNil
CutListT m >>= f = CutListT $ m >>= \x -> case x of
CCons a m -> unCutListT $ f a +<>+ (CutListT m >>= f)
CNil -> return CNil
CCut -> return CCut
instance (Functor m, Monad m) => Applicative (CutListT m) where
pure = return
(<*>) = ap
instance MonadTrans CutListT where
lift m = CutListT $ liftM (\a -> CCons a $ return CNil) m
instance (Functor m, Monad m) => Alternative (CutListT m) where
empty = CutListT $ return CNil
(<|>) = (+<>+)
instance (Functor m, Monad m) => MonadPlus (CutListT m) where
mzero = empty
mplus = (<|>)
instance (Foldable m) => Foldable (CutListT m) where
foldMap f (CutListT m) = foldMap (foldMap f) m
instance (Traversable m) => Traversable (CutListT m) where
traverse f (CutListT m) = CutListT <$> traverse (traverse f) m
instance (Functor m, Monad m) => Monoid (CutListT m a) where
mempty = mzero
mappend = mplus
instance (Functor m, Monad m) => MonoidRZero (CutListT m a) where
rzero = CutListT $ return $ CCut
retract :: (Monad m) => CutListT m a -> m ()
retract (CutListT m) = m >>= aux
where
aux (CCons _ m) = m >>= aux
aux _ = return ()
type CutList = CutListT Identity
cutToList :: CutList a -> [a]
cutToList (CutListT (Identity t)) = aux t
where
aux (CCons a (Identity t)) = a : aux t
aux _ = []
cutFromList :: [a] -> CutList a
cutFromList xs = CutListT $ Identity $ aux xs
where
aux (x : xs) = CCons x $ Identity $ aux xs
aux _ = CNil
cut :: (Functor m, Monad m) => CutListT m ()
cut = CutListT $ return CCut
cutFail :: (Functor m, Monad m) => CutListT m ()
cutFail = cut >> mzero
scope :: (Functor m, Monad m) => CutListT m a -> CutListT m a
scope (CutListT m) = CutListT $ liftM aux m
where
aux (CCons a m) = CCons a (liftM aux m)
aux CNil = CNil
aux CCut = CNil
(+<>+) :: (Monad m) => CutListT m a -> CutListT m a -> CutListT m a
CutListT m +<>+ CutListT n = CutListT $ m >>= aux
where
aux (CCons a k) = return $ CCons a $ k >>= aux
aux CNil = n
aux CCut = return CNil