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, 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 %************************************************************************
201 lintCoreExpr :: CoreExpr -> LintM Type
202 -- The returned type has the substitution from the monad
203 -- already applied to it:
204 -- lintCoreExpr e subst = exprType (subst e)
206 lintCoreExpr (Var var)
207 = do { checkIdInScope var
208 ; applySubst (idType var) }
210 lintCoreExpr (Lit lit)
211 = return (literalType lit)
213 lintCoreExpr (Note (Coerce to_ty from_ty) expr)
214 = do { expr_ty <- lintCoreExpr expr
215 ; to_ty <- lintTy to_ty
216 ; from_ty <- lintTy from_ty
217 ; checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty)
220 lintCoreExpr (Note other_note expr)
223 lintCoreExpr (Let (NonRec bndr rhs) body)
224 = do { lintSingleBinding NonRecursive (bndr,rhs)
225 ; addLoc (BodyOfLetRec [bndr])
226 (addInScopeVars [bndr] (lintCoreExpr body)) }
228 lintCoreExpr (Let (Rec pairs) body)
229 = addInScopeVars bndrs $
230 do { mapM (lintSingleBinding Recursive) pairs
231 ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
233 bndrs = map fst pairs
235 lintCoreExpr (App fun (Type ty))
236 -- This is like 'let' for types
237 -- It's needed when dealing with desugarer output for GADTs. Consider
238 -- data T = forall a. T a (a->Int) Bool
240 -- f (T x f True) = <e1>
241 -- f (T y g False) = <e2>
242 -- After desugaring we get
244 -- T a (x::a) (f::a->Int) (b:Bool) ->
247 -- False -> (/\b. let y=x; g=f in <e2>) a
248 -- And for a reason I now forget, the ...<e2>... can mention a; so
249 -- we want Lint to know that b=a. Ugh.
251 -- I tried quite hard to make the necessity for this go away, by changing the
252 -- desugarer, but the fundamental problem is this:
254 -- T a (x::a) (y::Int) -> let fail::a = ...
255 -- in (/\b. ...(case ... of
259 -- Now the inner case look as though it has incompatible branches.
262 go (App fun (Type ty)) tys
263 = do { go fun (ty:tys) }
264 go (Lam tv body) (ty:tys)
265 = do { checkL (isTyVar tv) (mkKindErrMsg tv ty) -- Not quite accurate
268 -- Now extend the substitution so we
269 -- take advantage of it in the body
270 ; addInScopeVars [tv] $
271 extendSubstL tv ty' $
274 = do { fun_ty <- lintCoreExpr fun
275 ; lintCoreArgs fun_ty (map Type tys) }
277 lintCoreExpr e@(App fun arg)
278 = do { ty <- lintCoreExpr fun
279 ; addLoc (AnExpr e) $
282 lintCoreExpr (Lam var expr)
283 = addLoc (LambdaBodyOf var) $
285 ; ty <- addInScopeVars [var] $
287 ; applySubst (mkPiType var ty) }
288 -- The applySubst is needed to apply the subst to var
290 lintCoreExpr e@(Case scrut var alt_ty alts) =
291 -- Check the scrutinee
292 do { scrut_ty <- lintCoreExpr scrut
293 ; alt_ty <- lintTy alt_ty
294 ; var_ty <- lintTy (idType var)
295 -- Don't use lintId on var, because unboxed tuple is legitimate
297 ; checkTys var_ty scrut_ty (mkScrutMsg var scrut_ty)
299 -- If the binder is an unboxed tuple type, don't put it in scope
300 ; let vars = if (isUnboxedTupleType (idType var)) then [] else [var]
301 ; addInScopeVars vars $
302 do { -- Check the alternatives
303 checkCaseAlts e scrut_ty alts
304 ; mapM (lintCoreAlt scrut_ty alt_ty) alts
307 lintCoreExpr e@(Type ty)
308 = addErrL (mkStrangeTyMsg e)
311 %************************************************************************
313 \subsection[lintCoreArgs]{lintCoreArgs}
315 %************************************************************************
317 The basic version of these functions checks that the argument is a
318 subtype of the required type, as one would expect.
321 lintCoreArgs :: Type -> [CoreArg] -> LintM Type
322 lintCoreArg :: Type -> CoreArg -> LintM Type
323 -- First argument has already had substitution applied to it
327 lintCoreArgs ty [] = return ty
328 lintCoreArgs ty (a : args) =
329 do { res <- lintCoreArg ty a
330 ; lintCoreArgs res args }
332 lintCoreArg ty a@(Type arg_ty) =
333 do { arg_ty <- lintTy arg_ty
334 ; lintTyApp ty arg_ty }
336 lintCoreArg fun_ty arg =
337 -- Make sure function type matches argument
338 do { arg_ty <- lintCoreExpr arg
339 ; let err = mkAppMsg fun_ty arg_ty
340 ; case splitFunTy_maybe fun_ty of
342 do { checkTys arg arg_ty err
348 -- Both args have had substitution applied
350 = case splitForAllTy_maybe ty of
351 Nothing -> addErrL (mkTyAppMsg ty arg_ty)
354 -> do { checkL (isTyVar tyvar) (mkTyAppMsg ty arg_ty)
355 ; checkKinds tyvar arg_ty
356 ; return (substTyWith [tyvar] [arg_ty] body) }
358 lintTyApps fun_ty [] = return fun_ty
360 lintTyApps fun_ty (arg_ty : arg_tys) =
361 do { fun_ty' <- lintTyApp fun_ty arg_ty
362 ; lintTyApps fun_ty' arg_tys }
364 checkKinds tyvar arg_ty
365 -- Arg type might be boxed for a function with an uncommitted
366 -- tyvar; notably this is used so that we can give
367 -- error :: forall a:*. String -> a
368 -- and then apply it to both boxed and unboxed types.
369 = checkL (argty_kind `isSubKind` tyvar_kind)
370 (mkKindErrMsg tyvar arg_ty)
372 tyvar_kind = tyVarKind tyvar
373 argty_kind = typeKind arg_ty
377 %************************************************************************
379 \subsection[lintCoreAlts]{lintCoreAlts}
381 %************************************************************************
384 checkCaseAlts :: CoreExpr -> Type -> [CoreAlt] -> LintM ()
385 -- a) Check that the alts are non-empty
386 -- b1) Check that the DEFAULT comes first, if it exists
387 -- b2) Check that the others are in increasing order
388 -- c) Check that there's a default for infinite types
389 -- NB: Algebraic cases are not necessarily exhaustive, because
390 -- the simplifer correctly eliminates case that can't
393 checkCaseAlts e ty []
394 = addErrL (mkNullAltsMsg e)
396 checkCaseAlts e ty alts =
397 do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
398 ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
399 ; checkL (isJust maybe_deflt || not is_infinite_ty)
400 (nonExhaustiveAltsMsg e) }
402 (con_alts, maybe_deflt) = findDefault alts
404 -- Check that successive alternatives have increasing tags
405 increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest
406 increasing_tag other = True
408 non_deflt (DEFAULT, _, _) = False
411 is_infinite_ty = case splitTyConApp_maybe ty of
413 Just (tycon, tycon_arg_tys) -> isPrimTyCon tycon
417 checkAltExpr :: CoreExpr -> Type -> LintM ()
419 = do { actual_ty <- lintCoreExpr expr
420 ; ty' <- applySubst ty
421 ; checkTys actual_ty ty' (mkCaseAltMsg expr actual_ty ty') }
423 lintCoreAlt :: Type -- Type of scrutinee; a fixed point of
425 -> Type -- Type of the alternative
429 lintCoreAlt scrut_ty alt_ty alt@(DEFAULT, args, rhs) =
430 do { checkL (null args) (mkDefaultArgsMsg args)
431 ; checkAltExpr rhs alt_ty }
433 lintCoreAlt scrut_ty alt_ty alt@(LitAlt lit, args, rhs) =
434 do { checkL (null args) (mkDefaultArgsMsg args)
435 ; checkTys lit_ty scrut_ty
436 (mkBadPatMsg lit_ty scrut_ty)
437 ; checkAltExpr rhs alt_ty }
439 lit_ty = literalType lit
441 lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
442 | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty,
443 tycon == dataConTyCon con
444 = addLoc (CaseAlt alt) $
445 addInScopeVars args $ -- Put the args in scope before lintBinder,
446 -- because the Ids mention the type variables
447 if isVanillaDataCon con then
448 do { mapM lintBinder args
449 -- FIX! Add check that all args are Ids.
451 -- Scrutinee type must be a tycon applicn; checked by caller
452 -- This code is remarkably compact considering what it does!
453 -- NB: args must be in scope here so that the lintCoreArgs line works.
454 -- NB: relies on existential type args coming *after* ordinary type args
456 ; con_type <- lintTyApps (dataConRepType con) tycon_arg_tys
457 -- Can just map Var as we know that this is a vanilla datacon
458 ; con_result_ty <- lintCoreArgs con_type (map Var args)
459 ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
461 ; checkAltExpr rhs alt_ty }
464 do { let (tvs,ids) = span isTyVar args
465 pat_res_ty = dataConResTy con (mkTyVarTys tvs)
467 ; subst <- getTvSubst
468 ; let in_scope = getTvInScope subst
469 subst_env = getTvSubstEnv subst
470 ; case coreRefineTys in_scope tvs pat_res_ty scrut_ty of {
471 Nothing -> return () ; -- Alternative is dead code
472 Just refine -> updateTvSubstEnv (composeTvSubst in_scope refine subst_env) $
473 do { tvs' <- mapM lintTy (mkTyVarTys tvs)
474 ; con_type <- lintTyApps (dataConRepType con) tvs'
475 ; mapM lintBinder ids -- Lint Ids in the refined world
476 ; lintCoreArgs con_type (map Var ids)
477 ; checkAltExpr rhs alt_ty
480 | otherwise -- Scrut-ty is wrong shape
481 = addErrL (mkBadAltMsg scrut_ty alt)
484 %************************************************************************
486 \subsection[lint-types]{Types}
488 %************************************************************************
491 lintBinder :: Var -> LintM ()
492 lintBinder var | isId var = lintId var >> return ()
493 | otherwise = return ()
495 lintId :: Var -> LintM Type
496 -- ToDo: lint its rules
498 = do { checkL (not (isUnboxedTupleType (idType id)))
499 (mkUnboxedTupleMsg id)
500 -- No variable can be bound to an unboxed tuple.
501 ; lintTy (idType id) }
503 lintTy :: Type -> LintM Type
504 -- Check the type, and apply the substitution to it
505 -- ToDo: check the kind structure of the type
507 = do { ty' <- applySubst ty
508 ; mapM_ checkIdInScope (varSetElems (tyVarsOfType ty'))
513 %************************************************************************
515 \subsection[lint-monad]{The Lint monad}
517 %************************************************************************
522 [LintLocInfo] -> -- Locations
523 TvSubst -> -- Current type substitution; we also use this
524 -- to keep track of all the variables in scope,
525 -- both Ids and TyVars
526 Bag Message -> -- Error messages so far
527 (Maybe a, Bag Message) } -- Result and error messages (if any)
529 instance Monad LintM where
530 return x = LintM (\ loc subst errs -> (Just x, errs))
531 fail err = LintM (\ loc subst errs -> (Nothing, addErr subst errs (text err) loc))
532 m >>= k = LintM (\ loc subst errs ->
533 let (res, errs') = unLintM m loc subst errs in
535 Just r -> unLintM (k r) loc subst errs'
536 Nothing -> (Nothing, errs'))
539 = RhsOf Id -- The variable bound
540 | LambdaBodyOf Id -- The lambda-binder
541 | BodyOfLetRec [Id] -- One of the binders
542 | CaseAlt CoreAlt -- Pattern of a case alternative
543 | AnExpr CoreExpr -- Some expression
544 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
549 initL :: LintM a -> Maybe Message {- errors -}
551 = case unLintM m [] emptyTvSubst emptyBag of
552 (_, errs) | isEmptyBag errs -> Nothing
553 | otherwise -> Just (vcat (punctuate (text "") (bagToList errs)))
557 checkL :: Bool -> Message -> LintM ()
558 checkL True msg = return ()
559 checkL False msg = addErrL msg
561 addErrL :: Message -> LintM a
562 addErrL msg = LintM (\ loc subst errs -> (Nothing, addErr subst errs msg loc))
564 addErr :: TvSubst -> Bag Message -> Message -> [LintLocInfo] -> Bag Message
565 addErr subst errs_so_far msg locs
566 = ASSERT( notNull locs )
567 errs_so_far `snocBag` mk_msg msg
569 (loc, cxt1) = dumpLoc (head locs)
570 cxts = [snd (dumpLoc loc) | loc <- locs]
571 context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$
572 ptext SLIT("Substitution:") <+> ppr subst
575 mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg)
577 addLoc :: LintLocInfo -> LintM a -> LintM a
579 LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs)
581 addInScopeVars :: [Var] -> LintM a -> LintM a
582 addInScopeVars vars m =
583 LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs)
585 updateTvSubstEnv :: TvSubstEnv -> LintM a -> LintM a
586 updateTvSubstEnv substenv m =
587 LintM (\ loc subst errs -> unLintM m loc (setTvSubstEnv subst substenv) errs)
589 getTvSubst :: LintM TvSubst
590 getTvSubst = LintM (\ loc subst errs -> (Just subst, errs))
592 applySubst :: Type -> LintM Type
593 applySubst ty = do { subst <- getTvSubst; return (substTy subst ty) }
595 extendSubstL :: TyVar -> Type -> LintM a -> LintM a
597 = LintM (\ loc subst errs -> unLintM m loc (extendTvSubst subst tv ty) errs)
601 checkIdInScope :: Var -> LintM ()
603 = do { checkL (not (id == oneTupleDataConId))
604 (ptext SLIT("Illegal one-tuple"))
605 ; checkInScope (ptext SLIT("is out of scope")) id }
607 oneTupleDataConId :: Id -- Should not happen
608 oneTupleDataConId = dataConWorkId (tupleCon Boxed 1)
610 checkBndrIdInScope :: Var -> Var -> LintM ()
611 checkBndrIdInScope binder id
612 = checkInScope msg id
614 msg = ptext SLIT("is out of scope inside info for") <+>
617 checkInScope :: SDoc -> Var -> LintM ()
618 checkInScope loc_msg var =
619 do { subst <- getTvSubst
620 ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
621 (hsep [ppr var, loc_msg]) }
623 checkTys :: Type -> Type -> Message -> LintM ()
624 -- check ty2 is subtype of ty1 (ie, has same structure but usage
625 -- annotations need only be consistent, not equal)
626 -- Assumes ty1,ty2 are have alrady had the substitution applied
627 checkTys ty1 ty2 msg = checkL (ty1 `coreEqType` ty2) msg
630 %************************************************************************
632 \subsection{Error messages}
634 %************************************************************************
638 = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))
640 dumpLoc (LambdaBodyOf b)
641 = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
643 dumpLoc (BodyOfLetRec [])
644 = (noSrcLoc, brackets (ptext SLIT("In body of a letrec with no binders")))
646 dumpLoc (BodyOfLetRec bs@(_:_))
647 = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
650 = (noSrcLoc, text "In the expression:" <+> ppr e)
652 dumpLoc (CaseAlt (con, args, rhs))
653 = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> ppr args))
655 dumpLoc (ImportedUnfolding locn)
656 = (locn, brackets (ptext SLIT("in an imported unfolding")))
658 pp_binders :: [Var] -> SDoc
659 pp_binders bs = sep (punctuate comma (map pp_binder bs))
661 pp_binder :: Var -> SDoc
662 pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)]
663 | isTyVar b = hsep [ppr b, dcolon, ppr (tyVarKind b)]
667 ------------------------------------------------------
668 -- Messages for case expressions
670 mkNullAltsMsg :: CoreExpr -> Message
672 = hang (text "Case expression with no alternatives:")
675 mkDefaultArgsMsg :: [Var] -> Message
676 mkDefaultArgsMsg args
677 = hang (text "DEFAULT case with binders")
680 mkCaseAltMsg :: CoreExpr -> Type -> Type -> Message
681 mkCaseAltMsg e ty1 ty2
682 = hang (text "Type of case alternatives not the same as the annotation on case:")
683 4 (vcat [ppr ty1, ppr ty2, ppr e])
685 mkScrutMsg :: Id -> Type -> Message
686 mkScrutMsg var scrut_ty
687 = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
688 text "Result binder type:" <+> ppr (idType var),
689 text "Scrutinee type:" <+> ppr scrut_ty]
693 = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
694 mkNonIncreasingAltsMsg e
695 = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)
697 nonExhaustiveAltsMsg :: CoreExpr -> Message
698 nonExhaustiveAltsMsg e
699 = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
701 mkBadPatMsg :: Type -> Type -> Message
702 mkBadPatMsg con_result_ty scrut_ty
704 text "In a case alternative, pattern result type doesn't match scrutinee type:",
705 text "Pattern result type:" <+> ppr con_result_ty,
706 text "Scrutinee type:" <+> ppr scrut_ty
709 mkBadAltMsg :: Type -> CoreAlt -> Message
710 mkBadAltMsg scrut_ty alt
711 = vcat [ text "Data alternative when scrutinee is not a tycon application",
712 text "Scrutinee type:" <+> ppr scrut_ty,
713 text "Alternative:" <+> pprCoreAlt alt ]
715 ------------------------------------------------------
716 -- Other error messages
718 mkAppMsg :: Type -> Type -> Message
720 = vcat [ptext SLIT("Argument value doesn't match argument type:"),
721 hang (ptext SLIT("Fun type:")) 4 (ppr fun),
722 hang (ptext SLIT("Arg type:")) 4 (ppr arg)]
724 mkKindErrMsg :: TyVar -> Type -> Message
725 mkKindErrMsg tyvar arg_ty
726 = vcat [ptext SLIT("Kinds don't match in type application:"),
727 hang (ptext SLIT("Type variable:"))
728 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
729 hang (ptext SLIT("Arg type:"))
730 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
732 mkTyAppMsg :: Type -> Type -> Message
734 = vcat [text "Illegal type application:",
735 hang (ptext SLIT("Exp type:"))
736 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
737 hang (ptext SLIT("Arg type:"))
738 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
740 mkRhsMsg :: Id -> Type -> Message
743 [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
745 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
746 hsep [ptext SLIT("Rhs type:"), ppr ty]]
748 mkRhsPrimMsg :: Id -> CoreExpr -> Message
749 mkRhsPrimMsg binder rhs
750 = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
752 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
755 mkUnboxedTupleMsg :: Id -> Message
756 mkUnboxedTupleMsg binder
757 = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
758 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
760 mkCoerceErr from_ty expr_ty
761 = vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"),
762 ptext SLIT("From-type:") <+> ppr from_ty,
763 ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
767 = ptext SLIT("Type where expression expected:") <+> ppr e