2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 \section[CoreLint]{A ``lint'' pass to check for Core correctness}
13 #include "HsVersions.h"
16 import CoreFVs ( idFreeVars )
17 import CoreUtils ( findDefault, exprOkForSpeculation, coreBindsSize, mkPiType )
18 import Unify ( coreRefineTys )
20 import Literal ( literalType )
21 import DataCon ( dataConRepType, isVanillaDataCon, dataConTyCon, dataConResTy, dataConWorkId )
22 import TysWiredIn ( tupleCon )
23 import Var ( Var, Id, TyVar, idType, tyVarKind, mustHaveLocalBinding )
25 import Name ( getSrcLoc )
27 import ErrUtils ( dumpIfSet_core, ghcExit, Message, showPass,
28 mkLocMessage, debugTraceMsg )
29 import SrcLoc ( SrcLoc, noSrcLoc, mkSrcSpan )
30 import Type ( Type, tyVarsOfType, coreEqType,
31 splitFunTy_maybe, mkTyVarTys,
32 splitForAllTy_maybe, splitTyConApp_maybe,
33 isUnLiftedType, typeKind,
34 isUnboxedTupleType, isSubKind,
35 substTyWith, emptyTvSubst, extendTvInScope,
36 TvSubst, TvSubstEnv, setTvSubstEnv, substTy,
37 extendTvSubst, isInScope )
38 import TyCon ( isPrimTyCon )
39 import BasicTypes ( RecFlag(..), Boxity(..), isNonRec )
44 import Util ( notNull )
51 %************************************************************************
55 %************************************************************************
57 @showPass@ and @endPass@ don't really belong here, but it makes a convenient
58 place for them. They print out stuff before and after core passes,
59 and do Core Lint when necessary.
62 endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
63 endPass dflags pass_name dump_flag binds
65 -- Report result size if required
66 -- This has the side effect of forcing the intermediate to be evaluated
67 debugTraceMsg dflags $
68 " Result size = " ++ show (coreBindsSize binds)
70 -- Report verbosely, if required
71 dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds)
74 lintCoreBindings dflags pass_name binds
80 %************************************************************************
82 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
84 %************************************************************************
86 Checks that a set of core bindings is well-formed. The PprStyle and String
87 just control what we print in the event of an error. The Bool value
88 indicates whether we have done any specialisation yet (in which case we do
93 (b) Out-of-scope type variables
94 (c) Out-of-scope local variables
97 If we have done specialisation the we check that there are
98 (a) No top-level bindings of primitive (unboxed type)
103 -- Things are *not* OK if:
105 -- * Unsaturated type app before specialisation has been done;
107 -- * Oversaturated type app after specialisation (eta reduction
108 -- may well be happening...);
111 lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
113 lintCoreBindings dflags whoDunnit binds
114 | not (dopt Opt_DoCoreLinting dflags)
117 lintCoreBindings dflags whoDunnit binds
118 = case (initL (lint_binds binds)) of
119 Nothing -> showPass dflags ("Core Linted result of " ++ whoDunnit)
120 Just bad_news -> printDump (display bad_news) >>
123 -- Put all the top-level binders in scope at the start
124 -- This is because transformation rules can bring something
125 -- into use 'unexpectedly'
126 lint_binds binds = addInScopeVars (bindersOfBinds binds) $
129 lint_bind (Rec prs) = mapM_ (lintSingleBinding Recursive) prs
130 lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
133 = vcat [ text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
135 ptext SLIT("*** Offending Program ***"),
136 pprCoreBindings binds,
137 ptext SLIT("*** End of Offense ***")
141 %************************************************************************
143 \subsection[lintUnfolding]{lintUnfolding}
145 %************************************************************************
147 We use this to check all unfoldings that come in from interfaces
148 (it is very painful to catch errors otherwise):
151 lintUnfolding :: SrcLoc
152 -> [Var] -- Treat these as in scope
154 -> Maybe Message -- Nothing => OK
156 lintUnfolding locn vars expr
157 = initL (addLoc (ImportedUnfolding locn) $
158 addInScopeVars vars $
162 %************************************************************************
164 \subsection[lintCoreBinding]{lintCoreBinding}
166 %************************************************************************
168 Check a core binding, returning the list of variables bound.
171 lintSingleBinding rec_flag (binder,rhs)
172 = addLoc (RhsOf binder) $
174 do { ty <- lintCoreExpr rhs
175 ; lintBinder binder -- Check match to RHS type
176 ; binder_ty <- applySubst binder_ty
177 ; checkTys binder_ty ty (mkRhsMsg binder ty)
178 -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
179 ; checkL (not (isUnLiftedType binder_ty)
180 || (isNonRec rec_flag && exprOkForSpeculation rhs))
181 (mkRhsPrimMsg binder rhs)
182 -- Check whether binder's specialisations contain any out-of-scope variables
183 ; mapM_ (checkBndrIdInScope binder) bndr_vars }
185 -- We should check the unfolding, if any, but this is tricky because
186 -- the unfolding is a SimplifiableCoreExpr. Give up for now.
188 binder_ty = idType binder
189 bndr_vars = varSetElems (idFreeVars binder)
192 %************************************************************************
194 \subsection[lintCoreExpr]{lintCoreExpr}
196 %************************************************************************
200 lintCoreExpr :: CoreExpr -> LintM Type
201 -- The returned type has the substitution from the monad
202 -- already applied to it:
203 -- lintCoreExpr e subst = exprType (subst e)
205 lintCoreExpr (Var var)
206 = do { checkIdInScope var
207 ; applySubst (idType var) }
209 lintCoreExpr (Lit lit)
210 = return (literalType lit)
212 lintCoreExpr (Note (Coerce to_ty from_ty) expr)
213 = do { expr_ty <- lintCoreExpr expr
214 ; to_ty <- lintTy to_ty
215 ; from_ty <- lintTy from_ty
216 ; checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty)
219 lintCoreExpr (Note other_note expr)
222 lintCoreExpr (Let (NonRec bndr rhs) body)
223 = do { lintSingleBinding NonRecursive (bndr,rhs)
224 ; addLoc (BodyOfLetRec [bndr])
225 (addInScopeVars [bndr] (lintCoreExpr body)) }
227 lintCoreExpr (Let (Rec pairs) body)
228 = addInScopeVars bndrs $
229 do { mapM (lintSingleBinding Recursive) pairs
230 ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
232 bndrs = map fst pairs
234 lintCoreExpr (App fun (Type ty))
235 -- This is like 'let' for types
236 -- It's needed when dealing with desugarer output for GADTs. Consider
237 -- data T = forall a. T a (a->Int) Bool
239 -- f (T x f True) = <e1>
240 -- f (T y g False) = <e2>
241 -- After desugaring we get
243 -- T a (x::a) (f::a->Int) (b:Bool) ->
246 -- False -> (/\b. let y=x; g=f in <e2>) a
247 -- And for a reason I now forget, the ...<e2>... can mention a; so
248 -- we want Lint to know that b=a. Ugh.
250 -- I tried quite hard to make the necessity for this go away, by changing the
251 -- desugarer, but the fundamental problem is this:
253 -- T a (x::a) (y::Int) -> let fail::a = ...
254 -- in (/\b. ...(case ... of
258 -- Now the inner case look as though it has incompatible branches.
261 go (App fun (Type ty)) tys
262 = do { go fun (ty:tys) }
263 go (Lam tv body) (ty:tys)
264 = do { checkL (isTyVar tv) (mkKindErrMsg tv ty) -- Not quite accurate
267 -- Now extend the substitution so we
268 -- take advantage of it in the body
269 ; addInScopeVars [tv] $
270 extendSubstL tv ty' $
273 = do { fun_ty <- lintCoreExpr fun
274 ; lintCoreArgs fun_ty (map Type tys) }
276 lintCoreExpr e@(App fun arg)
277 = do { ty <- lintCoreExpr fun
278 ; addLoc (AnExpr e) $
281 lintCoreExpr (Lam var expr)
282 = addLoc (LambdaBodyOf var) $
284 ; ty <- addInScopeVars [var] $
286 ; applySubst (mkPiType var ty) }
287 -- The applySubst is needed to apply the subst to var
289 lintCoreExpr e@(Case scrut var alt_ty alts) =
290 -- Check the scrutinee
291 do { scrut_ty <- lintCoreExpr scrut
292 ; alt_ty <- lintTy alt_ty
293 ; var_ty <- lintTy (idType var)
294 -- Don't use lintId on var, because unboxed tuple is legitimate
296 ; checkTys var_ty scrut_ty (mkScrutMsg var scrut_ty)
298 -- If the binder is an unboxed tuple type, don't put it in scope
299 ; let vars = if (isUnboxedTupleType (idType var)) then [] else [var]
300 ; addInScopeVars vars $
301 do { -- Check the alternatives
302 checkCaseAlts e scrut_ty alts
303 ; mapM (lintCoreAlt scrut_ty alt_ty) alts
306 lintCoreExpr e@(Type ty)
307 = addErrL (mkStrangeTyMsg e)
310 %************************************************************************
312 \subsection[lintCoreArgs]{lintCoreArgs}
314 %************************************************************************
316 The basic version of these functions checks that the argument is a
317 subtype of the required type, as one would expect.
320 lintCoreArgs :: Type -> [CoreArg] -> LintM Type
321 lintCoreArg :: Type -> CoreArg -> LintM Type
322 -- First argument has already had substitution applied to it
326 lintCoreArgs ty [] = return ty
327 lintCoreArgs ty (a : args) =
328 do { res <- lintCoreArg ty a
329 ; lintCoreArgs res args }
331 lintCoreArg ty a@(Type arg_ty) =
332 do { arg_ty <- lintTy arg_ty
333 ; lintTyApp ty arg_ty }
335 lintCoreArg fun_ty arg =
336 -- Make sure function type matches argument
337 do { arg_ty <- lintCoreExpr arg
338 ; let err = mkAppMsg fun_ty arg_ty
339 ; case splitFunTy_maybe fun_ty of
341 do { checkTys arg arg_ty err
347 -- Both args have had substitution applied
349 = case splitForAllTy_maybe ty of
350 Nothing -> addErrL (mkTyAppMsg ty arg_ty)
353 -> do { checkL (isTyVar tyvar) (mkTyAppMsg ty arg_ty)
354 ; checkKinds tyvar arg_ty
355 ; return (substTyWith [tyvar] [arg_ty] body) }
357 lintTyApps fun_ty [] = return fun_ty
359 lintTyApps fun_ty (arg_ty : arg_tys) =
360 do { fun_ty' <- lintTyApp fun_ty arg_ty
361 ; lintTyApps fun_ty' arg_tys }
363 checkKinds tyvar arg_ty
364 -- Arg type might be boxed for a function with an uncommitted
365 -- tyvar; notably this is used so that we can give
366 -- error :: forall a:*. String -> a
367 -- and then apply it to both boxed and unboxed types.
368 = checkL (argty_kind `isSubKind` tyvar_kind)
369 (mkKindErrMsg tyvar arg_ty)
371 tyvar_kind = tyVarKind tyvar
372 argty_kind = typeKind arg_ty
376 %************************************************************************
378 \subsection[lintCoreAlts]{lintCoreAlts}
380 %************************************************************************
383 checkCaseAlts :: CoreExpr -> Type -> [CoreAlt] -> LintM ()
384 -- a) Check that the alts are non-empty
385 -- b) Check that the DEFAULT comes first, if it exists
386 -- c) Check that there's a default for infinite types
387 -- NB: Algebraic cases are not necessarily exhaustive, because
388 -- the simplifer correctly eliminates case that can't
391 checkCaseAlts e ty []
392 = addErrL (mkNullAltsMsg e)
394 checkCaseAlts e ty alts =
395 do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
396 ; checkL (isJust maybe_deflt || not is_infinite_ty)
397 (nonExhaustiveAltsMsg e) }
399 (con_alts, maybe_deflt) = findDefault alts
401 non_deflt (DEFAULT, _, _) = False
404 is_infinite_ty = case splitTyConApp_maybe ty of
406 Just (tycon, tycon_arg_tys) -> isPrimTyCon tycon
410 checkAltExpr :: CoreExpr -> Type -> LintM ()
412 = do { actual_ty <- lintCoreExpr expr
413 ; ty' <- applySubst ty
414 ; checkTys actual_ty ty' (mkCaseAltMsg expr actual_ty ty') }
416 lintCoreAlt :: Type -- Type of scrutinee; a fixed point of
418 -> Type -- Type of the alternative
422 lintCoreAlt scrut_ty alt_ty alt@(DEFAULT, args, rhs) =
423 do { checkL (null args) (mkDefaultArgsMsg args)
424 ; checkAltExpr rhs alt_ty }
426 lintCoreAlt scrut_ty alt_ty alt@(LitAlt lit, args, rhs) =
427 do { checkL (null args) (mkDefaultArgsMsg args)
428 ; checkTys lit_ty scrut_ty
429 (mkBadPatMsg lit_ty scrut_ty)
430 ; checkAltExpr rhs alt_ty }
432 lit_ty = literalType lit
434 lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
435 | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty,
436 tycon == dataConTyCon con
437 = addLoc (CaseAlt alt) $
438 addInScopeVars args $ -- Put the args in scope before lintBinder,
439 -- because the Ids mention the type variables
440 if isVanillaDataCon con then
441 do { mapM lintBinder args
442 -- FIX! Add check that all args are Ids.
444 -- Scrutinee type must be a tycon applicn; checked by caller
445 -- This code is remarkably compact considering what it does!
446 -- NB: args must be in scope here so that the lintCoreArgs line works.
447 -- NB: relies on existential type args coming *after* ordinary type args
449 ; con_type <- lintTyApps (dataConRepType con) tycon_arg_tys
450 -- Can just map Var as we know that this is a vanilla datacon
451 ; con_result_ty <- lintCoreArgs con_type (map Var args)
452 ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
454 ; checkAltExpr rhs alt_ty }
457 do { let (tvs,ids) = span isTyVar args
458 pat_res_ty = dataConResTy con (mkTyVarTys tvs)
460 ; subst <- getTvSubst
461 ; case coreRefineTys tvs subst pat_res_ty scrut_ty of {
462 Nothing -> return () ; -- Alternative is dead code
463 Just senv -> updateTvSubstEnv senv $
464 do { tvs' <- mapM lintTy (mkTyVarTys tvs)
465 ; con_type <- lintTyApps (dataConRepType con) tvs'
466 ; mapM lintBinder ids -- Lint Ids in the refined world
467 ; lintCoreArgs con_type (map Var ids)
468 ; checkAltExpr rhs alt_ty
471 | otherwise -- Scrut-ty is wrong shape
472 = addErrL (mkBadAltMsg scrut_ty alt)
475 %************************************************************************
477 \subsection[lint-types]{Types}
479 %************************************************************************
482 lintBinder :: Var -> LintM ()
483 lintBinder var | isId var = lintId var >> return ()
484 | otherwise = return ()
486 lintId :: Var -> LintM Type
487 -- ToDo: lint its rules
489 = do { checkL (not (isUnboxedTupleType (idType id)))
490 (mkUnboxedTupleMsg id)
491 -- No variable can be bound to an unboxed tuple.
492 ; lintTy (idType id) }
494 lintTy :: Type -> LintM Type
495 -- Check the type, and apply the substitution to it
496 -- ToDo: check the kind structure of the type
498 = do { ty' <- applySubst ty
499 ; mapM_ checkIdInScope (varSetElems (tyVarsOfType ty'))
504 %************************************************************************
506 \subsection[lint-monad]{The Lint monad}
508 %************************************************************************
513 [LintLocInfo] -> -- Locations
514 TvSubst -> -- Current type substitution; we also use this
515 -- to keep track of all the variables in scope,
516 -- both Ids and TyVars
517 Bag Message -> -- Error messages so far
518 (Maybe a, Bag Message) } -- Result and error messages (if any)
520 instance Monad LintM where
521 return x = LintM (\ loc subst errs -> (Just x, errs))
522 fail err = LintM (\ loc subst errs -> (Nothing, addErr subst errs (text err) loc))
523 m >>= k = LintM (\ loc subst errs ->
524 let (res, errs') = unLintM m loc subst errs in
526 Just r -> unLintM (k r) loc subst errs'
527 Nothing -> (Nothing, errs'))
530 = RhsOf Id -- The variable bound
531 | LambdaBodyOf Id -- The lambda-binder
532 | BodyOfLetRec [Id] -- One of the binders
533 | CaseAlt CoreAlt -- Pattern of a case alternative
534 | AnExpr CoreExpr -- Some expression
535 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
540 initL :: LintM a -> Maybe Message {- errors -}
542 = case unLintM m [] emptyTvSubst emptyBag of
543 (_, errs) | isEmptyBag errs -> Nothing
544 | otherwise -> Just (vcat (punctuate (text "") (bagToList errs)))
548 checkL :: Bool -> Message -> LintM ()
549 checkL True msg = return ()
550 checkL False msg = addErrL msg
552 addErrL :: Message -> LintM a
553 addErrL msg = LintM (\ loc subst errs -> (Nothing, addErr subst errs msg loc))
555 addErr :: TvSubst -> Bag Message -> Message -> [LintLocInfo] -> Bag Message
556 addErr subst errs_so_far msg locs
557 = ASSERT( notNull locs )
558 errs_so_far `snocBag` mk_msg msg
560 (loc, cxt1) = dumpLoc (head locs)
561 cxts = [snd (dumpLoc loc) | loc <- locs]
562 context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$
563 ptext SLIT("Substitution:") <+> ppr subst
566 mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg)
568 addLoc :: LintLocInfo -> LintM a -> LintM a
570 LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs)
572 addInScopeVars :: [Var] -> LintM a -> LintM a
573 addInScopeVars vars m =
574 LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs)
577 updateTvSubstEnv :: TvSubstEnv -> LintM a -> LintM a
578 updateTvSubstEnv substenv m =
579 LintM (\ loc subst errs -> unLintM m loc (setTvSubstEnv subst substenv) errs)
581 getTvSubst :: LintM TvSubst
582 getTvSubst = LintM (\ loc subst errs -> (Just subst, errs))
584 applySubst :: Type -> LintM Type
585 applySubst ty = do { subst <- getTvSubst; return (substTy subst ty) }
587 extendSubstL :: TyVar -> Type -> LintM a -> LintM a
589 = LintM (\ loc subst errs -> unLintM m loc (extendTvSubst subst tv ty) errs)
593 checkIdInScope :: Var -> LintM ()
595 = do { checkL (not (id == oneTupleDataConId))
596 (ptext SLIT("Illegal one-tuple"))
597 ; checkInScope (ptext SLIT("is out of scope")) id }
599 oneTupleDataConId :: Id -- Should not happen
600 oneTupleDataConId = dataConWorkId (tupleCon Boxed 1)
602 checkBndrIdInScope :: Var -> Var -> LintM ()
603 checkBndrIdInScope binder id
604 = checkInScope msg id
606 msg = ptext SLIT("is out of scope inside info for") <+>
609 checkInScope :: SDoc -> Var -> LintM ()
610 checkInScope loc_msg var =
611 do { subst <- getTvSubst
612 ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
613 (hsep [ppr var, loc_msg]) }
615 checkTys :: Type -> Type -> Message -> LintM ()
616 -- check ty2 is subtype of ty1 (ie, has same structure but usage
617 -- annotations need only be consistent, not equal)
618 -- Assumes ty1,ty2 are have alrady had the substitution applied
619 checkTys ty1 ty2 msg = checkL (ty1 `coreEqType` ty2) msg
622 %************************************************************************
624 \subsection{Error messages}
626 %************************************************************************
630 = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))
632 dumpLoc (LambdaBodyOf b)
633 = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
635 dumpLoc (BodyOfLetRec [])
636 = (noSrcLoc, brackets (ptext SLIT("In body of a letrec with no binders")))
638 dumpLoc (BodyOfLetRec bs@(_:_))
639 = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
642 = (noSrcLoc, text "In the expression:" <+> ppr e)
644 dumpLoc (CaseAlt (con, args, rhs))
645 = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> ppr args))
647 dumpLoc (ImportedUnfolding locn)
648 = (locn, brackets (ptext SLIT("in an imported unfolding")))
650 pp_binders :: [Var] -> SDoc
651 pp_binders bs = sep (punctuate comma (map pp_binder bs))
653 pp_binder :: Var -> SDoc
654 pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)]
655 | isTyVar b = hsep [ppr b, dcolon, ppr (tyVarKind b)]
659 ------------------------------------------------------
660 -- Messages for case expressions
662 mkNullAltsMsg :: CoreExpr -> Message
664 = hang (text "Case expression with no alternatives:")
667 mkDefaultArgsMsg :: [Var] -> Message
668 mkDefaultArgsMsg args
669 = hang (text "DEFAULT case with binders")
672 mkCaseAltMsg :: CoreExpr -> Type -> Type -> Message
673 mkCaseAltMsg e ty1 ty2
674 = hang (text "Type of case alternatives not the same as the annotation on case:")
675 4 (vcat [ppr ty1, ppr ty2, ppr e])
677 mkScrutMsg :: Id -> Type -> Message
678 mkScrutMsg var scrut_ty
679 = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
680 text "Result binder type:" <+> ppr (idType var),
681 text "Scrutinee type:" <+> ppr scrut_ty]
685 = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
687 nonExhaustiveAltsMsg :: CoreExpr -> Message
688 nonExhaustiveAltsMsg e
689 = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
691 mkBadPatMsg :: Type -> Type -> Message
692 mkBadPatMsg con_result_ty scrut_ty
694 text "In a case alternative, pattern result type doesn't match scrutinee type:",
695 text "Pattern result type:" <+> ppr con_result_ty,
696 text "Scrutinee type:" <+> ppr scrut_ty
699 mkBadAltMsg :: Type -> CoreAlt -> Message
700 mkBadAltMsg scrut_ty alt
701 = vcat [ text "Data alternative when scrutinee is not a tycon application",
702 text "Scrutinee type:" <+> ppr scrut_ty,
703 text "Alternative:" <+> pprCoreAlt alt ]
705 ------------------------------------------------------
706 -- Other error messages
708 mkAppMsg :: Type -> Type -> Message
710 = vcat [ptext SLIT("Argument value doesn't match argument type:"),
711 hang (ptext SLIT("Fun type:")) 4 (ppr fun),
712 hang (ptext SLIT("Arg type:")) 4 (ppr arg)]
714 mkKindErrMsg :: TyVar -> Type -> Message
715 mkKindErrMsg tyvar arg_ty
716 = vcat [ptext SLIT("Kinds don't match in type application:"),
717 hang (ptext SLIT("Type variable:"))
718 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
719 hang (ptext SLIT("Arg type:"))
720 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
722 mkTyAppMsg :: Type -> Type -> Message
724 = vcat [text "Illegal type application:",
725 hang (ptext SLIT("Exp type:"))
726 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
727 hang (ptext SLIT("Arg type:"))
728 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
730 mkRhsMsg :: Id -> Type -> Message
733 [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
735 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
736 hsep [ptext SLIT("Rhs type:"), ppr ty]]
738 mkRhsPrimMsg :: Id -> CoreExpr -> Message
739 mkRhsPrimMsg binder rhs
740 = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
742 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
745 mkUnboxedTupleMsg :: Id -> Message
746 mkUnboxedTupleMsg binder
747 = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
748 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
750 mkCoerceErr from_ty expr_ty
751 = vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"),
752 ptext SLIT("From-type:") <+> ppr from_ty,
753 ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
757 = ptext SLIT("Type where expression expected:") <+> ppr e