{- 
    Copyright 2010-2014 Mario Blazevic

    This file is part of the Streaming Component Combinators (SCC) project.

    The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public
    License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later
    version.

    SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty
    of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more details.

    You should have received a copy of the GNU General Public License along with SCC.  If not, see
    <http://www.gnu.org/licenses/>.
-}

-- | A coroutine can choose to launch another coroutine. In this case, the nested coroutines always suspend to their
-- invoker. If a function from this module, such as 'pogoStickNested', is used to run a nested coroutine, the parent
-- coroutine can be automatically suspended as well. A single suspension can thus suspend an entire chain of nested
-- coroutines.
-- 
-- Nestable coroutines of this kind should group their suspension functors into a 'Sum'. A simple coroutine
-- suspension can be converted to a nested one using functions 'mapSuspension' and 'liftAncestor'. To run nested
-- coroutines, use 'pogoStickNested', or 'weave' with a 'NestWeaveStepper'.

{-# LANGUAGE ScopedTypeVariables, Rank2Types, MultiParamTypeClasses, TypeFamilies,
             FlexibleContexts, FlexibleInstances, UndecidableInstances
 #-}

module Control.Monad.Coroutine.Nested
   (
      eitherFunctor, mapNestedSuspension, pogoStickNested,
      NestWeaveStepper,
      ChildFunctor(..), AncestorFunctor(..),
      liftParent, liftAncestor
   )
where

import Control.Monad (liftM)
import Data.Functor.Sum (Sum(InL, InR))

import Control.Monad.Coroutine

-- | Like 'either' for the 'Sum' data type.
eitherFunctor :: (l x -> y) -> (r x -> y) -> Sum l r x -> y
eitherFunctor :: (l x -> y) -> (r x -> y) -> Sum l r x -> y
eitherFunctor l x -> y
left r x -> y
_ (InL l x
f) = l x -> y
left l x
f
eitherFunctor l x -> y
_ r x -> y
right (InR r x
f) = r x -> y
right r x
f

-- | Change the suspension functor of a nested 'Coroutine'.
mapNestedSuspension :: (Functor s0, Functor s, Monad m) => (forall y. s y -> s' y) ->
                       Coroutine (Sum s0 s) m x -> Coroutine (Sum s0 s') m x
mapNestedSuspension :: (forall y. s y -> s' y)
-> Coroutine (Sum s0 s) m x -> Coroutine (Sum s0 s') m x
mapNestedSuspension forall y. s y -> s' y
f Coroutine (Sum s0 s) m x
cort = Coroutine :: forall (s :: * -> *) (m :: * -> *) r.
m (Either (s (Coroutine s m r)) r) -> Coroutine s m r
Coroutine {resume :: m (Either (Sum s0 s' (Coroutine (Sum s0 s') m x)) x)
resume= (Either (Sum s0 s (Coroutine (Sum s0 s) m x)) x
 -> Either (Sum s0 s' (Coroutine (Sum s0 s') m x)) x)
-> m (Either (Sum s0 s (Coroutine (Sum s0 s) m x)) x)
-> m (Either (Sum s0 s' (Coroutine (Sum s0 s') m x)) x)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Either (Sum s0 s (Coroutine (Sum s0 s) m x)) x
-> Either (Sum s0 s' (Coroutine (Sum s0 s') m x)) x
map' (Coroutine (Sum s0 s) m x
-> m (Either (Sum s0 s (Coroutine (Sum s0 s) m x)) x)
forall (s :: * -> *) (m :: * -> *) r.
Coroutine s m r -> m (Either (s (Coroutine s m r)) r)
resume Coroutine (Sum s0 s) m x
cort)}
   where map' :: Either (Sum s0 s (Coroutine (Sum s0 s) m x)) x
-> Either (Sum s0 s' (Coroutine (Sum s0 s') m x)) x
map' (Right x
r) = x -> Either (Sum s0 s' (Coroutine (Sum s0 s') m x)) x
forall a b. b -> Either a b
Right x
r
         map' (Left (InL s0 (Coroutine (Sum s0 s) m x)
