{-# LANGUAGE KindSignatures
, ScopedTypeVariables
, GADTs
, MultiParamTypeClasses
, FunctionalDependencies
, UndecidableInstances
, FlexibleInstances
, FlexibleContexts
, TypeFamilies
, PatternSignatures #-}{-
Runtime.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/>.
-}-- | Having actually described a session type, you'll now want to-- implement it! Use the methods of 'SMonad' to chain functions-- together.moduleControl.Concurrent.Session.Runtime(OfferImpls(OfferImplsNil),(~||~),SessionState(..),SessionChain(..),sjump,ssend,srecv,soffer,sselect,run,ProgramToMVarsOutgoing(..),ProgramCell(),Cell())whereimportControl.Concurrent.Session.BoolimportControl.Concurrent.Session.ListimportControl.Concurrent.Session.SessionTypeimportControl.Concurrent.Session.NumberimportControl.Concurrent.Session.SMonadimportControl.Concurrent-- | Use OfferImpls to construct the implementations of the branches-- of an offer. Really, it's just a slightly fancy list.dataOfferImpls::*->*->*->*->*->*whereOfferImplsNil::OfferImplsNilprogprog'finalStatefinalResultOfferCons::(SessionChainprogprog'(Cons(Jumpl)Nil,Cons(Jumpl)Nil,Cons(Jumpl)Nil)finalStatefinalResult)->OfferImplsjumpsprogprog'finalStatefinalResult->OfferImpls(Cons(Cons(Jumpl)Nil)jumps)progprog'finalStatefinalResult-- | Use to construct OfferImpls. This function automatically adds the-- necessary 'sjump' to the start of each branch implementation.(~||~)::forallprogprog'progOutprogInoutgoingincomingfinalStatefinalResultjumpslcurrentcurrentUX.((ProgramToMVarsOutgoingTprogprog)~progOut,(ProgramToMVarsOutgoingTprog'prog')~progIn,ProgramToMVarsOutgoingprogprogprogOut,ProgramToMVarsOutgoingprog'prog'progIn,SWellFormedConfigl(D0E)prog,SWellFormedConfigl(D0E)prog',TyListIndexprogOutl(MVar(ProgramCell(Celloutgoing))),TyListIndexprogInl(MVar(ProgramCell(Cellincoming))),TyListIndexproglcurrentUX,ExpandPidsprogcurrentUXcurrent)=>(SessionChainprogprog'(current,outgoing,incoming)finalStatefinalResult)->(OfferImplsjumpsprogprog'finalStatefinalResult)->(OfferImpls(Cons(Cons(Jumpl)Nil)jumps)progprog'finalStatefinalResult)(~||~)chainnxt=OfferConschain'nxtwherechain'::SessionChainprogprog'((Cons(Jumpl)Nil),(Cons(Jumpl)Nil),(Cons(Jumpl)Nil))finalStatefinalResultchain'=sjump~>>chaininfixr5~||~classWalkOfferImplsprogprog'finalStatefinalResultwherewalkOfferImpls::Int->OfferImplsjumpsprogprog'finalStatefinalResult->SessionChainprogprog'fromfinalStatefinalResultinstanceforallprogprog'finalStatefinalResult.WalkOfferImplsprogprog'finalStatefinalResultwherewalkOfferImpls0(OfferConschain_)=SessionChainfwheref::forallfrom.SessionStateprogprog'from->IO(finalResult,SessionStateprogprog'finalState)f(SessionStateprogprog'outgoingProgincomingProg_outNotify_inNotify_)=runSessionChainchain(SessionStateprogprog'outgoingProgincomingProgundefinedoutNotifyundefinedinNotifyundefined)walkOfferImplsn(OfferCons_rest)=walkOfferImpls(n-1)restwalkOfferImpls__=error"The Truly Impossible Happened."dataCell::*->*whereCell::val->MVar(Cellnxt)->Cell(Consvalnxt)SelectCell::Int->Cell(Cons(Choicejumps)Nil)dataProgramCell::*->*whereProgramCell::MVara->MVar(ProgramCella)->ProgramCellaclassProgramToMVarsOutgoingprogRefprogmvars|progRefprog->mvarswheretypeProgramToMVarsOutgoingTprogRefprogprogramToMVarsOutgoing::progRef->prog->IOmvarsinstanceProgramToMVarsOutgoingrefNilNilwheretypeProgramToMVarsOutgoingTrefNil=NilprogramToMVarsOutgoing_p=returnpinstance(ProgramToMVarsOutgoingrefnxtnxt',TyListnxt,TyListnxt')=>ProgramToMVarsOutgoingref(Consvalnxt)(Cons(MVar(ProgramCell(Cellval')))nxt')wheretypeProgramToMVarsOutgoingTref(Consvalnxt)=(Cons(MVar(ProgramCell(Cell(Outgoingrefval))))(ProgramToMVarsOutgoingTrefnxt))programToMVarsOutgoingrefv=do{hole<-newEmptyMVar;rest<-programToMVarsOutgoingrefnxt;return$consholerest}wherenxt=tyTailvdataSessionState::*->*->*->*whereSessionState::((ProgramToMVarsOutgoingTprogprog)~progOut,(ProgramToMVarsOutgoingTprog'prog')~progIn)=>prog->prog'->progOut->progIn->current->MVar(Maybe(Chan()))->(MVar(CellcurrentOutgoing))->MVar(Maybe(Chan()))->(MVar(CellcurrentIncoming))->SessionStateprogprog'(current,currentOutgoing,currentIncoming)-- | The representation of a computation that performs work using-- session types. Again, really quite similar to a more-parameterized-- State monad.newtypeSessionChainprogprog'fromtores=SessionChain{runSessionChain::(SessionStateprogprog'from)->IO(res,SessionStateprogprog'to)}instanceSMonad(SessionChainprogprog')wheref~>>g=SessionChain$\x->do{(_,y)<-runSessionChainfx;runSessionChaingy}f~>>=g=SessionChain$\x->do{(a,y)<-runSessionChainfx;runSessionChain(ga)y}sreturna=SessionChain$\x->return(a,x)instanceSMonadIO(SessionChainprogprog')wheresliftIOf=SessionChain$\x->do{a<-f;return(a,x)}carefullySwapToNextCell::MVar(ProgramCella)->IO(ProgramCella)carefullySwapToNextCellprogramCellMVar=do{maybeProgramCell<-tryTakeMVarprogramCellMVar;casemaybeProgramCellof-- if it's already full then no one else will grab it but us, so safe-- if it's empty, then must be careful, as could fill up in mean timeNothing->do{emptyProgramCell<-newEmptyMVar;emptyProgramCellMVar<-newEmptyMVar;letcell=(ProgramCellemptyProgramCellemptyProgramCellMVar);didPut<-tryPutMVarprogramCellMVarcell;ifdidPutthenreturncellelsetakeMVarprogramCellMVar}(Justcell)->returncell}-- | Perform a jump. Now you may think that you should indicate where-- you want to jump to. But of course, that's actually specified by-- the session type so you don't have to specify it at all in the-- implementation.sjump::foralllprogprog'progOutprogInoutgoingincomingcurrentcurrentUX.((ProgramToMVarsOutgoingTprogprog)~progOut,(ProgramToMVarsOutgoingTprog'prog')~progIn,ProgramToMVarsOutgoingprogprogprogOut,ProgramToMVarsOutgoingprog'prog'progIn,SWellFormedConfigl(D0E)prog,SWellFormedConfigl(D0E)prog',TyListIndexprogOutl(MVar(ProgramCell(Celloutgoing))),TyListIndexprogInl(MVar(ProgramCell(Cellincoming))),TyListIndexproglcurrentUX,ExpandPidsprogcurrentUXcurrent)=>(SessionChainprogprog')((Cons(Jumpl)Nil),(Cons(Jumpl)Nil),(Cons(Jumpl)Nil))(current,outgoing,incoming)()sjump=SessionChainfwheref::SessionStateprogprog'(Cons(Jumpl)Nil,(Cons(Jumpl)Nil),(Cons(Jumpl)Nil))->IO((),SessionStateprogprog'(current,outgoing,incoming))f(SessionStateprogprog'outgoingProgincomingProg_outNotify_inNotify_)=do{(ProgramCelloutgoingoutProgCellMVar')<-carefullySwapToNextCelloutProgCellMVar;(ProgramCellincominginProgCellMVar')<-carefullySwapToNextCellinProgCellMVar;letoutgoingProg'=tyListUpdateoutgoingProg(undefined::l)outProgCellMVar';letincomingProg'=tyListUpdateincomingProg(undefined::l)inProgCellMVar';return((),(SessionStateprogprog'outgoingProg'incomingProg'currentoutNotifyoutgoinginNotifyincoming))}wherecurrent::current=expandPidsprog$tyListIndexprog(undefined::l)outProgCellMVar=tyListIndexoutgoingProg(undefined::l)inProgCellMVar=tyListIndexincomingProg(undefined::l)-- | Send a value to the other party. Of course, the value must be of-- the correct type indicated in the session type.ssend::foralltprogprog'nxtnxt'incoming.t->(SessionChainprogprog')((Cons(Sendt)nxt),(Constnxt'),incoming)(nxt,nxt',incoming)()ssendt=SessionChainfwheref::SessionStateprogprog'((Cons(Sendt)nxt),(Constnxt'),incoming)->IO((),SessionStateprogprog'(nxt,nxt',incoming))f(SessionStateprogprog'outgoingProgincomingProgcurrentoutNotifyoutMVarinNotifyinMVar)=do{hole<-newEmptyMVar;outChan<-takeMVaroutNotify;putMVaroutMVar(Cellthole);caseoutChanofNothing->return()(Justchan)->writeChanchan();putMVaroutNotifyoutChan;return((),(SessionStateprogprog'outgoingProgincomingProg(tyTailcurrent)outNotifyholeinNotifyinMVar))}-- | Recieve a value from the other party. This will block as-- necessary. The type of the value received is specified by the-- session type. No magic coercion needed.srecv::foralltprogprog'nxtnxt'outgoing.(SessionChainprogprog')((Cons(Recvt)nxt),outgoing,(Constnxt'))(nxt,outgoing,nxt')tsrecv=SessionChainfwheref::SessionStateprogprog'((Cons(Recvt)nxt),outgoing,(Constnxt'))->IO(t,SessionStateprogprog'(nxt,outgoing,nxt'))f(SessionStateprogprog'outgoingProgincomingProgcurrentoutNotifyoutMVarinNotifyinMVar)=do{(Celltnxt')<-takeMVarinMVar;return(t,(SessionStateprogprog'outgoingProgincomingProg(tyTailcurrent)outNotifyoutMVarinNotifynxt'))}-- | Offer a number of branches. This is basically an external choice-- - the other party uses 'sselect' to decide which branch to take.-- Use OfferImpls in order to construct the list of implementations of-- branches. Note that every implementation must result in the same-- final state and emit the same value.soffer::forallcurrentoutgoingincomingfinalResultprogprog'jumps.OfferImplsjumpsprogprog'(current,outgoing,incoming)finalResult->(SessionChainprogprog')(Cons(Offerjumps)Nil,Cons(Choicejumps)Nil,Cons(Choicejumps)Nil)(current,outgoing,incoming)finalResultsofferimplementations=SessionChainfwheref::SessionStateprogprog'(Cons(Offerjumps)Nil,Cons(Choicejumps)Nil,Cons(Choicejumps)Nil)->IO(finalResult,SessionStateprogprog'(current,outgoing,incoming))f(SessionStateprogprog'outgoingProgincomingProg_outNotify_inNotifyinMVar)=do{(SelectCelln)<-takeMVarinMVar;runSessionChain(walkOfferImplsnimplementations)(SessionStateprogprog'outgoingProgincomingProgundefinedoutNotifyundefinedinNotifyundefined)}-- | Select which branch we're taking at a branch point. Use a type-- number ("Control.Concurrent.Session.Number") to indicate the branch-- to take.sselect::forallprogprog'progOutprogInlabeljumpsoutgoingincomingcurrentcurrentUXlenjumpTarget.(ProgramToMVarsOutgoingTprogprog~progOut,ProgramToMVarsOutgoingTprog'prog'~progIn,ProgramToMVarsOutgoingprogprogprogOut,ProgramToMVarsOutgoingprog'prog'progIn,TyListLengthjumpslen,SmallerThanBoollabellenTrue,TypeNumberToIntlabel,TyListIndexjumpslabel(Cons(JumpjumpTarget)Nil),SWellFormedConfigjumpTarget(D0E)prog,SWellFormedConfigjumpTarget(D0E)prog',TyListIndexprogOutjumpTarget(MVar(ProgramCell(Celloutgoing))),TyListIndexprogInjumpTarget(MVar(ProgramCell(Cellincoming))),TyListIndexprogjumpTargetcurrentUX,ExpandPidsprogcurrentUXcurrent)=>label->(SessionChainprogprog')(Cons(Selectjumps)Nil,Cons(Choicejumps)Nil,Cons(Choicejumps)Nil)(current,outgoing,incoming)()sselectlabel=SessionChainfwheref::SessionStateprogprog'(Cons(Selectjumps)Nil,Cons(Choicejumps)Nil,Cons(Choicejumps)Nil)->IO((),SessionStateprogprog'(current,outgoing,incoming))f(SessionStateprogprog'outgoingProgincomingProg_outNotifyoutMVarinNotify_)=do{outChan<-takeMVaroutNotify;putMVaroutMVar(SelectCell(tyNumToIntlabel));caseoutChanofNothing->return()(Justchan)->writeChanchan();putMVaroutNotifyoutChan;(ProgramCelloutgoingoutProgCellMVar')<-carefullySwapToNextCelloutProgCellMVar;(ProgramCellincominginProgCellMVar')<-carefullySwapToNextCellinProgCellMVar;letoutgoingProg'=tyListUpdateoutgoingProg(undefined::jumpTarget)outProgCellMVar';letincomingProg'=tyListUpdateincomingProg(undefined::jumpTarget)inProgCellMVar';return((),(SessionStateprogprog'outgoingProg'incomingProg'currentoutNotifyoutgoinginNotifyincoming))}wherecurrent=expandPidsprog$tyListIndexprog(undefined::jumpTarget)outProgCellMVar=tyListIndexoutgoingProg(undefined::jumpTarget)inProgCellMVar=tyListIndexincomingProg(undefined::jumpTarget)-- | Run! Provide a program and a start point within that program-- (which is automatically 'sjump'ed to), the two implementations-- which must be duals of each other, run them, have them communicate,-- wait until they both finish and die and then return the results-- from both of them.run::forallprogprog'progOutprogIninitfromOfromItoOtoIresres'currentUXcurrentUX'currentcurrent'toCurtoCur'.(ProgramToMVarsOutgoingprogprogprogOut,ProgramToMVarsOutgoingprog'prog'progIn,ProgramToMVarsOutgoingTprogprog~progOut,ProgramToMVarsOutgoingTprog'prog'~progIn,SWellFormedConfiginit(D0E)prog,SWellFormedConfiginit(D0E)prog',TyListIndexprogOutinit(MVar(ProgramCell(CellfromO))),TyListIndexprogIninit(MVar(ProgramCell(CellfromI))),DualTprog~prog',Dualprogprog',TyListIndexproginitcurrentUX,ExpandPidsprogcurrentUXcurrent,TyListIndexprog'initcurrentUX',ExpandPidsprog'currentUX'current')=>prog->init->SessionChainprogprog'(current,fromO,fromI)(toCur,toO,toI)res->SessionChainprog'prog(current',fromI,fromO)(toCur',toI,toO)res'->IO(res,res')runprog_chain1chain2=do{mvarsOut<-programToMVarsOutgoingprogprog;mvarsIn<-programToMVarsOutgoingprog'prog';aDone<-newEmptyMVar;bDone<-newEmptyMVar;aNotify<-newMVarNothing;bNotify<-newMVarNothing;forkIO$runSessionChainchain1'(SessionStateprogprog'mvarsOutmvarsInundefinedaNotifyundefinedbNotifyundefined)>>=putMVaraDone.fst;forkIO$runSessionChainchain2'(SessionStateprog'progmvarsInmvarsOutundefinedbNotifyundefinedaNotifyundefined)>>=putMVarbDone.fst;aRes<-takeMVaraDone;bRes<-takeMVarbDone;return(aRes,bRes)}wherechain1'::SessionChainprogprog'((Cons(Jumpinit)Nil),(Cons(Jumpinit)Nil),(Cons(Jumpinit)Nil))(toCur,toO,toI)reschain1'=sjump~>>chain1chain2'::SessionChainprog'prog((Cons(Jumpinit)Nil),(Cons(Jumpinit)Nil),(Cons(Jumpinit)Nil))(toCur',toI,toO)res'chain2'=sjump~>>chain2prog'=dualprog