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 )
19 import Literal ( literalType )
20 import DataCon ( dataConRepType, dataConTyCon, dataConWorkId )
21 import TysWiredIn ( tupleCon )
22 import Var ( Var, Id, TyVar, idType, tyVarKind, mustHaveLocalBinding, setTyVarKind, setIdType )
23 import VarEnv ( lookupInScope )
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, substTyVarBndr, isInScope,
38 getTvSubstEnv, getTvInScope, mkTyVarTy )
39 import Coercion ( Coercion, coercionKind )
40 import TyCon ( isPrimTyCon )
41 import BasicTypes ( RecFlag(..), Boxity(..), isNonRec )
42 import StaticFlags ( opt_PprStyle_Debug )
43 import DynFlags ( DynFlags, DynFlag(..), dopt )
47 import Util ( notNull )
54 %************************************************************************
58 %************************************************************************
60 @showPass@ and @endPass@ don't really belong here, but it makes a convenient
61 place for them. They print out stuff before and after core passes,
62 and do Core Lint when necessary.
65 endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
66 endPass dflags pass_name dump_flag binds
68 -- Report result size if required
69 -- This has the side effect of forcing the intermediate to be evaluated
70 debugTraceMsg dflags 2 $
71 (text " Result size =" <+> int (coreBindsSize binds))
73 -- Report verbosely, if required
74 dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds)
77 lintCoreBindings dflags pass_name binds
83 %************************************************************************
85 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
87 %************************************************************************
89 Checks that a set of core bindings is well-formed. The PprStyle and String
90 just control what we print in the event of an error. The Bool value
91 indicates whether we have done any specialisation yet (in which case we do
96 (b) Out-of-scope type variables
97 (c) Out-of-scope local variables
100 If we have done specialisation the we check that there are
101 (a) No top-level bindings of primitive (unboxed type)
106 -- Things are *not* OK if:
108 -- * Unsaturated type app before specialisation has been done;
110 -- * Oversaturated type app after specialisation (eta reduction
111 -- may well be happening...);
116 In the desugarer, it's very very convenient to be able to say (in effect)
117 let a = Int in <body>
118 That is, use a type let. (See notes just below for why we want this.)
120 We don't have type lets in Core, so the desugarer uses type lambda
122 However, in the lambda form, we'd get lint errors from:
123 (/\a. let x::a = 4 in <body>) Int
124 because (x::a) doesn't look compatible with (4::Int).
126 So (HACK ALERT) the Lint phase does type-beta reduction "on the fly",
127 as it were. It carries a type substitution (in this example [a -> Int])
128 and applies this substitution before comparing types. The functin
129 lintTy :: Type -> LintM Type
130 returns a substituted type; that's the only reason it returns anything.
132 When we encounter a binder (like x::a) we must apply the substitution
133 to the type of the binding variable. lintBinders does this.
135 For Ids, the type-substituted Id is added to the in_scope set (which
136 itself is part of the TvSubst we are carrying down), and when we
137 find an occurence of an Id, we fetch it from the in-scope set.
142 It's needed when dealing with desugarer output for GADTs. Consider
143 data T = forall a. T a (a->Int) Bool
145 f (T x f True) = <e1>
146 f (T y g False) = <e2>
147 After desugaring we get
149 T a (x::a) (f::a->Int) (b:Bool) ->
152 False -> (/\b. let y=x; g=f in <e2>) a
153 And for a reason I now forget, the ...<e2>... can mention a; so
154 we want Lint to know that b=a. Ugh.
156 I tried quite hard to make the necessity for this go away, by changing the
157 desugarer, but the fundamental problem is this:
159 T a (x::a) (y::Int) -> let fail::a = ...
160 in (/\b. ...(case ... of
164 Now the inner case look as though it has incompatible branches.
168 lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
170 lintCoreBindings dflags whoDunnit binds
171 | not (dopt Opt_DoCoreLinting dflags)
174 lintCoreBindings dflags whoDunnit binds
175 = case (initL (lint_binds binds)) of
176 Nothing -> showPass dflags ("Core Linted result of " ++ whoDunnit)
177 Just bad_news -> printDump (display bad_news) >>
180 -- Put all the top-level binders in scope at the start
181 -- This is because transformation rules can bring something
182 -- into use 'unexpectedly'
183 lint_binds binds = addInScopeVars (bindersOfBinds binds) $
186 lint_bind (Rec prs) = mapM_ (lintSingleBinding Recursive) prs
187 lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
190 = vcat [ text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
192 ptext SLIT("*** Offending Program ***"),
193 pprCoreBindings binds,
194 ptext SLIT("*** End of Offense ***")
198 %************************************************************************
200 \subsection[lintUnfolding]{lintUnfolding}
202 %************************************************************************
204 We use this to check all unfoldings that come in from interfaces
205 (it is very painful to catch errors otherwise):
208 lintUnfolding :: SrcLoc
209 -> [Var] -- Treat these as in scope
211 -> Maybe Message -- Nothing => OK
213 lintUnfolding locn vars expr
214 = initL (addLoc (ImportedUnfolding locn) $
215 addInScopeVars vars $
219 %************************************************************************
221 \subsection[lintCoreBinding]{lintCoreBinding}
223 %************************************************************************
225 Check a core binding, returning the list of variables bound.
228 lintSingleBinding rec_flag (binder,rhs)
229 = addLoc (RhsOf binder) $
231 do { ty <- lintCoreExpr rhs
232 ; lintBinder binder -- Check match to RHS type
233 ; binder_ty <- applySubst binder_ty
234 ; checkTys binder_ty ty (mkRhsMsg binder ty)
235 -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
236 ; checkL (not (isUnLiftedType binder_ty)
237 || (isNonRec rec_flag && exprOkForSpeculation rhs))
238 (mkRhsPrimMsg binder rhs)
239 -- Check whether binder's specialisations contain any out-of-scope variables
240 ; mapM_ (checkBndrIdInScope binder) bndr_vars }
242 -- We should check the unfolding, if any, but this is tricky because
243 -- the unfolding is a SimplifiableCoreExpr. Give up for now.
245 binder_ty = idType binder
246 bndr_vars = varSetElems (idFreeVars binder)
247 lintBinder var | isId var = lintIdBndr var $ \_ -> (return ())
248 | otherwise = return ()
251 %************************************************************************
253 \subsection[lintCoreExpr]{lintCoreExpr}
255 %************************************************************************
258 type InType = Type -- Substitution not yet applied
259 type OutType = Type -- Substitution has been applied to this
261 lintCoreExpr :: CoreExpr -> LintM OutType
262 -- The returned type has the substitution from the monad
263 -- already applied to it:
264 -- lintCoreExpr e subst = exprType (subst e)
266 lintCoreExpr (Var var)
267 = do { checkL (not (var == oneTupleDataConId))
268 (ptext SLIT("Illegal one-tuple"))
269 ; var' <- lookupIdInScope var
270 ; return (idType var')
273 lintCoreExpr (Lit lit)
274 = return (literalType lit)
276 --lintCoreExpr (Note (Coerce to_ty from_ty) expr)
277 -- = do { expr_ty <- lintCoreExpr expr
278 -- ; to_ty <- lintTy to_ty
279 -- ; from_ty <- lintTy from_ty
280 -- ; checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty)
283 lintCoreExpr (Cast expr co)
284 = do { expr_ty <- lintCoreExpr expr
286 ; let (from_ty, to_ty) = coercionKind co'
287 ; checkTys from_ty expr_ty (mkCastErr from_ty expr_ty)
290 lintCoreExpr (Note other_note expr)
293 lintCoreExpr (Let (NonRec bndr rhs) body)
294 = do { lintSingleBinding NonRecursive (bndr,rhs)
295 ; addLoc (BodyOfLetRec [bndr])
296 (lintAndScopeId bndr $ \_ -> (lintCoreExpr body)) }
298 lintCoreExpr (Let (Rec pairs) body)
299 = lintAndScopeIds bndrs $ \_ ->
300 do { mapM (lintSingleBinding Recursive) pairs
301 ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
303 bndrs = map fst pairs
305 lintCoreExpr e@(App fun (Type ty))
306 -- See Note [Type let] above
307 = addLoc (AnExpr e) $
310 go (App fun (Type ty)) tys
311 = do { go fun (ty:tys) }
312 go (Lam tv body) (ty:tys)
313 = do { checkL (isTyVar tv) (mkKindErrMsg tv ty) -- Not quite accurate
315 ; let kind = tyVarKind tv
316 ; kind' <- lintTy kind
317 ; let tv' = setTyVarKind tv kind'
319 -- Now extend the substitution so we
320 -- take advantage of it in the body
321 ; addInScopeVars [tv'] $
322 extendSubstL tv' ty' $
325 = do { fun_ty <- lintCoreExpr fun
326 ; lintCoreArgs fun_ty (map Type tys) }
328 lintCoreExpr e@(App fun arg)
329 = do { fun_ty <- lintCoreExpr fun
330 ; addLoc (AnExpr e) $
331 lintCoreArg fun_ty arg }
333 lintCoreExpr (Lam var expr)
334 = addLoc (LambdaBodyOf var) $
335 lintBinders [var] $ \[var'] ->
336 do { body_ty <- lintCoreExpr expr
338 return (mkFunTy (idType var') body_ty)
340 return (mkForAllTy var' body_ty)
342 -- The applySubst is needed to apply the subst to var
344 lintCoreExpr e@(Case scrut var alt_ty alts) =
345 -- Check the scrutinee
346 do { scrut_ty <- lintCoreExpr scrut
347 ; alt_ty <- lintTy alt_ty
348 ; var_ty <- lintTy (idType var)
349 -- Don't use lintIdBndr on var, because unboxed tuple is legitimate
351 ; subst <- getTvSubst
352 ; checkTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst)
354 -- If the binder is an unboxed tuple type, don't put it in scope
355 ; let scope = if (isUnboxedTupleType (idType var)) then
357 else lintAndScopeId var
359 do { -- Check the alternatives
360 checkCaseAlts e scrut_ty alts
361 ; mapM (lintCoreAlt scrut_ty alt_ty) alts
366 lintCoreExpr e@(Type ty)
367 = addErrL (mkStrangeTyMsg e)
370 %************************************************************************
372 \subsection[lintCoreArgs]{lintCoreArgs}
374 %************************************************************************
376 The basic version of these functions checks that the argument is a
377 subtype of the required type, as one would expect.
380 lintCoreArgs :: Type -> [CoreArg] -> LintM Type
381 lintCoreArg :: Type -> CoreArg -> LintM Type
382 -- First argument has already had substitution applied to it
386 lintCoreArgs ty [] = return ty
387 lintCoreArgs ty (a : args) =
388 do { res <- lintCoreArg ty a
389 ; lintCoreArgs res args }
391 lintCoreArg fun_ty a@(Type arg_ty) =
392 do { arg_ty <- lintTy arg_ty
393 ; lintTyApp fun_ty arg_ty }
395 lintCoreArg fun_ty arg =
396 -- Make sure function type matches argument
397 do { arg_ty <- lintCoreExpr arg
398 ; let err = mkAppMsg fun_ty arg_ty arg
399 ; case splitFunTy_maybe fun_ty of
401 do { checkTys arg arg_ty err
407 -- Both args have had substitution applied
409 = case splitForAllTy_maybe ty of
410 Nothing -> addErrL (mkTyAppMsg ty arg_ty)
413 -> do { checkL (isTyVar tyvar) (mkTyAppMsg ty arg_ty)
414 ; checkKinds tyvar arg_ty
415 ; return (substTyWith [tyvar] [arg_ty] body) }
417 lintTyApps fun_ty [] = return fun_ty
419 lintTyApps fun_ty (arg_ty : arg_tys) =
420 do { fun_ty' <- lintTyApp fun_ty arg_ty
421 ; lintTyApps fun_ty' arg_tys }
423 checkKinds tyvar arg_ty
424 -- Arg type might be boxed for a function with an uncommitted
425 -- tyvar; notably this is used so that we can give
426 -- error :: forall a:*. String -> a
427 -- and then apply it to both boxed and unboxed types.
428 = checkL (argty_kind `isSubKind` tyvar_kind)
429 (mkKindErrMsg tyvar arg_ty)
431 tyvar_kind = tyVarKind tyvar
432 argty_kind = typeKind arg_ty
436 %************************************************************************
438 \subsection[lintCoreAlts]{lintCoreAlts}
440 %************************************************************************
443 checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
444 -- a) Check that the alts are non-empty
445 -- b1) Check that the DEFAULT comes first, if it exists
446 -- b2) Check that the others are in increasing order
447 -- c) Check that there's a default for infinite types
448 -- NB: Algebraic cases are not necessarily exhaustive, because
449 -- the simplifer correctly eliminates case that can't
452 checkCaseAlts e ty []
453 = addErrL (mkNullAltsMsg e)
455 checkCaseAlts e ty alts =
456 do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
457 ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
458 ; checkL (isJust maybe_deflt || not is_infinite_ty)
459 (nonExhaustiveAltsMsg e) }
461 (con_alts, maybe_deflt) = findDefault alts
463 -- Check that successive alternatives have increasing tags
464 increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest
465 increasing_tag other = True
467 non_deflt (DEFAULT, _, _) = False
470 is_infinite_ty = case splitTyConApp_maybe ty of
472 Just (tycon, tycon_arg_tys) -> isPrimTyCon tycon
476 checkAltExpr :: CoreExpr -> OutType -> LintM ()
477 checkAltExpr expr ann_ty
478 = do { actual_ty <- lintCoreExpr expr
479 ; checkTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) }
481 lintCoreAlt :: OutType -- Type of scrutinee
482 -> OutType -- Type of the alternative
486 lintCoreAlt scrut_ty alt_ty alt@(DEFAULT, args, rhs) =
487 do { checkL (null args) (mkDefaultArgsMsg args)
488 ; checkAltExpr rhs alt_ty }
490 lintCoreAlt scrut_ty alt_ty alt@(LitAlt lit, args, rhs) =
491 do { checkL (null args) (mkDefaultArgsMsg args)
492 ; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty)
493 ; checkAltExpr rhs alt_ty }
495 lit_ty = literalType lit
497 lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
498 | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty
499 = addLoc (CaseAlt alt) $ lintBinders args $ \ args ->
501 do { addLoc (CasePat alt) $ do
502 { -- Check the pattern
503 -- Scrutinee type must be a tycon applicn; checked by caller
504 -- This code is remarkably compact considering what it does!
505 -- NB: args must be in scope here so that the lintCoreArgs line works.
506 -- NB: relies on existential type args coming *after* ordinary type args
509 lintCoreArgs (dataConRepType con)
510 (map Type tycon_arg_tys ++ varsToCoreExprs args)
511 ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
514 ; checkAltExpr rhs alt_ty }
516 | otherwise -- Scrut-ty is wrong shape
517 = addErrL (mkBadAltMsg scrut_ty alt)
520 %************************************************************************
522 \subsection[lint-types]{Types}
524 %************************************************************************
527 -- When we lint binders, we (one at a time and in order):
528 -- 1. Lint var types or kinds (possibly substituting)
529 -- 2. Add the binder to the in scope set, and if its a coercion var,
530 -- we may extend the substitution to reflect its (possibly) new kind
531 lintBinders :: [Var] -> ([Var] -> LintM a) -> LintM a
532 lintBinders [] linterF = linterF []
533 lintBinders (var:vars) linterF = lintBinder var $ \var' ->
534 lintBinders vars $ \ vars' ->
537 lintBinder :: Var -> (Var -> LintM a) -> LintM a
538 lintBinder var linterF
539 | isTyVar var = lint_ty_bndr
540 | otherwise = lintIdBndr var linterF
542 lint_ty_bndr = do { lintTy (tyVarKind var)
543 ; subst <- getTvSubst
544 ; let (subst', tv') = substTyVarBndr subst var
545 ; updateTvSubst subst' (linterF tv') }
547 lintIdBndr :: Var -> (Var -> LintM a) -> LintM a
548 -- Do substitution on the type of a binder and add the var with this
549 -- new type to the in-scope set of the second argument
550 -- ToDo: lint its rules
551 lintIdBndr id linterF
552 = do { checkL (not (isUnboxedTupleType (idType id)))
553 (mkUnboxedTupleMsg id)
554 -- No variable can be bound to an unboxed tuple.
555 ; lintAndScopeId id $ \id' -> linterF id'
558 lintAndScopeIds :: [Var] -> ([Var] -> LintM a) -> LintM a
559 lintAndScopeIds ids linterF
563 go (id:ids) = do { lintAndScopeId id $ \id ->
564 lintAndScopeIds ids $ \ids ->
567 lintAndScopeId :: Var -> (Var -> LintM a) -> LintM a
568 lintAndScopeId id linterF
569 = do { ty <- lintTy (idType id)
570 ; let id' = setIdType id ty
571 ; addInScopeVars [id'] $ (linterF id')
574 lintTy :: InType -> LintM OutType
575 -- Check the type, and apply the substitution to it
576 -- ToDo: check the kind structure of the type
578 = do { ty' <- applySubst ty
579 ; mapM_ checkTyVarInScope (varSetElems (tyVarsOfType ty'))
584 %************************************************************************
586 \subsection[lint-monad]{The Lint monad}
588 %************************************************************************
593 [LintLocInfo] -> -- Locations
594 TvSubst -> -- Current type substitution; we also use this
595 -- to keep track of all the variables in scope,
596 -- both Ids and TyVars
597 Bag Message -> -- Error messages so far
598 (Maybe a, Bag Message) } -- Result and error messages (if any)
600 instance Monad LintM where
601 return x = LintM (\ loc subst errs -> (Just x, errs))
602 fail err = LintM (\ loc subst errs -> (Nothing, addErr subst errs (text err) loc))
603 m >>= k = LintM (\ loc subst errs ->
604 let (res, errs') = unLintM m loc subst errs in
606 Just r -> unLintM (k r) loc subst errs'
607 Nothing -> (Nothing, errs'))
610 = RhsOf Id -- The variable bound
611 | LambdaBodyOf Id -- The lambda-binder
612 | BodyOfLetRec [Id] -- One of the binders
613 | CaseAlt CoreAlt -- Case alternative
614 | CasePat CoreAlt -- *Pattern* of the case alternative
615 | AnExpr CoreExpr -- Some expression
616 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
621 initL :: LintM a -> Maybe Message {- errors -}
623 = case unLintM m [] emptyTvSubst emptyBag of
624 (_, errs) | isEmptyBag errs -> Nothing
625 | otherwise -> Just (vcat (punctuate (text "") (bagToList errs)))
629 checkL :: Bool -> Message -> LintM ()
630 checkL True msg = return ()
631 checkL False msg = addErrL msg
633 addErrL :: Message -> LintM a
634 addErrL msg = LintM (\ loc subst errs -> (Nothing, addErr subst errs msg loc))
636 addErr :: TvSubst -> Bag Message -> Message -> [LintLocInfo] -> Bag Message
637 addErr subst errs_so_far msg locs
638 = ASSERT( notNull locs )
639 errs_so_far `snocBag` mk_msg msg
641 (loc, cxt1) = dumpLoc (head locs)
642 cxts = [snd (dumpLoc loc) | loc <- locs]
643 context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$
644 ptext SLIT("Substitution:") <+> ppr subst
647 mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg)
649 addLoc :: LintLocInfo -> LintM a -> LintM a
651 LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs)
653 addInScopeVars :: [Var] -> LintM a -> LintM a
654 addInScopeVars vars m =
655 LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs)
657 updateTvSubst :: TvSubst -> LintM a -> LintM a
658 updateTvSubst subst' m =
659 LintM (\ loc subst errs -> unLintM m loc subst' errs)
661 getTvSubst :: LintM TvSubst
662 getTvSubst = LintM (\ loc subst errs -> (Just subst, errs))
664 applySubst :: Type -> LintM Type
665 applySubst ty = do { subst <- getTvSubst; return (substTy subst ty) }
667 extendSubstL :: TyVar -> Type -> LintM a -> LintM a
669 = LintM (\ loc subst errs -> unLintM m loc (extendTvSubst subst tv ty) errs)
673 lookupIdInScope :: Id -> LintM Id
675 | not (mustHaveLocalBinding id)
676 = return id -- An imported Id
678 = do { subst <- getTvSubst
679 ; case lookupInScope (getTvInScope subst) id of
681 Nothing -> do { addErrL out_of_scope
684 out_of_scope = ppr id <+> ptext SLIT("is out of scope")
687 oneTupleDataConId :: Id -- Should not happen
688 oneTupleDataConId = dataConWorkId (tupleCon Boxed 1)
690 checkBndrIdInScope :: Var -> Var -> LintM ()
691 checkBndrIdInScope binder id
692 = checkInScope msg id
694 msg = ptext SLIT("is out of scope inside info for") <+>
697 checkTyVarInScope :: TyVar -> LintM ()
698 checkTyVarInScope tv = checkInScope (ptext SLIT("is out of scope")) tv
700 checkInScope :: SDoc -> Var -> LintM ()
701 checkInScope loc_msg var =
702 do { subst <- getTvSubst
703 ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
704 (hsep [ppr var, loc_msg]) }
706 checkTys :: Type -> Type -> Message -> LintM ()
707 -- check ty2 is subtype of ty1 (ie, has same structure but usage
708 -- annotations need only be consistent, not equal)
709 -- Assumes ty1,ty2 are have alrady had the substitution applied
710 checkTys ty1 ty2 msg = checkL (ty1 `coreEqType` ty2) msg
713 %************************************************************************
715 \subsection{Error messages}
717 %************************************************************************
721 = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))
723 dumpLoc (LambdaBodyOf b)
724 = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
726 dumpLoc (BodyOfLetRec [])
727 = (noSrcLoc, brackets (ptext SLIT("In body of a letrec with no binders")))
729 dumpLoc (BodyOfLetRec bs@(_:_))
730 = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
733 = (noSrcLoc, text "In the expression:" <+> ppr e)
735 dumpLoc (CaseAlt (con, args, rhs))
736 = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args))
738 dumpLoc (CasePat (con, args, rhs))
739 = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args))
741 dumpLoc (ImportedUnfolding locn)
742 = (locn, brackets (ptext SLIT("in an imported unfolding")))
744 pp_binders :: [Var] -> SDoc
745 pp_binders bs = sep (punctuate comma (map pp_binder bs))
747 pp_binder :: Var -> SDoc
748 pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)]
749 | isTyVar b = hsep [ppr b, dcolon, ppr (tyVarKind b)]
753 ------------------------------------------------------
754 -- Messages for case expressions
756 mkNullAltsMsg :: CoreExpr -> Message
758 = hang (text "Case expression with no alternatives:")
761 mkDefaultArgsMsg :: [Var] -> Message
762 mkDefaultArgsMsg args
763 = hang (text "DEFAULT case with binders")
766 mkCaseAltMsg :: CoreExpr -> Type -> Type -> Message
767 mkCaseAltMsg e ty1 ty2
768 = hang (text "Type of case alternatives not the same as the annotation on case:")
769 4 (vcat [ppr ty1, ppr ty2, ppr e])
771 mkScrutMsg :: Id -> Type -> Type -> TvSubst -> Message
772 mkScrutMsg var var_ty scrut_ty subst
773 = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
774 text "Result binder type:" <+> ppr var_ty,--(idType var),
775 text "Scrutinee type:" <+> ppr scrut_ty,
776 hsep [ptext SLIT("Current TV subst"), ppr subst]]
780 = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
781 mkNonIncreasingAltsMsg e
782 = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)
784 nonExhaustiveAltsMsg :: CoreExpr -> Message
785 nonExhaustiveAltsMsg e
786 = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
788 mkBadPatMsg :: Type -> Type -> Message
789 mkBadPatMsg con_result_ty scrut_ty
791 text "In a case alternative, pattern result type doesn't match scrutinee type:",
792 text "Pattern result type:" <+> ppr con_result_ty,
793 text "Scrutinee type:" <+> ppr scrut_ty
796 mkBadAltMsg :: Type -> CoreAlt -> Message
797 mkBadAltMsg scrut_ty alt
798 = vcat [ text "Data alternative when scrutinee is not a tycon application",
799 text "Scrutinee type:" <+> ppr scrut_ty,
800 text "Alternative:" <+> pprCoreAlt alt ]
802 ------------------------------------------------------
803 -- Other error messages
805 mkAppMsg :: Type -> Type -> CoreExpr -> Message
806 mkAppMsg fun_ty arg_ty arg
807 = vcat [ptext SLIT("Argument value doesn't match argument type:"),
808 hang (ptext SLIT("Fun type:")) 4 (ppr fun_ty),
809 hang (ptext SLIT("Arg type:")) 4 (ppr arg_ty),
810 hang (ptext SLIT("Arg:")) 4 (ppr arg)]
812 mkKindErrMsg :: TyVar -> Type -> Message
813 mkKindErrMsg tyvar arg_ty
814 = vcat [ptext SLIT("Kinds don't match in type application:"),
815 hang (ptext SLIT("Type variable:"))
816 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
817 hang (ptext SLIT("Arg type:"))
818 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
820 mkTyAppMsg :: Type -> Type -> Message
822 = vcat [text "Illegal type application:",
823 hang (ptext SLIT("Exp type:"))
824 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
825 hang (ptext SLIT("Arg type:"))
826 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
828 mkRhsMsg :: Id -> Type -> Message
831 [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
833 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
834 hsep [ptext SLIT("Rhs type:"), ppr ty]]
836 mkRhsPrimMsg :: Id -> CoreExpr -> Message
837 mkRhsPrimMsg binder rhs
838 = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
840 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
843 mkUnboxedTupleMsg :: Id -> Message
844 mkUnboxedTupleMsg binder
845 = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
846 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
848 mkCastErr from_ty expr_ty
849 = vcat [ptext SLIT("From-type of Cast differs from type of enclosed expression"),
850 ptext SLIT("From-type:") <+> ppr from_ty,
851 ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
855 = ptext SLIT("Type where expression expected:") <+> ppr e