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 PprType          ( GenType, GenTyVar, TyCon )
  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            ( 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 lintCoreExpr (SCC _ expr) = lintCoreExpr expr
 209 lintCoreExpr e@(Coerce coercion ty expr)
 210   = lintCoercion e coercion     `seqL`
 211     lintCoreExpr expr `seqL` returnL (Just ty)
 212
 213 lintCoreExpr (Let binds body)
 214   = lintCoreBinding binds `thenL` \binders ->
 215     if (null binders) then
 216         lintCoreExpr body  -- Can't add a new source location
 217     else
 218       addLoc (BodyOfLetRec binders)
 219         (addInScopeVars binders (lintCoreExpr body))
 220
 221 lintCoreExpr e@(Con con args)
 222   = checkL (isDataCon con) (mkConErrMsg e)      `seqL`
 223     lintCoreArgs {-False-} e (dataConRepType con) args
 224     -- Note: we don't check for primitive types in these arguments
 225
 226 lintCoreExpr e@(Prim op args)
 227   = lintCoreArgs {-True-} e (primOpType op) args
 228     -- Note: we do check for primitive types in these arguments
 229
 230 lintCoreExpr e@(App fun@(Var v) arg) | isBottomingId v
 231   = lintCoreExpr fun `thenMaybeL` \ ty -> lintCoreArg {-False-} e ty arg
 232     -- Note: we don't check for primitive types in argument to 'error'
 233
 234 lintCoreExpr e@(App fun arg)
 235   = lintCoreExpr fun `thenMaybeL` \ty -> lintCoreArg {-True-} e ty arg
 236     -- Note: we do check for primitive types in this argument
 237
 238 lintCoreExpr (Lam (ValBinder var) expr)
 239   = addLoc (LambdaBodyOf var)
 240       (addInScopeVars [var]
 241         (lintCoreExpr expr `thenMaybeL` \ty ->
 242          returnL (Just (mkFunTy (idType var) ty))))
 243
 244 lintCoreExpr (Lam (TyBinder tyvar) expr)
 245   = lintCoreExpr expr `thenMaybeL` \ty ->
 246     returnL (Just(mkForAllTy tyvar ty))
 247     -- ToDo: Should add in-scope type variable at this point
 248
 249 lintCoreExpr e@(Case scrut alts)
 250  = lintCoreExpr scrut `thenMaybeL` \ty ->
 251    lintCoreAlts alts ty
 252 \end{code}
 253
 254 %************************************************************************
 255 %*                                                                      *
 256 \subsection[lintCoreArgs]{lintCoreArgs}
 257 %*                                                                      *
 258 %************************************************************************
 259
 260 The boolean argument indicates whether we should flag type
 261 applications to primitive types as being errors.
 262
 263 \begin{code}
 264 lintCoreArgs :: {-Bool ->-} CoreExpr -> Type -> [CoreArg] -> LintM (Maybe Type)
 265
 266 lintCoreArgs _ ty [] = returnL (Just ty)
 267 lintCoreArgs e ty (a : args)
 268   = lintCoreArg  e ty  a `thenMaybeL` \ res ->
 269     lintCoreArgs e res args
 270 \end{code}
 271
 272 %************************************************************************
 273 %*                                                                      *
 274 \subsection[lintCoreArg]{lintCoreArg}
 275 %*                                                                      *
 276 %************************************************************************
 277
 278 \begin{code}
 279 lintCoreArg :: {-Bool ->-} CoreExpr -> Type -> CoreArg -> LintM (Maybe Type)
 280
 281 lintCoreArg e ty (LitArg lit)
 282   = -- Make sure function type matches argument
 283     case (splitFunTy_maybe ty) of
 284       Just (arg,res) | (lit_ty == arg) -> returnL(Just res)
 285       _ -> addErrL (mkAppMsg ty lit_ty e) `seqL` returnL Nothing
 286   where
 287     lit_ty = literalType lit
 288
 289 lintCoreArg e ty (VarArg v)
 290   = -- Make sure variable is bound
 291     checkInScope v `seqL`
 292     -- Make sure function type matches argument
 293     case (splitFunTy_maybe ty) of
 294       Just (arg,res) | (var_ty == arg) -> returnL(Just res)
 295       _ -> addErrL (mkAppMsg ty var_ty e) `seqL` returnL Nothing
 296   where
 297     var_ty = idType v
 298
 299 lintCoreArg e ty a@(TyArg arg_ty)
 300   = -- ToDo: Check that ty is well-kinded and has no unbound tyvars
 301     case (splitForAllTy_maybe ty) of
 302       Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing
 303
 304       Just (tyvar,body) ->
 305         let
 306             tyvar_kind = tyVarKind tyvar
 307             argty_kind = typeKind arg_ty
 308         in
 309         if argty_kind `hasMoreBoxityInfo` tyvar_kind
 310                 -- Arg type might be boxed for a function with an uncommitted
 311                 -- tyvar; notably this is used so that we can give
 312                 --      error :: forall a:*. String -> a
 313                 -- and then apply it to both boxed and unboxed types.
 314          then
 315             returnL(Just(instantiateTy (mkTyVarEnv [(tyvar,arg_ty)]) body))
 316         else
 317             pprTrace "lintCoreArg:kinds:" (hsep [ppr tyvar_kind, ppr argty_kind]) $
 318             addErrL (mkKindErrMsg tyvar arg_ty e) `seqL` returnL Nothing
 319 \end{code}
 320
 321 %************************************************************************
 322 %*                                                                      *
 323 \subsection[lintCoreAlts]{lintCoreAlts}
 324 %*                                                                      *
 325 %************************************************************************
 326
 327 \begin{code}
 328 lintCoreAlts :: CoreCaseAlts
 329              -> Type                    -- Type of scrutinee
 330 --           -> TyCon                   -- TyCon pinned on the case
 331              -> LintM (Maybe Type)      -- Type of alternatives
 332
 333 lintCoreAlts whole_alts@(AlgAlts alts deflt) ty --tycon
 334   = -- Check tycon is not a primitive tycon
 335 --    addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon)
 336 --    `seqL`
 337     -- Check we are scrutinising a proper datatype
 338     -- (ToDo: robustify)
 339 --    addErrIfL (not (tyConFamilySize tycon >= 1)) (mkCaseAbstractMsg tycon)
 340 --    `seqL`
 341     lintDeflt deflt ty
 342     `thenL` \maybe_deflt_ty ->
 343     mapL (lintAlgAlt ty {-tycon-}) alts
 344     `thenL` \maybe_alt_tys ->
 345     -- Check the result types
 346     case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
 347       []             -> returnL Nothing
 348
 349       (first_ty:tys) -> mapL check tys  `seqL`
 350                         returnL (Just first_ty)
 351         where
 352           check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
 353
 354 lintCoreAlts whole_alts@(PrimAlts alts deflt) ty --tycon
 355   = -- Check tycon is a primitive tycon
 356 --    addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon)
 357 --    `seqL`
 358     mapL (lintPrimAlt ty) alts
 359     `thenL` \maybe_alt_tys ->
 360     lintDeflt deflt ty
 361     `thenL` \maybe_deflt_ty ->
 362     -- Check the result types
 363     case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
 364       []             -> returnL Nothing
 365
 366       (first_ty:tys) -> mapL check tys  `seqL`
 367                         returnL (Just first_ty)
 368         where
 369           check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
 370
 371 lintAlgAlt scrut_ty (con,args,rhs)
 372   = (case splitAlgTyConApp_maybe scrut_ty of
 373       Just (tycon, tys_applied, cons) | isDataTyCon tycon ->
 374          let
 375            arg_tys = dataConArgTys con tys_applied
 376          in
 377          checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `seqL`
 378          checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
 379                                                                  `seqL`
 380          mapL check (zipEqual "lintAlgAlt" arg_tys args)         `seqL`
 381          returnL ()
 382
 383       other -> addErrL (mkAlgAltMsg1 scrut_ty)
 384     )                                                            `seqL`
 385     addInScopeVars args         (
 386          lintCoreExpr rhs
 387     )
 388   where
 389     check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
 390
 391     -- elem: yes, the elem-list here can sometimes be long-ish,
 392     -- but as it's use-once, probably not worth doing anything different
 393     -- We give it its own copy, so it isn't overloaded.
 394     elem _ []       = False
 395     elem x (y:ys)   = x==y || elem x ys
 396
 397 lintPrimAlt ty alt@(lit,rhs)
 398  = checkTys (literalType lit) ty (mkPrimAltMsg alt) `seqL`
 399    lintCoreExpr rhs
 400
 401 lintDeflt NoDefault _ = returnL Nothing
 402 lintDeflt deflt@(BindDefault binder rhs) ty
 403   = checkTys (idType binder) ty (mkDefltMsg deflt) `seqL`
 404     addInScopeVars [binder] (lintCoreExpr rhs)
 405 \end{code}
 406
 407 %************************************************************************
 408 %*                                                                      *
 409 \subsection[lint-coercion]{Coercion}
 410 %*                                                                      *
 411 %************************************************************************
 412
 413 \begin{code}
 414 lintCoercion e (CoerceIn  con) = check_con e con
 415 lintCoercion e (CoerceOut con) = check_con e con
 416
 417 check_con e con = checkL (isNewCon con)
 418                          (mkCoerceErrMsg e)
 419 \end{code}
 420
 421
 422 %************************************************************************
 423 %*                                                                      *
 424 \subsection[lint-monad]{The Lint monad}
 425 %*                                                                      *
 426 %************************************************************************
 427
 428 \begin{code}
 429 type LintM a = Bool             -- True <=> specialisation has been done
 430             -> [LintLocInfo]    -- Locations
 431             -> IdSet            -- Local vars in scope
 432             -> Bag ErrMsg       -- Error messages so far
 433             -> (a, Bag ErrMsg)  -- Result and error messages (if any)
 434
 435 data LintLocInfo
 436   = RhsOf Id            -- The variable bound
 437   | LambdaBodyOf Id     -- The lambda-binder
 438   | BodyOfLetRec [Id]   -- One of the binders
 439   | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
 440
 441 instance Outputable LintLocInfo where
 442     ppr (RhsOf v)
 443       = ppr (getSrcLoc v) <> colon <+>
 444         brackets (ptext SLIT("RHS of") <+> pp_binders [v])
 445
 446     ppr (LambdaBodyOf b)
 447       = ppr (getSrcLoc b) <> colon <+>
 448         brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b)
 449
 450     ppr (BodyOfLetRec bs)
 451       = ppr (getSrcLoc (head bs)) <> colon <+>
 452         brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs)
 453
 454     ppr (ImportedUnfolding locn)
 455       = ppr locn <> colon <+>
 456         brackets (ptext SLIT("in an imported unfolding"))
 457
 458 pp_binders :: [Id] -> SDoc
 459 pp_binders bs = sep (punctuate comma (map pp_binder bs))
 460
 461 pp_binder :: Id -> SDoc
 462 pp_binder b = hsep [ppr b, text "::", ppr (idType b)]
 463 \end{code}
 464
 465 \begin{code}
 466 initL :: LintM a -> Bool -> Maybe ErrMsg
 467 initL m spec_done
 468   = case (m spec_done [] emptyIdSet emptyBag) of { (_, errs) ->
 469     if isEmptyBag errs then
 470         Nothing
 471     else
 472         Just (vcat (bagToList errs))
 473     }
 474
 475 returnL :: a -> LintM a
 476 returnL r spec loc scope errs = (r, errs)
 477
 478 thenL :: LintM a -> (a -> LintM b) -> LintM b
 479 thenL m k spec loc scope errs
 480   = case m spec loc scope errs of
 481       (r, errs') -> k r spec loc scope errs'
 482
 483 seqL :: LintM a -> LintM b -> LintM b
 484 seqL m k spec loc scope errs
 485   = case m spec loc scope errs of
 486       (_, errs') -> k spec loc scope errs'
 487
 488 thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b)
 489 thenMaybeL m k spec loc scope errs
 490   = case m spec loc scope errs of
 491       (Nothing, errs2) -> (Nothing, errs2)
 492       (Just r,  errs2) -> k r spec loc scope errs2
 493
 494 mapL :: (a -> LintM b) -> [a] -> LintM [b]
 495 mapL f [] = returnL []
 496 mapL f (x:xs)
 497   = f x         `thenL` \ r ->
 498     mapL f xs   `thenL` \ rs ->
 499     returnL (r:rs)
 500
 501 mapMaybeL :: (a -> LintM (Maybe b)) -> [a] -> LintM (Maybe [b])
 502         -- Returns Nothing if anything fails
 503 mapMaybeL f [] = returnL (Just [])
 504 mapMaybeL f (x:xs)
 505   = f x             `thenMaybeL` \ r ->
 506     mapMaybeL f xs  `thenMaybeL` \ rs ->
 507     returnL (Just (r:rs))
 508 \end{code}
 509
 510 \begin{code}
 511 checkL :: Bool -> ErrMsg -> LintM ()
 512 checkL True  msg spec loc scope errs = ((), errs)
 513 checkL False msg spec loc scope errs = ((), addErr errs msg loc)
 514
 515 checkIfSpecDoneL :: Bool -> ErrMsg -> LintM ()
 516 checkIfSpecDoneL True  msg spec  loc scope errs = ((), errs)
 517 checkIfSpecDoneL False msg True  loc scope errs = ((), addErr errs msg loc)
 518 checkIfSpecDoneL False msg False loc scope errs = ((), errs)
 519
 520 addErrL :: ErrMsg -> LintM ()
 521 addErrL msg spec loc scope errs = ((), addErr errs msg loc)
 522
 523 addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg
 524
 525 addErr errs_so_far msg locs
 526   = ASSERT (not (null locs))
 527     errs_so_far `snocBag` (hang (ppr (head locs)) 4 msg)
 528
 529 addLoc :: LintLocInfo -> LintM a -> LintM a
 530 addLoc extra_loc m spec loc scope errs
 531   = m spec (extra_loc:loc) scope errs
 532
 533 addInScopeVars :: [Id] -> LintM a -> LintM a
 534 addInScopeVars ids m spec loc scope errs
 535   = -- We check if these "new" ids are already
 536     -- in scope, i.e., we have *shadowing* going on.
 537     -- For now, it's just a "trace"; we may make
 538     -- a real error out of it...
 539     let
 540         new_set = mkIdSet ids
 541
 542 --      shadowed = scope `intersectIdSets` new_set
 543     in
 544 --  After adding -fliberate-case, Simon decided he likes shadowed
 545 --  names after all.  WDP 94/07
 546 --  (if isEmptyUniqSet shadowed
 547 --  then id
 548 --  else pprTrace "Shadowed vars:" (ppr (uniqSetToList shadowed))) (
 549     m spec loc (scope `unionIdSets` new_set) errs
 550 --  )
 551 \end{code}
 552
 553 \begin{code}
 554 checkInScope :: Id -> LintM ()
 555 checkInScope id spec loc scope errs
 556   = let
 557         id_name = getName id
 558     in
 559     if isLocallyDefined id_name && not (id `elementOfIdSet` scope) then
 560       ((), addErr errs (hsep [ppr id, ptext SLIT("is out of scope")]) loc)
 561     else
 562       ((),errs)
 563
 564 checkTys :: Type -> Type -> ErrMsg -> LintM ()
 565 checkTys ty1 ty2 msg spec loc scope errs
 566   = if ty1 == ty2 then ((), errs) else ((), addErr errs msg loc)
 567 \end{code}
 568
 569 \begin{code}
 570 mkConErrMsg e
 571   = ($$) (ptext SLIT("Application of newtype constructor:"))
 572             (ppr e)
 573
 574 mkCoerceErrMsg e
 575   = ($$) (ptext SLIT("Coercion using a datatype 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 \end{code}