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
 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 ErrMsg
 488 initL m
 489   = case (m [] emptyVarSet emptyBag) of { (_, errs) ->
 490     if isEmptyBag errs then
 491         Nothing
 492     else
 493         Just (vcat (bagToList 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 -> ErrMsg -> 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 :: ErrMsg -> LintM a
 527 addErrL msg loc scope errs = (Nothing, addErr errs msg loc)
 528
 529 addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg
 530
 531 addErr errs_so_far msg locs
 532   = ASSERT (not (null locs))
 533     errs_so_far `snocBag` (hang (pprLoc (head locs)) 4 msg)
 534
 535 addLoc :: LintLocInfo -> LintM a -> LintM a
 536 addLoc extra_loc m loc scope errs
 537   = m (extra_loc:loc) scope errs
 538
 539 addInScopeVars :: [IdOrTyVar] -> LintM a -> LintM a
 540 addInScopeVars ids m loc scope errs
 541   = m loc (scope `unionVarSet` mkVarSet ids) errs
 542 \end{code}
 543
 544 \begin{code}
 545 checkIdInScope :: IdOrTyVar -> LintM ()
 546 checkIdInScope id
 547   = checkInScope (ptext SLIT("is out of scope")) id
 548
 549 checkBndrIdInScope :: IdOrTyVar -> IdOrTyVar -> LintM ()
 550 checkBndrIdInScope binder id
 551   = checkInScope msg id
 552     where
 553      msg = ptext SLIT("is out of scope inside info for") <+>
 554            ppr binder
 555
 556 checkInScope :: SDoc -> IdOrTyVar -> LintM ()
 557 checkInScope loc_msg id loc scope errs
 558   |  isLocallyDefined id
 559   && not (id `elemVarSet` scope)
 560   && not (idMustBeINLINEd id)   -- Constructors and dict selectors
 561                                 -- don't have bindings,
 562                                 -- just MustInline prags
 563   = (Nothing, addErr errs (hsep [ppr id, loc_msg]) loc)
 564   | otherwise
 565   = (Nothing,errs)
 566
 567 checkTys :: Type -> Type -> ErrMsg -> LintM ()
 568 checkTys ty1 ty2 msg loc scope errs
 569   | ty1 == ty2 = (Nothing, errs)
 570   | otherwise  = (Nothing, addErr errs msg loc)
 571 \end{code}
 572
 573
 574 %************************************************************************
 575 %*                                                                      *
 576 \subsection{Error messages}
 577 %*                                                                      *
 578 %************************************************************************
 579
 580 \begin{code}
 581 pprLoc (RhsOf v)
 582   = ppr (getSrcLoc v) <> colon <+>
 583         brackets (ptext SLIT("RHS of") <+> pp_binders [v])
 584
 585 pprLoc (LambdaBodyOf b)
 586   = ppr (getSrcLoc b) <> colon <+>
 587         brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b)
 588
 589 pprLoc (BodyOfLetRec bs)
 590   = ppr (getSrcLoc (head bs)) <> colon <+>
 591         brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs)
 592
 593 pprLoc (AnExpr e)
 594   = text "In the expression:" <+> ppr e
 595
 596 pprLoc (CaseAlt (con, args, rhs))
 597   = text "In a case pattern:" <+> parens (ppr con <+> ppr args)
 598
 599 pprLoc (ImportedUnfolding locn)
 600   = ppr locn <> colon <+>
 601         brackets (ptext SLIT("in an imported unfolding"))
 602
 603 pp_binders :: [Id] -> SDoc
 604 pp_binders bs = sep (punctuate comma (map pp_binder bs))
 605
 606 pp_binder :: Id -> SDoc
 607 pp_binder b = hsep [ppr b, dcolon, ppr (idType b)]
 608 \end{code}
 609
 610 \begin{code}
 611 ------------------------------------------------------
 612 --      Messages for case expressions
 613
 614 mkConAppMsg :: CoreExpr -> ErrMsg
 615 mkConAppMsg e
 616   = hang (text "Application of newtype constructor:")
 617          4 (ppr e)
 618
 619 mkConAltMsg :: Con -> ErrMsg
 620 mkConAltMsg con
 621   = text "PrimOp in case pattern:" <+> ppr con
 622
 623 mkNullAltsMsg :: CoreExpr -> ErrMsg
 624 mkNullAltsMsg e
 625   = hang (text "Case expression with no alternatives:")
 626          4 (ppr e)
 627
 628 mkDefaultArgsMsg :: [IdOrTyVar] -> ErrMsg
 629 mkDefaultArgsMsg args
 630   = hang (text "DEFAULT case with binders")
 631          4 (ppr args)
 632
 633 mkCaseAltMsg :: CoreExpr -> ErrMsg
 634 mkCaseAltMsg e
 635   = hang (text "Type of case alternatives not the same:")
 636          4 (ppr e)
 637
 638 mkScrutMsg :: Id -> Type -> ErrMsg
 639 mkScrutMsg var scrut_ty
 640   = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
 641           text "Result binder type:" <+> ppr (idType var),
 642           text "Scrutinee type:" <+> ppr scrut_ty]
 643
 644 badAltsMsg :: CoreExpr -> ErrMsg
 645 badAltsMsg e
 646   = hang (text "Case statement scrutinee is not a data type:")
 647          4 (ppr e)
 648
 649 nonExhaustiveAltsMsg :: CoreExpr -> ErrMsg
 650 nonExhaustiveAltsMsg e
 651   = hang (text "Case expression with non-exhaustive alternatives")
 652          4 (ppr e)
 653
 654 mkBadPatMsg :: Type -> Type -> ErrMsg
 655 mkBadPatMsg con_result_ty scrut_ty
 656   = vcat [
 657         text "In a case alternative, pattern result type doesn't match scrutinee type:",
 658         text "Pattern result type:" <+> ppr con_result_ty,
 659         text "Scrutinee type:" <+> ppr scrut_ty
 660     ]
 661
 662 ------------------------------------------------------
 663 --      Other error messages
 664
 665 mkAppMsg :: Type -> Type -> ErrMsg
 666 mkAppMsg fun arg
 667   = vcat [ptext SLIT("Argument value doesn't match argument type:"),
 668               hang (ptext SLIT("Fun type:")) 4 (ppr fun),
 669               hang (ptext SLIT("Arg type:")) 4 (ppr arg)]
 670
 671 mkKindErrMsg :: TyVar -> Type -> ErrMsg
 672 mkKindErrMsg tyvar arg_ty
 673   = vcat [ptext SLIT("Kinds don't match in type application:"),
 674           hang (ptext SLIT("Type variable:"))
 675                  4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
 676           hang (ptext SLIT("Arg type:"))
 677                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
 678
 679 mkTyAppMsg :: Type -> Type -> ErrMsg
 680 mkTyAppMsg ty arg_ty
 681   = vcat [text "Illegal type application:",
 682               hang (ptext SLIT("Exp type:"))
 683                  4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
 684               hang (ptext SLIT("Arg type:"))
 685                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
 686
 687 mkRhsMsg :: Id -> Type -> ErrMsg
 688 mkRhsMsg binder ty
 689   = vcat
 690     [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
 691             ppr binder],
 692      hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
 693      hsep [ptext SLIT("Rhs type:"), ppr ty]]
 694
 695 mkRhsPrimMsg :: Id -> CoreExpr -> ErrMsg
 696 mkRhsPrimMsg binder rhs
 697   = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
 698                      ppr binder],
 699               hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
 700              ]
 701
 702 mkUnboxedTupleMsg :: Id -> ErrMsg
 703 mkUnboxedTupleMsg binder
 704   = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
 705           hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
 706
 707 mkCoerceErr from_ty expr_ty
 708   = vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"),
 709           ptext SLIT("From-type:") <+> ppr from_ty,
 710           ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
 711     ]
 712
 713 mkStrangeTyMsg e
 714   = ptext SLIT("Type where expression expected:") <+> ppr e
 715 \end{code}