X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsExpr.lhs;h=55709cabdd1df6271c4d6068daf2905066a52046;hb=f3998ec18fd0f3d56b377d41e2a2958aaf9460ec;hp=fc9356ade7703ca4ea1de0b8520f5f3f082eb061;hpb=7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index fc9356a..55709ca 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -19,7 +19,8 @@ import HsTypes ( PolyType ) -- others: import Id ( DictVar(..), GenId, Id(..) ) -import Outputable +import Name ( pprNonSym, pprSym ) +import Outputable ( interppSP, interpp'SP, ifnotPprForUser ) import PprType ( pprGenType, pprParendGenType, GenType{-instance-} ) import Pretty import PprStyle ( PprStyle(..) ) @@ -45,24 +46,29 @@ data HsExpr tyvar uvar id pat | HsApp (HsExpr tyvar uvar id pat) -- application (HsExpr tyvar uvar id pat) - -- Operator applications and sections. + -- Operator applications: -- NB Bracketed ops such as (+) come out as Vars. + -- NB We need an expr for the operator in an OpApp/Section since + -- the typechecker may need to apply the operator to a few types. + | OpApp (HsExpr tyvar uvar id pat) -- left operand (HsExpr tyvar uvar id pat) -- operator (HsExpr tyvar uvar id pat) -- right operand - -- ADR Question? Why is the "op" in a section an expr when it will - -- have to be of the form (HsVar op) anyway? - -- WDP Answer: But when the typechecker gets ahold of it, it may - -- apply the var to a few types; it will then be an expression. + -- We preserve prefix negation and parenthesis for the precedence parser. + -- They are eventually removed by the type checker. + + | NegApp (HsExpr tyvar uvar id pat) -- negated expr + (HsExpr tyvar uvar id pat) -- the negate id (in a HsVar) + + | HsPar (HsExpr tyvar uvar id pat) -- parenthesised expr | SectionL (HsExpr tyvar uvar id pat) -- operand (HsExpr tyvar uvar id pat) -- operator | SectionR (HsExpr tyvar uvar id pat) -- operator (HsExpr tyvar uvar id pat) -- operand - | HsCase (HsExpr tyvar uvar id pat) [Match tyvar uvar id pat] -- must have at least one Match SrcLoc @@ -106,6 +112,10 @@ data HsExpr tyvar uvar id pat | RecordUpd (HsExpr tyvar uvar id pat) (HsRecordBinds tyvar uvar id pat) + | RecordUpdOut (HsExpr tyvar uvar id pat) -- TRANSLATION + [id] -- Dicts needed for construction + (HsRecordBinds tyvar uvar id pat) + | ExprWithTySig -- signature binding (HsExpr tyvar uvar id pat) (PolyType id) @@ -162,6 +172,11 @@ Everything from here on appears only in typechecker output. | SingleDict -- a simple special case of Dictionary id -- local dictionary name + | HsCon -- TRANSLATION; a constructor application + Id -- used only in the RHS of constructor definitions + [GenType tyvar uvar] + [HsExpr tyvar uvar id pat] + type HsRecordBinds tyvar uvar id pat = [(id, HsExpr tyvar uvar id pat, Bool)] -- True <=> source code used "punning", @@ -182,8 +197,7 @@ instance (NamedThing id, Outputable id, Outputable pat, \end{code} \begin{code} -pprExpr sty (HsVar v) - = (if (isOpLexeme v) then ppParens else id) (ppr sty v) +pprExpr sty (HsVar v) = pprNonSym sty v pprExpr sty (HsLit lit) = ppr sty lit pprExpr sty (HsLitOut lit _) = ppr sty lit @@ -193,7 +207,7 @@ pprExpr sty (HsLam match) pprExpr sty expr@(HsApp e1 e2) = let (fun, args) = collect_args expr [] in - ppHang (pprParendExpr sty fun) 4 (ppSep (map (pprParendExpr sty) args)) + ppHang (pprExpr sty fun) 4 (ppSep (map (pprExpr sty) args)) where collect_args (HsApp fun arg) args = collect_args fun (arg:args) collect_args fun args = (fun, args) @@ -203,14 +217,20 @@ pprExpr sty (OpApp e1 op e2) HsVar v -> pp_infixly v _ -> pp_prefixly where - pp_e1 = pprParendExpr sty e1 - pp_e2 = pprParendExpr sty e2 + pp_e1 = pprExpr sty e1 + pp_e2 = pprExpr sty e2 pp_prefixly - = ppHang (pprParendExpr sty op) 4 (ppSep [pp_e1, pp_e2]) + = ppHang (pprExpr sty op) 4 (ppSep [pp_e1, pp_e2]) pp_infixly v - = ppSep [pp_e1, ppCat [pprOp sty v, pp_e2]] + = ppSep [pp_e1, ppCat [pprSym sty v, pp_e2]] + +pprExpr sty (NegApp e _) + = ppBeside (ppChar '-') (pprParendExpr sty e) + +pprExpr sty (HsPar e) + = ppParens (pprExpr sty e) pprExpr sty (SectionL expr op) = case op of @@ -223,7 +243,7 @@ pprExpr sty (SectionL expr op) 4 (ppCat [pp_expr, ppStr "_x )"]) pp_infixly v = ppSep [ ppBeside ppLparen pp_expr, - ppBeside (pprOp sty v) ppRparen ] + ppBeside (pprSym sty v) ppRparen ] pprExpr sty (SectionR op expr) = case op of @@ -235,26 +255,18 @@ pprExpr sty (SectionR op expr) pp_prefixly = ppHang (ppCat [ppStr "( \\ _x ->", ppr sty op, ppPStr SLIT("_x")]) 4 (ppBeside pp_expr ppRparen) pp_infixly v - = ppSep [ ppBeside ppLparen (pprOp sty v), + = ppSep [ ppBeside ppLparen (pprSym sty v), ppBeside pp_expr ppRparen ] -pprExpr sty (CCall fun args _ is_asm result_ty) - = ppHang (if is_asm - then ppBesides [ppStr "_casm_ ``", ppPStr fun, ppStr "''"] - else ppBeside (ppPStr SLIT("_ccall_ ")) (ppPStr fun)) - 4 (ppSep (map (pprParendExpr sty) args)) - -pprExpr sty (HsSCC label expr) - = ppSep [ ppBeside (ppPStr SLIT("_scc_ ")) (ppBesides [ppChar '"', ppPStr label, ppChar '"']), - pprParendExpr sty expr ] - pprExpr sty (HsCase expr matches _) = ppSep [ ppSep [ppPStr SLIT("case"), ppNest 4 (pprExpr sty expr), ppPStr SLIT("of")], ppNest 2 (pprMatches sty (True, ppNil) matches) ] -pprExpr sty (ListComp expr quals) - = ppHang (ppCat [ppLbrack, pprExpr sty expr, ppChar '|']) - 4 (ppSep [interpp'SP sty quals, ppRbrack]) +pprExpr sty (HsIf e1 e2 e3 _) + = ppSep [ppCat [ppPStr SLIT("if"), ppNest 2 (pprExpr sty e1), ppPStr SLIT("then")], + ppNest 4 (pprExpr sty e2), + ppPStr SLIT("else"), + ppNest 4 (pprExpr sty e3)] -- special case: let ... in let ... pprExpr sty (HsLet binds expr@(HsLet _ _)) @@ -267,12 +279,12 @@ pprExpr sty (HsLet binds expr) pprExpr sty (HsDo stmts _) = ppCat [ppPStr SLIT("do"), ppAboves (map (ppr sty) stmts)] +pprExpr sty (HsDoOut stmts _ _ _) + = ppCat [ppPStr SLIT("do"), ppAboves (map (ppr sty) stmts)] -pprExpr sty (HsIf e1 e2 e3 _) - = ppSep [ppCat [ppPStr SLIT("if"), ppNest 2 (pprExpr sty e1), ppPStr SLIT("then")], - ppNest 4 (pprExpr sty e2), - ppPStr SLIT("else"), - ppNest 4 (pprExpr sty e3)] +pprExpr sty (ListComp expr quals) + = ppHang (ppCat [ppLbrack, pprExpr sty expr, ppChar '|']) + 4 (ppSep [interpp'SP sty quals, ppRbrack]) pprExpr sty (ExplicitList exprs) = ppBracket (ppInterleave ppComma (map (pprExpr sty) exprs)) @@ -282,15 +294,18 @@ pprExpr sty (ExplicitListOut ty exprs) pprExpr sty (ExplicitTuple exprs) = ppParens (ppInterleave ppComma (map (pprExpr sty) exprs)) -pprExpr sty (ExprWithTySig expr sig) - = ppHang (ppBesides [ppLparen, ppNest 2 (pprExpr sty expr), ppPStr SLIT(" ::")]) - 4 (ppBeside (ppr sty sig) ppRparen) pprExpr sty (RecordCon con rbinds) = pp_rbinds sty (ppr sty con) rbinds pprExpr sty (RecordUpd aexp rbinds) = pp_rbinds sty (pprParendExpr sty aexp) rbinds +pprExpr sty (RecordUpdOut aexp _ rbinds) + = pp_rbinds sty (pprParendExpr sty aexp) rbinds + +pprExpr sty (ExprWithTySig expr sig) + = ppHang (ppBesides [ppLparen, ppNest 2 (pprExpr sty expr), ppPStr SLIT(" ::")]) + 4 (ppBeside (ppr sty sig) ppRparen) pprExpr sty (ArithSeqIn info) = ppBracket (ppr sty info) @@ -301,6 +316,16 @@ pprExpr sty (ArithSeqOut expr info) _ -> ppBesides [ppLbrack, ppParens (ppr sty expr), ppr sty info, ppRbrack] +pprExpr sty (CCall fun args _ is_asm result_ty) + = ppHang (if is_asm + then ppBesides [ppStr "_casm_ ``", ppPStr fun, ppStr "''"] + else ppBeside (ppPStr SLIT("_ccall_ ")) (ppPStr fun)) + 4 (ppSep (map (pprParendExpr sty) args)) + +pprExpr sty (HsSCC label expr) + = ppSep [ ppBeside (ppPStr SLIT("_scc_ ")) (ppBesides [ppChar '"', ppPStr label, ppChar '"']), + pprParendExpr sty expr ] + pprExpr sty (TyLam tyvars expr) = ppHang (ppCat [ppStr "/\\", interppSP sty tyvars, ppStr "->"]) 4 (pprExpr sty expr) @@ -331,12 +356,15 @@ pprExpr sty (ClassDictLam dicts methods expr) 4 (pprExpr sty expr) pprExpr sty (Dictionary dicts methods) - = ppSep [ppBesides [ppLparen, ppPStr SLIT("{-dict-}")], - ppBracket (interpp'SP sty dicts), - ppBesides [ppBracket (interpp'SP sty methods), ppRparen]] + = ppSep [ppBesides [ppLparen, ppPStr SLIT("{-dict-}")], + ppBracket (interpp'SP sty dicts), + ppBesides [ppBracket (interpp'SP sty methods), ppRparen]] pprExpr sty (SingleDict dname) - = ppCat [ppPStr SLIT("{-singleDict-}"), ppr sty dname] + = ppCat [ppPStr SLIT("{-singleDict-}"), ppr sty dname] + +pprExpr sty (HsCon con tys exprs) + = ppCat [ppPStr SLIT("{-HsCon-}"), ppr sty con, interppSP sty tys, interppSP sty exprs] \end{code} Parenthesize unless very simple: @@ -375,8 +403,8 @@ pp_rbinds sty thing rbinds = ppHang thing 4 (ppBesides [ppChar '{', ppInterleave ppComma (map (pp_rbind sty) rbinds), ppChar '}']) where - pp_rbind sty (v, _, True{-pun-}) = ppr sty v - pp_rbind sty (v, e, _) = ppCat [ppr sty v, ppStr "<-", ppr sty e] + pp_rbind PprForUser (v, _, True) = ppr PprForUser v + pp_rbind sty (v, e, _) = ppCat [ppr sty v, ppStr "=", ppr sty e] \end{code} %************************************************************************