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