{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Control.Monad.Zombie (Zombie(..)
  , liftZ
  , embalm
  , disembalm
  , disembalmBy
  , hoistZombie
  ) where
import Control.Applicative
import Control.Arrow
import Control.Monad
import Control.Monad.Skeleton
import Control.Monad.Skeleton.Internal
import Prelude hiding (id, (.))

-- | 'Zombie' is a variant of 'Skeleton' which has an 'Alternative' instance.
data Zombie t a where
  Sunlight :: Zombie t a
  ReturnZ :: a -> Zombie t a -> Zombie t a
  BindZ :: t x -> Cat (Kleisli (Zombie t)) x a -> Zombie t a -> Zombie t a

instance Functor (Zombie t) where
  fmap :: forall a b. (a -> b) -> Zombie t a -> Zombie t b
fmap = (a -> b) -> Zombie t a -> Zombie t b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative (Zombie t) where
  pure :: forall a. a -> Zombie t a
pure a
a = a -> Zombie t a -> Zombie t a
forall a (t :: * -> *). a -> Zombie t a -> Zombie t a
ReturnZ a
a Zombie t a
forall (t :: * -> *) a. Zombie t a
Sunlight
  <*> :: forall a b. Zombie t (a -> b) -> Zombie t a -> Zombie t b
(<*>) = Zombie t (a -> b) -> Zombie t a -> Zombie t b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
  Zombie t a
Sunlight *> :: forall a b. Zombie t a -> Zombie t b -> Zombie t b
*> Zombie t b
_ = Zombie t b
forall (t :: * -> *) a. Zombie t a
Sunlight
  ReturnZ a
_ Zombie t a
xs *> Zombie t b
k = Zombie t b
k Zombie t b -> Zombie t b -> Zombie t b
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Zombie t a
xs Zombie t a -> Zombie t b -> Zombie t b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Zombie t b
k)
  BindZ t x
x Cat (Kleisli (Zombie t)) x a
c Zombie t a
xs *> Zombie t b
k = t x -> Cat (Kleisli (Zombie t)) x b -> Zombie t b -> Zombie t b
forall (t :: * -> *) b a.
t b -> Cat (Kleisli (Zombie t)) b a -> Zombie t a -> Zombie t a
BindZ t x
x (Cat (Kleisli (Zombie t)) x a
c Cat (Kleisli (Zombie t)) x a
-> Kleisli (Zombie t) a b -> Cat (Kleisli (Zombie t)) x b
forall {k1} (k2 :: k1 -> k1 -> *) (a :: k1) (b :: k1) (c :: k1).
Cat k2 a b -> k2 b c -> Cat k2 a c
|> (a -> Zombie t b) -> Kleisli (Zombie t) a b
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli (Zombie t b -> a -> Zombie t b
forall a b. a -> b -> a
const Zombie t b
k)) (Zombie t a
xs Zombie t a -> Zombie t b -> Zombie t b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Zombie t b
k)

instance Alternative (Zombie t) where
  empty :: forall a. Zombie t a
empty = Zombie t a
forall (t :: * -> *) a. Zombie t a
Sunlight
  Zombie t a
Sunlight <|> :: forall a. Zombie t a -> Zombie t a -> Zombie t a
<|> Zombie t a
ys = Zombie t a
ys
  ReturnZ a
x Zombie t a
xs <|> Zombie t a
ys = a -> Zombie t a -> Zombie t a
forall a (t :: * -> *). a -> Zombie t a -> Zombie t a
ReturnZ a
x (Zombie t a
xs Zombie t a -> Zombie t a -> Zombie t a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Zombie t a
ys)
  BindZ t x
x Cat (Kleisli (Zombie t)) x a
c Zombie t a
xs <|> Zombie t a
ys = t x -> Cat (Kleisli (Zombie t)) x a -> Zombie t a -> Zombie t a
forall (t :: * -> *) b a.
t b -> Cat (Kleisli (Zombie t)) b a -> Zombie t a -> Zombie t a
BindZ t x
x Cat (Kleisli (Zombie t)) x a
c (Zombie t a
xs Zombie t a -> Zombie t a -> Zombie t a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Zombie t a
ys)

