{-# LANGUAGE DeriveDataTypeable #-}{-# LANGUAGE CPP #-}------------------------------------------------------------------------------- |-- 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.SyntaximportLanguage.Haskell.Exts.SrcLocimportControl.Monad(when,(<=<),liftM,liftM2,liftM3,liftM4)importData.Traversable(mapM)importData.Maybe(fromMaybe)importData.TypeableimportData.Datahiding(Fixity)#if __GLASGOW_HASKELL__ < 710importControl.Applicative((<$))#endifimportPreludehiding(mapM)-- | Operator fixities are represented by their associativity-- (left, right or none) and their precedence (0-9).dataFixity=Fixity(Assoc())Int(QName())deriving(Eq,Ord,Show,Typeable,Data)-- | 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.->astSrcSpanInfo-- ^ The element to tweak.->m(astSrcSpanInfo)-- ^ The same element, but with operator expressions updated, or a failure.assocNone,assocLeft,assocRight::Assoc()assocNone=AssocNone()assocLeft=AssocLeft()assocRight=AssocRight()instanceAppFixityExpwhereapplyFixitiesfixs'=infFixfixs'<=<leafFixfixs'where-- This is the real meat case. We can assume a left-associative list to begin with.infFixfixs(InfixAppl2aop2z)=doe<-infFixfixsaletfixup(a1,p1)(a2,p2)ypre=dowhen(p1==p2&&(a1/=a2||a1==assocNone))-- Ambiguous infix expression!$fail"Ambiguous infix expression"ifp1>p2||p1==p2&&(a1==assocLeft||a2==assocNone)-- Already right orderthenreturn$InfixAppl2eop2zelseliftMpre(infFixfixs$InfixApp(anny<++>annz)yop2z)caseeofInfixApp_xop1y->fixup(askFixityfixsop1)(askFixityfixsop2)y(InfixAppl2xop1)NegApp_y->fixupprefixMinusFixity(askFixityfixsop2)y(NegAppl2)_->return$InfixAppl2eop2zinfFix_e=returne--ambOps l = ParseFailed (getPointLoc l) $ "Ambiguous infix expression"instanceAppFixityPatwhereapplyFixitiesfixs'=infFixfixs'<=<leafFixPfixs'where-- This is the real meat case. We can assume a left-associative list to begin with.infFixfixs(PInfixAppl2aop2z)=dop<-infFixfixsaletfixup(a1,p1)(a2,p2)ypre=dowhen(p1==p2&&(a1/=a2||a1==assocNone))-- Ambiguous infix expression!$fail"Ambiguous infix expression"ifp1>p2||p1==p2&&(a1==assocLeft||a2==assocNone)-- Already right orderthenreturn$PInfixAppl2pop2zelseliftMpre(infFixfixs$PInfixApp(anny<++>annz)yop2z)casepofPInfixApp_xop1y->fixup(askFixityPfixsop1)(askFixityPfixsop2)y(PInfixAppl2xop1)_->return$PInfixAppl2pop2zinfFix_p=returnp-- Internal: lookup associativity and precedence of an operatoraskFixity::[Fixity]->QOpl->(Assoc(),Int)askFixityxsk=askFixxs(f(()<$k))wheref(QVarOp_x)=gxf(QConOp_x)=gxg(Special_(Cons_))=UnQual()(Symbol()":")gx=x-- Same using patternsaskFixityP::[Fixity]->QNamel->(Assoc(),Int)askFixityPxsqn=askFixxs(g(()<$qn))whereg(Special_(Cons_))=UnQual()(Symbol()":")gx=xaskFix::[Fixity]->QNamel->(Assoc(),Int)askFixxs=\k->lookupWithDefault(assocLeft,9)(()<$k)mpwherelookupWithDefaultdefkmp'=fromMaybedef$lookupkmp'mp=[(x,(a,p))|Fixityapx<-xs]-- | Built-in fixity for prefix minusprefixMinusFixity::(Assoc(),Int)prefixMinusFixity=(AssocLeft(),6)-- | 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`"],infixl_4["<$>","<$","<*>","<*","*>"],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_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()$Symbol()xs--------------------------------------------------------------------- Boilerplate - yuck!! Everything below here is internal stuffinstanceAppFixityModulewhereapplyFixitiesfixs(Modulelmmhprsimpdecls)=liftM(Modulelmmhprsimp)$appFixDeclsmmnfixsdeclswheremmn=getMmnmmhgetMmn(Just(ModuleHead_n__))=JustngetMmn_=NothingapplyFixitiesfixs(XmlPagelmnosxnxasmexpcs)=liftM3(XmlPagelmnosxn)(fixxas)(fixmexp)(fixcs)wherefixxs=mapM(applyFixitiesfixs)xsapplyFixitiesfixs(XmlHybridlmmhprsimpdeclsxnxasmexpcs)=liftM4(flip(XmlHybridlmmhprsimp)xn)(appFixDeclsmmnfixsdecls)(fixexas)(fixemexp)(fixecs)wheremmn=getMmnmmhgetMmn(Just(ModuleHead_n__))=JustngetMmn_=Nothingfixexs=letextraFixs=getFixitiesmmndeclsinmapM(applyFixities(fixs++extraFixs))xsinstanceAppFixityDeclwhereapplyFixitiesfixsdecl=casedeclofClassDecllctxtdhdepscdecls->liftM(ClassDecllctxtdhdeps)$mapM(mapMfix)cdeclsInstDecllolpihidecls->liftM(InstDecllolpih)$mapM(mapMfix)ideclsSpliceDecllspl->liftM(SpliceDecll)$fixsplFunBindlmatches->liftM(FunBindl)$mapMfixmatchesPatBindlprhsbs->letextraFixx=applyFixities(fixs++maybe[]getBindFixitiesbs)xinliftM3(PatBindl)(extraFixp)(extraFixrhs)(mapMextraFixbs)AnnPragmalann'->liftM(AnnPragmal)$fixann'PatSynlp1p2dir->liftM(PatSynlp1p2)(fixdir)_->returndeclwherefixx=applyFixitiesfixsxinstanceAppFixityPatternSynDirectionwhereapplyFixitiesfixsdir=casedirofExplicitBidirectionallds->liftM(ExplicitBidirectionall)(mapMfixds)_->returndirwherefixx=applyFixitiesfixsxappFixDecls::Monadm=>Maybe(ModuleNameSrcSpanInfo)->[Fixity]->[DeclSrcSpanInfo]->m[DeclSrcSpanInfo]appFixDeclsmmdlfixsdecls=letextraFixs=getFixitiesmmdldeclsinmapM(applyFixities(fixs++extraFixs))declsgetFixities::Maybe(ModuleNamel)->[Decll]->[Fixity]getFixitiesmmdl=concatMap(getFixitymmdl)getFixity::Maybe(ModuleNamel)->Decll->[Fixity]getFixitymmdld=casedofInfixDecl_ampops->letp=fromMaybe9mpinmap(Fixity(scruba)p)(concatMapg(mapscrubops))ClassDecl____cds->maybe[](concatMapgetClassFixity)cds_->[]whereg(VarOp_x)=fxg(ConOp_x)=fxfx=casemmdlofNothing->[UnQual()x]Justm->[Qual()(scrubm)x,UnQual()x]getClassFixity(ClsDecl_cd)=getFixitymmdlcdgetClassFixity_=[]scrub::Functorf=>fa->f()scrubf=()<$fgetBindFixities::Bindsl->[Fixity]getBindFixitiesbs=casebsofBDecls_ds->getFixitiesNothingds_->[]instanceAppFixityAnnotationwhereapplyFixitiesfixsann'=caseann'ofAnnlne->liftM(Annln)$fixeTypeAnnlne->liftM(TypeAnnln)$fixeModuleAnnle->liftM(ModuleAnnl)$fixewherefixx=applyFixitiesfixsxinstanceAppFixityClassDeclwhereapplyFixitiesfixs(ClsDeclldecl)=liftM(ClsDecll)$applyFixitiesfixsdeclapplyFixities_cdecl=returncdeclinstanceAppFixityInstDeclwhereapplyFixitiesfixs(InsDeclldecl)=liftM(InsDecll)$applyFixitiesfixsdeclapplyFixities_idecl=returnideclinstanceAppFixityMatchwhereapplyFixitiesfixsmatch=casematchofMatchlnpsrhsbs->liftM3(Matchln)(mapM(fixbs)ps)(fixbsrhs)(mapM(fixbs)bs)InfixMatchlanpsrhsbs->liftM4(flip(InfixMatchl)n)(fixbsa)(mapM(fixbs)ps)(fixbsrhs)(mapM(fixbs)bs)wherefixbsx=applyFixitiesfixs'xwherefixs'=fixs++maybe[]getBindFixitiesbsinstanceAppFixityRhswhereapplyFixitiesfixsrhs=caserhsofUnGuardedRhsle->liftM(UnGuardedRhsl)$fixeGuardedRhsslgrhss->liftM(GuardedRhssl)$mapMfixgrhsswherefixx=applyFixitiesfixsxinstanceAppFixityGuardedRhswhereapplyFixitiesfixs(GuardedRhslstmtse)=liftM2(GuardedRhsl)(mapMfixstmts)$fixewherefixx=applyFixitiesfixsxinstanceAppFixityPatFieldwhereapplyFixitiesfixs(PFieldPatlnp)=liftM(PFieldPatln)$applyFixitiesfixspapplyFixities_pf=returnpfinstanceAppFixityRPatwhereapplyFixitiesfixsrp'=caserp'ofRPOplrpop->liftM(flip(RPOpl)op)$fixrpRPEitherlab->liftM2(RPEitherl)(fixa)(fixb)RPSeqlrps->liftM(RPSeql)$mapMfixrpsRPGuardlpstmts->liftM2(RPGuardl)(fixp)$mapMfixstmtsRPCAslnrp->liftM(RPCAsln)$fixrpRPAslnrp->liftM(RPAsln)$fixrpRPParenlrp->liftM(RPParenl)$fixrpRPPatlp->liftM(RPPatl)$fixpwherefixx=applyFixitiesfixsxinstanceAppFixityPXAttrwhereapplyFixitiesfixs(PXAttrlnp)=liftM(PXAttrln)$applyFixitiesfixspinstanceAppFixityStmtwhereapplyFixitiesfixsstmt=casestmtofGeneratorlpe->liftM2(Generatorl)(fixp)(fixe)Qualifierle->liftM(Qualifierl)$fixeLetStmtlbs->liftM(LetStmtl)$fixbs-- special behaviorRecStmtlstmts->liftM(RecStmtl)$mapMfixstmtswherefixx=applyFixitiesfixsxinstanceAppFixityBindswhereapplyFixitiesfixsbs=casebsofBDeclsldecls->liftM(BDeclsl)$appFixDeclsNothingfixsdecls-- special behaviorIPBindslips->liftM(IPBindsl)$mapMfixipswherefixx=applyFixitiesfixsxinstanceAppFixityIPBindwhereapplyFixitiesfixs(IPBindlne)=liftM(IPBindln)$applyFixitiesfixseinstanceAppFixityFieldUpdatewhereapplyFixitiesfixs(FieldUpdatelne)=liftM(FieldUpdateln)$applyFixitiesfixseapplyFixities_fup=returnfupinstanceAppFixityAltwhereapplyFixitiesfixs(Altlpgaltsbs)=liftM3(Altl)(fixp)(fixgalts)(mapMfixbs)wherefixx=applyFixitiesfixsxinstanceAppFixityQualStmtwhereapplyFixitiesfixsqstmt=caseqstmtofQualStmtls->liftM(QualStmtl)$fixsThenTransle->liftM(ThenTransl)$fixeThenByle1e2->liftM2(ThenByl)(fixe1)(fixe2)GroupByle->liftM(GroupByl)(fixe)GroupUsingle->liftM(GroupUsingl)(fixe)GroupByUsingle1e2->liftM2(GroupByUsingl)(fixe1)(fixe2)wherefixx=applyFixitiesfixsxinstanceAppFixityBracketwhereapplyFixitiesfixsbr=casebrofExpBracketle->liftM(ExpBracketl)$fixePatBracketlp->liftM(PatBracketl)$fixpDeclBracketlds->liftM(DeclBracketl)$mapMfixds_->returnbrwherefixx=applyFixitiesfixsxinstanceAppFixitySplicewhereapplyFixitiesfixs(ParenSplicele)=liftM(ParenSplicel)$applyFixitiesfixseapplyFixities_s=returnsinstanceAppFixityXAttrwhereapplyFixitiesfixs(XAttrlne)=liftM(XAttrln)$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.leafFix::Monadm=>[Fixity]->ExpSrcSpanInfo->m(ExpSrcSpanInfo)leafFixfixse'=casee'ofInfixApple1ope2->liftM2(flip(InfixAppl)op)(leafFixfixse1)(fixe2)Apple1e2->liftM2(Appl)(fixe1)(fixe2)NegApple->liftM(NegAppl)$fixeLambdalpatse->liftM2(Lambdal)(mapMfixpats)$fixeLetlbse->letextraFixx=applyFixities(fixs++getBindFixitiesbs)xinliftM2(Letl)(extraFixbs)$extraFixeIfleab->liftM3(Ifl)(fixe)(fixa)(fixb)MultiIflalts->liftM(MultiIfl)(mapMfixalts)Caselealts->liftM2(Casel)(fixe)$mapMfixaltsDolstmts->liftM(Dol)$mapMfixstmtsMDolstmts->liftM(MDol)$mapMfixstmtsTuplelbxexps->liftM(Tuplelbx)$mapMfixexpsListlexps->liftM(Listl)$mapMfixexpsParenle->liftM(Parenl)$fixeLeftSectionleop->liftM(flip(LeftSectionl)op)(fixe)RightSectionlope->liftM(RightSectionlop)$fixeRecConstrlnfups->liftM(RecConstrln)$mapMfixfupsRecUpdatelefups->liftM2(RecUpdatel)(fixe)$mapMfixfupsEnumFromle->liftM(EnumFroml)$fixeEnumFromTole1e2->liftM2(EnumFromTol)(fixe1)(fixe2)EnumFromThenle1e2->liftM2(EnumFromThenl)(fixe1)(fixe2)EnumFromThenTole1e2e3->liftM3(EnumFromThenTol)(fixe1)(fixe2)(fixe3)ListComplequals->liftM2(ListCompl)(fixe)$mapMfixqualsParComplequalss->liftM2(ParCompl)(fixe)$mapM(mapMfix)qualssExpTypeSiglet->liftM(flip(ExpTypeSigl)t)(fixe)BracketExplb->liftM(BracketExpl)$fixbSpliceExpls->liftM(SpliceExpl)$fixsXTaglnatsmexpcs->liftM3(XTagln)(mapMfixats)(mapMfixmexp)(mapMfixcs)XETaglnatsmexp->liftM2(XETagln)(mapMfixats)(mapMfixmexp)XExpTagle->liftM(XExpTagl)$fixeXChildTaglcs->liftM(XChildTagl)$mapMfixcsProclpe->liftM2(Procl)(fixp)(fixe)LeftArrApple1e2->liftM2(LeftArrAppl)(fixe1)(fixe2)RightArrApple1e2->liftM2(RightArrAppl)(fixe1)(fixe2)LeftArrHighApple1e2->liftM2(LeftArrHighAppl)(fixe1)(fixe2)RightArrHighApple1e2->liftM2(RightArrHighAppl)(fixe1)(fixe2)CorePragmalse->liftM(CorePragmals)(fixe)SCCPragmalse->liftM(SCCPragmals)(fixe)GenPragmalsabcde->liftM(GenPragmalsabcd)(fixe)LCaselalts->liftM(LCasel)$mapMfixalts_->returne'wherefixx=applyFixitiesfixsxleafFixP::Monadm=>[Fixity]->PatSrcSpanInfo->m(PatSrcSpanInfo)leafFixPfixsp'=casep'ofPInfixApplp1opp2->liftM2(flip(PInfixAppl)op)(leafFixPfixsp1)(fixp2)PApplnps->liftM(PAppln)$mapMfixpsPTuplelbxps->liftM(PTuplelbx)$mapMfixpsPListlps->liftM(PListl)$mapMfixpsPParenlp->liftM(PParenl)$fixpPReclnpfs->liftM(PRecln)$mapMfixpfsPAsPatlnp->liftM(PAsPatln)$fixpPIrrPatlp->liftM(PIrrPatl)$fixpPatTypeSiglpt->liftM(flip(PatTypeSigl)t)(fixp)PViewPatlep->liftM2(PViewPatl)(fixe)(fixp)PRPatlrps->liftM(PRPatl)$mapMfixrpsPXTaglnatsmpps->liftM3(PXTagln)(mapMfixats)(mapMfixmp)(mapMfixps)PXETaglnatsmp->liftM2(PXETagln)(mapMfixats)(mapMfixmp)PXPatTaglp->liftM(PXPatTagl)$fixpPXRPatslrps->liftM(PXRPatsl)$mapMfixrpsPBangPatlp->liftM(PBangPatl)$fixp_->returnp'wherefixx=applyFixitiesfixsx