{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Control.Monad.Skeleton (MonadView(..)
  , hoistMV
  , iterMV
  , Skeleton(..)
  , bone
  , debone
  , deboneBy
  , boned
  , hoistSkeleton
  ) where
import Control.Arrow
import Control.Applicative
import Control.Monad
import Control.Category
import Control.Monad.Skeleton.Internal
import Prelude hiding (id, (.))

-- | Re-add a bone. Inverse of 'debone'
boned :: MonadView t (Skeleton t) a -> Skeleton t a
boned :: forall (t :: * -> *) a. MonadView t (Skeleton t) a -> Skeleton t a
boned (Return a
a) = a -> Skeleton t a
forall a (t :: * -> *). a -> Skeleton t a
ReturnS a
a
boned (t a
t :>>= a -> Skeleton t a
k) = t a -> Cat (Kleisli (Skeleton t)) a a -> Skeleton t a
forall (t :: * -> *) b b.
t b -> Cat (Kleisli (Skeleton t)) b b -> Skeleton t b
BindS t a
t (Cat (Kleisli (Skeleton t)) a a -> Skeleton t a)
-> Cat (Kleisli (Skeleton t)) a a -> Skeleton t a
forall a b. (a -> b) -> a -> b
$ Kleisli (Skeleton t) a a -> Cat (Kleisli (Skeleton t)) a a
forall {k} (k :: k -> k -> *) (a :: k) (b :: k). k a b -> Cat k a b
Leaf (Kleisli (Skeleton t) a a -> Cat (Kleisli (Skeleton t)) a a)
-> Kleisli (Skeleton t) a a -> Cat (Kleisli (Skeleton t)) a a
forall a b. (a -> b) -> a -> b
$ (a -> Skeleton t a) -> Kleisli (Skeleton t) a a
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli a -> Skeleton t a
k
{-# INLINE boned #-}

-- | Extract the first instruction in 'Skeleton'.
debone :: Skeleton t a -> MonadView t (Skeleton t) a
debone :: forall (t :: * -> *) a. Skeleton t a -> MonadView t (Skeleton t) a
debone (ReturnS a
a) = a -> MonadView t (Skeleton t) a
forall a (t :: * -> *) (m :: * -> *). a -> MonadView t m a
Return a
a
debone (BindS t a
t Cat (Kleisli (Skeleton t)) a a
c0) = t a
t t a -> (a -> Skeleton t a) -> MonadView t (Skeleton t) a
forall (t :: * -> *) b (m :: * -> *) b.
t b -> (b -> m b) -> MonadView t m b
:>>= Cat (Kleisli (Skeleton t)) a a -> a -> Skeleton t a
forall (t :: * -> *) a b.
Cat (Kleisli (Skeleton t)) a b -> a -> Skeleton t b
go Cat (Kleisli (Skeleton t)) a a
c0 where
  go :: Cat (Kleisli (Skeleton t)) a b -> a -> Skeleton t b
  go :: forall (t :: * -> *) a b.
Cat (Kleisli (Skeleton t)) a b -> a -> Skeleton t b
go Cat (Kleisli (Skeleton t)) a b
c a
a = Cat (Kleisli (Skeleton t)) a b
-> (Kleisli (Skeleton t) a b -> Skeleton t b)
-> (forall x.
    Kleisli (Skeleton t) a x
    -> Cat (Kleisli (Skeleton t)) x b -> Skeleton t b)
-> Skeleton t b
forall {k1} (k2 :: k1 -> k1 -> *) (a :: k1) (b :: k1) r.
Cat k2 a b
-> (k2 a b -> r)
-> (forall (x :: k1). k2 a x -> Cat k2 x b -> r)
-> r
viewL Cat (Kleisli (Skeleton t)) a b
c (\(Kleisli a -> Skeleton t b
k) -> a -> Skeleton t b
k a
a) ((forall x.
  Kleisli (Skeleton t) a x
  -> Cat (Kleisli (Skeleton t)) x b -> Skeleton t b)
 -> Skeleton t b)
-> (forall x.
    Kleisli (Skeleton t) a x
    -> Cat (Kleisli (Skeleton t)) x b -> Skeleton t b)
-> Skeleton t b
forall a b. (a -> b) -> a -> b
$ \(Kleisli a -> Skeleton t x
k) Cat (Kleisli (Skeleton t)) x b
c' -> case a -> Skeleton t x
k a
a of
    ReturnS x
b -> Cat (Kleisli (Skeleton t)) x b -> x -> Skeleton t b
forall (t :: * -> *) a b.
Cat (Kleisli (Skeleton t)) a b -> a -> Skeleton t b
go Cat (Kleisli (Skeleton t)) x b
c' x
b
    BindS t a
t' Cat (Kleisli (Skeleton t)) a x
c'' -> t a -> Cat (Kleisli (Skeleton t)) a b -> Skeleton t b
forall (t :: * -> *) b b.
t b -> Cat (Kleisli (Skeleton t)) b b -> Skeleton t b
BindS t a
t' (Cat (Kleisli (Skeleton t)) a x
-> Cat (Kleisli (Skeleton t)) x b -> Cat (Kleisli (Skeleton t)) a b
forall {k} (k :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Cat k a b -> Cat k b c -> Cat k a c
Tree Cat (Kleisli (Skeleton t)) a x
c'' Cat (Kleisli (Skeleton t)) x b
c')

-- | Continuation-passing variant of 'debone'
-- which allows nicer expression using @LambdaCase@.
--
-- Usecase:
--
-- >  interpretM :: Monad m => Skeleton m a -> m a
-- >  interpretM = deboneBy $ \case
-- >    Return a -> return a
-- >    x :>>= f -> x >>= interpretM . f
deboneBy :: (MonadView t (Skeleton t) a -> r) -> Skeleton t a -> r
deboneBy :: forall (t :: * -> *) a r.
(MonadView t (Skeleton t) a -> r) -> Skeleton t a -> r
deboneBy MonadView t (Skeleton t) a -> r
f Skeleton t a
s = MonadView t (Skeleton t) a -> r
f (Skeleton t a -> MonadView t (Skeleton t) a
forall (t :: * -> *) a. Skeleton t a -> MonadView t (Skeleton t) a
debone Skeleton t a
s)
{-# INLINE deboneBy #-}

-- | A skeleton that has only one bone.
bone :: t a -> Skeleton t a
bone :: forall (t :: * -> *) a. t a -> Skeleton t a
bone t a
t = t a -> Cat (Kleisli (Skeleton t)) a a -> Skeleton t a
forall (t :: * -> *) b b.
t b -> Cat (Kleisli (Skeleton t)) b b -> Skeleton t b
BindS t a
t (Cat (Kleisli (Skeleton t)) a a -> Skeleton t a)
-> Cat (Kleisli (Skeleton t)) a a -> Skeleton t a
forall a b. (a -> b) -> a -> b
$ Kleisli (Skeleton t) a a -> Cat (Kleisli (Skeleton t)) a a
forall {k} (k :: k -> k -> *) (a :: k) (b :: k). k a b -> Cat k a b
Leaf (Kleisli (Skeleton t) a a -> Cat (Kleisli (Skeleton t)) a a)
-> Kleisli (Skeleton t) a a -> Cat (Kleisli (Skeleton t)) a a
forall a b. (a -> b) -> a -> b
$ (a -> Skeleton t a) -> Kleisli (Skeleton t) a a
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli a -> Skeleton t a
forall a (t :: * -> *). a -> Skeleton t a
ReturnS
{-# INLINABLE bone #-}

-- | Lift a transformation between bones into transformation between skeletons.
hoistSkeleton :: forall s t a. (forall x. s x -> t x) -> Skeleton s a -> Skeleton t a
hoistSkeleton :: forall (s :: * -> *) (t :: * -> *) a.
(forall x. s x -> t x) -> Skeleton s a -> Skeleton t a
hoistSkeleton forall x. s x -> t x
f = Skeleton s a -> Skeleton t a
forall x. Skeleton s x -> Skeleton t x
go where
  go :: forall x. Skeleton s x -> Skeleton t x
  go :: forall x. Skeleton s x -> Skeleton t x
go (ReturnS x
a) = x -> Skeleton t x
forall a (t :: * -> *). a -> Skeleton t a
ReturnS x
a
  go (BindS s a
t Cat (Kleisli (Skeleton s)) a x
c) = t a -> Cat (Kleisli (Skeleton t)) a x -> Skeleton t x
forall (t :: * -> *) b b.
t b -> Cat (Kleisli (Skeleton t)) b b -> Skeleton t b
BindS (s a -> t a
forall x. s x -> t x
f s a
t) (Cat (Kleisli (Skeleton t)) a x -> Skeleton t x)
-> Cat (Kleisli (Skeleton t)) a x -> Skeleton t x
forall a b. (a -> b) -> a -> b
$ (forall x y. Kleisli (Skeleton s) x y -> Kleisli (Skeleton t) x y)
-> Cat (Kleisli (Skeleton s)) a x -> Cat (Kleisli (Skeleton t)) a x
forall {k1} (j :: k1 -> k1 -> *) (k2 :: k1 -> k1 -> *) (a :: k1)
       (b :: k1).
(forall (x :: k1) (y :: k1). j x y -> k2 x y)
-> Cat j a b -> Cat k2 a b
transCat ((Skeleton s y -> Skeleton t y)
-> Kleisli (Skeleton s) x y -> Kleisli (Skeleton t) x y
forall (m :: * -> *) b (n :: * -> *) a.
(m b -> n b) -> Kleisli m a b -> Kleisli n a b
transKleisli Skeleton s y -> Skeleton t y
forall x. Skeleton s x -> Skeleton t x
go) Cat (Kleisli (Skeleton s)) a x
c
{-# INLINE hoistSkeleton #-}

-- | A deconstructed action
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 :: forall a b. (a -> b) -> MonadView t m a -> MonadView t m b
fmap a -> b
f (Return a
a) = b -> MonadView t m b
forall a (t :: * -> *) (m :: * -> *). a -> MonadView t m a
Return (a -> b
f a
a)
  fmap a -> b
f (t a
t :>>= a -> m a
k) = t a
t t a -> (a -> m b) -> MonadView t m b
forall (t :: * -> *) b (m :: * -> *) b.
t b -> (b -> m b) -> MonadView t m b
:>>= (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (m a -> m b) -> (a -> m a) -> a -> m b
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> m a
k
  {-# INLINE fmap #-}

-- | Transform the instruction as well as the continuation.
hoistMV :: (forall x. s x -> t x) -> (m a -> n a) -> MonadView s m a -> MonadView t n a
hoistMV :: forall (s :: * -> *) (t :: * -> *) (m :: * -> *) a (n :: * -> *).
(forall x. s x -> t x)
-> (m a -> n a) -> MonadView s m a -> MonadView t n a
hoistMV forall x. s x -> t x
_ m a -> n a
_ (Return a
a) = a -> MonadView t n a
forall a (t :: * -> *) (m :: * -> *). a -> MonadView t m a
Return a
a
hoistMV forall x. s x -> t x
f m a -> n a
g (s a
t :>>= a -> m a
k) = s a -> t a
forall x. s x -> t x
f s a
t t a -> (a -> n a) -> MonadView t n a
forall (t :: * -> *) b (m :: * -> *) b.
t b -> (b -> m b) -> MonadView t m b
:>>= m a -> n a
g (m a -> n a) -> (a -> m a) -> a -> n a
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> m a
k
{-# INLINE hoistMV #-}

-- | Join 'MonadView' recursively.
iterMV :: Monad m => (t a -> MonadView m t a) -> t a -> m a
iterMV :: forall (m :: * -> *) (t :: * -> *) a.
Monad m =>
(t a -> MonadView m t a) -> t a -> m a
iterMV t a -> MonadView m t a
f = t a -> m a
go where
  go :: t a -> m a
go t a
t = case t a -> MonadView m t a
f t a
t of
    m a
m :>>= a -> t a
k -> m a
m m a -> (a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= t a -> m a
go (t a -> m a) -> (a -> t a) -> a -> m a
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> t a
k
    Return a
a -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
{-# INLINE iterMV #-}

-- | @'Skeleton' t@ is a monadic skeleton (operational monad) made out of 't'.
-- Skeletons can be fleshed out by interpreting the instructions.
-- It provides O(1) ('>>=') and 'debone'.
data Skeleton t a where
  ReturnS :: a -> Skeleton t a
  BindS :: t a -> Cat (Kleisli (Skeleton t)) a b -> Skeleton t b

instance Functor (Skeleton t) where
  fmap :: forall a b. (a -> b) -> Skeleton t a -> Skeleton t b
fmap = (a -> b) -> Skeleton t a -> Skeleton t b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
  {-# INLINE fmap #-}

instance Applicative (Skeleton t) where
  pure :: forall a. a -> Skeleton t a
pure = a -> Skeleton t a
forall a (t :: * -> *). a -> Skeleton t a
ReturnS
  {-# INLINE pure #-}
  <*> :: forall a b. Skeleton t (a -> b) -> Skeleton t a -> Skeleton t b
(<*>) = Skeleton t (a -> b) -> Skeleton t a -> Skeleton t b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
  {-# INLINE (<*>) #-}
  ReturnS a
_ *> :: forall a b. Skeleton t a -> Skeleton t b -> Skeleton t b
*> Skeleton t b
k = Skeleton t b
k
  BindS t a
t Cat (Kleisli (Skeleton t)) a a
c *> Skeleton t b
k = t a -> Cat (Kleisli (Skeleton t)) a b -> Skeleton t b
forall (t :: * -> *) b b.
t b -> Cat (Kleisli (Skeleton t)) b b -> Skeleton t b
BindS t a
t (Cat (Kleisli (Skeleton t)) a a
c Cat (Kleisli (Skeleton t)) a a
-> Kleisli (Skeleton t) a b -> Cat (Kleisli (Skeleton t)) a b
forall {k1} (k2 :: k1 -> k1 -> *) (a :: k1) (b :: k1) (c :: k1).
Cat k2 a b -> k2 b c -> Cat k2 a c
|> (a -> Skeleton t b) -> Kleisli (Skeleton t) a b
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli (Skeleton t b -> a -> Skeleton t b
forall a b. a -> b -> a
const Skeleton t b
k))
  Skeleton t a
a <* :: forall a b. Skeleton t a -> Skeleton t b -> Skeleton t a
<* Skeleton t b
b = Skeleton t a
a Skeleton t a -> (a -> Skeleton t a) -> Skeleton t a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x -> Skeleton t b
b Skeleton t b -> Skeleton t a -> Skeleton t a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Skeleton t a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

instance Monad (Skeleton t) where
  ReturnS a
a >>= :: forall a b. Skeleton t a -> (a -> Skeleton t b) -> Skeleton t b
>>= a -> Skeleton t b
k = a -> Skeleton t b
k a
a
  BindS t a
t Cat (Kleisli (Skeleton t)) a a
c >>= a -> Skeleton t b
k = t a -> Cat (Kleisli (Skeleton t)) a b -> Skeleton t b
forall (t :: * -> *) b b.
t b -> Cat (Kleisli (Skeleton t)) b b -> Skeleton t b
BindS t a
t (Cat (Kleisli (Skeleton t)) a a
c Cat (Kleisli (Skeleton t)) a a
-> Kleisli (Skeleton t) a b -> Cat (Kleisli (Skeleton t)) a b
forall {k1} (k2 :: k1 -> k1 -> *) (a :: k1) (b :: k1) (c :: k1).
Cat k2 a b -> k2 b c -> Cat k2 a c
|> (a -> Skeleton t b) -> Kleisli (Skeleton t) a b
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli a -> Skeleton t b
k)