X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsExpr.lhs;h=56ad5d23f65cc5234d940a180b24269fcc92d46e;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=0a0397ec2730f0bc7c02d3b6229bc04becb959b5;hpb=7b0181919416d8f04324575b7e17031ca692f5b0;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 0a0397e..56ad5d2 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -8,8 +8,8 @@ module HsExpr where -import Ubiq{-uitous-} -import HsLoop -- for paranoia checking +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(HsLoop) -- for paranoia checking -- friends: import HsBinds ( HsBinds ) @@ -18,15 +18,15 @@ import HsMatches ( pprMatches, pprMatch, Match ) import HsTypes ( PolyType ) -- others: -import Id ( DictVar(..), GenId, Id(..) ) -import Name ( isOpLexeme, pprOp ) +import Id ( SYN_IE(DictVar), GenId, SYN_IE(Id) ) +import Name ( pprNonSym, pprSym ) import Outputable ( interppSP, interpp'SP, ifnotPprForUser ) import PprType ( pprGenType, pprParendGenType, GenType{-instance-} ) import Pretty import PprStyle ( PprStyle(..) ) import SrcLoc ( SrcLoc ) import Usage ( GenUsage{-instance-} ) -import Util ( panic{-ToDo:rm eventually-} ) +--import Util ( panic{-ToDo:rm eventually-} ) \end{code} %************************************************************************ @@ -57,8 +57,11 @@ data HsExpr tyvar uvar id pat (HsExpr tyvar uvar id pat) -- right operand -- 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 @@ -66,7 +69,6 @@ data HsExpr tyvar uvar id pat | 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 @@ -82,12 +84,13 @@ data HsExpr tyvar uvar id pat | HsDo [Stmt tyvar uvar id pat] -- "do":one or more stmts SrcLoc - | HsDoOut [Stmt tyvar uvar id pat] -- "do":one or more stmts - id id -- Monad and MonadZero dicts + | HsDoOut [Stmt tyvar uvar id pat] -- "do":one or more stmts + id -- id for >>=, types applied + id -- id for zero, typed applied SrcLoc - | ListComp (HsExpr tyvar uvar id pat) -- list comprehension - [Qual tyvar uvar id pat] -- at least one Qual(ifier) + | ListComp (HsExpr tyvar uvar id pat) -- list comprehension + [Qualifier tyvar uvar id pat] -- at least one Qualifier | ExplicitList -- syntactic list [HsExpr tyvar uvar id pat] @@ -110,9 +113,9 @@ 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) + | 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) @@ -195,8 +198,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 @@ -206,33 +208,31 @@ 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) - pprExpr sty (OpApp e1 op e2) = case op of 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 '-') (ppParens (pprExpr sty e)) +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 HsVar v -> pp_infixly v @@ -240,11 +240,11 @@ pprExpr sty (SectionL expr op) where pp_expr = pprParendExpr sty expr - pp_prefixly = ppHang (ppCat [ppStr "( \\ _x ->", ppr sty op]) - 4 (ppCat [pp_expr, ppStr "_x )"]) + pp_prefixly = ppHang (ppCat [ppStr "( \\ x_ ->", ppr sty 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 @@ -253,29 +253,21 @@ pprExpr sty (SectionR op expr) where pp_expr = pprParendExpr sty expr - pp_prefixly = ppHang (ppCat [ppStr "( \\ _x ->", ppr sty op, ppPStr SLIT("_x")]) + 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 _ _)) @@ -287,13 +279,13 @@ pprExpr sty (HsLet binds expr) ppHang (ppPStr SLIT("in")) 2 (ppr sty expr)] pprExpr sty (HsDo stmts _) - = ppCat [ppPStr SLIT("do"), ppAboves (map (ppr sty) stmts)] + = ppHang (ppPStr SLIT("do")) 2 (ppAboves (map (ppr sty) stmts)) +pprExpr sty (HsDoOut stmts _ _ _) + = ppHang (ppPStr SLIT("do")) 2 (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)) @@ -303,15 +295,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 (ppBeside (ppNest 2 (pprExpr sty expr)) (ppPStr SLIT(" ::"))) + 4 (ppr sty sig) pprExpr sty (ArithSeqIn info) = ppBracket (ppr sty info) @@ -322,6 +317,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) @@ -352,12 +357,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: @@ -396,8 +404,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} %************************************************************************ @@ -414,6 +422,10 @@ data Stmt tyvar uvar id pat | ExprStmt (HsExpr tyvar uvar id pat) SrcLoc | LetStmt (HsBinds tyvar uvar id pat) + + -- Translations; the types are the "a" and "b" types of the monad. + | BindStmtOut pat (HsExpr tyvar uvar id pat) SrcLoc (GenType tyvar uvar) (GenType tyvar uvar) + | ExprStmtOut (HsExpr tyvar uvar id pat) SrcLoc (GenType tyvar uvar) (GenType tyvar uvar) \end{code} \begin{code} @@ -426,6 +438,10 @@ instance (NamedThing id, Outputable id, Outputable pat, = ppCat [ppPStr SLIT("let"), ppr sty binds] ppr sty (ExprStmt expr _) = ppr sty expr + ppr sty (BindStmtOut pat expr _ _ _) + = ppCat [ppr sty pat, ppStr "<-", ppr sty expr] + ppr sty (ExprStmtOut expr _ _ _) + = ppr sty expr \end{code} %************************************************************************ @@ -461,7 +477,7 @@ pp_dotdot = ppPStr SLIT(" .. ") ``Qualifiers'' in list comprehensions: \begin{code} -data Qual tyvar uvar id pat +data Qualifier tyvar uvar id pat = GeneratorQual pat (HsExpr tyvar uvar id pat) | LetQual (HsBinds tyvar uvar id pat) @@ -471,7 +487,7 @@ data Qual tyvar uvar id pat \begin{code} instance (NamedThing id, Outputable id, Outputable pat, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - Outputable (Qual tyvar uvar id pat) where + Outputable (Qualifier tyvar uvar id pat) where ppr sty (GeneratorQual pat expr) = ppCat [ppr sty pat, ppStr "<-", ppr sty expr] ppr sty (LetQual binds)