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