objpipe.hs

{-# Language GADTs #-}
{-# Language RankNTypes #-}
{-# Language TypeOperators #-}
{-# Language GeneralizedNewtypeDeriving #-}
{-# Language MultiParamTypeClasses #-}
{-# Language FlexibleInstances #-}
{-# Language LambdaCase #-}

module
    Main
where

import Control.Object
import Control.Applicative
import Control.Monad (forever, liftM)
import Control.Monad.Trans.Class
import Control.Monad.Error.Class
import Control.Monad.Trans.Either
import Control.Monad.Trans.State
import Debug.Trace
import qualified Data.Foldable as Fd


instance
    MonadTrans (Mortal f)
  where
    lift mx = mortal $ \_ -> lift mx >>= left

yield ::
    Monad m =>
    b ->
    Mortal (PushPull b' b) m ()
yield x = mortal $ \case
    Push _ r -> right (r, yield x)
    Pull f -> right (f x, return ())

each ::
    (Monad m, Fd.Foldable f) =>
    f a ->
    Mortal (PushPull a' a) m ()
each = Fd.mapM_ yield
              



for ::
    Monad m =>
    Mortal (PushPull b' b) m a' ->
    (b -> Mortal (PushPull c' c) m b') ->
    Mortal (PushPull c' c) m a'

for p0 body = mortal (forHead p0 body)


forHead ::
    Monad m =>
    Mortal (PushPull b' b) m a' ->
    (b -> Mortal (PushPull c' c) m b') ->
    PushPull c' c t ->
    EitherT a' m (t, Mortal (PushPull c' c) m a')
forHead p body fx =
  do
    (x, p') <- EitherT $ runMortal p (Pull id) -- may throw a'
    forBody (body x) p' body fx

forBody ::
    Monad m =>
    Mortal (PushPull c' c) m b' ->
    Mortal (PushPull b' b) m a' ->
    (b -> Mortal (PushPull c' c) m b') ->
    PushPull c' c t ->
    EitherT a' m (t, Mortal (PushPull c' c) m a')
forBody b dp body fx =
    lift (runMortal b fx) >>= \case
        Right (x, b') ->
            return (x, mortal $ forBody b' dp body)
        Left req ->
          do
            ((), p') <- EitherT $ runMortal dp (Push req ()) -- may throw a'
            forHead p' body fx


type GProxy s t m r =
    Mortal s (Mortal t m) r

type Proxy a' a b' b m r =
    GProxy (PushPull b' b) (PushPull a a') m r

await ::
    Monad m =>
    GProxy f (PushPull a ()) m a
await = lift awaitImpl
  where
    awaitImpl = mortal $ \case
        Push x r -> right (r, return x)
        Pull f -> right (f (), awaitImpl)

(+>>) ::
    (Monad m, Monad (t m), MonadTrans t) =>
    (b' -> Mortal (PushPull b' b) (t m) r) ->
    GProxy s (PushPull b b') m r ->
    Mortal s (t m) r
fm1i +>> m2i = mortal $ \sx ->
  do
    ret <- lift $ lift $ runMortal (runMortal m2i sx) (Pull id)
    handleRet fm1i ret
  where
    handleRet ::
        (Monad m, Monad (t m), MonadTrans t) =>
        (b' -> Mortal (PushPull b' b) (t m) r)
                   -> Either
                        (Either r (t0, GProxy s (PushPull b b') m r))
                        (b',
                         Mortal
                           (PushPull b b') m (Either r (t0, GProxy s (PushPull b b') m r)))
                   -> EitherT r (t m) (t0, Mortal s (t m) r)

    handleRet _ (Left (Left r)) =
      do
        left r
             
    handleRet fm1 (Left (Right (x, m2'))) =
      do
        return (x, fm1 +>> m2')
               
    handleRet fm1 (Right (b', awaiting)) =
      do
        (b, m1') <- EitherT $ runMortal (fm1 b') (Pull id)
    ret2 <- lift $ lift $ runMortal awaiting (Push b b')
    handleRet2 (pack m1' b) ret2

    handleRet2 ::
        (Monad m, Monad (t m), MonadTrans t) =>
                       (b' -> Mortal (PushPull b' b) (t m) r)
                    -> Either
                         (Either r (t0, GProxy s (PushPull b b') m r))
                         (b',
                          Mortal
                            (PushPull b b') m (Either r (t0, GProxy s (PushPull b b') m r)))
                    -> EitherT r (t m) (t0, Mortal s (t m) r)
    handleRet2 _ (Left (Left r)) =
      do
        left r
             
    handleRet2 fm1 (Left (Right (x, m2'))) =
      do
        return (x, fm1 +>> m2')

    handleRet2 fm1 (Right (_, awaiting)) =
      do
    ret2 <- lift $ lift $ runMortal awaiting (Pull id)
    handleRet fm1 ret2
    
    pack ::
        Monad m =>
        Mortal (PushPull b' b) m r ->
        b ->
    b' -> Mortal (PushPull b' b) m r
    pack mt dm x = mortal $ \fx ->
      do
        (_, mt') <- EitherT $ runMortal mt (Push x dm)
    EitherT $ runMortal mt' fx


(>->) ::
    (Monad m, Monad (t m), MonadTrans t) =>
    Mortal (PushPull () b) (t m) r ->
    GProxy s (PushPull b ()) m r ->
    Mortal s (t m) r
{-
    Monad m =>
    Proxy a' a () b m r ->
    Proxy () b c' c m r ->
    Proxy a' a c' c m r->
-}
p1 >-> p2 = (\() -> p1) +>> p2


{-
(>~) ::
    Monad m =>
    GProxy (Request a a') t m b    ->
    GProxy (Request b ()) t m c    ->
    GProxy (Request a a') t m c    
draw >~ p = mortal $ \fx ->
    lift (runMortal draw fx) >>= \case
        Right (x, draw') ->
            return (x, draw' >~ p)
        Left b ->
          do
            ((), p') <- EitherT $ runMortal p (Upper $ Request b (const ()))
            EitherT $ runMortal (draw >~ p') fx
-}


-- Stab
runEffect ::
    Monad m =>
    Proxy a' a () b m c -> m c
runEffect dg =
    eitherT return undefined $
        EitherT $
            runMortal (
                eitherT return undefined $
                    EitherT $
                        runMortal (dg >-> forever await) $ Pull (const ())) $ Pull (const ())
                                  
main =
  do
    let
        doSomething x =
          do
            lift $ lift $ putStrLn (">>" ++ x)
            yield (x++"a")
            yield (x++"b")
            lift $ lift $ putStrLn "<<"
    runEffect $
        each ["1", "2", "3"] `for` doSomething `for` (lift . lift . putStrLn)
    let
        somePipe =
          do
            lift $ lift $ putStrLn "*"
    runEffect $
        each ["1", "2", "3"] >-> somePipe

    putStrLn "----"

    let
        somePipe =
          do
            trace "a1" $ await
            return ()
    runEffect $
        each ["1", "2", "3"] >-> somePipe

    putStrLn "----"
    let
        somePipe =
          do
            x <- trace "a2" $ await
            lift $ lift $ putStrLn x
    runEffect $
        each ["1", "2", "3"] >-> somePipe
    putStrLn "----"
    let
        somePipe =
          do
            yield "yield"
            lift $ lift $ putStrLn "yielded"
    runEffect $
        each ["1", "2", "3"] >-> somePipe
    putStrLn "----"
    let
        provider =
          do
            lift $ lift $ putStrLn ">"
            yield "1"
            lift $ lift $ putStrLn "->"
            yield "2"
            lift $ lift $ putStrLn "-->"
        somePipe =
          do
            x <- await
            yield (x ++ "-")
            lift $ lift $ putStrLn x
            x <- await
            yield (x ++ "--")
            yield (x ++ "---")
            lift $ lift $ putStrLn x
    runEffect $
        (provider >-> somePipe) `for` (lift . lift . putStrLn)