-lintCoreAlts :: CoreCaseAlts
- -> Type -- Type of scrutinee
--- -> TyCon -- TyCon pinned on the case
- -> LintM (Maybe Type) -- Type of alternatives
-
-lintCoreAlts whole_alts@(AlgAlts alts deflt) ty --tycon
- = -- Check tycon is not a primitive tycon
--- addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon)
--- `seqL`
- -- Check we are scrutinising a proper datatype
- -- (ToDo: robustify)
--- addErrIfL (not (tyConFamilySize tycon >= 1)) (mkCaseAbstractMsg tycon)
--- `seqL`
- lintDeflt deflt ty
- `thenL` \maybe_deflt_ty ->
- mapL (lintAlgAlt ty {-tycon-}) alts
- `thenL` \maybe_alt_tys ->
- -- Check the result types
- case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
- [] -> returnL Nothing
-
- (first_ty:tys) -> mapL check tys `seqL`
- returnL (Just first_ty)
- where
- check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
-
-lintCoreAlts whole_alts@(PrimAlts alts deflt) ty --tycon
- = -- Check tycon is a primitive tycon
--- addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon)
--- `seqL`
- mapL (lintPrimAlt ty) alts
- `thenL` \maybe_alt_tys ->
- lintDeflt deflt ty
- `thenL` \maybe_deflt_ty ->
- -- Check the result types
- case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
- [] -> returnL Nothing
-
- (first_ty:tys) -> mapL check tys `seqL`
- returnL (Just first_ty)
- where
- check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
-
-lintAlgAlt scrut_ty (con,args,rhs)
- = (case splitAlgTyConApp_maybe scrut_ty of
- Just (tycon, tys_applied, cons) | isDataTyCon tycon ->
- let
- arg_tys = dataConArgTys con tys_applied
- in
- checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `seqL`
- checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
- `seqL`
- mapL check (zipEqual "lintAlgAlt" arg_tys args) `seqL`
- returnL ()
-
- other -> addErrL (mkAlgAltMsg1 scrut_ty)
- ) `seqL`
- addInScopeVars args (
- lintCoreExpr rhs
- )
+checkAllCasesCovered :: CoreExpr -> Type -> [CoreAlt] -> LintM ()
+
+checkAllCasesCovered e ty [] = addErrL (mkNullAltsMsg e)
+
+checkAllCasesCovered e ty [(DEFAULT,_,_)] = nopL
+
+checkAllCasesCovered e scrut_ty alts
+ = case splitTyConApp_maybe scrut_ty of {
+ Nothing -> addErrL (badAltsMsg e);
+ Just (tycon, tycon_arg_tys) ->
+
+ if isPrimTyCon tycon then
+ checkL (hasDefault alts) (nonExhaustiveAltsMsg e)
+ else
+{- No longer needed
+#ifdef DEBUG
+ -- Algebraic cases are not necessarily exhaustive, because
+ -- the simplifer correctly eliminates case that can't
+ -- possibly match.
+ -- This code just emits a message to say so
+ let
+ missing_cons = filter not_in_alts (tyConDataCons tycon)
+ not_in_alts con = all (not_in_alt con) alts
+ not_in_alt con (DataCon con', _, _) = con /= con'
+ not_in_alt con other = True
+
+ case_bndr = case e of { Case _ bndr alts -> bndr }
+ in
+ if not (hasDefault alts || null missing_cons) then
+ pprTrace "Exciting (but not a problem)! Non-exhaustive case:"
+ (ppr case_bndr <+> ppr missing_cons)
+ nopL
+ else
+#endif
+-}
+ nopL }
+
+hasDefault [] = False
+hasDefault ((DEFAULT,_,_) : alts) = True
+hasDefault (alt : alts) = hasDefault alts
+\end{code}
+
+\begin{code}
+lintCoreAlt :: Type -- Type of scrutinee
+ -> CoreAlt
+ -> LintM Type -- Type of alternatives
+
+lintCoreAlt scrut_ty alt@(DEFAULT, args, rhs)
+ = checkL (null args) (mkDefaultArgsMsg args) `seqL`
+ lintCoreExpr rhs
+
+lintCoreAlt scrut_ty alt@(LitAlt lit, args, rhs)
+ = checkL (null args) (mkDefaultArgsMsg args) `seqL`
+ checkTys lit_ty scrut_ty
+ (mkBadPatMsg lit_ty scrut_ty) `seqL`
+ lintCoreExpr rhs
+ where
+ lit_ty = literalType lit
+
+lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs)
+ = addLoc (CaseAlt alt) (
+
+ mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg)))
+ (mkUnboxedTupleMsg arg)) args `seqL`
+
+ addInScopeVars args (
+
+ -- Check the pattern
+ -- Scrutinee type must be a tycon applicn; checked by caller
+ -- This code is remarkably compact considering what it does!
+ -- NB: args must be in scope here so that the lintCoreArgs line works.
+ case splitTyConApp_maybe scrut_ty of { Just (tycon, tycon_arg_tys) ->
+ lintTyApps (dataConRepType con) tycon_arg_tys `thenL` \ con_type ->
+ lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty ->
+ checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
+ } `seqL`
+
+ -- Check the RHS
+ lintCoreExpr rhs
+ ))