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
13 showPass, endPass, endPassIf, endIteration
16 #include "HsVersions.h"
48 %************************************************************************
52 %************************************************************************
54 @showPass@ and @endPass@ don't really belong here, but it makes a convenient
55 place for them. They print out stuff before and after core passes,
56 and do Core Lint when necessary.
59 endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO ()
60 endPass = dumpAndLint dumpIfSet_core
62 endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO ()
63 endPassIf cond = dumpAndLint (dumpIf_core cond)
65 endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO ()
66 endIteration = dumpAndLint dumpIfSet_dyn
68 dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ())
69 -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO ()
70 dumpAndLint dump dflags pass_name dump_flag binds
72 -- Report result size if required
73 -- This has the side effect of forcing the intermediate to be evaluated
74 debugTraceMsg dflags 2 $
75 (text " Result size =" <+> int (coreBindsSize binds))
77 -- Report verbosely, if required
78 dump dflags dump_flag pass_name (pprCoreBindings binds)
81 lintCoreBindings dflags pass_name binds
85 %************************************************************************
87 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
89 %************************************************************************
91 Checks that a set of core bindings is well-formed. The PprStyle and String
92 just control what we print in the event of an error. The Bool value
93 indicates whether we have done any specialisation yet (in which case we do
98 (b) Out-of-scope type variables
99 (c) Out-of-scope local variables
102 If we have done specialisation the we check that there are
103 (a) No top-level bindings of primitive (unboxed type)
108 -- Things are *not* OK if:
110 -- * Unsaturated type app before specialisation has been done;
112 -- * Oversaturated type app after specialisation (eta reduction
113 -- may well be happening...);
116 Note [Linting type lets]
117 ~~~~~~~~~~~~~~~~~~~~~~~~
118 In the desugarer, it's very very convenient to be able to say (in effect)
119 let a = Type Int in <body>
120 That is, use a type let. See Note [Type let] in CoreSyn.
122 However, when linting <body> we need to remember that a=Int, else we might
123 reject a correct program. So we carry a type substitution (in this example
124 [a -> Int]) and apply this substitution before comparing types. The functin
125 lintTy :: Type -> LintM Type
126 returns a substituted type; that's the only reason it returns anything.
128 When we encounter a binder (like x::a) we must apply the substitution
129 to the type of the binding variable. lintBinders does this.
131 For Ids, the type-substituted Id is added to the in_scope set (which
132 itself is part of the TvSubst we are carrying down), and when we
133 find an occurence of an Id, we fetch it from the in-scope set.
137 lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
139 lintCoreBindings dflags _whoDunnit _binds
140 | not (dopt Opt_DoCoreLinting dflags)
143 lintCoreBindings dflags whoDunnit binds
144 = case (initL (lint_binds binds)) of
145 Nothing -> showPass dflags ("Core Linted result of " ++ whoDunnit)
146 Just bad_news -> printDump (display bad_news) >>
149 -- Put all the top-level binders in scope at the start
150 -- This is because transformation rules can bring something
151 -- into use 'unexpectedly'
152 lint_binds binds = addLoc TopLevelBindings $
153 addInScopeVars (bindersOfBinds binds) $
156 lint_bind (Rec prs) = mapM_ (lintSingleBinding TopLevel Recursive) prs
157 lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)
160 = vcat [ text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
162 ptext (sLit "*** Offending Program ***"),
163 pprCoreBindings binds,
164 ptext (sLit "*** End of Offense ***")
168 %************************************************************************
170 \subsection[lintUnfolding]{lintUnfolding}
172 %************************************************************************
174 We use this to check all unfoldings that come in from interfaces
175 (it is very painful to catch errors otherwise):
178 lintUnfolding :: SrcLoc
179 -> [Var] -- Treat these as in scope
181 -> Maybe Message -- Nothing => OK
183 lintUnfolding locn vars expr
184 = initL (addLoc (ImportedUnfolding locn) $
185 addInScopeVars vars $
189 %************************************************************************
191 \subsection[lintCoreBinding]{lintCoreBinding}
193 %************************************************************************
195 Check a core binding, returning the list of variables bound.
198 lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM ()
199 lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
200 = addLoc (RhsOf binder) $
202 do { ty <- lintCoreExpr rhs
203 ; lintBinder binder -- Check match to RHS type
204 ; binder_ty <- applySubst binder_ty
205 ; checkTys binder_ty ty (mkRhsMsg binder ty)
206 -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
207 ; checkL (not (isUnLiftedType binder_ty)
208 || (isNonRec rec_flag && exprOkForSpeculation rhs))
209 (mkRhsPrimMsg binder rhs)
210 -- Check that if the binder is top-level or recursive, it's not demanded
211 ; checkL (not (isStrictId binder)
212 || (isNonRec rec_flag && not (isTopLevel top_lvl_flag)))
214 -- Check whether binder's specialisations contain any out-of-scope variables
215 ; mapM_ (checkBndrIdInScope binder) bndr_vars
217 -- Check whether arity and demand type are consistent (only if demand analysis
219 ; checkL (case maybeDmdTy of
220 Just (StrictSig dmd_ty) -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs
222 (mkArityMsg binder) }
224 -- We should check the unfolding, if any, but this is tricky because
225 -- the unfolding is a SimplifiableCoreExpr. Give up for now.
227 binder_ty = idType binder
228 maybeDmdTy = idNewStrictness_maybe binder
229 bndr_vars = varSetElems (idFreeVars binder `unionVarSet` wkr_vars)
230 wkr_vars | workerExists wkr_info = unitVarSet (workerId wkr_info)
231 | otherwise = emptyVarSet
232 wkr_info = idWorkerInfo binder
233 lintBinder var | isId var = lintIdBndr var $ \_ -> (return ())
234 | otherwise = return ()
237 %************************************************************************
239 \subsection[lintCoreExpr]{lintCoreExpr}
241 %************************************************************************
244 type InType = Type -- Substitution not yet applied
245 type OutType = Type -- Substitution has been applied to this
247 lintCoreExpr :: CoreExpr -> LintM OutType
248 -- The returned type has the substitution from the monad
249 -- already applied to it:
250 -- lintCoreExpr e subst = exprType (subst e)
252 -- The returned "type" can be a kind, if the expression is (Type ty)
254 lintCoreExpr (Var var)
255 = do { checkL (not (var == oneTupleDataConId))
256 (ptext (sLit "Illegal one-tuple"))
259 ; var' <- lookupIdInScope var
260 ; return (idType var')
263 lintCoreExpr (Lit lit)
264 = return (literalType lit)
266 --lintCoreExpr (Note (Coerce to_ty from_ty) expr)
267 -- = do { expr_ty <- lintCoreExpr expr
268 -- ; to_ty <- lintTy to_ty
269 -- ; from_ty <- lintTy from_ty
270 -- ; checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty)
273 lintCoreExpr (Cast expr co)
274 = do { expr_ty <- lintCoreExpr expr
276 ; let (from_ty, to_ty) = coercionKind co'
277 ; checkTys from_ty expr_ty (mkCastErr from_ty expr_ty)
280 lintCoreExpr (Note _ expr)
283 lintCoreExpr (Let (NonRec tv (Type ty)) body)
284 = -- See Note [Type let] in CoreSyn
285 do { checkL (isTyVar tv) (mkKindErrMsg tv ty) -- Not quite accurate
287 ; kind' <- lintTy (tyVarKind tv)
288 ; let tv' = setTyVarKind tv kind'
290 -- Now extend the substitution so we
291 -- take advantage of it in the body
292 ; addLoc (BodyOfLetRec [tv]) $
293 addInScopeVars [tv'] $
294 extendSubstL tv' ty' $
297 lintCoreExpr (Let (NonRec bndr rhs) body)
298 = do { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs)
299 ; addLoc (BodyOfLetRec [bndr])
300 (lintAndScopeId bndr $ \_ -> (lintCoreExpr body)) }
302 lintCoreExpr (Let (Rec pairs) body)
303 = lintAndScopeIds bndrs $ \_ ->
304 do { mapM_ (lintSingleBinding NotTopLevel Recursive) pairs
305 ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
307 bndrs = map fst pairs
309 lintCoreExpr e@(App fun arg)
310 = do { fun_ty <- lintCoreExpr fun
311 ; addLoc (AnExpr e) $
312 lintCoreArg fun_ty arg }
314 lintCoreExpr (Lam var expr)
315 = addLoc (LambdaBodyOf var) $
316 lintBinders [var] $ \[var'] ->
317 do { body_ty <- lintCoreExpr expr
319 return (mkFunTy (idType var') body_ty)
321 return (mkForAllTy var' body_ty)
323 -- The applySubst is needed to apply the subst to var
325 lintCoreExpr e@(Case scrut var alt_ty alts) =
326 -- Check the scrutinee
327 do { scrut_ty <- lintCoreExpr scrut
328 ; alt_ty <- lintTy alt_ty
329 ; var_ty <- lintTy (idType var)
331 ; let mb_tc_app = splitTyConApp_maybe (idType var)
336 not (isOpenTyCon tycon) &&
337 null (tyConDataCons tycon) ->
338 pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var))
339 -- This can legitimately happen for type families
341 _otherwise -> return ()
343 -- Don't use lintIdBndr on var, because unboxed tuple is legitimate
345 ; subst <- getTvSubst
346 ; checkTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst)
348 -- If the binder is an unboxed tuple type, don't put it in scope
349 ; let scope = if (isUnboxedTupleType (idType var)) then
351 else lintAndScopeId var
353 do { -- Check the alternatives
354 mapM_ (lintCoreAlt scrut_ty alt_ty) alts
355 ; checkCaseAlts e scrut_ty alts
360 lintCoreExpr (Type ty)
361 = do { ty' <- lintTy ty
362 ; return (typeKind ty') }
365 %************************************************************************
367 \subsection[lintCoreArgs]{lintCoreArgs}
369 %************************************************************************
371 The basic version of these functions checks that the argument is a
372 subtype of the required type, as one would expect.
375 lintCoreArgs :: OutType -> [CoreArg] -> LintM OutType
376 lintCoreArg :: OutType -> CoreArg -> LintM OutType
377 -- First argument has already had substitution applied to it
381 lintCoreArgs ty [] = return ty
382 lintCoreArgs ty (a : args) =
383 do { res <- lintCoreArg ty a
384 ; lintCoreArgs res args }
386 lintCoreArg fun_ty (Type arg_ty) =
387 do { arg_ty <- lintTy arg_ty
388 ; lintTyApp fun_ty arg_ty }
390 lintCoreArg fun_ty arg =
391 -- Make sure function type matches argument
392 do { arg_ty <- lintCoreExpr arg
393 ; let err1 = mkAppMsg fun_ty arg_ty arg
394 err2 = mkNonFunAppMsg fun_ty arg_ty arg
395 ; case splitFunTy_maybe fun_ty of
397 do { checkTys arg arg_ty err1
403 -- Both args have had substitution applied
404 lintTyApp :: OutType -> OutType -> LintM OutType
406 = case splitForAllTy_maybe ty of
407 Nothing -> addErrL (mkTyAppMsg ty arg_ty)
410 -> do { checkL (isTyVar tyvar) (mkTyAppMsg ty arg_ty)
411 ; checkKinds tyvar arg_ty
412 ; return (substTyWith [tyvar] [arg_ty] body) }
414 checkKinds :: Var -> Type -> LintM ()
415 checkKinds tyvar arg_ty
416 -- Arg type might be boxed for a function with an uncommitted
417 -- tyvar; notably this is used so that we can give
418 -- error :: forall a:*. String -> a
419 -- and then apply it to both boxed and unboxed types.
420 = checkL (arg_kind `isSubKind` tyvar_kind)
421 (mkKindErrMsg tyvar arg_ty)
423 tyvar_kind = tyVarKind tyvar
424 arg_kind | isCoVar tyvar = coercionKindPredTy arg_ty
425 | otherwise = typeKind arg_ty
427 checkDeadIdOcc :: Id -> LintM ()
428 -- Occurrences of an Id should never be dead....
429 -- except when we are checking a case pattern
431 | isDeadOcc (idOccInfo id)
432 = do { in_case <- inCasePat
434 (ptext (sLit "Occurrence of a dead Id") <+> ppr id) }
440 %************************************************************************
442 \subsection[lintCoreAlts]{lintCoreAlts}
444 %************************************************************************
447 checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
448 -- a) Check that the alts are non-empty
449 -- b1) Check that the DEFAULT comes first, if it exists
450 -- b2) Check that the others are in increasing order
451 -- c) Check that there's a default for infinite types
452 -- NB: Algebraic cases are not necessarily exhaustive, because
453 -- the simplifer correctly eliminates case that can't
457 = addErrL (mkNullAltsMsg e)
459 checkCaseAlts e ty alts =
460 do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
461 ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
462 ; checkL (isJust maybe_deflt || not is_infinite_ty)
463 (nonExhaustiveAltsMsg e) }
465 (con_alts, maybe_deflt) = findDefault alts
467 -- Check that successive alternatives have increasing tags
468 increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest
469 increasing_tag _ = True
471 non_deflt (DEFAULT, _, _) = False
474 is_infinite_ty = case splitTyConApp_maybe ty of
476 Just (tycon, _) -> isPrimTyCon tycon
480 checkAltExpr :: CoreExpr -> OutType -> LintM ()
481 checkAltExpr expr ann_ty
482 = do { actual_ty <- lintCoreExpr expr
483 ; checkTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) }
485 lintCoreAlt :: OutType -- Type of scrutinee
486 -> OutType -- Type of the alternative
490 lintCoreAlt _ alt_ty (DEFAULT, args, rhs) =
491 do { checkL (null args) (mkDefaultArgsMsg args)
492 ; checkAltExpr rhs alt_ty }
494 lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs) =
495 do { checkL (null args) (mkDefaultArgsMsg args)
496 ; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty)
497 ; checkAltExpr rhs alt_ty }
499 lit_ty = literalType lit
501 lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
502 | isNewTyCon (dataConTyCon con) = addErrL (mkNewTyDataConAltMsg scrut_ty alt)
503 | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty
504 = addLoc (CaseAlt alt) $ do
505 { -- First instantiate the universally quantified
506 -- type variables of the data constructor
507 -- We've already check
508 checkL (tycon == dataConTyCon con) (mkBadConMsg tycon con)
509 ; let con_payload_ty = applyTys (dataConRepType con) tycon_arg_tys
511 -- And now bring the new binders into scope
512 ; lintBinders args $ \ args -> do
513 { addLoc (CasePat alt) $ do
514 { -- Check the pattern
515 -- Scrutinee type must be a tycon applicn; checked by caller
516 -- This code is remarkably compact considering what it does!
517 -- NB: args must be in scope here so that the lintCoreArgs
519 -- NB: relies on existential type args coming *after*
520 -- ordinary type args
521 ; con_result_ty <- lintCoreArgs con_payload_ty (varsToCoreExprs args)
522 ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
525 ; checkAltExpr rhs alt_ty } }
527 | otherwise -- Scrut-ty is wrong shape
528 = addErrL (mkBadAltMsg scrut_ty alt)
531 %************************************************************************
533 \subsection[lint-types]{Types}
535 %************************************************************************
538 -- When we lint binders, we (one at a time and in order):
539 -- 1. Lint var types or kinds (possibly substituting)
540 -- 2. Add the binder to the in scope set, and if its a coercion var,
541 -- we may extend the substitution to reflect its (possibly) new kind
542 lintBinders :: [Var] -> ([Var] -> LintM a) -> LintM a
543 lintBinders [] linterF = linterF []
544 lintBinders (var:vars) linterF = lintBinder var $ \var' ->
545 lintBinders vars $ \ vars' ->
548 lintBinder :: Var -> (Var -> LintM a) -> LintM a
549 lintBinder var linterF
550 | isTyVar var = lint_ty_bndr
551 | otherwise = lintIdBndr var linterF
553 lint_ty_bndr = do { _ <- lintTy (tyVarKind var)
554 ; subst <- getTvSubst
555 ; let (subst', tv') = substTyVarBndr subst var
556 ; updateTvSubst subst' (linterF tv') }
558 lintIdBndr :: Var -> (Var -> LintM a) -> LintM a
559 -- Do substitution on the type of a binder and add the var with this
560 -- new type to the in-scope set of the second argument
561 -- ToDo: lint its rules
562 lintIdBndr id linterF
563 = do { checkL (not (isUnboxedTupleType (idType id)))
564 (mkUnboxedTupleMsg id)
565 -- No variable can be bound to an unboxed tuple.
566 ; lintAndScopeId id $ \id' -> linterF id'
569 lintAndScopeIds :: [Var] -> ([Var] -> LintM a) -> LintM a
570 lintAndScopeIds ids linterF
574 go (id:ids) = do { lintAndScopeId id $ \id ->
575 lintAndScopeIds ids $ \ids ->
578 lintAndScopeId :: Var -> (Var -> LintM a) -> LintM a
579 lintAndScopeId id linterF
580 = do { ty <- lintTy (idType id)
581 ; let id' = setIdType id ty
582 ; addInScopeVars [id'] $ (linterF id')
585 lintTy :: InType -> LintM OutType
586 -- Check the type, and apply the substitution to it
587 -- See Note [Linting type lets]
588 -- ToDo: check the kind structure of the type
590 = do { ty' <- applySubst ty
591 ; mapM_ checkTyVarInScope (varSetElems (tyVarsOfType ty'))
596 %************************************************************************
598 \subsection[lint-monad]{The Lint monad}
600 %************************************************************************
605 [LintLocInfo] -> -- Locations
606 TvSubst -> -- Current type substitution; we also use this
607 -- to keep track of all the variables in scope,
608 -- both Ids and TyVars
609 Bag Message -> -- Error messages so far
610 (Maybe a, Bag Message) } -- Result and error messages (if any)
612 {- Note [Type substitution]
613 ~~~~~~~~~~~~~~~~~~~~~~~~
614 Why do we need a type substitution? Consider
615 /\(a:*). \(x:a). /\(a:*). id a x
616 This is ill typed, because (renaming variables) it is really
617 /\(a:*). \(x:a). /\(b:*). id b x
618 Hence, when checking an application, we can't naively compare x's type
619 (at its binding site) with its expected type (at a use site). So we
620 rename type binders as we go, maintaining a substitution.
622 The same substitution also supports let-type, current expressed as
624 Here we substitute 'ty' for 'a' in 'body', on the fly.
627 instance Monad LintM where
628 return x = LintM (\ _ _ errs -> (Just x, errs))
629 fail err = LintM (\ loc subst errs -> (Nothing, addErr subst errs (text err) loc))
630 m >>= k = LintM (\ loc subst errs ->
631 let (res, errs') = unLintM m loc subst errs in
633 Just r -> unLintM (k r) loc subst errs'
634 Nothing -> (Nothing, errs'))
637 = RhsOf Id -- The variable bound
638 | LambdaBodyOf Id -- The lambda-binder
639 | BodyOfLetRec [Id] -- One of the binders
640 | CaseAlt CoreAlt -- Case alternative
641 | CasePat CoreAlt -- The *pattern* of the case alternative
642 | AnExpr CoreExpr -- Some expression
643 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
649 initL :: LintM a -> Maybe Message {- errors -}
651 = case unLintM m [] emptyTvSubst emptyBag of
652 (_, errs) | isEmptyBag errs -> Nothing
653 | otherwise -> Just (vcat (punctuate (text "") (bagToList errs)))
657 checkL :: Bool -> Message -> LintM ()
658 checkL True _ = return ()
659 checkL False msg = addErrL msg
661 addErrL :: Message -> LintM a
662 addErrL msg = LintM (\ loc subst errs -> (Nothing, addErr subst errs msg loc))
664 addErr :: TvSubst -> Bag Message -> Message -> [LintLocInfo] -> Bag Message
665 addErr subst errs_so_far msg locs
666 = ASSERT( notNull locs )
667 errs_so_far `snocBag` mk_msg msg
669 (loc, cxt1) = dumpLoc (head locs)
670 cxts = [snd (dumpLoc loc) | loc <- locs]
671 context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$
672 ptext (sLit "Substitution:") <+> ppr subst
675 mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg)
677 addLoc :: LintLocInfo -> LintM a -> LintM a
679 LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs)
681 inCasePat :: LintM Bool -- A slight hack; see the unique call site
682 inCasePat = LintM $ \ loc _ errs -> (Just (is_case_pat loc), errs)
684 is_case_pat (CasePat {} : _) = True
685 is_case_pat _other = False
687 addInScopeVars :: [Var] -> LintM a -> LintM a
688 addInScopeVars vars m
690 = LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs)
692 = addErrL (dupVars dups)
694 (_, dups) = removeDups compare vars
696 updateTvSubst :: TvSubst -> LintM a -> LintM a
697 updateTvSubst subst' m =
698 LintM (\ loc _ errs -> unLintM m loc subst' errs)
700 getTvSubst :: LintM TvSubst
701 getTvSubst = LintM (\ _ subst errs -> (Just subst, errs))
703 applySubst :: Type -> LintM Type
704 applySubst ty = do { subst <- getTvSubst; return (substTy subst ty) }
706 extendSubstL :: TyVar -> Type -> LintM a -> LintM a
708 = LintM (\ loc subst errs -> unLintM m loc (extendTvSubst subst tv ty) errs)
712 lookupIdInScope :: Id -> LintM Id
714 | not (mustHaveLocalBinding id)
715 = return id -- An imported Id
717 = do { subst <- getTvSubst
718 ; case lookupInScope (getTvInScope subst) id of
720 Nothing -> do { _ <- addErrL out_of_scope
723 out_of_scope = ppr id <+> ptext (sLit "is out of scope")
726 oneTupleDataConId :: Id -- Should not happen
727 oneTupleDataConId = dataConWorkId (tupleCon Boxed 1)
729 checkBndrIdInScope :: Var -> Var -> LintM ()
730 checkBndrIdInScope binder id
731 = checkInScope msg id
733 msg = ptext (sLit "is out of scope inside info for") <+>
736 checkTyVarInScope :: TyVar -> LintM ()
737 checkTyVarInScope tv = checkInScope (ptext (sLit "is out of scope")) tv
739 checkInScope :: SDoc -> Var -> LintM ()
740 checkInScope loc_msg var =
741 do { subst <- getTvSubst
742 ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
743 (hsep [ppr var, loc_msg]) }
745 checkTys :: Type -> Type -> Message -> LintM ()
746 -- check ty2 is subtype of ty1 (ie, has same structure but usage
747 -- annotations need only be consistent, not equal)
748 -- Assumes ty1,ty2 are have alrady had the substitution applied
749 checkTys ty1 ty2 msg = checkL (ty1 `coreEqType` ty2) msg
752 %************************************************************************
754 \subsection{Error messages}
756 %************************************************************************
759 dumpLoc :: LintLocInfo -> (SrcLoc, SDoc)
762 = (getSrcLoc v, brackets (ptext (sLit "RHS of") <+> pp_binders [v]))
764 dumpLoc (LambdaBodyOf b)
765 = (getSrcLoc b, brackets (ptext (sLit "in body of lambda with binder") <+> pp_binder b))
767 dumpLoc (BodyOfLetRec [])
768 = (noSrcLoc, brackets (ptext (sLit "In body of a letrec with no binders")))
770 dumpLoc (BodyOfLetRec bs@(_:_))
771 = ( getSrcLoc (head bs), brackets (ptext (sLit "in body of letrec with binders") <+> pp_binders bs))
774 = (noSrcLoc, text "In the expression:" <+> ppr e)
776 dumpLoc (CaseAlt (con, args, _))
777 = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args))
779 dumpLoc (CasePat (con, args, _))
780 = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args))
782 dumpLoc (ImportedUnfolding locn)
783 = (locn, brackets (ptext (sLit "in an imported unfolding")))
784 dumpLoc TopLevelBindings
787 pp_binders :: [Var] -> SDoc
788 pp_binders bs = sep (punctuate comma (map pp_binder bs))
790 pp_binder :: Var -> SDoc
791 pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)]
792 | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)]
796 ------------------------------------------------------
797 -- Messages for case expressions
799 mkNullAltsMsg :: CoreExpr -> Message
801 = hang (text "Case expression with no alternatives:")
804 mkDefaultArgsMsg :: [Var] -> Message
805 mkDefaultArgsMsg args
806 = hang (text "DEFAULT case with binders")
809 mkCaseAltMsg :: CoreExpr -> Type -> Type -> Message
810 mkCaseAltMsg e ty1 ty2
811 = hang (text "Type of case alternatives not the same as the annotation on case:")
812 4 (vcat [ppr ty1, ppr ty2, ppr e])
814 mkScrutMsg :: Id -> Type -> Type -> TvSubst -> Message
815 mkScrutMsg var var_ty scrut_ty subst
816 = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
817 text "Result binder type:" <+> ppr var_ty,--(idType var),
818 text "Scrutinee type:" <+> ppr scrut_ty,
819 hsep [ptext (sLit "Current TV subst"), ppr subst]]
821 mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> Message
823 = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
824 mkNonIncreasingAltsMsg e
825 = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)
827 nonExhaustiveAltsMsg :: CoreExpr -> Message
828 nonExhaustiveAltsMsg e
829 = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
831 mkBadConMsg :: TyCon -> DataCon -> Message
832 mkBadConMsg tycon datacon
834 text "In a case alternative, data constructor isn't in scrutinee type:",
835 text "Scrutinee type constructor:" <+> ppr tycon,
836 text "Data con:" <+> ppr datacon
839 mkBadPatMsg :: Type -> Type -> Message
840 mkBadPatMsg con_result_ty scrut_ty
842 text "In a case alternative, pattern result type doesn't match scrutinee type:",
843 text "Pattern result type:" <+> ppr con_result_ty,
844 text "Scrutinee type:" <+> ppr scrut_ty
847 mkBadAltMsg :: Type -> CoreAlt -> Message
848 mkBadAltMsg scrut_ty alt
849 = vcat [ text "Data alternative when scrutinee is not a tycon application",
850 text "Scrutinee type:" <+> ppr scrut_ty,
851 text "Alternative:" <+> pprCoreAlt alt ]
853 mkNewTyDataConAltMsg :: Type -> CoreAlt -> Message
854 mkNewTyDataConAltMsg scrut_ty alt
855 = vcat [ text "Data alternative for newtype datacon",
856 text "Scrutinee type:" <+> ppr scrut_ty,
857 text "Alternative:" <+> pprCoreAlt alt ]
860 ------------------------------------------------------
861 -- Other error messages
863 mkAppMsg :: Type -> Type -> CoreExpr -> Message
864 mkAppMsg fun_ty arg_ty arg
865 = vcat [ptext (sLit "Argument value doesn't match argument type:"),
866 hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty),
867 hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty),
868 hang (ptext (sLit "Arg:")) 4 (ppr arg)]
870 mkNonFunAppMsg :: Type -> Type -> CoreExpr -> Message
871 mkNonFunAppMsg fun_ty arg_ty arg
872 = vcat [ptext (sLit "Non-function type in function position"),
873 hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty),
874 hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty),
875 hang (ptext (sLit "Arg:")) 4 (ppr arg)]
877 mkKindErrMsg :: TyVar -> Type -> Message
878 mkKindErrMsg tyvar arg_ty
879 = vcat [ptext (sLit "Kinds don't match in type application:"),
880 hang (ptext (sLit "Type variable:"))
881 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
882 hang (ptext (sLit "Arg type:"))
883 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
885 mkTyAppMsg :: Type -> Type -> Message
887 = vcat [text "Illegal type application:",
888 hang (ptext (sLit "Exp type:"))
889 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
890 hang (ptext (sLit "Arg type:"))
891 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
893 mkRhsMsg :: Id -> Type -> Message
896 [hsep [ptext (sLit "The type of this binder doesn't match the type of its RHS:"),
898 hsep [ptext (sLit "Binder's type:"), ppr (idType binder)],
899 hsep [ptext (sLit "Rhs type:"), ppr ty]]
901 mkRhsPrimMsg :: Id -> CoreExpr -> Message
902 mkRhsPrimMsg binder _rhs
903 = vcat [hsep [ptext (sLit "The type of this binder is primitive:"),
905 hsep [ptext (sLit "Binder's type:"), ppr (idType binder)]
908 mkStrictMsg :: Id -> Message
910 = vcat [hsep [ptext (sLit "Recursive or top-level binder has strict demand info:"),
912 hsep [ptext (sLit "Binder's demand info:"), ppr (idNewDemandInfo binder)]
915 mkArityMsg :: Id -> Message
917 = vcat [hsep [ptext (sLit "Demand type has "),
918 ppr (dmdTypeDepth dmd_ty),
919 ptext (sLit " arguments, rhs has "),
920 ppr (idArity binder),
921 ptext (sLit "arguments, "),
923 hsep [ptext (sLit "Binder's strictness signature:"), ppr dmd_ty]
926 where (StrictSig dmd_ty) = idNewStrictness binder
928 mkUnboxedTupleMsg :: Id -> Message
929 mkUnboxedTupleMsg binder
930 = vcat [hsep [ptext (sLit "A variable has unboxed tuple type:"), ppr binder],
931 hsep [ptext (sLit "Binder's type:"), ppr (idType binder)]]
933 mkCastErr :: Type -> Type -> Message
934 mkCastErr from_ty expr_ty
935 = vcat [ptext (sLit "From-type of Cast differs from type of enclosed expression"),
936 ptext (sLit "From-type:") <+> ppr from_ty,
937 ptext (sLit "Type of enclosed expr:") <+> ppr expr_ty
940 dupVars :: [[Var]] -> Message
942 = hang (ptext (sLit "Duplicate variables brought into scope"))