3 % (c) The University of Glasgow 2006
4 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
7 A ``lint'' pass to check for Core correctness
10 module CoreLint ( lintCoreBindings, lintUnfolding ) where
12 #include "HsVersions.h"
43 %************************************************************************
45 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
47 %************************************************************************
49 Checks that a set of core bindings is well-formed. The PprStyle and String
50 just control what we print in the event of an error. The Bool value
51 indicates whether we have done any specialisation yet (in which case we do
56 (b) Out-of-scope type variables
57 (c) Out-of-scope local variables
60 If we have done specialisation the we check that there are
61 (a) No top-level bindings of primitive (unboxed type)
66 -- Things are *not* OK if:
68 -- * Unsaturated type app before specialisation has been done;
70 -- * Oversaturated type app after specialisation (eta reduction
71 -- may well be happening...);
74 Note [Linting type lets]
75 ~~~~~~~~~~~~~~~~~~~~~~~~
76 In the desugarer, it's very very convenient to be able to say (in effect)
77 let a = Type Int in <body>
78 That is, use a type let. See Note [Type let] in CoreSyn.
80 However, when linting <body> we need to remember that a=Int, else we might
81 reject a correct program. So we carry a type substitution (in this example
82 [a -> Int]) and apply this substitution before comparing types. The functin
83 lintTy :: Type -> LintM Type
84 returns a substituted type; that's the only reason it returns anything.
86 When we encounter a binder (like x::a) we must apply the substitution
87 to the type of the binding variable. lintBinders does this.
89 For Ids, the type-substituted Id is added to the in_scope set (which
90 itself is part of the TvSubst we are carrying down), and when we
91 find an occurence of an Id, we fetch it from the in-scope set.
95 lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
97 lintCoreBindings dflags _whoDunnit _binds
98 | not (dopt Opt_DoCoreLinting dflags)
101 lintCoreBindings dflags whoDunnit binds
102 = case (initL (lint_binds binds)) of
103 Nothing -> showPass dflags ("Core Linted result of " ++ whoDunnit)
104 Just bad_news -> printDump (display bad_news) >>
107 -- Put all the top-level binders in scope at the start
108 -- This is because transformation rules can bring something
109 -- into use 'unexpectedly'
110 lint_binds binds = addLoc TopLevelBindings $
111 addInScopeVars (bindersOfBinds binds) $
114 lint_bind (Rec prs) = mapM_ (lintSingleBinding TopLevel Recursive) prs
115 lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)
118 = vcat [ text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
120 ptext (sLit "*** Offending Program ***"),
121 pprCoreBindings binds,
122 ptext (sLit "*** End of Offense ***")
126 %************************************************************************
128 \subsection[lintUnfolding]{lintUnfolding}
130 %************************************************************************
132 We use this to check all unfoldings that come in from interfaces
133 (it is very painful to catch errors otherwise):
136 lintUnfolding :: SrcLoc
137 -> [Var] -- Treat these as in scope
139 -> Maybe Message -- Nothing => OK
141 lintUnfolding locn vars expr
142 = initL (addLoc (ImportedUnfolding locn) $
143 addInScopeVars vars $
147 %************************************************************************
149 \subsection[lintCoreBinding]{lintCoreBinding}
151 %************************************************************************
153 Check a core binding, returning the list of variables bound.
156 lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM ()
157 lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
158 = addLoc (RhsOf binder) $
160 do { ty <- lintCoreExpr rhs
161 ; lintBinder binder -- Check match to RHS type
162 ; binder_ty <- applySubst binder_ty
163 ; checkTys binder_ty ty (mkRhsMsg binder ty)
164 -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
165 ; checkL (not (isUnLiftedType binder_ty)
166 || (isNonRec rec_flag && exprOkForSpeculation rhs))
167 (mkRhsPrimMsg binder rhs)
168 -- Check that if the binder is top-level or recursive, it's not demanded
169 ; checkL (not (isStrictId binder)
170 || (isNonRec rec_flag && not (isTopLevel top_lvl_flag)))
172 -- Check whether binder's specialisations contain any out-of-scope variables
173 ; mapM_ (checkBndrIdInScope binder) bndr_vars
175 -- Check whether arity and demand type are consistent (only if demand analysis
177 ; checkL (case maybeDmdTy of
178 Just (StrictSig dmd_ty) -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs
180 (mkArityMsg binder) }
182 -- We should check the unfolding, if any, but this is tricky because
183 -- the unfolding is a SimplifiableCoreExpr. Give up for now.
185 binder_ty = idType binder
186 maybeDmdTy = idNewStrictness_maybe binder
187 bndr_vars = varSetElems (idFreeVars binder)
188 lintBinder var | isId var = lintIdBndr var $ \_ -> (return ())
189 | otherwise = return ()
192 %************************************************************************
194 \subsection[lintCoreExpr]{lintCoreExpr}
196 %************************************************************************
199 type InType = Type -- Substitution not yet applied
200 type OutType = Type -- Substitution has been applied to this
202 lintCoreExpr :: CoreExpr -> LintM OutType
203 -- The returned type has the substitution from the monad
204 -- already applied to it:
205 -- lintCoreExpr e subst = exprType (subst e)
207 -- The returned "type" can be a kind, if the expression is (Type ty)
209 lintCoreExpr (Var var)
210 = do { checkL (not (var == oneTupleDataConId))
211 (ptext (sLit "Illegal one-tuple"))
214 ; var' <- lookupIdInScope var
215 ; return (idType var')
218 lintCoreExpr (Lit lit)
219 = return (literalType lit)
221 --lintCoreExpr (Note (Coerce to_ty from_ty) expr)
222 -- = do { expr_ty <- lintCoreExpr expr
223 -- ; to_ty <- lintTy to_ty
224 -- ; from_ty <- lintTy from_ty
225 -- ; checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty)
228 lintCoreExpr (Cast expr co)
229 = do { expr_ty <- lintCoreExpr expr
231 ; let (from_ty, to_ty) = coercionKind co'
232 ; checkTys from_ty expr_ty (mkCastErr from_ty expr_ty)
235 lintCoreExpr (Note _ expr)
238 lintCoreExpr (Let (NonRec tv (Type ty)) body)
239 = -- See Note [Type let] in CoreSyn
240 do { checkL (isTyVar tv) (mkKindErrMsg tv ty) -- Not quite accurate
242 ; kind' <- lintTy (tyVarKind tv)
243 ; let tv' = setTyVarKind tv kind'
245 -- Now extend the substitution so we
246 -- take advantage of it in the body
247 ; addLoc (BodyOfLetRec [tv]) $
248 addInScopeVars [tv'] $
249 extendSubstL tv' ty' $
252 lintCoreExpr (Let (NonRec bndr rhs) body)
253 = do { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs)
254 ; addLoc (BodyOfLetRec [bndr])
255 (lintAndScopeId bndr $ \_ -> (lintCoreExpr body)) }
257 lintCoreExpr (Let (Rec pairs) body)
258 = lintAndScopeIds bndrs $ \_ ->
259 do { mapM_ (lintSingleBinding NotTopLevel Recursive) pairs
260 ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
262 bndrs = map fst pairs
264 lintCoreExpr e@(App fun arg)
265 = do { fun_ty <- lintCoreExpr fun
266 ; addLoc (AnExpr e) $
267 lintCoreArg fun_ty arg }
269 lintCoreExpr (Lam var expr)
270 = addLoc (LambdaBodyOf var) $
271 lintBinders [var] $ \[var'] ->
272 do { body_ty <- lintCoreExpr expr
274 return (mkFunTy (idType var') body_ty)
276 return (mkForAllTy var' body_ty)
278 -- The applySubst is needed to apply the subst to var
280 lintCoreExpr e@(Case scrut var alt_ty alts) =
281 -- Check the scrutinee
282 do { scrut_ty <- lintCoreExpr scrut
283 ; alt_ty <- lintTy alt_ty
284 ; var_ty <- lintTy (idType var)
286 ; let mb_tc_app = splitTyConApp_maybe (idType var)
291 not (isOpenTyCon tycon) &&
292 null (tyConDataCons tycon) ->
293 pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var))
294 -- This can legitimately happen for type families
296 _otherwise -> return ()
298 -- Don't use lintIdBndr on var, because unboxed tuple is legitimate
300 ; subst <- getTvSubst
301 ; checkTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst)
303 -- If the binder is an unboxed tuple type, don't put it in scope
304 ; let scope = if (isUnboxedTupleType (idType var)) then
306 else lintAndScopeId var
308 do { -- Check the alternatives
309 mapM_ (lintCoreAlt scrut_ty alt_ty) alts
310 ; checkCaseAlts e scrut_ty alts
315 lintCoreExpr (Type ty)
316 = do { ty' <- lintTy ty
317 ; return (typeKind ty') }
320 %************************************************************************
322 \subsection[lintCoreArgs]{lintCoreArgs}
324 %************************************************************************
326 The basic version of these functions checks that the argument is a
327 subtype of the required type, as one would expect.
330 lintCoreArgs :: OutType -> [CoreArg] -> LintM OutType
331 lintCoreArg :: OutType -> CoreArg -> LintM OutType
332 -- First argument has already had substitution applied to it
336 lintCoreArgs ty [] = return ty
337 lintCoreArgs ty (a : args) =
338 do { res <- lintCoreArg ty a
339 ; lintCoreArgs res args }
341 lintCoreArg fun_ty (Type arg_ty) =
342 do { arg_ty <- lintTy arg_ty
343 ; lintTyApp fun_ty arg_ty }
345 lintCoreArg fun_ty arg =
346 -- Make sure function type matches argument
347 do { arg_ty <- lintCoreExpr arg
348 ; let err1 = mkAppMsg fun_ty arg_ty arg
349 err2 = mkNonFunAppMsg fun_ty arg_ty arg
350 ; case splitFunTy_maybe fun_ty of
352 do { checkTys arg arg_ty err1
358 -- Both args have had substitution applied
359 lintTyApp :: OutType -> OutType -> LintM OutType
361 = case splitForAllTy_maybe ty of
362 Nothing -> addErrL (mkTyAppMsg ty arg_ty)
365 -> do { checkL (isTyVar tyvar) (mkTyAppMsg ty arg_ty)
366 ; checkKinds tyvar arg_ty
367 ; return (substTyWith [tyvar] [arg_ty] body) }
369 checkKinds :: Var -> Type -> LintM ()
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 (arg_kind `isSubKind` tyvar_kind)
376 (mkKindErrMsg tyvar arg_ty)
378 tyvar_kind = tyVarKind tyvar
379 arg_kind | isCoVar tyvar = coercionKindPredTy arg_ty
380 | otherwise = typeKind arg_ty
382 checkDeadIdOcc :: Id -> LintM ()
383 -- Occurrences of an Id should never be dead....
384 -- except when we are checking a case pattern
386 | isDeadOcc (idOccInfo id)
387 = do { in_case <- inCasePat
389 (ptext (sLit "Occurrence of a dead Id") <+> ppr id) }
395 %************************************************************************
397 \subsection[lintCoreAlts]{lintCoreAlts}
399 %************************************************************************
402 checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
403 -- a) Check that the alts are non-empty
404 -- b1) Check that the DEFAULT comes first, if it exists
405 -- b2) Check that the others are in increasing order
406 -- c) Check that there's a default for infinite types
407 -- NB: Algebraic cases are not necessarily exhaustive, because
408 -- the simplifer correctly eliminates case that can't
412 = addErrL (mkNullAltsMsg e)
414 checkCaseAlts e ty alts =
415 do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
416 ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
417 ; checkL (isJust maybe_deflt || not is_infinite_ty)
418 (nonExhaustiveAltsMsg e) }
420 (con_alts, maybe_deflt) = findDefault alts
422 -- Check that successive alternatives have increasing tags
423 increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest
424 increasing_tag _ = True
426 non_deflt (DEFAULT, _, _) = False
429 is_infinite_ty = case splitTyConApp_maybe ty of
431 Just (tycon, _) -> isPrimTyCon tycon
435 checkAltExpr :: CoreExpr -> OutType -> LintM ()
436 checkAltExpr expr ann_ty
437 = do { actual_ty <- lintCoreExpr expr
438 ; checkTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) }
440 lintCoreAlt :: OutType -- Type of scrutinee
441 -> OutType -- Type of the alternative
445 lintCoreAlt _ alt_ty (DEFAULT, args, rhs) =
446 do { checkL (null args) (mkDefaultArgsMsg args)
447 ; checkAltExpr rhs alt_ty }
449 lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs) =
450 do { checkL (null args) (mkDefaultArgsMsg args)
451 ; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty)
452 ; checkAltExpr rhs alt_ty }
454 lit_ty = literalType lit
456 lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
457 | isNewTyCon (dataConTyCon con) = addErrL (mkNewTyDataConAltMsg scrut_ty alt)
458 | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty
459 = addLoc (CaseAlt alt) $ do
460 { -- First instantiate the universally quantified
461 -- type variables of the data constructor
462 -- We've already check
463 checkL (tycon == dataConTyCon con) (mkBadConMsg tycon con)
464 ; let con_payload_ty = applyTys (dataConRepType con) tycon_arg_tys
466 -- And now bring the new binders into scope
467 ; lintBinders args $ \ args -> do
468 { addLoc (CasePat alt) $ do
469 { -- Check the pattern
470 -- Scrutinee type must be a tycon applicn; checked by caller
471 -- This code is remarkably compact considering what it does!
472 -- NB: args must be in scope here so that the lintCoreArgs
474 -- NB: relies on existential type args coming *after*
475 -- ordinary type args
476 ; con_result_ty <- lintCoreArgs con_payload_ty (varsToCoreExprs args)
477 ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
480 ; checkAltExpr rhs alt_ty } }
482 | otherwise -- Scrut-ty is wrong shape
483 = addErrL (mkBadAltMsg scrut_ty alt)
486 %************************************************************************
488 \subsection[lint-types]{Types}
490 %************************************************************************
493 -- When we lint binders, we (one at a time and in order):
494 -- 1. Lint var types or kinds (possibly substituting)
495 -- 2. Add the binder to the in scope set, and if its a coercion var,
496 -- we may extend the substitution to reflect its (possibly) new kind
497 lintBinders :: [Var] -> ([Var] -> LintM a) -> LintM a
498 lintBinders [] linterF = linterF []
499 lintBinders (var:vars) linterF = lintBinder var $ \var' ->
500 lintBinders vars $ \ vars' ->
503 lintBinder :: Var -> (Var -> LintM a) -> LintM a
504 lintBinder var linterF
505 | isTyVar var = lint_ty_bndr
506 | otherwise = lintIdBndr var linterF
508 lint_ty_bndr = do { _ <- lintTy (tyVarKind var)
509 ; subst <- getTvSubst
510 ; let (subst', tv') = substTyVarBndr subst var
511 ; updateTvSubst subst' (linterF tv') }
513 lintIdBndr :: Var -> (Var -> LintM a) -> LintM a
514 -- Do substitution on the type of a binder and add the var with this
515 -- new type to the in-scope set of the second argument
516 -- ToDo: lint its rules
517 lintIdBndr id linterF
518 = do { checkL (not (isUnboxedTupleType (idType id)))
519 (mkUnboxedTupleMsg id)
520 -- No variable can be bound to an unboxed tuple.
521 ; lintAndScopeId id $ \id' -> linterF id'
524 lintAndScopeIds :: [Var] -> ([Var] -> LintM a) -> LintM a
525 lintAndScopeIds ids linterF
529 go (id:ids) = do { lintAndScopeId id $ \id ->
530 lintAndScopeIds ids $ \ids ->
533 lintAndScopeId :: Var -> (Var -> LintM a) -> LintM a
534 lintAndScopeId id linterF
535 = do { ty <- lintTy (idType id)
536 ; let id' = setIdType id ty
537 ; addInScopeVars [id'] $ (linterF id')
540 lintTy :: InType -> LintM OutType
541 -- Check the type, and apply the substitution to it
542 -- See Note [Linting type lets]
543 -- ToDo: check the kind structure of the type
545 = do { ty' <- applySubst ty
546 ; mapM_ checkTyVarInScope (varSetElems (tyVarsOfType ty'))
551 %************************************************************************
553 \subsection[lint-monad]{The Lint monad}
555 %************************************************************************
560 [LintLocInfo] -> -- Locations
561 TvSubst -> -- Current type substitution; we also use this
562 -- to keep track of all the variables in scope,
563 -- both Ids and TyVars
564 Bag Message -> -- Error messages so far
565 (Maybe a, Bag Message) } -- Result and error messages (if any)
567 {- Note [Type substitution]
568 ~~~~~~~~~~~~~~~~~~~~~~~~
569 Why do we need a type substitution? Consider
570 /\(a:*). \(x:a). /\(a:*). id a x
571 This is ill typed, because (renaming variables) it is really
572 /\(a:*). \(x:a). /\(b:*). id b x
573 Hence, when checking an application, we can't naively compare x's type
574 (at its binding site) with its expected type (at a use site). So we
575 rename type binders as we go, maintaining a substitution.
577 The same substitution also supports let-type, current expressed as
579 Here we substitute 'ty' for 'a' in 'body', on the fly.
582 instance Monad LintM where
583 return x = LintM (\ _ _ errs -> (Just x, errs))
584 fail err = LintM (\ loc subst errs -> (Nothing, addErr subst errs (text err) loc))
585 m >>= k = LintM (\ loc subst errs ->
586 let (res, errs') = unLintM m loc subst errs in
588 Just r -> unLintM (k r) loc subst errs'
589 Nothing -> (Nothing, errs'))
592 = RhsOf Id -- The variable bound
593 | LambdaBodyOf Id -- The lambda-binder
594 | BodyOfLetRec [Id] -- One of the binders
595 | CaseAlt CoreAlt -- Case alternative
596 | CasePat CoreAlt -- The *pattern* of the case alternative
597 | AnExpr CoreExpr -- Some expression
598 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
604 initL :: LintM a -> Maybe Message {- errors -}
606 = case unLintM m [] emptyTvSubst emptyBag of
607 (_, errs) | isEmptyBag errs -> Nothing
608 | otherwise -> Just (vcat (punctuate blankLine (bagToList errs)))
612 checkL :: Bool -> Message -> LintM ()
613 checkL True _ = return ()
614 checkL False msg = addErrL msg
616 addErrL :: Message -> LintM a
617 addErrL msg = LintM (\ loc subst errs -> (Nothing, addErr subst errs msg loc))
619 addErr :: TvSubst -> Bag Message -> Message -> [LintLocInfo] -> Bag Message
620 addErr subst errs_so_far msg locs
621 = ASSERT( notNull locs )
622 errs_so_far `snocBag` mk_msg msg
624 (loc, cxt1) = dumpLoc (head locs)
625 cxts = [snd (dumpLoc loc) | loc <- locs]
626 context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$
627 ptext (sLit "Substitution:") <+> ppr subst
630 mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg)
632 addLoc :: LintLocInfo -> LintM a -> LintM a
634 LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs)
636 inCasePat :: LintM Bool -- A slight hack; see the unique call site
637 inCasePat = LintM $ \ loc _ errs -> (Just (is_case_pat loc), errs)
639 is_case_pat (CasePat {} : _) = True
640 is_case_pat _other = False
642 addInScopeVars :: [Var] -> LintM a -> LintM a
643 addInScopeVars vars m
645 = LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs)
647 = addErrL (dupVars dups)
649 (_, dups) = removeDups compare vars
651 updateTvSubst :: TvSubst -> LintM a -> LintM a
652 updateTvSubst subst' m =
653 LintM (\ loc _ errs -> unLintM m loc subst' errs)
655 getTvSubst :: LintM TvSubst
656 getTvSubst = LintM (\ _ subst errs -> (Just subst, errs))
658 applySubst :: Type -> LintM Type
659 applySubst ty = do { subst <- getTvSubst; return (substTy subst ty) }
661 extendSubstL :: TyVar -> Type -> LintM a -> LintM a
663 = LintM (\ loc subst errs -> unLintM m loc (extendTvSubst subst tv ty) errs)
667 lookupIdInScope :: Id -> LintM Id
669 | not (mustHaveLocalBinding id)
670 = return id -- An imported Id
672 = do { subst <- getTvSubst
673 ; case lookupInScope (getTvInScope subst) id of
675 Nothing -> do { _ <- addErrL out_of_scope
678 out_of_scope = ppr id <+> ptext (sLit "is out of scope")
681 oneTupleDataConId :: Id -- Should not happen
682 oneTupleDataConId = dataConWorkId (tupleCon Boxed 1)
684 checkBndrIdInScope :: Var -> Var -> LintM ()
685 checkBndrIdInScope binder id
686 = checkInScope msg id
688 msg = ptext (sLit "is out of scope inside info for") <+>
691 checkTyVarInScope :: TyVar -> LintM ()
692 checkTyVarInScope tv = checkInScope (ptext (sLit "is out of scope")) tv
694 checkInScope :: SDoc -> Var -> LintM ()
695 checkInScope loc_msg var =
696 do { subst <- getTvSubst
697 ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
698 (hsep [ppr var, loc_msg]) }
700 checkTys :: Type -> Type -> Message -> LintM ()
701 -- check ty2 is subtype of ty1 (ie, has same structure but usage
702 -- annotations need only be consistent, not equal)
703 -- Assumes ty1,ty2 are have alrady had the substitution applied
704 checkTys ty1 ty2 msg = checkL (ty1 `coreEqType` ty2) msg
707 %************************************************************************
709 \subsection{Error messages}
711 %************************************************************************
714 dumpLoc :: LintLocInfo -> (SrcLoc, SDoc)
717 = (getSrcLoc v, brackets (ptext (sLit "RHS of") <+> pp_binders [v]))
719 dumpLoc (LambdaBodyOf b)
720 = (getSrcLoc b, brackets (ptext (sLit "in body of lambda with binder") <+> pp_binder b))
722 dumpLoc (BodyOfLetRec [])
723 = (noSrcLoc, brackets (ptext (sLit "In body of a letrec with no binders")))
725 dumpLoc (BodyOfLetRec bs@(_:_))
726 = ( getSrcLoc (head bs), brackets (ptext (sLit "in body of letrec with binders") <+> pp_binders bs))
729 = (noSrcLoc, text "In the expression:" <+> ppr e)
731 dumpLoc (CaseAlt (con, args, _))
732 = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args))
734 dumpLoc (CasePat (con, args, _))
735 = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args))
737 dumpLoc (ImportedUnfolding locn)
738 = (locn, brackets (ptext (sLit "in an imported unfolding")))
739 dumpLoc TopLevelBindings
742 pp_binders :: [Var] -> SDoc
743 pp_binders bs = sep (punctuate comma (map pp_binder bs))
745 pp_binder :: Var -> SDoc
746 pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)]
747 | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)]
751 ------------------------------------------------------
752 -- Messages for case expressions
754 mkNullAltsMsg :: CoreExpr -> Message
756 = hang (text "Case expression with no alternatives:")
759 mkDefaultArgsMsg :: [Var] -> Message
760 mkDefaultArgsMsg args
761 = hang (text "DEFAULT case with binders")
764 mkCaseAltMsg :: CoreExpr -> Type -> Type -> Message
765 mkCaseAltMsg e ty1 ty2
766 = hang (text "Type of case alternatives not the same as the annotation on case:")
767 4 (vcat [ppr ty1, ppr ty2, ppr e])
769 mkScrutMsg :: Id -> Type -> Type -> TvSubst -> Message
770 mkScrutMsg var var_ty scrut_ty subst
771 = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
772 text "Result binder type:" <+> ppr var_ty,--(idType var),
773 text "Scrutinee type:" <+> ppr scrut_ty,
774 hsep [ptext (sLit "Current TV subst"), ppr subst]]
776 mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> Message
778 = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
779 mkNonIncreasingAltsMsg e
780 = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)
782 nonExhaustiveAltsMsg :: CoreExpr -> Message
783 nonExhaustiveAltsMsg e
784 = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
786 mkBadConMsg :: TyCon -> DataCon -> Message
787 mkBadConMsg tycon datacon
789 text "In a case alternative, data constructor isn't in scrutinee type:",
790 text "Scrutinee type constructor:" <+> ppr tycon,
791 text "Data con:" <+> ppr datacon
794 mkBadPatMsg :: Type -> Type -> Message
795 mkBadPatMsg con_result_ty scrut_ty
797 text "In a case alternative, pattern result type doesn't match scrutinee type:",
798 text "Pattern result type:" <+> ppr con_result_ty,
799 text "Scrutinee type:" <+> ppr scrut_ty
802 mkBadAltMsg :: Type -> CoreAlt -> Message
803 mkBadAltMsg scrut_ty alt
804 = vcat [ text "Data alternative when scrutinee is not a tycon application",
805 text "Scrutinee type:" <+> ppr scrut_ty,
806 text "Alternative:" <+> pprCoreAlt alt ]
808 mkNewTyDataConAltMsg :: Type -> CoreAlt -> Message
809 mkNewTyDataConAltMsg scrut_ty alt
810 = vcat [ text "Data alternative for newtype datacon",
811 text "Scrutinee type:" <+> ppr scrut_ty,
812 text "Alternative:" <+> pprCoreAlt alt ]
815 ------------------------------------------------------
816 -- Other error messages
818 mkAppMsg :: Type -> Type -> CoreExpr -> Message
819 mkAppMsg fun_ty arg_ty arg
820 = vcat [ptext (sLit "Argument value doesn't match argument type:"),
821 hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty),
822 hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty),
823 hang (ptext (sLit "Arg:")) 4 (ppr arg)]
825 mkNonFunAppMsg :: Type -> Type -> CoreExpr -> Message
826 mkNonFunAppMsg fun_ty arg_ty arg
827 = vcat [ptext (sLit "Non-function type in function position"),
828 hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty),
829 hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty),
830 hang (ptext (sLit "Arg:")) 4 (ppr arg)]
832 mkKindErrMsg :: TyVar -> Type -> Message
833 mkKindErrMsg tyvar arg_ty
834 = vcat [ptext (sLit "Kinds don't match in type application:"),
835 hang (ptext (sLit "Type variable:"))
836 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
837 hang (ptext (sLit "Arg type:"))
838 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
840 mkTyAppMsg :: Type -> Type -> Message
842 = vcat [text "Illegal type application:",
843 hang (ptext (sLit "Exp type:"))
844 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
845 hang (ptext (sLit "Arg type:"))
846 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
848 mkRhsMsg :: Id -> Type -> Message
851 [hsep [ptext (sLit "The type of this binder doesn't match the type of its RHS:"),
853 hsep [ptext (sLit "Binder's type:"), ppr (idType binder)],
854 hsep [ptext (sLit "Rhs type:"), ppr ty]]
856 mkRhsPrimMsg :: Id -> CoreExpr -> Message
857 mkRhsPrimMsg binder _rhs
858 = vcat [hsep [ptext (sLit "The type of this binder is primitive:"),
860 hsep [ptext (sLit "Binder's type:"), ppr (idType binder)]
863 mkStrictMsg :: Id -> Message
865 = vcat [hsep [ptext (sLit "Recursive or top-level binder has strict demand info:"),
867 hsep [ptext (sLit "Binder's demand info:"), ppr (idNewDemandInfo binder)]
870 mkArityMsg :: Id -> Message
872 = vcat [hsep [ptext (sLit "Demand type has "),
873 ppr (dmdTypeDepth dmd_ty),
874 ptext (sLit " arguments, rhs has "),
875 ppr (idArity binder),
876 ptext (sLit "arguments, "),
878 hsep [ptext (sLit "Binder's strictness signature:"), ppr dmd_ty]
881 where (StrictSig dmd_ty) = idNewStrictness binder
883 mkUnboxedTupleMsg :: Id -> Message
884 mkUnboxedTupleMsg binder
885 = vcat [hsep [ptext (sLit "A variable has unboxed tuple type:"), ppr binder],
886 hsep [ptext (sLit "Binder's type:"), ppr (idType binder)]]
888 mkCastErr :: Type -> Type -> Message
889 mkCastErr from_ty expr_ty
890 = vcat [ptext (sLit "From-type of Cast differs from type of enclosed expression"),
891 ptext (sLit "From-type:") <+> ppr from_ty,
892 ptext (sLit "Type of enclosed expr:") <+> ppr expr_ty
895 dupVars :: [[Var]] -> Message
897 = hang (ptext (sLit "Duplicate variables brought into scope"))