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