module Control.Monad.Skeleton (MonadView(..)
, hoistMV
, iterMV
, Skeleton(..)
, bone
, debone
, unbone
, boned
, hoistSkeleton
, Spine(..)
, graftSpine
) where
import Control.Arrow
import Control.Applicative
import Control.Monad
import Control.Category
import Control.Monad.Skeleton.Internal
import Prelude hiding (id, (.))
boned :: MonadView t (Skeleton t) a -> Skeleton t a
boned t = Skeleton (Spine t id)
debone :: Skeleton t a -> MonadView t (Skeleton t) a
debone (Skeleton (Spine v c)) = case v of
Return a -> viewL c (Return a) $ \(Kleisli k) c' -> case k a of
Skeleton s -> debone $ Skeleton $ graftSpine c' s
t :>>= k -> t :>>= \a -> case k a of
Skeleton s -> Skeleton (graftSpine c s)
unbone :: Skeleton t a -> MonadView t (Skeleton t) a
unbone = debone
bone :: t a -> Skeleton t a
bone t = Skeleton (Spine (t :>>= return) id)
hoistSkeleton :: forall s t a. (forall x. s x -> t x) -> Skeleton s a -> Skeleton t a
hoistSkeleton f = go where
go :: forall x. Skeleton s x -> Skeleton t x
go (Skeleton (Spine v c)) = Skeleton $ Spine (hoistMV f go v)
(transCat (transKleisli go) c)
data MonadView t m x where
Return :: a -> MonadView t m a
(:>>=) :: !(t a) -> (a -> m b) -> MonadView t m b
infixl 1 :>>=
instance Functor m => Functor (MonadView t m) where
fmap f (Return a) = Return (f a)
fmap f (t :>>= k) = t :>>= fmap f . k
hoistMV :: (forall x. s x -> t x) -> (m a -> n a) -> MonadView s m a -> MonadView t n a
hoistMV _ _ (Return a) = Return a
hoistMV f g (t :>>= k) = f t :>>= g . k
iterMV :: Monad m => (t a -> MonadView m t a) -> t a -> m a
iterMV f = go where
go t = case f t of
m :>>= k -> m >>= go . k
Return a -> return a
data Spine t m a where
Spine :: MonadView t m a -> Cat (Kleisli m) a b -> Spine t m b
graftSpine :: Cat (Kleisli m) a b -> Spine t m a -> Spine t m b
graftSpine c (Spine v d) = Spine v (c . d)
newtype Skeleton t a = Skeleton { unSkeleton :: Spine t (Skeleton t) a }
instance Functor (Skeleton t) where
fmap = liftM
instance Applicative (Skeleton t) where
pure = return
(<*>) = ap
(*>) = (>>)
a <* b = a >>= \x -> b >> return x
instance Monad (Skeleton t) where
return a = Skeleton $ Spine (Return a) id
Skeleton (Spine t c) >>= k = Skeleton $ Spine t (c |> Kleisli k)