X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FHsExpr.lhs;h=fd4f6db8ebe59941e79f1b3237990b1024ef6d14;hb=6f8ff0bbad3b9fa389c960ad1b5a267a1ae502f1;hp=c3f38cac4bfaf9910887fd49a4df1ab0423841f7;hpb=f04dead93a15af1cb818172f207b8a81d2c81298;p=ghc-hetmet.git diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index c3f38ca..fd4f6db 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -744,7 +744,7 @@ pprPatBind pat ty@(grhss) pprMatch :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> Match idR -> SDoc pprMatch ctxt (Match pats maybe_ty grhss) - = herald <+> sep [sep (map ppr other_pats), + = herald <+> sep [sep (map pprParendLPat other_pats), ppr_maybe_ty, nest 2 (pprGRHSs ctxt grhss)] where @@ -756,18 +756,21 @@ pprMatch ctxt (Match pats maybe_ty grhss) -- Not pprBndr; the AbsBinds will -- have printed the signature - | null pats3 -> (pp_infix, []) + | null pats2 -> (pp_infix, []) -- x &&& y = e - | otherwise -> (parens pp_infix, pats3) + | otherwise -> (parens pp_infix, pats2) -- (x &&& y) z = e where - (pat1:pat2:pats3) = pats - pp_infix = ppr pat1 <+> ppr fun <+> ppr pat2 + pp_infix = pprParendLPat pat1 <+> ppr fun <+> pprParendLPat pat2 LambdaExpr -> (char '\\', pats) - _ -> (empty, pats) + + _ -> ASSERT( null pats1 ) + (ppr pat1, []) -- No parens around the single pat + (pat1:pats1) = pats + (pat2:pats2) = pats1 ppr_maybe_ty = case maybe_ty of Just ty -> dcolon <+> ppr ty Nothing -> empty @@ -777,8 +780,8 @@ pprGRHSs :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> GRHSs idR -> SDoc pprGRHSs ctxt (GRHSs grhss binds) = vcat (map (pprGRHS ctxt . unLoc) grhss) - $$ if isEmptyLocalBinds binds then empty - else text "where" $$ nest 4 (pprBinds binds) + $$ ppUnless (isEmptyLocalBinds binds) + (text "where" $$ nest 4 (pprBinds binds)) pprGRHS :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> GRHS idR -> SDoc @@ -857,12 +860,9 @@ data StmtLR idL idR , recS_rec_ids :: [idR] -- Ditto, but these variables are the "recursive" ones, -- that are used before they are bound in the stmts of -- the RecStmt. - -- An Id can be in both groups -- Both sets of Ids are (now) treated monomorphically - -- The only reason they are separate is becuase the DsArrows - -- code uses them separately, and I don't understand it well - -- enough to change it + -- See Note [How RecStmt works] for why they are separate -- Rebindable syntax , recS_bind_fn :: SyntaxExpr idR -- The bind function @@ -912,25 +912,30 @@ Array comprehensions are handled like list comprehensions -=chak Note [How RecStmt works] ~~~~~~~~~~~~~~~~~~~~~~~~ Example: - HsDo [ BindStmt x ex + HsDo [ BindStmt x ex - , RecStmt [a::forall a. a -> a, b] - [a::Int -> Int, c] - [ BindStmt b (return x) - , LetStmt a = ea - , BindStmt c ec ] + , RecStmt { recS_rec_ids = [a, c] + , recS_stmts = [ BindStmt b (return (a,c)) + , LetStmt a = ...b... + , BindStmt c ec ] + , recS_later_ids = [a, b] - , return (a b) ] + , return (a b) ] Here, the RecStmt binds a,b,c; but - Only a,b are used in the stmts *following* the RecStmt, - This 'a' is *polymorphic' - Only a,c are used in the stmts *inside* the RecStmt *before* their bindings - This 'a' is monomorphic -Nota Bene: the two a's have different types, even though they -have the same Name. +Why do we need *both* rec_ids and later_ids? For monads they could be +combined into a single set of variables, but not for arrows. That +follows from the types of the respective feedback operators: + + mfix :: MonadFix m => (a -> m a) -> m a + loop :: ArrowLoop a => a (b,d) (c,d) -> a b c + +* For mfix, the 'a' covers the union of the later_ids and the rec_ids +* For 'loop', 'c' is the later_ids and 'd' is the rec_ids Note [Typing a RecStmt] ~~~~~~~~~~~~~~~~~~~~~~~ @@ -973,6 +978,7 @@ pprGroupByClause (GroupBySomething eitherUsingExpr byExpr) = hsep [ptext (sLit " pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc pprDo DoExpr stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body +pprDo GhciStmt stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body pprDo (MDoExpr _) stmts body = ptext (sLit "mdo") <+> ppr_do_stmts stmts body pprDo ListComp stmts body = pprComp brackets stmts body pprDo PArrComp stmts body = pprComp pa_brackets stmts body @@ -1011,22 +1017,24 @@ pprSplice (HsSplice n e) = char '$' <> ifPprDebug (brackets (ppr n)) <> pprParendExpr e -data HsBracket id = ExpBr (LHsExpr id) -- [| expr |] - | PatBr (LPat id) -- [p| pat |] - | DecBr (HsGroup id) -- [d| decls |] - | TypBr (LHsType id) -- [t| type |] - | VarBr id -- 'x, ''T +data HsBracket id = ExpBr (LHsExpr id) -- [| expr |] + | PatBr (LPat id) -- [p| pat |] + | DecBrL [LHsDecl id] -- [d| decls |]; result of parser + | DecBrG (HsGroup id) -- [d| decls |]; result of renamer + | TypBr (LHsType id) -- [t| type |] + | VarBr id -- 'x, ''T instance OutputableBndr id => Outputable (HsBracket id) where ppr = pprHsBracket pprHsBracket :: OutputableBndr id => HsBracket id -> SDoc -pprHsBracket (ExpBr e) = thBrackets empty (ppr e) -pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p) -pprHsBracket (DecBr d) = thBrackets (char 'd') (ppr d) -pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t) -pprHsBracket (VarBr n) = char '\'' <> ppr n +pprHsBracket (ExpBr e) = thBrackets empty (ppr e) +pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p) +pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp) +pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds)) +pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t) +pprHsBracket (VarBr n) = char '\'' <> ppr n -- Infelicity: can't show ' vs '', because -- we can't ask n what its OccName is, because the -- pretty-printer for HsExpr doesn't ask for NamedThings @@ -1085,11 +1093,13 @@ data HsMatchContext id -- Context of a Match -- tell matchWrapper what sort of -- runtime error message to generate] | StmtCtxt (HsStmtContext id) -- Pattern of a do-stmt or list comprehension + | ThPatQuote -- A Template Haskell pattern quotation [p| (a,b) |] deriving () data HsStmtContext id = ListComp | DoExpr + | GhciStmt -- A command-line Stmt in GHCi pat <- rhs | MDoExpr PostTcTable -- Recursive do-expression -- (tiresomely, it needs table -- of its return/bind ops) @@ -1120,6 +1130,7 @@ matchSeparator ProcExpr = ptext (sLit "->") matchSeparator PatBindRhs = ptext (sLit "=") matchSeparator (StmtCtxt _) = ptext (sLit "<-") matchSeparator RecUpd = panic "unused" +matchSeparator ThPatQuote = panic "unused" \end{code} \begin{code} @@ -1128,6 +1139,7 @@ pprMatchContext (FunRhs fun _) = ptext (sLit "the definition of") <+> quotes (ppr fun) pprMatchContext CaseAlt = ptext (sLit "a case alternative") pprMatchContext RecUpd = ptext (sLit "a record-update construct") +pprMatchContext ThPatQuote = ptext (sLit "a Template Haskell pattern quotation") pprMatchContext PatBindRhs = ptext (sLit "a pattern binding") pprMatchContext LambdaExpr = ptext (sLit "a lambda abstraction") pprMatchContext ProcExpr = ptext (sLit "an arrow abstraction") @@ -1141,6 +1153,7 @@ pprStmtContext (TransformStmtCtxt c) = sep [ptext (sLit "a transformed branch of"), pprStmtContext c] pprStmtContext (PatGuard ctxt) = ptext (sLit "a pattern guard for") $$ pprMatchContext ctxt +pprStmtContext GhciStmt = ptext (sLit "an interactive GHCi command") pprStmtContext DoExpr = ptext (sLit "a 'do' expression") pprStmtContext (MDoExpr _) = ptext (sLit "an 'mdo' expression") pprStmtContext ListComp = ptext (sLit "a list comprehension") @@ -1169,9 +1182,11 @@ matchContextErrString PatBindRhs = ptext (sLit "pattern binding" matchContextErrString RecUpd = ptext (sLit "record update") matchContextErrString LambdaExpr = ptext (sLit "lambda") matchContextErrString ProcExpr = ptext (sLit "proc") +matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) matchContextErrString (StmtCtxt (TransformStmtCtxt c)) = matchContextErrString (StmtCtxt c) matchContextErrString (StmtCtxt (PatGuard _)) = ptext (sLit "pattern guard") +matchContextErrString (StmtCtxt GhciStmt) = ptext (sLit "interactive GHCi command") matchContextErrString (StmtCtxt DoExpr) = ptext (sLit "'do' expression") matchContextErrString (StmtCtxt (MDoExpr _)) = ptext (sLit "'mdo' expression") matchContextErrString (StmtCtxt ListComp) = ptext (sLit "list comprehension")