s)) = Sum s0 s' (Coroutine (Sum s0 s') m x)
-> Either (Sum s0 s' (Coroutine (Sum s0 s') m x)) x
forall a b. a -> Either a b
Left (s0 (Coroutine (Sum s0 s') m x)
-> Sum s0 s' (Coroutine (Sum s0 s') m x)
forall k (f :: k -> *) (g :: k -> *) (a :: k). f a -> Sum f g a
InL (s0 (Coroutine (Sum s0 s') m x)
 -> Sum s0 s' (Coroutine (Sum s0 s') m x))
-> s0 (Coroutine (Sum s0 s') m x)
-> Sum s0 s' (Coroutine (Sum s0 s') m x)
forall a b. (a -> b) -> a -> b
$ (Coroutine (Sum s0 s) m x -> Coroutine (Sum s0 s') m x)
-> s0 (Coroutine (Sum s0 s) m x) -> s0 (Coroutine (Sum s0 s') m x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall y. s y -> s' y)
-> Coroutine (Sum s0 s) m x -> Coroutine (Sum s0 s') m x
forall (s0 :: * -> *) (s :: * -> *) (m :: * -> *) (s' :: * -> *) x.
(Functor s0, Functor s, Monad m) =>
(forall y. s y -> s' y)
-> Coroutine (Sum s0 s) m x -> Coroutine (Sum s0 s') m x
mapNestedSuspension forall y. s y -> s' y
f) s0 (Coroutine (Sum s0 s) m x)
s)
         map' (Left (InR s (Coroutine (Sum s0 s) m x)
s)) = Sum s0 s' (Coroutine (Sum s0 s') m x)
-> Either (Sum s0 s' (Coroutine (Sum s0 s') m x)) x
forall a b. a -> Either a b
Left (s' (Coroutine (Sum s0 s') m x)
-> Sum s0 s' (Coroutine (Sum s0 s') m x)
forall k (f :: k -> *) (g :: k -> *) (a :: k). g a -> Sum f g a
InR (s (Coroutine (Sum s0 s') m x) -> s' (Coroutine (Sum s0 s') m x)
forall y. s y -> s' y
f (s (Coroutine (Sum s0 s') m x) -> s' (Coroutine (Sum s0 s') m x))
-> s (Coroutine (Sum s0 s') m x) -> s' (Coroutine (Sum s0 s') m x)
forall a b. (a -> b) -> a -> b
$ (Coroutine (Sum s0 s) m x -> Coroutine (Sum s0 s') m x)
-> s (Coroutine (Sum s0 s) m x) -> s (Coroutine (Sum s0 s') m x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall y. s y -> s' y)
-> Coroutine (Sum s0 s) m x -> Coroutine (Sum s0 s') m x
forall (s0 :: * -> *) (s :: * -> *) (m :: * -> *) (s' :: * -> *) x.
(Functor s0, Functor s, Monad m) =>
(forall y. s y -> s' y)
-> Coroutine (Sum s0 s) m x -> Coroutine (Sum s0 s') m x
mapNestedSuspension forall y. s y -> s' y
f) s (Coroutine (Sum s0 s) m x)
s))

-- | Run a nested 'Coroutine' that can suspend both itself and the current 'Coroutine'.
pogoStickNested :: forall s1 s2 m x. (Functor s1, Functor s2, Monad m) => 
                   (s2 (Coroutine (Sum s1 s2) m x) -> Coroutine (Sum s1 s2) m x)
                   -> Coroutine (Sum s1 s2) m x -> Coroutine s1 m x
pogoStickNested :: (s2 (Coroutine (Sum s1 s2) m x) -> Coroutine (Sum s1 s2) m x)
-> Coroutine (Sum s1 s2) m x -> Coroutine s1 m x
pogoStickNested s2 (Coroutine (Sum s1 s2) m x) -> Coroutine (Sum s1 s2) m x
reveal Coroutine (Sum s1 s2) m x
t = 
   Coroutine :: forall (s :: * -> *) (m :: * -> *) r.
m (Either (s (Coroutine s m r)) r) -> Coroutine s m r
Coroutine{resume :: m (Either (s1 (Coroutine s1 m x)) x)
resume= Coroutine (Sum s1 s2) m x
-> m (Either (Sum s1 s2 (Coroutine (Sum s1 s2) m x)) x)
forall (s :: * -> *) (m :: * -> *) r.
Coroutine s m r -> m (Either (s (Coroutine s m r)) r)
resume Coroutine (Sum s1 s2) m x
t
                      m (Either (Sum s1 s2 (Coroutine (Sum s1 s2) m x)) x)
-> (Either (Sum s1 s2 (Coroutine (Sum s1 s2) m x)) x
    -> m (Either (s1 (Coroutine s1 m x)) x))
-> m (Either (s1 (Coroutine s1 m x)) x)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Either (Sum s1 s2 (Coroutine (Sum s1 s2) m x)) x
s-> case Either (Sum s1 s2 (Coroutine (Sum s1 s2) m x)) x
s
                               of Right x
result -> Either (s1 (Coroutine s1 m x)) x
-> m (Either (s1 (Coroutine s1 m x)) x)
forall (m :: * -> *) a. Monad m => a -> m a
return (x -> Either (s1 (Coroutine s1 m x)) x
forall a b. b -> Either a b
Right x
result)
                                  Left (InL s1 (Coroutine (Sum s1 s2) m x)
s') -> Either (s1 (Coroutine s1 m x)) x
-> m (Either (s1 (Coroutine s1 m x)) x)
forall (m :: * -> *) a. Monad m => a -> m a
return (s1 (Coroutine s1 m x) -> Either (s1 (Coroutine s1 m x)) x
forall a b. a -> Either a b
Left ((Coroutine (Sum s1 s2) m x -> Coroutine s1 m x)
-> s1 (Coroutine (Sum s1 s2) m x) -> s1 (Coroutine s1 m x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((s2 (Coroutine (Sum s1 s2) m x) -> Coroutine (Sum s1 s2) m x)
-> Coroutine (Sum s1 s2) m x -> Coroutine s1 m x
forall (s1 :: * -> *) (s2 :: * -> *) (m :: * -> *) x.
(Functor s1, Functor s2, Monad m) =>
(s2 (Coroutine (Sum s1 s2) m x) -> Coroutine (Sum s1 s2) m x)
-> Coroutine (Sum s1 s2) m x -> Coroutine s1 m x
pogoStickNested s2 (Coroutine (Sum s1 s2) m x) -> Coroutine (Sum s1 s2) m x
reveal) s1 (Coroutine (Sum s1 s2) m x)
s'))
                                  Left (InR s2 (Coroutine (Sum s1 s2) m x)
c) -> Coroutine s1 m x -> m (Either (s1 (Coroutine s1 m x)) x)
forall (s :: * -> *) (m :: * -> *) r.
Coroutine s m r -> m (Either (s (Coroutine s m r)) r)
resume ((s2 (Coroutine (Sum s1 s2) m x) -> Coroutine (Sum s1 s2) m x)
-> Coroutine (Sum s1 s2) m x -> Coroutine s1 m x
forall (s1 :: * -> *) (s2 :: * -> *) (m :: * -> *) x.
(Functor s1, Functor s2, Monad m) =>
(s2 (Coroutine (Sum s1 s2) m x) -> Coroutine (Sum s1 s2) m x)
-> Coroutine (Sum s1 s2) m x -> Coroutine s1 m x
pogoStickNested s2 (Coroutine (Sum s1 s2) m x) -> Coroutine (Sum s1 s2) m x
reveal (s2 (Coroutine (Sum s1 s2) m x) -> Coroutine (Sum s1 s2) m x
reveal s2 (Coroutine (Sum s1 s2) m x)
c))}

-- | Type of functions capable of combining two child coroutines' 'CoroutineStepResult' values into a parent coroutine.
-- Use with the function 'weave'.
type NestWeaveStepper s0 s1 s2 m x y z = WeaveStepper (Sum s0 s1) (Sum s0 s2) s0 m x y z

-- | Class of functors that can contain another functor.
class Functor c => ChildFunctor c where
   type Parent c :: * -> *
   wrap :: Parent c x -> c x
instance (Functor p, Functor s) => ChildFunctor (Sum p s) where
   type Parent (Sum p s) = p
   wrap :: Parent (Sum p s) x -> Sum p s x
wrap = Parent (Sum p s) x -> Sum p s x
forall k (f :: k -> *) (g :: k -> *) (a :: k). f a -> Sum f g a
InL

-- | Class of functors that can be lifted.
class (Functor a, Functor d) => AncestorFunctor a d where
   -- | Convert the ancestor functor into its descendant. The descendant functor typically contains the ancestor.
   liftFunctor :: a x -> d x
instance {-# OVERLAPPING #-} Functor a => AncestorFunctor a a where
   liftFunctor :: a x -> a x
liftFunctor = a x -> a x
forall a. a -> a
id
instance {-# OVERLAPPABLE #-} (Functor a, ChildFunctor d, d' ~ Parent d, AncestorFunctor a d') => AncestorFunctor a d where
   liftFunctor :: a x -> d x
liftFunctor = d' x -> d x
forall (c :: * -> *) x. ChildFunctor c => Parent c x -> c x
wrap (d' x -> d x) -> (a x -> d' x) -> a x -> d x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x. a x -> d' x
forall (a :: * -> *) (d :: * -> *) x.
AncestorFunctor a d =>
a x -> d x
liftFunctor :: a x -> d' x)

-- | Converts a coroutine into a child nested coroutine.
liftParent :: forall m p c x. (Monad m, Functor p, ChildFunctor c, p ~ Parent c) => Coroutine p m x -> Coroutine c m x
liftParent :: Coroutine p m x -> Coroutine c m x
liftParent = (forall y. p y -> c y) -> Coroutine p m x -> Coroutine c m x
forall (s :: * -> *) (m :: * -> *) (s' :: * -> *) x.
(Functor s, Monad m) =>
(forall y. s y -> s' y) -> Coroutine s m x -> Coroutine s' m x
mapSuspension forall y. p y -> c y
forall (c :: * -> *) x. ChildFunctor c => Parent c x -> c x
wrap
{-# INLINE liftParent #-}

-- | Converts a coroutine into a descendant nested coroutine.
liftAncestor :: forall m a d x. (Monad m, Functor a, AncestorFunctor a d) => Coroutine a m x -> Coroutine d m x
liftAncestor :: Coroutine a m x -> Coroutine d m x
liftAncestor = (forall y. a y -> d y) -> Coroutine a m x -> Coroutine d m x
forall (s :: * -> *) (m :: * -> *) (s' :: * -> *) x.
(Functor s, Monad m) =>
(forall y. s y -> s' y) -> Coroutine s m x -> Coroutine s' m x
mapSuspension forall y. a y -> d y
forall (a :: * -> *) (d :: * -> *) x.
AncestorFunctor a d =>
a x -> d x
liftFunctor
{-# INLINE liftAncestor #-}