-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
- )
+checkCaseAlts :: CoreExpr -> Type -> [CoreAlt] -> LintM ()
+-- a) Check that the alts are non-empty
+-- b) Check that the DEFAULT comes first, if it exists
+-- c) Check that there's a default for infinite types
+-- NB: Algebraic cases are not necessarily exhaustive, because
+-- the simplifer correctly eliminates case that can't
+-- possibly match.
+
+checkCaseAlts e ty []
+ = addErrL (mkNullAltsMsg e)
+
+checkCaseAlts e ty alts
+ = checkL (all non_deflt con_alts) (mkNonDefltMsg e) `seqL`
+ checkL (isJust maybe_deflt || not is_infinite_ty)
+ (nonExhaustiveAltsMsg e)