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