{- 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 testRealChannels num = do { runInterleaved nil spec master } where spec = cons (sendPid (cons ((D2 E), FF) nil) ~> end) $ cons (sendPid (cons ((D2 E), TT) nil) ~> end) $ cons (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) ~>> sreturn (aPid, bPid) childA mCh mPid = sliftIO (putStrLn "Child A alive") ~>> withChannel mCh srecv ~>>= \bPid -> createSession (D2 E) TT bPid ~>>= \bCh -> myPid ~>>= \me -> withChannel bCh (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 (srecv) ~>>= \num -> withChannel aCh (if even num then sselect (D0 E) ~>> ssend (2*num) else sselect (D1 E) ~>> ssend me ) {- sendSpec a = cons (Send a ~> end) nil sendAndRecvSpec a = cons (Send a ~> Recv a ~> end) nil -- p1 creates p2. p2 creates p3. p1 sends a value to p2, p2 sends a -- value to p3. p3 sends a value to p2, p2 sends a value to p1. p1 prints. -- p1 sends 5 to p2. p2 sends 5 + 1 to p3. p3 sends (5+1+2) to p2. p2 -- sends (5+1+2)*2 to p1. testTriple = do { runInterleaved emptyMap p1 } where p1 = createChannel (sendAndRecvSpec (undefined::Int)) (D0 E) emptyMap p2 ~>>= \(p2ch, p2pid) -> withChannel p2ch (ssend 5 ~>> srecv ~>>= sliftIO . print) p2 p1ch p1pid = createChannel (sendAndRecvSpec (undefined::Int)) (D0 E) emptyMap p3 ~>>= \(p3ch, p3pid) -> withChannel p1ch srecv ~>>= \v -> withChannel p3ch (ssend (v + 1) ~>> srecv) ~>>= \v' -> withChannel p1ch (ssend (v' * 2)) p3 p2ch p2pid = withChannel p2ch (srecv ~>>= ssend . (+2)) 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 :: (Show t) => t -> SessionChain p p' (Cons (Send t) nxt, Cons t nxt', incoming) (nxt, nxt', incoming) () ssendLog x = (sliftIO . putStrLn $ "Sending " ++ (show x)) ~>> ssend x -- the \v here without a type sig is the reason for the NoMonomorphismRestriction srecvLog :: (Show t) => SessionChain p p' (Cons (Recv t) nxt, outgoing, Cons t nxt') (nxt, outgoing, nxt') t 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 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 } fetchInt :: IO Int fetchInt = do { putStrLn "Enter an Int" ; l <- hGetLine stdin ; return . read $ l } two = sliftIO fetchInt ~>>= ssend ~>> one one = sliftIO fetchInt ~>>= ssend ~>> srecvLog ~>> sjump ~>> sliftIO doMenu ~>>= id testCalculator = run calculatorSpec (D0 E) calculatorServer calculatorClient simpleSpec = cons (offer ((D1 E) ~|~ (D2 E) ~|~ nil) )$ cons (SendBool ~> jump (D0 E)) $ cons (SendChar ~> end) $ nil -- select the branch 1 - i.e. sendChar and then exit test = run simpleSpec (D0 E) p1 p2 where p1 = soffer ( (ssend True ~>> sjump ~>> p1) ~||~ (ssend 'a' ~>> sreturn "Two") ~||~ OfferImplsNil ) p2 = sselect (D1 E) ~>> srecv ~>>= (sliftIO . print) -- select the branch 0 - i.e. sendBool but then p2 stops whilst p1 -- will go back round test2 = run simpleSpec (D0 E) p1 p2 where p1 = soffer ( (ssend True ~>> sjump ~>> p1) ~||~ (ssend 'a' ~>> sreturn "Two") ~||~ OfferImplsNil ) p2 = sselect (D0 E) ~>> srecv ~>>= (sliftIO . print) -- as for test2, but p2 now loops back round too, so infinite loop test3 = run simpleSpec (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 -- a slightly more complex example where p1 will send True and then -- head to p1', where it'll send False which will force p2 to p2' and -- p1' will go to p1. Then p2 chooses the 2nd branch, causing the loop -- to exit in both parties. test4 = run simpleSpec (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) -}