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