2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section[CoreLint]{A ``lint'' pass to check for Core correctness}
7 #include "HsVersions.h"
16 import CmdLineOpts ( opt_D_show_passes, opt_PprUserLength, opt_DoCoreLinting )
20 import Kind ( hasMoreBoxityInfo, Kind{-instance-},
21 isTypeKind, isBoxedTypeKind {- TEMP --SOF -} )
22 import Literal ( literalType, Literal{-instance-} )
23 import Id ( idType, isBottomingId, dataConRepType, isDataCon, isNewCon,
24 dataConArgTys, GenId{-instances-},
25 emptyIdSet, mkIdSet, intersectIdSets,
26 unionIdSets, elementOfIdSet, SYN_IE(IdSet),
29 import Maybes ( catMaybes )
30 import Name ( isLocallyDefined, getSrcLoc, Name{-instance NamedThing-},
33 import Outputable ( PprStyle(..), Outputable(..), pprErrorsStyle, printErrs )
34 import ErrUtils ( doIfSet, ghcExit )
35 import PprType ( GenType, GenTyVar, TyCon )
37 import PrimOp ( primOpType, PrimOp(..) )
38 import PrimRep ( PrimRep(..) )
39 import SrcLoc ( SrcLoc )
40 import Type ( mkFunTy,getFunTy_maybe,mkForAllTy,mkForAllTys,getForAllTy_maybe,
41 getFunTyExpandingDicts_maybe,
42 getForAllTyExpandingDicts_maybe,
43 isPrimType,typeKind,instantiateTy,splitSigmaTy,
44 mkForAllUsageTy,getForAllUsageTy,instantiateUsage,
45 maybeAppDataTyConExpandingDicts, eqTy, SYN_IE(Type)
47 import TyCon ( isPrimTyCon, isDataTyCon )
48 import TyVar ( tyVarKind, GenTyVar{-instances-} )
49 import Unique ( Unique )
50 import Usage ( GenUsage, SYN_IE(Usage) )
51 import Util ( zipEqual, pprTrace, pprPanic, assertPanic, panic )
53 infixr 9 `thenL`, `seqL`, `thenMaybeL`, `seqMaybeL`
56 %************************************************************************
58 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
60 %************************************************************************
62 Checks that a set of core bindings is well-formed. The PprStyle and String
63 just control what we print in the event of an error. The Bool value
64 indicates whether we have done any specialisation yet (in which case we do
69 (b) Out-of-scope type variables
70 (c) Out-of-scope local variables
73 If we have done specialisation the we check that there are
74 (a) No top-level bindings of primitive (unboxed type)
79 -- Things are *not* OK if:
81 -- * Unsaturated type app before specialisation has been done;
83 -- * Oversaturated type app after specialisation (eta reduction
84 -- may well be happening...);
86 -- Note: checkTyApp is usually followed by a call to checkSpecTyApp.
90 lintCoreBindings :: String -> Bool -> [CoreBinding] -> IO ()
92 lintCoreBindings whoDunnit spec_done binds
93 | not opt_DoCoreLinting
96 lintCoreBindings whoDunnit spec_done binds
97 = case (initL (lint_binds binds) spec_done) of
98 Nothing -> doIfSet opt_D_show_passes
99 (hPutStr stderr ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
101 Just bad_news -> printErrs (display bad_news) >>
104 lint_binds [] = returnL ()
105 lint_binds (bind:binds)
106 = lintCoreBinding bind `thenL` \binders ->
107 addInScopeVars binders (lint_binds binds)
111 text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
112 bad_news pprErrorsStyle,
113 ptext SLIT("*** Offending Program ***"),
114 pprCoreBindings pprErrorsStyle binds,
115 ptext SLIT("*** End of Offense ***")
119 %************************************************************************
121 \subsection[lintUnfolding]{lintUnfolding}
123 %************************************************************************
125 We use this to check all unfoldings that come in from interfaces
126 (it is very painful to catch errors otherwise):
129 lintUnfolding :: SrcLoc -> CoreExpr -> Maybe CoreExpr
131 lintUnfolding locn expr
133 (initL (addLoc (ImportedUnfolding locn) (lintCoreExpr expr))
134 True{-pretend spec done-})
138 pprTrace "WARNING: Discarded bad unfolding from interface:\n"
139 (vcat [msg (PprForUser opt_PprUserLength),
140 ptext SLIT("*** Bad unfolding ***"),
142 ptext SLIT("*** End unfolding ***")])
146 %************************************************************************
148 \subsection[lintCoreBinding]{lintCoreBinding}
150 %************************************************************************
152 Check a core binding, returning the list of variables bound.
155 lintCoreBinding :: CoreBinding -> LintM [Id]
157 lintCoreBinding (NonRec binder rhs)
158 = lintSingleBinding (binder,rhs) `seqL` returnL [binder]
160 lintCoreBinding (Rec pairs)
161 = addInScopeVars binders (
162 mapL lintSingleBinding pairs `seqL` returnL binders
165 binders = [b | (b,_) <- pairs]
167 lintSingleBinding (binder,rhs)
168 = addLoc (RhsOf binder) (
173 -- Check match to RHS type
175 Nothing -> returnL ()
176 Just ty -> checkTys (idType binder) ty (mkRhsMsg binder ty))
179 -- Check (not isPrimType)
180 checkIfSpecDoneL (not (isPrimType (idType binder)))
181 (mkRhsPrimMsg binder rhs)
183 -- We should check the unfolding, if any, but this is tricky because
184 -- the unfolding is a SimplifiableCoreExpr. Give up for now.
188 %************************************************************************
190 \subsection[lintCoreExpr]{lintCoreExpr}
192 %************************************************************************
195 lintCoreExpr :: CoreExpr -> LintM (Maybe Type) -- Nothing if error found
197 lintCoreExpr (Var var) = checkInScope var `seqL` returnL (Just (idType var))
198 lintCoreExpr (Lit lit) = returnL (Just (literalType lit))
199 lintCoreExpr (SCC _ expr) = lintCoreExpr expr
200 lintCoreExpr e@(Coerce coercion ty expr)
201 = lintCoercion e coercion `seqL`
202 lintCoreExpr expr `seqL` returnL (Just ty)
204 lintCoreExpr (Let binds body)
205 = lintCoreBinding binds `thenL` \binders ->
206 if (null binders) then
207 lintCoreExpr body -- Can't add a new source location
209 addLoc (BodyOfLetRec binders)
210 (addInScopeVars binders (lintCoreExpr body))
212 lintCoreExpr e@(Con con args)
213 = checkL (isDataCon con) (mkConErrMsg e) `seqL`
214 lintCoreArgs {-False-} e (dataConRepType con) args
215 -- Note: we don't check for primitive types in these arguments
217 lintCoreExpr e@(Prim op args)
218 = lintCoreArgs {-True-} e (primOpType op) args
219 -- Note: we do check for primitive types in these arguments
221 lintCoreExpr e@(App fun@(Var v) arg) | isBottomingId v
222 = lintCoreExpr fun `thenMaybeL` \ ty -> lintCoreArg {-False-} e ty arg
223 -- Note: we don't check for primitive types in argument to 'error'
225 lintCoreExpr e@(App fun arg)
226 = lintCoreExpr fun `thenMaybeL` \ty -> lintCoreArg {-True-} e ty arg
227 -- Note: we do check for primitive types in this argument
229 lintCoreExpr (Lam (ValBinder var) expr)
230 = addLoc (LambdaBodyOf var)
231 (addInScopeVars [var]
232 (lintCoreExpr expr `thenMaybeL` \ty ->
233 returnL (Just (mkFunTy (idType var) ty))))
235 lintCoreExpr (Lam (TyBinder tyvar) expr)
236 = lintCoreExpr expr `thenMaybeL` \ty ->
237 returnL (Just(mkForAllTy tyvar ty))
238 -- ToDo: Should add in-scope type variable at this point
240 lintCoreExpr e@(Case scrut alts)
241 = lintCoreExpr scrut `thenMaybeL` \ty ->
245 %************************************************************************
247 \subsection[lintCoreArgs]{lintCoreArgs}
249 %************************************************************************
251 The boolean argument indicates whether we should flag type
252 applications to primitive types as being errors.
255 lintCoreArgs :: {-Bool ->-} CoreExpr -> Type -> [CoreArg] -> LintM (Maybe Type)
257 lintCoreArgs _ ty [] = returnL (Just ty)
258 lintCoreArgs e ty (a : args)
259 = lintCoreArg e ty a `thenMaybeL` \ res ->
260 lintCoreArgs e res args
263 %************************************************************************
265 \subsection[lintCoreArg]{lintCoreArg}
267 %************************************************************************
270 lintCoreArg :: {-Bool ->-} CoreExpr -> Type -> CoreArg -> LintM (Maybe Type)
272 lintCoreArg e ty (LitArg lit)
273 = -- Make sure function type matches argument
274 case (getFunTyExpandingDicts_maybe False{-no peeking in newtypes-} ty) of
275 Just (arg,res) | (lit_ty `eqTy` arg) -> returnL(Just res)
276 _ -> addErrL (mkAppMsg ty lit_ty e) `seqL` returnL Nothing
278 lit_ty = literalType lit
280 lintCoreArg e ty (VarArg v)
281 = -- Make sure variable is bound
282 checkInScope v `seqL`
283 -- Make sure function type matches argument
284 case (getFunTyExpandingDicts_maybe False{-as above-} ty) of
285 Just (arg,res) | (var_ty `eqTy` arg) -> returnL(Just res)
286 _ -> addErrL (mkAppMsg ty var_ty e) `seqL` returnL Nothing
290 lintCoreArg e ty a@(TyArg arg_ty)
291 = -- ToDo: Check that ty is well-kinded and has no unbound tyvars
292 case (getForAllTyExpandingDicts_maybe ty) of
293 Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing
297 tyvar_kind = tyVarKind tyvar
298 argty_kind = typeKind arg_ty
300 if argty_kind `hasMoreBoxityInfo` tyvar_kind
301 -- Arg type might be boxed for a function with an uncommitted
302 -- tyvar; notably this is used so that we can give
303 -- error :: forall a:*. String -> a
304 -- and then apply it to both boxed and unboxed types.
306 returnL(Just(instantiateTy [(tyvar,arg_ty)] body))
308 pprTrace "lintCoreArg:kinds:" (hsep [ppr PprDebug tyvar_kind, ppr PprDebug argty_kind]) $
309 addErrL (mkTyAppMsg SLIT("Kinds not right in") ty arg_ty e) `seqL` returnL Nothing
311 lintCoreArg e ty (UsageArg u)
312 = -- ToDo: Check that usage has no unbound usage variables
313 case (getForAllUsageTy ty) of
314 Just (uvar,bounds,body) ->
315 -- ToDo: Check argument satisfies bounds
316 returnL(Just(panic "lintCoreArg:instantiateUsage uvar u body"))
317 _ -> addErrL (mkUsageAppMsg ty u e) `seqL` returnL Nothing
320 %************************************************************************
322 \subsection[lintCoreAlts]{lintCoreAlts}
324 %************************************************************************
327 lintCoreAlts :: CoreCaseAlts
328 -> Type -- Type of scrutinee
329 -- -> TyCon -- TyCon pinned on the case
330 -> LintM (Maybe Type) -- Type of alternatives
332 lintCoreAlts whole_alts@(AlgAlts alts deflt) ty --tycon
333 = -- Check tycon is not a primitive tycon
334 -- addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon)
336 -- Check we are scrutinising a proper datatype
338 -- addErrIfL (not (tyConFamilySize tycon >= 1)) (mkCaseAbstractMsg tycon)
341 `thenL` \maybe_deflt_ty ->
342 mapL (lintAlgAlt ty {-tycon-}) alts
343 `thenL` \maybe_alt_tys ->
344 -- Check the result types
345 case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
346 [] -> returnL Nothing
348 (first_ty:tys) -> mapL check tys `seqL`
349 returnL (Just first_ty)
351 check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
353 lintCoreAlts whole_alts@(PrimAlts alts deflt) ty --tycon
354 = -- Check tycon is a primitive tycon
355 -- addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon)
357 mapL (lintPrimAlt ty) alts
358 `thenL` \maybe_alt_tys ->
360 `thenL` \maybe_deflt_ty ->
361 -- Check the result types
362 case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
363 [] -> returnL Nothing
365 (first_ty:tys) -> mapL check tys `seqL`
366 returnL (Just first_ty)
368 check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
370 lintAlgAlt scrut_ty (con,args,rhs)
371 = (case maybeAppDataTyConExpandingDicts scrut_ty of
372 Just (tycon, tys_applied, cons) | isDataTyCon tycon ->
374 arg_tys = dataConArgTys con tys_applied
376 checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `seqL`
377 checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
379 mapL check (zipEqual "lintAlgAlt" arg_tys args) `seqL`
382 other -> addErrL (mkAlgAltMsg1 scrut_ty)
384 addInScopeVars args (
388 check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
390 -- elem: yes, the elem-list here can sometimes be long-ish,
391 -- but as it's use-once, probably not worth doing anything different
392 -- We give it its own copy, so it isn't overloaded.
394 elem x (y:ys) = x==y || elem x ys
396 lintPrimAlt ty alt@(lit,rhs)
397 = checkTys (literalType lit) ty (mkPrimAltMsg alt) `seqL`
400 lintDeflt NoDefault _ = returnL Nothing
401 lintDeflt deflt@(BindDefault binder rhs) ty
402 = checkTys (idType binder) ty (mkDefltMsg deflt) `seqL`
403 addInScopeVars [binder] (lintCoreExpr rhs)
406 %************************************************************************
408 \subsection[lint-coercion]{Coercion}
410 %************************************************************************
413 lintCoercion e (CoerceIn con) = check_con e con
414 lintCoercion e (CoerceOut con) = check_con e con
416 check_con e con = checkL (isNewCon con)
421 %************************************************************************
423 \subsection[lint-monad]{The Lint monad}
425 %************************************************************************
428 type LintM a = Bool -- True <=> specialisation has been done
429 -> [LintLocInfo] -- Locations
430 -> IdSet -- Local vars in scope
431 -> Bag ErrMsg -- Error messages so far
432 -> (a, Bag ErrMsg) -- Result and error messages (if any)
434 type ErrMsg = PprStyle -> Doc
437 = RhsOf Id -- The variable bound
438 | LambdaBodyOf Id -- The lambda-binder
439 | BodyOfLetRec [Id] -- One of the binders
440 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
442 instance Outputable LintLocInfo where
444 = hcat [ppr sty (getSrcLoc v), ptext SLIT(": [RHS of "), pp_binders sty [v], char ']']
446 ppr sty (LambdaBodyOf b)
447 = hcat [ppr sty (getSrcLoc b),
448 ptext SLIT(": [in body of lambda with binder "), pp_binder sty b, char ']']
450 ppr sty (BodyOfLetRec bs)
451 = hcat [ppr sty (getSrcLoc (head bs)),
452 ptext SLIT(": [in body of letrec with binders "), pp_binders sty bs, char ']']
454 ppr sty (ImportedUnfolding locn)
455 = (<>) (ppr sty locn) (ptext SLIT(": [in an imported unfolding]"))
457 pp_binders :: PprStyle -> [Id] -> Doc
458 pp_binders sty bs = sep (punctuate comma (map (pp_binder sty) bs))
460 pp_binder :: PprStyle -> Id -> Doc
461 pp_binder sty b = hsep [ppr sty b, text "::", ppr sty (idType b)]
465 initL :: LintM a -> Bool -> Maybe ErrMsg
467 = case (m spec_done [] emptyIdSet emptyBag) of { (_, errs) ->
468 if isEmptyBag errs then
472 vcat [ msg sty | msg <- bagToList errs ]
476 returnL :: a -> LintM a
477 returnL r spec loc scope errs = (r, errs)
479 thenL :: LintM a -> (a -> LintM b) -> LintM b
480 thenL m k spec loc scope errs
481 = case m spec loc scope errs of
482 (r, errs') -> k r spec loc scope errs'
484 seqL :: LintM a -> LintM b -> LintM b
485 seqL m k spec loc scope errs
486 = case m spec loc scope errs of
487 (_, errs') -> k spec loc scope errs'
489 thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b)
490 thenMaybeL m k spec loc scope errs
491 = case m spec loc scope errs of
492 (Nothing, errs2) -> (Nothing, errs2)
493 (Just r, errs2) -> k r spec loc scope errs2
495 seqMaybeL :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b)
496 seqMaybeL m k spec loc scope errs
497 = case m spec loc scope errs of
498 (Nothing, errs2) -> (Nothing, errs2)
499 (Just _, errs2) -> k spec loc scope errs2
501 mapL :: (a -> LintM b) -> [a] -> LintM [b]
502 mapL f [] = returnL []
505 mapL f xs `thenL` \ rs ->
508 mapMaybeL :: (a -> LintM (Maybe b)) -> [a] -> LintM (Maybe [b])
509 -- Returns Nothing if anything fails
510 mapMaybeL f [] = returnL (Just [])
512 = f x `thenMaybeL` \ r ->
513 mapMaybeL f xs `thenMaybeL` \ rs ->
514 returnL (Just (r:rs))
518 checkL :: Bool -> ErrMsg -> LintM ()
519 checkL True msg spec loc scope errs = ((), errs)
520 checkL False msg spec loc scope errs = ((), addErr errs msg loc)
522 checkIfSpecDoneL :: Bool -> ErrMsg -> LintM ()
523 checkIfSpecDoneL True msg spec loc scope errs = ((), errs)
524 checkIfSpecDoneL False msg True loc scope errs = ((), addErr errs msg loc)
525 checkIfSpecDoneL False msg False loc scope errs = ((), errs)
528 = if pred then addErrL spec else returnL ()
530 addErrL :: ErrMsg -> LintM ()
531 addErrL msg spec loc scope errs = ((), addErr errs msg loc)
533 addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg
535 addErr errs_so_far msg locs
536 = ASSERT (not (null locs))
537 errs_so_far `snocBag` ( \ sty ->
538 hang (ppr sty (head locs)) 4 (msg sty)
541 addLoc :: LintLocInfo -> LintM a -> LintM a
542 addLoc extra_loc m spec loc scope errs
543 = m spec (extra_loc:loc) scope errs
545 addInScopeVars :: [Id] -> LintM a -> LintM a
546 addInScopeVars ids m spec loc scope errs
547 = -- We check if these "new" ids are already
548 -- in scope, i.e., we have *shadowing* going on.
549 -- For now, it's just a "trace"; we may make
550 -- a real error out of it...
552 new_set = mkIdSet ids
554 -- shadowed = scope `intersectIdSets` new_set
556 -- After adding -fliberate-case, Simon decided he likes shadowed
557 -- names after all. WDP 94/07
558 -- (if isEmptyUniqSet shadowed
560 -- else pprTrace "Shadowed vars:" (ppr PprDebug (uniqSetToList shadowed))) (
561 m spec loc (scope `unionIdSets` new_set) errs
566 checkInScope :: Id -> LintM ()
567 checkInScope id spec loc scope errs
571 if isLocallyDefined id_name && not (id `elementOfIdSet` scope) then
572 ((),addErr errs (\sty -> hsep [ppr sty id, ptext SLIT("is out of scope")]) loc)
576 checkTys :: Type -> Type -> ErrMsg -> LintM ()
577 checkTys ty1 ty2 msg spec loc scope errs
578 = if ty1 `eqTy` ty2 then ((), errs) else ((), addErr errs msg loc)
583 = ($$) (ptext SLIT("Application of newtype constructor:"))
587 = ($$) (ptext SLIT("Coercion using a datatype constructor:"))
591 mkCaseAltMsg :: CoreCaseAlts -> ErrMsg
592 mkCaseAltMsg alts sty
593 = ($$) (ptext SLIT("Type of case alternatives not the same:"))
596 mkCaseDataConMsg :: CoreExpr -> ErrMsg
597 mkCaseDataConMsg expr sty
598 = ($$) (ptext SLIT("A case scrutinee not of data constructor type:"))
601 mkCaseNotPrimMsg :: TyCon -> ErrMsg
602 mkCaseNotPrimMsg tycon sty
603 = ($$) (ptext SLIT("A primitive case on a non-primitive type:"))
606 mkCasePrimMsg :: TyCon -> ErrMsg
607 mkCasePrimMsg tycon sty
608 = ($$) (ptext SLIT("An algebraic case on a primitive type:"))
611 mkCaseAbstractMsg :: TyCon -> ErrMsg
612 mkCaseAbstractMsg tycon sty
613 = ($$) (ptext SLIT("An algebraic case on some weird type:"))
616 mkDefltMsg :: CoreCaseDefault -> ErrMsg
618 = ($$) (ptext SLIT("Binder in case default doesn't match type of scrutinee:"))
621 mkAppMsg :: Type -> Type -> CoreExpr -> ErrMsg
622 mkAppMsg fun arg expr sty
623 = vcat [ptext SLIT("Argument value doesn't match argument type:"),
624 hang (ptext SLIT("Fun type:")) 4 (ppr sty fun),
625 hang (ptext SLIT("Arg type:")) 4 (ppr sty arg),
626 hang (ptext SLIT("Expression:")) 4 (pp_expr sty expr)]
628 mkTyAppMsg :: FAST_STRING -> Type -> Type -> CoreExpr -> ErrMsg
629 mkTyAppMsg msg ty arg expr sty
630 = vcat [hsep [ptext msg, ptext SLIT("type application:")],
631 hang (ptext SLIT("Exp type:")) 4 (ppr sty ty),
632 hang (ptext SLIT("Arg type:")) 4 (ppr sty arg),
633 hang (ptext SLIT("Expression:")) 4 (pp_expr sty expr)]
635 mkUsageAppMsg :: Type -> Usage -> CoreExpr -> ErrMsg
636 mkUsageAppMsg ty u expr sty
637 = vcat [ptext SLIT("Illegal usage application:"),
638 hang (ptext SLIT("Exp type:")) 4 (ppr sty ty),
639 hang (ptext SLIT("Usage exp:")) 4 (ppr sty u),
640 hang (ptext SLIT("Expression:")) 4 (pp_expr sty expr)]
642 mkAlgAltMsg1 :: Type -> ErrMsg
644 = ($$) (text "In some case statement, type of scrutinee is not a data type:")
646 -- (($$) (ppr sty ty) (ppr sty (expandTy ty))) -- ToDo: rm
648 mkAlgAltMsg2 :: Type -> Id -> ErrMsg
649 mkAlgAltMsg2 ty con sty
651 text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
656 mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg
657 mkAlgAltMsg3 con alts sty
659 text "In some algebraic case alternative, number of arguments doesn't match constructor:",
664 mkAlgAltMsg4 :: Type -> Id -> ErrMsg
665 mkAlgAltMsg4 ty arg sty
667 text "In some algebraic case alternative, type of argument doesn't match data constructor:",
672 mkPrimAltMsg :: (Literal, CoreExpr) -> ErrMsg
675 (text "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
678 mkRhsMsg :: Id -> Type -> ErrMsg
679 mkRhsMsg binder ty sty
681 [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
683 hsep [ptext SLIT("Binder's type:"), ppr sty (idType binder)],
684 hsep [ptext SLIT("Rhs type:"), ppr sty ty]]
686 mkRhsPrimMsg :: Id -> CoreExpr -> ErrMsg
687 mkRhsPrimMsg binder rhs sty
688 = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
690 hsep [ptext SLIT("Binder's type:"), ppr sty (idType binder)]
693 mkSpecTyAppMsg :: CoreArg -> ErrMsg
694 mkSpecTyAppMsg arg sty
696 (ptext SLIT("Unboxed types in a type application (after specialisation):"))
699 pp_expr :: PprStyle -> CoreExpr -> Doc
701 = pprCoreExpr sty (pprBigCoreBinder sty) (pprTypedCoreBinder sty) (pprTypedCoreBinder sty) expr