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