summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/deSugar/DsExpr.lhs13
-rw-r--r--compiler/deSugar/DsUtils.lhs2
-rw-r--r--compiler/deSugar/Match.lhs55
-rw-r--r--compiler/deSugar/MatchCon.lhs3
-rw-r--r--compiler/deSugar/MatchLit.lhs2
-rw-r--r--compiler/main/DynFlags.hs4
-rw-r--r--compiler/parser/Parser.y.pp2
-rw-r--r--compiler/rename/RnBinds.lhs18
8 files changed, 68 insertions, 31 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
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 749651fab4..096fc23f21 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -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]
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index e3f4994166..b6139621d1 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -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) }
diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index 717b885e63..bed22613af 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -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)
View Lorry Controller Status