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