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         showPass, endPass
  11     ) where
  12
  13 #include "HsVersions.h"
  14
  15 import IO               ( hPutStr, hPutStrLn, stdout )
  16
  17 import CoreSyn
  18 import CoreFVs          ( idFreeVars )
  19 import CoreUtils        ( findDefault, exprOkForSpeculation, coreBindsSize, mkPiType )
  20
  21 import Bag
  22 import Literal          ( literalType )
  23 import DataCon          ( dataConRepType )
  24 import Var              ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId, mustHaveLocalBinding )
  25 import VarSet
  26 import Subst            ( substTyWith )
  27 import Name             ( getSrcLoc )
  28 import PprCore
  29 import ErrUtils         ( doIfSet, dumpIfSet_core, ghcExit, Message, showPass,
  30                           addErrLocHdrLine )
  31 import SrcLoc           ( SrcLoc, noSrcLoc )
  32 import Type             ( Type, tyVarsOfType, eqType,
  33                           splitFunTy_maybe, mkTyVarTy,
  34                           splitForAllTy_maybe, splitTyConApp_maybe, splitTyConApp,
  35                           isUnLiftedType, typeKind,
  36                           isUnboxedTupleType,
  37                           hasMoreBoxityInfo
  38                         )
  39 import TyCon            ( isPrimTyCon )
  40 import BasicTypes       ( RecFlag(..), isNonRec )
  41 import CmdLineOpts
  42 import Maybe
  43 import Util             ( notNull )
  44 import Outputable
  45
  46 infixr 9 `thenL`, `seqL`
  47 \end{code}
  48
  49 %************************************************************************
  50 %*                                                                      *
  51 \subsection{End pass}
  52 %*                                                                      *
  53 %************************************************************************
  54
  55 @showPass@ and @endPass@ don't really belong here, but it makes a convenient
  56 place for them.  They print out stuff before and after core passes,
  57 and do Core Lint when necessary.
  58
  59 \begin{code}
  60 endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
  61 endPass dflags pass_name dump_flag binds
  62   = do
  63         -- Report result size if required
  64         -- This has the side effect of forcing the intermediate to be evaluated
  65         if verbosity dflags >= 2 then
  66            hPutStrLn stdout ("    Result size = " ++ show (coreBindsSize binds))
  67          else
  68            return ()
  69
  70         -- Report verbosely, if required
  71         dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds)
  72
  73         -- Type check
  74         lintCoreBindings dflags 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 :: DynFlags -> String -> [CoreBind] -> IO ()
 112
 113 lintCoreBindings dflags whoDunnit binds
 114   | not (dopt Opt_DoCoreLinting dflags)
 115   = return ()
 116
 117 lintCoreBindings dflags whoDunnit binds
 118   = case (initL (lint_binds binds)) of
 119       Nothing       -> done_lint
 120       Just bad_news -> printDump (display bad_news)     >>
 121                        ghcExit 1
 122   where
 123         -- Put all the top-level binders in scope at the start
 124         -- This is because transformation rules can bring something
 125         -- into use 'unexpectedly'
 126     lint_binds binds = addInScopeVars (bindersOfBinds binds) $
 127                        mapL lint_bind binds
 128
 129     lint_bind (Rec prs)         = mapL (lintSingleBinding Recursive) prs        `seqL`
 130                                   returnL ()
 131     lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
 132
 133     done_lint = doIfSet (verbosity dflags >= 2)
 134                         (hPutStr stdout ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
 135
 136     display bad_news
 137       = vcat [  text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
 138                 bad_news,
 139                 ptext SLIT("*** Offending Program ***"),
 140                 pprCoreBindings binds,
 141                 ptext SLIT("*** End of Offense ***")
 142         ]
 143 \end{code}
 144
 145 %************************************************************************
 146 %*                                                                      *
 147 \subsection[lintUnfolding]{lintUnfolding}
 148 %*                                                                      *
 149 %************************************************************************
 150
 151 We use this to check all unfoldings that come in from interfaces
 152 (it is very painful to catch errors otherwise):
 153
 154 \begin{code}
 155 lintUnfolding :: SrcLoc
 156               -> [Var]          -- Treat these as in scope
 157               -> CoreExpr
 158               -> Maybe Message  -- Nothing => OK
 159
 160 lintUnfolding locn vars expr
 161   = initL (addLoc (ImportedUnfolding locn) $
 162            addInScopeVars vars             $
 163            lintCoreExpr expr)
 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 lintSingleBinding rec_flag (binder,rhs)
 176   = addLoc (RhsOf binder) $
 177
 178         -- Check the rhs
 179     lintCoreExpr rhs                            `thenL` \ ty ->
 180
 181         -- Check match to RHS type
 182     lintBinder binder                           `seqL`
 183     checkTys binder_ty ty (mkRhsMsg binder ty)  `seqL`
 184
 185         -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
 186     checkL (not (isUnLiftedType binder_ty)
 187             || (isNonRec rec_flag && exprOkForSpeculation rhs))
 188            (mkRhsPrimMsg binder rhs)            `seqL`
 189
 190         -- Check whether binder's specialisations contain any out-of-scope variables
 191     mapL (checkBndrIdInScope binder) bndr_vars  `seqL`
 192     returnL ()
 193
 194         -- We should check the unfolding, if any, but this is tricky because
 195         -- the unfolding is a SimplifiableCoreExpr. Give up for now.
 196   where
 197     binder_ty = idType binder
 198     bndr_vars = varSetElems (idFreeVars binder)
 199 \end{code}
 200
 201 %************************************************************************
 202 %*                                                                      *
 203 \subsection[lintCoreExpr]{lintCoreExpr}
 204 %*                                                                      *
 205 %************************************************************************
 206
 207 \begin{code}
 208 lintCoreExpr :: CoreExpr -> LintM Type
 209
 210 lintCoreExpr (Var var) = checkIdInScope var `seqL` returnL (idType var)
 211 lintCoreExpr (Lit lit) = returnL (literalType lit)
 212
 213 lintCoreExpr (Note (Coerce to_ty from_ty) expr)
 214   = lintCoreExpr expr   `thenL` \ expr_ty ->
 215     lintTy to_ty        `seqL`
 216     lintTy from_ty      `seqL`
 217     checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty)      `seqL`
 218     returnL to_ty
 219
 220 lintCoreExpr (Note other_note expr)
 221   = lintCoreExpr expr
 222
 223 lintCoreExpr (Let (NonRec bndr rhs) body)
 224   = lintSingleBinding NonRecursive (bndr,rhs)   `seqL`
 225     addLoc (BodyOfLetRec [bndr])
 226            (addInScopeVars [bndr] (lintCoreExpr body))
 227
 228 lintCoreExpr (Let (Rec pairs) body)
 229   = addInScopeVars bndrs        $
 230     mapL (lintSingleBinding Recursive) pairs    `seqL`
 231     addLoc (BodyOfLetRec bndrs) (lintCoreExpr body)
 232   where
 233     bndrs = map fst pairs
 234
 235 lintCoreExpr e@(App fun arg)
 236   = lintCoreExpr fun    `thenL` \ ty ->
 237     addLoc (AnExpr e)   $
 238     lintCoreArg ty arg
 239
 240 lintCoreExpr (Lam var expr)
 241   = addLoc (LambdaBodyOf var)   $
 242     (if isId var then
 243        checkL (not (isUnboxedTupleType (idType var))) (mkUnboxedTupleMsg var)
 244      else
 245        returnL ())
 246                                 `seqL`
 247     (addInScopeVars [var]       $
 248      lintCoreExpr expr          `thenL` \ ty ->
 249
 250      returnL (mkPiType var ty))
 251
 252 lintCoreExpr e@(Case scrut var alts)
 253  =      -- Check the scrutinee
 254    lintCoreExpr scrut                   `thenL` \ scrut_ty ->
 255
 256         -- Check the binder
 257    lintBinder var                                               `seqL`
 258
 259         -- If this is an unboxed tuple case, then the binder must be dead
 260    {-
 261    checkL (if isUnboxedTupleType (idType var)
 262                 then isDeadBinder var
 263                 else True) (mkUnboxedTupleMsg var)              `seqL`
 264    -}
 265
 266    checkTys (idType var) scrut_ty (mkScrutMsg var scrut_ty)     `seqL`
 267
 268    addInScopeVars [var]                         (
 269
 270         -- Check the alternatives
 271    checkCaseAlts e scrut_ty alts                `seqL`
 272
 273    mapL (lintCoreAlt scrut_ty) alts             `thenL` \ (alt_ty : alt_tys) ->
 274    mapL (check alt_ty) alt_tys                  `seqL`
 275    returnL alt_ty)
 276  where
 277    check alt_ty1 alt_ty2 = checkTys alt_ty1 alt_ty2 (mkCaseAltMsg e)
 278
 279 lintCoreExpr e@(Type ty)
 280   = addErrL (mkStrangeTyMsg e)
 281 \end{code}
 282
 283 %************************************************************************
 284 %*                                                                      *
 285 \subsection[lintCoreArgs]{lintCoreArgs}
 286 %*                                                                      *
 287 %************************************************************************
 288
 289 The basic version of these functions checks that the argument is a
 290 subtype of the required type, as one would expect.
 291
 292 \begin{code}
 293 lintCoreArgs :: Type -> [CoreArg] -> LintM Type
 294 lintCoreArgs = lintCoreArgs0 checkTys
 295
 296 lintCoreArg :: Type -> CoreArg -> LintM Type
 297 lintCoreArg = lintCoreArg0 checkTys
 298 \end{code}
 299
 300 The primitive version of these functions takes a check argument,
 301 allowing a different comparison.
 302
 303 \begin{code}
 304 lintCoreArgs0 check_tys ty [] = returnL ty
 305 lintCoreArgs0 check_tys ty (a : args)
 306   = lintCoreArg0  check_tys ty a        `thenL` \ res ->
 307     lintCoreArgs0 check_tys res args
 308
 309 lintCoreArg0 check_tys ty a@(Type arg_ty)
 310   = lintTy arg_ty                       `seqL`
 311     lintTyApp ty arg_ty
 312
 313 lintCoreArg0 check_tys fun_ty arg
 314   = -- Make sure function type matches argument
 315     lintCoreExpr arg            `thenL` \ arg_ty ->
 316     let
 317       err = mkAppMsg fun_ty arg_ty
 318     in
 319     case splitFunTy_maybe fun_ty of
 320       Just (arg,res) -> check_tys arg arg_ty err `seqL`
 321                         returnL res
 322       _              -> addErrL err
 323 \end{code}
 324
 325 \begin{code}
 326 lintTyApp ty arg_ty
 327   = case splitForAllTy_maybe ty of
 328       Nothing -> addErrL (mkTyAppMsg ty arg_ty)
 329
 330       Just (tyvar,body) ->
 331         if not (isTyVar tyvar) then addErrL (mkTyAppMsg ty arg_ty) else
 332         let
 333             tyvar_kind = tyVarKind tyvar
 334             argty_kind = typeKind arg_ty
 335         in
 336         if argty_kind `hasMoreBoxityInfo` tyvar_kind
 337                 -- Arg type might be boxed for a function with an uncommitted
 338                 -- tyvar; notably this is used so that we can give
 339                 --      error :: forall a:*. String -> a
 340                 -- and then apply it to both boxed and unboxed types.
 341          then
 342             returnL (substTyWith [tyvar] [arg_ty] body)
 343         else
 344             addErrL (mkKindErrMsg tyvar arg_ty)
 345
 346 lintTyApps fun_ty []
 347   = returnL fun_ty
 348
 349 lintTyApps fun_ty (arg_ty : arg_tys)
 350   = lintTyApp fun_ty arg_ty             `thenL` \ fun_ty' ->
 351     lintTyApps fun_ty' arg_tys
 352 \end{code}
 353
 354
 355
 356 %************************************************************************
 357 %*                                                                      *
 358 \subsection[lintCoreAlts]{lintCoreAlts}
 359 %*                                                                      *
 360 %************************************************************************
 361
 362 \begin{code}
 363 checkCaseAlts :: CoreExpr -> Type -> [CoreAlt] -> LintM ()
 364 -- a) Check that the alts are non-empty
 365 -- b) Check that the DEFAULT comes first, if it exists
 366 -- c) Check that there's a default for infinite types
 367 -- NB: Algebraic cases are not necessarily exhaustive, because
 368 --     the simplifer correctly eliminates case that can't
 369 --     possibly match.
 370
 371 checkCaseAlts e ty []
 372   = addErrL (mkNullAltsMsg e)
 373
 374 checkCaseAlts e ty alts
 375   = checkL (all non_deflt con_alts) (mkNonDefltMsg e)   `seqL`
 376     checkL (isJust maybe_deflt || not is_infinite_ty)
 377            (nonExhaustiveAltsMsg e)
 378   where
 379     (con_alts, maybe_deflt) = findDefault alts
 380
 381     non_deflt (DEFAULT, _, _) = False
 382     non_deflt alt             = True
 383
 384     is_infinite_ty = case splitTyConApp_maybe ty of
 385                         Nothing                     -> False
 386                         Just (tycon, tycon_arg_tys) -> isPrimTyCon tycon
 387 \end{code}
 388
 389 \begin{code}
 390 lintCoreAlt :: Type                     -- Type of scrutinee
 391             -> CoreAlt
 392             -> LintM Type               -- Type of alternatives
 393
 394 lintCoreAlt scrut_ty alt@(DEFAULT, args, rhs)
 395   = checkL (null args) (mkDefaultArgsMsg args)  `seqL`
 396     lintCoreExpr rhs
 397
 398 lintCoreAlt scrut_ty alt@(LitAlt lit, args, rhs)
 399   = checkL (null args) (mkDefaultArgsMsg args)  `seqL`
 400     checkTys lit_ty scrut_ty
 401              (mkBadPatMsg lit_ty scrut_ty)      `seqL`
 402     lintCoreExpr rhs
 403   where
 404     lit_ty = literalType lit
 405
 406 lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs)
 407   = addLoc (CaseAlt alt) (
 408
 409     mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg)))
 410                         (mkUnboxedTupleMsg arg)) args `seqL`
 411
 412     addInScopeVars args (
 413
 414         -- Check the pattern
 415         -- Scrutinee type must be a tycon applicn; checked by caller
 416         -- This code is remarkably compact considering what it does!
 417         -- NB: args must be in scope here so that the lintCoreArgs line works.
 418         -- NB: relies on existential type args coming *after* ordinary type args
 419     case splitTyConApp scrut_ty of { (tycon, tycon_arg_tys) ->
 420         lintTyApps (dataConRepType con) tycon_arg_tys   `thenL` \ con_type ->
 421         lintCoreArgs con_type (map mk_arg args)         `thenL` \ con_result_ty ->
 422         checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
 423     }                                           `seqL`
 424
 425         -- Check the RHS
 426     lintCoreExpr rhs
 427     ))
 428   where
 429     mk_arg b | isTyVar b = Type (mkTyVarTy b)
 430              | isId    b = Var b
 431              | otherwise = pprPanic "lintCoreAlt:mk_arg " (ppr b)
 432 \end{code}
 433
 434 %************************************************************************
 435 %*                                                                      *
 436 \subsection[lint-types]{Types}
 437 %*                                                                      *
 438 %************************************************************************
 439
 440 \begin{code}
 441 lintBinder :: Var -> LintM ()
 442 lintBinder v = nopL
 443 -- ToDo: lint its type
 444 -- ToDo: lint its rules
 445
 446 lintTy :: Type -> LintM ()
 447 lintTy ty = mapL checkIdInScope (varSetElems (tyVarsOfType ty)) `seqL`
 448             returnL ()
 449         -- ToDo: check the kind structure of the type
 450 \end{code}
 451
 452
 453 %************************************************************************
 454 %*                                                                      *
 455 \subsection[lint-monad]{The Lint monad}
 456 %*                                                                      *
 457 %************************************************************************
 458
 459 \begin{code}
 460 type LintM a = [LintLocInfo]    -- Locations
 461             -> IdSet            -- Local vars in scope
 462             -> Bag Message      -- Error messages so far
 463             -> (Maybe a, Bag Message)  -- Result and error messages (if any)
 464
 465 data LintLocInfo
 466   = RhsOf Id            -- The variable bound
 467   | LambdaBodyOf Id     -- The lambda-binder
 468   | BodyOfLetRec [Id]   -- One of the binders
 469   | CaseAlt CoreAlt     -- Pattern of a case alternative
 470   | AnExpr CoreExpr     -- Some expression
 471   | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
 472 \end{code}
 473
 474 \begin{code}
 475 initL :: LintM a -> Maybe Message {- errors -}
 476 initL m
 477   = case m [] emptyVarSet emptyBag of
 478       (_, errs) | isEmptyBag errs -> Nothing
 479                 | otherwise       -> Just (vcat (punctuate (text "") (bagToList errs)))
 480
 481 returnL :: a -> LintM a
 482 returnL r loc scope errs = (Just r, errs)
 483
 484 nopL :: LintM a
 485 nopL loc scope errs = (Nothing, errs)
 486
 487 thenL :: LintM a -> (a -> LintM b) -> LintM b
 488 thenL m k loc scope errs
 489   = case m loc scope errs of
 490       (Just r, errs')  -> k r loc scope errs'
 491       (Nothing, errs') -> (Nothing, errs')
 492
 493 seqL :: LintM a -> LintM b -> LintM b
 494 seqL m k loc scope errs
 495   = case m loc scope errs of
 496       (_, errs') -> k loc scope errs'
 497
 498 mapL :: (a -> LintM b) -> [a] -> LintM [b]
 499 mapL f [] = returnL []
 500 mapL f (x:xs)
 501   = f x         `thenL` \ r ->
 502     mapL f xs   `thenL` \ rs ->
 503     returnL (r:rs)
 504 \end{code}
 505
 506 \begin{code}
 507 checkL :: Bool -> Message -> LintM ()
 508 checkL True  msg = nopL
 509 checkL False msg = addErrL msg
 510
 511 addErrL :: Message -> LintM a
 512 addErrL msg loc scope errs = (Nothing, addErr errs msg loc)
 513
 514 addErr :: Bag Message -> Message -> [LintLocInfo] -> Bag Message
 515 addErr errs_so_far msg locs
 516   = ASSERT( notNull locs )
 517     errs_so_far `snocBag` mk_msg msg
 518   where
 519    (loc, cxt1) = dumpLoc (head locs)
 520    cxts        = [snd (dumpLoc loc) | loc <- locs]
 521    context     | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1
 522                | otherwise          = cxt1
 523
 524    mk_msg msg = addErrLocHdrLine loc context msg
 525
 526 addLoc :: LintLocInfo -> LintM a -> LintM a
 527 addLoc extra_loc m loc scope errs
 528   = m (extra_loc:loc) scope errs
 529
 530 addInScopeVars :: [Var] -> LintM a -> LintM a
 531 addInScopeVars ids m loc scope errs
 532   = m loc (scope `unionVarSet` mkVarSet ids) errs
 533 \end{code}
 534
 535 \begin{code}
 536 checkIdInScope :: Var -> LintM ()
 537 checkIdInScope id
 538   = checkInScope (ptext SLIT("is out of scope")) id
 539
 540 checkBndrIdInScope :: Var -> Var -> LintM ()
 541 checkBndrIdInScope binder id
 542   = checkInScope msg id
 543     where
 544      msg = ptext SLIT("is out of scope inside info for") <+>
 545            ppr binder
 546
 547 checkInScope :: SDoc -> Var -> LintM ()
 548 checkInScope loc_msg var loc scope errs
 549   |  mustHaveLocalBinding var && not (var `elemVarSet` scope)
 550   = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc)
 551   | otherwise
 552   = nopL loc scope errs
 553
 554 checkTys :: Type -> Type -> Message -> LintM ()
 555 -- check ty2 is subtype of ty1 (ie, has same structure but usage
 556 -- annotations need only be consistent, not equal)
 557 checkTys ty1 ty2 msg
 558   | ty1 `eqType` ty2 = nopL
 559   | otherwise        = addErrL msg
 560 \end{code}
 561
 562
 563 %************************************************************************
 564 %*                                                                      *
 565 \subsection{Error messages}
 566 %*                                                                      *
 567 %************************************************************************
 568
 569 \begin{code}
 570 dumpLoc (RhsOf v)
 571   = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))
 572
 573 dumpLoc (LambdaBodyOf b)
 574   = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
 575
 576 dumpLoc (BodyOfLetRec [])
 577   = (noSrcLoc, brackets (ptext SLIT("In body of a letrec with no binders")))
 578
 579 dumpLoc (BodyOfLetRec bs@(_:_))
 580   = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
 581
 582 dumpLoc (AnExpr e)
 583   = (noSrcLoc, text "In the expression:" <+> ppr e)
 584
 585 dumpLoc (CaseAlt (con, args, rhs))
 586   = (noSrcLoc, text "In a case pattern:" <+> parens (ppr con <+> ppr args))
 587
 588 dumpLoc (ImportedUnfolding locn)
 589   = (locn, brackets (ptext SLIT("in an imported unfolding")))
 590
 591 pp_binders :: [Var] -> SDoc
 592 pp_binders bs = sep (punctuate comma (map pp_binder bs))
 593
 594 pp_binder :: Var -> SDoc
 595 pp_binder b | isId b    = hsep [ppr b, dcolon, ppr (idType b)]
 596             | isTyVar b = hsep [ppr b, dcolon, ppr (tyVarKind b)]
 597 \end{code}
 598
 599 \begin{code}
 600 ------------------------------------------------------
 601 --      Messages for case expressions
 602
 603 mkNullAltsMsg :: CoreExpr -> Message
 604 mkNullAltsMsg e
 605   = hang (text "Case expression with no alternatives:")
 606          4 (ppr e)
 607
 608 mkDefaultArgsMsg :: [Var] -> Message
 609 mkDefaultArgsMsg args
 610   = hang (text "DEFAULT case with binders")
 611          4 (ppr args)
 612
 613 mkCaseAltMsg :: CoreExpr -> Message
 614 mkCaseAltMsg e
 615   = hang (text "Type of case alternatives not the same:")
 616          4 (ppr e)
 617
 618 mkScrutMsg :: Id -> Type -> Message
 619 mkScrutMsg var scrut_ty
 620   = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
 621           text "Result binder type:" <+> ppr (idType var),
 622           text "Scrutinee type:" <+> ppr scrut_ty]
 623
 624
 625 mkNonDefltMsg e
 626   = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
 627
 628 nonExhaustiveAltsMsg :: CoreExpr -> Message
 629 nonExhaustiveAltsMsg e
 630   = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
 631
 632 mkBadPatMsg :: Type -> Type -> Message
 633 mkBadPatMsg con_result_ty scrut_ty
 634   = vcat [
 635         text "In a case alternative, pattern result type doesn't match scrutinee type:",
 636         text "Pattern result type:" <+> ppr con_result_ty,
 637         text "Scrutinee type:" <+> ppr scrut_ty
 638     ]
 639
 640 ------------------------------------------------------
 641 --      Other error messages
 642
 643 mkAppMsg :: Type -> Type -> Message
 644 mkAppMsg fun arg
 645   = vcat [ptext SLIT("Argument value doesn't match argument type:"),
 646               hang (ptext SLIT("Fun type:")) 4 (ppr fun),
 647               hang (ptext SLIT("Arg type:")) 4 (ppr arg)]
 648
 649 mkKindErrMsg :: TyVar -> Type -> Message
 650 mkKindErrMsg tyvar arg_ty
 651   = vcat [ptext SLIT("Kinds don't match in type application:"),
 652           hang (ptext SLIT("Type variable:"))
 653                  4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
 654           hang (ptext SLIT("Arg type:"))
 655                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
 656
 657 mkTyAppMsg :: Type -> Type -> Message
 658 mkTyAppMsg ty arg_ty
 659   = vcat [text "Illegal type application:",
 660               hang (ptext SLIT("Exp type:"))
 661                  4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
 662               hang (ptext SLIT("Arg type:"))
 663                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
 664
 665 mkRhsMsg :: Id -> Type -> Message
 666 mkRhsMsg binder ty
 667   = vcat
 668     [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
 669             ppr binder],
 670      hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
 671      hsep [ptext SLIT("Rhs type:"), ppr ty]]
 672
 673 mkRhsPrimMsg :: Id -> CoreExpr -> Message
 674 mkRhsPrimMsg binder rhs
 675   = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
 676                      ppr binder],
 677               hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
 678              ]
 679
 680 mkUnboxedTupleMsg :: Id -> Message
 681 mkUnboxedTupleMsg binder
 682   = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
 683           hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
 684
 685 mkCoerceErr from_ty expr_ty
 686   = vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"),
 687           ptext SLIT("From-type:") <+> ppr from_ty,
 688           ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
 689     ]
 690
 691 mkStrangeTyMsg e
 692   = ptext SLIT("Type where expression expected:") <+> ppr e
 693 \end{code}