-- -- Control.Concurrent.Session :: Session Types for Haskell -- Copyright (C) 2007 Matthew Sackman (matthew@wellquite.org) -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public -- License as published by the Free Software Foundation; either -- version 2.1 of the License, or (at your option) any later version. -- -- This library 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 -- Lesser General Public License for more details. -- -- You should have received a copy of the GNU Lesser General Public -- License along with this library; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, -- MA 02111-1307 USA -- {-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances #-} module Control.Concurrent.Session.Loop where import Control.Concurrent.Session.BaseTypes import Control.Concurrent.Session.BaseClasses import Control.Concurrent.Session.List import Control.Concurrent.Session.State import Control.Concurrent.Session.ExtraClasses import Control.Concurrent.MVar import Control.Concurrent.Chan class ReplaceLoopEnd orig replacement result | orig replacement -> result where replaceLoopEnd :: orig -> replacement -> result instance ReplaceLoopEnd (SessionSpec EndT) (SessionSpec n) (SessionSpec EndT) where replaceLoopEnd EndS r = EndS instance ReplaceLoopEnd (SessionSpec LoopEndT) (SessionSpec n) (SessionSpec n) where replaceLoopEnd LoopEndS r = r instance ReplaceLoopEnd (SessionSpec (LoopT (SessionSpec l))) (SessionSpec replacement) (SessionSpec (LoopT (SessionSpec l))) where replaceLoopEnd (LoopS l) r = (LoopS l) instance (ReplaceLoopEnd (SessionSpec orig) (SessionSpec replacement) (SessionSpec result)) => ReplaceLoopEnd (SessionSpec (SendT t orig)) (SessionSpec replacement) (SessionSpec (SendT t result)) where replaceLoopEnd (SendS t n) r = SendS t (replaceLoopEnd n r) instance (ReplaceLoopEnd (SessionSpec orig) (SessionSpec replacement) (SessionSpec result)) => ReplaceLoopEnd (SessionSpec (RecvT t orig)) (SessionSpec replacement) (SessionSpec (RecvT t result)) where replaceLoopEnd (RecvS t n) r = RecvS t (replaceLoopEnd n r) instance (ReplaceLoopEnd (SessionSpec orig) (SessionSpec replacement) (SessionSpec result)) => ReplaceLoopEnd (SessionSpec (SessT t orig)) (SessionSpec replacement) (SessionSpec (SessT t result)) where replaceLoopEnd = undefined instance (ReplaceLoopEnd (List t list) (SessionSpec replacement) (List t list'), SpecList t list, SpecList t list') => ReplaceLoopEnd (SessionSpec (OfferT (List t list))) (SessionSpec replacement) (SessionSpec (OfferT (List t list'))) where replaceLoopEnd (OfferS list) r = OfferS (replaceLoopEnd list r) instance (ReplaceLoopEnd (List t list) (SessionSpec replacement) (List t list'), SpecList t list, SpecList t list') => ReplaceLoopEnd (SessionSpec (SelectT (List t list))) (SessionSpec replacement) (SessionSpec (SelectT (List t list'))) where replaceLoopEnd (SelectS list) r = SelectS (replaceLoopEnd list r) instance (ReplaceLoopEnd (List t list) (SessionSpec replacement) (List t list'), SpecList t list, SpecList t list') => ReplaceLoopEnd (SessionSpec (SessChoiceT (List t list))) (SessionSpec replacement) (SessionSpec (SessChoiceT (List t list'))) where replaceLoopEnd = undefined instance (ReplaceLoopEnd orig (SessionSpec replacement) result) => ReplaceLoopEnd (List t orig) (SessionSpec replacement) (List t result) where replaceLoopEnd (List t a) r = List t (replaceLoopEnd a r) instance ReplaceLoopEnd (Nil Zero) (SessionSpec replacement) (Nil Zero) where replaceLoopEnd Nil _ = nil instance (ReplaceLoopEnd (SessionSpec ltype) (SessionSpec replacement) (SessionSpec rtype), ReplaceLoopEnd ltail (SessionSpec replacement) rtail, ListLength ltail len, ListLength rtail len) => ReplaceLoopEnd (Cons (SessionSpec ltype) (Succ len) ltail) (SessionSpec replacement) (Cons (SessionSpec rtype) (Succ len) rtail) where replaceLoopEnd lst r = cons (replaceLoopEnd val r) (replaceLoopEnd nxt r) where (val, nxt) = decomposeCons lst instance (ReplaceLoopEnd (SessionSpec l) (SessionSpec (LoopT (SessionSpec l))) (SessionSpec r)) => UnrollLoop (SessionSpec (LoopT (SessionSpec l))) (SessionSpec r) where unroll (LoopS l) = replaceLoopEnd l (LoopS l) -- never quite worked out why this is required... instance (Choice generalType typeIndexes len) => Choice (generalType, a, b, c) typeIndexes len where typeIndexes = undefined -- loop, and we've seen it before. But make sure we can get to End. Magically! instance (BuildReductionList (LoopT (SessionSpec a)) (SessionSpec EndT) (Cons (SessionSpec EndT) (Succ Zero) (Nil Zero))) => BuildReductionList (LoopT (SessionSpec a)) (SessionSpec (LoopT (SessionSpec a))) (Cons (SessionSpec (LoopT (SessionSpec a))) (Succ (Succ Zero)) (Cons (SessionSpec EndT) (Succ Zero) (Nil Zero))) where findReduction lastSeenLoop (LoopS loop) = let endNxt = findReduction (LoopS loop) EndS in cons (LoopS loop) endNxt -- loop, but this one we've not seen before instance forall a b val len nxt lstLoop . (UnrollLoop (SessionSpec (LoopT (SessionSpec a))) (SessionSpec b), ReplaceLoopEnd (SessionSpec a) (SessionSpec (LoopT (SessionSpec a))) (SessionSpec b), BuildReductionList (LoopT (SessionSpec a)) (SessionSpec b) (Cons val len nxt)) => BuildReductionList lstLoop (SessionSpec (LoopT (SessionSpec a))) (Cons val len nxt) where findReduction _ (LoopS lp) = findReduction (undefined :: (LoopT (SessionSpec a))) (unroll (LoopS lp)) instance (JustSendsRecvs (SessionSpec l) (SessionSpec s) (SessionSpec r)) => JustSendsRecvs (SessionSpec (LoopT (SessionSpec l))) (SessionSpec (LoopT (SessionSpec s, SessionSpec r))) (SessionSpec (LoopT (SessionSpec r, SessionSpec s))) mkLoopS :: (SessionSpec LoopEndT -> SessionSpec l) -> SessionSpec (LoopT (SessionSpec l)) mkLoopS x = LoopS (x LoopEndS) mkLoop :: (UnrollLoop (SessionSpec (LoopT (SessionSpec s))) (SessionSpec sUnrolled), UnrollLoop (SessionSpec (LoopT (SessionSpec o))) (SessionSpec oUnrolled), UnrollLoop (SessionSpec (LoopT (SessionSpec i))) (SessionSpec iUnrolled), ReplaceLoopEnd (SessionSpec s) (SessionSpec (LoopT (SessionSpec s))) (SessionSpec sUnrolled), ReplaceLoopEnd (SessionSpec o) (SessionSpec (LoopT (SessionSpec o))) (SessionSpec oUnrolled), ReplaceLoopEnd (SessionSpec i) (SessionSpec (LoopT (SessionSpec i))) (SessionSpec iUnrolled), JustSendsRecvs (SessionSpec s) (SessionSpec o) (SessionSpec i), LoopContinue (SessionState (SessionSpec s') o' i'), JustSendsRecvs (SessionSpec (LoopT (SessionSpec s))) (SessionSpec (LoopT (SessionSpec o, SessionSpec i))) (SessionSpec (LoopT (SessionSpec i, SessionSpec o))) ) => (r -> SessionState (SessionSpec s) o i -> IO (r, SessionState (SessionSpec s') o' i')) -> r -> SessionState (SessionSpec (LoopT (SessionSpec s))) (LoopT (SessionSpec o, SessionSpec i)) (LoopT (SessionSpec i, SessionSpec o)) -> IO ((), (SessionState (SessionSpec EndT) EndT EndT)) mkLoop func arg (SessionState lock outgoing incoming) = do { readersE <- newChan ; writersE <- newChan ; didPutOut <- tryPutMVar outgoing (LoopCell writersE) ; didPutIn <- tryPutMVar incoming (LoopCell readersE) ; writers <- if didPutOut then return writersE else do { (LoopCell w) <- takeMVar outgoing ; return w } ; readers <- if didPutIn then return readersE else do { (LoopCell r) <- takeMVar incoming ; return r } ; doLoop func arg lock readers writers } doLoop :: (JustSendsRecvs (SessionSpec spec) (SessionSpec outgoing) (SessionSpec incoming), LoopContinue (SessionState (SessionSpec spec') outgoing' incoming')) => (r -> SessionState (SessionSpec spec) outgoing incoming -> IO (r, SessionState (SessionSpec spec') outgoing' incoming')) -> r -> MVar () -> Chan (MVar (Cell incoming), MVar (Cell outgoing)) -> Chan (MVar (Cell outgoing), MVar (Cell incoming)) -> IO ((), SessionState (SessionSpec EndT) EndT EndT) doLoop func arg lock readers writers = do { (incoming, outgoing) <- withMVar lock $ \_ -> do { empty <- isEmptyChan readers ; if empty then do { outVar <- newEmptyMVar ; inVar <- newEmptyMVar ; writeChan writers (outVar, inVar) ; return (inVar, outVar) } else readChan readers } ; let state = SessionState lock outgoing incoming ; (arg', deadState) <- func arg state -- agh, this should really use LoopContinue but can't due to issue with return type of offer ; doLoop func arg' lock readers writers } class LoopContinue termState where loopAgain :: (JustSendsRecvs (SessionSpec spec) (SessionSpec outgoing) (SessionSpec incoming), LoopContinue (SessionState (SessionSpec spec') outgoing' incoming')) => termState -> (r -> SessionState (SessionSpec spec) outgoing incoming -> IO (r, SessionState (SessionSpec spec') outgoing' incoming')) -> r -> MVar () -> Chan (MVar (Cell incoming), MVar (Cell outgoing)) -> Chan (MVar (Cell outgoing), MVar (Cell incoming)) -> IO ((), SessionState (SessionSpec EndT) EndT EndT) instance LoopContinue (SessionState (SessionSpec LoopEndT) LoopEndT LoopEndT) where loopAgain = const doLoop instance LoopContinue (SessionState (SessionSpec EndT) EndT EndT) where loopAgain termState func arg _ _ _ = return ((), termState) loopEnd :: r -> (SessionState (SessionSpec LoopEndT) LoopEndT LoopEndT) -> IO (r, (SessionState (SessionSpec LoopEndT) LoopEndT LoopEndT)) loopEnd r state = return (r, state)