X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FHsExpr.lhs;h=cdf7322b46d83055ebcb86a7c51e71620efcf10e;hb=69f8ed93800605d8df011388450d6d3bb9ca6071;hp=3142abc9324ad1912874a0abefe1c771e47c2298;hpb=58521c72cec262496dabf5fffb057d25ab17a0f7;p=ghc-hetmet.git

diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 3142abc..cdf7322 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -392,7 +392,7 @@ ppr_expr (ExplicitTuple exprs boxity)
   where
     ppr_tup_args []               = []
     ppr_tup_args (Present e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es
-    ppr_tup_args (Missing _ : es) = comma : ppr_tup_args es
+    ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es
 
     punc (Present {} : _) = comma <> space
     punc (Missing {} : _) = comma
@@ -469,21 +469,24 @@ ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
   = hsep [ptext (sLit "proc"), ppr pat, ptext (sLit "->"), ppr cmd]
 
 ppr_expr (HsTick tickId vars exp)
-  = hcat [ptext (sLit "tick<"),
-          ppr tickId,
-          ptext (sLit ">("),
-          hsep (map pprHsVar vars),
-          ppr exp,
-          ptext (sLit ")")]
+  = pprTicks (ppr exp) $
+    hcat [ptext (sLit "tick<"),
+    ppr tickId,
+    ptext (sLit ">("),
+    hsep (map pprHsVar vars),
+    ppr exp,
+    ptext (sLit ")")]
 ppr_expr (HsBinTick tickIdTrue tickIdFalse exp)
-  = hcat [ptext (sLit "bintick<"),
+  = pprTicks (ppr exp) $
+    hcat [ptext (sLit "bintick<"),
           ppr tickIdTrue,
           ptext (sLit ","),
           ppr tickIdFalse,
           ptext (sLit ">("),
           ppr exp,ptext (sLit ")")]
 ppr_expr (HsTickPragma externalSrcLoc exp)
-  = hcat [ptext (sLit "tickpragma<"),
+  = pprTicks (ppr exp) $
+    hcat [ptext (sLit "tickpragma<"),
           ppr externalSrcLoc,
           ptext (sLit ">("),
           ppr exp,
@@ -939,12 +942,19 @@ pprGroupByClause (GroupBySomething eitherUsingExpr byExpr) = hsep [ptext (sLit "
   where usingExprDoc = either (\usingExpr -> hsep [ptext (sLit "using"), ppr usingExpr]) (const empty) eitherUsingExpr
 
 pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc
-pprDo DoExpr      stmts body = ptext (sLit "do")  <+> pprDeeperList vcat (map ppr stmts ++ [ppr body])
-pprDo (MDoExpr _) stmts body = ptext (sLit "mdo") <+> pprDeeperList vcat (map ppr stmts ++ [ppr body])
+pprDo DoExpr      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
 pprDo _           _     _    = panic "pprDo" -- PatGuard, ParStmtCxt
 
+ppr_do_stmts :: OutputableBndr id => [LStmt id] -> LHsExpr id -> SDoc
+-- Print a bunch of do stmts, with explicit braces and semicolons,
+-- so that we are not vulnerable to layout bugs
+ppr_do_stmts stmts body
+  = lbrace <+> pprDeeperList vcat ([ ppr s <> semi | s <- stmts] ++ [ppr body])
+           <+> rbrace
+
 pprComp :: OutputableBndr id => (SDoc -> SDoc) -> [LStmt id] -> LHsExpr id -> SDoc
 pprComp brack quals body
   = brack $