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