X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsExpr.lhs;h=1acfd7102d5ee0390f734a7911cc473ee3f9f2be;hb=a8d4805f598186a88e56a1ce41644ac24ef00549;hp=bc64534af4933ff1c196076cb69e0cf9c511aae1;hpb=4250d64191132fd493985549eda5ca05b82a663f;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index bc64534..1acfd71 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -8,25 +8,31 @@ module HsExpr where -import Ubiq{-uitous-} -import HsLoop -- for paranoia checking +IMP_Ubiq(){-uitous-} -- friends: +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 +IMPORT_DELOOPER(HsLoop) ( pprMatches, pprMatch, Match ) +#else +import {-# SOURCE #-} HsMatches ( pprMatches, pprMatch, Match ) +#endif + import HsBinds ( HsBinds ) -import HsLit ( HsLit ) -import HsMatches ( pprMatches, pprMatch, Match ) -import HsTypes ( PolyType ) +import HsBasic ( HsLit ) +import BasicTypes ( Fixity(..), FixityDirection(..) ) +import HsTypes ( HsType ) -- others: -import Id ( DictVar(..), GenId, Id(..) ) -import Name ( isSymLexeme, pprSym ) -import Outputable ( interppSP, interpp'SP, ifnotPprForUser ) +import Id ( SYN_IE(DictVar), GenId, SYN_IE(Id) ) +import Outputable ( pprQuote, interppSP, interpp'SP, ifnotPprForUser, + PprStyle(..), userStyle, Outputable(..) ) import PprType ( pprGenType, pprParendGenType, GenType{-instance-} ) import Pretty -import PprStyle ( PprStyle(..) ) import SrcLoc ( SrcLoc ) import Usage ( GenUsage{-instance-} ) -import Util ( panic{-ToDo:rm eventually-} ) +#if __GLASGOW_HASKELL__ >= 202 +import Name +#endif \end{code} %************************************************************************ @@ -54,13 +60,14 @@ 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 - id -- the negate id + (HsExpr tyvar uvar id pat) -- the negate id (in a HsVar) | HsPar (HsExpr tyvar uvar id pat) -- parenthesised expr @@ -81,16 +88,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 @@ -113,12 +122,14 @@ data HsExpr tyvar uvar id pat (HsRecordBinds tyvar uvar id pat) | RecordUpdOut (HsExpr tyvar uvar id pat) -- TRANSLATION + (GenType tyvar uvar) -- Type of *result* record (may differ from + -- type of input record) [id] -- Dicts needed for construction (HsRecordBinds 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 @@ -172,11 +183,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", @@ -193,45 +199,48 @@ A @Dictionary@, unless of length 0 or 1, becomes a tuple. A instance (NamedThing id, Outputable id, Outputable pat, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => Outputable (HsExpr tyvar uvar id pat) where - ppr = pprExpr + ppr sty expr = pprQuote sty $ \ sty -> pprExpr sty expr \end{code} \begin{code} -pprExpr sty (HsVar v) - = (if (isSymLexeme v) then ppParens else id) (ppr sty v) +pprExpr :: (NamedThing id, Outputable id, Outputable pat, + Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) + => PprStyle -> HsExpr tyvar uvar id pat -> Doc + +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)] + = hsep [char '\\', nest 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)) + (pprExpr sty fun) <+> (sep (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]) + = hang (pprExpr sty op) 4 (sep [pp_e1, pp_e2]) pp_infixly v - = ppSep [pp_e1, ppCat [pprSym sty v, pp_e2]] + = sep [pp_e1, hsep [ppr sty v, pp_e2]] pprExpr sty (NegApp e _) - = ppBeside (ppChar '-') (pprParendExpr sty e) + = (<>) (char '-') (pprParendExpr sty e) pprExpr sty (HsPar e) - = ppParens (pprExpr sty e) + = parens (pprExpr sty e) pprExpr sty (SectionL expr op) = case op of @@ -240,11 +249,9 @@ 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_infixly v - = ppSep [ ppBeside ppLparen pp_expr, - ppBeside (pprSym sty v) ppRparen ] + pp_prefixly = hang (hsep [text " \\ x_ ->", ppr sty op]) + 4 (hsep [pp_expr, ptext SLIT("x_ )")]) + pp_infixly v = parens (sep [pp_expr, ppr sty v]) pprExpr sty (SectionR op expr) = case op of @@ -253,126 +260,114 @@ pprExpr sty (SectionR op expr) where pp_expr = pprParendExpr sty expr - pp_prefixly = ppHang (ppCat [ppStr "( \\ _x ->", ppr sty op, ppPStr SLIT("_x")]) - 4 (ppBeside pp_expr ppRparen) + pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr sty op, ptext SLIT("x_")]) + 4 ((<>) pp_expr rparen) pp_infixly v - = ppSep [ ppBeside ppLparen (pprSym sty v), - ppBeside pp_expr ppRparen ] + = parens (sep [ppr sty v, pp_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) ] + = sep [ sep [ptext SLIT("case"), nest 4 (pprExpr sty expr), ptext SLIT("of")], + nest 2 (pprMatches sty (True, empty) matches) ] 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)] + = sep [hsep [ptext SLIT("if"), nest 2 (pprExpr sty e1), ptext SLIT("then")], + nest 4 (pprExpr sty e2), + ptext SLIT("else"), + nest 4 (pprExpr sty e3)] -- special case: let ... in let ... pprExpr sty (HsLet binds expr@(HsLet _ _)) - = ppSep [ppHang (ppPStr SLIT("let")) 2 (ppCat [ppr sty binds, ppPStr SLIT("in")]), + = sep [hang (ptext SLIT("let")) 2 (hsep [ppr sty binds, ptext SLIT("in")]), ppr sty expr] 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)] + = sep [hang (ptext SLIT("let")) 2 (ppr sty binds), + hang (ptext SLIT("in")) 2 (ppr sty expr)] -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)) + = brackets (fsep (punctuate comma (map (pprExpr sty) exprs))) pprExpr sty (ExplicitListOut ty exprs) - = ppBesides [ ppBracket (ppInterleave ppComma (map (pprExpr sty) exprs)), - ifnotPprForUser sty (ppBeside ppSP (ppParens (pprGenType sty ty))) ] + = hcat [ brackets (fsep (punctuate comma (map (pprExpr sty) exprs))), + ifnotPprForUser sty ((<>) space (parens (pprGenType sty ty))) ] pprExpr sty (ExplicitTuple exprs) - = ppParens (ppInterleave ppComma (map (pprExpr sty) exprs)) + = parens (sep (punctuate comma (map (pprExpr sty) exprs))) 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) +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) + = hang ((<>) (nest 2 (pprExpr sty expr)) (ptext SLIT(" ::"))) + 4 (ppr sty sig) pprExpr sty (ArithSeqIn info) - = ppBracket (ppr sty info) + = brackets (ppr sty info) pprExpr sty (ArithSeqOut expr info) - = case sty of - PprForUser -> - ppBracket (ppr sty info) - _ -> - ppBesides [ppLbrack, ppParens (ppr sty expr), ppr sty info, ppRbrack] + | userStyle sty = brackets (ppr sty info) + | otherwise = brackets (hcat [parens (ppr sty expr), space, ppr sty info]) 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)) + = hang (if is_asm + then hcat [ptext SLIT("_casm_ ``"), ptext fun, ptext SLIT("''")] + else (<>) (ptext SLIT("_ccall_ ")) (ptext fun)) + 4 (sep (map (pprParendExpr sty) args)) pprExpr sty (HsSCC label expr) - = ppSep [ ppBeside (ppPStr SLIT("_scc_ ")) (ppBesides [ppChar '"', ppPStr label, ppChar '"']), + = sep [ (<>) (ptext SLIT("_scc_ ")) (hcat [char '"', ptext label, char '"']), pprParendExpr sty expr ] pprExpr sty (TyLam tyvars expr) - = ppHang (ppCat [ppStr "/\\", interppSP sty tyvars, ppStr "->"]) + = hang (hsep [ptext SLIT("/\\"), interppSP sty tyvars, ptext SLIT("->")]) 4 (pprExpr sty expr) pprExpr sty (TyApp expr [ty]) - = ppHang (pprExpr sty expr) 4 (pprParendGenType sty ty) + = hang (pprExpr sty expr) 4 (pprParendGenType sty ty) pprExpr sty (TyApp expr tys) - = ppHang (pprExpr sty expr) - 4 (ppBracket (interpp'SP sty tys)) + = hang (pprExpr sty expr) + 4 (brackets (interpp'SP sty tys)) pprExpr sty (DictLam dictvars expr) - = ppHang (ppCat [ppStr "\\{-dict-}", interppSP sty dictvars, ppStr "->"]) + = hang (hsep [ptext SLIT("\\{-dict-}"), interppSP sty dictvars, ptext SLIT("->")]) 4 (pprExpr sty expr) pprExpr sty (DictApp expr [dname]) - = ppHang (pprExpr sty expr) 4 (ppr sty dname) + = hang (pprExpr sty expr) 4 (ppr sty dname) pprExpr sty (DictApp expr dnames) - = ppHang (pprExpr sty expr) - 4 (ppBracket (interpp'SP sty dnames)) + = hang (pprExpr sty expr) + 4 (brackets (interpp'SP sty dnames)) pprExpr sty (ClassDictLam dicts methods expr) - = ppHang (ppCat [ppStr "\\{-classdict-}", - ppBracket (interppSP sty dicts), - ppBracket (interppSP sty methods), - ppStr "->"]) + = hang (hsep [ptext SLIT("\\{-classdict-}"), + brackets (interppSP sty dicts), + brackets (interppSP sty methods), + ptext SLIT("->")]) 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]] + = parens (sep [ptext SLIT("{-dict-}"), + brackets (interpp'SP sty dicts), + brackets (interpp'SP sty methods)]) pprExpr sty (SingleDict dname) - = ppCat [ppPStr SLIT("{-singleDict-}"), ppr sty dname] + = hsep [ptext 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: \begin{code} pprParendExpr :: (NamedThing id, Outputable id, Outputable pat, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => PprStyle -> HsExpr tyvar uvar id pat -> Pretty + => PprStyle -> HsExpr tyvar uvar id pat -> Doc pprParendExpr sty expr = let @@ -381,11 +376,14 @@ 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 - _ -> ppParens pp_as_was + HsPar _ -> pp_as_was + + _ -> parens pp_as_was \end{code} %************************************************************************ @@ -397,43 +395,69 @@ pprParendExpr sty expr \begin{code} pp_rbinds :: (NamedThing id, Outputable id, Outputable pat, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => PprStyle -> Pretty - -> HsRecordBinds tyvar uvar id pat -> Pretty + => PprStyle -> Doc + -> HsRecordBinds tyvar uvar id pat -> Doc pp_rbinds sty thing rbinds - = ppHang thing 4 - (ppBesides [ppChar '{', ppInterleave ppComma (map (pp_rbind sty) rbinds), ppChar '}']) + = hang thing + 4 (braces (hsep (punctuate comma (map (pp_rbind sty) rbinds)))) where - pp_rbind PprForUser (v, _, True) = ppr PprForUser v - pp_rbind sty (v, e, _) = ppCat [ppr sty v, ppStr "=", ppr sty e] + pp_rbind sty (v, _, True) | userStyle sty = ppr sty v + pp_rbind sty (v, e, _) = hsep [ppr sty v, char '=', ppr sty e] \end{code} %************************************************************************ %* * -\subsection{Do stmts} +\subsection{Do stmts and list comprehensions} %* * %************************************************************************ \begin{code} +data DoOrListComp = DoStmt | ListComp + +pprDo DoStmt sty stmts + = hang (ptext SLIT("do")) 2 (vcat (map (ppr sty) stmts)) +pprDo ListComp sty stmts + = hang (hsep [lbrack, pprExpr sty expr, char '|']) + 4 (sep [interpp'SP sty quals, rbrack]) + 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} 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] - ppr sty (LetStmt binds) - = ppCat [ppPStr SLIT("let"), ppr sty binds] - ppr sty (ExprStmt expr _) - = ppr sty expr + ppr sty stmt = pprQuote sty $ \ sty -> pprStmt sty stmt + +pprStmt sty (BindStmt pat expr _) + = hsep [ppr sty pat, ptext SLIT("<-"), ppr sty expr] +pprStmt sty (LetStmt binds) + = hsep [ptext SLIT("let"), ppr sty binds] +pprStmt sty (ExprStmt expr _) + = ppr sty expr +pprStmt sty (GuardStmt expr _) + = ppr sty expr +pprStmt sty (ReturnStmt expr) + = hsep [ptext SLIT("return"), ppr sty expr] \end{code} %************************************************************************ @@ -458,32 +482,11 @@ data ArithSeqInfo tyvar uvar id pat instance (NamedThing id, Outputable id, Outputable pat, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => Outputable (ArithSeqInfo tyvar uvar id pat) where - ppr sty (From e1) = ppBesides [ppr sty e1, pp_dotdot] - ppr sty (FromThen e1 e2) = ppBesides [ppr sty e1, pp'SP, ppr sty e2, pp_dotdot] - ppr sty (FromTo e1 e3) = ppBesides [ppr sty e1, pp_dotdot, ppr sty e3] + ppr sty (From e1) = hcat [ppr sty e1, pp_dotdot] + ppr sty (FromThen e1 e2) = hcat [ppr sty e1, comma, space, ppr sty e2, pp_dotdot] + ppr sty (FromTo e1 e3) = hcat [ppr sty e1, pp_dotdot, ppr sty e3] ppr sty (FromThenTo e1 e2 e3) - = ppBesides [ppr sty e1, pp'SP, ppr sty e2, pp_dotdot, ppr sty e3] - -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} + = hcat [ppr sty e1, comma, space, ppr sty e2, pp_dotdot, ppr sty e3] -\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 +pp_dotdot = ptext SLIT(" .. ") \end{code}