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

[git at git.haskell.org]

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

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

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

commit 69ec2ad157794621a1161862f9954d670fe58646
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.


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

69ec2ad157794621a1161862f9954d670fe58646
 compiler/coreSyn/CoreLint.hs  |  6 +++++-
 compiler/coreSyn/CoreUtils.hs | 20 ++++++++++++++++++++
 2 files changed, 25 insertions(+), 1 deletion(-)

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/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs
index b385576..46d4f58 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