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
  13         PprStyle, CoreBinding, PlainCoreBinding(..), Id
  14     ) where
  15
  16 IMPORT_Trace
  17
  18 import AbsPrel          ( typeOfPrimOp, mkFunTy, PrimOp(..), PrimKind
  19                           IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
  20                           IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
  21                         )
  22 import AbsUniType
  23 import Bag
  24 import BasicLit         ( typeOfBasicLit, BasicLit )
  25 import CoreSyn          ( pprCoreBinding ) -- ToDo: correctly
  26 import Id               ( getIdUniType, isNullaryDataCon, isBottomingId,
  27                           getInstantiatedDataConSig, Id
  28                           IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed)
  29                         )
  30 import Maybes
  31 import Outputable
  32 import PlainCore
  33 import Pretty
  34 import SrcLoc           ( SrcLoc )
  35 import UniqSet
  36 import Util
  37
  38 infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_`
  39 \end{code}
  40
  41 Checks for
  42         (a) type errors
  43         (b) locally-defined variables used but not defined
  44
  45 Doesn't check for out-of-scope type variables, because they can
  46 legitimately arise.  Eg
  47 \begin{verbatim}
  48         k = /\a b -> \x::a y::b -> x
  49         f = /\c -> \z::c -> k c w z (error w "foo")
  50 \end{verbatim}
  51 Here \tr{w} is just a free type variable.
  52
  53 %************************************************************************
  54 %*                                                                      *
  55 \subsection{``lint'' for various constructs}
  56 %*                                                                      *
  57 %************************************************************************
  58
  59 @lintCoreBindings@ is the top-level interface function.
  60
  61 \begin{code}
  62 lintCoreBindings :: PprStyle -> String -> Bool -> [PlainCoreBinding] -> [PlainCoreBinding]
  63
  64 lintCoreBindings sty whodunnit spec_done binds
  65   = BSCC("CoreLint")
  66     case (initL (lint_binds binds) spec_done) of
  67       Nothing  -> binds
  68       Just msg -> pprPanic "" (ppAboves [
  69                         ppStr ("*** Core Lint Errors: in "++whodunnit++" ***"),
  70                         msg sty,
  71                         ppStr "*** Offending Program ***",
  72                         ppAboves (map (pprCoreBinding sty pprBigCoreBinder pprTypedCoreBinder ppr) binds),
  73                         ppStr "*** End of Offense ***"])
  74     ESCC
  75   where
  76     lint_binds :: [PlainCoreBinding] -> LintM ()
  77
  78     lint_binds [] = returnL ()
  79     lint_binds (bind:binds)
  80       = lintCoreBinds bind              `thenL` \ binders ->
  81         addInScopeVars binders (
  82             lint_binds binds
  83         )
  84 \end{code}
  85
  86 We use this to check all unfoldings that come in from interfaces
  87 (it is very painful to catch errors otherwise):
  88 \begin{code}
  89 lintUnfolding :: SrcLoc -> PlainCoreExpr -> PlainCoreExpr
  90
  91 lintUnfolding locn expr
  92   = case (initL (addLoc (ImportedUnfolding locn) (lintCoreExpr expr)) True{-pretend spec done-}) of
  93       Nothing  -> expr
  94       Just msg -> error ("ERROR: Type-incorrect unfolding from an interface:\n"++
  95                         (ppShow 80 (ppAboves [msg PprForUser,
  96                                         ppStr "*** Bad unfolding ***",
  97                                         ppr PprDebug expr,
  98                                         ppStr "*** End of bad unfolding ***"])))
  99 \end{code}
 100
 101 \begin{code}
 102 lintCoreAtom :: PlainCoreAtom -> LintM (Maybe UniType)
 103
 104 lintCoreAtom (CoLitAtom lit)       = returnL (Just (typeOfBasicLit lit))
 105 lintCoreAtom a@(CoVarAtom v)
 106   = checkInScope v      `thenL_`
 107     returnL (Just (getIdUniType v))
 108 \end{code}
 109
 110 \begin{code}
 111 lintCoreBinds :: PlainCoreBinding -> LintM [Id]         -- Returns the binders
 112 lintCoreBinds (CoNonRec binder rhs)
 113   = lint_binds_help (binder,rhs)        `thenL_`
 114     returnL [binder]
 115
 116 lintCoreBinds (CoRec pairs)
 117   = addInScopeVars binders (
 118         mapL lint_binds_help pairs `thenL_`
 119         returnL binders
 120     )
 121   where
 122     binders = [b | (b,_) <- pairs]
 123
 124 lint_binds_help (binder,rhs)
 125   = addLoc (RhsOf binder) (
 126         -- Check the rhs
 127         lintCoreExpr rhs        `thenL` \ maybe_rhs_ty ->
 128
 129         -- Check match to RHS type
 130         (case maybe_rhs_ty of
 131           Nothing     -> returnL ()
 132           Just rhs_ty -> checkTys (getIdUniType binder)
 133                                    rhs_ty
 134                                    (mkRhsMsg binder rhs_ty)
 135         )                       `thenL_`
 136
 137         -- Check not isPrimType
 138         checkL (not (isPrimType (getIdUniType binder)))
 139                (mkRhsPrimMsg binder rhs)
 140                                 `thenL_`
 141
 142         -- Check unfolding, if any
 143         -- Blegh. This is tricky, because the unfolding is a SimplifiableCoreExpr
 144         -- Give up for now
 145
 146         returnL ()
 147     )
 148 \end{code}
 149
 150 \begin{code}
 151 lintCoreExpr :: PlainCoreExpr -> LintM (Maybe UniType)  -- Nothing if error found
 152
 153 lintCoreExpr (CoVar var)
 154   = checkInScope var    `thenL_`
 155     returnL (Just ty)
 156 {-
 157     case (splitForalls ty) of { (tyvars, _) ->
 158     if null tyvars then
 159         returnL (Just ty)
 160     else
 161         addErrL (mkUnappTyMsg var ty)   `thenL_`
 162         returnL Nothing
 163     }
 164 -}
 165   where
 166     ty = getIdUniType var
 167
 168 lintCoreExpr (CoLit lit)        = returnL (Just (typeOfBasicLit lit))
 169 lintCoreExpr (CoSCC label expr) = lintCoreExpr expr
 170
 171 lintCoreExpr (CoLet binds body)
 172   = lintCoreBinds binds         `thenL` \ binders ->
 173     ASSERT(not (null binders))
 174     addLoc (BodyOfLetRec binders) (
 175     addInScopeVars binders (
 176         lintCoreExpr body
 177     ))
 178
 179 lintCoreExpr e@(CoCon con tys args)
 180   = checkTyApp con_ty tys (mkTyAppMsg e)    `thenMaybeL` \ con_tau_ty ->
 181     -- Note: no call to checkSpecTyApp;
 182     -- we allow CoCons applied to unboxed types to sail through
 183     mapMaybeL lintCoreAtom args                     `thenL` \ maybe_arg_tys ->
 184     case maybe_arg_tys of
 185       Nothing       -> returnL Nothing
 186       Just arg_tys  -> checkFunApp con_tau_ty arg_tys (mkFunAppMsg con_tau_ty arg_tys e)
 187   where
 188     con_ty = getIdUniType con
 189
 190 lintCoreExpr e@(CoPrim op tys args)
 191   = checkTyApp op_ty tys (mkTyAppMsg e)         `thenMaybeL` \ op_tau_ty ->
 192     -- checkSpecTyApp e tys (mkSpecTyAppMsg e)  `thenMaybeL_`
 193     mapMaybeL lintCoreAtom args                 `thenL` \ maybe_arg_tys ->
 194     case maybe_arg_tys of
 195       Nothing -> returnL Nothing
 196       Just arg_tys -> checkFunApp op_tau_ty arg_tys (mkFunAppMsg op_tau_ty arg_tys e)
 197   where
 198     op_ty = typeOfPrimOp op
 199
 200 lintCoreExpr e@(CoApp fun arg)
 201   = lce e []
 202   where
 203     lce (CoApp fun arg) arg_tys = lintCoreAtom arg      `thenMaybeL` \ arg_ty ->
 204                                   lce fun (arg_ty:arg_tys)
 205
 206     lce other_fun arg_tys = lintCoreExpr other_fun      `thenMaybeL` \ fun_ty ->
 207                             checkFunApp fun_ty arg_tys (mkFunAppMsg fun_ty arg_tys e)
 208
 209 lintCoreExpr e@(CoTyApp fun ty_arg)
 210   = lce e []
 211   where
 212     lce (CoTyApp fun ty_arg) ty_args = lce fun (ty_arg:ty_args)
 213
 214     lce other_fun ty_args = lintCoreExpr other_fun      `thenMaybeL` \ fun_ty ->
 215                             checkTyApp fun_ty ty_args (mkTyAppMsg e)
 216                                                         `thenMaybeL` \ res_ty ->
 217                             checkSpecTyApp other_fun ty_args (mkSpecTyAppMsg e)
 218                                                         `thenMaybeL_`
 219                             returnL (Just res_ty)
 220
 221 lintCoreExpr (CoLam binders expr)
 222   = ASSERT (not (null binders))
 223     addLoc (LambdaBodyOf binders) (
 224     addInScopeVars binders (
 225         lintCoreExpr expr   `thenMaybeL` \ body_ty ->
 226         returnL (Just (foldr (mkFunTy . getIdUniType) body_ty binders))
 227     ))
 228
 229 lintCoreExpr (CoTyLam tyvar expr)
 230   = lintCoreExpr expr           `thenMaybeL` \ body_ty ->
 231     case quantifyTy [tyvar] body_ty of
 232       (_, ty) -> returnL (Just ty) -- not worried about the TyVarTemplates that come back
 233
 234 lintCoreExpr e@(CoCase scrut alts)
 235  = lintCoreExpr scrut           `thenMaybeL` \ scrut_ty ->
 236
 237         -- Check that it is a data type
 238    case getUniDataTyCon_maybe scrut_ty of
 239         Nothing -> addErrL (mkCaseDataConMsg e) `thenL_`
 240                    returnL Nothing
 241         Just (tycon, _, _)
 242                 -> lintCoreAlts alts scrut_ty tycon
 243
 244 lintCoreAlts :: PlainCoreCaseAlternatives
 245              -> UniType                 -- Type of scrutinee
 246              -> TyCon                   -- TyCon pinned on the case
 247              -> LintM (Maybe UniType)   -- Type of alternatives
 248
 249 lintCoreAlts alts scrut_ty case_tycon
 250   = (case alts of
 251          CoAlgAlts alg_alts deflt ->
 252            chk_prim_type False case_tycon       `thenL_`
 253            chk_non_abstract_type case_tycon     `thenL_`
 254            mapL (lintAlgAlt scrut_ty) alg_alts  `thenL` \ maybe_alt_tys ->
 255            lintDeflt deflt scrut_ty             `thenL` \ maybe_deflt_ty ->
 256            returnL (maybe_deflt_ty : maybe_alt_tys)
 257
 258          CoPrimAlts prim_alts deflt ->
 259            chk_prim_type True case_tycon         `thenL_`
 260            mapL (lintPrimAlt scrut_ty) prim_alts `thenL` \ maybe_alt_tys ->
 261            lintDeflt deflt scrut_ty              `thenL` \ maybe_deflt_ty ->
 262            returnL (maybe_deflt_ty : maybe_alt_tys)
 263     )                                            `thenL` \ maybe_result_tys ->
 264          -- Check the result types
 265     case catMaybes (maybe_result_tys) of
 266       []             -> returnL Nothing
 267
 268       (first_ty:tys) -> mapL check tys  `thenL_`
 269                         returnL (Just first_ty)
 270         where
 271           check ty = checkTys first_ty ty (mkCaseAltMsg alts)
 272   where
 273     chk_prim_type prim_required tycon
 274       = if (isPrimTyCon tycon == prim_required) then
 275             returnL ()
 276         else
 277             addErrL (mkCasePrimMsg prim_required tycon)
 278
 279     chk_non_abstract_type tycon
 280       = case (getTyConFamilySize tycon) of
 281           Nothing -> addErrL (mkCaseAbstractMsg tycon)
 282           Just  _ -> returnL ()
 283
 284
 285 lintAlgAlt scrut_ty (con,args,rhs)
 286   = (case getUniDataTyCon_maybe scrut_ty of
 287       Nothing ->
 288          addErrL (mkAlgAltMsg1 scrut_ty)
 289       Just (tycon, tys_applied, cons) ->
 290          let
 291            (_, arg_tys, _) = getInstantiatedDataConSig con tys_applied
 292          in
 293          checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `thenL_`
 294          checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
 295                                                                  `thenL_`
 296          mapL check (arg_tys `zipEqual` args)                    `thenL_`
 297          returnL ()
 298     )                                                            `thenL_`
 299     addInScopeVars args         (
 300          lintCoreExpr rhs
 301     )
 302   where
 303     check (ty, arg) = checkTys ty (getIdUniType arg) (mkAlgAltMsg4 ty arg)
 304
 305     -- elem: yes, the elem-list here can sometimes be long-ish,
 306     -- but as it's use-once, probably not worth doing anything different
 307     -- We give it its own copy, so it isn't overloaded.
 308     elem _ []       = False
 309     elem x (y:ys)   = x==y || elem x ys
 310
 311 lintPrimAlt scrut_ty alt@(lit,rhs)
 312  = checkTys (typeOfBasicLit lit) scrut_ty (mkPrimAltMsg alt)    `thenL_`
 313    lintCoreExpr rhs
 314
 315 lintDeflt CoNoDefault scrut_ty = returnL Nothing
 316 lintDeflt deflt@(CoBindDefault binder rhs) scrut_ty
 317   = checkTys (getIdUniType binder) scrut_ty (mkDefltMsg deflt)  `thenL_`
 318     addInScopeVars [binder] (
 319         lintCoreExpr rhs
 320     )
 321 \end{code}
 322
 323
 324 %************************************************************************
 325 %*                                                                      *
 326 \subsection[lint-monad]{The Lint monad}
 327 %*                                                                      *
 328 %************************************************************************
 329
 330 \begin{code}
 331 type LintM a = Bool             -- True <=> specialisation has been done
 332             -> [LintLocInfo]    -- Locations
 333             -> UniqSet Id       -- Local vars in scope
 334             -> Bag ErrMsg       -- Error messages so far
 335             -> (a, Bag ErrMsg)  -- Result and error messages (if any)
 336
 337 type ErrMsg = PprStyle -> Pretty
 338
 339 data LintLocInfo
 340   = RhsOf Id            -- The variable bound
 341   | LambdaBodyOf [Id]   -- The lambda-binder
 342   | BodyOfLetRec [Id]   -- One of the binders
 343   | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
 344
 345 instance Outputable LintLocInfo where
 346     ppr sty (RhsOf v)
 347       = ppBesides [ppr sty (getSrcLoc v), ppStr ": [RHS of ", pp_binders sty [v], ppStr "]"]
 348
 349     ppr sty (LambdaBodyOf bs)
 350       = ppBesides [ppr sty (getSrcLoc (head bs)),
 351                 ppStr ": [in body of lambda with binders ", pp_binders sty bs, ppStr "]"]
 352
 353     ppr sty (BodyOfLetRec bs)
 354       = ppBesides [ppr sty (getSrcLoc (head bs)),
 355                 ppStr ": [in body of letrec with binders ", pp_binders sty bs, ppStr "]"]
 356
 357     ppr sty (ImportedUnfolding locn)
 358       = ppBeside (ppr sty locn) (ppStr ": [in an imported unfolding]")
 359
 360 pp_binders :: PprStyle -> [Id] -> Pretty
 361 pp_binders sty bs
 362   = ppInterleave ppComma (map pp_binder bs)
 363   where
 364     pp_binder b
 365       = ppCat [ppr sty b, ppStr "::", ppr sty (getIdUniType b)]
 366 \end{code}
 367
 368 \begin{code}
 369 initL :: LintM a -> Bool -> Maybe ErrMsg
 370 initL m spec_done
 371   = case (m spec_done [] emptyUniqSet emptyBag) of { (_, errs) ->
 372     if isEmptyBag errs then
 373         Nothing
 374     else
 375         Just ( \ sty ->
 376           ppAboves [ msg sty | msg <- bagToList errs ]
 377         )
 378     }
 379
 380 returnL :: a -> LintM a
 381 returnL r spec loc scope errs = (r, errs)
 382
 383 thenL :: LintM a -> (a -> LintM b) -> LintM b
 384 thenL m k spec loc scope errs
 385   = case m spec loc scope errs of
 386       (r, errs') -> k r spec loc scope errs'
 387
 388 thenL_ :: LintM a -> LintM b -> LintM b
 389 thenL_ m k spec loc scope errs
 390   = case m spec loc scope errs of
 391       (_, errs') -> k spec loc scope errs'
 392
 393 thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b)
 394 thenMaybeL m k spec loc scope errs
 395   = case m spec loc scope errs of
 396       (Nothing, errs2) -> (Nothing, errs2)
 397       (Just r,  errs2) -> k r spec loc scope errs2
 398
 399 thenMaybeL_ :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b)
 400 thenMaybeL_ m k spec loc scope errs
 401   = case m spec loc scope errs of
 402       (Nothing, errs2) -> (Nothing, errs2)
 403       (Just _,  errs2) -> k spec loc scope errs2
 404
 405 mapL :: (a -> LintM b) -> [a] -> LintM [b]
 406 mapL f [] = returnL []
 407 mapL f (x:xs)
 408   = f x         `thenL` \ r ->
 409     mapL f xs   `thenL` \ rs ->
 410     returnL (r:rs)
 411
 412 mapMaybeL :: (a -> LintM (Maybe b)) -> [a] -> LintM (Maybe [b])
 413         -- Returns Nothing if anything fails
 414 mapMaybeL f [] = returnL (Just [])
 415 mapMaybeL f (x:xs)
 416   = f x             `thenMaybeL` \ r ->
 417     mapMaybeL f xs  `thenMaybeL` \ rs ->
 418     returnL (Just (r:rs))
 419 \end{code}
 420
 421 \begin{code}
 422 checkL :: Bool -> ErrMsg -> LintM ()
 423 checkL True  msg spec loc scope errs = ((), errs)
 424 checkL False msg spec loc scope errs = ((), addErr errs msg loc)
 425
 426 addErrL :: ErrMsg -> LintM ()
 427 addErrL msg spec loc scope errs = ((), addErr errs msg loc)
 428
 429 addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg
 430
 431 addErr errs_so_far msg locs
 432   = ASSERT (not (null locs))
 433     errs_so_far `snocBag` ( \ sty ->
 434     ppHang (ppr sty (head locs)) 4 (msg sty)
 435     )
 436
 437 addLoc :: LintLocInfo -> LintM a -> LintM a
 438 addLoc extra_loc m spec loc scope errs
 439   = m spec (extra_loc:loc) scope errs
 440
 441 addInScopeVars :: [Id] -> LintM a -> LintM a
 442 addInScopeVars ids m spec loc scope errs
 443   = -- We check if these "new" ids are already
 444     -- in scope, i.e., we have *shadowing* going on.
 445     -- For now, it's just a "trace"; we may make
 446     -- a real error out of it...
 447     let
 448         new_set = mkUniqSet ids
 449
 450         shadowed = scope `intersectUniqSets` new_set
 451     in
 452 --  After adding -fliberate-case, Simon decided he likes shadowed
 453 --  names after all.  WDP 94/07
 454 --  (if isEmptyUniqSet shadowed
 455 --  then id
 456 --  else pprTrace "Shadowed vars:" (ppr PprDebug (uniqSetToList shadowed))) (
 457     m spec loc (scope `unionUniqSets` new_set) errs
 458 --  )
 459 \end{code}
 460
 461 \begin{code}
 462 checkTyApp :: UniType
 463            -> [UniType]
 464            -> ErrMsg
 465            -> LintM (Maybe UniType)
 466
 467 checkTyApp forall_ty ty_args msg spec_done loc scope errs
 468   = if (not spec_done && n_ty_args /= n_tyvars)
 469     || (spec_done     && n_ty_args  > n_tyvars)
 470     --
 471     -- Things are *not* OK if:
 472     --
 473     -- * Unsaturated type app before specialisation has been done;
 474     --
 475     -- * Oversaturated type app after specialisation (eta reduction
 476     --   may well be happening...);
 477     --
 478     -- Note: checkTyApp is usually followed by a call to checkSpecTyApp.
 479     --
 480     then (Nothing,     addErr errs msg loc)
 481     else (Just res_ty, errs)
 482   where
 483     (tyvars, rho_ty) = splitForalls forall_ty
 484     n_tyvars = length tyvars
 485     n_ty_args = length ty_args
 486     leftover_tyvars = drop n_ty_args tyvars
 487     inst_env = tyvars `zip` ty_args
 488     res_ty = mkForallTy leftover_tyvars (instantiateTy inst_env rho_ty)
 489 \end{code}
 490
 491 \begin{code}
 492 checkSpecTyApp :: PlainCoreExpr -> [UniType] -> ErrMsg -> LintM (Maybe ())
 493
 494 checkSpecTyApp expr ty_args msg spec_done loc scope errs
 495   = if spec_done
 496     && any isUnboxedDataType ty_args
 497     && not (an_application_of_error expr)
 498     then (Nothing, addErr errs msg loc)
 499     else (Just (), errs)
 500   where
 501      -- always safe (but maybe unfriendly) to say "False"
 502     an_application_of_error (CoVar id) | isBottomingId id = True
 503     an_application_of_error _ = False
 504 \end{code}
 505
 506 \begin{code}
 507 checkFunApp :: UniType          -- The function type
 508             -> [UniType]        -- The arg type(s)
 509             -> ErrMsg           -- Error messgae
 510             -> LintM (Maybe UniType)    -- The result type
 511
 512 checkFunApp fun_ty arg_tys msg spec loc scope errs
 513   = cfa res_ty expected_arg_tys arg_tys
 514   where
 515     (expected_arg_tys, res_ty) = splitTyArgs fun_ty
 516
 517     cfa res_ty expected []      -- Args have run out; that's fine
 518         = (Just (glueTyArgs expected res_ty), errs)
 519
 520     cfa res_ty [] arg_tys       -- Expected arg tys ran out first; maybe res_ty is a
 521                                 -- dictionary type which is actually a function?
 522         = case splitTyArgs (unDictifyTy res_ty) of
 523             ([], _)                 -> (Nothing, addErr errs msg loc)   -- Too many args
 524             (new_expected, new_res) -> cfa new_res new_expected arg_tys
 525
 526     cfa res_ty (expected_arg_ty:expected_arg_tys) (arg_ty:arg_tys)
 527         = case (cmpUniType True{-properly-} expected_arg_ty arg_ty) of
 528                 EQ_ -> cfa res_ty expected_arg_tys arg_tys
 529                 other -> (Nothing, addErr errs msg loc)                 -- Arg mis-match
 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 :: UniType -> UniType -> ErrMsg -> LintM ()
 541 checkTys ty1 ty2 msg spec loc scope errs
 542   = case (cmpUniType True{-properly-} ty1 ty2) of
 543         EQ_   -> ((), errs)
 544         other -> ((), addErr errs msg loc)
 545 \end{code}
 546
 547 \begin{code}
 548 mkCaseAltMsg :: PlainCoreCaseAlternatives -> ErrMsg
 549 mkCaseAltMsg alts sty
 550   = ppAbove (ppStr "In some case alternatives, type of alternatives not all same:")
 551             (ppr sty alts)
 552
 553 mkCaseDataConMsg :: PlainCoreExpr -> ErrMsg
 554 mkCaseDataConMsg expr sty
 555   = ppAbove (ppStr "A case scrutinee not a type-constructor type:")
 556             (pp_expr sty expr)
 557
 558 mkCasePrimMsg :: Bool -> TyCon -> ErrMsg
 559 mkCasePrimMsg True tycon sty
 560   = ppAbove (ppStr "A primitive case on a non-primitive type:")
 561             (ppr sty tycon)
 562 mkCasePrimMsg False 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 an abstract type:")
 569             (ppr sty tycon)
 570
 571 mkDefltMsg :: PlainCoreCaseDefault -> ErrMsg
 572 mkDefltMsg deflt sty
 573   = ppAbove (ppStr "Binder in default case of a case expression doesn't match type of scrutinee:")
 574             (ppr sty deflt)
 575
 576 mkFunAppMsg :: UniType -> [UniType] -> PlainCoreExpr -> ErrMsg
 577 mkFunAppMsg fun_ty arg_tys expr sty
 578   = ppAboves [ppStr "In a function application, function type doesn't match arg types:",
 579               ppHang (ppStr "Function type:") 4 (ppr sty fun_ty),
 580               ppHang (ppStr "Arg types:") 4 (ppAboves (map (ppr sty) arg_tys)),
 581               ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
 582
 583 mkUnappTyMsg :: Id -> UniType -> ErrMsg
 584 mkUnappTyMsg var ty sty
 585   = ppAboves [ppStr "Variable has a for-all type, but isn't applied to any types.",
 586               ppBeside (ppStr "Var:      ") (ppr sty var),
 587               ppBeside (ppStr "Its type: ") (ppr sty ty)]
 588
 589 mkAlgAltMsg1 :: UniType -> ErrMsg
 590 mkAlgAltMsg1 ty sty
 591   = ppAbove (ppStr "In some case statement, type of scrutinee is not a data type:")
 592             (ppr sty ty)
 593
 594 mkAlgAltMsg2 :: UniType -> Id -> ErrMsg
 595 mkAlgAltMsg2 ty con sty
 596   = ppAboves [
 597         ppStr "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
 598         ppr sty ty,
 599         ppr sty con
 600     ]
 601
 602 mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg
 603 mkAlgAltMsg3 con alts sty
 604   = ppAboves [
 605         ppStr "In some algebraic case alternative, number of arguments doesn't match constructor:",
 606         ppr sty con,
 607         ppr sty alts
 608     ]
 609
 610 mkAlgAltMsg4 :: UniType -> Id -> ErrMsg
 611 mkAlgAltMsg4 ty arg sty
 612   = ppAboves [
 613         ppStr "In some algebraic case alternative, type of argument doesn't match data constructor:",
 614         ppr sty ty,
 615         ppr sty arg
 616     ]
 617
 618 mkPrimAltMsg :: (BasicLit, PlainCoreExpr) -> ErrMsg
 619 mkPrimAltMsg alt sty
 620   = ppAbove (ppStr "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
 621             (ppr sty alt)
 622
 623 mkRhsMsg :: Id -> UniType -> ErrMsg
 624 mkRhsMsg binder ty sty
 625   = ppAboves [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 (getIdUniType binder)],
 628               ppCat [ppStr "Rhs type:", ppr sty ty]
 629              ]
 630
 631 mkRhsPrimMsg :: Id -> PlainCoreExpr -> ErrMsg
 632 mkRhsPrimMsg binder rhs sty
 633   = ppAboves [ppCat [ppStr "The type of this binder is primitive:",
 634                      ppr sty binder],
 635               ppCat [ppStr "Binder's type:", ppr sty (getIdUniType binder)]
 636              ]
 637
 638 mkTyAppMsg :: PlainCoreExpr -> ErrMsg
 639 mkTyAppMsg expr sty
 640   = ppAboves [ppStr "In a type application, either the function's type doesn't match",
 641               ppStr "the argument types, or an argument type is primitive:",
 642               pp_expr sty expr]
 643
 644 mkSpecTyAppMsg :: PlainCoreExpr -> ErrMsg
 645 mkSpecTyAppMsg expr sty
 646   = ppAbove (ppStr "Unboxed types in a type application (after specialisation):")
 647             (pp_expr sty expr)
 648
 649 pp_expr sty expr
 650   = pprCoreExpr sty pprBigCoreBinder pprTypedCoreBinder pprTypedCoreBinder expr
 651 \end{code}