summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoachim Breitner <mail@joachim-breitner.de>2015-03-22 17:32:26 +0100
committerJoachim Breitner <mail@joachim-breitner.de>2015-03-23 10:18:17 +0100
commit13384c1aeb061b555f3860b3482949a729b7cfbe (patch)
treec4e3c3302384d656e495bd7ee9693e5aa5c7873c
parentb32e0495fc144a8d76229bff6becc7f40520effd (diff)
downloadhaskell-13384c1aeb061b555f3860b3482949a729b7cfbe.tar.gz
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.
-rw-r--r--compiler/coreSyn/CoreLint.hs6
-rw-r--r--compiler/types/TyCon.hs10
-rw-r--r--compiler/types/Type.hs12
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
+
{-
************************************************************************
* *