X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsExpr.lhs;h=56ad5d23f65cc5234d940a180b24269fcc92d46e;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=93aa0e3c12be66cbff0d098722433770cb66262d;hpb=2f51f1402e6869c0f049ffbe7b019bf6ab80558f;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 93aa0e3..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 ( isSymLexeme, pprSym ) +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 @@ -81,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] @@ -194,8 +198,7 @@ instance (NamedThing id, Outputable id, Outputable pat, \end{code} \begin{code} -pprExpr sty (HsVar v) - = (if (isSymLexeme 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 @@ -205,7 +208,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) @@ -215,16 +218,16 @@ 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 [pprSym sty v, pp_e2]] -pprExpr sty (NegApp e) +pprExpr sty (NegApp e _) = ppBeside (ppChar '-') (pprParendExpr sty e) pprExpr sty (HsPar e) @@ -237,8 +240,8 @@ 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 (pprSym sty v) ppRparen ] @@ -250,7 +253,7 @@ 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 (pprSym sty v), @@ -276,9 +279,9 @@ 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 _ _ _) - = ppCat [ppPStr SLIT("do"), ppAboves (map (ppr sty) stmts)] + = ppHang (ppPStr SLIT("do")) 2 (ppAboves (map (ppr sty) stmts)) pprExpr sty (ListComp expr quals) = ppHang (ppCat [ppLbrack, pprExpr sty expr, ppChar '|']) @@ -302,8 +305,8 @@ 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) + = ppHang (ppBeside (ppNest 2 (pprExpr sty expr)) (ppPStr SLIT(" ::"))) + 4 (ppr sty sig) pprExpr sty (ArithSeqIn info) = ppBracket (ppr sty info) @@ -401,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} %************************************************************************ @@ -419,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} @@ -431,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} %************************************************************************ @@ -466,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) @@ -476,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)