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 [CoreBind]
60 endPass = dumpAndLint dumpIfSet_core
62 endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
63 endPassIf cond = dumpAndLint (dumpIf_core cond)
65 endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
66 endIteration = dumpAndLint dumpIfSet_dyn
68 dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ())
69 -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
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
87 %************************************************************************
89 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
91 %************************************************************************
93 Checks that a set of core bindings is well-formed. The PprStyle and String
94 just control what we print in the event of an error. The Bool value
95 indicates whether we have done any specialisation yet (in which case we do
100 (b) Out-of-scope type variables
101 (c) Out-of-scope local variables
104 If we have done specialisation the we check that there are
105 (a) No top-level bindings of primitive (unboxed type)
110 -- Things are *not* OK if:
112 -- * Unsaturated type app before specialisation has been done;
114 -- * Oversaturated type app after specialisation (eta reduction
115 -- may well be happening...);
118 Note [Linting type lets]
119 ~~~~~~~~~~~~~~~~~~~~~~~~
120 In the desugarer, it's very very convenient to be able to say (in effect)
121 let a = Type Int in <body>
122 That is, use a type let. See Note [Type let] in CoreSyn.
124 However, when linting <body> we need to remember that a=Int, else we might
125 reject a correct program. So we carry a type substitution (in this example
126 [a -> Int]) and apply this substitution before comparing types. The functin
127 lintTy :: Type -> LintM Type
128 returns a substituted type; that's the only reason it returns anything.
130 When we encounter a binder (like x::a) we must apply the substitution
131 to the type of the binding variable. lintBinders does this.
133 For Ids, the type-substituted Id is added to the in_scope set (which
134 itself is part of the TvSubst we are carrying down), and when we
135 find an occurence of an Id, we fetch it from the in-scope set.
139 lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
141 lintCoreBindings dflags _whoDunnit _binds
142 | not (dopt Opt_DoCoreLinting dflags)
145 lintCoreBindings dflags whoDunnit binds
146 = case (initL (lint_binds binds)) of
147 Nothing -> showPass dflags ("Core Linted result of " ++ whoDunnit)
148 Just bad_news -> printDump (display bad_news) >>
151 -- Put all the top-level binders in scope at the start
152 -- This is because transformation rules can bring something
153 -- into use 'unexpectedly'
154 lint_binds binds = addLoc TopLevelBindings $
155 addInScopeVars (bindersOfBinds binds) $
158 lint_bind (Rec prs) = mapM_ (lintSingleBinding TopLevel Recursive) prs
159 lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)
162 = vcat [ text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
164 ptext (sLit "*** Offending Program ***"),
165 pprCoreBindings binds,
166 ptext (sLit "*** End of Offense ***")
170 %************************************************************************
172 \subsection[lintUnfolding]{lintUnfolding}
174 %************************************************************************
176 We use this to check all unfoldings that come in from interfaces
177 (it is very painful to catch errors otherwise):
180 lintUnfolding :: SrcLoc
181 -> [Var] -- Treat these as in scope
183 -> Maybe Message -- Nothing => OK
185 lintUnfolding locn vars expr
186 = initL (addLoc (ImportedUnfolding locn) $
187 addInScopeVars vars $
191 %************************************************************************
193 \subsection[lintCoreBinding]{lintCoreBinding}
195 %************************************************************************
197 Check a core binding, returning the list of variables bound.
200 lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM ()
201 lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
202 = addLoc (RhsOf binder) $
204 do { ty <- lintCoreExpr rhs
205 ; lintBinder binder -- Check match to RHS type
206 ; binder_ty <- applySubst binder_ty
207 ; checkTys binder_ty ty (mkRhsMsg binder ty)
208 -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
209 ; checkL (not (isUnLiftedType binder_ty)
210 || (isNonRec rec_flag && exprOkForSpeculation rhs))
211 (mkRhsPrimMsg binder rhs)
212 -- Check that if the binder is top-level or recursive, it's not demanded
213 ; checkL (not (isStrictId binder)
214 || (isNonRec rec_flag && not (isTopLevel top_lvl_flag)))
216 -- Check whether binder's specialisations contain any out-of-scope variables
217 ; mapM_ (checkBndrIdInScope binder) bndr_vars
219 -- Check whether arity and demand type are consistent (only if demand analysis
221 ; checkL (case maybeDmdTy of
222 Just (StrictSig dmd_ty) -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs
224 (mkArityMsg binder) }
226 -- We should check the unfolding, if any, but this is tricky because
227 -- the unfolding is a SimplifiableCoreExpr. Give up for now.
229 binder_ty = idType binder
230 maybeDmdTy = idNewStrictness_maybe binder
231 bndr_vars = varSetElems (idFreeVars binder `unionVarSet` wkr_vars)
232 wkr_vars | workerExists wkr_info = unitVarSet (workerId wkr_info)
233 | otherwise = emptyVarSet
234 wkr_info = idWorkerInfo binder
235 lintBinder var | isId var = lintIdBndr var $ \_ -> (return ())
236 | otherwise = return ()
239 %************************************************************************
241 \subsection[lintCoreExpr]{lintCoreExpr}
243 %************************************************************************
246 type InType = Type -- Substitution not yet applied
247 type OutType = Type -- Substitution has been applied to this
249 lintCoreExpr :: CoreExpr -> LintM OutType
250 -- The returned type has the substitution from the monad
251 -- already applied to it:
252 -- lintCoreExpr e subst = exprType (subst e)
254 -- The returned "type" can be a kind, if the expression is (Type ty)
256 lintCoreExpr (Var var)
257 = do { checkL (not (var == oneTupleDataConId))
258 (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 null (tyConDataCons tycon) ->
337 pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var))
338 -- This can legitimately happen for type families
340 _otherwise -> return ()
342 -- Don't use lintIdBndr on var, because unboxed tuple is legitimate
344 ; subst <- getTvSubst
345 ; checkTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst)
347 -- If the binder is an unboxed tuple type, don't put it in scope
348 ; let scope = if (isUnboxedTupleType (idType var)) then
350 else lintAndScopeId var
352 do { -- Check the alternatives
353 mapM (lintCoreAlt scrut_ty alt_ty) alts
354 ; checkCaseAlts e scrut_ty alts
359 lintCoreExpr (Type ty)
360 = do { ty' <- lintTy ty
361 ; return (typeKind ty') }
364 %************************************************************************
366 \subsection[lintCoreArgs]{lintCoreArgs}
368 %************************************************************************
370 The basic version of these functions checks that the argument is a
371 subtype of the required type, as one would expect.
374 lintCoreArgs :: OutType -> [CoreArg] -> LintM OutType
375 lintCoreArg :: OutType -> CoreArg -> LintM OutType
376 -- First argument has already had substitution applied to it
380 lintCoreArgs ty [] = return ty
381 lintCoreArgs ty (a : args) =
382 do { res <- lintCoreArg ty a
383 ; lintCoreArgs res args }
385 lintCoreArg fun_ty (Type arg_ty) =
386 do { arg_ty <- lintTy arg_ty
387 ; lintTyApp fun_ty arg_ty }
389 lintCoreArg fun_ty arg =
390 -- Make sure function type matches argument
391 do { arg_ty <- lintCoreExpr arg
392 ; let err1 = mkAppMsg fun_ty arg_ty arg
393 err2 = mkNonFunAppMsg fun_ty arg_ty arg
394 ; case splitFunTy_maybe fun_ty of
396 do { checkTys arg arg_ty err1
402 -- Both args have had substitution applied
403 lintTyApp :: OutType -> OutType -> LintM OutType
405 = case splitForAllTy_maybe ty of
406 Nothing -> addErrL (mkTyAppMsg ty arg_ty)
409 -> do { checkL (isTyVar tyvar) (mkTyAppMsg ty arg_ty)
410 ; checkKinds tyvar arg_ty
411 ; return (substTyWith [tyvar] [arg_ty] body) }
413 checkKinds :: Var -> Type -> LintM ()
414 checkKinds tyvar arg_ty
415 -- Arg type might be boxed for a function with an uncommitted
416 -- tyvar; notably this is used so that we can give
417 -- error :: forall a:*. String -> a
418 -- and then apply it to both boxed and unboxed types.
419 = checkL (arg_kind `isSubKind` tyvar_kind)
420 (mkKindErrMsg tyvar arg_ty)
422 tyvar_kind = tyVarKind tyvar
423 arg_kind | isCoVar tyvar = coercionKindPredTy arg_ty
424 | otherwise = typeKind arg_ty
428 %************************************************************************
430 \subsection[lintCoreAlts]{lintCoreAlts}
432 %************************************************************************
435 checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
436 -- a) Check that the alts are non-empty
437 -- b1) Check that the DEFAULT comes first, if it exists
438 -- b2) Check that the others are in increasing order
439 -- c) Check that there's a default for infinite types
440 -- NB: Algebraic cases are not necessarily exhaustive, because
441 -- the simplifer correctly eliminates case that can't
445 = addErrL (mkNullAltsMsg e)
447 checkCaseAlts e ty alts =
448 do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
449 ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
450 ; checkL (isJust maybe_deflt || not is_infinite_ty)
451 (nonExhaustiveAltsMsg e) }
453 (con_alts, maybe_deflt) = findDefault alts
455 -- Check that successive alternatives have increasing tags
456 increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest
457 increasing_tag _ = True
459 non_deflt (DEFAULT, _, _) = False
462 is_infinite_ty = case splitTyConApp_maybe ty of
464 Just (tycon, _) -> isPrimTyCon tycon
468 checkAltExpr :: CoreExpr -> OutType -> LintM ()
469 checkAltExpr expr ann_ty
470 = do { actual_ty <- lintCoreExpr expr
471 ; checkTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) }
473 lintCoreAlt :: OutType -- Type of scrutinee
474 -> OutType -- Type of the alternative
478 lintCoreAlt _ alt_ty (DEFAULT, args, rhs) =
479 do { checkL (null args) (mkDefaultArgsMsg args)
480 ; checkAltExpr rhs alt_ty }
482 lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs) =
483 do { checkL (null args) (mkDefaultArgsMsg args)
484 ; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty)
485 ; checkAltExpr rhs alt_ty }
487 lit_ty = literalType lit
489 lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
490 | isNewTyCon (dataConTyCon con) = addErrL (mkNewTyDataConAltMsg scrut_ty alt)
491 | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty
492 = addLoc (CaseAlt alt) $ do
493 { -- First instantiate the universally quantified
494 -- type variables of the data constructor
495 -- We've already check
496 checkL (tycon == dataConTyCon con) (mkBadConMsg tycon con)
497 ; let con_payload_ty = applyTys (dataConRepType con) tycon_arg_tys
499 -- And now bring the new binders into scope
500 ; lintBinders args $ \ args -> do
501 { addLoc (CasePat alt) $ do
502 { -- Check the pattern
503 -- Scrutinee type must be a tycon applicn; checked by caller
504 -- This code is remarkably compact considering what it does!
505 -- NB: args must be in scope here so that the lintCoreArgs
507 -- NB: relies on existential type args coming *after*
508 -- ordinary type args
509 ; con_result_ty <- lintCoreArgs con_payload_ty (varsToCoreExprs args)
510 ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
513 ; checkAltExpr rhs alt_ty } }
515 | otherwise -- Scrut-ty is wrong shape
516 = addErrL (mkBadAltMsg scrut_ty alt)
519 %************************************************************************
521 \subsection[lint-types]{Types}
523 %************************************************************************
526 -- When we lint binders, we (one at a time and in order):
527 -- 1. Lint var types or kinds (possibly substituting)
528 -- 2. Add the binder to the in scope set, and if its a coercion var,
529 -- we may extend the substitution to reflect its (possibly) new kind
530 lintBinders :: [Var] -> ([Var] -> LintM a) -> LintM a
531 lintBinders [] linterF = linterF []
532 lintBinders (var:vars) linterF = lintBinder var $ \var' ->
533 lintBinders vars $ \ vars' ->
536 lintBinder :: Var -> (Var -> LintM a) -> LintM a
537 lintBinder var linterF
538 | isTyVar var = lint_ty_bndr
539 | otherwise = lintIdBndr var linterF
541 lint_ty_bndr = do { lintTy (tyVarKind var)
542 ; subst <- getTvSubst
543 ; let (subst', tv') = substTyVarBndr subst var
544 ; updateTvSubst subst' (linterF tv') }
546 lintIdBndr :: Var -> (Var -> LintM a) -> LintM a
547 -- Do substitution on the type of a binder and add the var with this
548 -- new type to the in-scope set of the second argument
549 -- ToDo: lint its rules
550 lintIdBndr id linterF
551 = do { checkL (not (isUnboxedTupleType (idType id)))
552 (mkUnboxedTupleMsg id)
553 -- No variable can be bound to an unboxed tuple.
554 ; lintAndScopeId id $ \id' -> linterF id'
557 lintAndScopeIds :: [Var] -> ([Var] -> LintM a) -> LintM a
558 lintAndScopeIds ids linterF
562 go (id:ids) = do { lintAndScopeId id $ \id ->
563 lintAndScopeIds ids $ \ids ->
566 lintAndScopeId :: Var -> (Var -> LintM a) -> LintM a
567 lintAndScopeId id linterF
568 = do { ty <- lintTy (idType id)
569 ; let id' = setIdType id ty
570 ; addInScopeVars [id'] $ (linterF id')
573 lintTy :: InType -> LintM OutType
574 -- Check the type, and apply the substitution to it
575 -- See Note [Linting type lets]
576 -- ToDo: check the kind structure of the type
578 = do { ty' <- applySubst ty
579 ; mapM_ checkTyVarInScope (varSetElems (tyVarsOfType ty'))
584 %************************************************************************
586 \subsection[lint-monad]{The Lint monad}
588 %************************************************************************
593 [LintLocInfo] -> -- Locations
594 TvSubst -> -- Current type substitution; we also use this
595 -- to keep track of all the variables in scope,
596 -- both Ids and TyVars
597 Bag Message -> -- Error messages so far
598 (Maybe a, Bag Message) } -- Result and error messages (if any)
600 {- Note [Type substitution]
601 ~~~~~~~~~~~~~~~~~~~~~~~~
602 Why do we need a type substitution? Consider
603 /\(a:*). \(x:a). /\(a:*). id a x
604 This is ill typed, because (renaming variables) it is really
605 /\(a:*). \(x:a). /\(b:*). id b x
606 Hence, when checking an application, we can't naively compare x's type
607 (at its binding site) with its expected type (at a use site). So we
608 rename type binders as we go, maintaining a substitution.
610 The same substitution also supports let-type, current expressed as
612 Here we substitute 'ty' for 'a' in 'body', on the fly.
615 instance Monad LintM where
616 return x = LintM (\ _ _ errs -> (Just x, errs))
617 fail err = LintM (\ loc subst errs -> (Nothing, addErr subst errs (text err) loc))
618 m >>= k = LintM (\ loc subst errs ->
619 let (res, errs') = unLintM m loc subst errs in
621 Just r -> unLintM (k r) loc subst errs'
622 Nothing -> (Nothing, errs'))
625 = RhsOf Id -- The variable bound
626 | LambdaBodyOf Id -- The lambda-binder
627 | BodyOfLetRec [Id] -- One of the binders
628 | CaseAlt CoreAlt -- Case alternative
629 | CasePat CoreAlt -- The *pattern* of the case alternative
630 | AnExpr CoreExpr -- Some expression
631 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
637 initL :: LintM a -> Maybe Message {- errors -}
639 = case unLintM m [] emptyTvSubst emptyBag of
640 (_, errs) | isEmptyBag errs -> Nothing
641 | otherwise -> Just (vcat (punctuate (text "") (bagToList errs)))
645 checkL :: Bool -> Message -> LintM ()
646 checkL True _ = return ()
647 checkL False msg = addErrL msg
649 addErrL :: Message -> LintM a
650 addErrL msg = LintM (\ loc subst errs -> (Nothing, addErr subst errs msg loc))
652 addErr :: TvSubst -> Bag Message -> Message -> [LintLocInfo] -> Bag Message
653 addErr subst errs_so_far msg locs
654 = ASSERT( notNull locs )
655 errs_so_far `snocBag` mk_msg msg
657 (loc, cxt1) = dumpLoc (head locs)
658 cxts = [snd (dumpLoc loc) | loc <- locs]
659 context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$
660 ptext (sLit "Substitution:") <+> ppr subst
663 mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg)
665 addLoc :: LintLocInfo -> LintM a -> LintM a
667 LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs)
669 addInScopeVars :: [Var] -> LintM a -> LintM a
670 addInScopeVars vars m
672 = LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs)
674 = addErrL (dupVars dups)
676 (_, dups) = removeDups compare vars
678 updateTvSubst :: TvSubst -> LintM a -> LintM a
679 updateTvSubst subst' m =
680 LintM (\ loc _ errs -> unLintM m loc subst' errs)
682 getTvSubst :: LintM TvSubst
683 getTvSubst = LintM (\ _ subst errs -> (Just subst, errs))
685 applySubst :: Type -> LintM Type
686 applySubst ty = do { subst <- getTvSubst; return (substTy subst ty) }
688 extendSubstL :: TyVar -> Type -> LintM a -> LintM a
690 = LintM (\ loc subst errs -> unLintM m loc (extendTvSubst subst tv ty) errs)
694 lookupIdInScope :: Id -> LintM Id
696 | not (mustHaveLocalBinding id)
697 = return id -- An imported Id
699 = do { subst <- getTvSubst
700 ; case lookupInScope (getTvInScope subst) id of
702 Nothing -> do { addErrL out_of_scope
705 out_of_scope = ppr id <+> ptext (sLit "is out of scope")
708 oneTupleDataConId :: Id -- Should not happen
709 oneTupleDataConId = dataConWorkId (tupleCon Boxed 1)
711 checkBndrIdInScope :: Var -> Var -> LintM ()
712 checkBndrIdInScope binder id
713 = checkInScope msg id
715 msg = ptext (sLit "is out of scope inside info for") <+>
718 checkTyVarInScope :: TyVar -> LintM ()
719 checkTyVarInScope tv = checkInScope (ptext (sLit "is out of scope")) tv
721 checkInScope :: SDoc -> Var -> LintM ()
722 checkInScope loc_msg var =
723 do { subst <- getTvSubst
724 ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
725 (hsep [ppr var, loc_msg]) }
727 checkTys :: Type -> Type -> Message -> LintM ()
728 -- check ty2 is subtype of ty1 (ie, has same structure but usage
729 -- annotations need only be consistent, not equal)
730 -- Assumes ty1,ty2 are have alrady had the substitution applied
731 checkTys ty1 ty2 msg = checkL (ty1 `coreEqType` ty2) msg
734 %************************************************************************
736 \subsection{Error messages}
738 %************************************************************************
741 dumpLoc :: LintLocInfo -> (SrcLoc, SDoc)
744 = (getSrcLoc v, brackets (ptext (sLit "RHS of") <+> pp_binders [v]))
746 dumpLoc (LambdaBodyOf b)
747 = (getSrcLoc b, brackets (ptext (sLit "in body of lambda with binder") <+> pp_binder b))
749 dumpLoc (BodyOfLetRec [])
750 = (noSrcLoc, brackets (ptext (sLit "In body of a letrec with no binders")))
752 dumpLoc (BodyOfLetRec bs@(_:_))
753 = ( getSrcLoc (head bs), brackets (ptext (sLit "in body of letrec with binders") <+> pp_binders bs))
756 = (noSrcLoc, text "In the expression:" <+> ppr e)
758 dumpLoc (CaseAlt (con, args, _))
759 = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args))
761 dumpLoc (CasePat (con, args, _))
762 = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args))
764 dumpLoc (ImportedUnfolding locn)
765 = (locn, brackets (ptext (sLit "in an imported unfolding")))
766 dumpLoc TopLevelBindings
769 pp_binders :: [Var] -> SDoc
770 pp_binders bs = sep (punctuate comma (map pp_binder bs))
772 pp_binder :: Var -> SDoc
773 pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)]
774 | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)]
778 ------------------------------------------------------
779 -- Messages for case expressions
781 mkNullAltsMsg :: CoreExpr -> Message
783 = hang (text "Case expression with no alternatives:")
786 mkDefaultArgsMsg :: [Var] -> Message
787 mkDefaultArgsMsg args
788 = hang (text "DEFAULT case with binders")
791 mkCaseAltMsg :: CoreExpr -> Type -> Type -> Message
792 mkCaseAltMsg e ty1 ty2
793 = hang (text "Type of case alternatives not the same as the annotation on case:")
794 4 (vcat [ppr ty1, ppr ty2, ppr e])
796 mkScrutMsg :: Id -> Type -> Type -> TvSubst -> Message
797 mkScrutMsg var var_ty scrut_ty subst
798 = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
799 text "Result binder type:" <+> ppr var_ty,--(idType var),
800 text "Scrutinee type:" <+> ppr scrut_ty,
801 hsep [ptext (sLit "Current TV subst"), ppr subst]]
803 mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> Message
805 = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
806 mkNonIncreasingAltsMsg e
807 = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)
809 nonExhaustiveAltsMsg :: CoreExpr -> Message
810 nonExhaustiveAltsMsg e
811 = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
813 mkBadConMsg :: TyCon -> DataCon -> Message
814 mkBadConMsg tycon datacon
816 text "In a case alternative, data constructor isn't in scrutinee type:",
817 text "Scrutinee type constructor:" <+> ppr tycon,
818 text "Data con:" <+> ppr datacon
821 mkBadPatMsg :: Type -> Type -> Message
822 mkBadPatMsg con_result_ty scrut_ty
824 text "In a case alternative, pattern result type doesn't match scrutinee type:",
825 text "Pattern result type:" <+> ppr con_result_ty,
826 text "Scrutinee type:" <+> ppr scrut_ty
829 mkBadAltMsg :: Type -> CoreAlt -> Message
830 mkBadAltMsg scrut_ty alt
831 = vcat [ text "Data alternative when scrutinee is not a tycon application",
832 text "Scrutinee type:" <+> ppr scrut_ty,
833 text "Alternative:" <+> pprCoreAlt alt ]
835 mkNewTyDataConAltMsg :: Type -> CoreAlt -> Message
836 mkNewTyDataConAltMsg scrut_ty alt
837 = vcat [ text "Data alternative for newtype datacon",
838 text "Scrutinee type:" <+> ppr scrut_ty,
839 text "Alternative:" <+> pprCoreAlt alt ]
842 ------------------------------------------------------
843 -- Other error messages
845 mkAppMsg :: Type -> Type -> CoreExpr -> Message
846 mkAppMsg fun_ty arg_ty arg
847 = vcat [ptext (sLit "Argument value doesn't match argument type:"),
848 hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty),
849 hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty),
850 hang (ptext (sLit "Arg:")) 4 (ppr arg)]
852 mkNonFunAppMsg :: Type -> Type -> CoreExpr -> Message
853 mkNonFunAppMsg fun_ty arg_ty arg
854 = vcat [ptext (sLit "Non-function type in function position"),
855 hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty),
856 hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty),
857 hang (ptext (sLit "Arg:")) 4 (ppr arg)]
859 mkKindErrMsg :: TyVar -> Type -> Message
860 mkKindErrMsg tyvar arg_ty
861 = vcat [ptext (sLit "Kinds don't match in type application:"),
862 hang (ptext (sLit "Type variable:"))
863 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
864 hang (ptext (sLit "Arg type:"))
865 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
867 mkTyAppMsg :: Type -> Type -> Message
869 = vcat [text "Illegal type application:",
870 hang (ptext (sLit "Exp type:"))
871 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
872 hang (ptext (sLit "Arg type:"))
873 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
875 mkRhsMsg :: Id -> Type -> Message
878 [hsep [ptext (sLit "The type of this binder doesn't match the type of its RHS:"),
880 hsep [ptext (sLit "Binder's type:"), ppr (idType binder)],
881 hsep [ptext (sLit "Rhs type:"), ppr ty]]
883 mkRhsPrimMsg :: Id -> CoreExpr -> Message
884 mkRhsPrimMsg binder _rhs
885 = vcat [hsep [ptext (sLit "The type of this binder is primitive:"),
887 hsep [ptext (sLit "Binder's type:"), ppr (idType binder)]
890 mkStrictMsg :: Id -> Message
892 = vcat [hsep [ptext (sLit "Recursive or top-level binder has strict demand info:"),
894 hsep [ptext (sLit "Binder's demand info:"), ppr (idNewDemandInfo binder)]
897 mkArityMsg :: Id -> Message
899 = vcat [hsep [ptext (sLit "Demand type has "),
900 ppr (dmdTypeDepth dmd_ty),
901 ptext (sLit " arguments, rhs has "),
902 ppr (idArity binder),
903 ptext (sLit "arguments, "),
905 hsep [ptext (sLit "Binder's strictness signature:"), ppr dmd_ty]
908 where (StrictSig dmd_ty) = idNewStrictness binder
910 mkUnboxedTupleMsg :: Id -> Message
911 mkUnboxedTupleMsg binder
912 = vcat [hsep [ptext (sLit "A variable has unboxed tuple type:"), ppr binder],
913 hsep [ptext (sLit "Binder's type:"), ppr (idType binder)]]
915 mkCastErr :: Type -> Type -> Message
916 mkCastErr from_ty expr_ty
917 = vcat [ptext (sLit "From-type of Cast differs from type of enclosed expression"),
918 ptext (sLit "From-type:") <+> ppr from_ty,
919 ptext (sLit "Type of enclosed expr:") <+> ppr expr_ty
922 dupVars :: [[Var]] -> Message
924 = hang (ptext (sLit "Duplicate variables brought into scope"))