module Lambdabot.FixPrecedence (withPrecExp, withPrecDecl, precTable, FixPrecedence(..) ) where
import qualified Data.Map as M
import Language.Haskell.Syntax
import Data.List
type PrecedenceData = M.Map HsQName (HsAssoc, Int)
findPrec :: PrecedenceData -> HsQName -> (HsAssoc, Int)
findPrec = flip (M.findWithDefault defaultPrec)
where defaultPrec = (HsAssocLeft, 9)
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 :: HsQOp -> HsQName
nameFromQOp (HsQVarOp s) = s
nameFromQOp (HsQConOp s) = s
nameFromOp :: HsOp -> HsQName
nameFromOp (HsVarOp n) = UnQual n
nameFromOp (HsConOp n) = UnQual n
withPrecExp :: PrecedenceData -> HsExp -> HsExp
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)
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)
withPrecPat :: PrecedenceData -> HsPat -> HsPat
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)
withPrecPatField :: PrecedenceData -> HsPatField -> HsPatField
withPrecPatField pd (HsPFieldPat n p) = HsPFieldPat n (withPrecPat pd p)
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) =
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)
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'
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)
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)
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')
withPrecUpd :: PrecedenceData -> HsFieldUpdate -> HsFieldUpdate
withPrecUpd pd (HsFieldUpdate n e) = HsFieldUpdate n (withPrecExp pd e)
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