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, Message,
  30                           ErrMsg, addErrLocHdrLine, pprBagOfErrors )
  31 import PrimRep          ( PrimRep(..) )
  32 import SrcLoc           ( SrcLoc, noSrcLoc, isNoSrcLoc )
  33 import Type             ( Type, Kind, tyVarsOfType,
  34                           splitFunTy_maybe, mkPiType, mkTyVarTy,
  35                           splitForAllTy_maybe, splitTyConApp_maybe,
  36                           isUnLiftedType, typeKind, substTy,
  37                           splitAlgTyConApp_maybe,
  38                           isUnboxedTupleType,
  39                           hasMoreBoxityInfo
  40                         )
  41 import TyCon            ( TyCon, isPrimTyCon, tyConDataCons )
  42 import Outputable
  43
  44 infixr 9 `thenL`, `seqL`
  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
 298 lintCoreExpr e@(Type ty)
 299   = addErrL (mkStrangeTyMsg e)
 300 \end{code}
 301
 302 %************************************************************************
 303 %*                                                                      *
 304 \subsection[lintCoreArgs]{lintCoreArgs}
 305 %*                                                                      *
 306 %************************************************************************
 307
 308 The boolean argument indicates whether we should flag type
 309 applications to primitive types as being errors.
 310
 311 \begin{code}
 312 lintCoreArgs :: Type -> [CoreArg] -> LintM Type
 313
 314 lintCoreArgs ty [] = returnL ty
 315 lintCoreArgs ty (a : args)
 316   = lintCoreArg  ty a           `thenL` \ res ->
 317     lintCoreArgs res args
 318 \end{code}
 319
 320 \begin{code}
 321 lintCoreArg :: Type -> CoreArg -> LintM Type
 322
 323 lintCoreArg ty a@(Type arg_ty)
 324   = lintTy arg_ty                       `seqL`
 325     lintTyApp ty arg_ty
 326
 327 lintCoreArg fun_ty arg
 328   = -- Make sure function type matches argument
 329     lintCoreExpr arg            `thenL` \ arg_ty ->
 330     case (splitFunTy_maybe fun_ty) of
 331       Just (arg,res) | (arg_ty == arg) -> returnL res
 332       _                                -> addErrL (mkAppMsg fun_ty arg_ty)
 333 \end{code}
 334
 335 \begin{code}
 336 lintTyApp ty arg_ty
 337   = case splitForAllTy_maybe ty of
 338       Nothing -> addErrL (mkTyAppMsg ty arg_ty)
 339
 340       Just (tyvar,body) ->
 341         let
 342             tyvar_kind = tyVarKind tyvar
 343             argty_kind = typeKind arg_ty
 344         in
 345         if argty_kind `hasMoreBoxityInfo` tyvar_kind
 346                 -- Arg type might be boxed for a function with an uncommitted
 347                 -- tyvar; notably this is used so that we can give
 348                 --      error :: forall a:*. String -> a
 349                 -- and then apply it to both boxed and unboxed types.
 350          then
 351             returnL (substTy (mkVarEnv [(tyvar,arg_ty)]) body)
 352         else
 353             addErrL (mkKindErrMsg tyvar arg_ty)
 354
 355 lintTyApps fun_ty []
 356   = returnL fun_ty
 357
 358 lintTyApps fun_ty (arg_ty : arg_tys)
 359   = lintTyApp fun_ty arg_ty             `thenL` \ fun_ty' ->
 360     lintTyApps fun_ty' arg_tys
 361 \end{code}
 362
 363
 364
 365 %************************************************************************
 366 %*                                                                      *
 367 \subsection[lintCoreAlts]{lintCoreAlts}
 368 %*                                                                      *
 369 %************************************************************************
 370
 371 \begin{code}
 372 checkAllCasesCovered e ty [] = addErrL (mkNullAltsMsg e)
 373
 374 checkAllCasesCovered e ty [(DEFAULT,_,_)] = nopL
 375
 376 checkAllCasesCovered e scrut_ty alts
 377   = case splitTyConApp_maybe scrut_ty of {
 378         Nothing -> addErrL (badAltsMsg e);
 379         Just (tycon, tycon_arg_tys) ->
 380
 381     if isPrimTyCon tycon then
 382         checkL (hasDefault alts) (nonExhaustiveAltsMsg e)
 383     else
 384 #ifdef DEBUG
 385         -- Algebraic cases are not necessarily exhaustive, because
 386         -- the simplifer correctly eliminates case that can't
 387         -- possibly match.
 388         -- This code just emits a message to say so
 389     let
 390         missing_cons    = filter not_in_alts (tyConDataCons tycon)
 391         not_in_alts con = all (not_in_alt con) alts
 392         not_in_alt con (DataCon con', _, _) = con /= con'
 393         not_in_alt con other                = True
 394
 395         case_bndr = case e of { Case _ bndr alts -> bndr }
 396     in
 397     if not (hasDefault alts || null missing_cons) then
 398         pprTrace "Exciting (but not a problem)!  Non-exhaustive case:"
 399                  (ppr case_bndr <+> ppr missing_cons)
 400                  nopL
 401     else
 402 #endif
 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, pref) = dumpLoc (head locs)
 536
 537    mk_msg msg
 538      | isNoSrcLoc loc = (loc, hang pref 4 msg)
 539      | otherwise      = addErrLocHdrLine loc pref msg
 540
 541 addLoc :: LintLocInfo -> LintM a -> LintM a
 542 addLoc extra_loc m loc scope errs
 543   = m (extra_loc:loc) scope errs
 544
 545 addInScopeVars :: [IdOrTyVar] -> LintM a -> LintM a
 546 addInScopeVars ids m loc scope errs
 547   = m loc (scope `unionVarSet` mkVarSet ids) errs
 548 \end{code}
 549
 550 \begin{code}
 551 checkIdInScope :: IdOrTyVar -> LintM ()
 552 checkIdInScope id
 553   = checkInScope (ptext SLIT("is out of scope")) id
 554
 555 checkBndrIdInScope :: IdOrTyVar -> IdOrTyVar -> LintM ()
 556 checkBndrIdInScope binder id
 557   = checkInScope msg id
 558     where
 559      msg = ptext SLIT("is out of scope inside info for") <+>
 560            ppr binder
 561
 562 checkInScope :: SDoc -> IdOrTyVar -> LintM ()
 563 checkInScope loc_msg id loc scope errs
 564   |  isLocallyDefined id
 565   && not (id `elemVarSet` scope)
 566   && not (idMustBeINLINEd id)   -- Constructors and dict selectors
 567                                 -- don't have bindings,
 568                                 -- just MustInline prags
 569   = (Nothing, addErr errs (hsep [ppr id, loc_msg]) loc)
 570   | otherwise
 571   = (Nothing,errs)
 572
 573 checkTys :: Type -> Type -> Message -> LintM ()
 574 checkTys ty1 ty2 msg loc scope errs
 575   | ty1 == ty2 = (Nothing, errs)
 576   | otherwise  = (Nothing, addErr errs msg loc)
 577 \end{code}
 578
 579
 580 %************************************************************************
 581 %*                                                                      *
 582 \subsection{Error messages}
 583 %*                                                                      *
 584 %************************************************************************
 585
 586 \begin{code}
 587 dumpLoc (RhsOf v)
 588   = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))
 589
 590 dumpLoc (LambdaBodyOf b)
 591   = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
 592
 593 dumpLoc (BodyOfLetRec bs)
 594   = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
 595
 596 dumpLoc (AnExpr e)
 597   = (noSrcLoc, text "In the expression:" <+> ppr e)
 598
 599 dumpLoc (CaseAlt (con, args, rhs))
 600   = (noSrcLoc, text "In a case pattern:" <+> parens (ppr con <+> ppr args))
 601
 602 dumpLoc (ImportedUnfolding locn)
 603   = (locn, brackets (ptext SLIT("in an imported unfolding")))
 604
 605 pp_binders :: [Id] -> SDoc
 606 pp_binders bs = sep (punctuate comma (map pp_binder bs))
 607
 608 pp_binder :: Id -> SDoc
 609 pp_binder b = hsep [ppr b, dcolon, ppr (idType b)]
 610 \end{code}
 611
 612 \begin{code}
 613 ------------------------------------------------------
 614 --      Messages for case expressions
 615
 616 mkConAppMsg :: CoreExpr -> Message
 617 mkConAppMsg e
 618   = hang (text "Application of newtype constructor:")
 619          4 (ppr e)
 620
 621 mkConAltMsg :: Con -> Message
 622 mkConAltMsg con
 623   = text "PrimOp in case pattern:" <+> ppr con
 624
 625 mkNullAltsMsg :: CoreExpr -> Message
 626 mkNullAltsMsg e
 627   = hang (text "Case expression with no alternatives:")
 628          4 (ppr e)
 629
 630 mkDefaultArgsMsg :: [IdOrTyVar] -> Message
 631 mkDefaultArgsMsg args
 632   = hang (text "DEFAULT case with binders")
 633          4 (ppr args)
 634
 635 mkCaseAltMsg :: CoreExpr -> Message
 636 mkCaseAltMsg e
 637   = hang (text "Type of case alternatives not the same:")
 638          4 (ppr e)
 639
 640 mkScrutMsg :: Id -> Type -> Message
 641 mkScrutMsg var scrut_ty
 642   = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
 643           text "Result binder type:" <+> ppr (idType var),
 644           text "Scrutinee type:" <+> ppr scrut_ty]
 645
 646 badAltsMsg :: CoreExpr -> Message
 647 badAltsMsg e
 648   = hang (text "Case statement scrutinee is not a data type:")
 649          4 (ppr e)
 650
 651 nonExhaustiveAltsMsg :: CoreExpr -> Message
 652 nonExhaustiveAltsMsg e
 653   = hang (text "Case expression with non-exhaustive alternatives")
 654          4 (ppr e)
 655
 656 mkBadPatMsg :: Type -> Type -> Message
 657 mkBadPatMsg con_result_ty scrut_ty
 658   = vcat [
 659         text "In a case alternative, pattern result type doesn't match scrutinee type:",
 660         text "Pattern result type:" <+> ppr con_result_ty,
 661         text "Scrutinee type:" <+> ppr scrut_ty
 662     ]
 663
 664 ------------------------------------------------------
 665 --      Other error messages
 666
 667 mkAppMsg :: Type -> Type -> Message
 668 mkAppMsg fun arg
 669   = vcat [ptext SLIT("Argument value doesn't match argument type:"),
 670               hang (ptext SLIT("Fun type:")) 4 (ppr fun),
 671               hang (ptext SLIT("Arg type:")) 4 (ppr arg)]
 672
 673 mkKindErrMsg :: TyVar -> Type -> Message
 674 mkKindErrMsg tyvar arg_ty
 675   = vcat [ptext SLIT("Kinds don't match in type application:"),
 676           hang (ptext SLIT("Type variable:"))
 677                  4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
 678           hang (ptext SLIT("Arg type:"))
 679                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
 680
 681 mkTyAppMsg :: Type -> Type -> Message
 682 mkTyAppMsg ty arg_ty
 683   = vcat [text "Illegal type application:",
 684               hang (ptext SLIT("Exp type:"))
 685                  4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
 686               hang (ptext SLIT("Arg type:"))
 687                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
 688
 689 mkRhsMsg :: Id -> Type -> Message
 690 mkRhsMsg binder ty
 691   = vcat
 692     [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
 693             ppr binder],
 694      hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
 695      hsep [ptext SLIT("Rhs type:"), ppr ty]]
 696
 697 mkRhsPrimMsg :: Id -> CoreExpr -> Message
 698 mkRhsPrimMsg binder rhs
 699   = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
 700                      ppr binder],
 701               hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
 702              ]
 703
 704 mkUnboxedTupleMsg :: Id -> Message
 705 mkUnboxedTupleMsg binder
 706   = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
 707           hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
 708
 709 mkCoerceErr from_ty expr_ty
 710   = vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"),
 711           ptext SLIT("From-type:") <+> ppr from_ty,
 712           ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
 713     ]
 714
 715 mkStrangeTyMsg e
 716   = ptext SLIT("Type where expression expected:") <+> ppr e
 717 \end{code}