Commit 27de38ef authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Mostly fix Trac #2431: make empty case acceptable to (most of) GHC

See the comments with Trac #2431.  This patch makes an empty HsCase
acceptable to the renamer onwards.  If you want to accept empty case
in Haskell source there's a little more to do: the ticket lists the 
remaining tasks.
parent 1fa3580c
......@@ -266,10 +266,15 @@ dsExpr (HsSCC cc expr) = do
dsExpr (HsCoreAnn fs expr)
= Note (CoreNote $ unpackFS fs) <$> dsLExpr expr
dsExpr (HsCase discrim matches) = do
core_discrim <- dsLExpr discrim
([discrim_var], matching_code) <- matchWrapper CaseAlt matches
return (scrungleMatch discrim_var core_discrim matching_code)
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) "case"
| otherwise
= do { core_discrim <- dsLExpr discrim
; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
; return (scrungleMatch discrim_var core_discrim matching_code) }
-- Pepe: The binds are in scope in the body but NOT in the binding group
-- This is to avoid silliness in breakpoints
......
......@@ -378,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)
......@@ -663,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
......
......@@ -787,9 +787,9 @@ lookupSigOccRn mb_names sig v
\begin{code}
rnMatchGroup :: HsMatchContext Name -> MatchGroup RdrName -> RnM (MatchGroup Name, FreeVars)
rnMatchGroup ctxt (MatchGroup ms _) = do
(new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt) ms
return (MatchGroup new_ms placeHolderType, ms_fvs)
rnMatchGroup ctxt (MatchGroup ms _)
= do { (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt) ms
; return (MatchGroup new_ms placeHolderType, ms_fvs) }
rnMatch :: HsMatchContext Name -> LMatch RdrName -> RnM (LMatch Name, FreeVars)
rnMatch ctxt = wrapLocFstM (rnMatch' ctxt)
......
......@@ -36,6 +36,8 @@ import SrcLoc
import FastString
import Control.Monad
#include "HsVersions.h"
\end{code}
%************************************************************************
......@@ -92,6 +94,13 @@ tcMatchesCase :: TcMatchCtxt -- Case context
-> TcM (MatchGroup TcId) -- Translated alternatives
tcMatchesCase ctxt scrut_ty matches res_ty
| isEmptyMatchGroup matches
= -- Allow empty case expressions
do { -- Make sure we follow the invariant that res_ty is filled in
res_ty' <- refineBoxToTau res_ty
; return (MatchGroup [] (mkFunTys [scrut_ty] res_ty')) }
| otherwise
= tcMatches ctxt [scrut_ty] res_ty matches
tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (HsWrapper, MatchGroup TcId)
......@@ -141,7 +150,8 @@ data TcMatchCtxt -- c.f. TcStmtCtxt, also in this module
-> TcM (LHsExpr TcId) }
tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
= do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
= ASSERT( not (null matches) ) -- Ensure that rhs_ty is filled in
do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
; return (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) }
-------------
......
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