ghc/compiler/coreSyn/CoreLint.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
   3 %
   4 \section[CoreLint]{A ``lint'' pass to check for Core correctness}
   5
   6 \begin{code}
   7 module CoreLint (
   8         lintCoreBindings,
   9         lintUnfolding
  10     ) where
  11
  12 #include "HsVersions.h"
  13
  14 import IO       ( hPutStr, stderr )
  15
  16 import CmdLineOpts      ( opt_D_show_passes, opt_DoCoreLinting )
  17 import CoreSyn
  18
  19 import Bag
  20 import Kind             ( hasMoreBoxityInfo, Kind{-instance-} )
  21 import Literal          ( literalType, Literal{-instance-} )
  22 import Id               ( idType, isBottomingId, dataConRepType, isDataCon, isNewCon, isAlgCon,
  23                           dataConArgTys, GenId{-instances-},
  24                           emptyIdSet, mkIdSet,
  25                           unionIdSets, elementOfIdSet, IdSet,
  26                           Id
  27                         )
  28 import Maybes           ( catMaybes )
  29 import Name             ( isLocallyDefined, getSrcLoc, Name{-instance NamedThing-},
  30                           NamedThing(..) )
  31 import PprCore
  32 import ErrUtils         ( doIfSet, ghcExit )
  33 import PrimOp           ( primOpType )
  34 import PrimRep          ( PrimRep(..) )
  35 import SrcLoc           ( SrcLoc )
  36 import Type             ( mkFunTy, splitFunTy_maybe, mkForAllTy,
  37                           splitForAllTy_maybe,
  38                           isUnpointedType, typeKind, instantiateTy,
  39                           splitAlgTyConApp_maybe, Type
  40                         )
  41 import TyCon            ( TyCon, isPrimTyCon, isDataTyCon )
  42 import TyVar            ( TyVar, tyVarKind, mkTyVarEnv )
  43 import ErrUtils         ( ErrMsg )
  44 import Unique           ( Unique )
  45 import Util             ( zipEqual )
  46 import Outputable
  47
  48 infixr 9 `thenL`, `seqL`, `thenMaybeL`
  49 \end{code}
  50
  51 %************************************************************************
  52 %*                                                                      *
  53 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
  54 %*                                                                      *
  55 %************************************************************************
  56
  57 Checks that a set of core bindings is well-formed.  The PprStyle and String
  58 just control what we print in the event of an error.  The Bool value
  59 indicates whether we have done any specialisation yet (in which case we do
  60 some extra checks).
  61
  62 We check for
  63         (a) type errors
  64         (b) Out-of-scope type variables
  65         (c) Out-of-scope local variables
  66         (d) Ill-kinded types
  67
  68 If we have done specialisation the we check that there are
  69         (a) No top-level bindings of primitive (unboxed type)
  70
  71 Outstanding issues:
  72
  73     --
  74     -- Things are *not* OK if:
  75     --
  76     -- * Unsaturated type app before specialisation has been done;
  77     --
  78     -- * Oversaturated type app after specialisation (eta reduction
  79     --   may well be happening...);
  80     --
  81     -- Note: checkTyApp is usually followed by a call to checkSpecTyApp.
  82     --
  83
  84 \begin{code}
  85 lintCoreBindings :: String -> Bool -> [CoreBinding] -> IO ()
  86
  87 lintCoreBindings whoDunnit spec_done binds
  88   | not opt_DoCoreLinting
  89   = return ()
  90
  91 lintCoreBindings whoDunnit spec_done binds
  92   = case (initL (lint_binds binds) spec_done) of
  93       Nothing       -> doIfSet opt_D_show_passes
  94                         (hPutStr stderr ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
  95
  96       Just bad_news -> printDump (display bad_news)     >>
  97                        ghcExit 1
  98   where
  99     lint_binds [] = returnL ()
 100     lint_binds (bind:binds)
 101       = lintCoreBinding bind `thenL` \binders ->
 102         addInScopeVars binders (lint_binds binds)
 103
 104     display bad_news
 105       = vcat [
 106                 text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
 107                 bad_news,
 108                 ptext SLIT("*** Offending Program ***"),
 109                 pprCoreBindings binds,
 110                 ptext SLIT("*** End of Offense ***")
 111         ]
 112 \end{code}
 113
 114 %************************************************************************
 115 %*                                                                      *
 116 \subsection[lintUnfolding]{lintUnfolding}
 117 %*                                                                      *
 118 %************************************************************************
 119
 120 We use this to check all unfoldings that come in from interfaces
 121 (it is very painful to catch errors otherwise):
 122
 123 \begin{code}
 124 lintUnfolding :: SrcLoc -> CoreExpr -> Maybe CoreExpr
 125
 126 lintUnfolding locn expr
 127   = case
 128       (initL (addLoc (ImportedUnfolding locn) (lintCoreExpr expr))
 129        True{-pretend spec done-})
 130     of
 131       Nothing  -> Just expr
 132       Just msg ->
 133         pprTrace "WARNING: Discarded bad unfolding from interface:\n"
 134         (vcat [msg,
 135                    ptext SLIT("*** Bad unfolding ***"),
 136                    ppr expr,
 137                    ptext SLIT("*** End unfolding ***")])
 138         Nothing
 139 \end{code}
 140
 141 %************************************************************************
 142 %*                                                                      *
 143 \subsection[lintCoreBinding]{lintCoreBinding}
 144 %*                                                                      *
 145 %************************************************************************
 146
 147 Check a core binding, returning the list of variables bound.
 148
 149 \begin{code}
 150 lintCoreBinding :: CoreBinding -> LintM [Id]
 151
 152 lintCoreBinding (NonRec binder rhs)
 153   = lintSingleBinding (binder,rhs) `seqL` returnL [binder]
 154
 155 lintCoreBinding (Rec pairs)
 156   = addInScopeVars binders (
 157       mapL lintSingleBinding pairs `seqL` returnL binders
 158     )
 159   where
 160     binders = [b | (b,_) <- pairs]
 161
 162 lintSingleBinding (binder,rhs)
 163   = addLoc (RhsOf binder) (
 164         -- Check the rhs
 165         lintCoreExpr rhs
 166
 167         `thenL` \maybe_ty ->
 168         -- Check match to RHS type
 169         (case maybe_ty of
 170           Nothing -> returnL ()
 171           Just ty -> checkTys (idType binder) ty (mkRhsMsg binder ty))
 172
 173         `seqL`
 174         -- Check (not isUnpointedType)
 175         checkIfSpecDoneL (not (isUnpointedType (idType binder)))
 176           (mkRhsPrimMsg binder rhs)
 177
 178         -- We should check the unfolding, if any, but this is tricky because
 179         -- the unfolding is a SimplifiableCoreExpr. Give up for now.
 180     )
 181 \end{code}
 182
 183 %************************************************************************
 184 %*                                                                      *
 185 \subsection[lintCoreExpr]{lintCoreExpr}
 186 %*                                                                      *
 187 %************************************************************************
 188
 189 \begin{code}
 190 lintCoreExpr :: CoreExpr -> LintM (Maybe Type)  -- Nothing if error found
 191
 192 lintCoreExpr (Var var)
 193   | isAlgCon var = returnL (Just (idType var))
 194         -- Micro-hack here... Class decls generate applications of their
 195         -- dictionary constructor, but don't generate a binding for the
 196         -- constructor (since it would never be used).  After a single round
 197         -- of simplification, these dictionary constructors have been
 198         -- inlined (from their UnfoldInfo) to CoCons.  Just between
 199         -- desugaring and simplfication, though, they appear as naked, unbound
 200         -- variables as the function in an application.
 201         -- The hack here simply doesn't check for out-of-scope-ness for
 202         -- data constructors (at least, in a function position).
 203
 204   | otherwise    = checkInScope var `seqL` returnL (Just (idType var))
 205
 206 lintCoreExpr (Lit lit) = returnL (Just (literalType lit))
 207
 208 lintCoreExpr (Note (Coerce to_ty from_ty) expr)
 209   = lintCoreExpr expr   `thenMaybeL` \ expr_ty ->
 210     lintTy to_ty        `seqL`
 211     lintTy from_ty      `seqL`
 212     checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty)      `seqL`
 213     returnL (Just to_ty)
 214
 215 lintCoreExpr (Note other_note expr)
 216   = lintCoreExpr expr
 217
 218 lintCoreExpr (Let binds body)
 219   = lintCoreBinding binds `thenL` \binders ->
 220     if (null binders) then
 221         lintCoreExpr body  -- Can't add a new source location
 222     else
 223       addLoc (BodyOfLetRec binders)
 224         (addInScopeVars binders (lintCoreExpr body))
 225
 226 lintCoreExpr e@(Con con args)
 227   = checkL (isDataCon con) (mkConErrMsg e)      `seqL`
 228     lintCoreArgs {-False-} e (dataConRepType con) args
 229     -- Note: we don't check for primitive types in these arguments
 230
 231 lintCoreExpr e@(Prim op args)
 232   = lintCoreArgs {-True-} e (primOpType op) args
 233     -- Note: we do check for primitive types in these arguments
 234
 235 lintCoreExpr e@(App fun@(Var v) arg) | isBottomingId v
 236   = lintCoreExpr fun `thenMaybeL` \ ty -> lintCoreArg {-False-} e ty arg
 237     -- Note: we don't check for primitive types in argument to 'error'
 238
 239 lintCoreExpr e@(App fun arg)
 240   = lintCoreExpr fun `thenMaybeL` \ty -> lintCoreArg {-True-} e ty arg
 241     -- Note: we do check for primitive types in this argument
 242
 243 lintCoreExpr (Lam (ValBinder var) expr)
 244   = addLoc (LambdaBodyOf var)
 245       (addInScopeVars [var]
 246         (lintCoreExpr expr `thenMaybeL` \ty ->
 247          returnL (Just (mkFunTy (idType var) ty))))
 248
 249 lintCoreExpr (Lam (TyBinder tyvar) expr)
 250   = lintCoreExpr expr `thenMaybeL` \ty ->
 251     returnL (Just(mkForAllTy tyvar ty))
 252     -- ToDo: Should add in-scope type variable at this point
 253
 254 lintCoreExpr e@(Case scrut alts)
 255  = lintCoreExpr scrut `thenMaybeL` \ty ->
 256    lintCoreAlts alts ty
 257 \end{code}
 258
 259 %************************************************************************
 260 %*                                                                      *
 261 \subsection[lintCoreArgs]{lintCoreArgs}
 262 %*                                                                      *
 263 %************************************************************************
 264
 265 The boolean argument indicates whether we should flag type
 266 applications to primitive types as being errors.
 267
 268 \begin{code}
 269 lintCoreArgs :: {-Bool ->-} CoreExpr -> Type -> [CoreArg] -> LintM (Maybe Type)
 270
 271 lintCoreArgs _ ty [] = returnL (Just ty)
 272 lintCoreArgs e ty (a : args)
 273   = lintCoreArg  e ty  a `thenMaybeL` \ res ->
 274     lintCoreArgs e res args
 275 \end{code}
 276
 277 %************************************************************************
 278 %*                                                                      *
 279 \subsection[lintCoreArg]{lintCoreArg}
 280 %*                                                                      *
 281 %************************************************************************
 282
 283 \begin{code}
 284 lintCoreArg :: {-Bool ->-} CoreExpr -> Type -> CoreArg -> LintM (Maybe Type)
 285
 286 lintCoreArg e ty (LitArg lit)
 287   = -- Make sure function type matches argument
 288     case (splitFunTy_maybe ty) of
 289       Just (arg,res) | (lit_ty == arg) -> returnL(Just res)
 290       _ -> addErrL (mkAppMsg ty lit_ty e) `seqL` returnL Nothing
 291   where
 292     lit_ty = literalType lit
 293
 294 lintCoreArg e ty (VarArg v)
 295   = -- Make sure variable is bound
 296     checkInScope v `seqL`
 297     -- Make sure function type matches argument
 298     case (splitFunTy_maybe ty) of
 299       Just (arg,res) | (var_ty == arg) -> returnL(Just res)
 300       _ -> addErrL (mkAppMsg ty var_ty e) `seqL` returnL Nothing
 301   where
 302     var_ty = idType v
 303
 304 lintCoreArg e ty a@(TyArg arg_ty)
 305   = lintTy arg_ty                       `seqL`
 306
 307     case (splitForAllTy_maybe ty) of
 308       Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing
 309
 310       Just (tyvar,body) ->
 311         let
 312             tyvar_kind = tyVarKind tyvar
 313             argty_kind = typeKind arg_ty
 314         in
 315         if argty_kind `hasMoreBoxityInfo` tyvar_kind
 316                 -- Arg type might be boxed for a function with an uncommitted
 317                 -- tyvar; notably this is used so that we can give
 318                 --      error :: forall a:*. String -> a
 319                 -- and then apply it to both boxed and unboxed types.
 320          then
 321             returnL(Just(instantiateTy (mkTyVarEnv [(tyvar,arg_ty)]) body))
 322         else
 323             pprTrace "lintCoreArg:kinds:" (hsep [ppr tyvar_kind, ppr argty_kind]) $
 324             addErrL (mkKindErrMsg tyvar arg_ty e) `seqL` returnL Nothing
 325 \end{code}
 326
 327 %************************************************************************
 328 %*                                                                      *
 329 \subsection[lintCoreAlts]{lintCoreAlts}
 330 %*                                                                      *
 331 %************************************************************************
 332
 333 \begin{code}
 334 lintCoreAlts :: CoreCaseAlts
 335              -> Type                    -- Type of scrutinee
 336 --           -> TyCon                   -- TyCon pinned on the case
 337              -> LintM (Maybe Type)      -- Type of alternatives
 338
 339 lintCoreAlts whole_alts@(AlgAlts alts deflt) ty --tycon
 340   = -- Check tycon is not a primitive tycon
 341 --    addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon)
 342 --    `seqL`
 343     -- Check we are scrutinising a proper datatype
 344     -- (ToDo: robustify)
 345 --    addErrIfL (not (tyConFamilySize tycon >= 1)) (mkCaseAbstractMsg tycon)
 346 --    `seqL`
 347     lintDeflt deflt ty
 348     `thenL` \maybe_deflt_ty ->
 349     mapL (lintAlgAlt ty {-tycon-}) alts
 350     `thenL` \maybe_alt_tys ->
 351     -- Check the result types
 352     case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
 353       []             -> returnL Nothing
 354
 355       (first_ty:tys) -> mapL check tys  `seqL`
 356                         returnL (Just first_ty)
 357         where
 358           check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
 359
 360 lintCoreAlts whole_alts@(PrimAlts alts deflt) ty --tycon
 361   = -- Check tycon is a primitive tycon
 362 --    addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon)
 363 --    `seqL`
 364     mapL (lintPrimAlt ty) alts
 365     `thenL` \maybe_alt_tys ->
 366     lintDeflt deflt ty
 367     `thenL` \maybe_deflt_ty ->
 368     -- Check the result types
 369     case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
 370       []             -> returnL Nothing
 371
 372       (first_ty:tys) -> mapL check tys  `seqL`
 373                         returnL (Just first_ty)
 374         where
 375           check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
 376
 377 lintAlgAlt scrut_ty (con,args,rhs)
 378   = (case splitAlgTyConApp_maybe scrut_ty of
 379       Just (tycon, tys_applied, cons) | isDataTyCon tycon ->
 380          let
 381            arg_tys = dataConArgTys con tys_applied
 382          in
 383          checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `seqL`
 384          checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
 385                                                                  `seqL`
 386          mapL check (zipEqual "lintAlgAlt" arg_tys args)         `seqL`
 387          returnL ()
 388
 389       other -> addErrL (mkAlgAltMsg1 scrut_ty)
 390     )                                                            `seqL`
 391     addInScopeVars args         (
 392          lintCoreExpr rhs
 393     )
 394   where
 395     check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
 396
 397     -- elem: yes, the elem-list here can sometimes be long-ish,
 398     -- but as it's use-once, probably not worth doing anything different
 399     -- We give it its own copy, so it isn't overloaded.
 400     elem _ []       = False
 401     elem x (y:ys)   = x==y || elem x ys
 402
 403 lintPrimAlt ty alt@(lit,rhs)
 404  = checkTys (literalType lit) ty (mkPrimAltMsg alt) `seqL`
 405    lintCoreExpr rhs
 406
 407 lintDeflt NoDefault _ = returnL Nothing
 408 lintDeflt deflt@(BindDefault binder rhs) ty
 409   = checkTys (idType binder) ty (mkDefltMsg deflt) `seqL`
 410     addInScopeVars [binder] (lintCoreExpr rhs)
 411 \end{code}
 412
 413 %************************************************************************
 414 %*                                                                      *
 415 \subsection[lint-types]{Types}
 416 %*                                                                      *
 417 %************************************************************************
 418
 419 \begin{code}
 420 lintTy :: Type -> LintM ()
 421 lintTy ty = returnL ()
 422 -- ToDo: Check that ty is well-kinded and has no unbound tyvars
 423 \end{code}
 424
 425
 426 %************************************************************************
 427 %*                                                                      *
 428 \subsection[lint-monad]{The Lint monad}
 429 %*                                                                      *
 430 %************************************************************************
 431
 432 \begin{code}
 433 type LintM a = Bool             -- True <=> specialisation has been done
 434             -> [LintLocInfo]    -- Locations
 435             -> IdSet            -- Local vars in scope
 436             -> Bag ErrMsg       -- Error messages so far
 437             -> (a, Bag ErrMsg)  -- Result and error messages (if any)
 438
 439 data LintLocInfo
 440   = RhsOf Id            -- The variable bound
 441   | LambdaBodyOf Id     -- The lambda-binder
 442   | BodyOfLetRec [Id]   -- One of the binders
 443   | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
 444
 445 instance Outputable LintLocInfo where
 446     ppr (RhsOf v)
 447       = ppr (getSrcLoc v) <> colon <+>
 448         brackets (ptext SLIT("RHS of") <+> pp_binders [v])
 449
 450     ppr (LambdaBodyOf b)
 451       = ppr (getSrcLoc b) <> colon <+>
 452         brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b)
 453
 454     ppr (BodyOfLetRec bs)
 455       = ppr (getSrcLoc (head bs)) <> colon <+>
 456         brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs)
 457
 458     ppr (ImportedUnfolding locn)
 459       = ppr locn <> colon <+>
 460         brackets (ptext SLIT("in an imported unfolding"))
 461
 462 pp_binders :: [Id] -> SDoc
 463 pp_binders bs = sep (punctuate comma (map pp_binder bs))
 464
 465 pp_binder :: Id -> SDoc
 466 pp_binder b = hsep [ppr b, text "::", ppr (idType b)]
 467 \end{code}
 468
 469 \begin{code}
 470 initL :: LintM a -> Bool -> Maybe ErrMsg
 471 initL m spec_done
 472   = case (m spec_done [] emptyIdSet emptyBag) of { (_, errs) ->
 473     if isEmptyBag errs then
 474         Nothing
 475     else
 476         Just (vcat (bagToList errs))
 477     }
 478
 479 returnL :: a -> LintM a
 480 returnL r spec loc scope errs = (r, errs)
 481
 482 thenL :: LintM a -> (a -> LintM b) -> LintM b
 483 thenL m k spec loc scope errs
 484   = case m spec loc scope errs of
 485       (r, errs') -> k r spec loc scope errs'
 486
 487 seqL :: LintM a -> LintM b -> LintM b
 488 seqL m k spec loc scope errs
 489   = case m spec loc scope errs of
 490       (_, errs') -> k spec loc scope errs'
 491
 492 thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b)
 493 thenMaybeL m k spec loc scope errs
 494   = case m spec loc scope errs of
 495       (Nothing, errs2) -> (Nothing, errs2)
 496       (Just r,  errs2) -> k r spec loc scope errs2
 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
 505 mapMaybeL :: (a -> LintM (Maybe b)) -> [a] -> LintM (Maybe [b])
 506         -- Returns Nothing if anything fails
 507 mapMaybeL f [] = returnL (Just [])
 508 mapMaybeL f (x:xs)
 509   = f x             `thenMaybeL` \ r ->
 510     mapMaybeL f xs  `thenMaybeL` \ rs ->
 511     returnL (Just (r:rs))
 512 \end{code}
 513
 514 \begin{code}
 515 checkL :: Bool -> ErrMsg -> LintM ()
 516 checkL True  msg spec loc scope errs = ((), errs)
 517 checkL False msg spec loc scope errs = ((), addErr errs msg loc)
 518
 519 checkIfSpecDoneL :: Bool -> ErrMsg -> LintM ()
 520 checkIfSpecDoneL True  msg spec  loc scope errs = ((), errs)
 521 checkIfSpecDoneL False msg True  loc scope errs = ((), addErr errs msg loc)
 522 checkIfSpecDoneL False msg False loc scope errs = ((), errs)
 523
 524 addErrL :: ErrMsg -> LintM ()
 525 addErrL msg spec loc scope errs = ((), addErr errs msg loc)
 526
 527 addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg
 528
 529 addErr errs_so_far msg locs
 530   = ASSERT (not (null locs))
 531     errs_so_far `snocBag` (hang (ppr (head locs)) 4 msg)
 532
 533 addLoc :: LintLocInfo -> LintM a -> LintM a
 534 addLoc extra_loc m spec loc scope errs
 535   = m spec (extra_loc:loc) scope errs
 536
 537 addInScopeVars :: [Id] -> LintM a -> LintM a
 538 addInScopeVars ids m spec loc scope errs
 539   = -- We check if these "new" ids are already
 540     -- in scope, i.e., we have *shadowing* going on.
 541     -- For now, it's just a "trace"; we may make
 542     -- a real error out of it...
 543     let
 544         new_set = mkIdSet ids
 545
 546 --      shadowed = scope `intersectIdSets` new_set
 547     in
 548 --  After adding -fliberate-case, Simon decided he likes shadowed
 549 --  names after all.  WDP 94/07
 550 --  (if isEmptyUniqSet shadowed
 551 --  then id
 552 --  else pprTrace "Shadowed vars:" (ppr (uniqSetToList shadowed))) (
 553     m spec loc (scope `unionIdSets` new_set) errs
 554 --  )
 555 \end{code}
 556
 557 \begin{code}
 558 checkInScope :: Id -> LintM ()
 559 checkInScope id spec loc scope errs
 560   = let
 561         id_name = getName id
 562     in
 563     if isLocallyDefined id_name && not (id `elementOfIdSet` scope) then
 564       ((), addErr errs (hsep [ppr id, ptext SLIT("is out of scope")]) loc)
 565     else
 566       ((),errs)
 567
 568 checkTys :: Type -> Type -> ErrMsg -> LintM ()
 569 checkTys ty1 ty2 msg spec loc scope errs
 570   = if ty1 == ty2 then ((), errs) else ((), addErr errs msg loc)
 571 \end{code}
 572
 573 \begin{code}
 574 mkConErrMsg e
 575   = ($$) (ptext SLIT("Application of newtype constructor:"))
 576             (ppr e)
 577
 578
 579 mkCaseAltMsg :: CoreCaseAlts -> ErrMsg
 580 mkCaseAltMsg alts
 581   = ($$) (ptext SLIT("Type of case alternatives not the same:"))
 582             (ppr alts)
 583
 584 mkCaseAbstractMsg :: TyCon -> ErrMsg
 585 mkCaseAbstractMsg tycon
 586   = ($$) (ptext SLIT("An algebraic case on some weird type:"))
 587             (ppr tycon)
 588
 589 mkDefltMsg :: CoreCaseDefault -> ErrMsg
 590 mkDefltMsg deflt
 591   = ($$) (ptext SLIT("Binder in case default doesn't match type of scrutinee:"))
 592             (ppr deflt)
 593
 594 mkAppMsg :: Type -> Type -> CoreExpr -> ErrMsg
 595 mkAppMsg fun arg expr
 596   = vcat [ptext SLIT("Argument value doesn't match argument type:"),
 597               hang (ptext SLIT("Fun type:")) 4 (ppr fun),
 598               hang (ptext SLIT("Arg type:")) 4 (ppr arg),
 599               hang (ptext SLIT("Expression:")) 4 (pprCoreExpr expr)]
 600
 601 mkKindErrMsg :: TyVar -> Type -> CoreExpr -> ErrMsg
 602 mkKindErrMsg tyvar arg_ty expr
 603   = vcat [ptext SLIT("Kinds don't match in type application:"),
 604           hang (ptext SLIT("Type variable:"))
 605                  4 (ppr tyvar <+> ptext SLIT("::") <+> ppr (tyVarKind tyvar)),
 606           hang (ptext SLIT("Arg type:"))
 607                  4 (ppr arg_ty <+> ptext SLIT("::") <+> ppr (typeKind arg_ty)),
 608           hang (ptext SLIT("Expression:")) 4 (pprCoreExpr expr)]
 609
 610 mkTyAppMsg :: FAST_STRING -> Type -> Type -> CoreExpr -> ErrMsg
 611 mkTyAppMsg msg ty arg expr
 612   = vcat [hsep [ptext msg, ptext SLIT("type application:")],
 613               hang (ptext SLIT("Exp type:"))
 614                  4 (ppr ty <+> ptext SLIT("::") <+> ppr (typeKind ty)),
 615               hang (ptext SLIT("Arg type:"))
 616                  4 (ppr arg <+> ptext SLIT("::") <+> ppr (typeKind arg)),
 617               hang (ptext SLIT("Expression:")) 4 (pprCoreExpr expr)]
 618
 619 mkAlgAltMsg1 :: Type -> ErrMsg
 620 mkAlgAltMsg1 ty
 621   = ($$) (text "In some case statement, type of scrutinee is not a data type:")
 622             (ppr ty)
 623
 624 mkAlgAltMsg2 :: Type -> Id -> ErrMsg
 625 mkAlgAltMsg2 ty con
 626   = vcat [
 627         text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
 628         ppr ty,
 629         ppr con
 630     ]
 631
 632 mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg
 633 mkAlgAltMsg3 con alts
 634   = vcat [
 635         text "In some algebraic case alternative, number of arguments doesn't match constructor:",
 636         ppr con,
 637         ppr alts
 638     ]
 639
 640 mkAlgAltMsg4 :: Type -> Id -> ErrMsg
 641 mkAlgAltMsg4 ty arg
 642   = vcat [
 643         text "In some algebraic case alternative, type of argument doesn't match data constructor:",
 644         ppr ty,
 645         ppr arg
 646     ]
 647
 648 mkPrimAltMsg :: (Literal, CoreExpr) -> ErrMsg
 649 mkPrimAltMsg alt
 650   = ($$)
 651     (text "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
 652             (ppr alt)
 653
 654 mkRhsMsg :: Id -> Type -> ErrMsg
 655 mkRhsMsg binder ty
 656   = vcat
 657     [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
 658             ppr binder],
 659      hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
 660      hsep [ptext SLIT("Rhs type:"), ppr ty]]
 661
 662 mkRhsPrimMsg :: Id -> CoreExpr -> ErrMsg
 663 mkRhsPrimMsg binder rhs
 664   = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
 665                      ppr binder],
 666               hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
 667              ]
 668
 669 mkCoerceErr from_ty expr_ty
 670   = vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"),
 671           ptext SLIT("From-type:") <+> ppr from_ty,
 672           ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
 673     ]
 674 \end{code}