[commit: ghc] wip/T10180: New Lint check: no alternatives implies bottoming expression (a7d24cd)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T10180
Link       : http://ghc.haskell.org/trac/ghc/changeset/a7d24cd9c100655b487f1911cb014fea738cd36c/ghc

>---------------------------------------------------------------

commit a7d24cd9c100655b487f1911cb014fea738cd36c
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Sun Mar 22 17:32:26 2015 +0100

    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.


>---------------------------------------------------------------

a7d24cd9c100655b487f1911cb014fea738cd36c
 compiler/coreSyn/CoreLint.hs |  6 +++++-
 compiler/types/TyCon.hs      | 10 ++++++++++
 compiler/types/Type.hs       | 12 +++++++++++-
 3 files changed, 26 insertions(+), 2 deletions(-)

diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index 690836a..c615ea6 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 8e0175a..c3723c4 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 a2d3392..9cec0bd 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
+
 {-
 ************************************************************************
 *                                                                      *