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