X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsExpr.lhs;h=936c61225a3e9366ec39621711eca661203e8320;hb=1fb1ab5d53a09607e7f6d2450806760688396387;hp=3b4facef0adadb80c45cf33677cf7723804667e3;hpb=c49d51f812da9b1c2ceca7e0dad8f2a3626041a9;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 3b4face..936c612 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -8,25 +8,25 @@ module HsExpr where -import Ubiq{-uitous-} -import HsLoop -- for paranoia checking +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(HsLoop) -- for paranoia checking -- friends: import HsBinds ( HsBinds ) -import HsLit ( HsLit ) +import HsBasic ( HsLit, Fixity(..), FixityDirection(..) ) import HsMatches ( pprMatches, pprMatch, Match ) -import HsTypes ( PolyType ) +import HsTypes ( HsType ) -- 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} %************************************************************************ @@ -54,11 +54,15 @@ data HsExpr tyvar uvar id pat | OpApp (HsExpr tyvar uvar id pat) -- left operand (HsExpr tyvar uvar id pat) -- operator + Fixity -- Renamer adds fixity; bottom until then (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 @@ -78,16 +82,18 @@ data HsExpr tyvar uvar id pat | HsLet (HsBinds tyvar uvar id pat) -- let(rec) (HsExpr tyvar uvar id pat) - | HsDo [Stmt tyvar uvar id pat] -- "do":one or more stmts + | HsDo DoOrListComp + [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 DoOrListComp + [Stmt tyvar uvar id pat] -- "do":one or more stmts + id -- id for return + id -- id for >>= + id -- id for zero + (GenType tyvar uvar) -- Type of the whole expression SrcLoc - | ListComp (HsExpr tyvar uvar id pat) -- list comprehension - [Qual tyvar uvar id pat] -- at least one Qual(ifier) - | ExplicitList -- syntactic list [HsExpr tyvar uvar id pat] | ExplicitListOut -- TRANSLATION @@ -115,7 +121,7 @@ data HsExpr tyvar uvar id pat | ExprWithTySig -- signature binding (HsExpr tyvar uvar id pat) - (PolyType id) + (HsType id) | ArithSeqIn -- arithmetic sequence (ArithSeqInfo tyvar uvar id pat) | ArithSeqOut @@ -169,11 +175,6 @@ 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", @@ -194,37 +195,36 @@ 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) = ppr sty v pprExpr sty (HsLit lit) = ppr sty lit pprExpr sty (HsLitOut lit _) = ppr sty lit pprExpr sty (HsLam match) - = ppCat [ppStr "\\", ppNest 2 (pprMatch sty True match)] + = ppCat [ppChar '\\', ppNest 2 (pprMatch sty True 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) +pprExpr sty (OpApp e1 op fixity e2) = case op of HsVar v -> pp_infixly v _ -> pp_prefixly where - pp_e1 = pprParendExpr sty e1 + pp_e1 = pprParendExpr sty e1 -- Add parens to make precedence clear pp_e2 = pprParendExpr 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 [ppr sty v, pp_e2]] -pprExpr sty (NegApp e) +pprExpr sty (NegApp e _) = ppBeside (ppChar '-') (pprParendExpr sty e) pprExpr sty (HsPar e) @@ -237,11 +237,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, ppPStr SLIT("x_ )")]) pp_infixly v = ppSep [ ppBeside ppLparen pp_expr, - ppBeside (pprOp sty v) ppRparen ] + ppBeside (ppr sty v) ppRparen ] pprExpr sty (SectionR op expr) = case op of @@ -250,10 +250,10 @@ 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 (ppr sty v), ppBeside pp_expr ppRparen ] pprExpr sty (HsCase expr matches _) @@ -275,14 +275,8 @@ pprExpr sty (HsLet binds expr) = ppSep [ppHang (ppPStr SLIT("let")) 2 (ppr sty binds), ppHang (ppPStr SLIT("in")) 2 (ppr sty 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 (ListComp expr quals) - = ppHang (ppCat [ppLbrack, pprExpr sty expr, ppChar '|']) - 4 (ppSep [interpp'SP sty quals, ppRbrack]) +pprExpr sty (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp sty stmts +pprExpr sty (HsDoOut do_or_list_comp stmts _ _ _ _ _) = pprDo do_or_list_comp sty stmts pprExpr sty (ExplicitList exprs) = ppBracket (ppInterleave ppComma (map (pprExpr sty) exprs)) @@ -302,8 +296,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) @@ -312,11 +306,11 @@ pprExpr sty (ArithSeqOut expr info) PprForUser -> ppBracket (ppr sty info) _ -> - ppBesides [ppLbrack, ppParens (ppr sty expr), ppr sty info, ppRbrack] + ppBesides [ppLbrack, ppParens (ppr sty expr), ppSP, ppr sty info, ppRbrack] pprExpr sty (CCall fun args _ is_asm result_ty) = ppHang (if is_asm - then ppBesides [ppStr "_casm_ ``", ppPStr fun, ppStr "''"] + then ppBesides [ppPStr SLIT("_casm_ ``"), ppPStr fun, ppPStr SLIT("''")] else ppBeside (ppPStr SLIT("_ccall_ ")) (ppPStr fun)) 4 (ppSep (map (pprParendExpr sty) args)) @@ -325,7 +319,7 @@ pprExpr sty (HsSCC label expr) pprParendExpr sty expr ] pprExpr sty (TyLam tyvars expr) - = ppHang (ppCat [ppStr "/\\", interppSP sty tyvars, ppStr "->"]) + = ppHang (ppCat [ppPStr SLIT("/\\"), interppSP sty tyvars, ppPStr SLIT("->")]) 4 (pprExpr sty expr) pprExpr sty (TyApp expr [ty]) @@ -336,7 +330,7 @@ pprExpr sty (TyApp expr tys) 4 (ppBracket (interpp'SP sty tys)) pprExpr sty (DictLam dictvars expr) - = ppHang (ppCat [ppStr "\\{-dict-}", interppSP sty dictvars, ppStr "->"]) + = ppHang (ppCat [ppPStr SLIT("\\{-dict-}"), interppSP sty dictvars, ppPStr SLIT("->")]) 4 (pprExpr sty expr) pprExpr sty (DictApp expr [dname]) @@ -347,10 +341,10 @@ pprExpr sty (DictApp expr dnames) 4 (ppBracket (interpp'SP sty dnames)) pprExpr sty (ClassDictLam dicts methods expr) - = ppHang (ppCat [ppStr "\\{-classdict-}", + = ppHang (ppCat [ppPStr SLIT("\\{-classdict-}"), ppBracket (interppSP sty dicts), ppBracket (interppSP sty methods), - ppStr "->"]) + ppPStr SLIT("->")]) 4 (pprExpr sty expr) pprExpr sty (Dictionary dicts methods) @@ -361,8 +355,6 @@ pprExpr sty (Dictionary dicts methods) pprExpr sty (SingleDict 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: @@ -378,10 +370,13 @@ pprParendExpr sty expr case expr of HsLit l -> ppr sty l HsLitOut l _ -> ppr sty l + HsVar _ -> pp_as_was ExplicitList _ -> pp_as_was ExplicitListOut _ _ -> pp_as_was ExplicitTuple _ -> pp_as_was + HsPar _ -> pp_as_was + _ -> ppParens pp_as_was \end{code} @@ -398,27 +393,47 @@ pp_rbinds :: (NamedThing id, Outputable id, Outputable pat, -> HsRecordBinds tyvar uvar id pat -> Pretty pp_rbinds sty thing rbinds - = ppHang thing 4 - (ppBesides [ppChar '{', ppInterleave ppComma (map (pp_rbind sty) rbinds), ppChar '}']) + = ppHang thing + 4 (ppCurlies (ppIntersperse pp'SP (map (pp_rbind sty) rbinds))) 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, ppChar '=', ppr sty e] \end{code} %************************************************************************ %* * -\subsection{Do stmts} +\subsection{Do stmts and list comprehensions} %* * %************************************************************************ \begin{code} +data DoOrListComp = DoStmt | ListComp + +pprDo DoStmt sty stmts + = ppHang (ppPStr SLIT("do")) 2 (ppAboves (map (ppr sty) stmts)) +pprDo ListComp sty stmts + = ppHang (ppCat [ppLbrack, pprExpr sty expr, ppChar '|']) + 4 (ppSep [interpp'SP sty quals, ppRbrack]) + where + ReturnStmt expr = last stmts -- Last stmt should be a ReturnStmt for list comps + quals = init stmts +\end{code} + +\begin{code} data Stmt tyvar uvar id pat = BindStmt pat (HsExpr tyvar uvar id pat) SrcLoc - | ExprStmt (HsExpr tyvar uvar id pat) - SrcLoc + | LetStmt (HsBinds tyvar uvar id pat) + + | GuardStmt (HsExpr tyvar uvar id pat) -- List comps only + SrcLoc + + | ExprStmt (HsExpr tyvar uvar id pat) -- Do stmts only + SrcLoc + + | ReturnStmt (HsExpr tyvar uvar id pat) -- List comps only, at the end \end{code} \begin{code} @@ -426,11 +441,15 @@ instance (NamedThing id, Outputable id, Outputable pat, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => Outputable (Stmt tyvar uvar id pat) where ppr sty (BindStmt pat expr _) - = ppCat [ppr sty pat, ppStr "<-", ppr sty expr] + = ppCat [ppr sty pat, ppPStr SLIT("<-"), ppr sty expr] ppr sty (LetStmt binds) = ppCat [ppPStr SLIT("let"), ppr sty binds] ppr sty (ExprStmt expr _) = ppr sty expr + ppr sty (GuardStmt expr _) + = ppr sty expr + ppr sty (ReturnStmt expr) + = ppCat [ppPStr SLIT("return"), ppr sty expr] \end{code} %************************************************************************ @@ -463,24 +482,3 @@ instance (NamedThing id, Outputable id, Outputable pat, pp_dotdot = ppPStr SLIT(" .. ") \end{code} - -``Qualifiers'' in list comprehensions: -\begin{code} -data Qual tyvar uvar id pat - = GeneratorQual pat - (HsExpr tyvar uvar id pat) - | LetQual (HsBinds tyvar uvar id pat) - | FilterQual (HsExpr tyvar uvar id pat) -\end{code} - -\begin{code} -instance (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - Outputable (Qual tyvar uvar id pat) where - ppr sty (GeneratorQual pat expr) - = ppCat [ppr sty pat, ppStr "<-", ppr sty expr] - ppr sty (LetQual binds) - = ppCat [ppPStr SLIT("let"), ppr sty binds] - ppr sty (FilterQual expr) - = ppr sty expr -\end{code}