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 )
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,
30 splitFunTy_maybe, mkTyVarTys,
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 | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty,
434 tycon == dataConTyCon con
435 = addLoc (CaseAlt alt) $
436 addInScopeVars args $ -- Put the args in scope before lintBinder,
437 -- because the Ids mention the type variables
438 if isVanillaDataCon con then
439 do { mapM lintBinder args
440 -- FIX! Add check that all args are Ids.
442 -- Scrutinee type must be a tycon applicn; checked by caller
443 -- This code is remarkably compact considering what it does!
444 -- NB: args must be in scope here so that the lintCoreArgs line works.
445 -- NB: relies on existential type args coming *after* ordinary type args
447 ; con_type <- lintTyApps (dataConRepType con) tycon_arg_tys
448 -- Can just map Var as we know that this is a vanilla datacon
449 ; con_result_ty <- lintCoreArgs con_type (map Var args)
450 ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
452 ; checkAltExpr rhs alt_ty }
455 do { let (tvs,ids) = span isTyVar args
456 pat_res_ty = dataConResTy con (mkTyVarTys tvs)
458 ; subst <- getTvSubst
459 ; case coreRefineTys tvs subst pat_res_ty scrut_ty of {
460 Nothing -> return () ; -- Alternative is dead code
461 Just senv -> updateTvSubstEnv senv $
462 do { tvs' <- mapM lintTy (mkTyVarTys tvs)
463 ; con_type <- lintTyApps (dataConRepType con) tvs'
464 ; mapM lintBinder ids -- Lint Ids in the refined world
465 ; lintCoreArgs con_type (map Var ids)
466 ; checkAltExpr rhs alt_ty
469 | otherwise -- Scrut-ty is wrong shape
470 = addErrL (mkBadAltMsg scrut_ty alt)
473 %************************************************************************
475 \subsection[lint-types]{Types}
477 %************************************************************************
480 lintBinder :: Var -> LintM ()
481 lintBinder var | isId var = lintId var >> return ()
482 | otherwise = return ()
484 lintId :: Var -> LintM Type
485 -- ToDo: lint its rules
487 = do { checkL (not (isUnboxedTupleType (idType id)))
488 (mkUnboxedTupleMsg id)
489 -- No variable can be bound to an unboxed tuple.
490 ; lintTy (idType id) }
492 lintTy :: Type -> LintM Type
493 -- Check the type, and apply the substitution to it
494 -- ToDo: check the kind structure of the type
496 = do { ty' <- applySubst ty
497 ; mapM_ checkIdInScope (varSetElems (tyVarsOfType ty'))
502 %************************************************************************
504 \subsection[lint-monad]{The Lint monad}
506 %************************************************************************
511 [LintLocInfo] -> -- Locations
512 TvSubst -> -- Current type substitution; we also use this
513 -- to keep track of all the variables in scope,
514 -- both Ids and TyVars
515 Bag Message -> -- Error messages so far
516 (Maybe a, Bag Message) } -- Result and error messages (if any)
518 instance Monad LintM where
519 return x = LintM (\ loc subst errs -> (Just x, errs))
520 fail err = LintM (\ loc subst errs -> (Nothing, addErr subst errs (text err) loc))
521 m >>= k = LintM (\ loc subst errs ->
522 let (res, errs') = unLintM m loc subst errs in
524 Just r -> unLintM (k r) loc subst errs'
525 Nothing -> (Nothing, errs'))
528 = RhsOf Id -- The variable bound
529 | LambdaBodyOf Id -- The lambda-binder
530 | BodyOfLetRec [Id] -- One of the binders
531 | CaseAlt CoreAlt -- Pattern of a case alternative
532 | AnExpr CoreExpr -- Some expression
533 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
538 initL :: LintM a -> Maybe Message {- errors -}
540 = case unLintM m [] emptyTvSubst emptyBag of
541 (_, errs) | isEmptyBag errs -> Nothing
542 | otherwise -> Just (vcat (punctuate (text "") (bagToList errs)))
546 checkL :: Bool -> Message -> LintM ()
547 checkL True msg = return ()
548 checkL False msg = addErrL msg
550 addErrL :: Message -> LintM a
551 addErrL msg = LintM (\ loc subst errs -> (Nothing, addErr subst errs msg loc))
553 addErr :: TvSubst -> Bag Message -> Message -> [LintLocInfo] -> Bag Message
554 addErr subst errs_so_far msg locs
555 = ASSERT( notNull locs )
556 errs_so_far `snocBag` mk_msg msg
558 (loc, cxt1) = dumpLoc (head locs)
559 cxts = [snd (dumpLoc loc) | loc <- locs]
560 context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$
561 ptext SLIT("Substitution:") <+> ppr subst
564 mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg)
566 addLoc :: LintLocInfo -> LintM a -> LintM a
568 LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs)
570 addInScopeVars :: [Var] -> LintM a -> LintM a
571 addInScopeVars vars m =
572 LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs)
575 updateTvSubstEnv :: TvSubstEnv -> LintM a -> LintM a
576 updateTvSubstEnv substenv m =
577 LintM (\ loc subst errs -> unLintM m loc (setTvSubstEnv subst substenv) errs)
579 getTvSubst :: LintM TvSubst
580 getTvSubst = LintM (\ loc subst errs -> (Just subst, errs))
582 applySubst :: Type -> LintM Type
583 applySubst ty = do { subst <- getTvSubst; return (substTy subst ty) }
585 extendSubstL :: TyVar -> Type -> LintM a -> LintM a
587 = LintM (\ loc subst errs -> unLintM m loc (extendTvSubst subst tv ty) errs)
591 checkIdInScope :: Var -> LintM ()
593 = checkInScope (ptext SLIT("is out of scope")) id
595 checkBndrIdInScope :: Var -> Var -> LintM ()
596 checkBndrIdInScope binder id
597 = checkInScope msg id
599 msg = ptext SLIT("is out of scope inside info for") <+>
602 checkInScope :: SDoc -> Var -> LintM ()
603 checkInScope loc_msg var =
604 do { subst <- getTvSubst
605 ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
606 (hsep [ppr var, loc_msg]) }
608 checkTys :: Type -> Type -> Message -> LintM ()
609 -- check ty2 is subtype of ty1 (ie, has same structure but usage
610 -- annotations need only be consistent, not equal)
611 -- Assumes ty1,ty2 are have alrady had the substitution applied
612 checkTys ty1 ty2 msg = checkL (ty1 `eqType` ty2) msg
615 %************************************************************************
617 \subsection{Error messages}
619 %************************************************************************
623 = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))
625 dumpLoc (LambdaBodyOf b)
626 = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
628 dumpLoc (BodyOfLetRec [])
629 = (noSrcLoc, brackets (ptext SLIT("In body of a letrec with no binders")))
631 dumpLoc (BodyOfLetRec bs@(_:_))
632 = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
635 = (noSrcLoc, text "In the expression:" <+> ppr e)
637 dumpLoc (CaseAlt (con, args, rhs))
638 = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> ppr args))
640 dumpLoc (ImportedUnfolding locn)
641 = (locn, brackets (ptext SLIT("in an imported unfolding")))
643 pp_binders :: [Var] -> SDoc
644 pp_binders bs = sep (punctuate comma (map pp_binder bs))
646 pp_binder :: Var -> SDoc
647 pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)]
648 | isTyVar b = hsep [ppr b, dcolon, ppr (tyVarKind b)]
652 ------------------------------------------------------
653 -- Messages for case expressions
655 mkNullAltsMsg :: CoreExpr -> Message
657 = hang (text "Case expression with no alternatives:")
660 mkDefaultArgsMsg :: [Var] -> Message
661 mkDefaultArgsMsg args
662 = hang (text "DEFAULT case with binders")
665 mkCaseAltMsg :: CoreExpr -> Type -> Type -> Message
666 mkCaseAltMsg e ty1 ty2
667 = hang (text "Type of case alternatives not the same as the annotation on case:")
668 4 (vcat [ppr ty1, ppr ty2, ppr e])
670 mkScrutMsg :: Id -> Type -> Message
671 mkScrutMsg var scrut_ty
672 = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
673 text "Result binder type:" <+> ppr (idType var),
674 text "Scrutinee type:" <+> ppr scrut_ty]
678 = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
680 nonExhaustiveAltsMsg :: CoreExpr -> Message
681 nonExhaustiveAltsMsg e
682 = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
684 mkBadPatMsg :: Type -> Type -> Message
685 mkBadPatMsg con_result_ty scrut_ty
687 text "In a case alternative, pattern result type doesn't match scrutinee type:",
688 text "Pattern result type:" <+> ppr con_result_ty,
689 text "Scrutinee type:" <+> ppr scrut_ty
692 mkBadAltMsg :: Type -> CoreAlt -> Message
693 mkBadAltMsg scrut_ty alt
694 = vcat [ text "Data alternative when scrutinee is not a tycon application",
695 text "Scrutinee type:" <+> ppr scrut_ty,
696 text "Alternative:" <+> pprCoreAlt alt ]
698 ------------------------------------------------------
699 -- Other error messages
701 mkAppMsg :: Type -> Type -> Message
703 = vcat [ptext SLIT("Argument value doesn't match argument type:"),
704 hang (ptext SLIT("Fun type:")) 4 (ppr fun),
705 hang (ptext SLIT("Arg type:")) 4 (ppr arg)]
707 mkKindErrMsg :: TyVar -> Type -> Message
708 mkKindErrMsg tyvar arg_ty
709 = vcat [ptext SLIT("Kinds don't match in type application:"),
710 hang (ptext SLIT("Type variable:"))
711 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
712 hang (ptext SLIT("Arg type:"))
713 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
715 mkTyAppMsg :: Type -> Type -> Message
717 = vcat [text "Illegal type application:",
718 hang (ptext SLIT("Exp type:"))
719 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
720 hang (ptext SLIT("Arg type:"))
721 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
723 mkRhsMsg :: Id -> Type -> Message
726 [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
728 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
729 hsep [ptext SLIT("Rhs type:"), ppr ty]]
731 mkRhsPrimMsg :: Id -> CoreExpr -> Message
732 mkRhsPrimMsg binder rhs
733 = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
735 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
738 mkUnboxedTupleMsg :: Id -> Message
739 mkUnboxedTupleMsg binder
740 = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
741 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
743 mkCoerceErr from_ty expr_ty
744 = vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"),
745 ptext SLIT("From-type:") <+> ppr from_ty,
746 ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
750 = ptext SLIT("Type where expression expected:") <+> ppr e