{-# OPTIONS -fglasgow-exts #-}
-- By Jesse Tov (ccs.neu.edu!tov), November 2007
-- This is a DRAFT.  Later versions at http://www.ccs.neu.edu/home/tov/.
module Demo where

import GHC.Exts
import Control.Monad.Trans
import Control.Concurrent (forkIO)

import Linear
import Session

import CMLChan

newtype IOChan = IOChan { unIOChan :: CMLChan Int }

instance Channel IO IOChan where
  untyped_new = fmap IOChan newCMLChan
  untyped_send c v = writeCMLChan (unsafeCoerce# (unIOChan c)) v
  untyped_recv = readCMLChan . unsafeCoerce# . unIOChan
  untyped_close _ = return ()

newIOSpec :: IO (Spec x IOChan)
newIOSpec  = newSpec

-- A simple explicit protocol:
simple :: IO (Either Int String)
simple = do
  spec <- newSpec :: IO (Spec ((Snd Int:+:Snd String) :->: End) IOChan)
  forkIO . runLinearT $
    accept spec >>>= \cc ->
    sel1 cc >>>
    send cc 5 >>>
    close cc >>>
    unitL ()
  runLinearT $
    request spec >>>= \cc ->
    cases cc >>>
    eitherL (recv cc >>>= unitL . Left)
            (recv cc >>>= unitL . Right) >>>= \v ->
    close cc >>>
    unitL v

-- The protocol inferred is:
--   (Num a, Show a) => (Snd a :+: Snd String) :->:
--                      Rcv (Either a String) :->:
--                      Snd (Either a String)
inferred n = do
  spec <- newIOSpec
  forkIO . runLinearT $
    accept spec >>>= \cc ->
    (if n < 10 then
       with_sel1 cc (send cc n)
     else
       with_sel2 cc (send cc (show n))) >>>
    recv cc >>>=
    send cc >>>
    close cc
  runLinearT $
    request spec >>>= \cc ->
    with_cases cc 
      (recv cc >>>= unitL . Left)
      (recv cc >>>= unitL . Right) >>>=
    send cc >>>
    recv cc >>>= \v ->
    close cc >>>
    unitL v

-- Here we implement a protocol for "cat", which copies a sequence of
-- strings.

newCatSpec :: IO (Spec (Follow (Rcv String) :->: End) IOChan)
newCatSpec  = newSpec

copy :: IO ()
copy = do
  spec <- newCatSpec
  forkIO . runLinearT $
    request spec   >>>= \cc ->
    readLines cc   >>>
    close cc
  runLinearT $
    accept spec    >>>= \cc ->
    writeLines cc  >>>
    close cc

readLines cc =
  unroll cc >>>
  io maybeGetLine >>>= \ms ->
  case ms of
    Nothing   -> sel2 cc
    Just ":q" -> sel2 cc
    Just s    -> sel1 cc >>> send cc s >>> readLines cc

maybeGetLine = catch (fmap Just getLine) (const $ return Nothing)

writeLines cc =
  rollun cc >>>
  cases cc >>>
  eitherL (recv cc >>>= io . putStrLn >>> writeLines cc)
          (unitL ())


-- We can't infer types with Repeat and Follow yet.
{-
readLines' cc =
  with_repeat cc () $ \() ->
    io maybeGetLine >>>= \ms ->
    unitL $ case ms of
      Nothing -> Right ()
      Just s  -> Left (send cc s)

writeLines' cc =
  with_follow cc () $ \() ->
    recv cc >>>= io . putStrLn

copy' :: IO ()
copy' = do
  spec <- newIOSpec :: IO (Spec (Repeat (Snd String) :->: End) IOChan)
  forkIO . runLinearT $
    accept spec >>>= \cc ->
    readLines' cc >>>
    close cc
  runLinearT $
    request spec >>>= \cc ->
    writeLines' cc >>>
    close cc
    -}