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