New Lint check: no alternatives implies bottoming expressionwip/T10180

detected either by exprIsBottom or by an empty type.

This was suggested by SPJ and fixes #10180.

3 files changed, 26 insertions, 2 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/types/TyCon.hs b/compiler/types/TyCon.hs
index 8e0175a6cf..c3723c4661 100644
--- a/compiler/types/TyCon.hs
+++ b/compiler/types/TyCon.hs
@@ -42,6 +42,7 @@ module TyCon(
         promotableTyCon_maybe, promoteTyCon,
 
         isDataTyCon, isProductTyCon, isDataProductTyCon_maybe,
+        isEmptyDataTyCon,
         isEnumerationTyCon,
         isNewTyCon, isAbstractTyCon,
         isFamilyTyCon, isOpenFamilyTyCon,
@@ -1286,6 +1287,15 @@ isDataProductTyCon_maybe (TupleTyCon { dataCon = con })
   = Just con
 isDataProductTyCon_maybe _ = Nothing
 
+-- | True of datatypes with no constructors
+isEmptyDataTyCon :: TyCon -> Bool
+isEmptyDataTyCon tc
+  | AlgTyCon {algTcRhs = rhs} <- tc
+  , [] <- data_cons rhs
+  = True
+  | otherwise
+  = False
+
 -- | Is this a 'TyCon' representing a regular H98 type synonym (@type@)?
 isTypeSynonymTyCon :: TyCon -> Bool
 isTypeSynonymTyCon (SynonymTyCon {}) = True
diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index a2d339210c..9cec0bd338 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -66,7 +66,7 @@ module Type (
 
         -- (Lifting and boxity)
         isUnLiftedType, isUnboxedTupleType, isAlgType, isClosedAlgType,
-        isPrimitiveType, isStrictType,
+        isPrimitiveType, isStrictType, isEmptyTy,
 
         -- * Main data types representing Kinds
         -- $kind_subtyping
@@ -1184,6 +1184,16 @@ isPrimitiveType ty = case splitTyConApp_maybe ty of
                                               isPrimTyCon tc
                         _                  -> False
 
+-- | True if the type has no non-bottom elements
+isEmptyTy :: Type -> Bool
+isEmptyTy ty
+    -- Data types with no constructors are empty
+    | Just (tc, _) <- splitTyConApp_maybe ty
+    , isEmptyDataTyCon tc
+    = True
+    | otherwise
+    = False
+
 {-
 ************************************************************************
 *                                                                      *