2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
6 A ``lint'' pass to check for Core correctness
15 #include "HsVersions.h"
42 import Util ( notNull )
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 dflags pass_name dump_flag binds
62 -- Report result size if required
63 -- This has the side effect of forcing the intermediate to be evaluated
64 debugTraceMsg dflags 2 $
65 (text " Result size =" <+> int (coreBindsSize binds))
67 -- Report verbosely, if required
68 dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds)
71 lintCoreBindings dflags pass_name binds
77 %************************************************************************
79 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
81 %************************************************************************
83 Checks that a set of core bindings is well-formed. The PprStyle and String
84 just control what we print in the event of an error. The Bool value
85 indicates whether we have done any specialisation yet (in which case we do
90 (b) Out-of-scope type variables
91 (c) Out-of-scope local variables
94 If we have done specialisation the we check that there are
95 (a) No top-level bindings of primitive (unboxed type)
100 -- Things are *not* OK if:
102 -- * Unsaturated type app before specialisation has been done;
104 -- * Oversaturated type app after specialisation (eta reduction
105 -- may well be happening...);
110 In the desugarer, it's very very convenient to be able to say (in effect)
111 let a = Int in <body>
112 That is, use a type let. (See notes just below for why we want this.)
114 We don't have type lets in Core, so the desugarer uses type lambda
116 However, in the lambda form, we'd get lint errors from:
117 (/\a. let x::a = 4 in <body>) Int
118 because (x::a) doesn't look compatible with (4::Int).
120 So (HACK ALERT) the Lint phase does type-beta reduction "on the fly",
121 as it were. It carries a type substitution (in this example [a -> Int])
122 and applies this substitution before comparing types. The functin
123 lintTy :: Type -> LintM Type
124 returns a substituted type; that's the only reason it returns anything.
126 When we encounter a binder (like x::a) we must apply the substitution
127 to the type of the binding variable. lintBinders does this.
129 For Ids, the type-substituted Id is added to the in_scope set (which
130 itself is part of the TvSubst we are carrying down), and when we
131 find an occurence of an Id, we fetch it from the in-scope set.
136 It's needed when dealing with desugarer output for GADTs. Consider
137 data T = forall a. T a (a->Int) Bool
139 f (T x f True) = <e1>
140 f (T y g False) = <e2>
141 After desugaring we get
143 T a (x::a) (f::a->Int) (b:Bool) ->
146 False -> (/\b. let y=x; g=f in <e2>) a
147 And for a reason I now forget, the ...<e2>... can mention a; so
148 we want Lint to know that b=a. Ugh.
150 I tried quite hard to make the necessity for this go away, by changing the
151 desugarer, but the fundamental problem is this:
153 T a (x::a) (y::Int) -> let fail::a = ...
154 in (/\b. ...(case ... of
158 Now the inner case look as though it has incompatible branches.
162 lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
164 lintCoreBindings dflags whoDunnit binds
165 | not (dopt Opt_DoCoreLinting dflags)
168 lintCoreBindings dflags whoDunnit binds
169 = case (initL (lint_binds binds)) of
170 Nothing -> showPass dflags ("Core Linted result of " ++ whoDunnit)
171 Just bad_news -> printDump (display bad_news) >>
174 -- Put all the top-level binders in scope at the start
175 -- This is because transformation rules can bring something
176 -- into use 'unexpectedly'
177 lint_binds binds = addInScopeVars (bindersOfBinds binds) $
180 lint_bind (Rec prs) = mapM_ (lintSingleBinding TopLevel Recursive) prs
181 lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)
184 = vcat [ text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
186 ptext SLIT("*** Offending Program ***"),
187 pprCoreBindings binds,
188 ptext SLIT("*** End of Offense ***")
192 %************************************************************************
194 \subsection[lintUnfolding]{lintUnfolding}
196 %************************************************************************
198 We use this to check all unfoldings that come in from interfaces
199 (it is very painful to catch errors otherwise):
202 lintUnfolding :: SrcLoc
203 -> [Var] -- Treat these as in scope
205 -> Maybe Message -- Nothing => OK
207 lintUnfolding locn vars expr
208 = initL (addLoc (ImportedUnfolding locn) $
209 addInScopeVars vars $
213 %************************************************************************
215 \subsection[lintCoreBinding]{lintCoreBinding}
217 %************************************************************************
219 Check a core binding, returning the list of variables bound.
222 lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
223 = addLoc (RhsOf binder) $
225 do { ty <- lintCoreExpr rhs
226 ; lintBinder binder -- Check match to RHS type
227 ; binder_ty <- applySubst binder_ty
228 ; checkTys binder_ty ty (mkRhsMsg binder ty)
229 -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
230 ; checkL (not (isUnLiftedType binder_ty)
231 || (isNonRec rec_flag && exprOkForSpeculation rhs))
232 (mkRhsPrimMsg binder rhs)
233 -- Check that if the binder is top-level or recursive, it's not demanded
234 ; checkL (not (isStrictId binder)
235 || (isNonRec rec_flag && not (isTopLevel top_lvl_flag)))
237 -- Check whether binder's specialisations contain any out-of-scope variables
238 ; mapM_ (checkBndrIdInScope binder) bndr_vars
240 -- Check whether arity and demand type are consistent (only if demand analysis
242 ; checkL (case maybeDmdTy of
243 Just (StrictSig dmd_ty) -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs
245 (mkArityMsg binder) }
247 -- We should check the unfolding, if any, but this is tricky because
248 -- the unfolding is a SimplifiableCoreExpr. Give up for now.
250 binder_ty = idType binder
251 maybeDmdTy = idNewStrictness_maybe binder
252 bndr_vars = varSetElems (idFreeVars binder)
253 lintBinder var | isId var = lintIdBndr var $ \_ -> (return ())
254 | otherwise = return ()
257 %************************************************************************
259 \subsection[lintCoreExpr]{lintCoreExpr}
261 %************************************************************************
264 type InType = Type -- Substitution not yet applied
265 type OutType = Type -- Substitution has been applied to this
267 lintCoreExpr :: CoreExpr -> LintM OutType
268 -- The returned type has the substitution from the monad
269 -- already applied to it:
270 -- lintCoreExpr e subst = exprType (subst e)
272 lintCoreExpr (Var var)
273 = do { checkL (not (var == oneTupleDataConId))
274 (ptext SLIT("Illegal one-tuple"))
275 ; var' <- lookupIdInScope var
276 ; return (idType var')
279 lintCoreExpr (Lit lit)
280 = return (literalType lit)
282 --lintCoreExpr (Note (Coerce to_ty from_ty) expr)
283 -- = do { expr_ty <- lintCoreExpr expr
284 -- ; to_ty <- lintTy to_ty
285 -- ; from_ty <- lintTy from_ty
286 -- ; checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty)
289 lintCoreExpr (Cast expr co)
290 = do { expr_ty <- lintCoreExpr expr
292 ; let (from_ty, to_ty) = coercionKind co'
293 ; checkTys from_ty expr_ty (mkCastErr from_ty expr_ty)
296 lintCoreExpr (Note other_note expr)
299 lintCoreExpr (Let (NonRec bndr rhs) body)
300 = do { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs)
301 ; addLoc (BodyOfLetRec [bndr])
302 (lintAndScopeId bndr $ \_ -> (lintCoreExpr body)) }
304 lintCoreExpr (Let (Rec pairs) body)
305 = lintAndScopeIds bndrs $ \_ ->
306 do { mapM (lintSingleBinding NotTopLevel Recursive) pairs
307 ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
309 bndrs = map fst pairs
311 lintCoreExpr e@(App fun (Type ty))
312 -- See Note [Type let] above
313 = addLoc (AnExpr e) $
316 go (App fun (Type ty)) tys
317 = do { go fun (ty:tys) }
318 go (Lam tv body) (ty:tys)
319 = do { checkL (isTyVar tv) (mkKindErrMsg tv ty) -- Not quite accurate
321 ; let kind = tyVarKind tv
322 ; kind' <- lintTy kind
323 ; let tv' = setTyVarKind tv kind'
325 -- Now extend the substitution so we
326 -- take advantage of it in the body
327 ; addInScopeVars [tv'] $
328 extendSubstL tv' ty' $
331 = do { fun_ty <- lintCoreExpr fun
332 ; lintCoreArgs fun_ty (map Type tys) }
334 lintCoreExpr e@(App fun arg)
335 = do { fun_ty <- lintCoreExpr fun
336 ; addLoc (AnExpr e) $
337 lintCoreArg fun_ty arg }
339 lintCoreExpr (Lam var expr)
340 = addLoc (LambdaBodyOf var) $
341 lintBinders [var] $ \[var'] ->
342 do { body_ty <- lintCoreExpr expr
344 return (mkFunTy (idType var') body_ty)
346 return (mkForAllTy var' body_ty)
348 -- The applySubst is needed to apply the subst to var
350 lintCoreExpr e@(Case scrut var alt_ty alts) =
351 -- Check the scrutinee
352 do { scrut_ty <- lintCoreExpr scrut
353 ; alt_ty <- lintTy alt_ty
354 ; var_ty <- lintTy (idType var)
355 -- Don't use lintIdBndr on var, because unboxed tuple is legitimate
357 ; subst <- getTvSubst
358 ; checkTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst)
360 -- If the binder is an unboxed tuple type, don't put it in scope
361 ; let scope = if (isUnboxedTupleType (idType var)) then
363 else lintAndScopeId var
365 do { -- Check the alternatives
366 checkCaseAlts e scrut_ty alts
367 ; mapM (lintCoreAlt scrut_ty alt_ty) alts
372 lintCoreExpr e@(Type ty)
373 = addErrL (mkStrangeTyMsg e)
376 %************************************************************************
378 \subsection[lintCoreArgs]{lintCoreArgs}
380 %************************************************************************
382 The basic version of these functions checks that the argument is a
383 subtype of the required type, as one would expect.
386 lintCoreArgs :: OutType -> [CoreArg] -> LintM OutType
387 lintCoreArg :: OutType -> CoreArg -> LintM OutType
388 -- First argument has already had substitution applied to it
392 lintCoreArgs ty [] = return ty
393 lintCoreArgs ty (a : args) =
394 do { res <- lintCoreArg ty a
395 ; lintCoreArgs res args }
397 lintCoreArg fun_ty a@(Type arg_ty) =
398 do { arg_ty <- lintTy arg_ty
399 ; lintTyApp fun_ty arg_ty }
401 lintCoreArg fun_ty arg =
402 -- Make sure function type matches argument
403 do { arg_ty <- lintCoreExpr arg
404 ; let err1 = mkAppMsg fun_ty arg_ty arg
405 err2 = mkNonFunAppMsg fun_ty arg_ty arg
406 ; case splitFunTy_maybe fun_ty of
408 do { checkTys arg arg_ty err1
414 -- Both args have had substitution applied
415 lintTyApp :: OutType -> OutType -> LintM OutType
417 = case splitForAllTy_maybe ty of
418 Nothing -> addErrL (mkTyAppMsg ty arg_ty)
421 -> do { checkL (isTyVar tyvar) (mkTyAppMsg ty arg_ty)
422 ; checkKinds tyvar arg_ty
423 ; return (substTyWith [tyvar] [arg_ty] body) }
425 checkKinds tyvar arg_ty
426 -- Arg type might be boxed for a function with an uncommitted
427 -- tyvar; notably this is used so that we can give
428 -- error :: forall a:*. String -> a
429 -- and then apply it to both boxed and unboxed types.
430 = checkL (arg_kind `isSubKind` tyvar_kind)
431 (mkKindErrMsg tyvar arg_ty)
433 tyvar_kind = tyVarKind tyvar
434 arg_kind | isCoVar tyvar = coercionKindPredTy arg_ty
435 | otherwise = typeKind arg_ty
439 %************************************************************************
441 \subsection[lintCoreAlts]{lintCoreAlts}
443 %************************************************************************
446 checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
447 -- a) Check that the alts are non-empty
448 -- b1) Check that the DEFAULT comes first, if it exists
449 -- b2) Check that the others are in increasing order
450 -- c) Check that there's a default for infinite types
451 -- NB: Algebraic cases are not necessarily exhaustive, because
452 -- the simplifer correctly eliminates case that can't
455 checkCaseAlts e ty []
456 = addErrL (mkNullAltsMsg e)
458 checkCaseAlts e ty alts =
459 do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
460 ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
461 ; checkL (isJust maybe_deflt || not is_infinite_ty)
462 (nonExhaustiveAltsMsg e) }
464 (con_alts, maybe_deflt) = findDefault alts
466 -- Check that successive alternatives have increasing tags
467 increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest
468 increasing_tag other = True
470 non_deflt (DEFAULT, _, _) = False
473 is_infinite_ty = case splitTyConApp_maybe ty of
475 Just (tycon, tycon_arg_tys) -> isPrimTyCon tycon
479 checkAltExpr :: CoreExpr -> OutType -> LintM ()
480 checkAltExpr expr ann_ty
481 = do { actual_ty <- lintCoreExpr expr
482 ; checkTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) }
484 lintCoreAlt :: OutType -- Type of scrutinee
485 -> OutType -- Type of the alternative
489 lintCoreAlt scrut_ty alt_ty alt@(DEFAULT, args, rhs) =
490 do { checkL (null args) (mkDefaultArgsMsg args)
491 ; checkAltExpr rhs alt_ty }
493 lintCoreAlt scrut_ty alt_ty alt@(LitAlt lit, args, rhs) =
494 do { checkL (null args) (mkDefaultArgsMsg args)
495 ; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty)
496 ; checkAltExpr rhs alt_ty }
498 lit_ty = literalType lit
500 lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
501 | isNewTyCon (dataConTyCon con) = addErrL (mkNewTyDataConAltMsg scrut_ty alt)
502 | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty
503 = addLoc (CaseAlt alt) $ do
504 { -- First instantiate the universally quantified
505 -- type variables of the data constructor
506 -- We've already check
507 checkL (tycon == dataConTyCon con) (mkBadConMsg tycon con)
508 ; let con_payload_ty = applyTys (dataConRepType con) tycon_arg_tys
510 -- And now bring the new binders into scope
511 ; lintBinders args $ \ args -> do
512 { addLoc (CasePat alt) $ do
513 { -- Check the pattern
514 -- Scrutinee type must be a tycon applicn; checked by caller
515 -- This code is remarkably compact considering what it does!
516 -- NB: args must be in scope here so that the lintCoreArgs line works.
517 -- NB: relies on existential type args coming *after* ordinary type args
519 ; con_result_ty <- lintCoreArgs con_payload_ty (varsToCoreExprs args)
520 ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
523 ; checkAltExpr rhs alt_ty } }
525 | otherwise -- Scrut-ty is wrong shape
526 = addErrL (mkBadAltMsg scrut_ty alt)
529 %************************************************************************
531 \subsection[lint-types]{Types}
533 %************************************************************************
536 -- When we lint binders, we (one at a time and in order):
537 -- 1. Lint var types or kinds (possibly substituting)
538 -- 2. Add the binder to the in scope set, and if its a coercion var,
539 -- we may extend the substitution to reflect its (possibly) new kind
540 lintBinders :: [Var] -> ([Var] -> LintM a) -> LintM a
541 lintBinders [] linterF = linterF []
542 lintBinders (var:vars) linterF = lintBinder var $ \var' ->
543 lintBinders vars $ \ vars' ->
546 lintBinder :: Var -> (Var -> LintM a) -> LintM a
547 lintBinder var linterF
548 | isTyVar var = lint_ty_bndr
549 | otherwise = lintIdBndr var linterF
551 lint_ty_bndr = do { lintTy (tyVarKind var)
552 ; subst <- getTvSubst
553 ; let (subst', tv') = substTyVarBndr subst var
554 ; updateTvSubst subst' (linterF tv') }
556 lintIdBndr :: Var -> (Var -> LintM a) -> LintM a
557 -- Do substitution on the type of a binder and add the var with this
558 -- new type to the in-scope set of the second argument
559 -- ToDo: lint its rules
560 lintIdBndr id linterF
561 = do { checkL (not (isUnboxedTupleType (idType id)))
562 (mkUnboxedTupleMsg id)
563 -- No variable can be bound to an unboxed tuple.
564 ; lintAndScopeId id $ \id' -> linterF id'
567 lintAndScopeIds :: [Var] -> ([Var] -> LintM a) -> LintM a
568 lintAndScopeIds ids linterF
572 go (id:ids) = do { lintAndScopeId id $ \id ->
573 lintAndScopeIds ids $ \ids ->
576 lintAndScopeId :: Var -> (Var -> LintM a) -> LintM a
577 lintAndScopeId id linterF
578 = do { ty <- lintTy (idType id)
579 ; let id' = Var.setIdType id ty
580 ; addInScopeVars [id'] $ (linterF id')
583 lintTy :: InType -> LintM OutType
584 -- Check the type, and apply the substitution to it
585 -- ToDo: check the kind structure of the type
587 = do { ty' <- applySubst ty
588 ; mapM_ checkTyVarInScope (varSetElems (tyVarsOfType ty'))
593 %************************************************************************
595 \subsection[lint-monad]{The Lint monad}
597 %************************************************************************
602 [LintLocInfo] -> -- Locations
603 TvSubst -> -- Current type substitution; we also use this
604 -- to keep track of all the variables in scope,
605 -- both Ids and TyVars
606 Bag Message -> -- Error messages so far
607 (Maybe a, Bag Message) } -- Result and error messages (if any)
609 {- Note [Type substitution]
610 ~~~~~~~~~~~~~~~~~~~~~~~~
611 Why do we need a type substitution? Consider
612 /\(a:*). \(x:a). /\(a:*). id a x
613 This is ill typed, because (renaming variables) it is really
614 /\(a:*). \(x:a). /\(b:*). id b x
615 Hence, when checking an application, we can't naively compare x's type
616 (at its binding site) with its expected type (at a use site). So we
617 rename type binders as we go, maintaining a substitution.
619 The same substitution also supports let-type, current expressed as
621 Here we substitute 'ty' for 'a' in 'body', on the fly.
624 instance Monad LintM where
625 return x = LintM (\ loc subst errs -> (Just x, errs))
626 fail err = LintM (\ loc subst errs -> (Nothing, addErr subst errs (text err) loc))
627 m >>= k = LintM (\ loc subst errs ->
628 let (res, errs') = unLintM m loc subst errs in
630 Just r -> unLintM (k r) loc subst errs'
631 Nothing -> (Nothing, errs'))
634 = RhsOf Id -- The variable bound
635 | LambdaBodyOf Id -- The lambda-binder
636 | BodyOfLetRec [Id] -- One of the binders
637 | CaseAlt CoreAlt -- Case alternative
638 | CasePat CoreAlt -- *Pattern* of the case alternative
639 | AnExpr CoreExpr -- Some expression
640 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
645 initL :: LintM a -> Maybe Message {- errors -}
647 = case unLintM m [] emptyTvSubst emptyBag of
648 (_, errs) | isEmptyBag errs -> Nothing
649 | otherwise -> Just (vcat (punctuate (text "") (bagToList errs)))
653 checkL :: Bool -> Message -> LintM ()
654 checkL True msg = return ()
655 checkL False msg = addErrL msg
657 addErrL :: Message -> LintM a
658 addErrL msg = LintM (\ loc subst errs -> (Nothing, addErr subst errs msg loc))
660 addErr :: TvSubst -> Bag Message -> Message -> [LintLocInfo] -> Bag Message
661 addErr subst errs_so_far msg locs
662 = ASSERT( notNull locs )
663 errs_so_far `snocBag` mk_msg msg
665 (loc, cxt1) = dumpLoc (head locs)
666 cxts = [snd (dumpLoc loc) | loc <- locs]
667 context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$
668 ptext SLIT("Substitution:") <+> ppr subst
671 mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg)
673 addLoc :: LintLocInfo -> LintM a -> LintM a
675 LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs)
677 addInScopeVars :: [Var] -> LintM a -> LintM a
678 addInScopeVars vars m =
679 LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs)
681 updateTvSubst :: TvSubst -> LintM a -> LintM a
682 updateTvSubst subst' m =
683 LintM (\ loc subst errs -> unLintM m loc subst' errs)
685 getTvSubst :: LintM TvSubst
686 getTvSubst = LintM (\ loc subst errs -> (Just subst, errs))
688 applySubst :: Type -> LintM Type
689 applySubst ty = do { subst <- getTvSubst; return (substTy subst ty) }
691 extendSubstL :: TyVar -> Type -> LintM a -> LintM a
693 = LintM (\ loc subst errs -> unLintM m loc (extendTvSubst subst tv ty) errs)
697 lookupIdInScope :: Id -> LintM Id
699 | not (mustHaveLocalBinding id)
700 = return id -- An imported Id
702 = do { subst <- getTvSubst
703 ; case lookupInScope (getTvInScope subst) id of
705 Nothing -> do { addErrL out_of_scope
708 out_of_scope = ppr id <+> ptext SLIT("is out of scope")
711 oneTupleDataConId :: Id -- Should not happen
712 oneTupleDataConId = dataConWorkId (tupleCon Boxed 1)
714 checkBndrIdInScope :: Var -> Var -> LintM ()
715 checkBndrIdInScope binder id
716 = checkInScope msg id
718 msg = ptext SLIT("is out of scope inside info for") <+>
721 checkTyVarInScope :: TyVar -> LintM ()
722 checkTyVarInScope tv = checkInScope (ptext SLIT("is out of scope")) tv
724 checkInScope :: SDoc -> Var -> LintM ()
725 checkInScope loc_msg var =
726 do { subst <- getTvSubst
727 ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
728 (hsep [ppr var, loc_msg]) }
730 checkTys :: Type -> Type -> Message -> LintM ()
731 -- check ty2 is subtype of ty1 (ie, has same structure but usage
732 -- annotations need only be consistent, not equal)
733 -- Assumes ty1,ty2 are have alrady had the substitution applied
734 checkTys ty1 ty2 msg = checkL (ty1 `coreEqType` ty2) msg
737 %************************************************************************
739 \subsection{Error messages}
741 %************************************************************************
745 = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))
747 dumpLoc (LambdaBodyOf b)
748 = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
750 dumpLoc (BodyOfLetRec [])
751 = (noSrcLoc, brackets (ptext SLIT("In body of a letrec with no binders")))
753 dumpLoc (BodyOfLetRec bs@(_:_))
754 = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
757 = (noSrcLoc, text "In the expression:" <+> ppr e)
759 dumpLoc (CaseAlt (con, args, rhs))
760 = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args))
762 dumpLoc (CasePat (con, args, rhs))
763 = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args))
765 dumpLoc (ImportedUnfolding locn)
766 = (locn, brackets (ptext SLIT("in an imported unfolding")))
768 pp_binders :: [Var] -> SDoc
769 pp_binders bs = sep (punctuate comma (map pp_binder bs))
771 pp_binder :: Var -> SDoc
772 pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)]
773 | isTyVar b = hsep [ppr b, dcolon, ppr (tyVarKind b)]
777 ------------------------------------------------------
778 -- Messages for case expressions
780 mkNullAltsMsg :: CoreExpr -> Message
782 = hang (text "Case expression with no alternatives:")
785 mkDefaultArgsMsg :: [Var] -> Message
786 mkDefaultArgsMsg args
787 = hang (text "DEFAULT case with binders")
790 mkCaseAltMsg :: CoreExpr -> Type -> Type -> Message
791 mkCaseAltMsg e ty1 ty2
792 = hang (text "Type of case alternatives not the same as the annotation on case:")
793 4 (vcat [ppr ty1, ppr ty2, ppr e])
795 mkScrutMsg :: Id -> Type -> Type -> TvSubst -> Message
796 mkScrutMsg var var_ty scrut_ty subst
797 = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
798 text "Result binder type:" <+> ppr var_ty,--(idType var),
799 text "Scrutinee type:" <+> ppr scrut_ty,
800 hsep [ptext SLIT("Current TV subst"), ppr subst]]
803 = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
804 mkNonIncreasingAltsMsg e
805 = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)
807 nonExhaustiveAltsMsg :: CoreExpr -> Message
808 nonExhaustiveAltsMsg e
809 = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
811 mkBadConMsg :: TyCon -> DataCon -> Message
812 mkBadConMsg tycon datacon
814 text "In a case alternative, data constructor isn't in scrutinee type:",
815 text "Scrutinee type constructor:" <+> ppr tycon,
816 text "Data con:" <+> ppr datacon
819 mkBadPatMsg :: Type -> Type -> Message
820 mkBadPatMsg con_result_ty scrut_ty
822 text "In a case alternative, pattern result type doesn't match scrutinee type:",
823 text "Pattern result type:" <+> ppr con_result_ty,
824 text "Scrutinee type:" <+> ppr scrut_ty
827 mkBadAltMsg :: Type -> CoreAlt -> Message
828 mkBadAltMsg scrut_ty alt
829 = vcat [ text "Data alternative when scrutinee is not a tycon application",
830 text "Scrutinee type:" <+> ppr scrut_ty,
831 text "Alternative:" <+> pprCoreAlt alt ]
833 mkNewTyDataConAltMsg :: Type -> CoreAlt -> Message
834 mkNewTyDataConAltMsg scrut_ty alt
835 = vcat [ text "Data alternative for newtype datacon",
836 text "Scrutinee type:" <+> ppr scrut_ty,
837 text "Alternative:" <+> pprCoreAlt alt ]
840 ------------------------------------------------------
841 -- Other error messages
843 mkAppMsg :: Type -> Type -> CoreExpr -> Message
844 mkAppMsg fun_ty arg_ty arg
845 = vcat [ptext SLIT("Argument value doesn't match argument type:"),
846 hang (ptext SLIT("Fun type:")) 4 (ppr fun_ty),
847 hang (ptext SLIT("Arg type:")) 4 (ppr arg_ty),
848 hang (ptext SLIT("Arg:")) 4 (ppr arg)]
850 mkNonFunAppMsg :: Type -> Type -> CoreExpr -> Message
851 mkNonFunAppMsg fun_ty arg_ty arg
852 = vcat [ptext SLIT("Non-function type in function position"),
853 hang (ptext SLIT("Fun type:")) 4 (ppr fun_ty),
854 hang (ptext SLIT("Arg type:")) 4 (ppr arg_ty),
855 hang (ptext SLIT("Arg:")) 4 (ppr arg)]
857 mkKindErrMsg :: TyVar -> Type -> Message
858 mkKindErrMsg tyvar arg_ty
859 = vcat [ptext SLIT("Kinds don't match in type application:"),
860 hang (ptext SLIT("Type variable:"))
861 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
862 hang (ptext SLIT("Arg type:"))
863 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
865 mkTyAppMsg :: Type -> Type -> Message
867 = vcat [text "Illegal type application:",
868 hang (ptext SLIT("Exp type:"))
869 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
870 hang (ptext SLIT("Arg type:"))
871 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
873 mkRhsMsg :: Id -> Type -> Message
876 [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
878 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
879 hsep [ptext SLIT("Rhs type:"), ppr ty]]
881 mkRhsPrimMsg :: Id -> CoreExpr -> Message
882 mkRhsPrimMsg binder rhs
883 = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
885 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
888 mkStrictMsg :: Id -> Message
890 = vcat [hsep [ptext SLIT("Recursive or top-level binder has strict demand info:"),
892 hsep [ptext SLIT("Binder's demand info:"), ppr (idNewDemandInfo binder)]
895 mkArityMsg :: Id -> Message
897 = vcat [hsep [ptext SLIT("Demand type has "),
898 ppr (dmdTypeDepth dmd_ty),
899 ptext SLIT(" arguments, rhs has "),
900 ppr (idArity binder),
901 ptext SLIT("arguments, "),
903 hsep [ptext SLIT("Binder's strictness signature:"), ppr dmd_ty]
906 where (StrictSig dmd_ty) = idNewStrictness binder
908 mkUnboxedTupleMsg :: Id -> Message
909 mkUnboxedTupleMsg binder
910 = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
911 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
913 mkCastErr from_ty expr_ty
914 = vcat [ptext SLIT("From-type of Cast differs from type of enclosed expression"),
915 ptext SLIT("From-type:") <+> ppr from_ty,
916 ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
920 = ptext SLIT("Type where expression expected:") <+> ppr e