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 {-              No longer needed
 383 #ifdef DEBUG
 384         -- Algebraic cases are not necessarily exhaustive, because
 385         -- the simplifer correctly eliminates case that can't
 386         -- possibly match.
 387         -- This code just emits a message to say so
 388     let
 389         missing_cons    = filter not_in_alts (tyConDataCons tycon)
 390         not_in_alts con = all (not_in_alt con) alts
 391         not_in_alt con (DataCon con', _, _) = con /= con'
 392         not_in_alt con other                = True
 393
 394         case_bndr = case e of { Case _ bndr alts -> bndr }
 395     in
 396     if not (hasDefault alts || null missing_cons) then
 397         pprTrace "Exciting (but not a problem)!  Non-exhaustive case:"
 398                  (ppr case_bndr <+> ppr missing_cons)
 399                  nopL
 400     else
 401 #endif
 402 -}
 403     nopL }
 404
 405 hasDefault []                     = False
 406 hasDefault ((DEFAULT,_,_) : alts) = True
 407 hasDefault (alt           : alts) = hasDefault alts
 408 \end{code}
 409
 410 \begin{code}
 411 lintCoreAlt :: Type                     -- Type of scrutinee
 412             -> CoreAlt
 413             -> LintM Type               -- Type of alternatives
 414
 415 lintCoreAlt scrut_ty alt@(DEFAULT, args, rhs)
 416   = checkL (null args) (mkDefaultArgsMsg args)  `seqL`
 417     lintCoreExpr rhs
 418
 419 lintCoreAlt scrut_ty alt@(con, args, rhs)
 420   = addLoc (CaseAlt alt) (
 421
 422     checkL (conOkForAlt con) (mkConAltMsg con)  `seqL`
 423
 424     mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg)))
 425                         (mkUnboxedTupleMsg arg)) args `seqL`
 426
 427     addInScopeVars args (
 428
 429         -- Check the pattern
 430         -- Scrutinee type must be a tycon applicn; checked by caller
 431         -- This code is remarkably compact considering what it does!
 432         -- NB: args must be in scope here so that the lintCoreArgs line works.
 433     case splitTyConApp_maybe scrut_ty of { Just (tycon, tycon_arg_tys) ->
 434         lintTyApps (conType con) tycon_arg_tys  `thenL` \ con_type ->
 435         lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty ->
 436         checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
 437     }                                           `seqL`
 438
 439         -- Check the RHS
 440     lintCoreExpr rhs
 441     ))
 442   where
 443     mk_arg b | isTyVar b = Type (mkTyVarTy b)
 444              | otherwise = Var b
 445 \end{code}
 446
 447 %************************************************************************
 448 %*                                                                      *
 449 \subsection[lint-types]{Types}
 450 %*                                                                      *
 451 %************************************************************************
 452
 453 \begin{code}
 454 lintBinder :: IdOrTyVar -> LintM ()
 455 lintBinder v = nopL
 456 -- ToDo: lint its type
 457
 458 lintTy :: Type -> LintM ()
 459 lintTy ty = mapL checkIdInScope (varSetElems (tyVarsOfType ty)) `seqL`
 460             returnL ()
 461         -- ToDo: check the kind structure of the type
 462 \end{code}
 463
 464
 465 %************************************************************************
 466 %*                                                                      *
 467 \subsection[lint-monad]{The Lint monad}
 468 %*                                                                      *
 469 %************************************************************************
 470
 471 \begin{code}
 472 type LintM a = [LintLocInfo]    -- Locations
 473             -> IdSet            -- Local vars in scope
 474             -> Bag ErrMsg       -- Error messages so far
 475             -> (Maybe a, Bag ErrMsg)    -- Result and error messages (if any)
 476
 477 data LintLocInfo
 478   = RhsOf Id            -- The variable bound
 479   | LambdaBodyOf Id     -- The lambda-binder
 480   | BodyOfLetRec [Id]   -- One of the binders
 481   | CaseAlt CoreAlt     -- Pattern of a case alternative
 482   | AnExpr CoreExpr     -- Some expression
 483   | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
 484 \end{code}
 485
 486 \begin{code}
 487 initL :: LintM a -> Maybe Message
 488 initL m
 489   = case (m [] emptyVarSet emptyBag) of { (_, errs) ->
 490     if isEmptyBag errs then
 491         Nothing
 492     else
 493         Just (pprBagOfErrors errs)
 494     }
 495
 496 returnL :: a -> LintM a
 497 returnL r loc scope errs = (Just r, errs)
 498
 499 nopL :: LintM a
 500 nopL loc scope errs = (Nothing, errs)
 501
 502 thenL :: LintM a -> (a -> LintM b) -> LintM b
 503 thenL m k loc scope errs
 504   = case m loc scope errs of
 505       (Just r, errs')  -> k r loc scope errs'
 506       (Nothing, errs') -> (Nothing, errs')
 507
 508 seqL :: LintM a -> LintM b -> LintM b
 509 seqL m k loc scope errs
 510   = case m loc scope errs of
 511       (_, errs') -> k loc scope errs'
 512
 513 mapL :: (a -> LintM b) -> [a] -> LintM [b]
 514 mapL f [] = returnL []
 515 mapL f (x:xs)
 516   = f x         `thenL` \ r ->
 517     mapL f xs   `thenL` \ rs ->
 518     returnL (r:rs)
 519 \end{code}
 520
 521 \begin{code}
 522 checkL :: Bool -> Message -> LintM ()
 523 checkL True  msg loc scope errs = (Nothing, errs)
 524 checkL False msg loc scope errs = (Nothing, addErr errs msg loc)
 525
 526 addErrL :: Message -> LintM a
 527 addErrL msg loc scope errs = (Nothing, addErr errs msg loc)
 528
 529 addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg
 530
 531 addErr errs_so_far msg locs
 532   = ASSERT (not (null locs))
 533     errs_so_far `snocBag` mk_msg msg
 534   where
 535    (loc, cxt1) = dumpLoc (head locs)
 536    cxts        = [snd (dumpLoc loc) | loc <- locs]
 537    context     | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1
 538                | otherwise          = cxt1
 539
 540    mk_msg msg
 541      | isNoSrcLoc loc = (loc, hang context 4 msg)
 542      | otherwise      = addErrLocHdrLine loc context msg
 543
 544 addLoc :: LintLocInfo -> LintM a -> LintM a
 545 addLoc extra_loc m loc scope errs
 546   = m (extra_loc:loc) scope errs
 547
 548 addInScopeVars :: [IdOrTyVar] -> LintM a -> LintM a
 549 addInScopeVars ids m loc scope errs
 550   = m loc (scope `unionVarSet` mkVarSet ids) errs
 551 \end{code}
 552
 553 \begin{code}
 554 checkIdInScope :: IdOrTyVar -> LintM ()
 555 checkIdInScope id
 556   = checkInScope (ptext SLIT("is out of scope")) id
 557
 558 checkBndrIdInScope :: IdOrTyVar -> IdOrTyVar -> LintM ()
 559 checkBndrIdInScope binder id
 560   = checkInScope msg id
 561     where
 562      msg = ptext SLIT("is out of scope inside info for") <+>
 563            ppr binder
 564
 565 checkInScope :: SDoc -> IdOrTyVar -> LintM ()
 566 checkInScope loc_msg var loc scope errs
 567   |  isLocallyDefined var
 568   && not (var `elemVarSet` scope)
 569   && not (isId var && idMustBeINLINEd var)      -- Constructors and dict selectors
 570                                                 -- don't have bindings,
 571                                                 -- just MustInline prags
 572   = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc)
 573   | otherwise
 574   = (Nothing,errs)
 575
 576 checkTys :: Type -> Type -> Message -> LintM ()
 577 checkTys ty1 ty2 msg loc scope errs
 578   | ty1 == ty2 = (Nothing, errs)
 579   | otherwise  = (Nothing, addErr errs msg loc)
 580 \end{code}
 581
 582
 583 %************************************************************************
 584 %*                                                                      *
 585 \subsection{Error messages}
 586 %*                                                                      *
 587 %************************************************************************
 588
 589 \begin{code}
 590 dumpLoc (RhsOf v)
 591   = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))
 592
 593 dumpLoc (LambdaBodyOf b)
 594   = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
 595
 596 dumpLoc (BodyOfLetRec bs)
 597   = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
 598
 599 dumpLoc (AnExpr e)
 600   = (noSrcLoc, text "In the expression:" <+> ppr e)
 601
 602 dumpLoc (CaseAlt (con, args, rhs))
 603   = (noSrcLoc, text "In a case pattern:" <+> parens (ppr con <+> ppr args))
 604
 605 dumpLoc (ImportedUnfolding locn)
 606   = (locn, brackets (ptext SLIT("in an imported unfolding")))
 607
 608 pp_binders :: [Id] -> SDoc
 609 pp_binders bs = sep (punctuate comma (map pp_binder bs))
 610
 611 pp_binder :: Id -> SDoc
 612 pp_binder b = hsep [ppr b, dcolon, ppr (idType b)]
 613 \end{code}
 614
 615 \begin{code}
 616 ------------------------------------------------------
 617 --      Messages for case expressions
 618
 619 mkConAppMsg :: CoreExpr -> Message
 620 mkConAppMsg e
 621   = hang (text "Application of newtype constructor:")
 622          4 (ppr e)
 623
 624 mkConAltMsg :: Con -> Message
 625 mkConAltMsg con
 626   = text "PrimOp in case pattern:" <+> ppr con
 627
 628 mkNullAltsMsg :: CoreExpr -> Message
 629 mkNullAltsMsg e
 630   = hang (text "Case expression with no alternatives:")
 631          4 (ppr e)
 632
 633 mkDefaultArgsMsg :: [IdOrTyVar] -> Message
 634 mkDefaultArgsMsg args
 635   = hang (text "DEFAULT case with binders")
 636          4 (ppr args)
 637
 638 mkCaseAltMsg :: CoreExpr -> Message
 639 mkCaseAltMsg e
 640   = hang (text "Type of case alternatives not the same:")
 641          4 (ppr e)
 642
 643 mkScrutMsg :: Id -> Type -> Message
 644 mkScrutMsg var scrut_ty
 645   = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
 646           text "Result binder type:" <+> ppr (idType var),
 647           text "Scrutinee type:" <+> ppr scrut_ty]
 648
 649 badAltsMsg :: CoreExpr -> Message
 650 badAltsMsg e
 651   = hang (text "Case statement scrutinee is not a data type:")
 652          4 (ppr e)
 653
 654 nonExhaustiveAltsMsg :: CoreExpr -> Message
 655 nonExhaustiveAltsMsg e
 656   = hang (text "Case expression with non-exhaustive alternatives")
 657          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}