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