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 import Ubiq
  15
  16 import CoreSyn
  17
  18 import Bag
  19 import Kind             ( Kind{-instance-} )
  20 import Literal          ( literalType, Literal{-instance-} )
  21 import Id               ( idType, isBottomingId,
  22                           dataConArgTys, GenId{-instances-}
  23                         )
  24 import Maybes           ( catMaybes )
  25 import Name             ( isLocallyDefined, getSrcLoc )
  26 import Outputable       ( Outputable(..){-instance * []-} )
  27 import PprCore
  28 import PprStyle         ( PprStyle(..) )
  29 import PprType          ( GenType, GenTyVar, TyCon )
  30 import Pretty
  31 import PrimOp           ( primOpType, PrimOp(..) )
  32 import PrimRep          ( PrimRep(..) )
  33 import SrcLoc           ( SrcLoc )
  34 import Type             ( mkFunTy,getFunTy_maybe,mkForAllTy,mkForAllTys,getForAllTy_maybe,
  35                           getFunTyExpandingDicts_maybe,
  36                           isPrimType,typeKind,instantiateTy,splitSigmaTy,
  37                           mkForAllUsageTy,getForAllUsageTy,instantiateUsage,
  38                           maybeAppDataTyConExpandingDicts, eqTy
  39 --                        ,expandTy -- ToDo:rm
  40                         )
  41 import TyCon            ( isPrimTyCon, tyConFamilySize )
  42 import TyVar            ( tyVarKind, GenTyVar{-instances-} )
  43 import UniqSet          ( emptyUniqSet, mkUniqSet, intersectUniqSets,
  44                           unionUniqSets, elementOfUniqSet, UniqSet(..)
  45                         )
  46 import Unique           ( Unique )
  47 import Usage            ( GenUsage )
  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   = _trace "lintCoreExpr:Coerce" $
 191     lintCoreExpr expr `seqL` returnL (Just ty)
 192
 193 lintCoreExpr (Let binds body)
 194   = lintCoreBinding binds `thenL` \binders ->
 195     if (null binders) then
 196         lintCoreExpr body  -- Can't add a new source location
 197     else
 198       addLoc (BodyOfLetRec binders)
 199         (addInScopeVars binders (lintCoreExpr body))
 200
 201 lintCoreExpr e@(Con con args)
 202   = lintCoreArgs {-False-} e unoverloaded_ty args
 203     -- Note: we don't check for primitive types in these arguments
 204   where
 205         -- Constructors are special in that they aren't passed their
 206         -- dictionary arguments, so we swizzle them out of the
 207         -- constructor type before handing over to lintCorArgs
 208     unoverloaded_ty = mkForAllTys tyvars tau
 209     (tyvars, theta, tau) = splitSigmaTy (idType con)
 210
 211 lintCoreExpr e@(Prim op args)
 212   = lintCoreArgs {-True-} e (primOpType op) args
 213     -- Note: we do check for primitive types in these arguments
 214
 215 lintCoreExpr e@(App fun@(Var v) arg) | isBottomingId v
 216   = lintCoreExpr fun `thenMaybeL` \ ty -> lintCoreArg {-False-} e ty arg
 217     -- Note: we don't check for primitive types in argument to 'error'
 218
 219 lintCoreExpr e@(App fun arg)
 220   = lintCoreExpr fun `thenMaybeL` \ty -> lintCoreArg {-True-} e ty arg
 221     -- Note: we do check for primitive types in this argument
 222
 223 lintCoreExpr (Lam (ValBinder var) expr)
 224   = addLoc (LambdaBodyOf var)
 225       (addInScopeVars [var]
 226         (lintCoreExpr expr `thenMaybeL` \ty ->
 227          returnL (Just (mkFunTy (idType var) ty))))
 228
 229 lintCoreExpr (Lam (TyBinder tyvar) expr)
 230   = lintCoreExpr expr `thenMaybeL` \ty ->
 231     returnL (Just(mkForAllTy tyvar ty))
 232     -- ToDo: Should add in-scope type variable at this point
 233
 234 lintCoreExpr e@(Case scrut alts)
 235  = lintCoreExpr scrut `thenMaybeL` \ty ->
 236    lintCoreAlts alts ty
 237 \end{code}
 238
 239 %************************************************************************
 240 %*                                                                      *
 241 \subsection[lintCoreArgs]{lintCoreArgs}
 242 %*                                                                      *
 243 %************************************************************************
 244
 245 The boolean argument indicates whether we should flag type
 246 applications to primitive types as being errors.
 247
 248 \begin{code}
 249 lintCoreArgs :: {-Bool ->-} CoreExpr -> Type -> [CoreArg] -> LintM (Maybe Type)
 250
 251 lintCoreArgs _ ty [] = returnL (Just ty)
 252 lintCoreArgs e ty (a : args)
 253   = lintCoreArg  e ty  a `thenMaybeL` \ res ->
 254     lintCoreArgs e res args
 255 \end{code}
 256
 257 %************************************************************************
 258 %*                                                                      *
 259 \subsection[lintCoreArg]{lintCoreArg}
 260 %*                                                                      *
 261 %************************************************************************
 262
 263 \begin{code}
 264 lintCoreArg :: {-Bool ->-} CoreExpr -> Type -> CoreArg -> LintM (Maybe Type)
 265
 266 lintCoreArg e ty (LitArg lit)
 267   = -- Make sure function type matches argument
 268     case (getFunTyExpandingDicts_maybe ty) of
 269       Just (arg,res) | (lit_ty `eqTy` arg) -> returnL(Just res)
 270       _ -> addErrL (mkAppMsg ty lit_ty e) `seqL` returnL Nothing
 271   where
 272     lit_ty = literalType lit
 273
 274 lintCoreArg e ty (VarArg v)
 275   = -- Make sure variable is bound
 276     checkInScope v `seqL`
 277     -- Make sure function type matches argument
 278     case (getFunTyExpandingDicts_maybe ty) of
 279       Just (arg,res) | (var_ty `eqTy` arg) -> returnL(Just res)
 280       _ -> addErrL (mkAppMsg ty var_ty e) `seqL` returnL Nothing
 281   where
 282     var_ty = idType v
 283
 284 lintCoreArg e ty a@(TyArg arg_ty)
 285   = -- ToDo: Check that ty is well-kinded and has no unbound tyvars
 286     checkIfSpecDoneL (not (isPrimType arg_ty)) (mkSpecTyAppMsg a)
 287     `seqL`
 288     case (getForAllTy_maybe ty) of
 289       Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing
 290
 291       Just (tyvar,body) ->
 292         let
 293             tyvar_kind = tyVarKind tyvar
 294             argty_kind = typeKind arg_ty
 295         in
 296         if tyvar_kind == argty_kind
 297 -- SUSPICIOUS!  (tyvar_kind `isSubKindOf` argty_kind
 298 --               || argty_kind `isSubKindOf` tyvar_kind)
 299          then
 300             returnL(Just(instantiateTy [(tyvar,arg_ty)] body))
 301         else
 302             pprTrace "lintCoreArg:kinds:" (ppCat [ppr PprDebug tyvar_kind, ppr PprDebug argty_kind]) $
 303             addErrL (mkTyAppMsg SLIT("Kinds not right in") ty arg_ty e) `seqL` returnL Nothing
 304
 305 lintCoreArg e ty (UsageArg u)
 306   = -- ToDo: Check that usage has no unbound usage variables
 307     case (getForAllUsageTy ty) of
 308       Just (uvar,bounds,body) ->
 309         -- ToDo: Check argument satisfies bounds
 310         returnL(Just(panic "lintCoreArg:instantiateUsage uvar u body"))
 311       _ -> addErrL (mkUsageAppMsg ty u e) `seqL` returnL Nothing
 312 \end{code}
 313
 314 %************************************************************************
 315 %*                                                                      *
 316 \subsection[lintCoreAlts]{lintCoreAlts}
 317 %*                                                                      *
 318 %************************************************************************
 319
 320 \begin{code}
 321 lintCoreAlts :: CoreCaseAlts
 322              -> Type                    -- Type of scrutinee
 323 --           -> TyCon                   -- TyCon pinned on the case
 324              -> LintM (Maybe Type)      -- Type of alternatives
 325
 326 lintCoreAlts whole_alts@(AlgAlts alts deflt) ty --tycon
 327   = -- Check tycon is not a primitive tycon
 328 --    addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon)
 329 --    `seqL`
 330     -- Check we are scrutinising a proper datatype
 331     -- (ToDo: robustify)
 332 --    addErrIfL (not (tyConFamilySize tycon >= 1)) (mkCaseAbstractMsg tycon)
 333 --    `seqL`
 334     lintDeflt deflt ty
 335     `thenL` \maybe_deflt_ty ->
 336     mapL (lintAlgAlt ty {-tycon-}) alts
 337     `thenL` \maybe_alt_tys ->
 338     -- Check the result types
 339     case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
 340       []             -> returnL Nothing
 341
 342       (first_ty:tys) -> mapL check tys  `seqL`
 343                         returnL (Just first_ty)
 344         where
 345           check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
 346
 347 lintCoreAlts whole_alts@(PrimAlts alts deflt) ty --tycon
 348   = -- Check tycon is a primitive tycon
 349 --    addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon)
 350 --    `seqL`
 351     mapL (lintPrimAlt ty) alts
 352     `thenL` \maybe_alt_tys ->
 353     lintDeflt deflt ty
 354     `thenL` \maybe_deflt_ty ->
 355     -- Check the result types
 356     case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
 357       []             -> returnL Nothing
 358
 359       (first_ty:tys) -> mapL check tys  `seqL`
 360                         returnL (Just first_ty)
 361         where
 362           check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
 363
 364 lintAlgAlt scrut_ty {-tycon-ToDo: use it!-} (con,args,rhs)
 365   = (case maybeAppDataTyConExpandingDicts scrut_ty of
 366       Nothing ->
 367          addErrL (mkAlgAltMsg1 scrut_ty)
 368       Just (tycon, tys_applied, cons) ->
 369          let
 370            arg_tys = dataConArgTys con tys_applied
 371          in
 372          checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `seqL`
 373          checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
 374                                                                  `seqL`
 375          mapL check (zipEqual "lintAlgAlt" arg_tys args)         `seqL`
 376          returnL ()
 377     )                                                            `seqL`
 378     addInScopeVars args         (
 379          lintCoreExpr rhs
 380     )
 381   where
 382     check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
 383
 384     -- elem: yes, the elem-list here can sometimes be long-ish,
 385     -- but as it's use-once, probably not worth doing anything different
 386     -- We give it its own copy, so it isn't overloaded.
 387     elem _ []       = False
 388     elem x (y:ys)   = x==y || elem x ys
 389
 390 lintPrimAlt ty alt@(lit,rhs)
 391  = checkTys (literalType lit) ty (mkPrimAltMsg alt) `seqL`
 392    lintCoreExpr rhs
 393
 394 lintDeflt NoDefault _ = returnL Nothing
 395 lintDeflt deflt@(BindDefault binder rhs) ty
 396   = checkTys (idType binder) ty (mkDefltMsg deflt) `seqL`
 397     addInScopeVars [binder] (lintCoreExpr rhs)
 398 \end{code}
 399
 400 %************************************************************************
 401 %*                                                                      *
 402 \subsection[lint-monad]{The Lint monad}
 403 %*                                                                      *
 404 %************************************************************************
 405
 406 \begin{code}
 407 type LintM a = Bool             -- True <=> specialisation has been done
 408             -> [LintLocInfo]    -- Locations
 409             -> UniqSet Id       -- Local vars in scope
 410             -> Bag ErrMsg       -- Error messages so far
 411             -> (a, Bag ErrMsg)  -- Result and error messages (if any)
 412
 413 type ErrMsg = PprStyle -> Pretty
 414
 415 data LintLocInfo
 416   = RhsOf Id            -- The variable bound
 417   | LambdaBodyOf Id     -- The lambda-binder
 418   | BodyOfLetRec [Id]   -- One of the binders
 419   | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
 420
 421 instance Outputable LintLocInfo where
 422     ppr sty (RhsOf v)
 423       = ppBesides [ppr sty (getSrcLoc v), ppStr ": [RHS of ", pp_binders sty [v], ppStr "]"]
 424
 425     ppr sty (LambdaBodyOf b)
 426       = ppBesides [ppr sty (getSrcLoc b),
 427                 ppStr ": [in body of lambda with binder ", pp_binder sty b, ppStr "]"]
 428
 429     ppr sty (BodyOfLetRec bs)
 430       = ppBesides [ppr sty (getSrcLoc (head bs)),
 431                 ppStr ": [in body of letrec with binders ", pp_binders sty bs, ppStr "]"]
 432
 433     ppr sty (ImportedUnfolding locn)
 434       = ppBeside (ppr sty locn) (ppStr ": [in an imported unfolding]")
 435
 436 pp_binders :: PprStyle -> [Id] -> Pretty
 437 pp_binders sty bs = ppInterleave ppComma (map (pp_binder sty) bs)
 438
 439 pp_binder :: PprStyle -> Id -> Pretty
 440 pp_binder sty b = ppCat [ppr sty b, ppStr "::", ppr sty (idType b)]
 441 \end{code}
 442
 443 \begin{code}
 444 initL :: LintM a -> Bool -> Maybe ErrMsg
 445 initL m spec_done
 446   = case (m spec_done [] emptyUniqSet emptyBag) of { (_, errs) ->
 447     if isEmptyBag errs then
 448         Nothing
 449     else
 450         Just ( \ sty ->
 451           ppAboves [ msg sty | msg <- bagToList errs ]
 452         )
 453     }
 454
 455 returnL :: a -> LintM a
 456 returnL r spec loc scope errs = (r, errs)
 457
 458 thenL :: LintM a -> (a -> LintM b) -> LintM b
 459 thenL m k spec loc scope errs
 460   = case m spec loc scope errs of
 461       (r, errs') -> k r spec loc scope errs'
 462
 463 seqL :: LintM a -> LintM b -> LintM b
 464 seqL m k spec loc scope errs
 465   = case m spec loc scope errs of
 466       (_, errs') -> k spec loc scope errs'
 467
 468 thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b)
 469 thenMaybeL m k spec loc scope errs
 470   = case m spec loc scope errs of
 471       (Nothing, errs2) -> (Nothing, errs2)
 472       (Just r,  errs2) -> k r spec loc scope errs2
 473
 474 seqMaybeL :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b)
 475 seqMaybeL m k spec loc scope errs
 476   = case m spec loc scope errs of
 477       (Nothing, errs2) -> (Nothing, errs2)
 478       (Just _,  errs2) -> k spec loc scope errs2
 479
 480 mapL :: (a -> LintM b) -> [a] -> LintM [b]
 481 mapL f [] = returnL []
 482 mapL f (x:xs)
 483   = f x         `thenL` \ r ->
 484     mapL f xs   `thenL` \ rs ->
 485     returnL (r:rs)
 486
 487 mapMaybeL :: (a -> LintM (Maybe b)) -> [a] -> LintM (Maybe [b])
 488         -- Returns Nothing if anything fails
 489 mapMaybeL f [] = returnL (Just [])
 490 mapMaybeL f (x:xs)
 491   = f x             `thenMaybeL` \ r ->
 492     mapMaybeL f xs  `thenMaybeL` \ rs ->
 493     returnL (Just (r:rs))
 494 \end{code}
 495
 496 \begin{code}
 497 checkL :: Bool -> ErrMsg -> LintM ()
 498 checkL True  msg spec loc scope errs = ((), errs)
 499 checkL False msg spec loc scope errs = ((), addErr errs msg loc)
 500
 501 checkIfSpecDoneL :: Bool -> ErrMsg -> LintM ()
 502 checkIfSpecDoneL True  msg spec  loc scope errs = ((), errs)
 503 checkIfSpecDoneL False msg True  loc scope errs = ((), addErr errs msg loc)
 504 checkIfSpecDoneL False msg False loc scope errs = ((), errs)
 505
 506 addErrIfL pred spec
 507   = if pred then addErrL spec else returnL ()
 508
 509 addErrL :: ErrMsg -> LintM ()
 510 addErrL msg spec loc scope errs = ((), addErr errs msg loc)
 511
 512 addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg
 513
 514 addErr errs_so_far msg locs
 515   = ASSERT (not (null locs))
 516     errs_so_far `snocBag` ( \ sty ->
 517     ppHang (ppr sty (head locs)) 4 (msg sty)
 518     )
 519
 520 addLoc :: LintLocInfo -> LintM a -> LintM a
 521 addLoc extra_loc m spec loc scope errs
 522   = m spec (extra_loc:loc) scope errs
 523
 524 addInScopeVars :: [Id] -> LintM a -> LintM a
 525 addInScopeVars ids m spec loc scope errs
 526   = -- We check if these "new" ids are already
 527     -- in scope, i.e., we have *shadowing* going on.
 528     -- For now, it's just a "trace"; we may make
 529     -- a real error out of it...
 530     let
 531         new_set = mkUniqSet ids
 532
 533         shadowed = scope `intersectUniqSets` new_set
 534     in
 535 --  After adding -fliberate-case, Simon decided he likes shadowed
 536 --  names after all.  WDP 94/07
 537 --  (if isEmptyUniqSet shadowed
 538 --  then id
 539 --  else pprTrace "Shadowed vars:" (ppr PprDebug (uniqSetToList shadowed))) (
 540     m spec loc (scope `unionUniqSets` new_set) errs
 541 --  )
 542 \end{code}
 543
 544 \begin{code}
 545 checkInScope :: Id -> LintM ()
 546 checkInScope id spec loc scope errs
 547   = if isLocallyDefined id && not (id `elementOfUniqSet` scope) then
 548       ((),addErr errs (\sty -> ppCat [ppr sty id,ppStr "is out of scope"]) loc)
 549     else
 550       ((),errs)
 551
 552 checkTys :: Type -> Type -> ErrMsg -> LintM ()
 553 checkTys ty1 ty2 msg spec loc scope errs
 554   = if ty1 `eqTy` ty2 then ((), errs) else ((), addErr errs msg loc)
 555 \end{code}
 556
 557 \begin{code}
 558 mkCaseAltMsg :: CoreCaseAlts -> ErrMsg
 559 mkCaseAltMsg alts sty
 560   = ppAbove (ppStr "Type of case alternatives not the same:")
 561             (ppr sty alts)
 562
 563 mkCaseDataConMsg :: CoreExpr -> ErrMsg
 564 mkCaseDataConMsg expr sty
 565   = ppAbove (ppStr "A case scrutinee not of data constructor type:")
 566             (pp_expr sty expr)
 567
 568 mkCaseNotPrimMsg :: TyCon -> ErrMsg
 569 mkCaseNotPrimMsg tycon sty
 570   = ppAbove (ppStr "A primitive case on a non-primitive type:")
 571             (ppr sty tycon)
 572
 573 mkCasePrimMsg :: TyCon -> ErrMsg
 574 mkCasePrimMsg tycon sty
 575   = ppAbove (ppStr "An algebraic case on a primitive type:")
 576             (ppr sty tycon)
 577
 578 mkCaseAbstractMsg :: TyCon -> ErrMsg
 579 mkCaseAbstractMsg tycon sty
 580   = ppAbove (ppStr "An algebraic case on some weird type:")
 581             (ppr sty tycon)
 582
 583 mkDefltMsg :: CoreCaseDefault -> ErrMsg
 584 mkDefltMsg deflt sty
 585   = ppAbove (ppStr "Binder in case default doesn't match type of scrutinee:")
 586             (ppr sty deflt)
 587
 588 mkAppMsg :: Type -> Type -> CoreExpr -> ErrMsg
 589 mkAppMsg fun arg expr sty
 590   = ppAboves [ppStr "Argument value doesn't match argument type:",
 591               ppHang (ppStr "Fun type:") 4 (ppr sty fun),
 592               ppHang (ppStr "Arg type:") 4 (ppr sty arg),
 593               ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
 594
 595 mkTyAppMsg :: FAST_STRING -> Type -> Type -> CoreExpr -> ErrMsg
 596 mkTyAppMsg msg ty arg expr sty
 597   = ppAboves [ppCat [ppPStr msg, ppStr "type application:"],
 598               ppHang (ppStr "Exp type:")   4 (ppr sty ty),
 599               ppHang (ppStr "Arg type:")   4 (ppr sty arg),
 600               ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
 601
 602 mkUsageAppMsg :: Type -> Usage -> CoreExpr -> ErrMsg
 603 mkUsageAppMsg ty u expr sty
 604   = ppAboves [ppStr "Illegal usage application:",
 605               ppHang (ppStr "Exp type:") 4 (ppr sty ty),
 606               ppHang (ppStr "Usage exp:") 4 (ppr sty u),
 607               ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
 608
 609 mkAlgAltMsg1 :: Type -> ErrMsg
 610 mkAlgAltMsg1 ty sty
 611   = ppAbove (ppStr "In some case statement, type of scrutinee is not a data type:")
 612             (ppr sty ty)
 613 --          (ppAbove (ppr sty ty) (ppr sty (expandTy ty))) -- ToDo: rm
 614
 615 mkAlgAltMsg2 :: Type -> Id -> ErrMsg
 616 mkAlgAltMsg2 ty con sty
 617   = ppAboves [
 618         ppStr "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
 619         ppr sty ty,
 620         ppr sty con
 621     ]
 622
 623 mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg
 624 mkAlgAltMsg3 con alts sty
 625   = ppAboves [
 626         ppStr "In some algebraic case alternative, number of arguments doesn't match constructor:",
 627         ppr sty con,
 628         ppr sty alts
 629     ]
 630
 631 mkAlgAltMsg4 :: Type -> Id -> ErrMsg
 632 mkAlgAltMsg4 ty arg sty
 633   = ppAboves [
 634         ppStr "In some algebraic case alternative, type of argument doesn't match data constructor:",
 635         ppr sty ty,
 636         ppr sty arg
 637     ]
 638
 639 mkPrimAltMsg :: (Literal, CoreExpr) -> ErrMsg
 640 mkPrimAltMsg alt sty
 641   = ppAbove
 642     (ppStr "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
 643             (ppr sty alt)
 644
 645 mkRhsMsg :: Id -> Type -> ErrMsg
 646 mkRhsMsg binder ty sty
 647   = ppAboves
 648     [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:",
 649             ppr sty binder],
 650      ppCat [ppStr "Binder's type:", ppr sty (idType binder)],
 651      ppCat [ppStr "Rhs type:", ppr sty ty]]
 652
 653 mkRhsPrimMsg :: Id -> CoreExpr -> ErrMsg
 654 mkRhsPrimMsg binder rhs sty
 655   = ppAboves [ppCat [ppStr "The type of this binder is primitive:",
 656                      ppr sty binder],
 657               ppCat [ppStr "Binder's type:", ppr sty (idType binder)]
 658              ]
 659
 660 mkSpecTyAppMsg :: CoreArg -> ErrMsg
 661 mkSpecTyAppMsg arg sty
 662   = ppAbove
 663       (ppStr "Unboxed types in a type application (after specialisation):")
 664       (ppr sty arg)
 665
 666 pp_expr :: PprStyle -> CoreExpr -> Pretty
 667 pp_expr sty expr
 668   = pprCoreExpr sty (pprBigCoreBinder sty) (pprTypedCoreBinder sty) (pprTypedCoreBinder sty) expr
 669 \end{code}