instance Monad (Zombie t) where
  Zombie t a
Sunlight >>= :: forall a b. Zombie t a -> (a -> Zombie t b) -> Zombie t b
>>= a -> Zombie t b
_ = Zombie t b
forall (t :: * -> *) a. Zombie t a
Sunlight
  ReturnZ a
a Zombie t a
xs >>= a -> Zombie t b
k = a -> Zombie t b
k a
a Zombie t b -> Zombie t b -> Zombie t b
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Zombie t a
xs Zombie t a -> (a -> Zombie t b) -> Zombie t b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Zombie t b
k)
  BindZ t x
x Cat (Kleisli (Zombie t)) x a
c Zombie t a
xs >>= a -> Zombie t b
k = t x -> Cat (Kleisli (Zombie t)) x b -> Zombie t b -> Zombie t b
forall (t :: * -> *) b a.
t b -> Cat (Kleisli (Zombie t)) b a -> Zombie t a -> Zombie t a
BindZ t x
x (Cat (Kleisli (Zombie t)) x a
c Cat (Kleisli (Zombie t)) x a
-> Kleisli (Zombie t) a b -> Cat (Kleisli (Zombie t)) x b
forall {k1} (k2 :: k1 -> k1 -> *) (a :: k1) (b :: k1) (c :: k1).
Cat k2 a b -> k2 b c -> Cat k2 a c
|> (a -> Zombie t b) -> Kleisli (Zombie t) a b
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli a -> Zombie t b
k) (Zombie t a
xs Zombie t a -> (a -> Zombie t b) -> Zombie t b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Zombie t b
k)

instance MonadPlus (Zombie t) where
  mzero :: forall a. Zombie t a
mzero = Zombie t a
forall (f :: * -> *) a. Alternative f => f a
empty
  mplus :: forall a. Zombie t a -> Zombie t a -> Zombie t a
mplus = Zombie t a -> Zombie t a -> Zombie t a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

