moduleLanguage.Haskell.Exts.FixitywhereimportLanguage.Haskell.Exts.SyntaximportData.Char(isUpper)--------------------------------------------------------------dataFixity=FixityAssocIntOpclassAppFixityastwhereapplyFixities::[Fixity]->ast->astinstanceAppFixityExpwhere-- This is the real meat case. We can assume a left-associative list to begin with.applyFixitiesfixs(InfixAppaop2z)=lete=applyFixitiesfixsaincaseeofInfixAppxop1y->let(a1,p1)=askFixityfixsop1(a2,p2)=askFixityfixsop2inif(p1==p2&&(a1/=a2||a1==AssocNone))-- Ambiguous infix expression!||(p1>p2||p1==p2&&(a1==AssocLeft||a2==AssocNone))-- Already right orderthenInfixAppeop2zelseInfixAppxop1(applyFixitiesfixs$InfixAppyop2z)_->InfixAppeop2z-- the boilerplateapplyFixitiesfixse=appFixExpfixseaskFixity::[Fixity]->QOp->(Assoc,Int)askFixityxs=\k->lookupWithDefault(AssocLeft,9)(fk)mpwherelookupWithDefaultdefkmp=caselookupkmpofNothing->defJustx->xmp=[(x,(a,p))|Fixityapx<-xs]f(QVarOpx)=VarOp(gx)f(QConOpx)=ConOp(gx)g(Qual_x)=xg(UnQualx)=xg(SpecialCons)=Symbol":"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`"]]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_=fixityAssocRightinfixl_=fixityAssocLeftinfix_=fixityAssocNonefixity::Assoc->Int->[String]->[Fixity]fixityap=map(Fixityap.op)whereop('`':xs)=(ifisUpper(headxs)thenConOpelseVarOp)$Ident$initxsopxs=(ifheadxs==':'thenConOpelseVarOp)$Symbolxs--------------------------------------------------------------------- Boilerplate - yuck!!instanceAppFixityModulewhereapplyFixitiesfixs(Modulelocnprsmwtextimpdecls)=Modulelocnprsmwtextimp$appFixDeclsfixsdeclsinstanceAppFixityDeclwhereapplyFixitiesfixsdecl=casedeclofClassDecllocctxtnvarsdepscdecls->ClassDecllocctxtnvarsdeps$mapfixcdeclsInstDecllocctxtntsidecls->InstDecllocctxtnts$mapfixideclsSpliceDecllocspl->SpliceDeclloc$fixsplFunBindmatches->FunBind$mapfixmatchesPatBindlocpmtrhsbs->PatBindloc(fixp)mt(fixrhs)(fixbs)_->declwherefixx=applyFixitiesfixsxappFixDecls::[Fixity]->[Decl]->[Decl]appFixDeclsfixsdecls=letextraFixs=getFixitiesdeclsinmap(applyFixities(fixs++extraFixs))declswheregetFixities=concatMapgetFixitygetFixity(InfixDecl_apops)=map(Fixityap)opsgetFixity_=[]instanceAppFixityClassDeclwhereapplyFixitiesfixs(ClsDecldecl)=ClsDecl$applyFixitiesfixsdeclapplyFixities_cdecl=cdeclinstanceAppFixityInstDeclwhereapplyFixitiesfixs(InsDecldecl)=InsDecl$applyFixitiesfixsdeclapplyFixities_idecl=ideclinstanceAppFixityMatchwhereapplyFixitiesfixs(Matchlocnpsmtrhsbs)=Matchlocn(mapfixps)mt(fixrhs)(fixbs)wherefixx=applyFixitiesfixsxinstanceAppFixityRhswhereapplyFixitiesfixsrhs=caserhsofUnGuardedRhse->UnGuardedRhs$fixeGuardedRhssgrhss->GuardedRhss$mapfixgrhsswherefixx=applyFixitiesfixsxinstanceAppFixityGuardedRhswhereapplyFixitiesfixs(GuardedRhslocstmtse)=GuardedRhsloc(mapfixstmts)$fixewherefixx=applyFixitiesfixsxinstanceAppFixityPatwhereapplyFixitiesfixsp=casepofPNegp->PNeg$fixpPInfixAppaopb->PInfixApp(fixa)op(fixb)PAppnps->PAppn$mapfixpsPTupleps->PTuple$mapfixpsPListps->PList$mapfixpsPParenp->PParen$fixpPRecnpfs->PRecn$mapfixpfsPAsPatnp->PAsPatn$fixpPIrrPatp->PIrrPat$fixpPatTypeSiglocpt->PatTypeSigloc(fixp)tPViewPatep->PViewPat(fixe)(fixp)PRPatrps->PRPat$mapfixrpsPXTaglocnatsmpps->PXTaglocn(mapfixats)(fmapfixmp)(mapfixps)PXETaglocnatsmp->PXETaglocn(mapfixats)(fmapfixmp)PXPatTagp->PXPatTag$fixpPXRPatsrps->PXRPats$mapfixrpsPBangPatp->PBangPat$fixp_->pwherefixx=applyFixitiesfixsxinstanceAppFixityPatFieldwhereapplyFixitiesfixs(PFieldPatnp)=PFieldPatn$applyFixitiesfixspapplyFixities_pf=pfinstanceAppFixityRPatwhereapplyFixitiesfixsrp=caserpofRPOprpop->RPOp(fixrp)opRPEitherab->RPEither(fixa)(fixb)RPSeqrps->RPSeq$mapfixrpsRPGuardpstmts->RPGuard(fixp)$mapfixstmtsRPCAsnrp->RPCAsn$fixrpRPAsnrp->RPAsn$fixrpRPParenrp->RPParen$fixrpRPPatp->RPPat$fixpwherefixx=applyFixitiesfixsxinstanceAppFixityPXAttrwhereapplyFixitiesfixs(PXAttrnp)=PXAttrn$applyFixitiesfixspinstanceAppFixityStmtwhereapplyFixitiesfixsstmt=casestmtofGeneratorlocpe->Generatorloc(fixp)(fixe)Qualifiere->Qualifier$fixeLetStmtbs->LetStmt$fixbs-- special behaviorRecStmtstmts->RecStmt$mapfixstmtswherefixx=applyFixitiesfixsxinstanceAppFixityBindswhereapplyFixitiesfixsbs=casebsofBDeclsdecls->BDecls$appFixDeclsfixsdecls-- special behaviorIPBindsips->IPBinds$mapfixipswherefixx=applyFixitiesfixsxinstanceAppFixityIPBindwhereapplyFixitiesfixs(IPBindlocne)=IPBindlocn$applyFixitiesfixseinstanceAppFixityFieldUpdatewhereapplyFixitiesfixs(FieldUpdatene)=FieldUpdaten$applyFixitiesfixseapplyFixities_fup=fupinstanceAppFixityAltwhereapplyFixitiesfixs(Altlocpgaltsbs)=Altloc(fixp)(fixgalts)(fixbs)wherefixx=applyFixitiesfixsxinstanceAppFixityGuardedAltswhereapplyFixitiesfixsgalts=casegaltsofUnGuardedAlte->UnGuardedAlt$fixeGuardedAltsgalts->GuardedAlts$mapfixgaltswherefixx=applyFixitiesfixsxinstanceAppFixityGuardedAltwhereapplyFixitiesfixs(GuardedAltlocstmtse)=GuardedAltloc(mapfixstmts)(fixe)wherefixx=applyFixitiesfixsxinstanceAppFixityQualStmtwhereapplyFixitiesfixsqstmt=caseqstmtofQualStmts->QualStmt$fixsThenTranse->ThenTrans$fixeThenBye1e2->ThenBy(fixe1)(fixe2)GroupBye->GroupBy(fixe)GroupUsinge->GroupUsing(fixe)GroupByUsinge1e2->GroupByUsing(fixe1)(fixe2)wherefixx=applyFixitiesfixsxinstanceAppFixityBracketwhereapplyFixitiesfixsbr=casebrofExpBrackete->ExpBracket$fixePatBracketp->PatBracket$fixpDeclBracketds->DeclBracket$mapfixds_->brwherefixx=applyFixitiesfixsxinstanceAppFixitySplicewhereapplyFixitiesfixs(ParenSplicee)=ParenSplice$applyFixitiesfixseapplyFixities_s=sinstanceAppFixityXAttrwhereapplyFixitiesfixs(XAttrne)=XAttrn$applyFixitiesfixse-- the boring boilerplate stuff for expressions tooappFixExpfixse=caseeofAppe1e2->App(fixe1)(fixe2)NegAppe->NegApp$fixeLambdalocpatse->Lambdaloc(mapfixpats)$fixeLetbse->Let(fixbs)$fixeIfeab->If(fixe)(fixa)(fixb)Caseealts->Case(fixe)$mapfixaltsDostmts->Do$mapfixstmtsMDostmts->MDo$mapfixstmtsTupleexps->Tuple$mapfixexpsListexps->Tuple$mapfixexpsParene->Paren$fixeLeftSectioneop->LeftSection(fixe)opRightSectionope->RightSectionop$fixeRecConstrnfups->RecConstrn$mapfixfupsRecUpdateefups->RecUpdate(fixe)$mapfixfupsEnumFrome->EnumFrom$fixeEnumFromToe1e2->EnumFromTo(fixe1)(fixe2)EnumFromThene1e2->EnumFromThen(fixe1)(fixe2)EnumFromThenToe1e2e3->EnumFromThenTo(fixe1)(fixe2)(fixe3)ListCompequals->ListComp(fixe)$mapfixqualsParCompequalss->ParComp(fixe)$map(mapfix)qualssExpTypeSiglocet->ExpTypeSigloc(fixe)tBracketExpb->BracketExp$fixbSpliceExps->SpliceExp$fixsXTaglocnatsmexpcs->XTaglocn(mapfixats)(fmapfixmexp)(mapfixcs)XETaglocnatsmexp->XETaglocn(mapfixats)(fmapfixmexp)XExpTage->XExpTag$fixeProcpe->Proc(fixp)(fixe)LeftArrAppe1e2->LeftArrApp(fixe1)(fixe2)RightArrAppe1e2->RightArrApp(fixe1)(fixe2)LeftArrHighAppe1e2->LeftArrHighApp(fixe1)(fixe2)RightArrHighAppe1e2->RightArrHighApp(fixe1)(fixe2)_->ewherefixx=applyFixitiesfixsx