------------------------------------------------------------------------------- |-- Module : Language.CSPM.Parser-- Copyright : (c) Fontaine 2008-- License : BSD-- -- Maintainer : Fontaine@cs.uni-duesseldorf.de-- Stability : experimental-- Portability : GHC-only---- This modules defines a Parser for CSPM-- -----------------------------------------------------------------------------{- todo:
* add Autoversion to packet
* add wrappers for functions that throw dynamic exceptions
-}{-# OPTIONS_GHC -fglasgow-exts #-}{-# LANGUAGE ImplicitParams #-}moduleLanguage.CSPM.Parser(parse,ParseError(..))whereimportLanguage.CSPM.ASTimportLanguage.CSPM.Token(Token(..),AlexPosn)importLanguage.CSPM.TokenClassesasTokenClassesimportqualifiedLanguage.CSPM.TokenasTokenimportqualifiedLanguage.CSPM.SrcLocasSrcLocimportLanguage.CSPM.SrcLoc(SrcLoc)importLanguage.CSPM.LexHelper(filterIgnoredToken)importText.ParserCombinators.Parsec.ExprMimportText.ParserCombinators.Parsechiding(parse,eof,notFollowedBy,anyToken,label,ParseError,errorPos,token)importText.ParserCombinators.Parsec.Pos(newPos)importqualifiedText.ParserCombinators.Parsec.ErrorasParsecErrorimportData.Typeable(Typeable)importControl.Monad.StateimportData.ListimportPreludehiding(exp)importControl.Exception(Exception)typePTa=GenParserTokenPStatea-- | The 'parse' function parses a List of 'Token'.-- It returns a 'ParseError' or a 'Labled' 'Module'.-- The 'SourceName' argument is currently not used.parse::SourceName->[Token]->EitherParseErrorLModuleparsefilenametokenList=wrapParseErrortokenList$runParser(parseModuletokenList)initialPStatefilename$filterIgnoredTokentokenListdataParseError=ParseError{parseErrorMsg::String,parseErrorToken::Token,parseErrorPos::AlexPosn}deriving(Show,Typeable)instanceExceptionParseErrordataPState=PState{lastTok::Token,lastChannelDir::LastChannelDir,gtCounter::Int,gtMode::GtMode,nodeIdSupply::NodeId}derivingShowinitialPState::PStateinitialPState=PState{lastTok=Token.tokenSentinel,lastChannelDir=WasOut,gtCounter=0,gtMode=GtNoLimit,nodeIdSupply=mkNodeId0}setLastChannelDir::LastChannelDir->PState->PStatesetLastChannelDirdirenv=env{lastChannelDir=dir}setGtMode::GtMode->PState->PStatesetGtModemodeenv=env{gtMode=mode}countGt::PState->PStatecountGtenv=env{gtCounter=gtCounterenv+1}dataLastChannelDir=WasIn|WasOutderivingShowdataGtMode=GtNoLimit|GtLimitIntderivingShowinstanceNodeIdSupply(GenParserTokenPState)wheregetNewNodeId=doi<-getsnodeIdSupplymodify$\s->s{nodeIdSupply=succ$nodeIdSupplys}returniinstanceMonadStatePState(GenParserTokenPState)whereget=getStateput=setStategetNextPos::PTTokengetNextPos=dotokenList<-getInputcasetokenListof(hd:_)->returnhd[]->returnToken.tokenSentinelgetLastPos::PTTokengetLastPos=getStateslastTokgetPos::PTSrcLocgetPos=dot<-getNextPosreturn$mkSrcPostmkSrcSpan::Token->Token->SrcLocmkSrcSpanbe=SrcLoc.mkTokSpanbe{-# DEPRECATED mkSrcPos "simplify alternatives for sourcelocations" #-}mkSrcPos::Token->SrcLocmkSrcPosl=SrcLoc.mkTokPoslwithLoc::PTa->PT(Labeleda)withLoca=dos<-getNextPosav<-ae<-getLastPosmkLabeledNode(mkSrcSpanse)avinSpan::(a->b)->PTa->PT(Labeledb)inSpanconstrexp=dos<-getNextPosl<-expe<-getLastPosmkLabeledNode(mkSrcSpanse)$constrlparseModule::[Token.Token]->PT(LabeledModule)parseModuletokenList=withLoc$dodecl<-topDeclListeof<?>"end of module"return$Module{moduleDecls=decl,moduleTokens=JusttokenList}token::TokenClasses.PrimToken->PT()tokent=tokenPrimExDefaulttokenTestwheretokenTesttok=iftokenClasstok==tthenJust()elseNothing{-
builtInFunctions :: Set TokenClasses.PrimToken
builtInFunctions = Set.fromList
[ T_union ,T_inter, T_diff, T_Union, T_Inter,
T_member, T_card, T_empty, T_set, T_Set,
T_Seq, T_null, T_head, T_tail, T_concat,
T_elem, T_length, T_CHAOS ]
-}anyBuiltIn::PTConstanyBuiltIn=try$dotok<-tokenPrimExDefault(\t->Just$tokenClasst)casetokofT_union->returnF_unionT_inter->returnF_interT_diff->returnF_diffT_Union->returnF_UnionT_Inter->returnF_InterT_member->returnF_memberT_card->returnF_cardT_empty->returnF_emptyT_set->returnF_setT_Set->returnF_SetT_Seq->returnF_SeqT_null->returnF_nullT_head->returnF_headT_tail->returnF_tailT_concat->returnF_concatT_elem->returnF_elemT_length->returnF_lengthT_CHAOS->returnF_CHAOS_->fail"not a built-in function"blockBuiltIn::PTablockBuiltIn=dobi<-anyBuiltInfail$"can not use built-in '"++showbi++"' here"-- todo fix: better error -messagelIdent::PTStringlIdent=tokenPrimExDefaulttestToken<?>"identifier"wheretestTokent=casetokenClasstofL_Ident->Just$tokenStringt_->Nothingident::PTLIdentident=withLoc(lIdent>>=return.Ident)varExp::PTLExpvarExp=withLoc(ident>>=return.Var)commaSeperator::PT()commaSeperator=tokenT_commasepByComma::PTx->PT[x]sepByCommaa=sepByacommaSeperatorsepBy1Comma::PTx->PT[x]sepBy1Commaa=sepBy1acommaSeperatorrangeCloseExp::PT(LExp,LExp)rangeCloseExp=dos<-parseExp_noPrefixtokenT_dotdote<-parseExp_noPrefixreturn(s,e)rangeOpenExp::PTLExprangeOpenExp=dos<-parseExp_noPrefixtokenT_dotdotreturnscomprehensionExp::PT([LExp],[LCompGen])comprehensionExp=doexpList<-sepByCommaparseExpgens<-parseComprehensionreturn(expList,gens)parseComprehension::PT[LCompGen]parseComprehension=tokenT_mid>>sepByComma(compGenerator<|>compGuard)compGuard::PTLCompGencompGuard=withLoc(parseExp_noPrefix>>=return.Guard)compGenerator::PTLCompGencompGenerator=try$withLoc$dopat<-parsePatterntokenT_leftarrowexp<-parseExp_noPrefixreturn$Generatorpatexp-- replicated operations use comprehensions with a differen SyntaxcomprehensionRep::PTLCompGenListcomprehensionRep=withLoc$dol<-sepByComma(repGenerator<|>compGuard)tokenT_atreturnlrepGenerator::PTLCompGenrepGenerator=try$withLoc$dopat<-parsePatterntokenT_colonexp<-parseExp_noPrefixreturn$GeneratorpatexpinBraces::PTx->PTxinBraces=between(tokenT_openBrace)(tokenT_closeBrace)inParens::PTx->PTxinParens=between(tokenT_openParen)(tokenT_closeParen)setExpEnum::PTLExpsetExpEnum=inSpanSetEnum$inBraces(sepByCommaparseExp)listExpEnum::PTLExplistExpEnum=inSpanListEnum$betweenLtGt(sepByCommaparseExp_noPrefix)setExpOpen::PTLExpsetExpOpen=inSpanSetOpen$inBracesrangeOpenExplistExpOpen::PTLExplistExpOpen=inSpanListOpen$betweenLtGtrangeOpenExpsetExpClose::PTLExpsetExpClose=inSpanSetClose$inBracesrangeCloseExplistExpClose::PTLExplistExpClose=inSpanListClose$betweenLtGtrangeCloseExpsetComprehension::PTLExpsetComprehension=inSpanSetComprehension$inBracescomprehensionExplistComprehension::PTLExplistComprehension=inSpanListComprehension$betweenLtGtcomprehensionExpclosureComprehension::PTLExpclosureComprehension=inSpanClosureComprehension$between(tokenT_openPBrace)(tokenT_closePBrace)comprehensionExp-- todo check in csp-m doku size of IntintLit::PTIntegerintLit=-- " - {-comment-} 10 " is parsed as Integer(-10) "(tokenT_minus>>linteger>>=return.negate)<|>lintegerwherelinteger::PTIntegerlinteger=tokenPrimExDefaulttestTokentestTokent=iftokenClasst==L_IntegerthenJust$read$tokenStringtelseNothingnegateExp::PTLExpnegateExp=withLoc$dotokenT_minusbody<-parseExpreturn$NegExpbodylitExp::PTLExplitExp=inSpanIntExpintLitlitPat::PTLPatternlitPat=inSpanIntPatintLitletExp::PTLExpletExp=withLoc$dotokenT_letdecl<-parseDeclListtokenT_withinexp<-parseExpreturn$LetdeclexpifteExp::PTLExpifteExp=withLoc$dotokenT_ifcond<-parseExptokenT_thenthenExp<-parseExptokenT_elseelseExp<-parseExpreturn$IftecondthenExpelseExpfunCall::PTLExpfunCall=funCallFkt<|>funCallBifunCallFkt::PTLExpfunCallFkt=withLoc$dofkt<-varExpargs<-parseFunArgsreturn$CallFunctionfktargsfunCallBi::PTLExpfunCallBi=withLoc$dofkt<-inSpanBuiltInanyBuiltInargs<-parseFunArgsreturn$CallBuiltInfktargsparseFunArgs::PT[[LExp]]parseFunArgs=doargsL<-many1funArgsTreturnargsL{-
fun application in tuple form f(1,2,3)
if the tuple is follwed by "=", it belongs to the next declaration
g = h
(a,b) = (1,2)
-}funArgsT::PT[LExp]funArgsT=try$dotArgs<-inParens$sepByCommaparseExpnotFollowedBy'token_isreturntArgslambdaExp::PTLExplambdaExp=withLoc$dotokenT_backslashpatList<-sepBy1parsePattern$tokenT_commatokenT_atexp<-parseExpreturn$LambdapatListexpparseExpBase::PTLExpparseExpBase=parenExpOrTupleEnum<|>(tryfunCall)<|>withLoc(tokenT_STOP>>returnStop)<|>withLoc(tokenT_SKIP>>returnSkip)<|>withLoc(tokenT_true>>returnCTrue)<|>withLoc(tokenT_false>>returnCFalse)<|>withLoc(tokenT_Events>>returnEvents)<|>withLoc(tokenT_Bool>>returnBoolSet)<|>withLoc(tokenT_Int>>returnIntSet)<|>ifteExp<|>letExp<|>trylitExp-- -10 is Integer(-10) <|>negateExp-- -(10) is NegExp(Integer(10))<|>varExp<|>lambdaExp<|>tryclosureComprehension<|>closureExp<|>trylistComprehension<|>trysetComprehension<|>trylistExpEnum<|>trysetExpEnum<|>trysetExpClose<|>trylistExpClose<|>trysetExpOpen<|>trylistExpOpen<|>blockBuiltIn<?>"core-expression"{-
maybe need a Ast-node for parenExp for prettyPrint-Printing
parenExps are now a special case of TupleExps
-}parenExpOrTupleEnum::PTLExpparenExpOrTupleEnum=withLoc$dobody<-inParens$sepByCommaparseExpcasebodyof[]->return$TupleExp[][x]->return$Parensx_->return$TupleExpbody{-
Warning : postfixM and Prefix may not be nested
"not not true" does not parse !!
-}opTable::[[Text.ParserCombinators.Parsec.ExprM.OperatorTokenPStateLExp]]opTable=[-- [ infixM ( cspSym "." >> binOp mkDotPair) AssocRight ]-- ,-- dot.expression moved to a seperate Step-- ToDo : fix funApply and procRenaming[postfixMfunApplyImplicit],[postfixMprocRenaming],[infixM(nfun2T_hatF_Concat)AssocLeft,prefixM(nfun1T_hashF_Len2)-- different from Roscoe Book],[infixM(nfun2T_timesF_Mult)AssocLeft,infixM(nfun2T_slashF_Div)AssocLeft,infixM(nfun2T_percentF_Mod)AssocLeft],[infixM(nfun2T_plusF_Add)AssocLeft,infixM(nfun2T_minusF_Sub)AssocLeft],[infixM(nfun2T_eqF_Eq)AssocLeft,infixM(nfun2T_neqF_NEq)AssocLeft,infixM(nfun2T_geF_GE)AssocLeft,infixM(nfun2T_leF_LE)AssocLeft,infixM(nfun2T_ltF_LT)AssocLeft,infixM(dos<-getNextPosgtSyme<-getLastPosop<-mkLabeledNode(mkSrcSpanse)(BuiltInF_GT)return$(\ab->mkLabeledNode(posFromToab)$Fun2opab))AssocLeft],[prefixM(tokenT_not>>unOpNotExp)],[infixM(tokenT_and>>binOpAndExp)AssocLeft],[infixM(tokenT_or>>binOpOrExp)AssocLeft],[infixMproc_op_aparallelAssocLeft],[infixMproc_op_lparallelAssocLeft],[infixMprocOpSharingAssocLeft],[infixM(nfun2T_ampF_Guard)AssocLeft],[infixM(nfun2T_semicolonF_Sequential)AssocLeft],[infixM(nfun2T_triangleF_Interrupt)AssocLeft],[infixM(nfun2T_boxF_ExtChoice)AssocLeft],[infixM(nfun2T_rhdF_Timeout)AssocLeft],[infixM(nfun2T_sqcapF_IntChoice)AssocLeft],[infixM(nfun2T_interleaveF_Interleave)AssocLeft],[infixM(nfun2T_backslashF_Hiding)AssocLeft]]wherenfun1::TokenClasses.PrimToken->Const->PT(LExp->PTLExp)nfun1tokcst=dofkt<-biOptokcstpos<-getPosreturn$(\a->mkLabeledNodepos$Fun1fkta)nfun2::TokenClasses.PrimToken->Const->PT(LExp->LExp->PTLExp)nfun2tokcst=dofkt<-biOptokcstpos<-getLastPos-- return $ \a b -> mkLabeledNode (posFromTo a b) $ Fun2 fkt a breturn$\ab->mkLabeledNode(mkSrcPospos)$Fun2fktabbinOp::(LExp->LExp->Exp)->PT(LExp->LExp->PTLExp)binOpop=return$\ab->mkLabeledNode(posFromToab)$opabunOp::(LExp->Exp)->PT(LExp->PTLExp)unOpop=dopos<-getLastPosreturn$(\a->mkLabeledNode(mkSrcPospos)$opa)biOp::TokenClasses.PrimToken->Const->PTLBuiltInbiOptokcst=inSpanBuiltIn(tokentok>>returncst)posFromTo::LExp->LExp->SrcLoc.SrcLocposFromToab=SrcLoc.srcLocFromTo(srcLoca)(srcLocb)parseExp::PTLExpparseExp=(parseDotExpOf$buildExpressionParseropTableparseProcReplicatedExp)<?>"expression"parseExp_noPrefix_NoDot::PTLExpparseExp_noPrefix_NoDot=buildExpressionParseropTableparseExpBaseparseExp_noPrefix::PTLExpparseExp_noPrefix=parseDotExpOfparseExp_noPrefix_NoDotparseDotExpOf::PTLExp->PTLExpparseDotExpOfbaseExp=dosPos<-getNextPosdotExp<-sepBy1baseExp$tokenT_dotePos<-getLastPoscasedotExpof[x]->returnxl->mkLabeledNode(mkSrcSpansPosePos)$DotTuplel{-
place (term) as a suffix behind any term to
make a function application
used a lot in CspBook -examples
notice : we do not destict between f(a,b,c) and f(a)(b)(c) or f(a,b)(c)
this is buggy for f(a)(b)(c)
this may interact with normal function -application !
-}funApplyImplicit::PT(LExp->PTLExp)funApplyImplicit=doargs<-parseFunArgspos<-getPosreturn$(\fkt->mkLabeledNodepos$CallFunctionfktargs)-- this is complicated and meight as well be buggy !gtSym::PT()gtSym=try$dotokenT_gtupdateStatecountGt--we count the occurences of gt-symbolsnext<-testFollowsparseExp-- and accept it only if it is followed by an expressioncasenextofNothing->fail"Gt token not followed by an expression"(Just_)->do--mode<-getStatesgtModecasemodeofGtNoLimit->return()(GtLimitx)->docnt<-getStatesgtCounterifcnt<xthenreturn()elsefail"(Gt token belongs to sequence expression)"{-
parse an sequenceexpression <...>
we have to be carefull not to parse the end of sequence ">"
as comparision
-}token_gt::PT()token_gt=tokenT_gttoken_lt::PT()token_lt=tokenT_ltbetweenLtGt::PTa->PTabetweenLtGtparser=dotoken_ltst<-getParserState-- maybe we need to backtrackbody<-parser-- even if this is successfullcnt<-getStatesgtCounterendSym<-testFollowstoken_gtcaseendSymofJust()->dotoken_gtreturnbody-- gtSym could make distinction between endOfSequence and GtSymNothing->do-- last comparision expression was indeed end of sequencesetParserStatest--backtracks<-parseWithGtLimit(cnt)parsertoken_gtreturns{-
parse an expression which contains as most count Greater-symbols (">"
used to leave the last ">" as end of sequence
attention: this can be nested !!
-}parseWithGtLimit::Int->PTa->PTaparseWithGtLimitmaxGtparser=dooldLimit<-getStatesgtModeupdateState$setGtMode$GtLimitmaxGtres<-optionMaybeparserupdateState$setGtModeoldLimitcaseresofJustp->returnpNothing->fail"contents of sequence expression"proc_op_aparallel::PT(LExp->LExp->PTLExp)proc_op_aparallel=try$dos<-getNextPostokenT_openBracka1<-parseExp_noPrefixtokenT_parallela2<-parseExp_noPrefixtokenT_closeBracke<-getLastPosreturn$(\p1p2->mkLabeledNode(mkSrcSpanse)$ProcAParallela1a2p1p2)proc_op_lparallel::PT(LExp->LExp->PTLExp)proc_op_lparallel=try$doren<-parseLinkListp<-getPosreturn$(\p1p2->mkLabeledNodep$ProcLinkParallelrenp1p2)procRenaming::PT(LExp->PTLExp)procRenaming=dorens<-many1procOneRenamingreturn$(\x->foldl(>>=)(returnx)rens)procOneRenaming::PT(LExp->PTLExp)procOneRenaming=try$dos<-getNextPostokenT_openBrackBrackren<-(sepByparseRenamecommaSeperator)gens<-optionMaybeparseComprehensiontokenT_closeBrackBracke<-getLastPoscasegensofNothing->return$(\p1->mkLabeledNode(mkSrcSpanse)$ProcRenamingrenp1)Justg->return$(\p1->mkLabeledNode(mkSrcSpanse)$ProcRenamingComprehensionrengp1)parseLinkList::PTLLinkListparseLinkList=withLoc$dotokenT_openBracklinkList<-(sepByparseLinkcommaSeperator)gens<-optionMaybeparseComprehensiontokenT_closeBrackcasegensofNothing->return$LinkListlinkListJustg->return$LinkListComprehensionglinkListparseLink::PTLLinkparseLink=withLoc$doe1<-parseExp_noPrefixtokenT_leftrightarrowe2<-parseExp_noPrefixreturn$Linke1e2parseRename::PTLRenameparseRename=withLoc$doe1<-parseExp_noPrefixtokenT_leftarrowe2<-parseExp_noPrefixreturn$Renamee1e2-- here starts the parser for patternparsePatternNoDot::PTLPatternparsePatternNoDot=let?innerDot=FalseinparsePatternAlsoparsePattern::PTLPatternparsePattern=let?innerDot=TrueinparsePatternAlsoparsePatternAlso::(?innerDot::Bool)=>PTLPatternparsePatternAlso=(dosPos<-getNextPosconcList<-sepBy1parsePatternAppend$tokenT_atatePos<-getLastPoscaseconcListof[x]->returnxl->mkLabeledNode(mkSrcSpansPosePos)$Alsol)<?>"pattern"parsePatternAppend::(?innerDot::Bool)=>PTLPatternparsePatternAppend=dosPos<-getNextPosconcList<-sepBy1parsePatternDot$tokenT_hatePos<-getLastPoscaseconcListof[x]->returnxl->mkLabeledNode(mkSrcSpansPosePos)$AppendlparsePatternDot::(?innerDot::Bool)=>PTLPatternparsePatternDot=case?innerDotofFalse->parsePatternCoreTrue->dos<-getNextPosdList<-sepBy1parsePatternCore$tokenT_dote<-getLastPoscasedListof[p]->returnpl->mkLabeledNode(mkSrcSpanse)$DotPatlparsePatternCore::(?innerDot::Bool)=>PTLPatternparsePatternCore=nestedPattern<|>withLoc(tokenT_true>>returnTruePat)<|>withLoc(tokenT_false>>returnFalsePat)<|>litPat<|>varPat<|>tuplePatEnum<|>listPatEnum<|>singleSetPat<|>emptySetPat<|>withLoc(tokenT_underscore>>returnWildCard)<|>blockBuiltIn<?>"pattern"wherenestedPattern=try$inParensparsePatternvarPat::(?innerDot::Bool)=>PTLPatternvarPat=inSpanVarPatidentsingleSetPat::(?innerDot::Bool)=>PTLPatternsingleSetPat=try$inSpanSingleSetPat$inBracesparsePatternemptySetPat::(?innerDot::Bool)=>PTLPatternemptySetPat=withLoc(tokenT_openBrace>>tokenT_closeBrace>>returnEmptySetPat)listPatEnum::(?innerDot::Bool)=>PTLPatternlistPatEnum=inSpanListEnumPat$betweentoken_lttoken_gt(sepByCommaparsePattern)tuplePatEnum::(?innerDot::Bool)=>PTLPatterntuplePatEnum=inSpanTuplePat$inParens(sepByCommaparsePattern)-- FixMe: do not use patBind to parse variable bindings ?patBind::PTLDeclpatBind=withLoc$dopat<-parsePatterntoken_isexp<-parseExpreturn$PatBindpatexp-- parse all fundefs and merge consecutive case alternativesfunBind::PT[LDecl]funBind=doflist<-many1sfun-- group functioncases by the name of the functionletflgr=groupBy(\ab->(unIdent$unLabel$fst$a)==(unIdent$unLabel$fstb))flistmapMmkFunflgrwheremkFun::[(LIdent,(FunArgs,LExp))]->PTLDeclmkFunl=doletfname=fst$headlpos=srcLocfnamecases=map((uncurryFunCase).snd)lmkLabeledNodepos$FunBindfnamecases-- parse a single function-casesfun::PT(LIdent,(FunArgs,LExp))sfun=do(fname,patl)<-trysfunHeadtoken_is<?>"rhs of function clause"exp<-parseExpreturn(fname,(patl,exp))wheresfunHead=dofname<-identpatl<-parseFktCurryPatreturn(fname,patl){-
in CSP f(x)(y), f(x,y) , f((x,y)) are all different
we parse a function pattern as a list of curryargs (a)(b)( )( )..
each of with can be a comma-seperated list of args that do not allow
currying in-between
i,e (a,b,c)(d,e,f) -> [[a,b,c][d,e,f]]
-}parseFktCurryPat::PT[[LPattern]]parseFktCurryPat=many1parseFktCspPatparseFktCspPat::PT[LPattern]parseFktCspPat=inParens$sepByCommaparsePattern{-
5. nov 2007 remove try to give better error-messages
parseFktCspPat =
try $ between (cspSym "(") (cspSym ")") $ sepByComma parsePattern
todo: better error-messages for fun(card) (card is a buildin)
-}{-
parsePatL = withLoc $ between (cspSym "(") (cspSym ")")
$ sepBy parsePattern funArgumentSeperator
funArgumentSeperator = cspSym "," <|> (try (cspSym ")" >> cspSym "("))
-}parseDeclList::PT[LDecl]parseDeclList=dodecl<-many1parseDeclreturn$concatdeclsingleList::PTa->PT[a]singleLista=doav<-areturn[av]{-
returns a list of decls
because funBind can't easily parse a single function
ToDo : PatBinds are actually different from varbind
example x={} with patbind will not be polymorphic
-}parseDecl::PT[LDecl]parseDecl=funBind<|>singleListpatBind<?>"declaration"topDeclList::PT[LDecl]topDeclList=dodecl<-many1topDeclreturn$concatdeclwheretopDecl::PT[LDecl]topDecl=funBind<|>singleListpatBind<|>singleListparseAssert<|>singleListparseTransparent<|>singleListparseDatatype<|>singleListparseSubtype<|>singleListparseNametype<|>singleListparseChannel<|>singleListparsePrint<?>"top-level declaration"assertRef=withLoc$dotokenT_assertp1<-parseExpop<-tokenT_Refine{- ToDo: fix this -}p2<-parseExpreturn$AssertRefp1"k"p2assertBool=withLoc$dotokenT_assertb<-parseExpreturn$AssertBoolbparseAssert::PTLDeclparseAssert=(tryassertRef)<|>assertBoolparseTransparent::PTLDeclparseTransparent=withLoc$dotokenT_transparentl<-sepBy1Commaidentreturn$TransparentlparseSubtype::PTLDeclparseSubtype=withLoc$dotokenT_subtypei<-identtoken_isconList<-sepBy1constrDef$tokenT_midreturn$SubTypeiconListparseDatatype::PTLDeclparseDatatype=withLoc$dotokenT_datatypei<-identtoken_isconList<-sepBy1constrDef$tokenT_midreturn$DataTypeiconListconstrDef::PTLConstructorconstrDef=withLoc$doi<-identty<-optionMaybeconstrTypereturn$ConstructorityconstrType=try(tokenT_dot>>typeExp)parseNametype::PTLDeclparseNametype=withLoc$dotokenT_nametypei<-identtoken_ist<-typeExpreturn$NameTypeitparseChannel::PTLDeclparseChannel=withLoc$dotokenT_channelidentl<-sepBy1Commaidentt<-optionMaybetypeDefreturn$ChannelidentlttypeDef=tokenT_colon>>typeExptypeExp=typeTuple<|>typeDottypeTuple=inSpanTypeTuple$inParens$sepBy1CommaparseExptypeDot=inSpanTypeDot$sepBy1parseExpBase$tokenT_dotparsePrint::PTLDeclparsePrint=withLoc$dotokenT_printe<-parseExpreturn$PrinteprocOpSharing::PT(LProc->LProc->PTLProc)procOpSharing=dospos<-getNextPosal<-between(tokenT_openOxBrack)(tokenT_closeOxBrack)parseExpepos<-getLastPosreturn$(\ab->mkLabeledNode(mkSrcSpansposepos)$ProcSharingalab)closureExp::PTLExpclosureExp=inSpanClosure$between(tokenT_openPBrace)(tokenT_closePBrace)(sepBy1CommaparseExp){- Replicated Expressions in Prefix form -}parseProcReplicatedExp::PTLProcparseProcReplicatedExp=doprocRepT_semicolonProcRepSequence<|>procRepT_sqcapProcRepInternalChoice<|>procRepT_interleaveProcRepInterleave<|>procRepT_boxProcRepChoice<|>procRepAParallel<|>procRepLinkParallel<|>procRepSharing<|>parsePrefixExp<|>parseExpBase<?>"parseProcReplicatedExp"where-- todo : refactor all these to using inSpanprocRep::TokenClasses.PrimToken->(LCompGenList->LProc->Exp)->PTLProcprocRepsymfkt=withLoc$dotokensyml<-comprehensionRepbody<-parseExpreturn$fktlbodyprocRepAParallel=withLoc$dotokenT_parallell<-comprehensionReptokenT_openBrackalph<-parseExptokenT_closeBrackbody<-parseExpreturn$ProcRepAParallellalphbodyprocRepLinkParallel=withLoc$dolink<-parseLinkListgen<-comprehensionRepbody<-parseExpreturn$ProcRepLinkParallelgenlinkbodyprocRepSharing=withLoc$doal<-between(tokenT_openOxBrack)(tokenT_closeOxBrack)parseExpgen<-comprehensionRepbody<-parseExpreturn$ProcRepSharinggenalbody{-
parsePrefixExp is to be called without try
i.e. it must only commit after "->"
prefix binds stronger than any operator (except dot-operator)
either another prefix or an expression without prefix
exp <-(parsePrefixExp <|> parseExpBase ) <?> "rhs of prefix operation"
-}parsePrefixExp::PTLExpparsePrefixExp=withLoc$do(channel,comm)<-tryparsePrefixexp<-parseProcReplicatedExp<?>"rhs of prefix operation"return$PrefixExpchannelcommexpwhereparsePrefix::PT(LExp,[LCommField])parsePrefix=dochannel<-tryfunCall<|>varExp--maybe permit even moreupdateState$setLastChannelDirWasOutcommfields<-manyparseCommFieldtokenT_rightarrowreturn(channel,commfields){-
this is not what fdr really does
fdr parese ch?x.y:a as ch?((x.y):a)
-}parseCommField::PTLCommFieldparseCommField=inComm<|>outComm<|>dotComm<?>"communication field"whereinComm=withLoc$dotokenT_questionmarkupdateState$setLastChannelDirWasIninCommCoreinCommCore=dopat<-parsePatternNoDotguarD<-optionMaybe(tokenT_colon>>parseExp_noPrefix_NoDot)caseguarDofNothing->return$InCommpatJustg->return$InCommGuardedpatgoutComm=withLoc$dotokenT_exclamationupdateState$setLastChannelDirWasOute<-parseExp_noPrefix_NoDotreturn$OutComme-- repeat the direction of the last CommFielddotComm=withLoc$dotokenT_dotlastDir<-getStateslastChannelDircaselastDirofWasOut->docom<-parseExp_noPrefix_NoDotreturn$OutCommcomWasIn->inCommCore{-
Helper routines for connecting the Token with the parser
and general Helper routines
The following is not related to CSPM-Syntax
-}--maybe this is Combinator.lookAhead ?testFollows::PTx->PT(Maybex)testFollowsp=dooldState<-getParserStateres<-optionMaybepsetParserStateoldStatereturnresgetStates::(PState->x)->PTxgetStatessel=dost<-getStatereturn$selstprimExUpdatePos::SourcePos->Token->t->SourcePosprimExUpdatePospost@(Token{})_=newPos(sourceNamepos)(-1)(Token.unTokenId$Token.tokenIdt)primExUpdateState::t->Token->t1->PState->PStateprimExUpdateState_tok_st=st{lastTok=tok}{-
replicating existing combinators, just to work with our lexer
improve this
-}anyToken::PTTokenanyToken=tokenPrimExToken.showTokenprimExUpdatePos(JustprimExUpdateState)JustnotFollowedBy::PTToken->PT()notFollowedByp=try(do{c<-p;unexpected$Token.showTokenc}<|>return())notFollowedBy'::PTx->PT()notFollowedBy'p=try(do{p;pzero}<|>return())eof::PT()eof=notFollowedByanyToken<?>"end of input"pprintParsecError::ParsecError.ParseError->StringpprintParsecErrorerr=ParsecError.showErrorMessages"or""unknown parse error""expecting""unexpected""end of input"(ParsecError.errorMessageserr)wrapParseError::[Token]->EitherParsecError.ParseErrorLModule->EitherParseErrorLModulewrapParseError_(Rightast)=RightastwrapParseErrortl(Lefterr)=Left$ParseError{parseErrorMsg=pprintParsecErrorerr,parseErrorToken=errorTok,parseErrorPos=tokenStarterrorTok}wheretokId=Token.mkTokenId$sourceColumn$ParsecError.errorPoserrerrorTok=maybeToken.tokenSentinelid$find(\t->tokenIdt==tokId)tltoken_is::PT()token_is=tokenT_istokenPrimExDefault::(Token->Maybea)->GenParserTokenPStateatokenPrimExDefault=tokenPrimExToken.showTokenprimExUpdatePos(JustprimExUpdateState)