{-
    Tests.hs
        Copyright 2008 Matthew Sackman <matthew@wellquite.org>

    This file is part of Session Types for Haskell.

    Session Types for Haskell 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.

    Session Types for Haskell 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 Session Types for Haskell.
    If not, see <http://www.gnu.org/licenses/>.
-}

{-# LANGUAGE NoMonomorphismRestriction #-}

module Control.Concurrent.Session.Tests where

import Control.Concurrent.Session
import Control.Concurrent

import System.IO

sendAndRecvSpec a = cons (Send a ~> Recv a ~> end) nil

testSendAndRecvSimple
    = run (sendAndRecvSpec (undefined::Bool)) (D0 E) p1 p2
      where
        p1 = (sliftIO . print $ "P1 Sending True") ~>>
             ssend True ~>>
             srecv ~>>=
             (sliftIO . print . (++) "P1 Received " . show)
        p2 = srecv ~>>= \v ->
             (sliftIO . print $ "P2 Received " ++ (show v)) ~>>
             (ssend . not $ v)
ssendLog x = (sliftIO . putStrLn $ "Sending " ++ (show x)) ~>>
             ssend x

srecvLog = srecv ~>>= \v ->
           (sliftIO . putStrLn $ "Received " ++ (show v)) ~>>
           sreturn v

sendAndRecvTwiceSpec a = cons (Send a ~> Recv a ~> Send a ~> Recv a ~> end)
                         nil

testSendAndRecvTwicePartial
    = run (sendAndRecvTwiceSpec (undefined::Bool)) (D0 E) p1 p2
      where
        p1 = ssendLog True ~>> srecvLog
        p2 = srecvLog ~>>= (ssendLog . not)

testSendAndRecvTwiceDelayP2
    = run (sendAndRecvTwiceSpec (undefined::Bool)) (D0 E) p1 p2
      where
        p1 = ssendLog True ~>> ssendLog False
        p2 = (sliftIO . threadDelay $ 1000000) ~>>
             srecvLog ~>> srecvLog

testSendAndRecvTwiceDelayMid
    = run (sendAndRecvTwiceSpec (undefined::Bool)) (D0 E) p1 p2
      where
        p1 = ssendLog True ~>>
             (sliftIO . threadDelay $ 1000000) ~>>
             ssendLog False
        p2 = srecvLog ~>> srecvLog

testProperEcho n f
    = run (sendAndRecvSpec (undefined::Int)) (D0 E) p1 p2
      where
        p1 = ssendLog n ~>> srecvLog
        p2 = srecvLog ~>>= ssendLog . f

sendFuncSpec :: (a -> b)
                -> a
                -> b
                -> Cons (Cons (Send (a -> b)) (Cons (Send a) (Cons (Recv b) (Cons End Nil)))) Nil
sendFuncSpec f a b = cons (Send f ~> Send a ~> Recv b ~> end) nil

testSendFunc :: (Show a, Show b) => a -> (a -> b) -> IO (b, ())
testSendFunc v f
    = run (sendFuncSpec (undefined::(a -> b)) (undefined::a) (undefined::b))
      (D0 E) p1 p2
    where
      p1 = ssend f ~>>
           ssendLog v ~>>
           srecvLog
      p2 = srecv ~>>= \f' ->
           srecvLog ~>>=
           ssendLog . f'

calculatorSpec = cons (offer ((D1 E) ~|~ -- add
                              (D2 E) ~|~ -- subtract
                              (D3 E) ~|~ -- multiply
                              (D4 E) ~|~ -- negate
                              (D5 E) ~|~ nil) -- quit
                      ) $
                 cons (RecvInt ~> RecvInt ~> SendInt ~> jump (D0 E)) $
                 cons (RecvInt ~> RecvInt ~> SendInt ~> jump (D0 E)) $
                 cons (RecvInt ~> RecvInt ~> SendInt ~> jump (D0 E)) $
                 cons (RecvInt ~> SendInt ~> jump (D0 E)) $
                 cons end nil

calculatorServer = soffer ( bin (+)
                            ~||~
                            bin (-)
                            ~||~
                            bin (*)
                            ~||~
                            (srecv ~>>=
                             ssend . negate ~>> sjump ~>> calculatorServer)
                            ~||~
                            sreturn ()
                            ~||~
                            OfferImplsNil
                          )
    where
      bin f = (srecv ~>>= \x ->
               srecv ~>>= \y ->
               ssend (f x y) ~>> sjump ~>> calculatorServer)

calculatorClient = sliftIO doMenu ~>>= id
    where
      fetchInt :: IO Int
      fetchInt = do { putStrLn "Enter an Int"
                    ; l <- hGetLine stdin
                    ; return . read $ l
                    }
      doMenu = do { putStrLn "Menu:\n1. Add\n2. Subtract\n3. Multiply\n4. Negate\n5. Quit\nEnter your choice:"
                  ; l <- hGetLine stdin
                  ; case read l of
                      1 -> return $ sselect (D0 E) ~>> two
                      2 -> return $ sselect (D1 E) ~>> two
                      3 -> return $ sselect (D2 E) ~>> two
                      4 -> return $ sselect (D3 E) ~>> one
                      5 -> return $ sselect (D4 E)
                      _ -> doMenu
                  }
      two = sliftIO fetchInt ~>>=
            ssend ~>> one
      one = sliftIO fetchInt ~>>=
            ssend ~>> srecvLog ~>> sjump ~>> sliftIO doMenu ~>>=
            id
                   

testCalculator = run calculatorSpec (D0 E) calculatorServer calculatorClient

testProg = cons (SendBool ~> RecvInt ~> jump (D2 E)) $
           cons (offer ((D0 E) ~|~
                        (D1 E) ~|~
                        (D2 E) ~|~ nil)
                ) $
           cons (jump (D0 E)) $
           nil

simpleTestProg = cons (offer ((D1 E) ~|~
                              (D2 E) ~|~ nil)
                      )$
                 cons (SendBool ~> end) $
                 cons (SendChar ~> end) $
                 nil

simpleTestProg' = cons (offer ((D1 E) ~|~
                               (D2 E) ~|~ nil)
                       )$
                  cons (SendBool ~> jump (D0 E)) $
                  cons (SendChar ~> end) $
                  nil

