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