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,
  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           ppStr "*** Offending Program ***",
  98           ppAboves (map (pprCoreBinding sty) binds),
  99           ppStr "*** 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                    ppStr "*** Bad unfolding ***",
 130                    ppr PprDebug expr,
 131                    ppStr "*** 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 unoverloaded_ty args
 202     -- Note: we don't check for primitive types in these arguments
 203   where
 204         -- Constructors are special in that they aren't passed their
 205         -- dictionary arguments, so we swizzle them out of the
 206         -- constructor type before handing over to lintCorArgs
 207     unoverloaded_ty = mkForAllTys tyvars tau
 208     (tyvars, theta, tau) = splitSigmaTy (idType con)
 209
 210 lintCoreExpr e@(Prim op args)
 211   = lintCoreArgs {-True-} e (primOpType op) args
 212     -- Note: we do check for primitive types in these arguments
 213
 214 lintCoreExpr e@(App fun@(Var v) arg) | isBottomingId v
 215   = lintCoreExpr fun `thenMaybeL` \ ty -> lintCoreArg {-False-} e ty arg
 216     -- Note: we don't check for primitive types in argument to 'error'
 217
 218 lintCoreExpr e@(App fun arg)
 219   = lintCoreExpr fun `thenMaybeL` \ty -> lintCoreArg {-True-} e ty arg
 220     -- Note: we do check for primitive types in this argument
 221
 222 lintCoreExpr (Lam (ValBinder var) expr)
 223   = addLoc (LambdaBodyOf var)
 224       (addInScopeVars [var]
 225         (lintCoreExpr expr `thenMaybeL` \ty ->
 226          returnL (Just (mkFunTy (idType var) ty))))
 227
 228 lintCoreExpr (Lam (TyBinder tyvar) expr)
 229   = lintCoreExpr expr `thenMaybeL` \ty ->
 230     returnL (Just(mkForAllTy tyvar ty))
 231     -- ToDo: Should add in-scope type variable at this point
 232
 233 lintCoreExpr e@(Case scrut alts)
 234  = lintCoreExpr scrut `thenMaybeL` \ty ->
 235    lintCoreAlts alts ty
 236 \end{code}
 237
 238 %************************************************************************
 239 %*                                                                      *
 240 \subsection[lintCoreArgs]{lintCoreArgs}
 241 %*                                                                      *
 242 %************************************************************************
 243
 244 The boolean argument indicates whether we should flag type
 245 applications to primitive types as being errors.
 246
 247 \begin{code}
 248 lintCoreArgs :: {-Bool ->-} CoreExpr -> Type -> [CoreArg] -> LintM (Maybe Type)
 249
 250 lintCoreArgs _ ty [] = returnL (Just ty)
 251 lintCoreArgs e ty (a : args)
 252   = lintCoreArg  e ty  a `thenMaybeL` \ res ->
 253     lintCoreArgs e res args
 254 \end{code}
 255
 256 %************************************************************************
 257 %*                                                                      *
 258 \subsection[lintCoreArg]{lintCoreArg}
 259 %*                                                                      *
 260 %************************************************************************
 261
 262 \begin{code}
 263 lintCoreArg :: {-Bool ->-} CoreExpr -> Type -> CoreArg -> LintM (Maybe Type)
 264
 265 lintCoreArg e ty (LitArg lit)
 266   = -- Make sure function type matches argument
 267     case (getFunTyExpandingDicts_maybe False{-no peeking in newtypes-} ty) of
 268       Just (arg,res) | (lit_ty `eqTy` arg) -> returnL(Just res)
 269       _ -> addErrL (mkAppMsg ty lit_ty e) `seqL` returnL Nothing
 270   where
 271     lit_ty = literalType lit
 272
 273 lintCoreArg e ty (VarArg v)
 274   = -- Make sure variable is bound
 275     checkInScope v `seqL`
 276     -- Make sure function type matches argument
 277     case (getFunTyExpandingDicts_maybe False{-as above-} ty) of
 278       Just (arg,res) | (var_ty `eqTy` arg) -> returnL(Just res)
 279       _ -> addErrL (mkAppMsg ty var_ty e) `seqL` returnL Nothing
 280   where
 281     var_ty = idType v
 282
 283 lintCoreArg e ty a@(TyArg arg_ty)
 284   = -- ToDo: Check that ty is well-kinded and has no unbound tyvars
 285     checkIfSpecDoneL (not (isPrimType arg_ty)) (mkSpecTyAppMsg a)
 286     `seqL`
 287     case (getForAllTyExpandingDicts_maybe ty) of
 288       Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing
 289
 290       Just (tyvar,body) ->
 291         let
 292             tyvar_kind = tyVarKind tyvar
 293             argty_kind = typeKind arg_ty
 294         in
 295         if argty_kind `hasMoreBoxityInfo` tyvar_kind
 296                 -- Arg type might be boxed for a function with an uncommitted
 297                 -- tyvar; notably this is used so that we can give
 298                 --      error :: forall a:*. String -> a
 299                 -- and then apply it to both boxed and unboxed types.
 300          then
 301             returnL(Just(instantiateTy [(tyvar,arg_ty)] body))
 302         else
 303             pprTrace "lintCoreArg:kinds:" (ppCat [ppr PprDebug tyvar_kind, ppr PprDebug argty_kind]) $
 304             addErrL (mkTyAppMsg SLIT("Kinds not right in") ty arg_ty e) `seqL` returnL Nothing
 305
 306 lintCoreArg e ty (UsageArg u)
 307   = -- ToDo: Check that usage has no unbound usage variables
 308     case (getForAllUsageTy ty) of
 309       Just (uvar,bounds,body) ->
 310         -- ToDo: Check argument satisfies bounds
 311         returnL(Just(panic "lintCoreArg:instantiateUsage uvar u body"))
 312       _ -> addErrL (mkUsageAppMsg ty u e) `seqL` returnL Nothing
 313 \end{code}
 314
 315 %************************************************************************
 316 %*                                                                      *
 317 \subsection[lintCoreAlts]{lintCoreAlts}
 318 %*                                                                      *
 319 %************************************************************************
 320
 321 \begin{code}
 322 lintCoreAlts :: CoreCaseAlts
 323              -> Type                    -- Type of scrutinee
 324 --           -> TyCon                   -- TyCon pinned on the case
 325              -> LintM (Maybe Type)      -- Type of alternatives
 326
 327 lintCoreAlts whole_alts@(AlgAlts alts deflt) ty --tycon
 328   = -- Check tycon is not a primitive tycon
 329 --    addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon)
 330 --    `seqL`
 331     -- Check we are scrutinising a proper datatype
 332     -- (ToDo: robustify)
 333 --    addErrIfL (not (tyConFamilySize tycon >= 1)) (mkCaseAbstractMsg tycon)
 334 --    `seqL`
 335     lintDeflt deflt ty
 336     `thenL` \maybe_deflt_ty ->
 337     mapL (lintAlgAlt ty {-tycon-}) alts
 338     `thenL` \maybe_alt_tys ->
 339     -- Check the result types
 340     case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
 341       []             -> returnL Nothing
 342
 343       (first_ty:tys) -> mapL check tys  `seqL`
 344                         returnL (Just first_ty)
 345         where
 346           check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
 347
 348 lintCoreAlts whole_alts@(PrimAlts alts deflt) ty --tycon
 349   = -- Check tycon is a primitive tycon
 350 --    addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon)
 351 --    `seqL`
 352     mapL (lintPrimAlt ty) alts
 353     `thenL` \maybe_alt_tys ->
 354     lintDeflt deflt ty
 355     `thenL` \maybe_deflt_ty ->
 356     -- Check the result types
 357     case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
 358       []             -> returnL Nothing
 359
 360       (first_ty:tys) -> mapL check tys  `seqL`
 361                         returnL (Just first_ty)
 362         where
 363           check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
 364
 365 lintAlgAlt scrut_ty {-tycon-ToDo: use it!-} (con,args,rhs)
 366   = (case maybeAppDataTyConExpandingDicts scrut_ty of
 367       Nothing ->
 368          addErrL (mkAlgAltMsg1 scrut_ty)
 369       Just (tycon, tys_applied, cons) ->
 370          let
 371            arg_tys = dataConArgTys con tys_applied
 372          in
 373          checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `seqL`
 374          checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
 375                                                                  `seqL`
 376          mapL check (zipEqual "lintAlgAlt" arg_tys args)         `seqL`
 377          returnL ()
 378     )                                                            `seqL`
 379     addInScopeVars args         (
 380          lintCoreExpr rhs
 381     )
 382   where
 383     check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
 384
 385     -- elem: yes, the elem-list here can sometimes be long-ish,
 386     -- but as it's use-once, probably not worth doing anything different
 387     -- We give it its own copy, so it isn't overloaded.
 388     elem _ []       = False
 389     elem x (y:ys)   = x==y || elem x ys
 390
 391 lintPrimAlt ty alt@(lit,rhs)
 392  = checkTys (literalType lit) ty (mkPrimAltMsg alt) `seqL`
 393    lintCoreExpr rhs
 394
 395 lintDeflt NoDefault _ = returnL Nothing
 396 lintDeflt deflt@(BindDefault binder rhs) ty
 397   = checkTys (idType binder) ty (mkDefltMsg deflt) `seqL`
 398     addInScopeVars [binder] (lintCoreExpr rhs)
 399 \end{code}
 400
 401 %************************************************************************
 402 %*                                                                      *
 403 \subsection[lint-monad]{The Lint monad}
 404 %*                                                                      *
 405 %************************************************************************
 406
 407 \begin{code}
 408 type LintM a = Bool             -- True <=> specialisation has been done
 409             -> [LintLocInfo]    -- Locations
 410             -> IdSet            -- Local vars in scope
 411             -> Bag ErrMsg       -- Error messages so far
 412             -> (a, Bag ErrMsg)  -- Result and error messages (if any)
 413
 414 type ErrMsg = PprStyle -> Pretty
 415
 416 data LintLocInfo
 417   = RhsOf Id            -- The variable bound
 418   | LambdaBodyOf Id     -- The lambda-binder
 419   | BodyOfLetRec [Id]   -- One of the binders
 420   | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
 421
 422 instance Outputable LintLocInfo where
 423     ppr sty (RhsOf v)
 424       = ppBesides [ppr sty (getSrcLoc v), ppStr ": [RHS of ", pp_binders sty [v], ppStr "]"]
 425
 426     ppr sty (LambdaBodyOf b)
 427       = ppBesides [ppr sty (getSrcLoc b),
 428                 ppStr ": [in body of lambda with binder ", pp_binder sty b, ppStr "]"]
 429
 430     ppr sty (BodyOfLetRec bs)
 431       = ppBesides [ppr sty (getSrcLoc (head bs)),
 432                 ppStr ": [in body of letrec with binders ", pp_binders sty bs, ppStr "]"]
 433
 434     ppr sty (ImportedUnfolding locn)
 435       = ppBeside (ppr sty locn) (ppStr ": [in an imported unfolding]")
 436
 437 pp_binders :: PprStyle -> [Id] -> Pretty
 438 pp_binders sty bs = ppInterleave ppComma (map (pp_binder sty) bs)
 439
 440 pp_binder :: PprStyle -> Id -> Pretty
 441 pp_binder sty b = ppCat [ppr sty b, ppStr "::", ppr sty (idType b)]
 442 \end{code}
 443
 444 \begin{code}
 445 initL :: LintM a -> Bool -> Maybe ErrMsg
 446 initL m spec_done
 447   = case (m spec_done [] emptyIdSet emptyBag) of { (_, errs) ->
 448     if isEmptyBag errs then
 449         Nothing
 450     else
 451         Just ( \ sty ->
 452           ppAboves [ msg sty | msg <- bagToList errs ]
 453         )
 454     }
 455
 456 returnL :: a -> LintM a
 457 returnL r spec loc scope errs = (r, errs)
 458
 459 thenL :: LintM a -> (a -> LintM b) -> LintM b
 460 thenL m k spec loc scope errs
 461   = case m spec loc scope errs of
 462       (r, errs') -> k r spec loc scope errs'
 463
 464 seqL :: LintM a -> LintM b -> LintM b
 465 seqL m k spec loc scope errs
 466   = case m spec loc scope errs of
 467       (_, errs') -> k spec loc scope errs'
 468
 469 thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b)
 470 thenMaybeL m k spec loc scope errs
 471   = case m spec loc scope errs of
 472       (Nothing, errs2) -> (Nothing, errs2)
 473       (Just r,  errs2) -> k r spec loc scope errs2
 474
 475 seqMaybeL :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b)
 476 seqMaybeL m k spec loc scope errs
 477   = case m spec loc scope errs of
 478       (Nothing, errs2) -> (Nothing, errs2)
 479       (Just _,  errs2) -> k spec loc scope errs2
 480
 481 mapL :: (a -> LintM b) -> [a] -> LintM [b]
 482 mapL f [] = returnL []
 483 mapL f (x:xs)
 484   = f x         `thenL` \ r ->
 485     mapL f xs   `thenL` \ rs ->
 486     returnL (r:rs)
 487
 488 mapMaybeL :: (a -> LintM (Maybe b)) -> [a] -> LintM (Maybe [b])
 489         -- Returns Nothing if anything fails
 490 mapMaybeL f [] = returnL (Just [])
 491 mapMaybeL f (x:xs)
 492   = f x             `thenMaybeL` \ r ->
 493     mapMaybeL f xs  `thenMaybeL` \ rs ->
 494     returnL (Just (r:rs))
 495 \end{code}
 496
 497 \begin{code}
 498 checkL :: Bool -> ErrMsg -> LintM ()
 499 checkL True  msg spec loc scope errs = ((), errs)
 500 checkL False msg spec loc scope errs = ((), addErr errs msg loc)
 501
 502 checkIfSpecDoneL :: Bool -> ErrMsg -> LintM ()
 503 checkIfSpecDoneL True  msg spec  loc scope errs = ((), errs)
 504 checkIfSpecDoneL False msg True  loc scope errs = ((), addErr errs msg loc)
 505 checkIfSpecDoneL False msg False loc scope errs = ((), errs)
 506
 507 addErrIfL pred spec
 508   = if pred then addErrL spec else returnL ()
 509
 510 addErrL :: ErrMsg -> LintM ()
 511 addErrL msg spec loc scope errs = ((), addErr errs msg loc)
 512
 513 addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg
 514
 515 addErr errs_so_far msg locs
 516   = ASSERT (not (null locs))
 517     errs_so_far `snocBag` ( \ sty ->
 518     ppHang (ppr sty (head locs)) 4 (msg sty)
 519     )
 520
 521 addLoc :: LintLocInfo -> LintM a -> LintM a
 522 addLoc extra_loc m spec loc scope errs
 523   = m spec (extra_loc:loc) scope errs
 524
 525 addInScopeVars :: [Id] -> LintM a -> LintM a
 526 addInScopeVars ids m spec loc scope errs
 527   = -- We check if these "new" ids are already
 528     -- in scope, i.e., we have *shadowing* going on.
 529     -- For now, it's just a "trace"; we may make
 530     -- a real error out of it...
 531     let
 532         new_set = mkIdSet ids
 533
 534 --      shadowed = scope `intersectIdSets` new_set
 535     in
 536 --  After adding -fliberate-case, Simon decided he likes shadowed
 537 --  names after all.  WDP 94/07
 538 --  (if isEmptyUniqSet shadowed
 539 --  then id
 540 --  else pprTrace "Shadowed vars:" (ppr PprDebug (uniqSetToList shadowed))) (
 541     m spec loc (scope `unionIdSets` new_set) errs
 542 --  )
 543 \end{code}
 544
 545 \begin{code}
 546 checkInScope :: Id -> LintM ()
 547 checkInScope id spec loc scope errs
 548   = let
 549         id_name = getName id
 550     in
 551     if isLocallyDefined id_name && not (id `elementOfIdSet` scope) then
 552       ((),addErr errs (\sty -> ppCat [ppr sty id, ppStr "is out of scope"]) loc)
 553     else
 554       ((),errs)
 555
 556 checkTys :: Type -> Type -> ErrMsg -> LintM ()
 557 checkTys ty1 ty2 msg spec loc scope errs
 558   = if ty1 `eqTy` ty2 then ((), errs) else ((), addErr errs msg loc)
 559 \end{code}
 560
 561 \begin{code}
 562 mkCaseAltMsg :: CoreCaseAlts -> ErrMsg
 563 mkCaseAltMsg alts sty
 564   = ppAbove (ppStr "Type of case alternatives not the same:")
 565             (ppr sty alts)
 566
 567 mkCaseDataConMsg :: CoreExpr -> ErrMsg
 568 mkCaseDataConMsg expr sty
 569   = ppAbove (ppStr "A case scrutinee not of data constructor type:")
 570             (pp_expr sty expr)
 571
 572 mkCaseNotPrimMsg :: TyCon -> ErrMsg
 573 mkCaseNotPrimMsg tycon sty
 574   = ppAbove (ppStr "A primitive case on a non-primitive type:")
 575             (ppr sty tycon)
 576
 577 mkCasePrimMsg :: TyCon -> ErrMsg
 578 mkCasePrimMsg tycon sty
 579   = ppAbove (ppStr "An algebraic case on a primitive type:")
 580             (ppr sty tycon)
 581
 582 mkCaseAbstractMsg :: TyCon -> ErrMsg
 583 mkCaseAbstractMsg tycon sty
 584   = ppAbove (ppStr "An algebraic case on some weird type:")
 585             (ppr sty tycon)
 586
 587 mkDefltMsg :: CoreCaseDefault -> ErrMsg
 588 mkDefltMsg deflt sty
 589   = ppAbove (ppStr "Binder in case default doesn't match type of scrutinee:")
 590             (ppr sty deflt)
 591
 592 mkAppMsg :: Type -> Type -> CoreExpr -> ErrMsg
 593 mkAppMsg fun arg expr sty
 594   = ppAboves [ppStr "Argument value doesn't match argument type:",
 595               ppHang (ppStr "Fun type:") 4 (ppr sty fun),
 596               ppHang (ppStr "Arg type:") 4 (ppr sty arg),
 597               ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
 598
 599 mkTyAppMsg :: FAST_STRING -> Type -> Type -> CoreExpr -> ErrMsg
 600 mkTyAppMsg msg ty arg expr sty
 601   = ppAboves [ppCat [ppPStr msg, ppStr "type application:"],
 602               ppHang (ppStr "Exp type:")   4 (ppr sty ty),
 603               ppHang (ppStr "Arg type:")   4 (ppr sty arg),
 604               ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
 605
 606 mkUsageAppMsg :: Type -> Usage -> CoreExpr -> ErrMsg
 607 mkUsageAppMsg ty u expr sty
 608   = ppAboves [ppStr "Illegal usage application:",
 609               ppHang (ppStr "Exp type:") 4 (ppr sty ty),
 610               ppHang (ppStr "Usage exp:") 4 (ppr sty u),
 611               ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
 612
 613 mkAlgAltMsg1 :: Type -> ErrMsg
 614 mkAlgAltMsg1 ty sty
 615   = ppAbove (ppStr "In some case statement, type of scrutinee is not a data type:")
 616             (ppr sty ty)
 617 --          (ppAbove (ppr sty ty) (ppr sty (expandTy ty))) -- ToDo: rm
 618
 619 mkAlgAltMsg2 :: Type -> Id -> ErrMsg
 620 mkAlgAltMsg2 ty con sty
 621   = ppAboves [
 622         ppStr "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
 623         ppr sty ty,
 624         ppr sty con
 625     ]
 626
 627 mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg
 628 mkAlgAltMsg3 con alts sty
 629   = ppAboves [
 630         ppStr "In some algebraic case alternative, number of arguments doesn't match constructor:",
 631         ppr sty con,
 632         ppr sty alts
 633     ]
 634
 635 mkAlgAltMsg4 :: Type -> Id -> ErrMsg
 636 mkAlgAltMsg4 ty arg sty
 637   = ppAboves [
 638         ppStr "In some algebraic case alternative, type of argument doesn't match data constructor:",
 639         ppr sty ty,
 640         ppr sty arg
 641     ]
 642
 643 mkPrimAltMsg :: (Literal, CoreExpr) -> ErrMsg
 644 mkPrimAltMsg alt sty
 645   = ppAbove
 646     (ppStr "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
 647             (ppr sty alt)
 648
 649 mkRhsMsg :: Id -> Type -> ErrMsg
 650 mkRhsMsg binder ty sty
 651   = ppAboves
 652     [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:",
 653             ppr sty binder],
 654      ppCat [ppStr "Binder's type:", ppr sty (idType binder)],
 655      ppCat [ppStr "Rhs type:", ppr sty ty]]
 656
 657 mkRhsPrimMsg :: Id -> CoreExpr -> ErrMsg
 658 mkRhsPrimMsg binder rhs sty
 659   = ppAboves [ppCat [ppStr "The type of this binder is primitive:",
 660                      ppr sty binder],
 661               ppCat [ppStr "Binder's type:", ppr sty (idType binder)]
 662              ]
 663
 664 mkSpecTyAppMsg :: CoreArg -> ErrMsg
 665 mkSpecTyAppMsg arg sty
 666   = ppAbove
 667       (ppStr "Unboxed types in a type application (after specialisation):")
 668       (ppr sty arg)
 669
 670 pp_expr :: PprStyle -> CoreExpr -> Pretty
 671 pp_expr sty expr
 672   = pprCoreExpr sty (pprBigCoreBinder sty) (pprTypedCoreBinder sty) (pprTypedCoreBinder sty) expr
 673 \end{code}