ghc/compiler/coreSyn/CoreLint.lhs

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