{-# LANGUAGE CPP, DeriveDataTypeable #-}------------------------------------------------------------------------------- |-- Module : Language.Haskell.Exts.Fixity-- Copyright : (c) Niklas Broberg 2009-- License : BSD-style (see the file LICENSE.txt)---- Maintainer : Niklas Broberg, d00nibro@chalmers.se-- Stability : stable-- Portability : portable---- Fixity information to give the parser so that infix operators can-- be parsed properly.-------------------------------------------------------------------------------moduleLanguage.Haskell.Exts.Fixity(-- * Fixity representationFixity(..)-- | The following three functions all create lists of-- fixities from textual representations of operators.-- The intended usage is e.g.---- > fixs = infixr_ 0 ["$","$!","`seq`"]---- Note that the operators are expected as you would-- write them infix, i.e. with ` characters surrounding-- /varid/ operators, and /varsym/ operators written as is.,infix_,infixl_,infixr_-- ** Collections of fixities,preludeFixities,baseFixities-- * Applying fixities to an AST,AppFixity(..))whereimportLanguage.Haskell.Exts.SyntaximportData.Char(isUpper)importControl.Monad(when,(<=<),liftM,liftM2,liftM3,liftM4)importData.Traversable(mapM)importPreludehiding(mapM)#ifdef __GLASGOW_HASKELL__#ifdef BASE4importData.Datahiding(Fixity)#elseimportData.Generics(Data(..),Typeable(..))#endif#endif-- | Operator fixities are represented by their associativity-- (left, right or none) and their precedence (0-9).dataFixity=FixityAssocIntQName#ifdef __GLASGOW_HASKELL__deriving(Eq,Ord,Show,Typeable,Data)#elsederiving(Eq,Ord,Show)#endif-- | All AST elements that may include expressions which in turn may-- need fixity tweaking will be instances of this class.classAppFixityastwhere-- | Tweak any expressions in the element to account for the-- fixities given. Assumes that all operator expressions are-- fully left associative chains to begin with.applyFixities::Monadm=>[Fixity]-- ^ The fixities to account for.->ast-- ^ The element to tweak.->mast-- ^ The same element, but with operator expressions updated, or a failure.instanceAppFixityExpwhereapplyFixitiesfixs=infFixfixs<=<leafFixfixswhere-- This is the real meat case. We can assume a left-associative list to begin with.infFixfixs(InfixAppaop2z)=doe<-infFixfixsacaseeofInfixAppxop1y->dolet(a1,p1)=askFixityfixsop1(a2,p2)=askFixityfixsop2when(p1==p2&&(a1/=a2||a1==AssocNone))-- Ambiguous infix expression!$fail"Ambiguous infix expression"if(p1>p2||p1==p2&&(a1==AssocLeft||a2==AssocNone))-- Already right orderthenreturn$InfixAppeop2zelseliftM(InfixAppxop1)(infFixfixs$InfixAppyop2z)_->return$InfixAppeop2zinfFix_e=returneinstanceAppFixityPatwhereapplyFixitiesfixs=infFixfixs<=<leafFixPfixswhere-- Same for patternsinfFixfixs(PInfixAppaop2z)=dop<-infFixfixsacasepofPInfixAppxop1y->dolet(a1,p1)=askFixityPfixsop1(a2,p2)=askFixityPfixsop2when(p1==p2&&(a1/=a2||a1==AssocNone))-- Ambiguous infix expression!$fail"Ambiguous infix expression"if(p1>p2||p1==p2&&(a1==AssocLeft||a2==AssocNone))-- Already right orderthenreturn$PInfixApppop2zelseliftM(PInfixAppxop1)(infFixfixs$PInfixAppyop2z)_->return$PInfixApppop2zinfFix_p=returnp-- Internal: lookup associativity and precedence of an operatoraskFixity::[Fixity]->QOp->(Assoc,Int)askFixityxsk=askFixxs(fk)-- undefined -- \k -> askFixityP xs (f k) -- lookupWithDefault (AssocLeft, 9) (f k) mpwheref(QVarOpx)=gxf(QConOpx)=gxg(SpecialCons)=UnQual(Symbol":")gx=x-- Same using patternsaskFixityP::[Fixity]->QName->(Assoc,Int)askFixityPxsqn=askFixxs(gqn)whereg(SpecialCons)=UnQual(Symbol":")gx=xaskFix::[Fixity]->QName->(Assoc,Int)askFixxs=\k->lookupWithDefault(AssocLeft,9)kmpwherelookupWithDefaultdefkmp=caselookupkmpofNothing->defJustx->xmp=[(x,(a,p))|Fixityapx<-xs]-- | All fixities defined in the Prelude.preludeFixities::[Fixity]preludeFixities=concat[infixr_9["."],infixl_9["!!"],infixr_8["^","^^","**"],infixl_7["*","/","`quot`","`rem`","`div`","`mod`",":%","%"],infixl_6["+","-"],infixr_5[":","++"],infix_4["==","/=","<","<=",">=",">","`elem`","`notElem`"],infixr_3["&&"],infixr_2["||"],infixl_1[">>",">>="],infixr_1["=<<"],infixr_0["$","$!","`seq`"]]-- | All fixities defined in the base package.---- Note that the @+++@ operator appears in both Control.Arrows and-- Text.ParserCombinators.ReadP. The listed precedence for @+++@ in-- this list is that of Control.Arrows.baseFixities::[Fixity]baseFixities=preludeFixities++concat[infixl_9["!","//","!:"],infixl_8["`shift`","`rotate`","`shiftL`","`shiftR`","`rotateL`","`rotateR`"],infixl_7[".&."],infixl_6["`xor`"],infix_6[":+"],infixl_5[".|."],infixr_5["+:+","<++","<+>"]-- fixity conflict for +++ between ReadP and Arrow,infix_5["\\\\"],infixl_4["<$>","<$","<*>","<*","*>","<**>"],infix_4["`elemP`","`notElemP`"],infixl_3["<|>"],infixr_3["&&&","***"],infixr_2["+++","|||"],infixr_1["<=<",">=>",">>>","<<<","^<<","<<^","^>>",">>^"],infixl_0["`on`"],infixr_0["`par`","`pseq`"]]infixr_,infixl_,infix_::Int->[String]->[Fixity]infixr_=fixityAssocRightinfixl_=fixityAssocLeftinfix_=fixityAssocNone-- Internal: help function for the above definitions.fixity::Assoc->Int->[String]->[Fixity]fixityap=map(Fixityap.op)whereop('`':xs)=UnQual$Ident$initxsopxs=UnQual$Symbolxs--------------------------------------------------------------------- Boilerplate - yuck!! Everything below here is internal stuffinstanceAppFixityModulewhereapplyFixitiesfixs(Modulelocnprsmwtextimpdecls)=liftM(Modulelocnprsmwtextimp)$appFixDeclsfixsdeclsinstanceAppFixityDeclwhereapplyFixitiesfixsdecl=casedeclofClassDecllocctxtnvarsdepscdecls->liftM(ClassDecllocctxtnvarsdeps)$mapMfixcdeclsInstDecllocctxtntsidecls->liftM(InstDecllocctxtnts)$mapMfixideclsSpliceDecllocspl->liftM(SpliceDeclloc)$fixsplFunBindmatches->liftMFunBind$mapMfixmatchesPatBindlocpmtrhsbs->liftM3(flip(PatBindloc)mt)(fixp)(fixrhs)(fixbs)AnnPragmalocann->liftM(AnnPragmaloc)$fixann_->returndeclwherefixx=applyFixitiesfixsxappFixDecls::Monadm=>[Fixity]->[Decl]->m[Decl]appFixDeclsfixsdecls=letextraFixs=getFixitiesdeclsinmapM(applyFixities(fixs++extraFixs))declswheregetFixities=concatMapgetFixitygetFixity(InfixDecl_apops)=map(Fixityap.g)opsgetFixity_=[]g(VarOpx)=UnQualxg(ConOpx)=UnQualxinstanceAppFixityAnnotationwhereapplyFixitiesfixsann=caseannofAnnne->liftM(Annn)$fixeTypeAnnne->liftM(TypeAnnn)$fixeModuleAnne->liftMModuleAnn$fixewherefixx=applyFixitiesfixsxinstanceAppFixityClassDeclwhereapplyFixitiesfixs(ClsDecldecl)=liftMClsDecl$applyFixitiesfixsdeclapplyFixities_cdecl=returncdeclinstanceAppFixityInstDeclwhereapplyFixitiesfixs(InsDecldecl)=liftMInsDecl$applyFixitiesfixsdeclapplyFixities_idecl=returnideclinstanceAppFixityMatchwhereapplyFixitiesfixs(Matchlocnpsmtrhsbs)=liftM3(flip(Matchlocn)mt)(mapMfixps)(fixrhs)(fixbs)wherefixx=applyFixitiesfixsxinstanceAppFixityRhswhereapplyFixitiesfixsrhs=caserhsofUnGuardedRhse->liftMUnGuardedRhs$fixeGuardedRhssgrhss->liftMGuardedRhss$mapMfixgrhsswherefixx=applyFixitiesfixsxinstanceAppFixityGuardedRhswhereapplyFixitiesfixs(GuardedRhslocstmtse)=liftM2(GuardedRhsloc)(mapMfixstmts)$fixewherefixx=applyFixitiesfixsxinstanceAppFixityPatFieldwhereapplyFixitiesfixs(PFieldPatnp)=liftM(PFieldPatn)$applyFixitiesfixspapplyFixities_pf=returnpfinstanceAppFixityRPatwhereapplyFixitiesfixsrp=caserpofRPOprpop->liftM(flipRPOpop)(fixrp)RPEitherab->liftM2RPEither(fixa)(fixb)RPSeqrps->liftMRPSeq$mapMfixrpsRPGuardpstmts->liftM2RPGuard(fixp)$mapMfixstmtsRPCAsnrp->liftM(RPCAsn)$fixrpRPAsnrp->liftM(RPAsn)$fixrpRPParenrp->liftMRPParen$fixrpRPPatp->liftMRPPat$fixpwherefixx=applyFixitiesfixsxinstanceAppFixityPXAttrwhereapplyFixitiesfixs(PXAttrnp)=liftM(PXAttrn)$applyFixitiesfixspinstanceAppFixityStmtwhereapplyFixitiesfixsstmt=casestmtofGeneratorlocpe->liftM2(Generatorloc)(fixp)(fixe)Qualifiere->liftMQualifier$fixeLetStmtbs->liftMLetStmt$fixbs-- special behaviorRecStmtstmts->liftMRecStmt$mapMfixstmtswherefixx=applyFixitiesfixsxinstanceAppFixityBindswhereapplyFixitiesfixsbs=casebsofBDeclsdecls->liftMBDecls$appFixDeclsfixsdecls-- special behaviorIPBindsips->liftMIPBinds$mapMfixipswherefixx=applyFixitiesfixsxinstanceAppFixityIPBindwhereapplyFixitiesfixs(IPBindlocne)=liftM(IPBindlocn)$applyFixitiesfixseinstanceAppFixityFieldUpdatewhereapplyFixitiesfixs(FieldUpdatene)=liftM(FieldUpdaten)$applyFixitiesfixseapplyFixities_fup=returnfupinstanceAppFixityAltwhereapplyFixitiesfixs(Altlocpgaltsbs)=liftM3(Altloc)(fixp)(fixgalts)(fixbs)wherefixx=applyFixitiesfixsxinstanceAppFixityGuardedAltswhereapplyFixitiesfixsgalts=casegaltsofUnGuardedAlte->liftMUnGuardedAlt$fixeGuardedAltsgalts->liftMGuardedAlts$mapMfixgaltswherefixx=applyFixitiesfixsxinstanceAppFixityGuardedAltwhereapplyFixitiesfixs(GuardedAltlocstmtse)=liftM2(GuardedAltloc)(mapMfixstmts)(fixe)wherefixx=applyFixitiesfixsxinstanceAppFixityQualStmtwhereapplyFixitiesfixsqstmt=caseqstmtofQualStmts->liftMQualStmt$fixsThenTranse->liftMThenTrans$fixeThenBye1e2->liftM2ThenBy(fixe1)(fixe2)GroupBye->liftMGroupBy(fixe)GroupUsinge->liftMGroupUsing(fixe)GroupByUsinge1e2->liftM2GroupByUsing(fixe1)(fixe2)wherefixx=applyFixitiesfixsxinstanceAppFixityBracketwhereapplyFixitiesfixsbr=casebrofExpBrackete->liftMExpBracket$fixePatBracketp->liftMPatBracket$fixpDeclBracketds->liftMDeclBracket$mapMfixds_->returnbrwherefixx=applyFixitiesfixsxinstanceAppFixitySplicewhereapplyFixitiesfixs(ParenSplicee)=liftMParenSplice$applyFixitiesfixseapplyFixities_s=returnsinstanceAppFixityXAttrwhereapplyFixitiesfixs(XAttrne)=liftM(XAttrn)$applyFixitiesfixse-- the boring boilerplate stuff for expressions too-- Recursively fixes the "leaves" of the infix chains,-- without yet touching the chain itself. We assume all chains are-- left-associate to begin with.leafFixfixse=caseeofInfixAppe1ope2->liftM2(flipInfixAppop)(leafFixfixse1)(fixe2)Appe1e2->liftM2App(fixe1)(fixe2)NegAppe->liftMNegApp$fixeLambdalocpatse->liftM2(Lambdaloc)(mapMfixpats)$fixeLetbse->liftM2Let(fixbs)$fixeIfeab->liftM3If(fixe)(fixa)(fixb)Caseealts->liftM2Case(fixe)$mapMfixaltsDostmts->liftMDo$mapMfixstmtsMDostmts->liftMMDo$mapMfixstmtsTupleexps->liftMTuple$mapMfixexpsListexps->liftMList$mapMfixexpsParene->liftMParen$fixeLeftSectioneop->liftM(flipLeftSectionop)(fixe)RightSectionope->liftM(RightSectionop)$fixeRecConstrnfups->liftM(RecConstrn)$mapMfixfupsRecUpdateefups->liftM2RecUpdate(fixe)$mapMfixfupsEnumFrome->liftMEnumFrom$fixeEnumFromToe1e2->liftM2EnumFromTo(fixe1)(fixe2)EnumFromThene1e2->liftM2EnumFromThen(fixe1)(fixe2)EnumFromThenToe1e2e3->liftM3EnumFromThenTo(fixe1)(fixe2)(fixe3)ListCompequals->liftM2ListComp(fixe)$mapMfixqualsParCompequalss->liftM2ParComp(fixe)$mapM(mapMfix)qualssExpTypeSiglocet->liftM(flip(ExpTypeSigloc)t)(fixe)BracketExpb->liftMBracketExp$fixbSpliceExps->liftMSpliceExp$fixsXTaglocnatsmexpcs->liftM3(XTaglocn)(mapMfixats)(mapMfixmexp)(mapMfixcs)XETaglocnatsmexp->liftM2(XETaglocn)(mapMfixats)(mapMfixmexp)XExpTage->liftMXExpTag$fixeXChildTagloccs->liftM(XChildTagloc)$mapMfixcsProclocpe->liftM2(Procloc)(fixp)(fixe)LeftArrAppe1e2->liftM2LeftArrApp(fixe1)(fixe2)RightArrAppe1e2->liftM2RightArrApp(fixe1)(fixe2)LeftArrHighAppe1e2->liftM2LeftArrHighApp(fixe1)(fixe2)RightArrHighAppe1e2->liftM2RightArrHighApp(fixe1)(fixe2)CorePragmase->liftM(CorePragmas)(fixe)SCCPragmase->liftM(SCCPragmas)(fixe)GenPragmasabcde->liftM(GenPragmasabcd)(fixe)_->returnewherefixx=applyFixitiesfixsxleafFixPfixsp=casepofPNegp->liftMPNeg$fixpPAppnps->liftM(PAppn)$mapMfixpsPTupleps->liftMPTuple$mapMfixpsPListps->liftMPList$mapMfixpsPParenp->liftMPParen$fixpPRecnpfs->liftM(PRecn)$mapMfixpfsPAsPatnp->liftM(PAsPatn)$fixpPIrrPatp->liftMPIrrPat$fixpPatTypeSiglocpt->liftM(flip(PatTypeSigloc)t)(fixp)PViewPatep->liftM2PViewPat(fixe)(fixp)PRPatrps->liftMPRPat$mapMfixrpsPXTaglocnatsmpps->liftM3(PXTaglocn)(mapMfixats)(mapMfixmp)(mapMfixps)PXETaglocnatsmp->liftM2(PXETaglocn)(mapMfixats)(mapMfixmp)PXPatTagp->liftMPXPatTag$fixpPXRPatsrps->liftMPXRPats$mapMfixrpsPBangPatp->liftMPBangPat$fixp_->returnpwherefixx=applyFixitiesfixsx