ghc/compiler/coreSyn/CoreLint.lhs

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