ghc/compiler/coreSyn/CoreLint.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section[CoreLint]{A ``lint'' pass to check for Core correctness}
   5
   6 \begin{code}
   7 module CoreLint (
   8         lintCoreBindings,
   9         lintUnfolding,
  10         showPass, endPass, endPassWithRules
  11     ) where
  12
  13 #include "HsVersions.h"
  14
  15 import IO               ( hPutStr, hPutStrLn, stdout )
  16
  17 import CoreSyn
  18 import Rules            ( RuleBase, pprRuleBase )
  19 import CoreFVs          ( idFreeVars )
  20 import CoreUtils        ( findDefault, exprOkForSpeculation, coreBindsSize, mkPiType )
  21
  22 import Bag
  23 import Literal          ( literalType )
  24 import DataCon          ( dataConRepType )
  25 import Var              ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId, mustHaveLocalBinding )
  26 import VarSet
  27 import Subst            ( mkTyVarSubst, substTy )
  28 import Name             ( getSrcLoc )
  29 import PprCore
  30 import ErrUtils         ( doIfSet, dumpIfSet_core, ghcExit, Message, showPass,
  31                           ErrMsg, addErrLocHdrLine, pprBagOfErrors,
  32                           WarnMsg, pprBagOfWarnings)
  33 import SrcLoc           ( SrcLoc, noSrcLoc )
  34 import Type             ( Type, tyVarsOfType, eqType,
  35                           splitFunTy_maybe, mkTyVarTy,
  36                           splitForAllTy_maybe, splitTyConApp_maybe, splitTyConApp,
  37                           isUnLiftedType, typeKind,
  38                           isUnboxedTupleType,
  39                           hasMoreBoxityInfo
  40                         )
  41 import TyCon            ( isPrimTyCon )
  42 import BasicTypes       ( RecFlag(..), isNonRec )
  43 import CmdLineOpts
  44 import Maybe
  45 import Outputable
  46
  47 infixr 9 `thenL`, `seqL`
  48 \end{code}
  49
  50 %************************************************************************
  51 %*                                                                      *
  52 \subsection{Start and end pass}
  53 %*                                                                      *
  54 %************************************************************************
  55
  56 @beginPass@ and @endPass@ don't really belong here, but it makes a convenient
  57 place for them.  They print out stuff before and after core passes,
  58 and do Core Lint when necessary.
  59
  60 \begin{code}
  61 endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
  62 endPass dflags pass_name dump_flag binds
  63   = do
  64         (binds, _) <- endPassWithRules dflags pass_name dump_flag binds Nothing
  65         return binds
  66
  67 endPassWithRules :: DynFlags -> String -> DynFlag -> [CoreBind]
  68                  -> Maybe RuleBase
  69                  -> IO ([CoreBind], Maybe RuleBase)
  70 endPassWithRules dflags pass_name dump_flag binds rules
  71   = do
  72         -- ToDo: force the rules?
  73
  74         -- Report result size if required
  75         -- This has the side effect of forcing the intermediate to be evaluated
  76         if verbosity dflags >= 2 then
  77            hPutStrLn stdout ("    Result size = " ++ show (coreBindsSize binds))
  78          else
  79            return ()
  80
  81         -- Report verbosely, if required
  82         dumpIfSet_core dflags dump_flag pass_name
  83                   (pprCoreBindings binds $$ case rules of
  84                                               Nothing -> empty
  85                                               Just rb -> pprRuleBase rb)
  86
  87         -- Type check
  88         lintCoreBindings dflags pass_name binds
  89         -- ToDo: lint the rules
  90
  91         return (binds, rules)
  92 \end{code}
  93
  94
  95 %************************************************************************
  96 %*                                                                      *
  97 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
  98 %*                                                                      *
  99 %************************************************************************
 100
 101 Checks that a set of core bindings is well-formed.  The PprStyle and String
 102 just control what we print in the event of an error.  The Bool value
 103 indicates whether we have done any specialisation yet (in which case we do
 104 some extra checks).
 105
 106 We check for
 107         (a) type errors
 108         (b) Out-of-scope type variables
 109         (c) Out-of-scope local variables
 110         (d) Ill-kinded types
 111
 112 If we have done specialisation the we check that there are
 113         (a) No top-level bindings of primitive (unboxed type)
 114
 115 Outstanding issues:
 116
 117     --
 118     -- Things are *not* OK if:
 119     --
 120     -- * Unsaturated type app before specialisation has been done;
 121     --
 122     -- * Oversaturated type app after specialisation (eta reduction
 123     --   may well be happening...);
 124
 125 \begin{code}
 126 lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
 127
 128 lintCoreBindings dflags whoDunnit binds
 129   | not (dopt Opt_DoCoreLinting dflags)
 130   = return ()
 131
 132 lintCoreBindings dflags whoDunnit binds
 133   = case (initL (lint_binds binds)) of
 134       (Nothing, Nothing)       -> done_lint
 135
 136       (Nothing, Just warnings) -> printDump (warn warnings) >>
 137                                   done_lint
 138
 139       (Just bad_news, warns)   -> printDump (display bad_news warns)    >>
 140                                   ghcExit 1
 141   where
 142         -- Put all the top-level binders in scope at the start
 143         -- This is because transformation rules can bring something
 144         -- into use 'unexpectedly'
 145     lint_binds binds = addInScopeVars (bindersOfBinds binds) $
 146                        mapL lint_bind binds
 147
 148     lint_bind (Rec prs)         = mapL (lintSingleBinding Recursive) prs        `seqL`
 149                                   returnL ()
 150     lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
 151
 152     done_lint = doIfSet (verbosity dflags >= 2)
 153                         (hPutStr stdout ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
 154     warn warnings
 155       = vcat [
 156                 text ("*** Core Lint Warnings: in result of " ++ whoDunnit ++ " ***"),
 157                 warnings,
 158                 offender
 159         ]
 160
 161     display bad_news warns
 162       = vcat [
 163                 text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
 164                 bad_news,
 165                 maybe offender warn warns  -- either offender or warnings (with offender)
 166         ]
 167
 168     offender
 169       = vcat [
 170                 ptext SLIT("*** Offending Program ***"),
 171                 pprCoreBindings binds,
 172                 ptext SLIT("*** End of Offense ***")
 173         ]
 174 \end{code}
 175
 176 %************************************************************************
 177 %*                                                                      *
 178 \subsection[lintUnfolding]{lintUnfolding}
 179 %*                                                                      *
 180 %************************************************************************
 181
 182 We use this to check all unfoldings that come in from interfaces
 183 (it is very painful to catch errors otherwise):
 184
 185 \begin{code}
 186 lintUnfolding :: DynFlags
 187               -> SrcLoc
 188               -> [Var]          -- Treat these as in scope
 189               -> CoreExpr
 190               -> (Maybe Message, Maybe Message)         -- (Nothing,_) => OK
 191
 192 lintUnfolding dflags locn vars expr
 193   | not (dopt Opt_DoCoreLinting dflags)
 194   = (Nothing, Nothing)
 195
 196   | otherwise
 197   = initL (addLoc (ImportedUnfolding locn) $
 198            addInScopeVars vars             $
 199            lintCoreExpr expr)
 200 \end{code}
 201
 202 %************************************************************************
 203 %*                                                                      *
 204 \subsection[lintCoreBinding]{lintCoreBinding}
 205 %*                                                                      *
 206 %************************************************************************
 207
 208 Check a core binding, returning the list of variables bound.
 209
 210 \begin{code}
 211 lintSingleBinding rec_flag (binder,rhs)
 212   = addLoc (RhsOf binder) $
 213
 214         -- Check the rhs
 215     lintCoreExpr rhs                            `thenL` \ ty ->
 216
 217         -- Check match to RHS type
 218     lintBinder binder                           `seqL`
 219     checkTys binder_ty ty (mkRhsMsg binder ty)  `seqL`
 220
 221         -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
 222     checkL (not (isUnLiftedType binder_ty)
 223             || (isNonRec rec_flag && exprOkForSpeculation rhs))
 224            (mkRhsPrimMsg binder rhs)            `seqL`
 225
 226         -- Check whether binder's specialisations contain any out-of-scope variables
 227     mapL (checkBndrIdInScope binder) bndr_vars  `seqL`
 228     returnL ()
 229
 230         -- We should check the unfolding, if any, but this is tricky because
 231         -- the unfolding is a SimplifiableCoreExpr. Give up for now.
 232   where
 233     binder_ty = idType binder
 234     bndr_vars = varSetElems (idFreeVars binder)
 235 \end{code}
 236
 237 %************************************************************************
 238 %*                                                                      *
 239 \subsection[lintCoreExpr]{lintCoreExpr}
 240 %*                                                                      *
 241 %************************************************************************
 242
 243 \begin{code}
 244 lintCoreExpr :: CoreExpr -> LintM Type
 245
 246 lintCoreExpr (Var var) = checkIdInScope var `seqL` returnL (idType var)
 247 lintCoreExpr (Lit lit) = returnL (literalType lit)
 248
 249 lintCoreExpr (Note (Coerce to_ty from_ty) expr)
 250   = lintCoreExpr expr   `thenL` \ expr_ty ->
 251     lintTy to_ty        `seqL`
 252     lintTy from_ty      `seqL`
 253     checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty)      `seqL`
 254     returnL to_ty
 255
 256 lintCoreExpr (Note other_note expr)
 257   = lintCoreExpr expr
 258
 259 lintCoreExpr (Let (NonRec bndr rhs) body)
 260   = lintSingleBinding NonRecursive (bndr,rhs)   `seqL`
 261     addLoc (BodyOfLetRec [bndr])
 262            (addInScopeVars [bndr] (lintCoreExpr body))
 263
 264 lintCoreExpr (Let (Rec pairs) body)
 265   = addInScopeVars bndrs        $
 266     mapL (lintSingleBinding Recursive) pairs    `seqL`
 267     addLoc (BodyOfLetRec bndrs) (lintCoreExpr body)
 268   where
 269     bndrs = map fst pairs
 270
 271 lintCoreExpr e@(App fun arg)
 272   = lintCoreExpr fun    `thenL` \ ty ->
 273     addLoc (AnExpr e)   $
 274     lintCoreArg ty arg
 275
 276 lintCoreExpr (Lam var expr)
 277   = addLoc (LambdaBodyOf var)   $
 278     (if isId var then
 279        checkL (not (isUnboxedTupleType (idType var))) (mkUnboxedTupleMsg var)
 280      else
 281        returnL ())
 282                                 `seqL`
 283     (addInScopeVars [var]       $
 284      lintCoreExpr expr          `thenL` \ ty ->
 285
 286      returnL (mkPiType var ty))
 287
 288 lintCoreExpr e@(Case scrut var alts)
 289  =      -- Check the scrutinee
 290    lintCoreExpr scrut                   `thenL` \ scrut_ty ->
 291
 292         -- Check the binder
 293    lintBinder var                                               `seqL`
 294
 295         -- If this is an unboxed tuple case, then the binder must be dead
 296    {-
 297    checkL (if isUnboxedTupleType (idType var)
 298                 then isDeadBinder var
 299                 else True) (mkUnboxedTupleMsg var)              `seqL`
 300    -}
 301
 302    checkTys (idType var) scrut_ty (mkScrutMsg var scrut_ty)     `seqL`
 303
 304    addInScopeVars [var]                         (
 305
 306         -- Check the alternatives
 307    checkCaseAlts e scrut_ty alts                `seqL`
 308
 309    mapL (lintCoreAlt scrut_ty) alts             `thenL` \ (alt_ty : alt_tys) ->
 310    mapL (check alt_ty) alt_tys                  `seqL`
 311    returnL alt_ty)
 312  where
 313    check alt_ty1 alt_ty2 = checkTys alt_ty1 alt_ty2 (mkCaseAltMsg e)
 314
 315 lintCoreExpr e@(Type ty)
 316   = addErrL (mkStrangeTyMsg e)
 317 \end{code}
 318
 319 %************************************************************************
 320 %*                                                                      *
 321 \subsection[lintCoreArgs]{lintCoreArgs}
 322 %*                                                                      *
 323 %************************************************************************
 324
 325 The basic version of these functions checks that the argument is a
 326 subtype of the required type, as one would expect.
 327
 328 \begin{code}
 329 lintCoreArgs :: Type -> [CoreArg] -> LintM Type
 330 lintCoreArgs = lintCoreArgs0 checkTys
 331
 332 lintCoreArg :: Type -> CoreArg -> LintM Type
 333 lintCoreArg = lintCoreArg0 checkTys
 334 \end{code}
 335
 336 The primitive version of these functions takes a check argument,
 337 allowing a different comparison.
 338
 339 \begin{code}
 340 lintCoreArgs0 check_tys ty [] = returnL ty
 341 lintCoreArgs0 check_tys ty (a : args)
 342   = lintCoreArg0  check_tys ty a        `thenL` \ res ->
 343     lintCoreArgs0 check_tys res args
 344
 345 lintCoreArg0 check_tys ty a@(Type arg_ty)
 346   = lintTy arg_ty                       `seqL`
 347     lintTyApp ty arg_ty
 348
 349 lintCoreArg0 check_tys fun_ty arg
 350   = -- Make sure function type matches argument
 351     lintCoreExpr arg            `thenL` \ arg_ty ->
 352     let
 353       err = mkAppMsg fun_ty arg_ty
 354     in
 355     case splitFunTy_maybe fun_ty of
 356       Just (arg,res) -> check_tys arg arg_ty err `seqL`
 357                         returnL res
 358       _              -> addErrL err
 359 \end{code}
 360
 361 \begin{code}
 362 lintTyApp ty arg_ty
 363   = case splitForAllTy_maybe ty of
 364       Nothing -> addErrL (mkTyAppMsg ty arg_ty)
 365
 366       Just (tyvar,body) ->
 367         if not (isTyVar tyvar) then addErrL (mkTyAppMsg ty arg_ty) else
 368         let
 369             tyvar_kind = tyVarKind tyvar
 370             argty_kind = typeKind arg_ty
 371         in
 372         if argty_kind `hasMoreBoxityInfo` tyvar_kind
 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          then
 378             returnL (substTy (mkTyVarSubst [tyvar] [arg_ty]) body)
 379         else
 380             addErrL (mkKindErrMsg tyvar arg_ty)
 381
 382 lintTyApps fun_ty []
 383   = returnL fun_ty
 384
 385 lintTyApps fun_ty (arg_ty : arg_tys)
 386   = lintTyApp fun_ty arg_ty             `thenL` \ fun_ty' ->
 387     lintTyApps fun_ty' arg_tys
 388 \end{code}
 389
 390
 391
 392 %************************************************************************
 393 %*                                                                      *
 394 \subsection[lintCoreAlts]{lintCoreAlts}
 395 %*                                                                      *
 396 %************************************************************************
 397
 398 \begin{code}
 399 checkCaseAlts :: CoreExpr -> Type -> [CoreAlt] -> LintM ()
 400 -- a) Check that the alts are non-empty
 401 -- b) Check that the DEFAULT comes first, if it exists
 402 -- c) Check that there's a default for infinite types
 403 -- NB: Algebraic cases are not necessarily exhaustive, because
 404 --     the simplifer correctly eliminates case that can't
 405 --     possibly match.
 406
 407 checkCaseAlts e ty []
 408   = addErrL (mkNullAltsMsg e)
 409
 410 checkCaseAlts e ty alts
 411   = checkL (all non_deflt con_alts) (mkNonDefltMsg e)   `seqL`
 412     checkL (isJust maybe_deflt || not is_infinite_ty)
 413            (nonExhaustiveAltsMsg e)
 414   where
 415     (con_alts, maybe_deflt) = findDefault alts
 416
 417     non_deflt (DEFAULT, _, _) = False
 418     non_deflt alt             = True
 419
 420     is_infinite_ty = case splitTyConApp_maybe ty of
 421                         Nothing                     -> False
 422                         Just (tycon, tycon_arg_tys) -> isPrimTyCon tycon
 423 \end{code}
 424
 425 \begin{code}
 426 lintCoreAlt :: Type                     -- Type of scrutinee
 427             -> CoreAlt
 428             -> LintM Type               -- Type of alternatives
 429
 430 lintCoreAlt scrut_ty alt@(DEFAULT, args, rhs)
 431   = checkL (null args) (mkDefaultArgsMsg args)  `seqL`
 432     lintCoreExpr rhs
 433
 434 lintCoreAlt scrut_ty alt@(LitAlt lit, args, rhs)
 435   = checkL (null args) (mkDefaultArgsMsg args)  `seqL`
 436     checkTys lit_ty scrut_ty
 437              (mkBadPatMsg lit_ty scrut_ty)      `seqL`
 438     lintCoreExpr rhs
 439   where
 440     lit_ty = literalType lit
 441
 442 lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs)
 443   = addLoc (CaseAlt alt) (
 444
 445     mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg)))
 446                         (mkUnboxedTupleMsg arg)) args `seqL`
 447
 448     addInScopeVars args (
 449
 450         -- Check the pattern
 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     case splitTyConApp scrut_ty of { (tycon, tycon_arg_tys) ->
 455         lintTyApps (dataConRepType con) tycon_arg_tys   `thenL` \ con_type ->
 456         lintCoreArgs con_type (map mk_arg args)         `thenL` \ con_result_ty ->
 457         checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
 458     }                                           `seqL`
 459
 460         -- Check the RHS
 461     lintCoreExpr rhs
 462     ))
 463   where
 464     mk_arg b | isTyVar b = Type (mkTyVarTy b)
 465              | isId    b = Var b
 466              | otherwise = pprPanic "lintCoreAlt:mk_arg " (ppr b)
 467 \end{code}
 468
 469 %************************************************************************
 470 %*                                                                      *
 471 \subsection[lint-types]{Types}
 472 %*                                                                      *
 473 %************************************************************************
 474
 475 \begin{code}
 476 lintBinder :: Var -> LintM ()
 477 lintBinder v = nopL
 478 -- ToDo: lint its type
 479 -- ToDo: lint its rules
 480
 481 lintTy :: Type -> LintM ()
 482 lintTy ty = mapL checkIdInScope (varSetElems (tyVarsOfType ty)) `seqL`
 483             returnL ()
 484         -- ToDo: check the kind structure of the type
 485 \end{code}
 486
 487
 488 %************************************************************************
 489 %*                                                                      *
 490 \subsection[lint-monad]{The Lint monad}
 491 %*                                                                      *
 492 %************************************************************************
 493
 494 \begin{code}
 495 type LintM a = [LintLocInfo]    -- Locations
 496             -> IdSet            -- Local vars in scope
 497             -> Bag ErrMsg       -- Error messages so far
 498             -> Bag WarnMsg      -- Warning messages so far
 499             -> (Maybe a, Bag ErrMsg, Bag WarnMsg)  -- Result and error/warning messages (if any)
 500
 501 data LintLocInfo
 502   = RhsOf Id            -- The variable bound
 503   | LambdaBodyOf Id     -- The lambda-binder
 504   | BodyOfLetRec [Id]   -- One of the binders
 505   | CaseAlt CoreAlt     -- Pattern of a case alternative
 506   | AnExpr CoreExpr     -- Some expression
 507   | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
 508 \end{code}
 509
 510 \begin{code}
 511 initL :: LintM a -> (Maybe Message {- errors -}, Maybe Message {- warnings -})
 512 initL m
 513   = case m [] emptyVarSet emptyBag emptyBag of
 514       (_, errs, warns) -> (ifNonEmptyBag errs  pprBagOfErrors,
 515                            ifNonEmptyBag warns pprBagOfWarnings)
 516   where
 517     ifNonEmptyBag bag f | isEmptyBag bag = Nothing
 518                         | otherwise      = Just (f bag)
 519
 520 returnL :: a -> LintM a
 521 returnL r loc scope errs warns = (Just r, errs, warns)
 522
 523 nopL :: LintM a
 524 nopL loc scope errs warns = (Nothing, errs, warns)
 525
 526 thenL :: LintM a -> (a -> LintM b) -> LintM b
 527 thenL m k loc scope errs warns
 528   = case m loc scope errs warns of
 529       (Just r, errs', warns')  -> k r loc scope errs' warns'
 530       (Nothing, errs', warns') -> (Nothing, errs', warns')
 531
 532 seqL :: LintM a -> LintM b -> LintM b
 533 seqL m k loc scope errs warns
 534   = case m loc scope errs warns of
 535       (_, errs', warns') -> k loc scope errs' warns'
 536
 537 mapL :: (a -> LintM b) -> [a] -> LintM [b]
 538 mapL f [] = returnL []
 539 mapL f (x:xs)
 540   = f x         `thenL` \ r ->
 541     mapL f xs   `thenL` \ rs ->
 542     returnL (r:rs)
 543 \end{code}
 544
 545 \begin{code}
 546 checkL :: Bool -> Message -> LintM ()
 547 checkL True  msg = nopL
 548 checkL False msg = addErrL msg
 549
 550 addErrL :: Message -> LintM a
 551 addErrL msg loc scope errs warns = (Nothing, addErr errs msg loc, warns)
 552
 553 addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg
 554 -- errors or warnings, actually... they're the same type.
 555 addErr errs_so_far msg locs
 556   = ASSERT( not (null locs) )
 557     errs_so_far `snocBag` mk_msg msg
 558   where
 559    (loc, cxt1) = dumpLoc (head locs)
 560    cxts        = [snd (dumpLoc loc) | loc <- locs]
 561    context     | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1
 562                | otherwise          = cxt1
 563
 564    mk_msg msg = addErrLocHdrLine loc context msg
 565
 566 addLoc :: LintLocInfo -> LintM a -> LintM a
 567 addLoc extra_loc m loc scope errs warns
 568   = m (extra_loc:loc) scope errs warns
 569
 570 addInScopeVars :: [Var] -> LintM a -> LintM a
 571 addInScopeVars ids m loc scope errs warns
 572   = m loc (scope `unionVarSet` mkVarSet ids) errs warns
 573 \end{code}
 574
 575 \begin{code}
 576 checkIdInScope :: Var -> LintM ()
 577 checkIdInScope id
 578   = checkInScope (ptext SLIT("is out of scope")) id
 579
 580 checkBndrIdInScope :: Var -> Var -> LintM ()
 581 checkBndrIdInScope binder id
 582   = checkInScope msg id
 583     where
 584      msg = ptext SLIT("is out of scope inside info for") <+>
 585            ppr binder
 586
 587 checkInScope :: SDoc -> Var -> LintM ()
 588 checkInScope loc_msg var loc scope errs warns
 589   |  mustHaveLocalBinding var && not (var `elemVarSet` scope)
 590   = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc, warns)
 591   | otherwise
 592   = nopL loc scope errs warns
 593
 594 checkTys :: Type -> Type -> Message -> LintM ()
 595 -- check ty2 is subtype of ty1 (ie, has same structure but usage
 596 -- annotations need only be consistent, not equal)
 597 checkTys ty1 ty2 msg
 598   | ty1 `eqType` ty2 = nopL
 599   | otherwise        = addErrL msg
 600 \end{code}
 601
 602
 603 %************************************************************************
 604 %*                                                                      *
 605 \subsection{Error messages}
 606 %*                                                                      *
 607 %************************************************************************
 608
 609 \begin{code}
 610 dumpLoc (RhsOf v)
 611   = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))
 612
 613 dumpLoc (LambdaBodyOf b)
 614   = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
 615
 616 dumpLoc (BodyOfLetRec [])
 617   = (noSrcLoc, brackets (ptext SLIT("In body of a letrec with no binders")))
 618
 619 dumpLoc (BodyOfLetRec bs@(_:_))
 620   = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
 621
 622 dumpLoc (AnExpr e)
 623   = (noSrcLoc, text "In the expression:" <+> ppr e)
 624
 625 dumpLoc (CaseAlt (con, args, rhs))
 626   = (noSrcLoc, text "In a case pattern:" <+> parens (ppr con <+> ppr args))
 627
 628 dumpLoc (ImportedUnfolding locn)
 629   = (locn, brackets (ptext SLIT("in an imported unfolding")))
 630
 631 pp_binders :: [Var] -> SDoc
 632 pp_binders bs = sep (punctuate comma (map pp_binder bs))
 633
 634 pp_binder :: Var -> SDoc
 635 pp_binder b | isId b    = hsep [ppr b, dcolon, ppr (idType b)]
 636             | isTyVar b = hsep [ppr b, dcolon, ppr (tyVarKind b)]
 637 \end{code}
 638
 639 \begin{code}
 640 ------------------------------------------------------
 641 --      Messages for case expressions
 642
 643 mkNullAltsMsg :: CoreExpr -> Message
 644 mkNullAltsMsg e
 645   = hang (text "Case expression with no alternatives:")
 646          4 (ppr e)
 647
 648 mkDefaultArgsMsg :: [Var] -> Message
 649 mkDefaultArgsMsg args
 650   = hang (text "DEFAULT case with binders")
 651          4 (ppr args)
 652
 653 mkCaseAltMsg :: CoreExpr -> Message
 654 mkCaseAltMsg e
 655   = hang (text "Type of case alternatives not the same:")
 656          4 (ppr e)
 657
 658 mkScrutMsg :: Id -> Type -> Message
 659 mkScrutMsg var scrut_ty
 660   = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
 661           text "Result binder type:" <+> ppr (idType var),
 662           text "Scrutinee type:" <+> ppr scrut_ty]
 663
 664
 665 mkNonDefltMsg e
 666   = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
 667
 668 nonExhaustiveAltsMsg :: CoreExpr -> Message
 669 nonExhaustiveAltsMsg e
 670   = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
 671
 672 mkBadPatMsg :: Type -> Type -> Message
 673 mkBadPatMsg con_result_ty scrut_ty
 674   = vcat [
 675         text "In a case alternative, pattern result type doesn't match scrutinee type:",
 676         text "Pattern result type:" <+> ppr con_result_ty,
 677         text "Scrutinee type:" <+> ppr scrut_ty
 678     ]
 679
 680 ------------------------------------------------------
 681 --      Other error messages
 682
 683 mkAppMsg :: Type -> Type -> Message
 684 mkAppMsg fun arg
 685   = vcat [ptext SLIT("Argument value doesn't match argument type:"),
 686               hang (ptext SLIT("Fun type:")) 4 (ppr fun),
 687               hang (ptext SLIT("Arg type:")) 4 (ppr arg)]
 688
 689 mkKindErrMsg :: TyVar -> Type -> Message
 690 mkKindErrMsg tyvar arg_ty
 691   = vcat [ptext SLIT("Kinds don't match in type application:"),
 692           hang (ptext SLIT("Type variable:"))
 693                  4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
 694           hang (ptext SLIT("Arg type:"))
 695                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
 696
 697 mkTyAppMsg :: Type -> Type -> Message
 698 mkTyAppMsg ty arg_ty
 699   = vcat [text "Illegal type application:",
 700               hang (ptext SLIT("Exp type:"))
 701                  4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
 702               hang (ptext SLIT("Arg type:"))
 703                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
 704
 705 mkRhsMsg :: Id -> Type -> Message
 706 mkRhsMsg binder ty
 707   = vcat
 708     [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
 709             ppr binder],
 710      hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
 711      hsep [ptext SLIT("Rhs type:"), ppr ty]]
 712
 713 mkRhsPrimMsg :: Id -> CoreExpr -> Message
 714 mkRhsPrimMsg binder rhs
 715   = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
 716                      ppr binder],
 717               hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
 718              ]
 719
 720 mkUnboxedTupleMsg :: Id -> Message
 721 mkUnboxedTupleMsg binder
 722   = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
 723           hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
 724
 725 mkCoerceErr from_ty expr_ty
 726   = vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"),
 727           ptext SLIT("From-type:") <+> ppr from_ty,
 728           ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
 729     ]
 730
 731 mkStrangeTyMsg e
 732   = ptext SLIT("Type where expression expected:") <+> ppr e
 733 \end{code}