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 )
18 import Unify ( coreRefineTys )
20 import Literal ( literalType )
21 import DataCon ( dataConRepType, isVanillaDataCon, dataConTyCon, 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, mkForAllTy, mkFunTy,
34 isUnboxedTupleType, isSubKind,
35 substTyWith, emptyTvSubst, extendTvInScope,
36 TvSubst, TvSubstEnv, mkTvSubst, setTvSubstEnv, substTy,
37 extendTvSubst, composeTvSubst, isInScope,
38 getTvSubstEnv, getTvInScope )
39 import TyCon ( isPrimTyCon )
40 import BasicTypes ( RecFlag(..), Boxity(..), isNonRec )
45 import Util ( notNull )
52 %************************************************************************
56 %************************************************************************
58 @showPass@ and @endPass@ don't really belong here, but it makes a convenient
59 place for them. They print out stuff before and after core passes,
60 and do Core Lint when necessary.
63 endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
64 endPass dflags pass_name dump_flag binds
66 -- Report result size if required
67 -- This has the side effect of forcing the intermediate to be evaluated
68 debugTraceMsg dflags $
69 " Result size = " ++ show (coreBindsSize binds)
71 -- Report verbosely, if required
72 dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds)
75 lintCoreBindings dflags pass_name binds
81 %************************************************************************
83 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
85 %************************************************************************
87 Checks that a set of core bindings is well-formed. The PprStyle and String
88 just control what we print in the event of an error. The Bool value
89 indicates whether we have done any specialisation yet (in which case we do
94 (b) Out-of-scope type variables
95 (c) Out-of-scope local variables
98 If we have done specialisation the we check that there are
99 (a) No top-level bindings of primitive (unboxed type)
104 -- Things are *not* OK if:
106 -- * Unsaturated type app before specialisation has been done;
108 -- * Oversaturated type app after specialisation (eta reduction
109 -- may well be happening...);
112 lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
114 lintCoreBindings dflags whoDunnit binds
115 | not (dopt Opt_DoCoreLinting dflags)
118 lintCoreBindings dflags whoDunnit binds
119 = case (initL (lint_binds binds)) of
120 Nothing -> showPass dflags ("Core Linted result of " ++ whoDunnit)
121 Just bad_news -> printDump (display bad_news) >>
124 -- Put all the top-level binders in scope at the start
125 -- This is because transformation rules can bring something
126 -- into use 'unexpectedly'
127 lint_binds binds = addInScopeVars (bindersOfBinds binds) $
130 lint_bind (Rec prs) = mapM_ (lintSingleBinding Recursive) prs
131 lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
134 = vcat [ text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
136 ptext SLIT("*** Offending Program ***"),
137 pprCoreBindings binds,
138 ptext SLIT("*** End of Offense ***")
142 %************************************************************************
144 \subsection[lintUnfolding]{lintUnfolding}
146 %************************************************************************
148 We use this to check all unfoldings that come in from interfaces
149 (it is very painful to catch errors otherwise):
152 lintUnfolding :: SrcLoc
153 -> [Var] -- Treat these as in scope
155 -> Maybe Message -- Nothing => OK
157 lintUnfolding locn vars expr
158 = initL (addLoc (ImportedUnfolding locn) $
159 addInScopeVars vars $
163 %************************************************************************
165 \subsection[lintCoreBinding]{lintCoreBinding}
167 %************************************************************************
169 Check a core binding, returning the list of variables bound.
172 lintSingleBinding rec_flag (binder,rhs)
173 = addLoc (RhsOf binder) $
175 do { ty <- lintCoreExpr rhs
176 ; lintBinder binder -- Check match to RHS type
177 ; binder_ty <- applySubst binder_ty
178 ; checkTys binder_ty ty (mkRhsMsg binder ty)
179 -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
180 ; checkL (not (isUnLiftedType binder_ty)
181 || (isNonRec rec_flag && exprOkForSpeculation rhs))
182 (mkRhsPrimMsg binder rhs)
183 -- Check whether binder's specialisations contain any out-of-scope variables
184 ; mapM_ (checkBndrIdInScope binder) bndr_vars }
186 -- We should check the unfolding, if any, but this is tricky because
187 -- the unfolding is a SimplifiableCoreExpr. Give up for now.
189 binder_ty = idType binder
190 bndr_vars = varSetElems (idFreeVars binder)
193 %************************************************************************
195 \subsection[lintCoreExpr]{lintCoreExpr}
197 %************************************************************************
200 type InType = Type -- Substitution not yet applied
201 type OutType = Type -- Substitution has been applied to this
203 lintCoreExpr :: CoreExpr -> LintM OutType
204 -- The returned type has the substitution from the monad
205 -- already applied to it:
206 -- lintCoreExpr e subst = exprType (subst e)
208 lintCoreExpr (Var var)
209 = do { checkIdInScope var
210 ; applySubst (idType var) }
212 lintCoreExpr (Lit lit)
213 = return (literalType lit)
215 lintCoreExpr (Note (Coerce to_ty from_ty) expr)
216 = do { expr_ty <- lintCoreExpr expr
217 ; to_ty <- lintTy to_ty
218 ; from_ty <- lintTy from_ty
219 ; checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty)
222 lintCoreExpr (Note other_note expr)
225 lintCoreExpr (Let (NonRec bndr rhs) body)
226 = do { lintSingleBinding NonRecursive (bndr,rhs)
227 ; addLoc (BodyOfLetRec [bndr])
228 (addInScopeVars [bndr] (lintCoreExpr body)) }
230 lintCoreExpr (Let (Rec pairs) body)
231 = addInScopeVars bndrs $
232 do { mapM (lintSingleBinding Recursive) pairs
233 ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
235 bndrs = map fst pairs
237 lintCoreExpr (App fun (Type ty))
238 -- This is like 'let' for types
239 -- It's needed when dealing with desugarer output for GADTs. Consider
240 -- data T = forall a. T a (a->Int) Bool
242 -- f (T x f True) = <e1>
243 -- f (T y g False) = <e2>
244 -- After desugaring we get
246 -- T a (x::a) (f::a->Int) (b:Bool) ->
249 -- False -> (/\b. let y=x; g=f in <e2>) a
250 -- And for a reason I now forget, the ...<e2>... can mention a; so
251 -- we want Lint to know that b=a. Ugh.
253 -- I tried quite hard to make the necessity for this go away, by changing the
254 -- desugarer, but the fundamental problem is this:
256 -- T a (x::a) (y::Int) -> let fail::a = ...
257 -- in (/\b. ...(case ... of
261 -- Now the inner case look as though it has incompatible branches.
264 go (App fun (Type ty)) tys
265 = do { go fun (ty:tys) }
266 go (Lam tv body) (ty:tys)
267 = do { checkL (isTyVar tv) (mkKindErrMsg tv ty) -- Not quite accurate
270 -- Now extend the substitution so we
271 -- take advantage of it in the body
272 ; addInScopeVars [tv] $
273 extendSubstL tv ty' $
276 = do { fun_ty <- lintCoreExpr fun
277 ; lintCoreArgs fun_ty (map Type tys) }
279 lintCoreExpr e@(App fun arg)
280 = do { ty <- lintCoreExpr fun
281 ; addLoc (AnExpr e) $
284 lintCoreExpr (Lam var expr)
285 = addLoc (LambdaBodyOf var) $
286 do { body_ty <- addInScopeVars [var] $
288 ; if isId var then do
289 { var_ty <- lintId var
290 ; return (mkFunTy var_ty body_ty) }
292 return (mkForAllTy var body_ty)
294 -- The applySubst is needed to apply the subst to var
296 lintCoreExpr e@(Case scrut var alt_ty alts) =
297 -- Check the scrutinee
298 do { scrut_ty <- lintCoreExpr scrut
299 ; alt_ty <- lintTy alt_ty
300 ; var_ty <- lintTy (idType var)
301 -- Don't use lintId on var, because unboxed tuple is legitimate
303 ; checkTys var_ty scrut_ty (mkScrutMsg var scrut_ty)
305 -- If the binder is an unboxed tuple type, don't put it in scope
306 ; let vars = if (isUnboxedTupleType (idType var)) then [] else [var]
307 ; addInScopeVars vars $
308 do { -- Check the alternatives
309 checkCaseAlts e scrut_ty alts
310 ; mapM (lintCoreAlt scrut_ty alt_ty) alts
313 lintCoreExpr e@(Type ty)
314 = addErrL (mkStrangeTyMsg e)
317 %************************************************************************
319 \subsection[lintCoreArgs]{lintCoreArgs}
321 %************************************************************************
323 The basic version of these functions checks that the argument is a
324 subtype of the required type, as one would expect.
327 lintCoreArgs :: Type -> [CoreArg] -> LintM Type
328 lintCoreArg :: Type -> CoreArg -> LintM Type
329 -- First argument has already had substitution applied to it
333 lintCoreArgs ty [] = return ty
334 lintCoreArgs ty (a : args) =
335 do { res <- lintCoreArg ty a
336 ; lintCoreArgs res args }
338 lintCoreArg ty a@(Type arg_ty) =
339 do { arg_ty <- lintTy arg_ty
340 ; lintTyApp ty arg_ty }
342 lintCoreArg fun_ty arg =
343 -- Make sure function type matches argument
344 do { arg_ty <- lintCoreExpr arg
345 ; let err = mkAppMsg fun_ty arg_ty
346 ; case splitFunTy_maybe fun_ty of
348 do { checkTys arg arg_ty err
354 -- Both args have had substitution applied
356 = case splitForAllTy_maybe ty of
357 Nothing -> addErrL (mkTyAppMsg ty arg_ty)
360 -> do { checkL (isTyVar tyvar) (mkTyAppMsg ty arg_ty)
361 ; checkKinds tyvar arg_ty
362 ; return (substTyWith [tyvar] [arg_ty] body) }
364 lintTyApps fun_ty [] = return fun_ty
366 lintTyApps fun_ty (arg_ty : arg_tys) =
367 do { fun_ty' <- lintTyApp fun_ty arg_ty
368 ; lintTyApps fun_ty' arg_tys }
370 checkKinds tyvar arg_ty
371 -- Arg type might be boxed for a function with an uncommitted
372 -- tyvar; notably this is used so that we can give
373 -- error :: forall a:*. String -> a
374 -- and then apply it to both boxed and unboxed types.
375 = checkL (argty_kind `isSubKind` tyvar_kind)
376 (mkKindErrMsg tyvar arg_ty)
378 tyvar_kind = tyVarKind tyvar
379 argty_kind = typeKind arg_ty
383 %************************************************************************
385 \subsection[lintCoreAlts]{lintCoreAlts}
387 %************************************************************************
390 checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
391 -- a) Check that the alts are non-empty
392 -- b1) Check that the DEFAULT comes first, if it exists
393 -- b2) Check that the others are in increasing order
394 -- c) Check that there's a default for infinite types
395 -- NB: Algebraic cases are not necessarily exhaustive, because
396 -- the simplifer correctly eliminates case that can't
399 checkCaseAlts e ty []
400 = addErrL (mkNullAltsMsg e)
402 checkCaseAlts e ty alts =
403 do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
404 ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
405 ; checkL (isJust maybe_deflt || not is_infinite_ty)
406 (nonExhaustiveAltsMsg e) }
408 (con_alts, maybe_deflt) = findDefault alts
410 -- Check that successive alternatives have increasing tags
411 increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest
412 increasing_tag other = True
414 non_deflt (DEFAULT, _, _) = False
417 is_infinite_ty = case splitTyConApp_maybe ty of
419 Just (tycon, tycon_arg_tys) -> isPrimTyCon tycon
423 checkAltExpr :: CoreExpr -> OutType -> LintM ()
424 checkAltExpr expr ann_ty
425 = do { actual_ty <- lintCoreExpr expr
426 ; checkTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) }
428 lintCoreAlt :: OutType -- Type of scrutinee
429 -> OutType -- Type of the alternative
433 lintCoreAlt scrut_ty alt_ty alt@(DEFAULT, args, rhs) =
434 do { checkL (null args) (mkDefaultArgsMsg args)
435 ; checkAltExpr rhs alt_ty }
437 lintCoreAlt scrut_ty alt_ty alt@(LitAlt lit, args, rhs) =
438 do { checkL (null args) (mkDefaultArgsMsg args)
439 ; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty)
440 ; checkAltExpr rhs alt_ty }
442 lit_ty = literalType lit
444 lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
445 | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty,
446 tycon == dataConTyCon con
447 = addLoc (CaseAlt alt) $
448 addInScopeVars args $ -- Put the args in scope before lintBinder,
449 -- because the Ids mention the type variables
450 if isVanillaDataCon con then
451 do { mapM lintBinder args
452 -- FIX! Add check that all args are Ids.
454 -- Scrutinee type must be a tycon applicn; checked by caller
455 -- This code is remarkably compact considering what it does!
456 -- NB: args must be in scope here so that the lintCoreArgs line works.
457 -- NB: relies on existential type args coming *after* ordinary type args
459 ; con_type <- lintTyApps (dataConRepType con) tycon_arg_tys
460 -- Can just map Var as we know that this is a vanilla datacon
461 ; con_result_ty <- lintCoreArgs con_type (map Var args)
462 ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
464 ; checkAltExpr rhs alt_ty }
467 do { let (tvs,ids) = span isTyVar args
468 ; subst <- getTvSubst
469 ; let in_scope = getTvInScope subst
470 subst_env = getTvSubstEnv subst
471 ; case coreRefineTys in_scope con tvs scrut_ty of {
472 Nothing -> return () ; -- Alternative is dead code
473 Just (refine, _) -> updateTvSubstEnv (composeTvSubst in_scope refine subst_env) $
474 do { tvs' <- mapM lintTy (mkTyVarTys tvs)
475 ; con_type <- lintTyApps (dataConRepType con) tvs'
476 ; mapM lintBinder ids -- Lint Ids in the refined world
477 ; lintCoreArgs con_type (map Var ids)
478 ; let refined_alt_ty = substTy (mkTvSubst in_scope refine) alt_ty
479 -- alt_ty is already an OutType, so don't re-apply
480 -- the current substitution. But we must apply the
481 -- refinement so that the check in checkAltExpr is ok
482 ; checkAltExpr rhs refined_alt_ty
485 | otherwise -- Scrut-ty is wrong shape
486 = addErrL (mkBadAltMsg scrut_ty alt)
489 %************************************************************************
491 \subsection[lint-types]{Types}
493 %************************************************************************
496 lintBinder :: Var -> LintM ()
497 lintBinder var | isId var = lintId var >> return ()
498 | otherwise = return ()
500 lintId :: Var -> LintM OutType
501 -- ToDo: lint its rules
503 = do { checkL (not (isUnboxedTupleType (idType id)))
504 (mkUnboxedTupleMsg id)
505 -- No variable can be bound to an unboxed tuple.
506 ; lintTy (idType id) }
508 lintTy :: InType -> LintM OutType
509 -- Check the type, and apply the substitution to it
510 -- ToDo: check the kind structure of the type
512 = do { ty' <- applySubst ty
513 ; mapM_ checkIdInScope (varSetElems (tyVarsOfType ty'))
518 %************************************************************************
520 \subsection[lint-monad]{The Lint monad}
522 %************************************************************************
527 [LintLocInfo] -> -- Locations
528 TvSubst -> -- Current type substitution; we also use this
529 -- to keep track of all the variables in scope,
530 -- both Ids and TyVars
531 Bag Message -> -- Error messages so far
532 (Maybe a, Bag Message) } -- Result and error messages (if any)
534 instance Monad LintM where
535 return x = LintM (\ loc subst errs -> (Just x, errs))
536 fail err = LintM (\ loc subst errs -> (Nothing, addErr subst errs (text err) loc))
537 m >>= k = LintM (\ loc subst errs ->
538 let (res, errs') = unLintM m loc subst errs in
540 Just r -> unLintM (k r) loc subst errs'
541 Nothing -> (Nothing, errs'))
544 = RhsOf Id -- The variable bound
545 | LambdaBodyOf Id -- The lambda-binder
546 | BodyOfLetRec [Id] -- One of the binders
547 | CaseAlt CoreAlt -- Pattern of a case alternative
548 | AnExpr CoreExpr -- Some expression
549 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
554 initL :: LintM a -> Maybe Message {- errors -}
556 = case unLintM m [] emptyTvSubst emptyBag of
557 (_, errs) | isEmptyBag errs -> Nothing
558 | otherwise -> Just (vcat (punctuate (text "") (bagToList errs)))
562 checkL :: Bool -> Message -> LintM ()
563 checkL True msg = return ()
564 checkL False msg = addErrL msg
566 addErrL :: Message -> LintM a
567 addErrL msg = LintM (\ loc subst errs -> (Nothing, addErr subst errs msg loc))
569 addErr :: TvSubst -> Bag Message -> Message -> [LintLocInfo] -> Bag Message
570 addErr subst errs_so_far msg locs
571 = ASSERT( notNull locs )
572 errs_so_far `snocBag` mk_msg msg
574 (loc, cxt1) = dumpLoc (head locs)
575 cxts = [snd (dumpLoc loc) | loc <- locs]
576 context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$
577 ptext SLIT("Substitution:") <+> ppr subst
580 mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg)
582 addLoc :: LintLocInfo -> LintM a -> LintM a
584 LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs)
586 addInScopeVars :: [Var] -> LintM a -> LintM a
587 addInScopeVars vars m =
588 LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs)
590 updateTvSubstEnv :: TvSubstEnv -> LintM a -> LintM a
591 updateTvSubstEnv substenv m =
592 LintM (\ loc subst errs -> unLintM m loc (setTvSubstEnv subst substenv) errs)
594 getTvSubst :: LintM TvSubst
595 getTvSubst = LintM (\ loc subst errs -> (Just subst, errs))
597 applySubst :: Type -> LintM Type
598 applySubst ty = do { subst <- getTvSubst; return (substTy subst ty) }
600 extendSubstL :: TyVar -> Type -> LintM a -> LintM a
602 = LintM (\ loc subst errs -> unLintM m loc (extendTvSubst subst tv ty) errs)
606 checkIdInScope :: Var -> LintM ()
608 = do { checkL (not (id == oneTupleDataConId))
609 (ptext SLIT("Illegal one-tuple"))
610 ; checkInScope (ptext SLIT("is out of scope")) id }
612 oneTupleDataConId :: Id -- Should not happen
613 oneTupleDataConId = dataConWorkId (tupleCon Boxed 1)
615 checkBndrIdInScope :: Var -> Var -> LintM ()
616 checkBndrIdInScope binder id
617 = checkInScope msg id
619 msg = ptext SLIT("is out of scope inside info for") <+>
622 checkInScope :: SDoc -> Var -> LintM ()
623 checkInScope loc_msg var =
624 do { subst <- getTvSubst
625 ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
626 (hsep [ppr var, loc_msg]) }
628 checkTys :: Type -> Type -> Message -> LintM ()
629 -- check ty2 is subtype of ty1 (ie, has same structure but usage
630 -- annotations need only be consistent, not equal)
631 -- Assumes ty1,ty2 are have alrady had the substitution applied
632 checkTys ty1 ty2 msg = checkL (ty1 `coreEqType` ty2) msg
635 %************************************************************************
637 \subsection{Error messages}
639 %************************************************************************
643 = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))
645 dumpLoc (LambdaBodyOf b)
646 = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
648 dumpLoc (BodyOfLetRec [])
649 = (noSrcLoc, brackets (ptext SLIT("In body of a letrec with no binders")))
651 dumpLoc (BodyOfLetRec bs@(_:_))
652 = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
655 = (noSrcLoc, text "In the expression:" <+> ppr e)
657 dumpLoc (CaseAlt (con, args, rhs))
658 = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> ppr args))
660 dumpLoc (ImportedUnfolding locn)
661 = (locn, brackets (ptext SLIT("in an imported unfolding")))
663 pp_binders :: [Var] -> SDoc
664 pp_binders bs = sep (punctuate comma (map pp_binder bs))
666 pp_binder :: Var -> SDoc
667 pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)]
668 | isTyVar b = hsep [ppr b, dcolon, ppr (tyVarKind b)]
672 ------------------------------------------------------
673 -- Messages for case expressions
675 mkNullAltsMsg :: CoreExpr -> Message
677 = hang (text "Case expression with no alternatives:")
680 mkDefaultArgsMsg :: [Var] -> Message
681 mkDefaultArgsMsg args
682 = hang (text "DEFAULT case with binders")
685 mkCaseAltMsg :: CoreExpr -> Type -> Type -> Message
686 mkCaseAltMsg e ty1 ty2
687 = hang (text "Type of case alternatives not the same as the annotation on case:")
688 4 (vcat [ppr ty1, ppr ty2, ppr e])
690 mkScrutMsg :: Id -> Type -> Message
691 mkScrutMsg var scrut_ty
692 = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
693 text "Result binder type:" <+> ppr (idType var),
694 text "Scrutinee type:" <+> ppr scrut_ty]
698 = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
699 mkNonIncreasingAltsMsg e
700 = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)
702 nonExhaustiveAltsMsg :: CoreExpr -> Message
703 nonExhaustiveAltsMsg e
704 = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
706 mkBadPatMsg :: Type -> Type -> Message
707 mkBadPatMsg con_result_ty scrut_ty
709 text "In a case alternative, pattern result type doesn't match scrutinee type:",
710 text "Pattern result type:" <+> ppr con_result_ty,
711 text "Scrutinee type:" <+> ppr scrut_ty
714 mkBadAltMsg :: Type -> CoreAlt -> Message
715 mkBadAltMsg scrut_ty alt
716 = vcat [ text "Data alternative when scrutinee is not a tycon application",
717 text "Scrutinee type:" <+> ppr scrut_ty,
718 text "Alternative:" <+> pprCoreAlt alt ]
720 ------------------------------------------------------
721 -- Other error messages
723 mkAppMsg :: Type -> Type -> Message
725 = vcat [ptext SLIT("Argument value doesn't match argument type:"),
726 hang (ptext SLIT("Fun type:")) 4 (ppr fun),
727 hang (ptext SLIT("Arg type:")) 4 (ppr arg)]
729 mkKindErrMsg :: TyVar -> Type -> Message
730 mkKindErrMsg tyvar arg_ty
731 = vcat [ptext SLIT("Kinds don't match in type application:"),
732 hang (ptext SLIT("Type variable:"))
733 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
734 hang (ptext SLIT("Arg type:"))
735 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
737 mkTyAppMsg :: Type -> Type -> Message
739 = vcat [text "Illegal type application:",
740 hang (ptext SLIT("Exp type:"))
741 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
742 hang (ptext SLIT("Arg type:"))
743 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
745 mkRhsMsg :: Id -> Type -> Message
748 [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
750 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
751 hsep [ptext SLIT("Rhs type:"), ppr ty]]
753 mkRhsPrimMsg :: Id -> CoreExpr -> Message
754 mkRhsPrimMsg binder rhs
755 = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
757 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
760 mkUnboxedTupleMsg :: Id -> Message
761 mkUnboxedTupleMsg binder
762 = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
763 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
765 mkCoerceErr from_ty expr_ty
766 = vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"),
767 ptext SLIT("From-type:") <+> ppr from_ty,
768 ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
772 = ptext SLIT("Type where expression expected:") <+> ppr e