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