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