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