New Lint check: no alternatives implies bottoming expression

detected either by exprIsBottom or by an empty type.

This was suggested by SPJ and fixes #10180.

2 files changed, 25 insertions, 1 deletions

diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index 690836a1aa..c615ea6b8a 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -637,8 +637,12 @@ lintCoreExpr e@(Case scrut var alt_ty alts) =
      ; alt_ty   <- lintInTy alt_ty
      ; var_ty   <- lintInTy (idType var)
 
-     ; checkL (not (null alts && exprIsHNF scrut))
+     ; when (null alts) $
+     do { checkL (not (exprIsHNF scrut))
           (ptext (sLit "No alternatives for a case scrutinee in head-normal form:") <+> ppr scrut)
+        ; checkL (exprIsBottom scrut || isEmptyTy (exprType scrut))
+          (ptext (sLit "No alternatives for a case scrutinee not known to diverge for sure:") <+> ppr scrut)
+        }
 
      ; case tyConAppTyCon_maybe (idType var) of
          Just tycon
diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs
index b3855764d8..46d4f58c5b 100644
--- a/compiler/coreSyn/CoreUtils.hs
+++ b/compiler/coreSyn/CoreUtils.hs
@@ -42,6 +42,7 @@ module CoreUtils (
         -- * Manipulating data constructors and types
         applyTypeToArgs, applyTypeToArg,
         dataConRepInstPat, dataConRepFSInstPat,
+        isEmptyTy,
 
         -- * Working with ticks
         stripTicksTop, stripTicksTopE, stripTicksTopT,
@@ -2098,3 +2099,22 @@ rhsIsStatic platform is_dynamic_name cvt_integer rhs = is_static False rhs
         = case isDataConWorkId_maybe f of
             Just dc -> n_val_args == dataConRepArity dc
             Nothing -> False
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Type utilities}
+*                                                                      *
+************************************************************************
+-}
+
+-- | True if the type has no non-bottom elements
+isEmptyTy :: Type -> Bool
+isEmptyTy ty
+    -- Data types with no constructors are empty
+    | Just (tc, inst_tys) <- splitTyConApp_maybe ty
+    , Just dcs <- tyConDataCons_maybe tc
+    , all (dataConCannotMatch inst_tys) dcs
+    = True
+    | otherwise
+    = False