module Lambdabot.FixPrecedence (withPrecExp, withPrecDecl, precTable, FixPrecedence(..) ) where import qualified Data.Map as M import Language.Haskell.Syntax import Data.List {- PrecedenceData This is a data type to hold precedence information. It simply records, for each operator, its precedence level (a number), and associativity (one of HsAssocNone, HsAssocLeft, or HsAssocRight). -} type PrecedenceData = M.Map HsQName (HsAssoc, Int) {- findPrec Looks up precedence information for a goven operator. If the operator is not in the precedence data, the Haskell report specifies that it should be treated as infixl 9. -} findPrec :: PrecedenceData -> HsQName -> (HsAssoc, Int) findPrec = flip (M.findWithDefault defaultPrec) where defaultPrec = (HsAssocLeft, 9) {- precWrong This returns True iff the first operator should be a parent of the second in the expression tree, when they occur consecutively left to right in the input. This is called "wrong" because the parser in Language.Haskell.Parser treats everything as left associative at the same precedence, so the right-most operator will be the parent in the expression tree in the original input. XXX: Currently, this function treats operators with no associativity as if they were left associative. It also looks only at the associativity of the left-most operator. This should work for correct code, but it does not report errors for incorrect code. -} precWrong :: PrecedenceData -> HsQName -> HsQName -> Bool precWrong pd a b = let (assoc, prec) = findPrec pd a (_, prec') = findPrec pd b in (prec < prec') || (prec == prec' && assoc == HsAssocRight) {- nameFromQOp Extracts the HsQName from an HsQOp. -} nameFromQOp :: HsQOp -> HsQName nameFromQOp (HsQVarOp s) = s nameFromQOp (HsQConOp s) = s nameFromOp :: HsOp -> HsQName nameFromOp (HsVarOp n) = UnQual n nameFromOp (HsConOp n) = UnQual n {- withPrecExp This routine fixes up an expression by applying precedence data. -} withPrecExp :: PrecedenceData -> HsExp -> HsExp {- This is the heart of the whole thing. It applies an algorithm described by LaLonde and Rivieres in ACM Transactions on Programming Languages and Systems, January 1981. The idea is to take a parse tree with a consistent left-associative organization, and rearrange it to match a precedence table. A few changes have been made. LaLonde and Rivieres remove parentheses from their parse tree, which isn't necessary here; and they work with an inherently right-associative grammar, while Language.Haskell.Parser produces a left-associative grammar. -} withPrecExp pd (HsInfixApp k@(HsInfixApp e qop' f) qop g) = let g' = withPrecExp pd g op = nameFromQOp qop op' = nameFromQOp qop' in if precWrong pd op' op then let e' = withPrecExp pd e f' = withPrecExp pd f in withPrecExp pd (HsInfixApp e' qop' (HsInfixApp f' qop g')) else HsInfixApp (withPrecExp pd k) qop g' withPrecExp pd (HsInfixApp e op f) = HsInfixApp (withPrecExp pd e) op (withPrecExp pd f) {- The remaining cases simply propogate the correction throughout other elements of the grammar. -} withPrecExp _ (HsVar v) = HsVar v withPrecExp _ (HsCon c) = HsCon c withPrecExp _ (HsLit l) = HsLit l withPrecExp pd (HsApp e f) = HsApp (withPrecExp pd e) (withPrecExp pd f) withPrecExp pd (HsNegApp e) = HsNegApp (withPrecExp pd e) withPrecExp pd (HsLambda loc pats e) = let pats' = map (withPrecPat pd) pats in HsLambda loc pats' (withPrecExp pd e) withPrecExp pd (HsLet decls e) = let (pd', decls') = mapAccumL withPrecDecl pd decls in HsLet decls' (withPrecExp pd' e) withPrecExp pd (HsIf e f g) = HsIf (withPrecExp pd e) (withPrecExp pd f) (withPrecExp pd g) withPrecExp pd (HsCase e alts) = let alts' = map (withPrecAlt pd) alts in HsCase (withPrecExp pd e) alts' withPrecExp pd (HsDo stmts) = let (_, stmts') = mapAccumL withPrecStmt pd stmts in HsDo stmts' withPrecExp pd (HsTuple exps) = let exps' = map (withPrecExp pd) exps in HsTuple exps' withPrecExp pd (HsList exps) = let exps' = map (withPrecExp pd) exps in HsList exps' withPrecExp pd (HsParen e) = HsParen (withPrecExp pd e) withPrecExp pd (HsLeftSection e op) = HsLeftSection (withPrecExp pd e) op withPrecExp pd (HsRightSection op e) = HsRightSection op (withPrecExp pd e) withPrecExp pd (HsRecConstr n upd) = let upd' = map (withPrecUpd pd) upd in HsRecConstr n upd' withPrecExp pd (HsRecUpdate e upd) = let upd' = map (withPrecUpd pd) upd in HsRecUpdate (withPrecExp pd e) upd' withPrecExp pd (HsEnumFrom e) = HsEnumFrom (withPrecExp pd e) withPrecExp pd (HsEnumFromThen e f) = HsEnumFromThen (withPrecExp pd e) (withPrecExp pd f) withPrecExp pd (HsEnumFromTo e f) = HsEnumFromTo (withPrecExp pd e) (withPrecExp pd f) withPrecExp pd (HsEnumFromThenTo e f g) = HsEnumFromThenTo (withPrecExp pd e) (withPrecExp pd f) (withPrecExp pd g) withPrecExp pd (HsListComp e stmts) = let (_, stmts') = mapAccumL withPrecStmt pd stmts in HsListComp (withPrecExp pd e) stmts' withPrecExp pd (HsExpTypeSig l e t) = HsExpTypeSig l (withPrecExp pd e) t withPrecExp pd (HsAsPat n e) = HsAsPat n (withPrecExp pd e) withPrecExp _ (HsWildCard) = HsWildCard withPrecExp pd (HsIrrPat e) = HsIrrPat (withPrecExp pd e) {- This function is analogous to withPrec, but operates on patterns instead of expressions. -} withPrecPat :: PrecedenceData -> HsPat -> HsPat {- This is the same algorithm based on Lalonde and Rivieres, but designed to work with infix data constructors in pattern matching. -} withPrecPat pd (HsPInfixApp k@(HsPInfixApp e op' f) op g) = let g' = withPrecPat pd g in if precWrong pd op' op then let e' = withPrecPat pd e f' = withPrecPat pd f in withPrecPat pd (HsPInfixApp e' op' (HsPInfixApp f' op g')) else HsPInfixApp (withPrecPat pd k) op g' withPrecPat pd (HsPInfixApp e op f) = HsPInfixApp (withPrecPat pd e) op (withPrecPat pd f) withPrecPat _ (HsPVar n) = HsPVar n withPrecPat _ (HsPLit l) = HsPLit l withPrecPat pd (HsPNeg p) = HsPNeg (withPrecPat pd p) withPrecPat pd (HsPApp n ps) = let ps' = map (withPrecPat pd) ps in HsPApp n ps' withPrecPat pd (HsPTuple ps) = let ps' = map (withPrecPat pd) ps in HsPTuple ps' withPrecPat pd (HsPList ps) = let ps' = map (withPrecPat pd) ps in HsPList ps' withPrecPat pd (HsPParen p) = HsPParen (withPrecPat pd p) withPrecPat pd (HsPRec n pfs) = let pfs' = map (withPrecPatField pd) pfs in HsPRec n pfs' withPrecPat pd (HsPAsPat n p) = HsPAsPat n (withPrecPat pd p) withPrecPat _ (HsPWildCard) = HsPWildCard withPrecPat pd (HsPIrrPat p) = HsPIrrPat (withPrecPat pd p) {- Propogates precedence fixing through a pattern "field" -} withPrecPatField :: PrecedenceData -> HsPatField -> HsPatField withPrecPatField pd (HsPFieldPat n p) = HsPFieldPat n (withPrecPat pd p) {- Propogates precedence fixing through declaration sections. This gets interesting, because declarations can actually change the existing precedence, so withPrecDecl returns both the transformed tree and an augmented precedence relation. -} withPrecDecl :: PrecedenceData -> HsDecl -> (PrecedenceData, HsDecl) withPrecDecl pd d@(HsInfixDecl _ assoc p ops) = let nms = map nameFromOp ops prec = (assoc, p) pd' = M.union pd $ M.fromList $ map (flip (,) prec) nms in (pd', d) withPrecDecl pd (HsClassDecl l ctx n ns decls) = let (pd', decls') = mapAccumL withPrecDecl pd decls in (pd', HsClassDecl l ctx n ns decls') withPrecDecl pd (HsInstDecl l ctx n ts decls) = -- The question of what to do with fixity declarations here is -- interesting. The report says they aren't allowed (4.3.2), but -- GHC accepts them as of version 6.6 and apparently ignores them. -- The best thing is probably to match GHC's behavior. let decls' = map snd $ map (withPrecDecl pd) decls in (pd, HsInstDecl l ctx n ts decls') withPrecDecl pd (HsFunBind ms) = let ms' = map (withPrecMatch pd) ms in (pd, HsFunBind ms') withPrecDecl pd (HsPatBind l p rhs decls) = let p' = withPrecPat pd p (pd',decls') = mapAccumL withPrecDecl pd decls rhs' = withPrecRhs pd' rhs in (pd, HsPatBind l p' rhs' decls') withPrecDecl pd d = (pd, d) {- Propogates precedence fixing through HsMatch -} withPrecMatch :: PrecedenceData -> HsMatch -> HsMatch withPrecMatch pd (HsMatch l n ps rhs decls) = let ps' = map (withPrecPat pd) ps (pd', decls') = mapAccumL withPrecDecl pd decls rhs' = withPrecRhs pd' rhs in HsMatch l n ps' rhs' decls' {- Propogates precedence fixing through HsRhs -} withPrecRhs :: PrecedenceData -> HsRhs -> HsRhs withPrecRhs pd (HsUnGuardedRhs e) = HsUnGuardedRhs (withPrecExp pd e) withPrecRhs pd (HsGuardedRhss grs) = let grs' = map (withPrecGRhs pd) grs in HsGuardedRhss grs' withPrecGRhs :: PrecedenceData -> HsGuardedRhs -> HsGuardedRhs withPrecGRhs pd (HsGuardedRhs l e f) = HsGuardedRhs l (withPrecExp pd e) (withPrecExp pd f) {- Propogates precedence fixing through case statement alternatives. -} withPrecAlt :: PrecedenceData -> HsAlt -> HsAlt withPrecAlt pd (HsAlt l p alts ds) = let (pd', ds') = mapAccumL withPrecDecl pd ds in HsAlt l (withPrecPat pd p) (withPrecGAlts pd' alts) ds' withPrecGAlts :: PrecedenceData -> HsGuardedAlts -> HsGuardedAlts withPrecGAlts pd (HsUnGuardedAlt e) = HsUnGuardedAlt (withPrecExp pd e) withPrecGAlts pd (HsGuardedAlts alts) = let alts' = map (withPrecGAlt pd) alts in HsGuardedAlts alts' withPrecGAlt :: PrecedenceData -> HsGuardedAlt -> HsGuardedAlt withPrecGAlt pd (HsGuardedAlt l e f) = HsGuardedAlt l (withPrecExp pd e) (withPrecExp pd f) {- Propogates precedence fixing through do blocks. Because let statements can change precedence, the result is both the transformed tree and an augmented precedence relation, much like in withPrecDecl. -} withPrecStmt :: PrecedenceData -> HsStmt -> (PrecedenceData, HsStmt) withPrecStmt pd (HsGenerator l p e) = (pd, HsGenerator l (withPrecPat pd p) (withPrecExp pd e)) withPrecStmt pd (HsQualifier e) = (pd, HsQualifier (withPrecExp pd e)) withPrecStmt pd (HsLetStmt ds) = let (pd', ds') = mapAccumL withPrecDecl pd ds in (pd', HsLetStmt ds') {- Propogates precedence fixing through record field updates. -} withPrecUpd :: PrecedenceData -> HsFieldUpdate -> HsFieldUpdate withPrecUpd pd (HsFieldUpdate n e) = HsFieldUpdate n (withPrecExp pd e) {- This is the default precedence table used for parsing expressions. It is taken from the precedences of the main operators in the Haskell Prelude. XXX: It might be a good idea to search the standard library docs for other operators. These are the ones listed in the Haskell Report section 4. For example, one that is not included here is Data.Ratio.% -} precTable :: PrecedenceData precTable = M.fromList [ (UnQual (HsSymbol "!!"), (HsAssocLeft, 9)), (UnQual (HsSymbol "."), (HsAssocRight, 9)), (UnQual (HsSymbol "^"), (HsAssocRight, 8)), (UnQual (HsSymbol "^^"), (HsAssocRight, 8)), (UnQual (HsSymbol "**"), (HsAssocLeft, 8)), (UnQual (HsSymbol "*"), (HsAssocLeft, 7)), (UnQual (HsSymbol "/"), (HsAssocLeft, 7)), (UnQual (HsIdent "div"), (HsAssocLeft, 7)), (UnQual (HsIdent "mod"), (HsAssocLeft, 7)), (UnQual (HsIdent "rem"), (HsAssocLeft, 7)), (UnQual (HsIdent "quot"), (HsAssocLeft, 7)), (UnQual (HsSymbol "+"), (HsAssocLeft, 6)), (UnQual (HsSymbol "-"), (HsAssocLeft, 6)), (UnQual (HsSymbol ":"), (HsAssocRight, 5)), (Special HsCons, (HsAssocRight, 5)), (UnQual (HsSymbol "++"), (HsAssocRight, 5)), (UnQual (HsSymbol "=="), (HsAssocNone, 4)), (UnQual (HsSymbol "/="), (HsAssocNone, 4)), (UnQual (HsSymbol "<"), (HsAssocNone, 4)), (UnQual (HsSymbol "<="), (HsAssocNone, 4)), (UnQual (HsSymbol ">"), (HsAssocNone, 4)), (UnQual (HsSymbol ">="), (HsAssocNone, 4)), (UnQual (HsIdent "elem"), (HsAssocNone, 4)), (UnQual (HsIdent "notElem"), (HsAssocNone, 4)), (UnQual (HsSymbol "&&"), (HsAssocRight, 3)), (UnQual (HsSymbol "||"), (HsAssocRight, 2)), (UnQual (HsSymbol ">>"), (HsAssocLeft, 1)), (UnQual (HsSymbol ">>="), (HsAssocLeft, 1)), (UnQual (HsSymbol "$"), (HsAssocRight, 0)), (UnQual (HsSymbol "$!"), (HsAssocRight, 0)), (UnQual (HsIdent "seq"), (HsAssocRight, 0)) ] class FixPrecedence a where fixPrecedence :: a -> a instance FixPrecedence HsExp where fixPrecedence = withPrecExp precTable instance FixPrecedence HsDecl where fixPrecedence = snd . withPrecDecl precTable