compiler/rename/RnSource.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[RnSource]{Main pass of renamer}
   5
   6 \begin{code}
   7 {-# OPTIONS -w #-}
   8 -- The above warning supression flag is a temporary kludge.
   9 -- While working on this module you are encouraged to remove it and fix
  10 -- any warnings in the module. See
  11 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  12 -- for details
  13
  14 module RnSource (
  15         rnSrcDecls, addTcgDUs,
  16         rnTyClDecls,
  17         rnSplice, checkTH
  18     ) where
  19
  20 #include "HsVersions.h"
  21
  22 import {-# SOURCE #-} RnExpr( rnLExpr )
  23
  24 import HsSyn
  25 import RdrName          ( RdrName, isRdrDataCon, elemLocalRdrEnv,
  26                           globalRdrEnvElts, GlobalRdrElt(..), isLocalGRE, rdrNameOcc )
  27 import RdrHsSyn         ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
  28 import RnHsSyn
  29 import RnTypes          ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
  30 import RnBinds          ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn,
  31                                 makeMiniFixityEnv)
  32 import RnEnv            ( lookupLocalDataTcNames,
  33                           lookupLocatedTopBndrRn, lookupLocatedOccRn,
  34                           lookupOccRn, newLocalsRn,
  35                           bindLocatedLocalsFV, bindPatSigTyVarsFV,
  36                           bindTyVarsRn, extendTyVarEnvFVRn,
  37                           bindLocalNames, checkDupNames, mapFvRn, lookupGreLocalRn,
  38                         )
  39 import RnNames       (importsFromLocalDecls, extendRdrEnvRn)
  40 import HscTypes      (GenAvailInfo(..))
  41 import RnHsDoc          ( rnHsDoc, rnMbLHsDoc )
  42 import TcRnMonad
  43
  44 import HscTypes         ( FixityEnv, FixItem(..), Deprecations(..), plusDeprecs )
  45 import Class            ( FunDep )
  46 import Name             ( Name, nameOccName )
  47 import NameSet
  48 import NameEnv
  49 import UniqFM
  50 import OccName
  51 import Outputable
  52 import SrcLoc           ( Located(..), unLoc, noLoc )
  53 import DynFlags ( DynFlag(..) )
  54 import Maybes           ( seqMaybe )
  55 import Maybe            ( isNothing )
  56 import Monad            ( liftM, when )
  57 import BasicTypes       ( Boxity(..) )
  58
  59 import ListSetOps    (findDupsEq, mkLookupFun)
  60 \end{code}
  61
  62 @rnSourceDecl@ `renames' declarations.
  63 It simultaneously performs dependency analysis and precedence parsing.
  64 It also does the following error checks:
  65 \begin{enumerate}
  66 \item
  67 Checks that tyvars are used properly. This includes checking
  68 for undefined tyvars, and tyvars in contexts that are ambiguous.
  69 (Some of this checking has now been moved to module @TcMonoType@,
  70 since we don't have functional dependency information at this point.)
  71 \item
  72 Checks that all variable occurences are defined.
  73 \item
  74 Checks the @(..)@ etc constraints in the export list.
  75 \end{enumerate}
  76
  77
  78 \begin{code}
  79 -- brings the binders of the group into scope in the appropriate places;
  80 -- does NOT assume that anything is in scope already
  81 --
  82 -- the Bool determines whether (True) names in the group shadow existing
  83 -- Unquals in the global environment (used in Template Haskell) or
  84 -- (False) whether duplicates are reported as an error
  85 rnSrcDecls :: Bool -> HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
  86
  87 rnSrcDecls shadowP group@(HsGroup {hs_valds  = val_decls,
  88                                    hs_tyclds = tycl_decls,
  89                                    hs_instds = inst_decls,
  90                                    hs_derivds = deriv_decls,
  91                                    hs_fixds  = fix_decls,
  92                                    hs_depds  = deprec_decls,
  93                                    hs_fords  = foreign_decls,
  94                                    hs_defds  = default_decls,
  95                                    hs_ruleds = rule_decls,
  96                                    hs_docs   = docs })
  97  = do {
  98    -- (A) Process the fixity declarations, creating a mapping from
  99    --     FastStrings to FixItems.
 100    --     Also checks for duplcates.
 101    local_fix_env <- makeMiniFixityEnv fix_decls;
 102
 103    -- (B) Bring top level binders (and their fixities) into scope,
 104    --     except for the value bindings, which get brought in below.
 105    inNewEnv (importsFromLocalDecls shadowP group local_fix_env) $ \ tcg_env -> do {
 106
 107    failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
 108
 109    -- (C) Extract the mapping from data constructors to field names and
 110    --     extend the record field env.
 111    --     This depends on the data constructors and field names being in
 112    --     scope from (B) above
 113    inNewEnv (extendRecordFieldEnv tycl_decls) $ \ tcg_env -> do {
 114
 115    -- (D) Rename the left-hand sides of the value bindings.
 116    --     This depends on everything from (B) being in scope,
 117    --     and on (C) for resolving record wild cards.
 118    --     It uses the fixity env from (A) to bind fixities for view patterns.
 119    new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
 120    -- bind the LHSes (and their fixities) in the global rdr environment
 121    let { lhs_binders = map unLoc $ collectHsValBinders new_lhs;
 122          lhs_avails = map Avail lhs_binders
 123        } ;
 124    inNewEnv (extendRdrEnvRn shadowP (tcg_rdr_env tcg_env, tcg_fix_env tcg_env)
 125                              lhs_avails local_fix_env
 126               >>= \ (new_rdr_env, new_fix_env) ->
 127                          return (tcg_env { tcg_rdr_env = new_rdr_env,
 128                                            tcg_fix_env = new_fix_env
 129                                          })) $ \tcg_env -> do {
 130
 131    --  Now everything is in scope, as the remaining renaming assumes.
 132
 133    -- (E) Rename type and class decls
 134    --     (note that value LHSes need to be in scope for default methods)
 135    --
 136    -- You might think that we could build proper def/use information
 137    -- for type and class declarations, but they can be involved
 138    -- in mutual recursion across modules, and we only do the SCC
 139    -- analysis for them in the type checker.
 140    -- So we content ourselves with gathering uses only; that
 141    -- means we'll only report a declaration as unused if it isn't
 142    -- mentioned at all.  Ah well.
 143    traceRn (text "Start rnTyClDecls") ;
 144    (rn_tycl_decls, src_fvs1) <- rnList rnTyClDecl tycl_decls ;
 145
 146    -- (F) Rename Value declarations right-hand sides
 147    traceRn (text "Start rnmono") ;
 148    (rn_val_decls, bind_dus) <- rnTopBindsRHS lhs_binders new_lhs ;
 149    traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
 150
 151    -- (G) Rename Fixity and deprecations
 152
 153    -- rename fixity declarations and error if we try to
 154    -- fix something from another module (duplicates were checked in (A))
 155    rn_fix_decls                 <- rnSrcFixityDecls fix_decls ;
 156    -- rename deprec decls;
 157    -- check for duplicates and ensure that deprecated things are defined locally
 158    -- at the moment, we don't keep these around past renaming
 159    rn_deprecs <- rnSrcDeprecDecls deprec_decls ;
 160
 161    -- (H) Rename Everything else
 162
 163    (rn_inst_decls,    src_fvs2) <- rnList rnSrcInstDecl   inst_decls ;
 164    (rn_rule_decls,    src_fvs3) <- rnList rnHsRuleDecl    rule_decls ;
 165    (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ;
 166    (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl   default_decls ;
 167    (rn_deriv_decls,   src_fvs6) <- rnList rnSrcDerivDecl  deriv_decls ;
 168       -- Haddock docs; no free vars
 169    rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
 170
 171    -- (I) Compute the results and return
 172    let {rn_group = HsGroup { hs_valds  = rn_val_decls,
 173                                 hs_tyclds = rn_tycl_decls,
 174                                 hs_instds = rn_inst_decls,
 175                              hs_derivds = rn_deriv_decls,
 176                                 hs_fixds  = rn_fix_decls,
 177                                 hs_depds  = [], -- deprecs are returned in the tcg_env (see below)
 178                                              -- not in the HsGroup
 179                                 hs_fords  = rn_foreign_decls,
 180                                 hs_defds  = rn_default_decls,
 181                                 hs_ruleds = rn_rule_decls,
 182                              hs_docs   = rn_docs } ;
 183
 184         other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs6, src_fvs3,
 185                              src_fvs4, src_fvs5] ;
 186         src_dus = bind_dus `plusDU` usesOnly other_fvs;
 187                 -- Note: src_dus will contain *uses* for locally-defined types
 188                 -- and classes, but no *defs* for them.  (Because rnTyClDecl
 189                 -- returns only the uses.)  This is a little
 190                 -- surprising but it doesn't actually matter at all.
 191
 192        final_tcg_env = let tcg_env' = (tcg_env `addTcgDUs` src_dus)
 193                        in -- we return the deprecs in the env, not in the HsGroup above
 194                          tcg_env' { tcg_deprecs = tcg_deprecs tcg_env' `plusDeprecs` rn_deprecs };
 195        } ;
 196
 197    traceRn (text "finish rnSrc" <+> ppr rn_group) ;
 198    traceRn (text "finish Dus" <+> ppr src_dus ) ;
 199    return (final_tcg_env , rn_group)
 200                     }}}}
 201
 202 -- some utils because we do this a bunch above
 203 -- compute and install the new env
 204 inNewEnv :: TcM TcGblEnv -> (TcGblEnv -> TcM a) -> TcM a
 205 inNewEnv env cont = do e <- env
 206                        setGblEnv e $ cont e
 207
 208 rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name]
 209 -- Used for external core
 210 rnTyClDecls tycl_decls = do  (decls', fvs) <- rnList rnTyClDecl tycl_decls
 211                              return decls'
 212
 213 addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
 214 addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
 215
 216 rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)
 217 rnList f xs = mapFvRn (wrapLocFstM f) xs
 218 \end{code}
 219
 220
 221 %*********************************************************
 222 %*                                                       *
 223         HsDoc stuff
 224 %*                                                       *
 225 %*********************************************************
 226
 227 \begin{code}
 228 rnDocDecl :: DocDecl RdrName -> RnM (DocDecl Name)
 229 rnDocDecl (DocCommentNext doc) = do
 230   rn_doc <- rnHsDoc doc
 231   return (DocCommentNext rn_doc)
 232 rnDocDecl (DocCommentPrev doc) = do
 233   rn_doc <- rnHsDoc doc
 234   return (DocCommentPrev rn_doc)
 235 rnDocDecl (DocCommentNamed str doc) = do
 236   rn_doc <- rnHsDoc doc
 237   return (DocCommentNamed str rn_doc)
 238 rnDocDecl (DocGroup lev doc) = do
 239   rn_doc <- rnHsDoc doc
 240   return (DocGroup lev rn_doc)
 241 \end{code}
 242
 243
 244 %*********************************************************
 245 %*                                                       *
 246         Source-code fixity declarations
 247 %*                                                       *
 248 %*********************************************************
 249
 250 \begin{code}
 251 rnSrcFixityDecls :: [LFixitySig RdrName] -> RnM [LFixitySig Name]
 252 -- Rename the fixity decls, so we can put
 253 -- the renamed decls in the renamed syntax tree
 254 -- Errors if the thing being fixed is not defined locally.
 255 rnSrcFixityDecls fix_decls
 256   = do fix_decls <- mapM rn_decl fix_decls
 257        return (concat fix_decls)
 258   where
 259     rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name]
 260         -- GHC extension: look up both the tycon and data con
 261         -- for con-like things; hence returning a list
 262         -- If neither are in scope, report an error; otherwise
 263         -- add both to the fixity env
 264     rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity))
 265       = setSrcSpan name_loc $
 266                     -- this lookup will fail if the definition isn't local
 267         do names <- lookupLocalDataTcNames rdr_name
 268            return [ L loc (FixitySig (L name_loc name) fixity)
 269                     | name <- names ]
 270 \end{code}
 271
 272
 273 %*********************************************************
 274 %*                                                       *
 275         Source-code deprecations declarations
 276 %*                                                       *
 277 %*********************************************************
 278
 279 Check that the deprecated names are defined, are defined locally, and
 280 that there are no duplicate deprecations.
 281
 282 It's only imported deprecations, dealt with in RnIfaces, that we
 283 gather them together.
 284
 285 \begin{code}
 286 -- checks that the deprecations are defined locally, and that there are no duplicates
 287 rnSrcDeprecDecls :: [LDeprecDecl RdrName] -> RnM Deprecations
 288 rnSrcDeprecDecls []
 289   = returnM NoDeprecs
 290
 291 rnSrcDeprecDecls decls
 292   = do { -- check for duplicates
 293        ; mappM_ (\ (lrdr:lrdr':_) -> addLocErr lrdr (dupDeprecDecl lrdr')) deprec_rdr_dups
 294        ; mappM (addLocM rn_deprec) decls        `thenM` \ pairs_s ->
 295          returnM (DeprecSome ((concat pairs_s))) }
 296  where
 297    rn_deprec (Deprecation rdr_name txt)
 298        -- ensures that the names are defined locally
 299      = lookupLocalDataTcNames rdr_name  `thenM` \ names ->
 300        returnM [(nameOccName name, txt) | name <- names]
 301
 302    -- look for duplicates among the OccNames;
 303    -- we check that the names are defined above
 304    -- invt: the lists returned by findDupsEq always have at least two elements
 305    deprec_rdr_dups = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
 306                      (map (\ (L loc (Deprecation rdr_name _)) -> L loc rdr_name) decls)
 307
 308 dupDeprecDecl (L loc _) rdr_name
 309   = vcat [ptext SLIT("Multiple deprecation declarations for") <+> quotes (ppr rdr_name),
 310           ptext SLIT("also at ") <+> ppr loc]
 311
 312 \end{code}
 313
 314 %*********************************************************
 315 %*                                                      *
 316 \subsection{Source code declarations}
 317 %*                                                      *
 318 %*********************************************************
 319
 320 \begin{code}
 321 rnDefaultDecl (DefaultDecl tys)
 322   = mapFvRn (rnHsTypeFVs doc_str) tys   `thenM` \ (tys', fvs) ->
 323     returnM (DefaultDecl tys', fvs)
 324   where
 325     doc_str = text "In a `default' declaration"
 326 \end{code}
 327
 328 %*********************************************************
 329 %*                                                      *
 330 \subsection{Foreign declarations}
 331 %*                                                      *
 332 %*********************************************************
 333
 334 \begin{code}
 335 rnHsForeignDecl (ForeignImport name ty spec)
 336   = lookupLocatedTopBndrRn name         `thenM` \ name' ->
 337     rnHsTypeFVs (fo_decl_msg name) ty   `thenM` \ (ty', fvs) ->
 338     returnM (ForeignImport name' ty' spec, fvs)
 339
 340 rnHsForeignDecl (ForeignExport name ty spec)
 341   = lookupLocatedOccRn name             `thenM` \ name' ->
 342     rnHsTypeFVs (fo_decl_msg name) ty   `thenM` \ (ty', fvs) ->
 343     returnM (ForeignExport name' ty' spec, fvs `addOneFV` unLoc name')
 344         -- NB: a foreign export is an *occurrence site* for name, so
 345         --     we add it to the free-variable list.  It might, for example,
 346         --     be imported from another module
 347
 348 fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name
 349 \end{code}
 350
 351
 352 %*********************************************************
 353 %*                                                      *
 354 \subsection{Instance declarations}
 355 %*                                                      *
 356 %*********************************************************
 357
 358 \begin{code}
 359 rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
 360         -- Used for both source and interface file decls
 361   = rnHsSigType (text "an instance decl") inst_ty       `thenM` \ inst_ty' ->
 362
 363         -- Rename the associated types
 364         -- The typechecker (not the renamer) checks that all
 365         -- the declarations are for the right class
 366     let
 367         at_doc   = text "In the associated types of an instance declaration"
 368         at_names = map (head . tyClDeclNames . unLoc) ats
 369     in
 370     checkDupNames at_doc at_names               `thenM_`
 371     rnATInsts ats                               `thenM` \ (ats', at_fvs) ->
 372
 373         -- Rename the bindings
 374         -- The typechecker (not the renamer) checks that all
 375         -- the bindings are for the right class
 376     let
 377         meth_doc    = text "In the bindings in an instance declaration"
 378         meth_names  = collectHsBindLocatedBinders mbinds
 379         (inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
 380     in
 381     checkDupNames meth_doc meth_names   `thenM_`
 382     extendTyVarEnvForMethodBinds inst_tyvars (
 383         -- (Slightly strangely) the forall-d tyvars scope over
 384         -- the method bindings too
 385         rnMethodBinds cls (\n->[])      -- No scoped tyvars
 386                       [] mbinds
 387     )                                           `thenM` \ (mbinds', meth_fvs) ->
 388         -- Rename the prags and signatures.
 389         -- Note that the type variables are not in scope here,
 390         -- so that      instance Eq a => Eq (T a) where
 391         --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
 392         -- works OK.
 393         --
 394         -- But the (unqualified) method names are in scope
 395     let
 396         binders = collectHsBindBinders mbinds'
 397         ok_sig  = okInstDclSig (mkNameSet binders)
 398     in
 399     bindLocalNames binders (renameSigs ok_sig uprags)   `thenM` \ uprags' ->
 400
 401     returnM (InstDecl inst_ty' mbinds' uprags' ats',
 402              meth_fvs `plusFV` at_fvs
 403                       `plusFV` hsSigsFVs uprags'
 404                       `plusFV` extractHsTyNames inst_ty')
 405              -- We return the renamed associated data type declarations so
 406              -- that they can be entered into the list of type declarations
 407              -- for the binding group, but we also keep a copy in the instance.
 408              -- The latter is needed for well-formedness checks in the type
 409              -- checker (eg, to ensure that all ATs of the instance actually
 410              -- receive a declaration).
 411              -- NB: Even the copies in the instance declaration carry copies of
 412              --     the instance context after renaming.  This is a bit
 413              --     strange, but should not matter (and it would be more work
 414              --     to remove the context).
 415 \end{code}
 416
 417 Renaming of the associated types in instances.
 418
 419 \begin{code}
 420 rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
 421 rnATInsts atDecls = rnList rnATInst atDecls
 422   where
 423     rnATInst tydecl@TyData     {} = rnTyClDecl tydecl
 424     rnATInst tydecl@TySynonym  {} = rnTyClDecl tydecl
 425     rnATInst tydecl               =
 426       pprPanic "RnSource.rnATInsts: invalid AT instance"
 427                (ppr (tcdName tydecl))
 428 \end{code}
 429
 430 For the method bindings in class and instance decls, we extend the
 431 type variable environment iff -fglasgow-exts
 432
 433 \begin{code}
 434 extendTyVarEnvForMethodBinds tyvars thing_inside
 435   = do  { scoped_tvs <- doptM Opt_ScopedTypeVariables
 436         ; if scoped_tvs then
 437                 extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
 438           else
 439                 thing_inside }
 440 \end{code}
 441
 442 %*********************************************************
 443 %*                                                      *
 444 \subsection{Stand-alone deriving declarations}
 445 %*                                                      *
 446 %*********************************************************
 447
 448 \begin{code}
 449 rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
 450 rnSrcDerivDecl (DerivDecl ty)
 451   = do ty' <- rnLHsType (text "a deriving decl") ty
 452        let fvs = extractHsTyNames ty'
 453        return (DerivDecl ty', fvs)
 454 \end{code}
 455
 456 %*********************************************************
 457 %*                                                      *
 458 \subsection{Rules}
 459 %*                                                      *
 460 %*********************************************************
 461
 462 \begin{code}
 463 rnHsRuleDecl (HsRule rule_name act vars lhs fv_lhs rhs fv_rhs)
 464   = bindPatSigTyVarsFV (collectRuleBndrSigTys vars)     $
 465
 466     bindLocatedLocalsFV doc (map get_var vars)          $ \ ids ->
 467     mapFvRn rn_var (vars `zip` ids)             `thenM` \ (vars', fv_vars) ->
 468
 469     rnLExpr lhs                                 `thenM` \ (lhs', fv_lhs') ->
 470     rnLExpr rhs                                 `thenM` \ (rhs', fv_rhs') ->
 471
 472     checkValidRule rule_name ids lhs' fv_lhs'   `thenM_`
 473
 474     returnM (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
 475              fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs')
 476   where
 477     doc = text "In the transformation rule" <+> ftext rule_name
 478
 479     get_var (RuleBndr v)      = v
 480     get_var (RuleBndrSig v _) = v
 481
 482     rn_var (RuleBndr (L loc v), id)
 483         = returnM (RuleBndr (L loc id), emptyFVs)
 484     rn_var (RuleBndrSig (L loc v) t, id)
 485         = rnHsTypeFVs doc t     `thenM` \ (t', fvs) ->
 486           returnM (RuleBndrSig (L loc id) t', fvs)
 487
 488 badRuleVar name var
 489   = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon,
 490          ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
 491                 ptext SLIT("does not appear on left hand side")]
 492 \end{code}
 493
 494 Note [Rule LHS validity checking]
 495 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 496 Check the shape of a transformation rule LHS.  Currently we only allow
 497 LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
 498 @forall@'d variables.
 499
 500 We used restrict the form of the 'ei' to prevent you writing rules
 501 with LHSs with a complicated desugaring (and hence unlikely to match);
 502 (e.g. a case expression is not allowed: too elaborate.)
 503
 504 But there are legitimate non-trivial args ei, like sections and
 505 lambdas.  So it seems simmpler not to check at all, and that is why
 506 check_e is commented out.
 507
 508 \begin{code}
 509 checkValidRule rule_name ids lhs' fv_lhs'
 510   = do  {       -- Check for the form of the LHS
 511           case (validRuleLhs ids lhs') of
 512                 Nothing  -> return ()
 513                 Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
 514
 515                 -- Check that LHS vars are all bound
 516         ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
 517         ; mappM (addErr . badRuleVar rule_name) bad_vars }
 518
 519 validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
 520 -- Nothing => OK
 521 -- Just e  => Not ok, and e is the offending expression
 522 validRuleLhs foralls lhs
 523   = checkl lhs
 524   where
 525     checkl (L loc e) = check e
 526
 527     check (OpApp e1 op _ e2)              = checkl op `seqMaybe` checkl_e e1 `seqMaybe` checkl_e e2
 528     check (HsApp e1 e2)                   = checkl e1 `seqMaybe` checkl_e e2
 529     check (HsVar v) | v `notElem` foralls = Nothing
 530     check other                           = Just other  -- Failure
 531
 532         -- Check an argument
 533     checkl_e (L loc e) = Nothing        -- Was (check_e e); see Note [Rule LHS validity checking]
 534
 535 {-      Commented out; see Note [Rule LHS validity checking] above
 536     check_e (HsVar v)     = Nothing
 537     check_e (HsPar e)     = checkl_e e
 538     check_e (HsLit e)     = Nothing
 539     check_e (HsOverLit e) = Nothing
 540
 541     check_e (OpApp e1 op _ e2)   = checkl_e e1 `seqMaybe` checkl_e op `seqMaybe` checkl_e e2
 542     check_e (HsApp e1 e2)        = checkl_e e1 `seqMaybe` checkl_e e2
 543     check_e (NegApp e _)         = checkl_e e
 544     check_e (ExplicitList _ es)  = checkl_es es
 545     check_e (ExplicitTuple es _) = checkl_es es
 546     check_e other                = Just other   -- Fails
 547
 548     checkl_es es = foldr (seqMaybe . checkl_e) Nothing es
 549 -}
 550
 551 badRuleLhsErr name lhs bad_e
 552   = sep [ptext SLIT("Rule") <+> ftext name <> colon,
 553          nest 4 (vcat [ptext SLIT("Illegal expression:") <+> ppr bad_e,
 554                        ptext SLIT("in left-hand side:") <+> ppr lhs])]
 555     $$
 556     ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
 557 \end{code}
 558
 559
 560 %*********************************************************
 561 %*                                                      *
 562 \subsection{Type, class and iface sig declarations}
 563 %*                                                      *
 564 %*********************************************************
 565
 566 @rnTyDecl@ uses the `global name function' to create a new type
 567 declaration in which local names have been replaced by their original
 568 names, reporting any unknown names.
 569
 570 Renaming type variables is a pain. Because they now contain uniques,
 571 it is necessary to pass in an association list which maps a parsed
 572 tyvar to its @Name@ representation.
 573 In some cases (type signatures of values),
 574 it is even necessary to go over the type first
 575 in order to get the set of tyvars used by it, make an assoc list,
 576 and then go over it again to rename the tyvars!
 577 However, we can also do some scoping checks at the same time.
 578
 579 \begin{code}
 580 rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_name})
 581   = lookupLocatedTopBndrRn name         `thenM` \ name' ->
 582     returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
 583              emptyFVs)
 584
 585 -- all flavours of type family declarations ("type family", "newtype fanily",
 586 -- and "data family")
 587 rnTyClDecl (tydecl@TyFamily {}) =
 588   rnFamily tydecl bindTyVarsRn
 589
 590 -- "data", "newtype", "data instance, and "newtype instance" declarations
 591 rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 592                            tcdLName = tycon, tcdTyVars = tyvars,
 593                            tcdTyPats = typatsMaybe, tcdCons = condecls,
 594                            tcdKindSig = sig, tcdDerivs = derivs})
 595   | is_vanilla            -- Normal Haskell data type decl
 596   = ASSERT( isNothing sig )     -- In normal H98 form, kind signature on the
 597                                 -- data type is syntactically illegal
 598     bindTyVarsRn data_doc tyvars                $ \ tyvars' ->
 599     do  { tycon' <- if isFamInstDecl tydecl
 600                     then lookupLocatedOccRn     tycon -- may be imported family
 601                     else lookupLocatedTopBndrRn tycon
 602         ; context' <- rnContext data_doc context
 603         ; typats' <- rnTyPats data_doc typatsMaybe
 604         ; (derivs', deriv_fvs) <- rn_derivs derivs
 605         ; checkDupNames data_doc con_names
 606         ; condecls' <- rnConDecls (unLoc tycon') condecls
 607         ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context',
 608                            tcdLName = tycon', tcdTyVars = tyvars',
 609                            tcdTyPats = typats', tcdKindSig = Nothing,
 610                            tcdCons = condecls', tcdDerivs = derivs'},
 611                    delFVs (map hsLTyVarName tyvars')    $
 612                    extractHsCtxtTyNames context'        `plusFV`
 613                    plusFVs (map conDeclFVs condecls')   `plusFV`
 614                    deriv_fvs                            `plusFV`
 615                    (if isFamInstDecl tydecl
 616                    then unitFV (unLoc tycon')   -- type instance => use
 617                    else emptyFVs))
 618         }
 619
 620   | otherwise             -- GADT
 621   = ASSERT( none typatsMaybe )    -- GADTs cannot have type patterns for now
 622     do  { tycon' <- if isFamInstDecl tydecl
 623                     then lookupLocatedOccRn     tycon -- may be imported family
 624                     else lookupLocatedTopBndrRn tycon
 625         ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
 626         ; tyvars' <- bindTyVarsRn data_doc tyvars
 627                                   (\ tyvars' -> return tyvars')
 628                 -- For GADTs, the type variables in the declaration
 629                 -- do not scope over the constructor signatures
 630                 --      data T a where { T1 :: forall b. b-> b }
 631         ; (derivs', deriv_fvs) <- rn_derivs derivs
 632         ; checkDupNames data_doc con_names
 633         ; condecls' <- rnConDecls (unLoc tycon') condecls
 634         ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [],
 635                            tcdLName = tycon', tcdTyVars = tyvars',
 636                            tcdTyPats = Nothing, tcdKindSig = sig,
 637                            tcdCons = condecls', tcdDerivs = derivs'},
 638                    plusFVs (map conDeclFVs condecls') `plusFV`
 639                    deriv_fvs                          `plusFV`
 640                    (if isFamInstDecl tydecl
 641                    then unitFV (unLoc tycon')   -- type instance => use
 642                    else emptyFVs))
 643         }
 644   where
 645     is_vanilla = case condecls of       -- Yuk
 646                      []                    -> True
 647                      L _ (ConDecl { con_res = ResTyH98 }) : _  -> True
 648                      other                 -> False
 649
 650     none Nothing   = True
 651     none (Just []) = True
 652     none _         = False
 653
 654     data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
 655     con_names = map con_names_helper condecls
 656
 657     con_names_helper (L _ c) = con_name c
 658
 659     rn_derivs Nothing   = returnM (Nothing, emptyFVs)
 660     rn_derivs (Just ds) = rnLHsTypes data_doc ds        `thenM` \ ds' ->
 661                           returnM (Just ds', extractHsTyNames_s ds')
 662
 663 -- "type" and "type instance" declarations
 664 rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
 665                               tcdTyPats = typatsMaybe, tcdSynRhs = ty})
 666   = bindTyVarsRn syn_doc tyvars                 $ \ tyvars' ->
 667     do { name' <- if isFamInstDecl tydecl
 668                   then lookupLocatedOccRn     name -- may be imported family
 669                   else lookupLocatedTopBndrRn name
 670        ; typats' <- rnTyPats syn_doc typatsMaybe
 671        ; (ty', fvs) <- rnHsTypeFVs syn_doc ty
 672        ; returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars',
 673                              tcdTyPats = typats', tcdSynRhs = ty'},
 674                   delFVs (map hsLTyVarName tyvars') $
 675                   fvs                         `plusFV`
 676                    (if isFamInstDecl tydecl
 677                    then unitFV (unLoc name')    -- type instance => use
 678                    else emptyFVs))
 679        }
 680   where
 681     syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
 682
 683 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
 684                        tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
 685                        tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs})
 686   = do  { cname' <- lookupLocatedTopBndrRn cname
 687
 688         -- Tyvars scope over superclass context and method signatures
 689         ; (tyvars', context', fds', ats', ats_fvs, sigs')
 690             <- bindTyVarsRn cls_doc tyvars $ \ tyvars' -> do
 691              { context' <- rnContext cls_doc context
 692              ; fds' <- rnFds cls_doc fds
 693              ; (ats', ats_fvs) <- rnATs ats
 694              ; sigs' <- renameSigs okClsDclSig sigs
 695              ; return   (tyvars', context', fds', ats', ats_fvs, sigs') }
 696
 697         -- Check for duplicates among the associated types
 698         ; let at_rdr_names_w_locs = [tcdLName ty | L _ ty <- ats]
 699         ; checkDupNames at_doc at_rdr_names_w_locs
 700
 701         -- Check the signatures
 702         -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
 703         ; let sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs]
 704         ; checkDupNames sig_doc sig_rdr_names_w_locs
 705                 -- Typechecker is responsible for checking that we only
 706                 -- give default-method bindings for things in this class.
 707                 -- The renamer *could* check this for class decls, but can't
 708                 -- for instance decls.
 709
 710         -- The newLocals call is tiresome: given a generic class decl
 711         --      class C a where
 712         --        op :: a -> a
 713         --        op {| x+y |} (Inl a) = ...
 714         --        op {| x+y |} (Inr b) = ...
 715         --        op {| a*b |} (a*b)   = ...
 716         -- we want to name both "x" tyvars with the same unique, so that they are
 717         -- easy to group together in the typechecker.
 718         ; (mbinds', meth_fvs)
 719             <- extendTyVarEnvForMethodBinds tyvars' $ do
 720             { name_env <- getLocalRdrEnv
 721             ; let meth_rdr_names_w_locs = collectHsBindLocatedBinders mbinds
 722                   gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds,
 723                                                  not (unLoc tv `elemLocalRdrEnv` name_env) ]
 724             ; checkDupNames meth_doc meth_rdr_names_w_locs
 725             ; gen_tyvars <- newLocalsRn gen_rdr_tyvars_w_locs
 726             ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds }
 727
 728   -- Haddock docs
 729         ; docs' <- mapM (wrapLocM rnDocDecl) docs
 730
 731         ; return (ClassDecl { tcdCtxt = context', tcdLName = cname',
 732                               tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
 733                               tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'},
 734
 735                   delFVs (map hsLTyVarName tyvars')     $
 736                   extractHsCtxtTyNames context'         `plusFV`
 737                   plusFVs (map extractFunDepNames (map unLoc fds'))  `plusFV`
 738                   hsSigsFVs sigs'                       `plusFV`
 739                   meth_fvs                              `plusFV`
 740                   ats_fvs) }
 741   where
 742     meth_doc = text "In the default-methods for class"  <+> ppr cname
 743     cls_doc  = text "In the declaration for class"      <+> ppr cname
 744     sig_doc  = text "In the signatures for class"       <+> ppr cname
 745     at_doc   = text "In the associated types for class" <+> ppr cname
 746
 747 badGadtStupidTheta tycon
 748   = vcat [ptext SLIT("No context is allowed on a GADT-style data declaration"),
 749           ptext SLIT("(You can put a context on each contructor, though.)")]
 750 \end{code}
 751
 752 %*********************************************************
 753 %*                                                      *
 754 \subsection{Support code for type/data declarations}
 755 %*                                                      *
 756 %*********************************************************
 757
 758 \begin{code}
 759 -- Although, we are processing type patterns here, all type variables will
 760 -- already be in scope (they are the same as in the 'tcdTyVars' field of the
 761 -- type declaration to which these patterns belong)
 762 --
 763 rnTyPats :: SDoc -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name])
 764 rnTyPats _   Nothing       = return Nothing
 765 rnTyPats doc (Just typats) = liftM Just $ rnLHsTypes doc typats
 766
 767 rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
 768 rnConDecls tycon condecls
 769   = mappM (wrapLocM rnConDecl) condecls
 770
 771 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
 772 rnConDecl (ConDecl name expl tvs cxt details res_ty mb_doc)
 773   = do  { addLocM checkConName name
 774
 775         ; new_name <- lookupLocatedTopBndrRn name
 776         ; name_env <- getLocalRdrEnv
 777
 778         -- For H98 syntax, the tvs are the existential ones
 779         -- For GADT syntax, the tvs are all the quantified tyvars
 780         -- Hence the 'filter' in the ResTyH98 case only
 781         ; let not_in_scope  = not . (`elemLocalRdrEnv` name_env) . unLoc
 782               arg_tys       = hsConDeclArgTys details
 783               implicit_tvs  = case res_ty of
 784                                 ResTyH98 -> filter not_in_scope $
 785                                                 get_rdr_tvs arg_tys
 786                                 ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
 787               tvs' = case expl of
 788                         Explicit -> tvs
 789                         Implicit -> userHsTyVarBndrs implicit_tvs
 790
 791         ; mb_doc' <- rnMbLHsDoc mb_doc
 792
 793         ; bindTyVarsRn doc tvs' $ \new_tyvars -> do
 794         { new_context <- rnContext doc cxt
 795         ; new_details <- rnConDeclDetails doc details
 796         ; (new_details', new_res_ty)  <- rnConResult doc new_details res_ty
 797         ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty mb_doc') }}
 798  where
 799     doc = text "In the definition of data constructor" <+> quotes (ppr name)
 800     get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
 801
 802 rnConResult _ details ResTyH98 = return (details, ResTyH98)
 803
 804 rnConResult doc details (ResTyGADT ty) = do
 805     ty' <- rnHsSigType doc ty
 806     let (arg_tys, res_ty) = splitHsFunType ty'
 807         -- We can split it up, now the renamer has dealt with fixities
 808     case details of
 809         PrefixCon _xs -> ASSERT( null _xs ) return (PrefixCon arg_tys, ResTyGADT res_ty)
 810         RecCon fields -> return (details, ResTyGADT ty')
 811         InfixCon {}   -> panic "rnConResult"
 812
 813 rnConDeclDetails doc (PrefixCon tys)
 814   = mappM (rnLHsType doc) tys   `thenM` \ new_tys  ->
 815     returnM (PrefixCon new_tys)
 816
 817 rnConDeclDetails doc (InfixCon ty1 ty2)
 818   = rnLHsType doc ty1           `thenM` \ new_ty1 ->
 819     rnLHsType doc ty2           `thenM` \ new_ty2 ->
 820     returnM (InfixCon new_ty1 new_ty2)
 821
 822 rnConDeclDetails doc (RecCon fields)
 823   = do  { checkDupNames doc (map cd_fld_name fields)
 824         ; new_fields <- mappM (rnField doc) fields
 825         ; return (RecCon new_fields) }
 826
 827 rnField doc (ConDeclField name ty haddock_doc)
 828   = lookupLocatedTopBndrRn name `thenM` \ new_name ->
 829     rnLHsType doc ty            `thenM` \ new_ty ->
 830     rnMbLHsDoc haddock_doc      `thenM` \ new_haddock_doc ->
 831     returnM (ConDeclField new_name new_ty new_haddock_doc)
 832
 833 -- Rename family declarations
 834 --
 835 -- * This function is parametrised by the routine handling the index
 836 --   variables.  On the toplevel, these are defining occurences, whereas they
 837 --   are usage occurences for associated types.
 838 --
 839 rnFamily :: TyClDecl RdrName
 840          -> (SDoc -> [LHsTyVarBndr RdrName] ->
 841              ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
 842              RnM (TyClDecl Name, FreeVars))
 843          -> RnM (TyClDecl Name, FreeVars)
 844
 845 rnFamily (tydecl@TyFamily {tcdFlavour = flavour,
 846                            tcdLName = tycon, tcdTyVars = tyvars})
 847         bindIdxVars =
 848       do { checkM (isDataFlavour flavour                      -- for synonyms,
 849                    || not (null tyvars)) $ addErr needOneIdx  -- #indexes >= 1
 850          ; bindIdxVars (family_doc tycon) tyvars $ \tyvars' -> do {
 851          ; tycon' <- lookupLocatedTopBndrRn tycon
 852          ; returnM (TyFamily {tcdFlavour = flavour, tcdLName = tycon',
 853                               tcdTyVars = tyvars', tcdKind = tcdKind tydecl},
 854                     emptyFVs)
 855          } }
 856       where
 857         isDataFlavour DataFamily = True
 858         isDataFlavour _          = False
 859
 860 family_doc tycon = text "In the family declaration for" <+> quotes (ppr tycon)
 861 needOneIdx = text "Type family declarations requires at least one type index"
 862
 863 -- Rename associated type declarations (in classes)
 864 --
 865 -- * This can be family declarations and (default) type instances
 866 --
 867 rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
 868 rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
 869   where
 870     rn_at (tydecl@TyFamily  {}) = rnFamily tydecl lookupIdxVars
 871     rn_at (tydecl@TySynonym {}) =
 872       do
 873         checkM (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
 874         rnTyClDecl tydecl
 875     rn_at _                      = panic "RnSource.rnATs: invalid TyClDecl"
 876
 877     lookupIdxVars _ tyvars cont =
 878       do { checkForDups tyvars;
 879          ; tyvars' <- mappM lookupIdxVar tyvars
 880          ; cont tyvars'
 881          }
 882     -- Type index variables must be class parameters, which are the only
 883     -- type variables in scope at this point.
 884     lookupIdxVar (L l tyvar) =
 885       do
 886         name' <- lookupOccRn (hsTyVarName tyvar)
 887         return $ L l (replaceTyVarName tyvar name')
 888
 889     -- Type variable may only occur once.
 890     --
 891     checkForDups [] = return ()
 892     checkForDups (L loc tv:ltvs) =
 893       do { setSrcSpan loc $
 894              when (hsTyVarName tv `ltvElem` ltvs) $
 895                addErr (repeatedTyVar tv)
 896          ; checkForDups ltvs
 897          }
 898
 899     rdrName `ltvElem` [] = False
 900     rdrName `ltvElem` (L _ tv:ltvs)
 901       | rdrName == hsTyVarName tv = True
 902       | otherwise                 = rdrName `ltvElem` ltvs
 903
 904 noPatterns = text "Default definition for an associated synonym cannot have"
 905              <+> text "type pattern"
 906
 907 repeatedTyVar tv = ptext SLIT("Illegal repeated type variable") <+>
 908                    quotes (ppr tv)
 909
 910 -- This data decl will parse OK
 911 --      data T = a Int
 912 -- treating "a" as the constructor.
 913 -- It is really hard to make the parser spot this malformation.
 914 -- So the renamer has to check that the constructor is legal
 915 --
 916 -- We can get an operator as the constructor, even in the prefix form:
 917 --      data T = :% Int Int
 918 -- from interface files, which always print in prefix form
 919
 920 checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
 921
 922 badDataCon name
 923    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 924 \end{code}
 925
 926
 927 %*********************************************************
 928 %*                                                      *
 929 \subsection{Support code for type/data declarations}
 930 %*                                                      *
 931 %*********************************************************
 932
 933 Get the mapping from constructors to fields for this module.
 934 It's convenient to do this after the data type decls have been renamed
 935 \begin{code}
 936 extendRecordFieldEnv :: [LTyClDecl RdrName] -> TcM TcGblEnv
 937 extendRecordFieldEnv decls
 938   = do  { tcg_env <- getGblEnv
 939         ; field_env' <- foldrM get (tcg_field_env tcg_env) decls
 940         ; return (tcg_env { tcg_field_env = field_env' }) }
 941   where
 942     -- we want to lookup:
 943     --  (a) a datatype constructor
 944     --  (b) a record field
 945     -- knowing that they're from this module.
 946     -- lookupLocatedTopBndrRn does this, because it does a lookupGreLocalRn,
 947     -- which keeps only the local ones.
 948     lookup x = do { x' <- lookupLocatedTopBndrRn x
 949                     ; return $ unLoc x'}
 950
 951     get (L _ (TyData { tcdCons = cons })) env = foldrM get_con env cons
 952     get other                        env = return env
 953
 954     get_con (L _ (ConDecl { con_name = con, con_details = RecCon flds })) env
 955         = do { con' <- lookup con
 956             ; flds' <- mappM lookup (map cd_fld_name flds)
 957             ; return $ extendNameEnv env con' flds' }
 958     get_con other env
 959         = return env
 960 \end{code}
 961
 962 %*********************************************************
 963 %*                                                      *
 964 \subsection{Support code to rename types}
 965 %*                                                      *
 966 %*********************************************************
 967
 968 \begin{code}
 969 rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
 970
 971 rnFds doc fds
 972   = mappM (wrapLocM rn_fds) fds
 973   where
 974     rn_fds (tys1, tys2)
 975       = rnHsTyVars doc tys1             `thenM` \ tys1' ->
 976         rnHsTyVars doc tys2             `thenM` \ tys2' ->
 977         returnM (tys1', tys2')
 978
 979 rnHsTyVars doc tvs  = mappM (rnHsTyvar doc) tvs
 980 rnHsTyvar doc tyvar = lookupOccRn tyvar
 981 \end{code}
 982
 983
 984 %*********************************************************
 985 %*                                                      *
 986                 Splices
 987 %*                                                      *
 988 %*********************************************************
 989
 990 Note [Splices]
 991 ~~~~~~~~~~~~~~
 992 Consider
 993         f = ...
 994         h = ...$(thing "f")...
 995
 996 The splice can expand into literally anything, so when we do dependency
 997 analysis we must assume that it might mention 'f'.  So we simply treat
 998 all locally-defined names as mentioned by any splice.  This is terribly
 999 brutal, but I don't see what else to do.  For example, it'll mean
1000 that every locally-defined thing will appear to be used, so no unused-binding
1001 warnings.  But if we miss the dependency, then we might typecheck 'h' before 'f',
1002 and that will crash the type checker because 'f' isn't in scope.
1003
1004 Currently, I'm not treating a splice as also mentioning every import,
1005 which is a bit inconsistent -- but there are a lot of them.  We might
1006 thereby get some bogus unused-import warnings, but we won't crash the
1007 type checker.  Not very satisfactory really.
1008
1009 \begin{code}
1010 rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
1011 rnSplice (HsSplice n expr)
1012   = do  { checkTH expr "splice"
1013         ; loc  <- getSrcSpanM
1014         ; [n'] <- newLocalsRn [L loc n]
1015         ; (expr', fvs) <- rnLExpr expr
1016
1017         -- Ugh!  See Note [Splices] above
1018         ; lcl_rdr <- getLocalRdrEnv
1019         ; gbl_rdr <- getGlobalRdrEnv
1020         ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr,
1021                                                     isLocalGRE gre]
1022               lcl_names = mkNameSet (occEnvElts lcl_rdr)
1023
1024         ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }
1025
1026 #ifdef GHCI
1027 checkTH e what = returnM ()     -- OK
1028 #else
1029 checkTH e what  -- Raise an error in a stage-1 compiler
1030   = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>
1031                   ptext SLIT("illegal in a stage-1 compiler"),
1032                   nest 2 (ppr e)])
1033 #endif
1034 \end{code}