{-# LANGUAGE KindSignatures
, GADTs
, MultiParamTypeClasses
, UndecidableInstances
, FunctionalDependencies
, ScopedTypeVariables
, FlexibleInstances
, FlexibleContexts #-}{-
SessionTypeMonad.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/>.
-}moduleControl.Concurrent.Session.SessionTypeMonadwhereimportControl.Concurrent.Session.Base.BoolimportControl.Concurrent.Session.Base.NumberimportControl.Concurrent.Session.Base.ListimportControl.Concurrent.Session.Base.SMonadimportControl.Concurrent.Session.TypesimportControl.Concurrent.Session.SessionTypehiding(jump,end,select,offer,(~|~),sendPid,recvPid,sendSession,recvSession,Dual(..))dataTypeState::*->*->*->*->*whereTypeState::nxtLabel->declareable->useable->st->TypeStatenxtLabeldeclareableuseablestnewtypeSessionTypeftr=SessionType{buildSessionType::f->(r,t)}instanceSMonadSessionTypewherea~>>b=SessionType$\f->let(_,f')=buildSessionTypeafinbuildSessionTypebf'a~>>=b=SessionType$\f->let(r,f')=buildSessionTypeafinbuildSessionType(br)f'sreturnr=SessionType$\f->(r,f)newLabel::(SuccnxtLabelnxtLabel',TyListConsSetnxtLabeldeclareabledeclareable',TyListConsSetnxtLabeluseableuseable')=>SessionType(TypeStatenxtLabeldeclareableuseablest)(TypeStatenxtLabel'declareable'useable'st)nxtLabelnewLabel=SessionType$\(TypeStatenxtLabeldeclareableuseablest)->(nxtLabel,(TypeState(tySuccnxtLabel)(tyListConsSetnxtLabeldeclareable)(tyListConsSetnxtLabeluseable)st))declareLabel::(TyListMemberdeclareablelabelTrue,TyListElemdeclareablelabelidx,TyListDeletedeclareableidxdeclareable',TyListst)=>label->(SessionType(TypeStatenxtLabeldeclareable'useable(Cons(label,Nil)st))(TypeStatenxtLabel'declareable''useable'st')a)->SessionType(TypeStatenxtLabeldeclareableuseablest)(TypeStatenxtLabel'declareable''useable'st')adeclareLabellabelf=SessionType$\(TypeStatenxtLabeldeclareableuseablest)->letidx=tyListElemdeclareablelabeldeclareable'=tyListDeleteidxdeclareableinbuildSessionTypef(TypeStatenxtLabeldeclareable'useable(cons(label,nil)st))(.=)::(TyListMemberdeclareablelabelTrue,TyListElemdeclareablelabelidx,TyListDeletedeclareableidxdeclareable',TyListst)=>label->(SessionType(TypeStatenxtLabeldeclareable'useable(Cons(label,Nil)st))(TypeStatenxtLabel'declareable''useable'st')a)->SessionType(TypeStatenxtLabeldeclareableuseablest)(TypeStatenxtLabel'declareable''useable'st')a(.=)=declareLabelinfixl2.=send::(TyListf,TyListfs)=>t->SessionType(TypeStatenxtLabeldeclareableuseable(Cons(label,f)fs))(TypeStatenxtLabeldeclareableuseable(Cons(label,(Cons(Send(SpecialNormal,t))f))fs))()sendt=SessionType$\(TypeStatenxtLabeldeclareableuseablest)->((),(TypeStatenxtLabeldeclareableuseable(modifyCons(\(label,f)->(label,cons(Send(undefined,t))f))idst)))recv::(TyListf,TyListfs)=>t->SessionType(TypeStatenxtLabeldeclareableuseable(Cons(label,f)fs))(TypeStatenxtLabeldeclareableuseable(Cons(label,(Cons(Recv(SpecialNormal,t))f))fs))()recvt=SessionType$\(TypeStatenxtLabeldeclareableuseablest)->((),(TypeStatenxtLabeldeclareableuseable(modifyCons(\(label,f)->(label,cons(Recv(undefined,t))f))idst)))sendPid::(TyListf,TyListfs,TyListSortNumslstlst')=>lst->SessionType(TypeStatenxtLabeldeclareableuseable(Cons(label,f)fs))(TypeStatenxtLabeldeclareableuseable(Cons(label,(Cons(SendPidFalselst')f))fs))()sendPidlst=SessionType$\(TypeStatenxtLabeldeclareableuseablest)->((),(TypeStatenxtLabeldeclareableuseable(modifyCons(\(label,f)->(label,cons(SendPidFF(tyListSortNumslst))f))idst)))recvPid::(TyListf,TyListfs,TyListSortNumslstlst')=>lst->SessionType(TypeStatenxtLabeldeclareableuseable(Cons(label,f)fs))(TypeStatenxtLabeldeclareableuseable(Cons(label,(Cons(RecvPidFalselst')f))fs))()recvPidlst=SessionType$\(TypeStatenxtLabeldeclareableuseablest)->((),(TypeStatenxtLabeldeclareableuseable(modifyCons(\(label,f)->(label,cons(RecvPidFF(tyListSortNumslst))f))idst)))sendSession::(TyListf,TyListfs,TyListfs',TyListReversefragfragRev,TyListTake(D1E)fragRev(Cons(label,fragHead)Nil),TyListDrop(D1E)fragRevfragTailRev,TyListReversefragTailRevfragTail,TyListAppendfragTailfsfs')=>SessionType(TypeStatenxtLabeldeclareableuseable(Cons(label,Nil)Nil))(TypeStatenxtLabel'declareable'useable'frag)res->SessionType(TypeStatenxtLabeldeclareableuseable(Cons(label,f)fs))(TypeStatenxtLabel'declareable'useable'(Cons(label,(Cons(SendSessionFalsefragHead)f))fs'))ressendSessionfragST=SessionType$\(TypeStatenxtLabeldeclareableuseablest)->let(label,f)=tyHeadststTail=tyTailst(res,(TypeStatenxtLabel'declareable'useable'frag))=buildSessionTypefragST(TypeStatenxtLabeldeclareableuseable(cons(label,nil)nil))fragRev=tyListReversefrag(_,fragHead)=tyHead$tyListTake(D1E)fragRevfragTailRev=tyListDrop(D1E)fragRevfragTail=tyListReversefragTailRevfs'=cons(label,cons(SendSessionFFfragHead)f)$tyListAppendfragTailstTailin(res,(TypeStatenxtLabel'declareable'useable'fs'))recvSession::(TyListf,TyListfs,TyListfs',TyListReversefragfragRev,TyListTake(D1E)fragRev(Cons(label,fragHead)Nil),TyListDrop(D1E)fragRevfragTailRev,TyListReversefragTailRevfragTail,TyListAppendfragTailfsfs')=>SessionType(TypeStatenxtLabeldeclareableuseable(Cons(label,Nil)Nil))(TypeStatenxtLabel'declareable'useable'frag)res->SessionType(TypeStatenxtLabeldeclareableuseable(Cons(label,f)fs))(TypeStatenxtLabel'declareable'useable'(Cons(label,(Cons(RecvSessionFalsefragHead)f))fs'))resrecvSessionfragST=SessionType$\(TypeStatenxtLabeldeclareableuseablest)->let(label,f)=tyHeadststTail=tyTailst(res,(TypeStatenxtLabel'declareable'useable'frag))=buildSessionTypefragST(TypeStatenxtLabeldeclareableuseable(cons(label,nil)nil))fragRev=tyListReversefrag(_,fragHead)=tyHead$tyListTake(D1E)fragRevfragTailRev=tyListDrop(D1E)fragRevfragTail=tyListReversefragTailRevfs'=cons(label,cons(RecvSessionFFfragHead)f)$tyListAppendfragTailstTailin(res,(TypeStatenxtLabel'declareable'useable'fs'))end::(TyListReverse(ConsEndf)f',TyListf,TyListfs)=>SessionType(TypeStatenxtLabeldeclareableuseable(Cons(label,f)fs))(TypeStatenxtLabeldeclareableuseable(Cons(label,f')fs))()end=SessionType$\(TypeStatenxtLabeldeclareableuseablest)->((),(TypeStatenxtLabeldeclareableuseable(modifyCons(\(label,f)->(label,tyListReverse(consEndf)))idst)))jump::(TyListReverse(Cons(Jumpjt)f)f',TyListf,TyListfs,TyListMemberuseablejtTrue)=>jt->SessionType(TypeStatenxtLabeldeclareableuseable(Cons(label,f)fs))(TypeStatenxtLabeldeclareableuseable(Cons(label,f')fs))()jumpjt=SessionType$\(TypeStatenxtLabeldeclareableuseablest)->((),(TypeStatenxtLabeldeclareableuseable(modifyCons(\(label,f)->(label,tyListReverse(cons(Jumpjt)f)))idst)))dataBranchesList::*->*->*->*->*->*whereBLNil::BranchesListNilNilzzzBLCons::(SessionType(TypeStatenxtLabeldeclareableuseablest)(TypeStatenxtLabel'declareable'useable'st')((resLst->ConsresresLst),(labs->Cons(Cons(JumpnxtLabel)Nil)labs)))->(BranchesListresLstlabs(TypeStatenxtLabel'declareable'useable'st')tofinalTo)->(BranchesList(ConsresresLst)(Cons(Cons(JumpnxtLabel)Nil)labs)(TypeStatenxtLabeldeclareableuseablest)((TypeStatenxtLabel'declareable'useable'st'),to)finalTo)(~|~)::(SucclabelnxtLabel,TyListConsSetlabeldeclareabledeclareable',TyListElemdeclareable'labelidx,TyListDeletedeclareable'idxdeclareable'',TyListConsSetlabeluseableuseable',TyListst,TyListMemberdeclareable'labelTrue,TyListlabs,TyListresLst)=>(SessionType(TypeStatenxtLabeldeclareable''useable'(Cons(label,Nil)st))(TypeStatenxtLabel'declareable'''useable''st')res)->(BranchesListresLstlabs(TypeStatenxtLabel'declareable'''useable''st')tofinalTo)->(BranchesList(ConsresresLst)(Cons(Cons(Jumplabel)Nil)labs)(TypeStatelabeldeclareableuseablest)((TypeStatenxtLabel'declareable'''useable''st'),to)finalTo)(~|~)stlst=BLCons(newLabel~>>=\l->declareLabellst~>>=\r->sreturn(consr,(cons(cons(Jumpl)nil))))lstinfixr5~|~classBuildBranchesblstwherebuildBranches::bl->stinstanceBuildBranches(BranchesListNilNil(TypeStatenxtLabeldeclareLabeluseablest)(TypeStatenxtLabeldeclareLabeluseablest)(TypeStatenxtLabeldeclareLabeluseablest))(SessionType(TypeStatenxtLabeldeclareLabeluseablest)(TypeStatenxtLabeldeclareLabeluseablest)(Nil,Nil))wherebuildBranches(BLNil)=sreturn(nil,nil)buildBranches_=error"Monstrously impossible"instance(BuildBranches(BranchesListresLstlabs(TypeStatenxtLabel'declareable'useable'st')tofinalTo)(SessionType(TypeStatenxtLabel'declareable'useable'st')finalTo(resLst,labs)))=>BuildBranches(BranchesList(ConsresresLst)(Cons(Cons(JumpnxtLabel)Nil)labs)(TypeStatenxtLabeldeclareableuseablest)((TypeStatenxtLabel'declareable'useable'st'),to)finalTo)(SessionType(TypeStatenxtLabeldeclareableuseablest)finalTo((ConsresresLst),(Cons(Cons(JumpnxtLabel)Nil)labs)))wherebuildBranches(BLConsstmlst)=stm~>>=\(fR,fL)->buildBrancheslst~>>=\(res,labs)->sreturn(fRres,fLlabs)buildBranches_=error"Equally monstrously impossible"select::forallff'fslistOfReslistOfJumpslabelnxtLabeldeclareableuseabletofinalTo.(TyListReverse(Cons(SelectlistOfJumps)f)f',TyListf,TyListfs,BuildBranches(BranchesListlistOfReslistOfJumps(TypeStatenxtLabeldeclareableuseable(Cons(label,f')fs))tofinalTo)(SessionType(TypeStatenxtLabeldeclareableuseable(Cons(label,f')fs))finalTo(listOfRes,listOfJumps)))=>(BranchesListlistOfReslistOfJumps(TypeStatenxtLabeldeclareableuseable(Cons(label,f')fs))tofinalTo)->(SessionType(TypeStatenxtLabeldeclareableuseable(Cons(label,f)fs))finalTolistOfRes)selectbl=SessionType$\(TypeStatenxtLabeldeclareableuseablest)->let((listOfRes,listOfJumps),ts)=buildSessionType(buildBranchesbl)(TypeStatenxtLabeldeclareableuseable((modifyCons(\(label,f)->(label,tyListReverse(cons(SelectlistOfJumps)f)))idst)::Cons(label,f')fs))in(listOfRes,ts)offer::forallff'fslistOfReslistOfJumpslabelnxtLabeldeclareableuseabletofinalTo.(TyListReverse(Cons(OfferlistOfJumps)f)f',TyListf,TyListfs,BuildBranches(BranchesListlistOfReslistOfJumps(TypeStatenxtLabeldeclareableuseable(Cons(label,f')fs))tofinalTo)(SessionType(TypeStatenxtLabeldeclareableuseable(Cons(label,f')fs))finalTo(listOfRes,listOfJumps)))=>(BranchesListlistOfReslistOfJumps(TypeStatenxtLabeldeclareableuseable(Cons(label,f')fs))tofinalTo)->(SessionType(TypeStatenxtLabeldeclareableuseable(Cons(label,f)fs))finalTolistOfRes)offerbl=SessionType$\(TypeStatenxtLabeldeclareableuseablest)->let((listOfRes,listOfJumps),ts)=buildSessionType(buildBranchesbl)(TypeStatenxtLabeldeclareableuseable((modifyCons(\(label,f)->(label,tyListReverse(cons(OfferlistOfJumps)f)))idst)::Cons(label,f')fs))in(listOfRes,ts)currentLabel::SessionType(TypeStatenxtLabeldeclareableuseable(Cons(label,f)fs))(TypeStatenxtLabeldeclareableuseable(Cons(label,f)fs))labelcurrentLabel=SessionType$\ts@(TypeState___st)->(fst.tyHead$st,ts)makeSessionType::(TyListSortNumsstst',TyListSndst'st'')=>SessionType(TypeState(D0E)NilNilNil)(TypeStatenxtLabelNiluseablest)res->(st'',res)makeSessionTypea=let(res,(TypeState___st))=(buildSessionTypea)(TypeState(D0E)nilnilnil)in(tyListSnd.tyListSortNums$st,res)classTyListSndlstAlstB|lstA->lstBwheretyListSnd::lstA->lstBinstanceTyListSndNilNilwheretyListSnd_=nilinstance(TyListSndnxtnxt',TyListnxt,TyListnxt')=>TyListSnd(Cons(a,b)nxt)(Consbnxt')wheretyListSnd=modifyConssndtyListSnddual::Truedual=TTnotDual::FalsenotDual=FF