Allow empty case expressions (and lambda-case) with -XEmptyCase

The main changes are:
  * Parser accepts empty case alternatives
  * Renamer checks that -XEmptyCase is on in that case
  * (Typechecker is pretty much unchanged.)
  * Desugarer desugars empty case alternatives, esp:
      - Match.matchWrapper and Match.match now accept empty eqns
      - New function matchEmpty deals with the empty case
      - See Note [Empty case alternatives] in Match

This patch contains most of the work, but it's a bit mixed up
with a refactoring of MatchGroup that I did at the same time
(next commit).

5 files changed, 48 insertions, 27 deletions

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 6e9a7acbb3..7f439eabe6 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -205,11 +205,7 @@ dsExpr (NegApp expr neg_expr)
 dsExpr (HsLam a_Match)
   = uncurry mkLams <$> matchWrapper LambdaExpr a_Match
 
-dsExpr (HsLamCase arg matches@(MatchGroup _ rhs_ty))
-  | isEmptyMatchGroup matches   -- A Core 'case' is always non-empty
-  =                             -- So desugar empty HsLamCase to error call
-    mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) (ptext (sLit "\\case"))
-  | otherwise
+dsExpr (HsLamCase arg matches)
   = do { arg_var <- newSysLocalDs arg
        ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
        ; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code }
@@ -305,12 +301,7 @@ dsExpr (HsSCC cc expr@(L loc _)) = do
 dsExpr (HsCoreAnn _ expr)
   = dsLExpr expr
 
-dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty)) 
-  | isEmptyMatchGroup matches   -- A Core 'case' is always non-empty
-  =                             -- So desugar empty HsCase to error call
-    mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) (ptext (sLit "case"))
-
-  | otherwise
+dsExpr (HsCase discrim matches)
   = do { core_discrim <- dsLExpr discrim
        ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
        ; return (bindNonRec discrim_var core_discrim matching_code) }
diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index 504a76dc86..e05a175950 100644
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -307,7 +307,7 @@ mkCoAlgCaseMatchResult dflags var ty match_alts
     match_results  = [match_result | (_,_,match_result) <- match_alts]
 
     fail_flag | exhaustive_case
-	      = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
+	      = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
 	      | otherwise
 	      = CanFail
 
diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index 75a3aa5191..2de2bb4d42 100644
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -291,9 +291,8 @@ match [] ty eqns
 		      eqn_rhs eqn
 		    | eqn <- eqns ]
 
-match vars@(v:_) ty eqns
-  = ASSERT( not (null eqns ) )
-    do	{ dflags <- getDynFlags
+match vars@(v:_) ty eqns    -- Eqns *can* be empty
+  = do	{ dflags <- getDynFlags
       	; 	-- Tidy the first pattern, generating
 		-- auxiliary bindings if necessary
           (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
@@ -304,13 +303,18 @@ match vars@(v:_) ty eqns
          -- print the view patterns that are commoned up to help debug
         ; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped)
 
-	; match_results <- mapM match_group grouped
-	; return (adjustMatchResult (foldr1 (.) aux_binds) $
+	; match_results <- match_groups grouped
+	; return (adjustMatchResult (foldr (.) id aux_binds) $
 		  foldr1 combineMatchResults match_results) }
   where
     dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo]
     dropGroup = map snd
 
+    match_groups :: [[(PatGroup,EquationInfo)]] -> DsM [MatchResult]
+    -- Result list of [MatchResult] is always non-empty
+    match_groups [] = matchEmpty v ty
+    match_groups gs = mapM match_group gs
+
     match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult
     match_group [] = panic "match_group"
     match_group eqns@((group,_) : _)
@@ -339,6 +343,14 @@ match vars@(v:_) ty eqns
           maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))
                        (filter (not . null) gs))
 
+matchEmpty :: Id -> Type -> DsM [MatchResult]
+-- See Note [Empty case expressions]
+matchEmpty var res_ty
+  = return [MatchResult CanFail mk_seq]
+  where
+    mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty 
+                                      [(DEFAULT, [], fail)]
+
 matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 -- Real true variables, just like in matchVar, SLPJ p 94
 -- No binding to do: they'll all be wildcards by now (done in tidy)
@@ -394,6 +406,24 @@ getViewPat (ViewPat _ pat _) = unLoc pat
 getViewPat _                 = panic "getBangPat"
 \end{code}
 
+Note [Empty case alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The list of EquationInfo can be empty, arising from
+    case x of {}   or    \case {}
+In that situation we desugar to
+    case x of { _ -> error "pattern match failure" }
+The *desugarer* isn't certain whether there really should be no
+alternatives, so it adds a default case, as it always does.  A later
+pass may remove it if it's inaccessible.  (See also Note [Empty case
+alternatives] in CoreSyn.)
+
+We do *not* deugar simply to
+   error "empty case" 
+or some such, because 'x' might be bound to (error "hello"), in which
+case we want to see that "hello" exception, not (error "empty case").
+See also Note [Case elimination: lifted case] in Simplify.
+
+
 %************************************************************************
 %*									*
 		Tidying patterns
@@ -693,17 +723,16 @@ one pattern, and match simply only accepts one pattern.
 JJQC 30-Nov-1997
 
 \begin{code}
-matchWrapper ctxt (MatchGroup matches match_ty)
-  = ASSERT( notNull matches )
-    do	{ eqns_info   <- mapM mk_eqn_info matches
-	; new_vars    <- selectMatchVars arg_pats
+matchWrapper ctxt (MG { mg_alts = matches
+                      , mg_arg_tys = arg_tys
+                      , mg_res_ty = rhs_ty })
+  = do	{ eqns_info   <- mapM mk_eqn_info matches
+	; new_vars    <- case matches of
+                           []    -> mapM newSysLocalDs arg_tys
+                           (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m))
 	; result_expr <- matchEquations ctxt new_vars eqns_info rhs_ty
 	; return (new_vars, result_expr) }
   where
-    arg_pats    = map unLoc (hsLMatchPats (head matches))
-    n_pats	= length arg_pats
-    (_, rhs_ty) = splitFunTysN n_pats match_ty
-
     mk_eqn_info (L _ (Match pats _ grhss))
       = do { let upats = map unLoc pats
 	   ; match_result <- dsGRHSs ctxt upats grhss rhs_ty
diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs
index 10270e50ca..5c4f4273b0 100644
--- a/compiler/deSugar/MatchCon.lhs
+++ b/compiler/deSugar/MatchCon.lhs
@@ -134,7 +134,8 @@ matchOneCon vars ty (eqn1 : eqns)	-- All eqns for a single constructor
     match_group :: [Id] -> [(ConArgPats, EquationInfo)] -> DsM MatchResult
     -- All members of the group have compatible ConArgPats
     match_group arg_vars arg_eqn_prs
-      = do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs)
+      = ASSERT( notNull arg_eqn_prs )
+        do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs)
     	   ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs
     	   ; match_result <- match (group_arg_vars ++ vars) ty eqns'
     	   ; return (adjustMatchResult (foldr1 (.) wraps) match_result) }
diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs
index 80f2124d1f..b9b6ec5a4f 100644
--- a/compiler/deSugar/MatchLit.lhs
+++ b/compiler/deSugar/MatchLit.lhs
@@ -236,7 +236,7 @@ matchLiterals :: [Id]
 	      -> DsM MatchResult
 
 matchLiterals (var:vars) ty sub_groups
-  = ASSERT( all notNull sub_groups )
+  = ASSERT( notNull sub_groups && all notNull sub_groups )
     do	{	-- Deal with each group
 	; alts <- mapM match_group sub_groups