3 % (c) The University of Glasgow 2006
4 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
7 A ``lint'' pass to check for Core correctness
11 -- The above warning supression flag is a temporary kludge.
12 -- While working on this module you are encouraged to remove it and fix
13 -- any warnings in the module. See
14 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
20 showPass, endPass, endIteration
23 #include "HsVersions.h"
53 %************************************************************************
57 %************************************************************************
59 @showPass@ and @endPass@ don't really belong here, but it makes a convenient
60 place for them. They print out stuff before and after core passes,
61 and do Core Lint when necessary.
64 endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
65 endPass = dumpAndLint dumpIfSet_core
67 endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
68 endIteration = dumpAndLint dumpIfSet_dyn
70 dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ())
71 -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
72 dumpAndLint dump dflags pass_name dump_flag binds
74 -- Report result size if required
75 -- This has the side effect of forcing the intermediate to be evaluated
76 debugTraceMsg dflags 2 $
77 (text " Result size =" <+> int (coreBindsSize binds))
79 -- Report verbosely, if required
80 dump dflags dump_flag pass_name (pprCoreBindings binds)
83 lintCoreBindings dflags pass_name binds
89 %************************************************************************
91 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
93 %************************************************************************
95 Checks that a set of core bindings is well-formed. The PprStyle and String
96 just control what we print in the event of an error. The Bool value
97 indicates whether we have done any specialisation yet (in which case we do
102 (b) Out-of-scope type variables
103 (c) Out-of-scope local variables
106 If we have done specialisation the we check that there are
107 (a) No top-level bindings of primitive (unboxed type)
112 -- Things are *not* OK if:
114 -- * Unsaturated type app before specialisation has been done;
116 -- * Oversaturated type app after specialisation (eta reduction
117 -- may well be happening...);
122 In the desugarer, it's very very convenient to be able to say (in effect)
123 let a = Int in <body>
124 That is, use a type let. (See notes just below for why we want this.)
126 We don't have type lets in Core, so the desugarer uses type lambda
128 However, in the lambda form, we'd get lint errors from:
129 (/\a. let x::a = 4 in <body>) Int
130 because (x::a) doesn't look compatible with (4::Int).
132 So (HACK ALERT) the Lint phase does type-beta reduction "on the fly",
133 as it were. It carries a type substitution (in this example [a -> Int])
134 and applies this substitution before comparing types. The functin
135 lintTy :: Type -> LintM Type
136 returns a substituted type; that's the only reason it returns anything.
138 When we encounter a binder (like x::a) we must apply the substitution
139 to the type of the binding variable. lintBinders does this.
141 For Ids, the type-substituted Id is added to the in_scope set (which
142 itself is part of the TvSubst we are carrying down), and when we
143 find an occurence of an Id, we fetch it from the in-scope set.
148 It's needed when dealing with desugarer output for GADTs. Consider
149 data T = forall a. T a (a->Int) Bool
151 f (T x f True) = <e1>
152 f (T y g False) = <e2>
153 After desugaring we get
155 T a (x::a) (f::a->Int) (b:Bool) ->
158 False -> (/\b. let y=x; g=f in <e2>) a
159 And for a reason I now forget, the ...<e2>... can mention a; so
160 we want Lint to know that b=a. Ugh.
162 I tried quite hard to make the necessity for this go away, by changing the
163 desugarer, but the fundamental problem is this:
165 T a (x::a) (y::Int) -> let fail::a = ...
166 in (/\b. ...(case ... of
170 Now the inner case look as though it has incompatible branches.
174 lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
176 lintCoreBindings dflags whoDunnit binds
177 | not (dopt Opt_DoCoreLinting dflags)
180 lintCoreBindings dflags whoDunnit binds
181 = case (initL (lint_binds binds)) of
182 Nothing -> showPass dflags ("Core Linted result of " ++ whoDunnit)
183 Just bad_news -> printDump (display bad_news) >>
186 -- Put all the top-level binders in scope at the start
187 -- This is because transformation rules can bring something
188 -- into use 'unexpectedly'
189 lint_binds binds = addLoc TopLevelBindings $
190 addInScopeVars (bindersOfBinds binds) $
193 lint_bind (Rec prs) = mapM_ (lintSingleBinding TopLevel Recursive) prs
194 lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)
197 = vcat [ text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
199 ptext SLIT("*** Offending Program ***"),
200 pprCoreBindings binds,
201 ptext SLIT("*** End of Offense ***")
205 %************************************************************************
207 \subsection[lintUnfolding]{lintUnfolding}
209 %************************************************************************
211 We use this to check all unfoldings that come in from interfaces
212 (it is very painful to catch errors otherwise):
215 lintUnfolding :: SrcLoc
216 -> [Var] -- Treat these as in scope
218 -> Maybe Message -- Nothing => OK
220 lintUnfolding locn vars expr
221 = initL (addLoc (ImportedUnfolding locn) $
222 addInScopeVars vars $
226 %************************************************************************
228 \subsection[lintCoreBinding]{lintCoreBinding}
230 %************************************************************************
232 Check a core binding, returning the list of variables bound.
235 lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
236 = addLoc (RhsOf binder) $
238 do { ty <- lintCoreExpr rhs
239 ; lintBinder binder -- Check match to RHS type
240 ; binder_ty <- applySubst binder_ty
241 ; checkTys binder_ty ty (mkRhsMsg binder ty)
242 -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
243 ; checkL (not (isUnLiftedType binder_ty)
244 || (isNonRec rec_flag && exprOkForSpeculation rhs))
245 (mkRhsPrimMsg binder rhs)
246 -- Check that if the binder is top-level or recursive, it's not demanded
247 ; checkL (not (isStrictId binder)
248 || (isNonRec rec_flag && not (isTopLevel top_lvl_flag)))
250 -- Check whether binder's specialisations contain any out-of-scope variables
251 ; mapM_ (checkBndrIdInScope binder) bndr_vars
253 -- Check whether arity and demand type are consistent (only if demand analysis
255 ; checkL (case maybeDmdTy of
256 Just (StrictSig dmd_ty) -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs
258 (mkArityMsg binder) }
260 -- We should check the unfolding, if any, but this is tricky because
261 -- the unfolding is a SimplifiableCoreExpr. Give up for now.
263 binder_ty = idType binder
264 maybeDmdTy = idNewStrictness_maybe binder
265 bndr_vars = varSetElems (idFreeVars binder)
266 lintBinder var | isId var = lintIdBndr var $ \_ -> (return ())
267 | otherwise = return ()
270 %************************************************************************
272 \subsection[lintCoreExpr]{lintCoreExpr}
274 %************************************************************************
277 type InType = Type -- Substitution not yet applied
278 type OutType = Type -- Substitution has been applied to this
280 lintCoreExpr :: CoreExpr -> LintM OutType
281 -- The returned type has the substitution from the monad
282 -- already applied to it:
283 -- lintCoreExpr e subst = exprType (subst e)
285 lintCoreExpr (Var var)
286 = do { checkL (not (var == oneTupleDataConId))
287 (ptext SLIT("Illegal one-tuple"))
288 ; var' <- lookupIdInScope var
289 ; return (idType var')
292 lintCoreExpr (Lit lit)
293 = return (literalType lit)
295 --lintCoreExpr (Note (Coerce to_ty from_ty) expr)
296 -- = do { expr_ty <- lintCoreExpr expr
297 -- ; to_ty <- lintTy to_ty
298 -- ; from_ty <- lintTy from_ty
299 -- ; checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty)
302 lintCoreExpr (Cast expr co)
303 = do { expr_ty <- lintCoreExpr expr
305 ; let (from_ty, to_ty) = coercionKind co'
306 ; checkTys from_ty expr_ty (mkCastErr from_ty expr_ty)
309 lintCoreExpr (Note other_note expr)
312 lintCoreExpr (Let (NonRec bndr rhs) body)
313 = do { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs)
314 ; addLoc (BodyOfLetRec [bndr])
315 (lintAndScopeId bndr $ \_ -> (lintCoreExpr body)) }
317 lintCoreExpr (Let (Rec pairs) body)
318 = lintAndScopeIds bndrs $ \_ ->
319 do { mapM (lintSingleBinding NotTopLevel Recursive) pairs
320 ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
322 bndrs = map fst pairs
324 lintCoreExpr e@(App fun (Type ty))
325 -- See Note [Type let] above
326 = addLoc (AnExpr e) $
329 go (App fun (Type ty)) tys
330 = do { go fun (ty:tys) }
331 go (Lam tv body) (ty:tys)
332 = do { checkL (isTyVar tv) (mkKindErrMsg tv ty) -- Not quite accurate
334 ; let kind = tyVarKind tv
335 ; kind' <- lintTy kind
336 ; let tv' = setTyVarKind tv kind'
338 -- Now extend the substitution so we
339 -- take advantage of it in the body
340 ; addInScopeVars [tv'] $
341 extendSubstL tv' ty' $
344 = do { fun_ty <- lintCoreExpr fun
345 ; lintCoreArgs fun_ty (map Type tys) }
347 lintCoreExpr e@(App fun arg)
348 = do { fun_ty <- lintCoreExpr fun
349 ; addLoc (AnExpr e) $
350 lintCoreArg fun_ty arg }
352 lintCoreExpr (Lam var expr)
353 = addLoc (LambdaBodyOf var) $
354 lintBinders [var] $ \[var'] ->
355 do { body_ty <- lintCoreExpr expr
357 return (mkFunTy (idType var') body_ty)
359 return (mkForAllTy var' body_ty)
361 -- The applySubst is needed to apply the subst to var
363 lintCoreExpr e@(Case scrut var alt_ty alts) =
364 -- Check the scrutinee
365 do { scrut_ty <- lintCoreExpr scrut
366 ; alt_ty <- lintTy alt_ty
367 ; var_ty <- lintTy (idType var)
368 -- Don't use lintIdBndr on var, because unboxed tuple is legitimate
370 ; subst <- getTvSubst
371 ; checkTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst)
373 -- If the binder is an unboxed tuple type, don't put it in scope
374 ; let scope = if (isUnboxedTupleType (idType var)) then
376 else lintAndScopeId var
378 do { -- Check the alternatives
379 mapM (lintCoreAlt scrut_ty alt_ty) alts
380 ; checkCaseAlts e scrut_ty alts
385 lintCoreExpr e@(Type ty)
386 = addErrL (mkStrangeTyMsg e)
389 %************************************************************************
391 \subsection[lintCoreArgs]{lintCoreArgs}
393 %************************************************************************
395 The basic version of these functions checks that the argument is a
396 subtype of the required type, as one would expect.
399 lintCoreArgs :: OutType -> [CoreArg] -> LintM OutType
400 lintCoreArg :: OutType -> CoreArg -> LintM OutType
401 -- First argument has already had substitution applied to it
405 lintCoreArgs ty [] = return ty
406 lintCoreArgs ty (a : args) =
407 do { res <- lintCoreArg ty a
408 ; lintCoreArgs res args }
410 lintCoreArg fun_ty a@(Type arg_ty) =
411 do { arg_ty <- lintTy arg_ty
412 ; lintTyApp fun_ty arg_ty }
414 lintCoreArg fun_ty arg =
415 -- Make sure function type matches argument
416 do { arg_ty <- lintCoreExpr arg
417 ; let err1 = mkAppMsg fun_ty arg_ty arg
418 err2 = mkNonFunAppMsg fun_ty arg_ty arg
419 ; case splitFunTy_maybe fun_ty of
421 do { checkTys arg arg_ty err1
427 -- Both args have had substitution applied
428 lintTyApp :: OutType -> OutType -> LintM OutType
430 = case splitForAllTy_maybe ty of
431 Nothing -> addErrL (mkTyAppMsg ty arg_ty)
434 -> do { checkL (isTyVar tyvar) (mkTyAppMsg ty arg_ty)
435 ; checkKinds tyvar arg_ty
436 ; return (substTyWith [tyvar] [arg_ty] body) }
438 checkKinds tyvar arg_ty
439 -- Arg type might be boxed for a function with an uncommitted
440 -- tyvar; notably this is used so that we can give
441 -- error :: forall a:*. String -> a
442 -- and then apply it to both boxed and unboxed types.
443 = checkL (arg_kind `isSubKind` tyvar_kind)
444 (mkKindErrMsg tyvar arg_ty)
446 tyvar_kind = tyVarKind tyvar
447 arg_kind | isCoVar tyvar = coercionKindPredTy arg_ty
448 | otherwise = typeKind arg_ty
452 %************************************************************************
454 \subsection[lintCoreAlts]{lintCoreAlts}
456 %************************************************************************
459 checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
460 -- a) Check that the alts are non-empty
461 -- b1) Check that the DEFAULT comes first, if it exists
462 -- b2) Check that the others are in increasing order
463 -- c) Check that there's a default for infinite types
464 -- NB: Algebraic cases are not necessarily exhaustive, because
465 -- the simplifer correctly eliminates case that can't
468 checkCaseAlts e ty []
469 = addErrL (mkNullAltsMsg e)
471 checkCaseAlts e ty alts =
472 do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
473 ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
474 ; checkL (isJust maybe_deflt || not is_infinite_ty)
475 (nonExhaustiveAltsMsg e) }
477 (con_alts, maybe_deflt) = findDefault alts
479 -- Check that successive alternatives have increasing tags
480 increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest
481 increasing_tag other = True
483 non_deflt (DEFAULT, _, _) = False
486 is_infinite_ty = case splitTyConApp_maybe ty of
488 Just (tycon, tycon_arg_tys) -> isPrimTyCon tycon
492 checkAltExpr :: CoreExpr -> OutType -> LintM ()
493 checkAltExpr expr ann_ty
494 = do { actual_ty <- lintCoreExpr expr
495 ; checkTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) }
497 lintCoreAlt :: OutType -- Type of scrutinee
498 -> OutType -- Type of the alternative
502 lintCoreAlt scrut_ty alt_ty alt@(DEFAULT, args, rhs) =
503 do { checkL (null args) (mkDefaultArgsMsg args)
504 ; checkAltExpr rhs alt_ty }
506 lintCoreAlt scrut_ty alt_ty alt@(LitAlt lit, args, rhs) =
507 do { checkL (null args) (mkDefaultArgsMsg args)
508 ; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty)
509 ; checkAltExpr rhs alt_ty }
511 lit_ty = literalType lit
513 lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
514 | isNewTyCon (dataConTyCon con) = addErrL (mkNewTyDataConAltMsg scrut_ty alt)
515 | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty
516 = addLoc (CaseAlt alt) $ do
517 { -- First instantiate the universally quantified
518 -- type variables of the data constructor
519 -- We've already check
520 checkL (tycon == dataConTyCon con) (mkBadConMsg tycon con)
521 ; let con_payload_ty = applyTys (dataConRepType con) tycon_arg_tys
523 -- And now bring the new binders into scope
524 ; lintBinders args $ \ args -> do
525 { addLoc (CasePat alt) $ do
526 { -- Check the pattern
527 -- Scrutinee type must be a tycon applicn; checked by caller
528 -- This code is remarkably compact considering what it does!
529 -- NB: args must be in scope here so that the lintCoreArgs
531 -- NB: relies on existential type args coming *after*
532 -- ordinary type args
533 ; con_result_ty <- lintCoreArgs con_payload_ty (varsToCoreExprs args)
534 ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
537 ; checkAltExpr rhs alt_ty } }
539 | otherwise -- Scrut-ty is wrong shape
540 = addErrL (mkBadAltMsg scrut_ty alt)
543 %************************************************************************
545 \subsection[lint-types]{Types}
547 %************************************************************************
550 -- When we lint binders, we (one at a time and in order):
551 -- 1. Lint var types or kinds (possibly substituting)
552 -- 2. Add the binder to the in scope set, and if its a coercion var,
553 -- we may extend the substitution to reflect its (possibly) new kind
554 lintBinders :: [Var] -> ([Var] -> LintM a) -> LintM a
555 lintBinders [] linterF = linterF []
556 lintBinders (var:vars) linterF = lintBinder var $ \var' ->
557 lintBinders vars $ \ vars' ->
560 lintBinder :: Var -> (Var -> LintM a) -> LintM a
561 lintBinder var linterF
562 | isTyVar var = lint_ty_bndr
563 | otherwise = lintIdBndr var linterF
565 lint_ty_bndr = do { lintTy (tyVarKind var)
566 ; subst <- getTvSubst
567 ; let (subst', tv') = substTyVarBndr subst var
568 ; updateTvSubst subst' (linterF tv') }
570 lintIdBndr :: Var -> (Var -> LintM a) -> LintM a
571 -- Do substitution on the type of a binder and add the var with this
572 -- new type to the in-scope set of the second argument
573 -- ToDo: lint its rules
574 lintIdBndr id linterF
575 = do { checkL (not (isUnboxedTupleType (idType id)))
576 (mkUnboxedTupleMsg id)
577 -- No variable can be bound to an unboxed tuple.
578 ; lintAndScopeId id $ \id' -> linterF id'
581 lintAndScopeIds :: [Var] -> ([Var] -> LintM a) -> LintM a
582 lintAndScopeIds ids linterF
586 go (id:ids) = do { lintAndScopeId id $ \id ->
587 lintAndScopeIds ids $ \ids ->
590 lintAndScopeId :: Var -> (Var -> LintM a) -> LintM a
591 lintAndScopeId id linterF
592 = do { ty <- lintTy (idType id)
593 ; let id' = Var.setIdType id ty
594 ; addInScopeVars [id'] $ (linterF id')
597 lintTy :: InType -> LintM OutType
598 -- Check the type, and apply the substitution to it
599 -- ToDo: check the kind structure of the type
601 = do { ty' <- applySubst ty
602 ; mapM_ checkTyVarInScope (varSetElems (tyVarsOfType ty'))
607 %************************************************************************
609 \subsection[lint-monad]{The Lint monad}
611 %************************************************************************
616 [LintLocInfo] -> -- Locations
617 TvSubst -> -- Current type substitution; we also use this
618 -- to keep track of all the variables in scope,
619 -- both Ids and TyVars
620 Bag Message -> -- Error messages so far
621 (Maybe a, Bag Message) } -- Result and error messages (if any)
623 {- Note [Type substitution]
624 ~~~~~~~~~~~~~~~~~~~~~~~~
625 Why do we need a type substitution? Consider
626 /\(a:*). \(x:a). /\(a:*). id a x
627 This is ill typed, because (renaming variables) it is really
628 /\(a:*). \(x:a). /\(b:*). id b x
629 Hence, when checking an application, we can't naively compare x's type
630 (at its binding site) with its expected type (at a use site). So we
631 rename type binders as we go, maintaining a substitution.
633 The same substitution also supports let-type, current expressed as
635 Here we substitute 'ty' for 'a' in 'body', on the fly.
638 instance Monad LintM where
639 return x = LintM (\ loc subst errs -> (Just x, errs))
640 fail err = LintM (\ loc subst errs -> (Nothing, addErr subst errs (text err) loc))
641 m >>= k = LintM (\ loc subst errs ->
642 let (res, errs') = unLintM m loc subst errs in
644 Just r -> unLintM (k r) loc subst errs'
645 Nothing -> (Nothing, errs'))
648 = RhsOf Id -- The variable bound
649 | LambdaBodyOf Id -- The lambda-binder
650 | BodyOfLetRec [Id] -- One of the binders
651 | CaseAlt CoreAlt -- Case alternative
652 | CasePat CoreAlt -- *Pattern* of the case alternative
653 | AnExpr CoreExpr -- Some expression
654 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
660 initL :: LintM a -> Maybe Message {- errors -}
662 = case unLintM m [] emptyTvSubst emptyBag of
663 (_, errs) | isEmptyBag errs -> Nothing
664 | otherwise -> Just (vcat (punctuate (text "") (bagToList errs)))
668 checkL :: Bool -> Message -> LintM ()
669 checkL True msg = return ()
670 checkL False msg = addErrL msg
672 addErrL :: Message -> LintM a
673 addErrL msg = LintM (\ loc subst errs -> (Nothing, addErr subst errs msg loc))
675 addErr :: TvSubst -> Bag Message -> Message -> [LintLocInfo] -> Bag Message
676 addErr subst errs_so_far msg locs
677 = ASSERT( notNull locs )
678 errs_so_far `snocBag` mk_msg msg
680 (loc, cxt1) = dumpLoc (head locs)
681 cxts = [snd (dumpLoc loc) | loc <- locs]
682 context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$
683 ptext SLIT("Substitution:") <+> ppr subst
686 mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg)
688 addLoc :: LintLocInfo -> LintM a -> LintM a
690 LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs)
692 addInScopeVars :: [Var] -> LintM a -> LintM a
693 addInScopeVars vars m
695 = LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs)
697 = addErrL (dupVars dups)
699 (_, dups) = removeDups compare vars
701 updateTvSubst :: TvSubst -> LintM a -> LintM a
702 updateTvSubst subst' m =
703 LintM (\ loc subst errs -> unLintM m loc subst' errs)
705 getTvSubst :: LintM TvSubst
706 getTvSubst = LintM (\ loc subst errs -> (Just subst, errs))
708 applySubst :: Type -> LintM Type
709 applySubst ty = do { subst <- getTvSubst; return (substTy subst ty) }
711 extendSubstL :: TyVar -> Type -> LintM a -> LintM a
713 = LintM (\ loc subst errs -> unLintM m loc (extendTvSubst subst tv ty) errs)
717 lookupIdInScope :: Id -> LintM Id
719 | not (mustHaveLocalBinding id)
720 = return id -- An imported Id
722 = do { subst <- getTvSubst
723 ; case lookupInScope (getTvInScope subst) id of
725 Nothing -> do { addErrL out_of_scope
728 out_of_scope = ppr id <+> ptext SLIT("is out of scope")
731 oneTupleDataConId :: Id -- Should not happen
732 oneTupleDataConId = dataConWorkId (tupleCon Boxed 1)
734 checkBndrIdInScope :: Var -> Var -> LintM ()
735 checkBndrIdInScope binder id
736 = checkInScope msg id
738 msg = ptext SLIT("is out of scope inside info for") <+>
741 checkTyVarInScope :: TyVar -> LintM ()
742 checkTyVarInScope tv = checkInScope (ptext SLIT("is out of scope")) tv
744 checkInScope :: SDoc -> Var -> LintM ()
745 checkInScope loc_msg var =
746 do { subst <- getTvSubst
747 ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
748 (hsep [ppr var, loc_msg]) }
750 checkTys :: Type -> Type -> Message -> LintM ()
751 -- check ty2 is subtype of ty1 (ie, has same structure but usage
752 -- annotations need only be consistent, not equal)
753 -- Assumes ty1,ty2 are have alrady had the substitution applied
754 checkTys ty1 ty2 msg = checkL (ty1 `coreEqType` ty2) msg
757 %************************************************************************
759 \subsection{Error messages}
761 %************************************************************************
765 = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))
767 dumpLoc (LambdaBodyOf b)
768 = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
770 dumpLoc (BodyOfLetRec [])
771 = (noSrcLoc, brackets (ptext SLIT("In body of a letrec with no binders")))
773 dumpLoc (BodyOfLetRec bs@(_:_))
774 = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
777 = (noSrcLoc, text "In the expression:" <+> ppr e)
779 dumpLoc (CaseAlt (con, args, rhs))
780 = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args))
782 dumpLoc (CasePat (con, args, rhs))
783 = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args))
785 dumpLoc (ImportedUnfolding locn)
786 = (locn, brackets (ptext SLIT("in an imported unfolding")))
787 dumpLoc TopLevelBindings
790 pp_binders :: [Var] -> SDoc
791 pp_binders bs = sep (punctuate comma (map pp_binder bs))
793 pp_binder :: Var -> SDoc
794 pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)]
795 | isTyVar b = hsep [ppr b, dcolon, ppr (tyVarKind b)]
799 ------------------------------------------------------
800 -- Messages for case expressions
802 mkNullAltsMsg :: CoreExpr -> Message
804 = hang (text "Case expression with no alternatives:")
807 mkDefaultArgsMsg :: [Var] -> Message
808 mkDefaultArgsMsg args
809 = hang (text "DEFAULT case with binders")
812 mkCaseAltMsg :: CoreExpr -> Type -> Type -> Message
813 mkCaseAltMsg e ty1 ty2
814 = hang (text "Type of case alternatives not the same as the annotation on case:")
815 4 (vcat [ppr ty1, ppr ty2, ppr e])
817 mkScrutMsg :: Id -> Type -> Type -> TvSubst -> Message
818 mkScrutMsg var var_ty scrut_ty subst
819 = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
820 text "Result binder type:" <+> ppr var_ty,--(idType var),
821 text "Scrutinee type:" <+> ppr scrut_ty,
822 hsep [ptext SLIT("Current TV subst"), ppr subst]]
825 = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
826 mkNonIncreasingAltsMsg e
827 = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)
829 nonExhaustiveAltsMsg :: CoreExpr -> Message
830 nonExhaustiveAltsMsg e
831 = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
833 mkBadConMsg :: TyCon -> DataCon -> Message
834 mkBadConMsg tycon datacon
836 text "In a case alternative, data constructor isn't in scrutinee type:",
837 text "Scrutinee type constructor:" <+> ppr tycon,
838 text "Data con:" <+> ppr datacon
841 mkBadPatMsg :: Type -> Type -> Message
842 mkBadPatMsg con_result_ty scrut_ty
844 text "In a case alternative, pattern result type doesn't match scrutinee type:",
845 text "Pattern result type:" <+> ppr con_result_ty,
846 text "Scrutinee type:" <+> ppr scrut_ty
849 mkBadAltMsg :: Type -> CoreAlt -> Message
850 mkBadAltMsg scrut_ty alt
851 = vcat [ text "Data alternative when scrutinee is not a tycon application",
852 text "Scrutinee type:" <+> ppr scrut_ty,
853 text "Alternative:" <+> pprCoreAlt alt ]
855 mkNewTyDataConAltMsg :: Type -> CoreAlt -> Message
856 mkNewTyDataConAltMsg scrut_ty alt
857 = vcat [ text "Data alternative for newtype datacon",
858 text "Scrutinee type:" <+> ppr scrut_ty,
859 text "Alternative:" <+> pprCoreAlt alt ]
862 ------------------------------------------------------
863 -- Other error messages
865 mkAppMsg :: Type -> Type -> CoreExpr -> Message
866 mkAppMsg fun_ty arg_ty arg
867 = vcat [ptext SLIT("Argument value doesn't match argument type:"),
868 hang (ptext SLIT("Fun type:")) 4 (ppr fun_ty),
869 hang (ptext SLIT("Arg type:")) 4 (ppr arg_ty),
870 hang (ptext SLIT("Arg:")) 4 (ppr arg)]
872 mkNonFunAppMsg :: Type -> Type -> CoreExpr -> Message
873 mkNonFunAppMsg fun_ty arg_ty arg
874 = vcat [ptext SLIT("Non-function type in function position"),
875 hang (ptext SLIT("Fun type:")) 4 (ppr fun_ty),
876 hang (ptext SLIT("Arg type:")) 4 (ppr arg_ty),
877 hang (ptext SLIT("Arg:")) 4 (ppr arg)]
879 mkKindErrMsg :: TyVar -> Type -> Message
880 mkKindErrMsg tyvar arg_ty
881 = vcat [ptext SLIT("Kinds don't match in type application:"),
882 hang (ptext SLIT("Type variable:"))
883 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
884 hang (ptext SLIT("Arg type:"))
885 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
887 mkTyAppMsg :: Type -> Type -> Message
889 = vcat [text "Illegal type application:",
890 hang (ptext SLIT("Exp type:"))
891 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
892 hang (ptext SLIT("Arg type:"))
893 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
895 mkRhsMsg :: Id -> Type -> Message
898 [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
900 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
901 hsep [ptext SLIT("Rhs type:"), ppr ty]]
903 mkRhsPrimMsg :: Id -> CoreExpr -> Message
904 mkRhsPrimMsg binder rhs
905 = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
907 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
910 mkStrictMsg :: Id -> Message
912 = vcat [hsep [ptext SLIT("Recursive or top-level binder has strict demand info:"),
914 hsep [ptext SLIT("Binder's demand info:"), ppr (idNewDemandInfo binder)]
917 mkArityMsg :: Id -> Message
919 = vcat [hsep [ptext SLIT("Demand type has "),
920 ppr (dmdTypeDepth dmd_ty),
921 ptext SLIT(" arguments, rhs has "),
922 ppr (idArity binder),
923 ptext SLIT("arguments, "),
925 hsep [ptext SLIT("Binder's strictness signature:"), ppr dmd_ty]
928 where (StrictSig dmd_ty) = idNewStrictness binder
930 mkUnboxedTupleMsg :: Id -> Message
931 mkUnboxedTupleMsg binder
932 = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
933 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
935 mkCastErr from_ty expr_ty
936 = vcat [ptext SLIT("From-type of Cast differs from type of enclosed expression"),
937 ptext SLIT("From-type:") <+> ppr from_ty,
938 ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
942 = hang (ptext SLIT("Duplicate variables brought into scope"))
946 = ptext SLIT("Type where expression expected:") <+> ppr e