{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE KindSignatures, PatternGuards #-}

-- Sending messages up-and-down the iteratee-enumerator chain
-- An enumerator may tell something to an iteratee in the middle
-- of a stream, or an iteratee may ask something of the iteratee.
-- In fact, an enumerator can always tell an iteratee that EOF 
-- has occurred.
-- Asking for a new chunk is an example of an iteratee request.
-- An exception is another example.
-- A non-trivial example of the communication is enumerator's
-- telling iteratees to flush the buffers, and iteratee's
-- asking for the current position in the stream.
-- The problem of bi-directional communication was posed by
-- David Mazie'res in the message
-- http://www.haskell.org/pipermail/haskell-cafe/2011-May/091810.html

-- The set of messages an enumerator may send and the set of requests
-- an iteratee may ask are both treated as open unions.

-- The present code illustrates the explicit coding of open unions,
-- to let the type checker ensure that what an iteratee may ask
-- an enumerator can answer, and what an enumerator may tell
-- an iteratee can understand.

-- In process calculus lingo, we implement external (to iteratee)
-- choice, internal choice, and a form of session types.

-- The present code implements a greatly simplified version
-- of iteratees. We assume a single-character chunk, which
-- an iteratee always consumes.
-- Chunking of a stream and look-ahead are orthogonal concerns. 
-- We do not entertain them here to emphasize the non-character-related, 
-- `exceptional' communication between enumerators and iteratees.


module UpDown where

-- The stream (external choice)

data Stream ie = 
      Chunk Char		-- the current character
    | SExc ie			-- A message from the enumerator

-- One sort of message from the enumerator
data EOF = EOF

-- Inject into the open sum
instance Sum EOF EOF where
    inj = id
    prj = Just

eof :: Sum EOF ie => Stream ie
eof = SExc . inj $ EOF

-- Another type of message from the enumerator
data Flush = Flush

-- Inject into the open sum
-- the boilerplate is the price of avoiding overlapping instances
instance Sum Flush Flush where
    inj = id
    prj = Just

instance Sum Flush x => Sum Flush (Either EOF x) where
    inj = Right . inj
    prj (Right x) = prj x
    prj _         = Nothing


-- The iteratee: the internal choice

-- Cont is a typical request from an iteratee. In fact, it is so
-- typical that we wire it in (we could've treated it as other requests,
-- like Tell)

-- The iteratee is parameterized by what messages it understands
-- and what requests it may ask
data Iter ee ie a = 
      Done a
    | Cont (Stream ie -> Iter ee ie a)
    | IExc (ee (Iter ee ie) a)		-- other requests

instance Bindable ee => Monad (Iter ee ie) where
    return = Done
    Done a >>= f = f a
    Cont k >>= f = Cont (\x -> k x >>= f)
    IExc ee >>= f = IExc (comp ee f)

-- All requests must be bindable, so they can percolate
class Bindable ee where
    comp :: Monad m => ee m a -> (a -> m b) -> ee m b

-- An exception is a sort of request (especially if the exception
-- is resumable)

data Err m a  = Err (() -> m a)

instance Bindable Err where
    comp (Err k) f = Err (\x -> k x >>= f)

instance Sum2 Err Err where
    inj2 = id
    prj2 = Just


-- A request to tell the position
data Tell m a = Tell (Int -> m a)

instance Bindable Tell where
    comp (Tell k) f = Tell (\x -> k x >>= f)

instance Sum2 Tell Tell where
    inj2 = id
    prj2 = Just

instance Sum2 Tell x => Sum2 Tell (E2 Err x) where
    inj2 = R2 . inj2
    prj2 (R2 x) = prj2 x
    prj2 _      = Nothing



-- ------------------------------------------------------------------------
-- Sample code

-- Iteratees are explicit in what they receive on the stream,
-- the external choices they may handle.
-- But they leave the requests polymorphic to ease composing with
-- other iteratees which may asks more requests

-- The simplest iteratee, which doesn't do anything but asks for trouble
ierr :: Sum2 Err c => Iter c ie a
ierr = IExc . inj2 $ Err (\_ -> ierr)


-- A small iteratee: asks for little and accepts little
-- Return the current element
iehead :: Sum2 Err c => Iter c EOF Char
iehead = Cont step
 where
 step (Chunk a)  = Done a
 step (SExc EOF) = ierr


-- Ask for the current position
itell :: Sum2 Tell c => Iter c ie Int
itell = IExc . inj2 $ Tell Done

-- check to see if the current character is 'a' and it occurs at pos 2 (1-based)
ietell :: (Sum2 Err c, Sum2 Tell c, Bindable c) => Iter c EOF Bool
ietell = Cont step
 where
 step (Chunk 'a') = itell >>= return . (== 2)
 step (Chunk _)   = Done False
 step (SExc EOF)  = ierr


-- Like iehead, but accept the Flush message
ieflush :: Sum2 Err c => Iter c (Either EOF Flush) Char
ieflush = Cont step
 where
 step (Chunk a)  = Done a
 step (SExc x) | Just EOF   <- prj x = ierr
 step (SExc x) | Just Flush <- prj x = ieflush


-- Enumerators and enumeratees
-- Enumerators, in contrast, are explicit in what requests they may
-- satisfy, but implicit in what they may send on the stream.

-- Simple typical enumerator
-- The iteratee must at least accept EOF
-- The iteratee may return Err, but no other requests

en_str :: Sum EOF ie => String -> Iter Err ie x -> Iter Err ie x
en_str _ i@Done{} = i
en_str _ (IExc x) | Just (Err _) <- prj2 x = ierr
en_str "" (Cont k) = k eof
en_str (h:t) (Cont k) = en_str t $ k (Chunk h)

-- A typical enumeratee
-- It keeps the track of positions
-- It is explicit in requests it accepts: only Tell and Err.
-- It is polymorphic in the in-stream messages

en_pos :: Int -> Iter (E2 Err Tell) ie x -> Iter Err ie x
en_pos _ (Done x) = return x
en_pos n (Cont k) = Cont (\s -> en_pos (n+1) (k s))
en_pos _ (IExc x) | Just (Err _)  <- prj2 x = ierr
en_pos n (IExc x) | Just (Tell k) <- prj2 x = en_pos n (k n)


irun :: Sum EOF ie => Iter Err ie x -> x
irun (Done x) = x
irun (Cont k) = irun $ k eof
irun _        = error "Iter error"

-- ------------------------------------------------------------------------
-- Examples

t1 = irun $ en_str "x" iehead
-- "x"

t2 = irun $ en_str "" iehead
-- *** Exception: Iter error

t3 = irun $ en_str "x" ieflush
-- 'x'

-- Here, ihead does not understand flush
-- Since there is no telling when Flush may occur, there is no telling
-- which of the two primitive iteratees in iter may receive it
-- Both must be able to handle Flush then.
{-
tb1 = irun $ en_str "ab" iter
 where
 iter = do
	x <- iehead
	y <- ieflush
	return (x,y)


    Couldn't match expected type `Either EOF Flush'
           against inferred type `EOF'
-}

-- en_str doesn't know how to handle Tell
{-
tb2 = irun $ en_str "x" ietell
    No instance for (Sum2 Tell Err)
-}


t5 = irun $ en_str "xab" $ en_pos 0 $ iter
 where
 iter = do
	x <- iehead
	y <- ietell
	return (x,y)

-- ('x',True)



-- ------------------------------------------------------------------------
-- Encoding of open unions
-- This is a simple version of a dual of HList


-- Sum e c states that 'e' is a member of an open union 'c'
class Sum e c where
    inj :: e -> c
    prj :: c -> Maybe e

instance Sum a (Either a b) where
    inj = Left
    prj (Left x) = Just x
    prj _        = Nothing


-- Haskell is kind, but not too kind

data E2 (x :: (* -> *) -> * -> *) (y :: (* -> *) -> * -> *)  m a 
    = L2 (x m a) | R2 (y m a)

instance (Bindable x, Bindable y) => Bindable (E2 x y) where
    comp (L2 k)  f = L2 (comp k f)
    comp (R2 k) f  = R2 (comp k f)

class Sum2 (e :: (* -> *) -> * -> *) (c :: (* -> *) -> * -> *) where
    inj2 :: e m a -> c m a
    prj2 :: c m a -> Maybe (e m a)

instance Sum2 a (E2 a b) where
    inj2 = L2
    prj2 (L2 x) = Just x
    prj2 _      = Nothing