Nested.hs

{- 
    Copyright 2010-2012 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 an 'EitherFunctor'. 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, OverlappingInstances, UndecidableInstances
 #-}

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

import Control.Monad (liftM)
import Control.Monad.Coroutine

-- | Combines two alternative functors into one, applying one or the other. Used for nested coroutines.
data EitherFunctor l r x = LeftF (l x) | RightF (r x)
instance (Functor l, Functor r) => Functor (EitherFunctor l r) where
   fmap f (LeftF l) = LeftF (fmap f l)
   fmap f (RightF r) = RightF (fmap f r)

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

-- | Change the suspension functor of a nested 'Coroutine'.
mapNestedSuspension :: (Functor s0, Functor s, Monad m) => (forall y. s y -> s' y) ->
                       Coroutine (EitherFunctor s0 s) m x -> Coroutine (EitherFunctor s0 s') m x
mapNestedSuspension f cort = Coroutine {resume= liftM map' (resume cort)}
   where map' (Right r) = Right r
         map' (Left (LeftF s)) = Left (LeftF $ fmap (mapNestedSuspension f) s)
         map' (Left (RightF s)) = Left (RightF (f $ fmap (mapNestedSuspension f) 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 (EitherFunctor s1 s2) m x) -> Coroutine (EitherFunctor s1 s2) m x)
                   -> Coroutine (EitherFunctor s1 s2) m x -> Coroutine s1 m x
pogoStickNested reveal t = 
   Coroutine{resume= resume t
                      >>= \s-> case s
                               of Right result -> return (Right result)
                                  Left (LeftF s') -> return (Left (fmap (pogoStickNested reveal) s'))
                                  Left (RightF c) -> resume (pogoStickNested reveal (reveal 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 (EitherFunctor s0 s1) (EitherFunctor 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 (EitherFunctor p s) where
   type Parent (EitherFunctor p s) = p
   wrap = LeftF

-- | 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 Functor a => AncestorFunctor a a where
   liftFunctor = id
instance (Functor a, ChildFunctor d, d' ~ Parent d, AncestorFunctor a d') => AncestorFunctor a d where
   liftFunctor = wrap . (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 = mapSuspension 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 = mapSuspension liftFunctor
{-# INLINE liftAncestor #-}