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 -> Maybe PlainCoreExpr
  90
  91 lintUnfolding locn expr
  92   = case (initL (addLoc (ImportedUnfolding locn) (lintCoreExpr expr)) True{-pretend spec done-}) of
  93       Nothing  -> Just expr
  94       Just msg -> pprTrace "WARNING: Discarded bad unfolding from interface:\n"
  95                            (ppAboves [msg PprForUser,
  96                                       ppStr "*** Bad unfolding ***",
  97                                       ppr PprDebug expr,
  98                                       ppStr "*** End unfolding ***"])
  99                   Nothing
 100 \end{code}
 101
 102 \begin{code}
 103 lintCoreAtom :: PlainCoreAtom -> LintM (Maybe UniType)
 104
 105 lintCoreAtom (CoLitAtom lit)       = returnL (Just (typeOfBasicLit lit))
 106 lintCoreAtom a@(CoVarAtom v)
 107   = checkInScope v      `thenL_`
 108     returnL (Just (getIdUniType v))
 109 \end{code}
 110
 111 \begin{code}
 112 lintCoreBinds :: PlainCoreBinding -> LintM [Id]         -- Returns the binders
 113 lintCoreBinds (CoNonRec binder rhs)
 114   = lint_binds_help (binder,rhs)        `thenL_`
 115     returnL [binder]
 116
 117 lintCoreBinds (CoRec pairs)
 118   = addInScopeVars binders (
 119         mapL lint_binds_help pairs `thenL_`
 120         returnL binders
 121     )
 122   where
 123     binders = [b | (b,_) <- pairs]
 124
 125 lint_binds_help (binder,rhs)
 126   = addLoc (RhsOf binder) (
 127         -- Check the rhs
 128         lintCoreExpr rhs        `thenL` \ maybe_rhs_ty ->
 129
 130         -- Check match to RHS type
 131         (case maybe_rhs_ty of
 132           Nothing     -> returnL ()
 133           Just rhs_ty -> checkTys (getIdUniType binder)
 134                                    rhs_ty
 135                                    (mkRhsMsg binder rhs_ty)
 136         )                       `thenL_`
 137
 138         -- Check not isPrimType
 139         checkIfSpecDoneL (not (isPrimType (getIdUniType binder)))
 140                          (mkRhsPrimMsg binder rhs)
 141                                 `thenL_`
 142
 143         -- Check unfolding, if any
 144         -- Blegh. This is tricky, because the unfolding is a SimplifiableCoreExpr
 145         -- Give up for now
 146
 147         returnL ()
 148     )
 149 \end{code}
 150
 151 \begin{code}
 152 lintCoreExpr :: PlainCoreExpr -> LintM (Maybe UniType)  -- Nothing if error found
 153
 154 lintCoreExpr (CoVar var)
 155   = checkInScope var    `thenL_`
 156     returnL (Just ty)
 157 {-
 158     case (splitForalls ty) of { (tyvars, _) ->
 159     if null tyvars then
 160         returnL (Just ty)
 161     else
 162         addErrL (mkUnappTyMsg var ty)   `thenL_`
 163         returnL Nothing
 164     }
 165 -}
 166   where
 167     ty = getIdUniType var
 168
 169 lintCoreExpr (CoLit lit)        = returnL (Just (typeOfBasicLit lit))
 170 lintCoreExpr (CoSCC label expr) = lintCoreExpr expr
 171
 172 lintCoreExpr (CoLet binds body)
 173   = lintCoreBinds binds         `thenL` \ binders ->
 174     ASSERT(not (null binders))
 175     addLoc (BodyOfLetRec binders) (
 176     addInScopeVars binders (
 177         lintCoreExpr body
 178     ))
 179
 180 lintCoreExpr e@(CoCon con tys args)
 181   = checkTyApp con_ty tys (mkTyAppMsg e)        `thenMaybeL` \ con_tau_ty ->
 182     -- Note: no call to checkSpecTyApp for constructor type args
 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     -- ToDo: 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 checkIfSpecDoneL :: Bool -> ErrMsg -> LintM ()
 427 checkIfSpecDoneL True  msg spec  loc scope errs = ((), errs)
 428 checkIfSpecDoneL False msg True  loc scope errs = ((), addErr errs msg loc)
 429 checkIfSpecDoneL False msg False loc scope errs = ((), errs)
 430
 431 addErrL :: ErrMsg -> LintM ()
 432 addErrL msg spec loc scope errs = ((), addErr errs msg loc)
 433
 434 addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg
 435
 436 addErr errs_so_far msg locs
 437   = ASSERT (not (null locs))
 438     errs_so_far `snocBag` ( \ sty ->
 439     ppHang (ppr sty (head locs)) 4 (msg sty)
 440     )
 441
 442 addLoc :: LintLocInfo -> LintM a -> LintM a
 443 addLoc extra_loc m spec loc scope errs
 444   = m spec (extra_loc:loc) scope errs
 445
 446 addInScopeVars :: [Id] -> LintM a -> LintM a
 447 addInScopeVars ids m spec loc scope errs
 448   = -- We check if these "new" ids are already
 449     -- in scope, i.e., we have *shadowing* going on.
 450     -- For now, it's just a "trace"; we may make
 451     -- a real error out of it...
 452     let
 453         new_set = mkUniqSet ids
 454
 455         shadowed = scope `intersectUniqSets` new_set
 456     in
 457 --  After adding -fliberate-case, Simon decided he likes shadowed
 458 --  names after all.  WDP 94/07
 459 --  (if isEmptyUniqSet shadowed
 460 --  then id
 461 --  else pprTrace "Shadowed vars:" (ppr PprDebug (uniqSetToList shadowed))) (
 462     m spec loc (scope `unionUniqSets` new_set) errs
 463 --  )
 464 \end{code}
 465
 466 \begin{code}
 467 checkTyApp :: UniType
 468            -> [UniType]
 469            -> ErrMsg
 470            -> LintM (Maybe UniType)
 471
 472 checkTyApp forall_ty ty_args msg spec_done loc scope errs
 473   = if (not spec_done && n_ty_args /= n_tyvars)
 474     || (spec_done     && n_ty_args  > n_tyvars)
 475     --
 476     -- Things are *not* OK if:
 477     --
 478     -- * Unsaturated type app before specialisation has been done;
 479     --
 480     -- * Oversaturated type app after specialisation (eta reduction
 481     --   may well be happening...);
 482     --
 483     -- Note: checkTyApp is usually followed by a call to checkSpecTyApp.
 484     --
 485     then (Nothing,     addErr errs msg loc)
 486     else (Just res_ty, errs)
 487   where
 488     (tyvars, rho_ty) = splitForalls forall_ty
 489     n_tyvars = length tyvars
 490     n_ty_args = length ty_args
 491     leftover_tyvars = drop n_ty_args tyvars
 492     inst_env = tyvars `zip` ty_args
 493     res_ty = mkForallTy leftover_tyvars (instantiateTy inst_env rho_ty)
 494 \end{code}
 495
 496 \begin{code}
 497 checkSpecTyApp :: PlainCoreExpr -> [UniType] -> ErrMsg -> LintM (Maybe ())
 498
 499 checkSpecTyApp expr ty_args msg spec_done loc scope errs
 500   = if spec_done
 501     && any isUnboxedDataType ty_args
 502     && not (an_application_of_error expr)
 503     then (Nothing, addErr errs msg loc)
 504     else (Just (), errs)
 505   where
 506      -- always safe (but maybe unfriendly) to say "False"
 507     an_application_of_error (CoVar id) | isBottomingId id = True
 508     an_application_of_error _ = False
 509 \end{code}
 510
 511 \begin{code}
 512 checkFunApp :: UniType          -- The function type
 513             -> [UniType]        -- The arg type(s)
 514             -> ErrMsg           -- Error messgae
 515             -> LintM (Maybe UniType)    -- The result type
 516
 517 checkFunApp fun_ty arg_tys msg spec loc scope errs
 518   = cfa res_ty expected_arg_tys arg_tys
 519   where
 520     (expected_arg_tys, res_ty) = splitTyArgs fun_ty
 521
 522     cfa res_ty expected []      -- Args have run out; that's fine
 523         = (Just (glueTyArgs expected res_ty), errs)
 524
 525     cfa res_ty [] arg_tys       -- Expected arg tys ran out first; maybe res_ty is a
 526                                 -- dictionary type which is actually a function?
 527         = case splitTyArgs (unDictifyTy res_ty) of
 528             ([], _)                 -> (Nothing, addErr errs msg loc)   -- Too many args
 529             (new_expected, new_res) -> cfa new_res new_expected arg_tys
 530
 531     cfa res_ty (expected_arg_ty:expected_arg_tys) (arg_ty:arg_tys)
 532         = case (cmpUniType True{-properly-} expected_arg_ty arg_ty) of
 533                 EQ_ -> cfa res_ty expected_arg_tys arg_tys
 534                 other -> (Nothing, addErr errs msg loc)                 -- Arg mis-match
 535 \end{code}
 536
 537 \begin{code}
 538 checkInScope :: Id -> LintM ()
 539 checkInScope id spec loc scope errs
 540   = if isLocallyDefined id && not (id `elementOfUniqSet` scope) then
 541         ((), addErr errs (\ sty -> ppCat [ppr sty id, ppStr "is out of scope"]) loc)
 542     else
 543         ((), errs)
 544
 545 checkTys :: UniType -> UniType -> ErrMsg -> LintM ()
 546 checkTys ty1 ty2 msg spec loc scope errs
 547   = case (cmpUniType True{-properly-} ty1 ty2) of
 548         EQ_   -> ((), errs)
 549         other -> ((), addErr errs msg loc)
 550 \end{code}
 551
 552 \begin{code}
 553 mkCaseAltMsg :: PlainCoreCaseAlternatives -> ErrMsg
 554 mkCaseAltMsg alts sty
 555   = ppAbove (ppStr "In some case alternatives, type of alternatives not all same:")
 556             (ppr sty alts)
 557
 558 mkCaseDataConMsg :: PlainCoreExpr -> ErrMsg
 559 mkCaseDataConMsg expr sty
 560   = ppAbove (ppStr "A case scrutinee not a type-constructor type:")
 561             (pp_expr sty expr)
 562
 563 mkCasePrimMsg :: Bool -> TyCon -> ErrMsg
 564 mkCasePrimMsg True tycon sty
 565   = ppAbove (ppStr "A primitive case on a non-primitive type:")
 566             (ppr sty tycon)
 567 mkCasePrimMsg False tycon sty
 568   = ppAbove (ppStr "An algebraic case on a primitive type:")
 569             (ppr sty tycon)
 570
 571 mkCaseAbstractMsg :: TyCon -> ErrMsg
 572 mkCaseAbstractMsg tycon sty
 573   = ppAbove (ppStr "An algebraic case on an abstract type:")
 574             (ppr sty tycon)
 575
 576 mkDefltMsg :: PlainCoreCaseDefault -> ErrMsg
 577 mkDefltMsg deflt sty
 578   = ppAbove (ppStr "Binder in default case of a case expression doesn't match type of scrutinee:")
 579             (ppr sty deflt)
 580
 581 mkFunAppMsg :: UniType -> [UniType] -> PlainCoreExpr -> ErrMsg
 582 mkFunAppMsg fun_ty arg_tys expr sty
 583   = ppAboves [ppStr "In a function application, function type doesn't match arg types:",
 584               ppHang (ppStr "Function type:") 4 (ppr sty fun_ty),
 585               ppHang (ppStr "Arg types:") 4 (ppAboves (map (ppr sty) arg_tys)),
 586               ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
 587
 588 mkUnappTyMsg :: Id -> UniType -> ErrMsg
 589 mkUnappTyMsg var ty sty
 590   = ppAboves [ppStr "Variable has a for-all type, but isn't applied to any types.",
 591               ppBeside (ppStr "Var:      ") (ppr sty var),
 592               ppBeside (ppStr "Its type: ") (ppr sty ty)]
 593
 594 mkAlgAltMsg1 :: UniType -> ErrMsg
 595 mkAlgAltMsg1 ty sty
 596   = ppAbove (ppStr "In some case statement, type of scrutinee is not a data type:")
 597             (ppr sty ty)
 598
 599 mkAlgAltMsg2 :: UniType -> Id -> ErrMsg
 600 mkAlgAltMsg2 ty con sty
 601   = ppAboves [
 602         ppStr "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
 603         ppr sty ty,
 604         ppr sty con
 605     ]
 606
 607 mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg
 608 mkAlgAltMsg3 con alts sty
 609   = ppAboves [
 610         ppStr "In some algebraic case alternative, number of arguments doesn't match constructor:",
 611         ppr sty con,
 612         ppr sty alts
 613     ]
 614
 615 mkAlgAltMsg4 :: UniType -> Id -> ErrMsg
 616 mkAlgAltMsg4 ty arg sty
 617   = ppAboves [
 618         ppStr "In some algebraic case alternative, type of argument doesn't match data constructor:",
 619         ppr sty ty,
 620         ppr sty arg
 621     ]
 622
 623 mkPrimAltMsg :: (BasicLit, PlainCoreExpr) -> ErrMsg
 624 mkPrimAltMsg alt sty
 625   = ppAbove (ppStr "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
 626             (ppr sty alt)
 627
 628 mkRhsMsg :: Id -> UniType -> ErrMsg
 629 mkRhsMsg binder ty sty
 630   = ppAboves [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:",
 631                      ppr sty binder],
 632               ppCat [ppStr "Binder's type:", ppr sty (getIdUniType binder)],
 633               ppCat [ppStr "Rhs type:", ppr sty ty]
 634              ]
 635
 636 mkRhsPrimMsg :: Id -> PlainCoreExpr -> ErrMsg
 637 mkRhsPrimMsg binder rhs sty
 638   = ppAboves [ppCat [ppStr "The type of this binder is primitive:",
 639                      ppr sty binder],
 640               ppCat [ppStr "Binder's type:", ppr sty (getIdUniType binder)]
 641              ]
 642
 643 mkTyAppMsg :: PlainCoreExpr -> ErrMsg
 644 mkTyAppMsg expr sty
 645   = ppAboves [ppStr "In a type application, either the function's type doesn't match",
 646               ppStr "the argument types, or an argument type is primitive:",
 647               pp_expr sty expr]
 648
 649 mkSpecTyAppMsg :: PlainCoreExpr -> ErrMsg
 650 mkSpecTyAppMsg expr sty
 651   = ppAbove (ppStr "Unboxed types in a type application (after specialisation):")
 652             (pp_expr sty expr)
 653
 654 pp_expr sty expr
 655   = pprCoreExpr sty pprBigCoreBinder pprTypedCoreBinder pprTypedCoreBinder expr
 656 \end{code}