Allow empty case expressions (and lambda-case) with -XEmptyCase
authorSimon Peyton Jones <simonpj@microsoft.com>
Fri, 4 Jan 2013 10:27:38 +0000 (10:27 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Fri, 4 Jan 2013 10:27:38 +0000 (10:27 +0000)
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).

compiler/deSugar/DsExpr.lhs
compiler/deSugar/DsUtils.lhs
compiler/deSugar/Match.lhs
compiler/deSugar/MatchCon.lhs
compiler/deSugar/MatchLit.lhs
compiler/main/DynFlags.hs
compiler/parser/Parser.y.pp
compiler/rename/RnBinds.lhs
docs/users_guide/glasgow_exts.xml

index 6e9a7ac..7f439ea 100644 (file)
@@ -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) }
index 504a76d..e05a175 100644 (file)
@@ -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
 
index 75a3aa5..2de2bb4 100644 (file)
@@ -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
index 10270e5..5c4f427 100644 (file)
@@ -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) }
index 80f2124..b9b6ec5 100644 (file)
@@ -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
 
index 749651f..096fc23 100644 (file)
@@ -529,6 +529,7 @@ data ExtensionFlag
    | Opt_LambdaCase
    | Opt_MultiWayIf
    | Opt_TypeHoles
+   | Opt_EmptyCase
    deriving (Eq, Enum, Show)
 
 -- | Contains not only a collection of 'GeneralFlag's but also a plethora of
@@ -2608,7 +2609,8 @@ xFlags = [
   ( "UndecidableInstances",             Opt_UndecidableInstances, nop ),
   ( "IncoherentInstances",              Opt_IncoherentInstances, nop ),
   ( "PackageImports",                   Opt_PackageImports, nop ),
-  ( "TypeHoles",                        Opt_TypeHoles, nop )
+  ( "TypeHoles",                        Opt_TypeHoles, nop ),
+  ( "EmptyCase",                        Opt_EmptyCase, nop )
   ]
 
 defaultFlags :: Settings -> [GeneralFlag]
index e3f4994..b613962 100644 (file)
@@ -1712,6 +1712,8 @@ guardquals1 :: { Located [LStmt RdrName (LHsExpr RdrName)] }
 altslist :: { Located [LMatch RdrName (LHsExpr RdrName)] }
         : '{'            alts '}'       { LL (reverse (unLoc $2)) }
         |     vocurly    alts  close    { L (getLoc $2) (reverse (unLoc $2)) }
+        | '{'                 '}'       { noLoc [] }
+        |     vocurly          close    { noLoc [] }
 
 alts    :: { Located [LMatch RdrName (LHsExpr RdrName)] }
         : alts1                         { L1 (unLoc $1) }
index 717b885..bed2261 100644 (file)
@@ -781,9 +781,11 @@ rnMatchGroup :: Outputable (body RdrName) => HsMatchContext Name
              -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
              -> MatchGroup RdrName (Located (body RdrName))
              -> RnM (MatchGroup Name (Located (body Name)), FreeVars)
-rnMatchGroup ctxt rnBody (MatchGroup ms _) 
-  = do { (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms
-       ; return (MatchGroup new_ms placeHolderType, ms_fvs) }
+rnMatchGroup ctxt rnBody (MG { mg_alts = ms }) 
+  = do { empty_case_ok <- xoptM Opt_EmptyCase
+       ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt))
+       ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms
+       ; return (mkMatchGroup new_ms, ms_fvs) }
 
 rnMatch :: Outputable (body RdrName) => HsMatchContext Name
         -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
@@ -808,6 +810,16 @@ rnMatch' ctxt rnBody match@(Match pats maybe_rhs_sig grhss)
 
        ; return (Match pats' Nothing grhss', grhss_fvs) }}
 
+emptyCaseErr :: HsMatchContext Name -> SDoc
+emptyCaseErr ctxt = hang (ptext (sLit "Empty list of alterantives in") <+> pp_ctxt)
+                       2 (ptext (sLit "Use -XEmptyCase to allow this"))
+  where
+    pp_ctxt = case ctxt of
+                CaseAlt    -> ptext (sLit "case expression")
+                LambdaExpr -> ptext (sLit "\\case expression")
+                _ -> ptext (sLit "(unexpected)") <+> pprMatchContextNoun ctxt
+
 resSigErr :: Outputable body => HsMatchContext Name -> Match RdrName body -> HsType RdrName -> SDoc 
 resSigErr ctxt match ty
    = vcat [ ptext (sLit "Illegal result type signature") <+> quotes (ppr ty)
index 93279aa..98c43c2 100644 (file)
@@ -1666,6 +1666,44 @@ Note that <literal>\case</literal> starts a layout, so you can write
 </para>
 </sect2>
 
+<sect2 id="empty-case">
+<title>Empty case alternatives</title>
+<para>
+The <option>-XEmptyCase</option> flag enables 
+case expressions, or lambda-case expressions, that have no alternatives, 
+thus:
+<programlisting>
+    case e of { }   -- No alternatives
+or
+    \case { }       -- -XLambdaCase is also required
+</programlisting>
+This can be useful when you know that the expression being scrutinised
+has no non-bottom values.  For example:
+<programlisting>
+  data Void
+  f :: Void -> Int
+  f x = case x of { }
+</programlisting>
+With dependently-typed features it is more useful 
+(see <ulink url="http://hackage.haskell.org/trac/ghc/ticket/2431">Trac</ulink>).
+For example, consider these two candidate definitions of <literal>absurd</literal>:
+<programlisting>
+data a :==: b where
+  Refl :: a :==: a
+
+absurd :: True :~: False -> a
+absurd x = error "absurd"    -- (A)
+absurd x = case x of {}      -- (B)
+</programlisting>
+We much prefer (B). Why? Because GHC can figure out that <literal>(True :~: False)</literal>
+is an empty type. So (B) has no partiality and GHC should be able to compile with 
+<option>-fwarn-incomplete-patterns</option>.  (Though the pattern match checking is not
+yet clever enough to do that.
+On the other hand (A) looks dangerous, and GHC doesn't check to make
+sure that, in fact, the function can never get called.
+</para>
+</sect2>
+
 <sect2 id="multi-way-if">
 <title>Multi-way if-expressions</title>
 <para>