Commit 3671e674 authored by Simon Peyton Jones's avatar Simon Peyton Jones

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).
parent 28d9a032
......@@ -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) }
......
......@@ -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
......
......@@ -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
......
......@@ -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) }
......
......@@ -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
......
......@@ -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]
......
......@@ -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) }
......
......@@ -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)
......
......@@ -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>
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment