Fix Trac #2597 (second bug): complain about an empty DoE block

[ghc-hetmet.git] / compiler / hsSyn / HsExpr.lhs

diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index cef711f..bbb2712 100644 (file)
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -15,7 +15,6 @@ import HsDecls
 import HsPat
 import HsLit
 import HsTypes
-import HsImpExp
 import HsBinds
 
 -- others:
@@ -160,7 +159,7 @@ data HsExpr id
   | RecordUpd   (LHsExpr id)
                 (HsRecordBinds id)
                 [DataCon]          -- Filled in by the type checker to the
-                                   -- *non-empty* list of DataCons that have
+                                   -- _non-empty_ list of DataCons that have
                                    -- all the upd'd fields
                 [PostTcType]       -- Argument types of *input* record type
                 [PostTcType]       --              and  *output* record type
@@ -198,7 +197,7 @@ data HsExpr id
   | HsBracketOut (HsBracket Name)       -- Output of the type checker is
                                         -- the *original*
                  [PendingSplice]        -- renamed expression, plus
-                                        -- *typechecked* splices to be
+                                        -- _typechecked_ splices to be
                                         -- pasted back in by the desugarer
 
   | HsSpliceE (HsSplice id)
@@ -346,7 +345,7 @@ ppr_expr (OpApp e1 op _ e2)
       = hang (ppr op) 2 (sep [pp_e1, pp_e2])
 
     pp_infixly v
-      = sep [nest 2 pp_e1, pprInfix v, nest 2 pp_e2]
+      = sep [nest 2 pp_e1, pprHsInfix v, nest 2 pp_e2]
 
 ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e
 
@@ -359,7 +358,7 @@ ppr_expr (SectionL expr op)
 
     pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
                        4 (hsep [pp_expr, ptext (sLit "x_ )")])
-    pp_infixly v = (sep [pp_expr, pprInfix v])
+    pp_infixly v = (sep [pp_expr, pprHsInfix v])
 
 ppr_expr (SectionR op expr)
   = case unLoc op of
@@ -371,7 +370,7 @@ ppr_expr (SectionR op expr)
     pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext (sLit "x_")])
                        4 ((<>) pp_expr rparen)
     pp_infixly v
-      = (sep [pprInfix v, pp_expr])
+      = (sep [pprHsInfix v, pp_expr])
 
 --avoid using PatternSignatures for stage1 code portability
 ppr_expr exprType@(HsLam matches)
@@ -379,8 +378,8 @@ ppr_expr exprType@(HsLam matches)
  where idType :: HsExpr id -> HsMatchContext id; idType = undefined
 
 ppr_expr exprType@(HsCase expr matches)
-  = sep [ sep [ptext (sLit "case"), nest 4 (ppr expr), ptext (sLit "of")],
-          nest 2 (pprMatches (CaseAlt `asTypeOf` idType exprType) matches) ]
+  = sep [ sep [ptext (sLit "case"), nest 4 (ppr expr), ptext (sLit "of {")],
+          nest 2 (pprMatches (CaseAlt `asTypeOf` idType exprType) matches <+> char '}') ]
  where idType :: HsExpr id -> HsMatchContext id; idType = undefined
 
 ppr_expr (HsIf e1 e2 e3)
@@ -441,10 +440,7 @@ ppr_expr (HsSpliceE s)       = pprSplice s
 ppr_expr (HsBracket b)       = pprHsBracket b
 ppr_expr (HsBracketOut e []) = ppr e
 ppr_expr (HsBracketOut e ps) = ppr e $$ ptext (sLit "pending") <+> ppr ps
-ppr_expr (HsQuasiQuoteE (HsQuasiQuote name quoter _ quote)) 
-    = char '$' <> brackets (ppr name) <>
-      ptext (sLit "[:") <> ppr quoter <> ptext (sLit "|") <>
-      ppr quote <> ptext (sLit "|]")
+ppr_expr (HsQuasiQuoteE qq)  = ppr qq
 
 ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
   = hsep [ptext (sLit "proc"), ppr pat, ptext (sLit "->"), ppr cmd]
@@ -480,7 +476,7 @@ ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False)
   = hsep [ppr_lexpr arg, ptext (sLit ">>-"), ppr_lexpr arrow]
 
 ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2])
-  = sep [pprCmdArg (unLoc arg1), hsep [pprInfix v, pprCmdArg (unLoc arg2)]]
+  = sep [pprCmdArg (unLoc arg1), hsep [pprHsInfix v, pprCmdArg (unLoc arg2)]]
 ppr_expr (HsArrForm op _ args)
   = hang (ptext (sLit "(|") <> ppr_lexpr op)
          4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)"))
@@ -491,11 +487,8 @@ pprCmdArg (HsCmdTop cmd@(L _ (HsArrForm _ Nothing [])) _ _ _)
 pprCmdArg (HsCmdTop cmd _ _ _)
   = parens (ppr_lexpr cmd)
 
--- Put a var in backquotes if it's not an operator already
-pprInfix :: Outputable name => name -> SDoc
-pprInfix v | isOperator ppr_v = ppr_v
-           | otherwise        = char '`' <> ppr_v <> char '`'
-    where ppr_v = ppr v
+instance OutputableBndr id => Outputable (HsCmdTop id) where
+    ppr = pprCmdArg
 
 -- add parallel array brackets around a document
 --
@@ -670,9 +663,12 @@ data Match id
                                 -- Nothing after typechecking
         (GRHSs id)
 
+isEmptyMatchGroup :: MatchGroup id -> Bool
+isEmptyMatchGroup (MatchGroup ms _) = null ms
+
 matchGroupArity :: MatchGroup id -> Arity
 matchGroupArity (MatchGroup [] _)
-  = panic "matchGroupArity"     -- MatchGroup is never empty
+  = panic "matchGroupArity"     -- Precondition: MatchGroup is non-empty
 matchGroupArity (MatchGroup (match:matches) _)
   = ASSERT( all ((== n_pats) . length . hsLMatchPats) matches )
     -- Assertion just checks that all the matches have the same number of pats
@@ -1113,3 +1109,15 @@ matchContextErrString (StmtCtxt (MDoExpr _))     = "'mdo' expression"
 matchContextErrString (StmtCtxt ListComp)        = "list comprehension"
 matchContextErrString (StmtCtxt PArrComp)        = "array comprehension"
 \end{code}
+
+\begin{code}
+pprMatchInCtxt :: (OutputableBndr idL, OutputableBndr idR)
+              => HsMatchContext idL -> Match idR -> SDoc
+pprMatchInCtxt ctxt match  = hang (ptext (sLit "In") <+> pprMatchContext ctxt <> colon) 
+                            4 (pprMatch ctxt match)
+
+pprStmtInCtxt :: (OutputableBndr idL, OutputableBndr idR)
+              => HsStmtContext idL -> StmtLR idL idR -> SDoc
+pprStmtInCtxt ctxt stmt = hang (ptext (sLit "In a stmt of") <+> pprStmtContext ctxt <> colon)
+                         4 (ppr stmt)
+\end{code}