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