module Language.Haskell.Exts.Annotated.Fixity
(
Fixity(..)
, infix_, infixl_, infixr_
, preludeFixities, baseFixities
, AppFixity(..)
) where
import Language.Haskell.Exts.Annotated.Syntax
import Language.Haskell.Exts.SrcLoc
import Language.Haskell.Exts.Fixity ( Fixity(..), infix_, infixl_, infixr_, preludeFixities, baseFixities )
import qualified Language.Haskell.Exts.Syntax as S ( Assoc(..), QOp(..), Op(..), QName(..), Name(..), SpecialCon(..) )
import Language.Haskell.Exts.Annotated.Simplify ( sQOp, sOp, sAssoc )
import Data.Char (isUpper)
class AppFixity ast where
applyFixities :: [Fixity]
-> ast SrcSpanInfo
-> ast SrcSpanInfo
instance AppFixity Exp where
applyFixities fixs = infFix fixs . leafFix fixs
where
infFix fixs (InfixApp l2 a op2 z) =
let e = infFix fixs a
in case e of
InfixApp l1 x op1 y ->
let (a1,p1) = askFixity fixs op1
(a2,p2) = askFixity fixs op2
in if (p1 == p2 && (a1 /= a2 || a1 == S.AssocNone ))
|| (p1 > p2 || p1 == p2 && (a1 == S.AssocLeft || a2 == S.AssocNone))
then InfixApp l2 e op2 z
else InfixApp l2 x op1 (infFix fixs $ InfixApp (ann y <++> ann z) y op2 z)
_ -> InfixApp l2 e op2 z
infFix _ e = e
askFixity :: [Fixity] -> QOp l -> (S.Assoc, Int)
askFixity xs k = lookupWithDefault (S.AssocLeft, 9) (f $ sQOp k) mp
where
lookupWithDefault def k mp = case lookup k mp of
Nothing -> def
Just x -> x
mp = [(x,(a,p)) | Fixity a p x <- xs]
f (S.QVarOp x) = S.VarOp (g x)
f (S.QConOp x) = S.ConOp (g x)
g (S.Qual _ x) = x
g (S.UnQual x) = x
g (S.Special S.Cons) = S.Symbol ":"
instance AppFixity Module where
applyFixities fixs (Module l mmh prs imp decls) =
Module l mmh prs imp $ appFixDecls fixs decls
applyFixities fixs (XmlPage l mn os xn xas mexp cs) =
XmlPage l mn os xn (map fix xas) (fmap fix mexp) (map fix cs)
where fix x = applyFixities fixs x
applyFixities fixs (XmlHybrid l mmh prs imp decls xn xas mexp cs) =
XmlHybrid l mmh prs imp (appFixDecls fixs decls)
xn (map fixe xas) (fmap fixe mexp) (map fixe cs)
where fixe x = let extraFixs = getFixities decls
in applyFixities (fixs++extraFixs) x
instance AppFixity Decl where
applyFixities fixs decl = case decl of
ClassDecl l ctxt dh deps cdecls -> ClassDecl l ctxt dh deps $ fmap (map fix) cdecls
InstDecl l ctxt ih idecls -> InstDecl l ctxt ih $ fmap (map fix) idecls
SpliceDecl l spl -> SpliceDecl l $ fix spl
FunBind l matches -> FunBind l $ map fix matches
PatBind l p mt rhs bs -> PatBind l (fix p) mt (fix rhs) (fmap fix bs)
_ -> decl
where fix x = applyFixities fixs x
appFixDecls :: [Fixity] -> [Decl SrcSpanInfo] -> [Decl SrcSpanInfo]
appFixDecls fixs decls =
let extraFixs = getFixities decls
in map (applyFixities (fixs++extraFixs)) decls
getFixities = concatMap getFixity
getFixity (InfixDecl _ a mp ops) = let p = maybe 9 id mp in map (Fixity (sAssoc a) p) (map sOp ops)
getFixity _ = []
instance AppFixity ClassDecl where
applyFixities fixs (ClsDecl l decl) = ClsDecl l $ applyFixities fixs decl
applyFixities _ cdecl = cdecl
instance AppFixity InstDecl where
applyFixities fixs (InsDecl l decl) = InsDecl l $ applyFixities fixs decl
applyFixities _ idecl = idecl
instance AppFixity Match where
applyFixities fixs match = case match of
Match l n ps rhs bs -> Match l n (map fix ps) (fix rhs) (fmap fix bs)
InfixMatch l a n b rhs bs -> InfixMatch l (fix a) n (fix b) (fix rhs) (fmap fix bs)
where fix x = applyFixities fixs x
instance AppFixity Rhs where
applyFixities fixs rhs = case rhs of
UnGuardedRhs l e -> UnGuardedRhs l $ fix e
GuardedRhss l grhss -> GuardedRhss l $ map fix grhss
where fix x = applyFixities fixs x
instance AppFixity GuardedRhs where
applyFixities fixs (GuardedRhs l stmts e) = GuardedRhs l (map fix stmts) $ fix e
where fix x = applyFixities fixs x
instance AppFixity Pat where
applyFixities fixs p = case p of
PNeg l p -> PNeg l $ fix p
PInfixApp l a op b -> PInfixApp l (fix a) op (fix b)
PApp l n ps -> PApp l n $ map fix ps
PTuple l ps -> PTuple l $ map fix ps
PList l ps -> PList l $ map fix ps
PParen l p -> PParen l $ fix p
PRec l n pfs -> PRec l n $ map fix pfs
PAsPat l n p -> PAsPat l n $ fix p
PIrrPat l p -> PIrrPat l $ fix p
PatTypeSig l p t -> PatTypeSig l (fix p) t
PViewPat l e p -> PViewPat l (fix e) (fix p)
PRPat l rps -> PRPat l $ map fix rps
PXTag l n ats mp ps -> PXTag l n (map fix ats) (fmap fix mp) (map fix ps)
PXETag l n ats mp -> PXETag l n (map fix ats) (fmap fix mp)
PXPatTag l p -> PXPatTag l $ fix p
PXRPats l rps -> PXRPats l $ map fix rps
PBangPat l p -> PBangPat l $ fix p
_ -> p
where fix x = applyFixities fixs x
instance AppFixity PatField where
applyFixities fixs (PFieldPat l n p) = PFieldPat l n $ applyFixities fixs p
applyFixities _ pf = pf
instance AppFixity RPat where
applyFixities fixs rp = case rp of
RPOp l rp op -> RPOp l (fix rp) op
RPEither l a b -> RPEither l (fix a) (fix b)
RPSeq l rps -> RPSeq l $ map fix rps
RPGuard l p stmts -> RPGuard l (fix p) $ map fix stmts
RPCAs l n rp -> RPCAs l n $ fix rp
RPAs l n rp -> RPAs l n $ fix rp
RPParen l rp -> RPParen l $ fix rp
RPPat l p -> RPPat l $ fix p
where fix x = applyFixities fixs x
instance AppFixity PXAttr where
applyFixities fixs (PXAttr l n p) = PXAttr l n $ applyFixities fixs p
instance AppFixity Stmt where
applyFixities fixs stmt = case stmt of
Generator l p e -> Generator l (fix p) (fix e)
Qualifier l e -> Qualifier l $ fix e
LetStmt l bs -> LetStmt l $ fix bs
RecStmt l stmts -> RecStmt l $ map fix stmts
where fix x = applyFixities fixs x
instance AppFixity Binds where
applyFixities fixs bs = case bs of
BDecls l decls -> BDecls l $ appFixDecls fixs decls
IPBinds l ips -> IPBinds l $ map fix ips
where fix x = applyFixities fixs x
instance AppFixity IPBind where
applyFixities fixs (IPBind l n e) = IPBind l n $ applyFixities fixs e
instance AppFixity FieldUpdate where
applyFixities fixs (FieldUpdate l n e) = FieldUpdate l n $ applyFixities fixs e
applyFixities _ fup = fup
instance AppFixity Alt where
applyFixities fixs (Alt l p galts bs) = Alt l (fix p) (fix galts) (fmap fix bs)
where fix x = applyFixities fixs x
instance AppFixity GuardedAlts where
applyFixities fixs galts = case galts of
UnGuardedAlt l e -> UnGuardedAlt l $ fix e
GuardedAlts l galts -> GuardedAlts l $ map fix galts
where fix x = applyFixities fixs x
instance AppFixity GuardedAlt where
applyFixities fixs (GuardedAlt l stmts e) = GuardedAlt l (map fix stmts) (fix e)
where fix x = applyFixities fixs x
instance AppFixity QualStmt where
applyFixities fixs qstmt = case qstmt of
QualStmt l s -> QualStmt l $ fix s
ThenTrans l e -> ThenTrans l $ fix e
ThenBy l e1 e2 -> ThenBy l (fix e1) (fix e2)
GroupBy l e -> GroupBy l (fix e)
GroupUsing l e -> GroupUsing l (fix e)
GroupByUsing l e1 e2 -> GroupByUsing l (fix e1) (fix e2)
where fix x = applyFixities fixs x
instance AppFixity Bracket where
applyFixities fixs br = case br of
ExpBracket l e -> ExpBracket l $ fix e
PatBracket l p -> PatBracket l $ fix p
DeclBracket l ds -> DeclBracket l $ map fix ds
_ -> br
where fix x = applyFixities fixs x
instance AppFixity Splice where
applyFixities fixs (ParenSplice l e) = ParenSplice l $ applyFixities fixs e
applyFixities _ s = s
instance AppFixity XAttr where
applyFixities fixs (XAttr l n e) = XAttr l n $ applyFixities fixs e
leafFix fixs e = case e of
InfixApp l e1 op e2 -> InfixApp l (leafFix fixs e1) op (fix e2)
App l e1 e2 -> App l (fix e1) (fix e2)
NegApp l e -> NegApp l $ fix e
Lambda l pats e -> Lambda l (map fix pats) $ fix e
Let l bs e -> Let l (fix bs) $ fix e
If l e a b -> If l (fix e) (fix a) (fix b)
Case l e alts -> Case l (fix e) $ map fix alts
Do l stmts -> Do l $ map fix stmts
MDo l stmts -> MDo l $ map fix stmts
Tuple l exps -> Tuple l $ map fix exps
List l exps -> List l $ map fix exps
Paren l e -> Paren l $ fix e
LeftSection l e op -> LeftSection l (fix e) op
RightSection l op e -> RightSection l op $ fix e
RecConstr l n fups -> RecConstr l n $ map fix fups
RecUpdate l e fups -> RecUpdate l (fix e) $ map fix fups
EnumFrom l e -> EnumFrom l $ fix e
EnumFromTo l e1 e2 -> EnumFromTo l (fix e1) (fix e2)
EnumFromThen l e1 e2 -> EnumFromThen l (fix e1) (fix e2)
EnumFromThenTo l e1 e2 e3 -> EnumFromThenTo l (fix e1) (fix e2) (fix e3)
ListComp l e quals -> ListComp l (fix e) $ map fix quals
ParComp l e qualss -> ParComp l (fix e) $ map (map fix) qualss
ExpTypeSig l e t -> ExpTypeSig l (fix e) t
BracketExp l b -> BracketExp l $ fix b
SpliceExp l s -> SpliceExp l $ fix s
XTag l n ats mexp cs -> XTag l n (map fix ats) (fmap fix mexp) (map fix cs)
XETag l n ats mexp -> XETag l n (map fix ats) (fmap fix mexp)
XExpTag l e -> XExpTag l $ fix e
Proc l p e -> Proc l (fix p) (fix e)
LeftArrApp l e1 e2 -> LeftArrApp l (fix e1) (fix e2)
RightArrApp l e1 e2 -> RightArrApp l (fix e1) (fix e2)
LeftArrHighApp l e1 e2 -> LeftArrHighApp l (fix e1) (fix e2)
RightArrHighApp l e1 e2 -> RightArrHighApp l (fix e1) (fix e2)
CorePragma l s e -> CorePragma l s (fix e)
SCCPragma l s e -> SCCPragma l s (fix e)
GenPragma l s ab cd e -> GenPragma l s ab cd (fix e)
_ -> e
where
fix x = applyFixities fixs x