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