code.hs

{-# LANGUAGE RankNTypes, GADTs #-}

module Bidi where

import Control.Monad.Trans

import Data.Machine

data Pipe a' a b' b c where
    Request :: a' -> Pipe a' a b' b a
    Respond :: b  -> Pipe a' a b' b b'

type Proxy a' a b' b m c = MachineT m (Pipe a' a b' b) c

type Effect m a = Proxy () () () () m a

request :: a' -> PlanT (Pipe a' a y' y) o m a
request a = awaits (Request a)

respond :: a -> PlanT (Pipe x' x a' a) o m a'
respond a = awaits (Respond a)

infixl 7 >>~

(>>~) :: Monad m
      => Proxy a' a b' b m r
      -> (b -> Proxy b' b c' c m r)
      -> Proxy a' a c' c m r
pm >>~ fb = MachineT $ runMachineT pm >>= \p ->
    case p of
        Stop                    -> return Stop
        Yield r n               -> return $ Yield r (n >>~ fb)
        Await k (Request a') ff -> return $ Await (\a -> k a >>~ fb) (Request a') (ff >>~ fb)
        Await k (Respond b) _   -> runMachineT (k +>> fb b)

infixr 6 +>>

(+>>) :: Monad m
      => (b' -> Proxy a' a b' b m r)
      -> Proxy b' b c' c m r
      -> Proxy a' a c' c m r
fb' +>> pm = MachineT $ runMachineT pm >>= \p ->
    case p of
        Stop                   -> return Stop
        Yield r n              -> return $ Yield r (fb' +>> n)
        Await k (Request b') _ -> runMachineT (fb' b' >>~ k)
        Await k (Respond c) ff -> return $ Await (\c' -> fb' +>> k c') (Respond c) (fb' +>> ff)

data Req
    = Ping
    | ReadLn String deriving Show

data Resp
    = Started
    | Pong
    | String String deriving Show

server :: Proxy a' a Req Resp IO r
server = construct $ do
    liftIO $ putStrLn "Bootstrapping server..."
    req <- respond Started
    loop req
  where
    loop Ping = do
        liftIO $ putStrLn "Get a Ping"
        respond Pong >>= loop
    loop (ReadLn src) = do
        l <- liftIO $ do
            putStr $ "Read from " ++ src ++ " > "
            getLine
        respond (String l) >>= loop

client :: Proxy Req Resp b' b IO r
client = construct $ do
    Pong <- request Ping
    liftIO $ putStrLn "Receive PONG"
    String s <- request (ReadLn "terminal")
    liftIO $ putStrLn $ "Got message: " ++ s

runEffect_ :: Monad m => Effect m r -> m ()
runEffect_ (MachineT m) = m >>= go
  where
    go Stop        = return ()
    go (Yield _ n) = runMachineT n >>= go
    go _           = error "impossible situation"

app :: IO ()
app = runEffect_ (server >>~ (const client))

output

*Bidi> app
Bootstrapping server...
Get a Ping
Receive PONG
Read from terminal > hello world
Got message: hello world
*Bidi>