-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)
+ where
+ (con_alts, maybe_deflt) = findDefault alts
+
+ non_deflt (DEFAULT, _, _) = False
+ non_deflt alt = True
+
+ is_infinite_ty = case splitTyConApp_maybe ty of
+ Nothing -> False
+ Just (tycon, tycon_arg_tys) -> isPrimTyCon tycon
+\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.
+ -- NB: relies on existential type args coming *after* ordinary type args
+ case splitTyConApp scrut_ty of { (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
+ ))