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