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