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