diff options
| author | simonpj@microsoft.com <unknown> | 2006-10-18 12:05:00 +0000 |
|---|---|---|
| committer | simonpj@microsoft.com <unknown> | 2006-10-18 12:05:00 +0000 |
| commit | 054b55029dbf8b7d76ac917e4e2ac937785cb90b (patch) | |
| tree | d5d5764cd18414453dc9662b73edda1650d87db2 /compiler/coreSyn | |
| parent | c128930dc98c73e2459a4610539fee73ca941247 (diff) | |
| download | haskell-054b55029dbf8b7d76ac917e4e2ac937785cb90b.tar.gz | |
Fix a bug in Lint (which wrongly complained when compiling Data.Sequence with -02)
Diffstat (limited to 'compiler/coreSyn')
| -rw-r--r-- | compiler/coreSyn/CoreLint.lhs | 18 |
1 files changed, 14 insertions, 4 deletions
diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index a33c469e53..59c52da46a 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -369,8 +369,8 @@ The basic version of these functions checks that the argument is a subtype of the required type, as one would expect. \begin{code} -lintCoreArgs :: Type -> [CoreArg] -> LintM Type -lintCoreArg :: Type -> CoreArg -> LintM Type +lintCoreArgs :: OutType -> [CoreArg] -> LintM OutType +lintCoreArg :: OutType -> CoreArg -> LintM OutType -- First argument has already had substitution applied to it \end{code} @@ -398,6 +398,7 @@ lintCoreArg fun_ty arg = \begin{code} -- Both args have had substitution applied +lintTyApp :: OutType -> OutType -> LintM OutType lintTyApp ty arg_ty = case splitForAllTy_maybe ty of Nothing -> addErrL (mkTyAppMsg ty arg_ty) @@ -488,7 +489,9 @@ lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs) = addLoc (CaseAlt alt) $ do { -- First instantiate the universally quantified -- type variables of the data constructor - con_payload_ty <- lintCoreArgs (dataConRepType con) (map Type tycon_arg_tys) + -- We've already check + checkL (tycon == dataConTyCon con) (mkBadConMsg tycon con) + ; let con_payload_ty = applyTys (dataConRepType con) tycon_arg_tys -- And now bring the new binders into scope ; lintBinders args $ \ args -> do @@ -782,7 +785,6 @@ mkScrutMsg var var_ty scrut_ty subst text "Scrutinee type:" <+> ppr scrut_ty, hsep [ptext SLIT("Current TV subst"), ppr subst]] - mkNonDefltMsg e = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e) mkNonIncreasingAltsMsg e @@ -792,6 +794,14 @@ nonExhaustiveAltsMsg :: CoreExpr -> Message nonExhaustiveAltsMsg e = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e) +mkBadConMsg :: TyCon -> DataCon -> Message +mkBadConMsg tycon datacon + = vcat [ + text "In a case alternative, data constructor isn't in scrutinee type:", + text "Scrutinee type constructor:" <+> ppr tycon, + text "Data con:" <+> ppr datacon + ] + mkBadPatMsg :: Type -> Type -> Message mkBadPatMsg con_result_ty scrut_ty = vcat [ |