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