{- Tests.hs Copyright 2008 Matthew Sackman 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 . -} module Control.Concurrent.Session.Tests where import Control.Concurrent.Session import Control.Concurrent import System.IO testMR delay pulse = runInterleaved nil st master where st = cons (Send () ~> jump (D0 E)) $ cons (SendInt ~> end) nil master = fork (D0 E) TT nil (clock pulse) ~>>= \(clkCh, _) -> fork (D1 E) TT nil (child delay) ~>>= \(childCh, _) -> multiReceive ( (clkCh, withChannel clkCh (srecv ~>> sjump) ~>> (sliftIO . print $ "TIMEOUT") ~>> withChannel childCh srecv) ~|||~ (childCh, (sliftIO . print $ "Child") ~>> withChannel childCh srecv) ~|||~ MultiReceiveNil ) clock pulse ch pid = sliftIO (threadDelay pulse) ~>> withChannel ch (ssend () ~>> sjump) ~>> clock pulse ch pid child delay ch pid = sliftIO (threadDelay delay) ~>> withChannel ch (ssend delay) test aDelay bDelay = runInterleaved nil st master where st = cons (SendInt ~> end) nil master = fork (D0 E) TT nil (child aDelay) ~>>= \(aCh, _) -> fork (D0 E) TT nil (child bDelay) ~>>= \(bCh, _) -> multiReceive ( (aCh, receive "A" aCh ~>> receive "B" bCh) ~|||~ (bCh, receive "B" bCh ~>> receive "A" aCh) ~|||~ MultiReceiveNil ) receive str ch = withChannel ch (srecv ~>>= sliftIO . print . (++) ("Master received from child " ++ str ++ ": ") . show) child delay parentCh _ = (sliftIO . threadDelay $ delay) ~>> withChannel parentCh (ssend delay) {- test = runInterleaved (cons ((D1 E), TT) nil) st master where st = cons (sendPid (cons ((D1 E), FF) nil) ~> end) $ cons (SendInt ~> end) nil master = fork (D0 E) TT (cons ((D1 E), FF) nil) child ~>>= \(childCh, childPid) -> withChannel childCh srecv ~>>= \childPid' -> createSession (D1 E) TT childPid' ~>>= \chA -> createSession (D1 E) TT childPid ~>>= \chB -> withChannel chA (srecv ~>>= sliftIO . putStrLn . (++) "Received on chA: " . show) ~>> withChannel chB (srecv ~>>= sliftIO . putStrLn . (++) "Received on chB: " . show) ~>> sreturn () child parentCh parentPid = myPid ~>>= \me -> withChannel parentCh (ssend me) ~>> createSession (D1 E) FF parentPid ~>>= \chA -> createSession (D1 E) FF parentPid ~>>= \chB -> withChannel chA (ssend 10) ~>> withChannel chB (ssend 20) test = runInterleaved nil st master where st = cons (SendInt ~> SendInt ~> RecvBool ~> end) $ cons (SendBool ~> RecvBool ~> end) nil childA parentCh parentPid = (sliftIO . putStrLn $ "ChildA is alive!") ~>> withChannel parentCh srecv ~>>= \x -> withChannel parentCh srecv ~>>= \y -> withChannel parentCh (ssend (x == y)) childB parentCh parentPid = (sliftIO . putStrLn $ "ChildB is alive!") ~>> withChannel parentCh (ssend True ~>> srecv ~>>= sliftIO . putStrLn . (++) "ChildB received a Bool: " . show ) master = fork (D0 E) FF nil childA ~>>= \(aCh, aPid) -> fork (D1 E) TT nil childB ~>>= \(bCh, bPid) -> withChannel aCh (ssend 5) ~>> withChannel bCh srecv ~>>= \boolB -> (if boolB then withChannel aCh (ssend 6 ~>> srecv) else withChannel aCh (ssend 5 ~>> srecv) ) ~>>= \boolA -> withChannel bCh (ssend (boolA && boolB)) ~>> (sliftIO . putStrLn $ "Master has finished. Bye bye.") -} testRealChannels num = do { runInterleaved nil spec master } where spec = cons (sendPid (cons ((D2 E), FF) nil) ~> SendBool ~> end) $ cons (sendPid (cons ((D2 E), TT) nil) ~> end) $ cons (SendStr ~> RecvInt ~> select ((D3 E) ~|~ (D4 E) ~|~ nil)) $ cons (SendInt ~> end) $ cons (sendPid (cons ((D2 E), FF) nil) ~> end) $ nil aSessions = (cons ((D2 E), TT) nil) bSessions = (cons ((D2 E), FF) nil) master = fork (D0 E) FF aSessions childA ~>>= \(aCh, aPid) -> fork (D1 E) FF bSessions childB ~>>= \(bCh, bPid) -> withChannel aCh (ssend bPid) ~>> withChannel bCh (ssend aPid) ~>> sliftIO (threadDelay num) ~>> withChannel aCh (ssend True) ~>> sreturn (aPid, bPid) childA mCh mPid = sliftIO (putStrLn "Child A alive") ~>> withChannel mCh srecv ~>>= \bPid -> createSession (D2 E) TT bPid ~>>= \bCh -> myPid ~>>= \me -> multiReceive ( (bCh, bThenM mCh bCh me) ~|||~ (mCh, mThenB mCh bCh me) ~|||~ MultiReceiveNil ) where mThenB mCh bCh me = (dealWithM mCh) ~>> (dealWithB bCh me) bThenM mCh bCh me = (dealWithB bCh me) ~>> (dealWithM mCh) dealWithM mCh = withChannel mCh srecv ~>>= sliftIO . putStrLn . (++) "Got a bool from master: " . show dealWithB bCh me = withChannel bCh (srecv ~>> ssend num ~>> soffer ( (srecv ~>>= sliftIO . print) ~||~ (srecv ~>>= \them -> sliftIO (if (them =~= me) then putStrLn $ "EQ: " ++ (show them) ++ " " ++ (show me) else putStrLn $ "NEQ: " ++ (show them) ++ " " ++ (show me) ) ) ~||~ OfferImplsNil ) ) childB mCh mPid = sliftIO (putStrLn "Child B alive") ~>> withChannel mCh srecv ~>>= \aPid -> createSession (D2 E) FF aPid ~>>= \aCh -> myPid ~>>= \me -> withChannel aCh (ssend "foo" ~>> srecv) ~>>= \num -> withChannel aCh (if even num then sselect (D0 E) ~>> ssend (2*num) else sselect (D1 E) ~>> ssend me ) calculatorSpec = cons (offer ((D1 E) ~|~ -- add (D1 E) ~|~ -- subtract (D1 E) ~|~ -- multiply (D2 E) ~|~ -- negate (D3 E) ~|~ nil) -- quit ) $ 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 = sjoin (sliftIO doMenu) where doMenu = do { putStrLn "Menu:\n 1. Add\n 2. Subtract\n 3. Multiply\n 4. Negate\n 5. Quit\n Enter 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 } fetchInt :: IO Int fetchInt = do { putStrLn "Enter an Int" ; l <- hGetLine stdin ; return . read $ l } two = sliftIO fetchInt ~>>= ssend ~>> one one = sliftIO fetchInt ~>>= ssend ~>> srecv ~>>= sliftIO . print ~>> sjump ~>> sjoin (sliftIO doMenu) testCalculator = run calculatorSpec (D0 E) calculatorServer calculatorClient