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 )
41 import StaticFlags ( opt_PprStyle_Debug )
42 import DynFlags ( DynFlags, DynFlag(..), dopt )
46 import Util ( notNull )
53 %************************************************************************
57 %************************************************************************
59 @showPass@ and @endPass@ don't really belong here, but it makes a convenient
60 place for them. They print out stuff before and after core passes,
61 and do Core Lint when necessary.
64 endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
65 endPass dflags pass_name dump_flag binds
67 -- Report result size if required
68 -- This has the side effect of forcing the intermediate to be evaluated
69 debugTraceMsg dflags 2 $
70 (text " Result size =" <+> int (coreBindsSize binds))
72 -- Report verbosely, if required
73 dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds)
76 lintCoreBindings dflags pass_name binds
82 %************************************************************************
84 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
86 %************************************************************************
88 Checks that a set of core bindings is well-formed. The PprStyle and String
89 just control what we print in the event of an error. The Bool value
90 indicates whether we have done any specialisation yet (in which case we do
95 (b) Out-of-scope type variables
96 (c) Out-of-scope local variables
99 If we have done specialisation the we check that there are
100 (a) No top-level bindings of primitive (unboxed type)
105 -- Things are *not* OK if:
107 -- * Unsaturated type app before specialisation has been done;
109 -- * Oversaturated type app after specialisation (eta reduction
110 -- may well be happening...);
113 lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
115 lintCoreBindings dflags whoDunnit binds
116 | not (dopt Opt_DoCoreLinting dflags)
119 lintCoreBindings dflags whoDunnit binds
120 = case (initL (lint_binds binds)) of
121 Nothing -> showPass dflags ("Core Linted result of " ++ whoDunnit)
122 Just bad_news -> printDump (display bad_news) >>
125 -- Put all the top-level binders in scope at the start
126 -- This is because transformation rules can bring something
127 -- into use 'unexpectedly'
128 lint_binds binds = addInScopeVars (bindersOfBinds binds) $
131 lint_bind (Rec prs) = mapM_ (lintSingleBinding Recursive) prs
132 lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
135 = vcat [ text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
137 ptext SLIT("*** Offending Program ***"),
138 pprCoreBindings binds,
139 ptext SLIT("*** End of Offense ***")
143 %************************************************************************
145 \subsection[lintUnfolding]{lintUnfolding}
147 %************************************************************************
149 We use this to check all unfoldings that come in from interfaces
150 (it is very painful to catch errors otherwise):
153 lintUnfolding :: SrcLoc
154 -> [Var] -- Treat these as in scope
156 -> Maybe Message -- Nothing => OK
158 lintUnfolding locn vars expr
159 = initL (addLoc (ImportedUnfolding locn) $
160 addInScopeVars vars $
164 %************************************************************************
166 \subsection[lintCoreBinding]{lintCoreBinding}
168 %************************************************************************
170 Check a core binding, returning the list of variables bound.
173 lintSingleBinding rec_flag (binder,rhs)
174 = addLoc (RhsOf binder) $
176 do { ty <- lintCoreExpr rhs
177 ; lintBinder binder -- Check match to RHS type
178 ; binder_ty <- applySubst binder_ty
179 ; checkTys binder_ty ty (mkRhsMsg binder ty)
180 -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
181 ; checkL (not (isUnLiftedType binder_ty)
182 || (isNonRec rec_flag && exprOkForSpeculation rhs))
183 (mkRhsPrimMsg binder rhs)
184 -- Check whether binder's specialisations contain any out-of-scope variables
185 ; mapM_ (checkBndrIdInScope binder) bndr_vars }
187 -- We should check the unfolding, if any, but this is tricky because
188 -- the unfolding is a SimplifiableCoreExpr. Give up for now.
190 binder_ty = idType binder
191 bndr_vars = varSetElems (idFreeVars binder)
194 %************************************************************************
196 \subsection[lintCoreExpr]{lintCoreExpr}
198 %************************************************************************
201 type InType = Type -- Substitution not yet applied
202 type OutType = Type -- Substitution has been applied to this
204 lintCoreExpr :: CoreExpr -> LintM OutType
205 -- The returned type has the substitution from the monad
206 -- already applied to it:
207 -- lintCoreExpr e subst = exprType (subst e)
209 lintCoreExpr (Var var)
210 = do { checkIdInScope var
211 ; applySubst (idType var) }
213 lintCoreExpr (Lit lit)
214 = return (literalType lit)
216 lintCoreExpr (Note (Coerce to_ty from_ty) expr)
217 = do { expr_ty <- lintCoreExpr expr
218 ; to_ty <- lintTy to_ty
219 ; from_ty <- lintTy from_ty
220 ; checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty)
223 lintCoreExpr (Note other_note expr)
226 lintCoreExpr (Let (NonRec bndr rhs) body)
227 = do { lintSingleBinding NonRecursive (bndr,rhs)
228 ; addLoc (BodyOfLetRec [bndr])
229 (addInScopeVars [bndr] (lintCoreExpr body)) }
231 lintCoreExpr (Let (Rec pairs) body)
232 = addInScopeVars bndrs $
233 do { mapM (lintSingleBinding Recursive) pairs
234 ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
236 bndrs = map fst pairs
238 lintCoreExpr e@(App fun (Type ty))
239 -- This is like 'let' for types
240 -- It's needed when dealing with desugarer output for GADTs. Consider
241 -- data T = forall a. T a (a->Int) Bool
243 -- f (T x f True) = <e1>
244 -- f (T y g False) = <e2>
245 -- After desugaring we get
247 -- T a (x::a) (f::a->Int) (b:Bool) ->
250 -- False -> (/\b. let y=x; g=f in <e2>) a
251 -- And for a reason I now forget, the ...<e2>... can mention a; so
252 -- we want Lint to know that b=a. Ugh.
254 -- I tried quite hard to make the necessity for this go away, by changing the
255 -- desugarer, but the fundamental problem is this:
257 -- T a (x::a) (y::Int) -> let fail::a = ...
258 -- in (/\b. ...(case ... of
262 -- Now the inner case look as though it has incompatible branches.
263 = addLoc (AnExpr e) $
266 go (App fun (Type ty)) tys
267 = do { go fun (ty:tys) }
268 go (Lam tv body) (ty:tys)
269 = do { checkL (isTyVar tv) (mkKindErrMsg tv ty) -- Not quite accurate
272 -- Now extend the substitution so we
273 -- take advantage of it in the body
274 ; addInScopeVars [tv] $
275 extendSubstL tv ty' $
278 = do { fun_ty <- lintCoreExpr fun
279 ; lintCoreArgs fun_ty (map Type tys) }
281 lintCoreExpr e@(App fun arg)
282 = do { fun_ty <- lintCoreExpr fun
283 ; addLoc (AnExpr e) $
284 lintCoreArg fun_ty arg }
286 lintCoreExpr (Lam var expr)
287 = addLoc (LambdaBodyOf var) $
288 do { body_ty <- addInScopeVars [var] $
290 ; if isId var then do
291 { var_ty <- lintId var
292 ; return (mkFunTy var_ty body_ty) }
294 return (mkForAllTy var body_ty)
296 -- The applySubst is needed to apply the subst to var
298 lintCoreExpr e@(Case scrut var alt_ty alts) =
299 -- Check the scrutinee
300 do { scrut_ty <- lintCoreExpr scrut
301 ; alt_ty <- lintTy alt_ty
302 ; var_ty <- lintTy (idType var)
303 -- Don't use lintId on var, because unboxed tuple is legitimate
305 ; checkTys var_ty scrut_ty (mkScrutMsg var scrut_ty)
307 -- If the binder is an unboxed tuple type, don't put it in scope
308 ; let vars = if (isUnboxedTupleType (idType var)) then [] else [var]
309 ; addInScopeVars vars $
310 do { -- Check the alternatives
311 checkCaseAlts e scrut_ty alts
312 ; mapM (lintCoreAlt scrut_ty alt_ty) alts
315 lintCoreExpr e@(Type ty)
316 = addErrL (mkStrangeTyMsg e)
319 %************************************************************************
321 \subsection[lintCoreArgs]{lintCoreArgs}
323 %************************************************************************
325 The basic version of these functions checks that the argument is a
326 subtype of the required type, as one would expect.
329 lintCoreArgs :: Type -> [CoreArg] -> LintM Type
330 lintCoreArg :: Type -> CoreArg -> LintM Type
331 -- First argument has already had substitution applied to it
335 lintCoreArgs ty [] = return ty
336 lintCoreArgs ty (a : args) =
337 do { res <- lintCoreArg ty a
338 ; lintCoreArgs res args }
340 lintCoreArg fun_ty a@(Type arg_ty) =
341 do { arg_ty <- lintTy arg_ty
342 ; lintTyApp fun_ty arg_ty }
344 lintCoreArg fun_ty arg =
345 -- Make sure function type matches argument
346 do { arg_ty <- lintCoreExpr arg
347 ; let err = mkAppMsg fun_ty arg_ty arg
348 ; case splitFunTy_maybe fun_ty of
350 do { checkTys arg arg_ty err
356 -- Both args have had substitution applied
358 = case splitForAllTy_maybe ty of
359 Nothing -> addErrL (mkTyAppMsg ty arg_ty)
362 -> do { checkL (isTyVar tyvar) (mkTyAppMsg ty arg_ty)
363 ; checkKinds tyvar arg_ty
364 ; return (substTyWith [tyvar] [arg_ty] body) }
366 lintTyApps fun_ty [] = return fun_ty
368 lintTyApps fun_ty (arg_ty : arg_tys) =
369 do { fun_ty' <- lintTyApp fun_ty arg_ty
370 ; lintTyApps fun_ty' arg_tys }
372 checkKinds tyvar arg_ty
373 -- Arg type might be boxed for a function with an uncommitted
374 -- tyvar; notably this is used so that we can give
375 -- error :: forall a:*. String -> a
376 -- and then apply it to both boxed and unboxed types.
377 = checkL (argty_kind `isSubKind` tyvar_kind)
378 (mkKindErrMsg tyvar arg_ty)
380 tyvar_kind = tyVarKind tyvar
381 argty_kind = typeKind arg_ty
385 %************************************************************************
387 \subsection[lintCoreAlts]{lintCoreAlts}
389 %************************************************************************
392 checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
393 -- a) Check that the alts are non-empty
394 -- b1) Check that the DEFAULT comes first, if it exists
395 -- b2) Check that the others are in increasing order
396 -- c) Check that there's a default for infinite types
397 -- NB: Algebraic cases are not necessarily exhaustive, because
398 -- the simplifer correctly eliminates case that can't
401 checkCaseAlts e ty []
402 = addErrL (mkNullAltsMsg e)
404 checkCaseAlts e ty alts =
405 do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
406 ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
407 ; checkL (isJust maybe_deflt || not is_infinite_ty)
408 (nonExhaustiveAltsMsg e) }
410 (con_alts, maybe_deflt) = findDefault alts
412 -- Check that successive alternatives have increasing tags
413 increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest
414 increasing_tag other = True
416 non_deflt (DEFAULT, _, _) = False
419 is_infinite_ty = case splitTyConApp_maybe ty of
421 Just (tycon, tycon_arg_tys) -> isPrimTyCon tycon
425 checkAltExpr :: CoreExpr -> OutType -> LintM ()
426 checkAltExpr expr ann_ty
427 = do { actual_ty <- lintCoreExpr expr
428 ; checkTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) }
430 lintCoreAlt :: OutType -- Type of scrutinee
431 -> OutType -- Type of the alternative
435 lintCoreAlt scrut_ty alt_ty alt@(DEFAULT, args, rhs) =
436 do { checkL (null args) (mkDefaultArgsMsg args)
437 ; checkAltExpr rhs alt_ty }
439 lintCoreAlt scrut_ty alt_ty alt@(LitAlt lit, args, rhs) =
440 do { checkL (null args) (mkDefaultArgsMsg args)
441 ; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty)
442 ; checkAltExpr rhs alt_ty }
444 lit_ty = literalType lit
446 lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
447 | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty,
448 tycon == dataConTyCon con
449 = addLoc (CaseAlt alt) $
450 addInScopeVars args $ -- Put the args in scope before lintBinder,
451 -- because the Ids mention the type variables
452 if isVanillaDataCon con then
453 do { addLoc (CasePat alt) $ do
454 { mapM lintBinder args
455 -- FIX! Add check that all args are Ids.
457 -- Scrutinee type must be a tycon applicn; checked by caller
458 -- This code is remarkably compact considering what it does!
459 -- NB: args must be in scope here so that the lintCoreArgs line works.
460 -- NB: relies on existential type args coming *after* ordinary type args
462 ; con_type <- lintTyApps (dataConRepType con) tycon_arg_tys
463 -- Can just map Var as we know that this is a vanilla datacon
464 ; con_result_ty <- lintCoreArgs con_type (map Var args)
465 ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
468 ; checkAltExpr rhs alt_ty }
471 do { let (tvs,ids) = span isTyVar args
472 ; subst <- getTvSubst
473 ; let in_scope = getTvInScope subst
474 subst_env = getTvSubstEnv subst
475 ; case coreRefineTys con tvs scrut_ty of {
476 Nothing -> return () ; -- Alternative is dead code
477 Just (refine, _) -> updateTvSubstEnv (composeTvSubst in_scope refine subst_env) $
478 do { addLoc (CasePat alt) $ do
479 { tvs' <- mapM lintTy (mkTyVarTys tvs)
480 ; con_type <- lintTyApps (dataConRepType con) tvs'
481 ; mapM lintBinder ids -- Lint Ids in the refined world
482 ; lintCoreArgs con_type (map Var ids)
485 ; let refined_alt_ty = substTy (mkTvSubst in_scope refine) alt_ty
486 -- alt_ty is already an OutType, so don't re-apply
487 -- the current substitution. But we must apply the
488 -- refinement so that the check in checkAltExpr is ok
489 ; checkAltExpr rhs refined_alt_ty
492 | otherwise -- Scrut-ty is wrong shape
493 = addErrL (mkBadAltMsg scrut_ty alt)
496 %************************************************************************
498 \subsection[lint-types]{Types}
500 %************************************************************************
503 lintBinder :: Var -> LintM ()
504 lintBinder var | isId var = lintId var >> return ()
505 | otherwise = return ()
507 lintId :: Var -> LintM OutType
508 -- ToDo: lint its rules
510 = do { checkL (not (isUnboxedTupleType (idType id)))
511 (mkUnboxedTupleMsg id)
512 -- No variable can be bound to an unboxed tuple.
513 ; lintTy (idType id) }
515 lintTy :: InType -> LintM OutType
516 -- Check the type, and apply the substitution to it
517 -- ToDo: check the kind structure of the type
519 = do { ty' <- applySubst ty
520 ; mapM_ checkIdInScope (varSetElems (tyVarsOfType ty'))
525 %************************************************************************
527 \subsection[lint-monad]{The Lint monad}
529 %************************************************************************
534 [LintLocInfo] -> -- Locations
535 TvSubst -> -- Current type substitution; we also use this
536 -- to keep track of all the variables in scope,
537 -- both Ids and TyVars
538 Bag Message -> -- Error messages so far
539 (Maybe a, Bag Message) } -- Result and error messages (if any)
541 instance Monad LintM where
542 return x = LintM (\ loc subst errs -> (Just x, errs))
543 fail err = LintM (\ loc subst errs -> (Nothing, addErr subst errs (text err) loc))
544 m >>= k = LintM (\ loc subst errs ->
545 let (res, errs') = unLintM m loc subst errs in
547 Just r -> unLintM (k r) loc subst errs'
548 Nothing -> (Nothing, errs'))
551 = RhsOf Id -- The variable bound
552 | LambdaBodyOf Id -- The lambda-binder
553 | BodyOfLetRec [Id] -- One of the binders
554 | CaseAlt CoreAlt -- Case alternative
555 | CasePat CoreAlt -- *Pattern* of the case alternative
556 | AnExpr CoreExpr -- Some expression
557 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
562 initL :: LintM a -> Maybe Message {- errors -}
564 = case unLintM m [] emptyTvSubst emptyBag of
565 (_, errs) | isEmptyBag errs -> Nothing
566 | otherwise -> Just (vcat (punctuate (text "") (bagToList errs)))
570 checkL :: Bool -> Message -> LintM ()
571 checkL True msg = return ()
572 checkL False msg = addErrL msg
574 addErrL :: Message -> LintM a
575 addErrL msg = LintM (\ loc subst errs -> (Nothing, addErr subst errs msg loc))
577 addErr :: TvSubst -> Bag Message -> Message -> [LintLocInfo] -> Bag Message
578 addErr subst errs_so_far msg locs
579 = ASSERT( notNull locs )
580 errs_so_far `snocBag` mk_msg msg
582 (loc, cxt1) = dumpLoc (head locs)
583 cxts = [snd (dumpLoc loc) | loc <- locs]
584 context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$
585 ptext SLIT("Substitution:") <+> ppr subst
588 mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg)
590 addLoc :: LintLocInfo -> LintM a -> LintM a
592 LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs)
594 addInScopeVars :: [Var] -> LintM a -> LintM a
595 addInScopeVars vars m =
596 LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs)
598 updateTvSubstEnv :: TvSubstEnv -> LintM a -> LintM a
599 updateTvSubstEnv substenv m =
600 LintM (\ loc subst errs -> unLintM m loc (setTvSubstEnv subst substenv) errs)
602 getTvSubst :: LintM TvSubst
603 getTvSubst = LintM (\ loc subst errs -> (Just subst, errs))
605 applySubst :: Type -> LintM Type
606 applySubst ty = do { subst <- getTvSubst; return (substTy subst ty) }
608 extendSubstL :: TyVar -> Type -> LintM a -> LintM a
610 = LintM (\ loc subst errs -> unLintM m loc (extendTvSubst subst tv ty) errs)
614 checkIdInScope :: Var -> LintM ()
616 = do { checkL (not (id == oneTupleDataConId))
617 (ptext SLIT("Illegal one-tuple"))
618 ; checkInScope (ptext SLIT("is out of scope")) id }
620 oneTupleDataConId :: Id -- Should not happen
621 oneTupleDataConId = dataConWorkId (tupleCon Boxed 1)
623 checkBndrIdInScope :: Var -> Var -> LintM ()
624 checkBndrIdInScope binder id
625 = checkInScope msg id
627 msg = ptext SLIT("is out of scope inside info for") <+>
630 checkInScope :: SDoc -> Var -> LintM ()
631 checkInScope loc_msg var =
632 do { subst <- getTvSubst
633 ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
634 (hsep [ppr var, loc_msg]) }
636 checkTys :: Type -> Type -> Message -> LintM ()
637 -- check ty2 is subtype of ty1 (ie, has same structure but usage
638 -- annotations need only be consistent, not equal)
639 -- Assumes ty1,ty2 are have alrady had the substitution applied
640 checkTys ty1 ty2 msg = checkL (ty1 `coreEqType` ty2) msg
643 %************************************************************************
645 \subsection{Error messages}
647 %************************************************************************
651 = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))
653 dumpLoc (LambdaBodyOf b)
654 = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
656 dumpLoc (BodyOfLetRec [])
657 = (noSrcLoc, brackets (ptext SLIT("In body of a letrec with no binders")))
659 dumpLoc (BodyOfLetRec bs@(_:_))
660 = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
663 = (noSrcLoc, text "In the expression:" <+> ppr e)
665 dumpLoc (CaseAlt (con, args, rhs))
666 = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args))
668 dumpLoc (CasePat (con, args, rhs))
669 = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args))
671 dumpLoc (ImportedUnfolding locn)
672 = (locn, brackets (ptext SLIT("in an imported unfolding")))
674 pp_binders :: [Var] -> SDoc
675 pp_binders bs = sep (punctuate comma (map pp_binder bs))
677 pp_binder :: Var -> SDoc
678 pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)]
679 | isTyVar b = hsep [ppr b, dcolon, ppr (tyVarKind b)]
683 ------------------------------------------------------
684 -- Messages for case expressions
686 mkNullAltsMsg :: CoreExpr -> Message
688 = hang (text "Case expression with no alternatives:")
691 mkDefaultArgsMsg :: [Var] -> Message
692 mkDefaultArgsMsg args
693 = hang (text "DEFAULT case with binders")
696 mkCaseAltMsg :: CoreExpr -> Type -> Type -> Message
697 mkCaseAltMsg e ty1 ty2
698 = hang (text "Type of case alternatives not the same as the annotation on case:")
699 4 (vcat [ppr ty1, ppr ty2, ppr e])
701 mkScrutMsg :: Id -> Type -> Message
702 mkScrutMsg var scrut_ty
703 = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
704 text "Result binder type:" <+> ppr (idType var),
705 text "Scrutinee type:" <+> ppr scrut_ty]
709 = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
710 mkNonIncreasingAltsMsg e
711 = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)
713 nonExhaustiveAltsMsg :: CoreExpr -> Message
714 nonExhaustiveAltsMsg e
715 = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
717 mkBadPatMsg :: Type -> Type -> Message
718 mkBadPatMsg con_result_ty scrut_ty
720 text "In a case alternative, pattern result type doesn't match scrutinee type:",
721 text "Pattern result type:" <+> ppr con_result_ty,
722 text "Scrutinee type:" <+> ppr scrut_ty
725 mkBadAltMsg :: Type -> CoreAlt -> Message
726 mkBadAltMsg scrut_ty alt
727 = vcat [ text "Data alternative when scrutinee is not a tycon application",
728 text "Scrutinee type:" <+> ppr scrut_ty,
729 text "Alternative:" <+> pprCoreAlt alt ]
731 ------------------------------------------------------
732 -- Other error messages
734 mkAppMsg :: Type -> Type -> CoreExpr -> Message
735 mkAppMsg fun_ty arg_ty arg
736 = vcat [ptext SLIT("Argument value doesn't match argument type:"),
737 hang (ptext SLIT("Fun type:")) 4 (ppr fun_ty),
738 hang (ptext SLIT("Arg type:")) 4 (ppr arg_ty),
739 hang (ptext SLIT("Arg:")) 4 (ppr arg)]
741 mkKindErrMsg :: TyVar -> Type -> Message
742 mkKindErrMsg tyvar arg_ty
743 = vcat [ptext SLIT("Kinds don't match in type application:"),
744 hang (ptext SLIT("Type variable:"))
745 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
746 hang (ptext SLIT("Arg type:"))
747 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
749 mkTyAppMsg :: Type -> Type -> Message
751 = vcat [text "Illegal type application:",
752 hang (ptext SLIT("Exp type:"))
753 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
754 hang (ptext SLIT("Arg type:"))
755 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
757 mkRhsMsg :: Id -> Type -> Message
760 [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
762 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
763 hsep [ptext SLIT("Rhs type:"), ppr ty]]
765 mkRhsPrimMsg :: Id -> CoreExpr -> Message
766 mkRhsPrimMsg binder rhs
767 = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
769 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
772 mkUnboxedTupleMsg :: Id -> Message
773 mkUnboxedTupleMsg binder
774 = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
775 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
777 mkCoerceErr from_ty expr_ty
778 = vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"),
779 ptext SLIT("From-type:") <+> ppr from_ty,
780 ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
784 = ptext SLIT("Type where expression expected:") <+> ppr e