test = run simpleTestProg' (D0 E) p1 p2
    where p1 = soffer (  (ssend True ~>> sjump ~>> p1)
                        ~||~
                         (ssend 'a' ~>> sreturn "Two")
                        ~||~
                         OfferImplsNil
                       )
          p2 = sselect (D1 E) ~>>
                srecv ~>>=
                 (sliftIO . print)

test2 = run simpleTestProg' (D0 E) p1 p2
    where p1 = soffer ( (ssend True ~>> sjump ~>> p1)
                       ~||~
                        (ssend 'a' ~>> sreturn "Two")
                       ~||~
                        OfferImplsNil
                      )
          p2 = sselect (D0 E) ~>>
                srecv ~>>=
                 (sliftIO . print)

test3 = run simpleTestProg' (D0 E) p1 p2
    where p1 = soffer ( (ssend True ~>> sjump ~>> p1)
                       ~||~
                        (ssend 'a' ~>> sreturn "Two")
                       ~||~
                        OfferImplsNil
                      )
          p2 = sselect (D0 E) ~>>
                srecv ~>>=
                 (sliftIO . print) ~>>
                  sjump ~>> p2

test4 = run simpleTestProg' (D0 E) p1 p2
    where p1 = soffer ( (ssend True ~>> sjump ~>> p1')
                       ~||~
                        (ssend 'a' ~>> sreturn "Two")
                       ~||~
                        OfferImplsNil
                      )
          p1' = soffer ( (ssend False ~>> sjump ~>> p1)
                        ~||~
                         (ssend 'b' ~>> sreturn "Three")
                        ~||~
                         OfferImplsNil
                      )
          p2 = sselect (D0 E) ~>>
                srecv ~>>= \val ->
                 (sliftIO (print val)) ~>> sjump ~>>
                  if val then p2 else p2'
          p2' = sselect (D1 E) ~>>
                 srecv ~>>=
                  (sliftIO . print)