-- | Lift a unit action
liftZ :: t a -> Zombie t a
liftZ :: forall (t :: * -> *) a. t a -> Zombie t a
liftZ t a
t = MonadView t (Zombie t) a -> Zombie t a
forall (t :: * -> *) a. MonadView t (Zombie t) a -> Zombie t a
embalm (t a
t t a -> (a -> Zombie t a) -> MonadView t (Zombie t) a
forall (t :: * -> *) b (m :: * -> *) b.
t b -> (b -> m b) -> MonadView t m b
:>>= a -> Zombie t a
forall (m :: * -> *) a. Monad m => a -> m a
return)
{-# INLINE liftZ #-}

-- | Turn a decomposed form into a composed form.
embalm :: MonadView t (Zombie t) a -> Zombie t a
embalm :: forall (t :: * -> *) a. MonadView t (Zombie t) a -> Zombie t a
embalm (Return a
x) = a -> Zombie t a -> Zombie t a
forall a (t :: * -> *). a -> Zombie t a -> Zombie t a
ReturnZ a
x Zombie t a
forall (t :: * -> *) a. Zombie t a
Sunlight
embalm (t a
x :>>= a -> Zombie t a
k) = t a -> Cat (Kleisli (Zombie t)) a a -> Zombie t a -> Zombie t a
forall (t :: * -> *) b a.
t b -> Cat (Kleisli (Zombie t)) b a -> Zombie t a -> Zombie t a
BindZ t a
x (Kleisli (Zombie t) a a -> Cat (Kleisli (Zombie t)) a a
forall {k} (k :: k -> k -> *) (a :: k) (b :: k). k a b -> Cat k a b
Leaf (Kleisli (Zombie t) a a -> Cat (Kleisli (Zombie t)) a a)
-> Kleisli (Zombie t) a a -> Cat (Kleisli (Zombie t)) a a
forall a b. (a -> b) -> a -> b
$ (a -> Zombie t a) -> Kleisli (Zombie t) a a
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli a -> Zombie t a
k) Zombie t a
forall (t :: * -> *) a. Zombie t a
Sunlight
{-# INLINE embalm #-}

-- | Decompose a zombie as a list of possibilities.
disembalm :: Zombie t a -> [MonadView t (Zombie t) a]
disembalm :: forall (t :: * -> *) a. Zombie t a -> [MonadView t (Zombie t) a]
disembalm = [MonadView t (Zombie t) a]
-> (MonadView t (Zombie t) a
    -> [MonadView t (Zombie t) a] -> [MonadView t (Zombie t) a])
-> Zombie t a
-> [MonadView t (Zombie t) a]
forall r (t :: * -> *) a.
r -> (MonadView t (Zombie t) a -> r -> r) -> Zombie t a -> r
disembalmBy [] (:)
{-# INLINE disembalm #-}

-- | Decompose a zombie as a list of possibilitie and fold the list.
disembalmBy :: r -> (MonadView t (Zombie t) a -> r -> r) -> Zombie t a -> r
disembalmBy :: forall r (t :: * -> *) a.
r -> (MonadView t (Zombie t) a -> r -> r) -> Zombie t a -> r
disembalmBy r
e MonadView t (Zombie t) a -> r -> r
r = Zombie t a -> r
go where
  go :: Zombie t a -> r
go Zombie t a
Sunlight = r
e
  go (ReturnZ a
x Zombie t a
xs) = a -> MonadView t (Zombie t) a
forall a (t :: * -> *) (m :: * -> *). a -> MonadView t m a
Return a
x MonadView t (Zombie t) a -> r -> r
`r` Zombie t a -> r
go Zombie t a
xs
  go (BindZ t x
x Cat (Kleisli (Zombie t)) x a
c Zombie t a
xs) = (t x
x t x -> (x -> Zombie t a) -> MonadView t (Zombie t) a
forall (t :: * -> *) b (m :: * -> *) b.
t b -> (b -> m b) -> MonadView t m b
:>>= Cat (Kleisli (Zombie t)) x a -> x -> Zombie t a
forall (t :: * -> *) a b.
Cat (Kleisli (Zombie t)) a b -> a -> Zombie t b
disembalm_go Cat (Kleisli (Zombie t)) x a
c) MonadView t (Zombie t) a -> r -> r
`r` Zombie t a -> r
go Zombie t a
xs
{-# INLINE disembalmBy #-}

disembalm_go :: Cat (Kleisli (Zombie t)) a b -> a -> Zombie t b
disembalm_go :: forall (t :: * -> *) a b.
Cat (Kleisli (Zombie t)) a b -> a -> Zombie t b
disembalm_go Cat (Kleisli (Zombie t)) a b
c a
a = Cat (Kleisli (Zombie t)) a b
-> (Kleisli (Zombie t) a b -> Zombie t b)
-> (forall x.
    Kleisli (Zombie t) a x
    -> Cat (Kleisli (Zombie t)) x b -> Zombie t b)
-> Zombie 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 (Zombie t)) a b
c (\Kleisli (Zombie t) a b
k -> Kleisli (Zombie t) a b -> a -> Zombie t b
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli Kleisli (Zombie t) a b
k a
a) ((forall x.
  Kleisli (Zombie t) a x
  -> Cat (Kleisli (Zombie t)) x b -> Zombie t b)
 -> Zombie t b)
-> (forall x.
    Kleisli (Zombie t) a x
    -> Cat (Kleisli (Zombie t)) x b -> Zombie t b)
-> Zombie t b
forall a b. (a -> b) -> a -> b
$
  \Kleisli (Zombie t) a x
k Cat (Kleisli (Zombie t)) x b
d -> Cat (Kleisli (Zombie t)) x b -> Zombie t x -> Zombie t b
forall (t :: * -> *) a b.
Cat (Kleisli (Zombie t)) a b -> Zombie t a -> Zombie t b
disembalm_go2 Cat (Kleisli (Zombie t)) x b
d (Zombie t x -> Zombie t b) -> Zombie t x -> Zombie t b
forall a b. (a -> b) -> a -> b
$ Kleisli (Zombie t) a x -> a -> Zombie t x
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli Kleisli (Zombie t) a x
k a
a

disembalm_go2 :: Cat (Kleisli (Zombie t)) a b -> Zombie t a -> Zombie t b
disembalm_go2 :: forall (t :: * -> *) a b.
Cat (Kleisli (Zombie t)) a b -> Zombie t a -> Zombie t b
disembalm_go2 Cat (Kleisli (Zombie t)) a b
c = Zombie t a -> Zombie t b
go where
  go :: Zombie t a -> Zombie t b
go Zombie t a
Sunlight = Zombie t b
forall (t :: * -> *) a. Zombie t a
Sunlight
  go (ReturnZ a
a Zombie t a
xs) = Cat (Kleisli (Zombie t)) a b -> a -> Zombie t b
forall (t :: * -> *) a b.
Cat (Kleisli (Zombie t)) a b -> a -> Zombie t b
disembalm_go Cat (Kleisli (Zombie t)) a b
c a
a Zombie t b -> Zombie t b -> Zombie t b
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Zombie t a -> Zombie t b
go Zombie t a
xs
  go (BindZ t x
t Cat (Kleisli (Zombie t)) x a
d Zombie t a
xs) = t x -> Cat (Kleisli (Zombie t)) x b -> Zombie t b -> Zombie t b
forall (t :: * -> *) b a.
t b -> Cat (Kleisli (Zombie t)) b a -> Zombie t a -> Zombie t a
BindZ t x
t (Cat (Kleisli (Zombie t)) x a
-> Cat (Kleisli (Zombie t)) a b -> Cat (Kleisli (Zombie t)) x 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 (Zombie t)) x a
d Cat (Kleisli (Zombie t)) a b
c) (Zombie t b -> Zombie t b) -> Zombie t b -> Zombie t b
forall a b. (a -> b) -> a -> b
$ Zombie t a -> Zombie t b
go Zombie t a
xs

-- | Like 'hoistSkeleton'
hoistZombie :: forall s t a. (forall x. s x -> t x) -> Zombie s a -> Zombie t a
hoistZombie :: forall (s :: * -> *) (t :: * -> *) a.
(forall x. s x -> t x) -> Zombie s a -> Zombie t a
hoistZombie forall x. s x -> t x
f = Zombie s a -> Zombie t a
forall x. Zombie s x -> Zombie t x
go where
  go :: forall x. Zombie s x -> Zombie t x
  go :: forall x. Zombie s x -> Zombie t x
go Zombie s x
Sunlight = Zombie t x
forall (t :: * -> *) a. Zombie t a
Sunlight
  go (ReturnZ x
x Zombie s x
xs) = x -> Zombie t x -> Zombie t x
forall a (t :: * -> *). a -> Zombie t a -> Zombie t a
ReturnZ x
x (Zombie s x -> Zombie t x
forall x. Zombie s x -> Zombie t x
go Zombie s x
xs)
  go (BindZ s x
x Cat (Kleisli (Zombie s)) x x
c Zombie s x
xs) = t x -> Cat (Kleisli (Zombie t)) x x -> Zombie t x -> Zombie t x
forall (t :: * -> *) b a.
t b -> Cat (Kleisli (Zombie t)) b a -> Zombie t a -> Zombie t a
BindZ (s x -> t x
forall x. s x -> t x
f s x
x) ((forall x y. Kleisli (Zombie s) x y -> Kleisli (Zombie t) x y)
-> Cat (Kleisli (Zombie s)) x x -> Cat (Kleisli (Zombie t)) x 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 ((Zombie s y -> Zombie t y)
-> Kleisli (Zombie s) x y -> Kleisli (Zombie t) x y
forall (m :: * -> *) b (n :: * -> *) a.
(m b -> n b) -> Kleisli m a b -> Kleisli n a b
transKleisli Zombie s y -> Zombie t y
forall x. Zombie s x -> Zombie t x
go) Cat (Kleisli (Zombie s)) x x
c) (Zombie s x -> Zombie t x
forall x. Zombie s x -> Zombie t x
go Zombie s x
xs)
{-# INLINE hoistZombie #-}