ghc/compiler/coreSyn/CoreLint.lhs

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