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 )
22 import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId, mustHaveLocalBinding )
24 import Name ( getSrcLoc )
26 import ErrUtils ( dumpIfSet_core, ghcExit, Message, showPass,
27 mkLocMessage, debugTraceMsg )
28 import SrcLoc ( SrcLoc, noSrcLoc, mkSrcSpan )
29 import Type ( Type, tyVarsOfType, eqType,
31 splitForAllTy_maybe, splitTyConApp_maybe,
32 isUnLiftedType, typeKind,
33 isUnboxedTupleType, isSubKind,
34 substTyWith, emptyTvSubst, extendTvInScope,
35 TvSubst, TvSubstEnv, setTvSubstEnv, substTy,
36 extendTvSubst, isInScope )
37 import TyCon ( isPrimTyCon, TyCon )
38 import BasicTypes ( RecFlag(..), isNonRec )
43 import Util ( notNull )
50 %************************************************************************
54 %************************************************************************
56 @showPass@ and @endPass@ don't really belong here, but it makes a convenient
57 place for them. They print out stuff before and after core passes,
58 and do Core Lint when necessary.
61 endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
62 endPass dflags pass_name dump_flag binds
64 -- Report result size if required
65 -- This has the side effect of forcing the intermediate to be evaluated
66 debugTraceMsg dflags $
67 " Result size = " ++ show (coreBindsSize binds)
69 -- Report verbosely, if required
70 dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds)
73 lintCoreBindings dflags pass_name binds
79 %************************************************************************
81 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
83 %************************************************************************
85 Checks that a set of core bindings is well-formed. The PprStyle and String
86 just control what we print in the event of an error. The Bool value
87 indicates whether we have done any specialisation yet (in which case we do
92 (b) Out-of-scope type variables
93 (c) Out-of-scope local variables
96 If we have done specialisation the we check that there are
97 (a) No top-level bindings of primitive (unboxed type)
102 -- Things are *not* OK if:
104 -- * Unsaturated type app before specialisation has been done;
106 -- * Oversaturated type app after specialisation (eta reduction
107 -- may well be happening...);
110 lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
112 lintCoreBindings dflags whoDunnit binds
113 | not (dopt Opt_DoCoreLinting dflags)
116 lintCoreBindings dflags whoDunnit binds
117 = case (initL (lint_binds binds)) of
118 Nothing -> showPass dflags ("Core Linted result of " ++ whoDunnit)
119 Just bad_news -> printDump (display bad_news) >>
122 -- Put all the top-level binders in scope at the start
123 -- This is because transformation rules can bring something
124 -- into use 'unexpectedly'
125 lint_binds binds = addInScopeVars (bindersOfBinds binds) $
128 lint_bind (Rec prs) = mapM_ (lintSingleBinding Recursive) prs
129 lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
132 = vcat [ text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
134 ptext SLIT("*** Offending Program ***"),
135 pprCoreBindings binds,
136 ptext SLIT("*** End of Offense ***")
140 %************************************************************************
142 \subsection[lintUnfolding]{lintUnfolding}
144 %************************************************************************
146 We use this to check all unfoldings that come in from interfaces
147 (it is very painful to catch errors otherwise):
150 lintUnfolding :: SrcLoc
151 -> [Var] -- Treat these as in scope
153 -> Maybe Message -- Nothing => OK
155 lintUnfolding locn vars expr
156 = initL (addLoc (ImportedUnfolding locn) $
157 addInScopeVars vars $
161 %************************************************************************
163 \subsection[lintCoreBinding]{lintCoreBinding}
165 %************************************************************************
167 Check a core binding, returning the list of variables bound.
170 lintSingleBinding rec_flag (binder,rhs)
171 = addLoc (RhsOf binder) $
173 do { ty <- lintCoreExpr rhs
174 ; lintBinder binder -- Check match to RHS type
175 ; binder_ty <- applySubst binder_ty
176 ; checkTys binder_ty ty (mkRhsMsg binder ty)
177 -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
178 ; checkL (not (isUnLiftedType binder_ty)
179 || (isNonRec rec_flag && exprOkForSpeculation rhs))
180 (mkRhsPrimMsg binder rhs)
181 -- Check whether binder's specialisations contain any out-of-scope variables
182 ; mapM_ (checkBndrIdInScope binder) bndr_vars }
184 -- We should check the unfolding, if any, but this is tricky because
185 -- the unfolding is a SimplifiableCoreExpr. Give up for now.
187 binder_ty = idType binder
188 bndr_vars = varSetElems (idFreeVars binder)
191 %************************************************************************
193 \subsection[lintCoreExpr]{lintCoreExpr}
195 %************************************************************************
199 lintCoreExpr :: CoreExpr -> LintM Type
200 -- The returned type has the substitution from the monad
201 -- already applied to it:
202 -- lintCoreExpr e subst = exprTpye (subst e)
204 lintCoreExpr (Var var)
205 = do { checkIdInScope var
206 ; applySubst (idType var) }
208 lintCoreExpr (Lit lit)
209 = return (literalType lit)
211 lintCoreExpr (Note (Coerce to_ty from_ty) expr)
212 = do { expr_ty <- lintCoreExpr expr
213 ; to_ty <- lintTy to_ty
214 ; from_ty <- lintTy from_ty
215 ; checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty)
218 lintCoreExpr (Note other_note expr)
221 lintCoreExpr (Let (NonRec bndr rhs) body)
222 = do { lintSingleBinding NonRecursive (bndr,rhs)
223 ; addLoc (BodyOfLetRec [bndr])
224 (addInScopeVars [bndr] (lintCoreExpr body)) }
226 lintCoreExpr (Let (Rec pairs) body)
227 = addInScopeVars bndrs $
228 do { mapM (lintSingleBinding Recursive) pairs
229 ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
231 bndrs = map fst pairs
233 lintCoreExpr (App fun (Type ty))
234 -- This is like 'let' for types
235 -- It's needed when dealing with desugarer output for GADTs. Consider
236 -- data T = forall a. T a (a->Int) Bool
238 -- f (T x f True) = <e1>
239 -- f (T y g False) = <e2>
240 -- After desugaring we get
242 -- T a (x::a) (f::a->Int) (b:Bool) ->
245 -- False -> (/\b. let y=x; g=f in <e2>) a
246 -- And for a reason I now forget, the ...<e2>... can mention a; so
247 -- we want Lint to know that b=a. Ugh.
249 -- I tried quite hard to make the necessity for this go away, by changing the
250 -- desugarer, but the fundamental problem is this:
252 -- T a (x::a) (y::Int) -> let fail::a = ...
253 -- in (/\b. ...(case ... of
257 -- Now the inner case look as though it has incompatible branches.
260 go (App fun (Type ty)) tys
261 = do { go fun (ty:tys) }
262 go (Lam tv body) (ty:tys)
263 = do { checkL (isTyVar tv) (mkKindErrMsg tv ty) -- Not quite accurate
266 -- Now extend the substitution so we
267 -- take advantage of it in the body
268 ; addInScopeVars [tv] $
269 extendSubstL tv ty' $
272 = do { fun_ty <- lintCoreExpr fun
273 ; lintCoreArgs fun_ty (map Type tys) }
275 lintCoreExpr e@(App fun arg)
276 = do { ty <- lintCoreExpr fun
277 ; addLoc (AnExpr e) $
280 lintCoreExpr (Lam var expr)
281 = addLoc (LambdaBodyOf var) $
283 ; ty <- addInScopeVars [var] $
285 ; applySubst (mkPiType var ty) }
286 -- The applySubst is needed to apply the subst to var
288 lintCoreExpr e@(Case scrut var alt_ty alts) =
289 -- Check the scrutinee
290 do { scrut_ty <- lintCoreExpr scrut
291 ; alt_ty <- lintTy alt_ty
292 ; var_ty <- lintTy (idType var)
293 -- Don't use lintId on var, because unboxed tuple is legitimate
295 ; checkTys var_ty scrut_ty (mkScrutMsg var scrut_ty)
297 -- If the binder is an unboxed tuple type, don't put it in scope
298 ; let vars = if (isUnboxedTupleType (idType var)) then [] else [var]
299 ; addInScopeVars vars $
300 do { -- Check the alternatives
301 checkCaseAlts e scrut_ty alts
302 ; mapM (lintCoreAlt scrut_ty alt_ty) alts
305 lintCoreExpr e@(Type ty)
306 = addErrL (mkStrangeTyMsg e)
309 %************************************************************************
311 \subsection[lintCoreArgs]{lintCoreArgs}
313 %************************************************************************
315 The basic version of these functions checks that the argument is a
316 subtype of the required type, as one would expect.
319 lintCoreArgs :: Type -> [CoreArg] -> LintM Type
320 lintCoreArg :: Type -> CoreArg -> LintM Type
321 -- First argument has already had substitution applied to it
325 lintCoreArgs ty [] = return ty
326 lintCoreArgs ty (a : args) =
327 do { res <- lintCoreArg ty a
328 ; lintCoreArgs res args }
330 lintCoreArg ty a@(Type arg_ty) =
331 do { arg_ty <- lintTy arg_ty
332 ; lintTyApp ty arg_ty }
334 lintCoreArg fun_ty arg =
335 -- Make sure function type matches argument
336 do { arg_ty <- lintCoreExpr arg
337 ; let err = mkAppMsg fun_ty arg_ty
338 ; case splitFunTy_maybe fun_ty of
340 do { checkTys arg arg_ty err
346 -- Both args have had substitution applied
348 = case splitForAllTy_maybe ty of
349 Nothing -> addErrL (mkTyAppMsg ty arg_ty)
352 -> do { checkL (isTyVar tyvar) (mkTyAppMsg ty arg_ty)
353 ; checkKinds tyvar arg_ty
354 ; return (substTyWith [tyvar] [arg_ty] body) }
356 lintTyApps fun_ty [] = return fun_ty
358 lintTyApps fun_ty (arg_ty : arg_tys) =
359 do { fun_ty' <- lintTyApp fun_ty arg_ty
360 ; lintTyApps fun_ty' arg_tys }
362 checkKinds tyvar arg_ty
363 -- Arg type might be boxed for a function with an uncommitted
364 -- tyvar; notably this is used so that we can give
365 -- error :: forall a:*. String -> a
366 -- and then apply it to both boxed and unboxed types.
367 = checkL (argty_kind `isSubKind` tyvar_kind)
368 (mkKindErrMsg tyvar arg_ty)
370 tyvar_kind = tyVarKind tyvar
371 argty_kind = typeKind arg_ty
375 %************************************************************************
377 \subsection[lintCoreAlts]{lintCoreAlts}
379 %************************************************************************
382 checkCaseAlts :: CoreExpr -> Type -> [CoreAlt] -> LintM ()
383 -- a) Check that the alts are non-empty
384 -- b) Check that the DEFAULT comes first, if it exists
385 -- c) Check that there's a default for infinite types
386 -- NB: Algebraic cases are not necessarily exhaustive, because
387 -- the simplifer correctly eliminates case that can't
390 checkCaseAlts e ty []
391 = addErrL (mkNullAltsMsg e)
393 checkCaseAlts e ty alts =
394 do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
395 ; checkL (isJust maybe_deflt || not is_infinite_ty)
396 (nonExhaustiveAltsMsg e) }
398 (con_alts, maybe_deflt) = findDefault alts
400 non_deflt (DEFAULT, _, _) = False
403 is_infinite_ty = case splitTyConApp_maybe ty of
405 Just (tycon, tycon_arg_tys) -> isPrimTyCon tycon
409 checkAltExpr :: CoreExpr -> Type -> LintM ()
411 = do { actual_ty <- lintCoreExpr expr
412 ; ty' <- applySubst ty
413 ; checkTys actual_ty ty' (mkCaseAltMsg expr actual_ty ty') }
415 lintCoreAlt :: Type -- Type of scrutinee
416 -> Type -- Type of the alternative
420 lintCoreAlt scrut_ty alt_ty alt@(DEFAULT, args, rhs) =
421 do { checkL (null args) (mkDefaultArgsMsg args)
422 ; checkAltExpr rhs alt_ty }
424 lintCoreAlt scrut_ty alt_ty alt@(LitAlt lit, args, rhs) =
425 do { checkL (null args) (mkDefaultArgsMsg args)
426 ; checkTys lit_ty scrut_ty
427 (mkBadPatMsg lit_ty scrut_ty)
428 ; checkAltExpr rhs alt_ty }
430 lit_ty = literalType lit
432 lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
433 | isVanillaDataCon con
434 = addLoc (CaseAlt alt) $
435 addInScopeVars args $
436 do { mapM lintBinder args
437 -- FIX! Add check that all args are Ids.
439 -- Scrutinee type must be a tycon applicn; checked by caller
440 -- This code is remarkably compact considering what it does!
441 -- NB: args must be in scope here so that the lintCoreArgs line works.
442 -- NB: relies on existential type args coming *after* ordinary type args
444 ; case splitTyConApp_maybe scrut_ty of {
445 Just (tycon, tycon_arg_tys) ->
446 do { con_type <- lintTyApps (dataConRepType con) tycon_arg_tys
447 -- Can just map Var as we know that this is a vanilla datacon
448 ; con_result_ty <- lintCoreArgs con_type (map Var args)
449 ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
451 ; checkAltExpr rhs alt_ty } ;
452 Nothing -> addErrL (mkBadAltMsg scrut_ty alt)
456 = addLoc (CaseAlt alt) $
457 addInScopeVars args $ -- Put the args in scope before lintBinder, because
458 -- the Ids mention the type variables
459 do { mapM lintBinder args
460 ; case splitTyConApp_maybe scrut_ty of {
461 Nothing -> addErrL (mkBadAltMsg scrut_ty alt) ;
462 Just (tycon, tycon_args_tys) ->
463 do { checkL (tycon == dataConTyCon con) (mkIncTyconMsg tycon alt)
464 ; pat_res_ty <- lintCoreArgs (dataConRepType con) (map varToCoreExpr args)
465 ; subst <- getTvSubst
466 ; case coreRefineTys args subst pat_res_ty scrut_ty of
467 Just senv -> updateTvSubstEnv senv (checkAltExpr rhs alt_ty)
468 Nothing -> return () -- Alternative is dead code
472 %************************************************************************
474 \subsection[lint-types]{Types}
476 %************************************************************************
479 lintBinder :: Var -> LintM ()
480 lintBinder var | isId var = lintId var >> return ()
481 | otherwise = return ()
483 lintId :: Var -> LintM Type
484 -- ToDo: lint its rules
486 = do { checkL (not (isUnboxedTupleType (idType id)))
487 (mkUnboxedTupleMsg id)
488 -- No variable can be bound to an unboxed tuple.
489 ; lintTy (idType id) }
491 lintTy :: Type -> LintM Type
492 -- Check the type, and apply the substitution to it
493 -- ToDo: check the kind structure of the type
495 = do { ty' <- applySubst ty
496 ; mapM_ checkIdInScope (varSetElems (tyVarsOfType ty'))
501 %************************************************************************
503 \subsection[lint-monad]{The Lint monad}
505 %************************************************************************
510 [LintLocInfo] -> -- Locations
511 TvSubst -> -- Current type substitution; we also use this
512 -- to keep track of all the variables in scope,
513 -- both Ids and TyVars
514 Bag Message -> -- Error messages so far
515 (Maybe a, Bag Message) } -- Result and error messages (if any)
517 instance Monad LintM where
518 return x = LintM (\ loc subst errs -> (Just x, errs))
519 fail err = LintM (\ loc subst errs -> (Nothing, addErr subst errs (text err) loc))
520 m >>= k = LintM (\ loc subst errs ->
521 let (res, errs') = unLintM m loc subst errs in
523 Just r -> unLintM (k r) loc subst errs'
524 Nothing -> (Nothing, errs'))
527 = RhsOf Id -- The variable bound
528 | LambdaBodyOf Id -- The lambda-binder
529 | BodyOfLetRec [Id] -- One of the binders
530 | CaseAlt CoreAlt -- Pattern of a case alternative
531 | AnExpr CoreExpr -- Some expression
532 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
537 initL :: LintM a -> Maybe Message {- errors -}
539 = case unLintM m [] emptyTvSubst emptyBag of
540 (_, errs) | isEmptyBag errs -> Nothing
541 | otherwise -> Just (vcat (punctuate (text "") (bagToList errs)))
545 checkL :: Bool -> Message -> LintM ()
546 checkL True msg = return ()
547 checkL False msg = addErrL msg
549 addErrL :: Message -> LintM a
550 addErrL msg = LintM (\ loc subst errs -> (Nothing, addErr subst errs msg loc))
552 addErr :: TvSubst -> Bag Message -> Message -> [LintLocInfo] -> Bag Message
553 addErr subst errs_so_far msg locs
554 = ASSERT( notNull locs )
555 errs_so_far `snocBag` mk_msg msg
557 (loc, cxt1) = dumpLoc (head locs)
558 cxts = [snd (dumpLoc loc) | loc <- locs]
559 context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$
560 ptext SLIT("Substitution:") <+> ppr subst
563 mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg)
565 addLoc :: LintLocInfo -> LintM a -> LintM a
567 LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs)
569 addInScopeVars :: [Var] -> LintM a -> LintM a
570 addInScopeVars vars m =
571 LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs)
574 updateTvSubstEnv :: TvSubstEnv -> LintM a -> LintM a
575 updateTvSubstEnv substenv m =
576 LintM (\ loc subst errs -> unLintM m loc (setTvSubstEnv subst substenv) errs)
578 getTvSubst :: LintM TvSubst
579 getTvSubst = LintM (\ loc subst errs -> (Just subst, errs))
581 applySubst :: Type -> LintM Type
582 applySubst ty = do { subst <- getTvSubst; return (substTy subst ty) }
584 extendSubstL :: TyVar -> Type -> LintM a -> LintM a
586 = LintM (\ loc subst errs -> unLintM m loc (extendTvSubst subst tv ty) errs)
590 checkIdInScope :: Var -> LintM ()
592 = checkInScope (ptext SLIT("is out of scope")) id
594 checkBndrIdInScope :: Var -> Var -> LintM ()
595 checkBndrIdInScope binder id
596 = checkInScope msg id
598 msg = ptext SLIT("is out of scope inside info for") <+>
601 checkInScope :: SDoc -> Var -> LintM ()
602 checkInScope loc_msg var =
603 do { subst <- getTvSubst
604 ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
605 (hsep [ppr var, loc_msg]) }
607 checkTys :: Type -> Type -> Message -> LintM ()
608 -- check ty2 is subtype of ty1 (ie, has same structure but usage
609 -- annotations need only be consistent, not equal)
610 -- Assumes ty1,ty2 are have alrady had the substitution applied
611 checkTys ty1 ty2 msg = checkL (ty1 `eqType` ty2) msg
614 %************************************************************************
616 \subsection{Error messages}
618 %************************************************************************
622 = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))
624 dumpLoc (LambdaBodyOf b)
625 = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
627 dumpLoc (BodyOfLetRec [])
628 = (noSrcLoc, brackets (ptext SLIT("In body of a letrec with no binders")))
630 dumpLoc (BodyOfLetRec bs@(_:_))
631 = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
634 = (noSrcLoc, text "In the expression:" <+> ppr e)
636 dumpLoc (CaseAlt (con, args, rhs))
637 = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> ppr args))
639 dumpLoc (ImportedUnfolding locn)
640 = (locn, brackets (ptext SLIT("in an imported unfolding")))
642 pp_binders :: [Var] -> SDoc
643 pp_binders bs = sep (punctuate comma (map pp_binder bs))
645 pp_binder :: Var -> SDoc
646 pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)]
647 | isTyVar b = hsep [ppr b, dcolon, ppr (tyVarKind b)]
651 ------------------------------------------------------
652 -- Messages for case expressions
654 mkNullAltsMsg :: CoreExpr -> Message
656 = hang (text "Case expression with no alternatives:")
659 mkDefaultArgsMsg :: [Var] -> Message
660 mkDefaultArgsMsg args
661 = hang (text "DEFAULT case with binders")
664 mkCaseAltMsg :: CoreExpr -> Type -> Type -> Message
665 mkCaseAltMsg e ty1 ty2
666 = hang (text "Type of case alternatives not the same as the annotation on case:")
667 4 (vcat [ppr ty1, ppr ty2, ppr e])
669 mkScrutMsg :: Id -> Type -> Message
670 mkScrutMsg var scrut_ty
671 = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
672 text "Result binder type:" <+> ppr (idType var),
673 text "Scrutinee type:" <+> ppr scrut_ty]
677 = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
679 nonExhaustiveAltsMsg :: CoreExpr -> Message
680 nonExhaustiveAltsMsg e
681 = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
683 mkBadPatMsg :: Type -> Type -> Message
684 mkBadPatMsg con_result_ty scrut_ty
686 text "In a case alternative, pattern result type doesn't match scrutinee type:",
687 text "Pattern result type:" <+> ppr con_result_ty,
688 text "Scrutinee type:" <+> ppr scrut_ty
691 mkBadAltMsg :: Type -> CoreAlt -> Message
692 mkBadAltMsg scrut_ty alt
693 = vcat [ text "Data alternative when scrutinee is not a tycon application",
694 text "Scrutinee type:" <+> ppr scrut_ty,
695 text "Alternative:" <+> pprCoreAlt alt ]
697 mkIncTyconMsg :: TyCon -> CoreAlt -> Message
698 mkIncTyconMsg tycon1 alt@(DataAlt con,_,_)
699 = vcat [ text "Incompatible tycon applications in alternative",
700 text "Scrutinee tycon:" <+> ppr tycon1,
701 text "Alternative tycon:" <+> ppr (dataConTyCon con),
702 text "Alternative:" <+> pprCoreAlt alt ]
704 ------------------------------------------------------
705 -- Other error messages
707 mkAppMsg :: Type -> Type -> Message
709 = vcat [ptext SLIT("Argument value doesn't match argument type:"),
710 hang (ptext SLIT("Fun type:")) 4 (ppr fun),
711 hang (ptext SLIT("Arg type:")) 4 (ppr arg)]
713 mkKindErrMsg :: TyVar -> Type -> Message
714 mkKindErrMsg tyvar arg_ty
715 = vcat [ptext SLIT("Kinds don't match in type application:"),
716 hang (ptext SLIT("Type variable:"))
717 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
718 hang (ptext SLIT("Arg type:"))
719 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
721 mkTyAppMsg :: Type -> Type -> Message
723 = vcat [text "Illegal type application:",
724 hang (ptext SLIT("Exp type:"))
725 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
726 hang (ptext SLIT("Arg type:"))
727 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
729 mkRhsMsg :: Id -> Type -> Message
732 [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
734 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
735 hsep [ptext SLIT("Rhs type:"), ppr ty]]
737 mkRhsPrimMsg :: Id -> CoreExpr -> Message
738 mkRhsPrimMsg binder rhs
739 = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
741 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
744 mkUnboxedTupleMsg :: Id -> Message
745 mkUnboxedTupleMsg binder
746 = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
747 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
749 mkCoerceErr from_ty expr_ty
750 = vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"),
751 ptext SLIT("From-type:") <+> ppr from_ty,
752 ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
756 = ptext SLIT("Type where expression expected:") <+> ppr e