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         ok_sig  = okInstDclSig (mkNameSet binders)
 431     in
 432     bindLocalNames binders (renameSigs ok_sig uprags)   `thenM` \ uprags' ->
 433
 434     returnM (InstDecl inst_ty' mbinds' uprags' ats',
 435              meth_fvs `plusFV` at_fvs
 436                       `plusFV` hsSigsFVs uprags'
 437                       `plusFV` extractHsTyNames inst_ty')
 438              -- We return the renamed associated data type declarations so
 439              -- that they can be entered into the list of type declarations
 440              -- for the binding group, but we also keep a copy in the instance.
 441              -- The latter is needed for well-formedness checks in the type
 442              -- checker (eg, to ensure that all ATs of the instance actually
 443              -- receive a declaration).
 444              -- NB: Even the copies in the instance declaration carry copies of
 445              --     the instance context after renaming.  This is a bit
 446              --     strange, but should not matter (and it would be more work
 447              --     to remove the context).
 448 \end{code}
 449
 450 Renaming of the associated types in instances.
 451
 452 \begin{code}
 453 rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
 454 rnATInsts atDecls = rnList rnATInst atDecls
 455   where
 456     rnATInst tydecl@TyData     {} = rnTyClDecl tydecl
 457     rnATInst tydecl@TySynonym  {} = rnTyClDecl tydecl
 458     rnATInst tydecl               =
 459       pprPanic "RnSource.rnATInsts: invalid AT instance"
 460                (ppr (tcdName tydecl))
 461 \end{code}
 462
 463 For the method bindings in class and instance decls, we extend the
 464 type variable environment iff -fglasgow-exts
 465
 466 \begin{code}
 467 extendTyVarEnvForMethodBinds :: [LHsTyVarBndr Name]
 468                              -> RnM (Bag (LHsBind Name), FreeVars)
 469                              -> RnM (Bag (LHsBind Name), FreeVars)
 470 extendTyVarEnvForMethodBinds tyvars thing_inside
 471   = do  { scoped_tvs <- doptM Opt_ScopedTypeVariables
 472         ; if scoped_tvs then
 473                 extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
 474           else
 475                 thing_inside }
 476 \end{code}
 477
 478 %*********************************************************
 479 %*                                                      *
 480 \subsection{Stand-alone deriving declarations}
 481 %*                                                      *
 482 %*********************************************************
 483
 484 \begin{code}
 485 rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
 486 rnSrcDerivDecl (DerivDecl ty)
 487   = do ty' <- rnLHsType (text "a deriving decl") ty
 488        let fvs = extractHsTyNames ty'
 489        return (DerivDecl ty', fvs)
 490 \end{code}
 491
 492 %*********************************************************
 493 %*                                                      *
 494 \subsection{Rules}
 495 %*                                                      *
 496 %*********************************************************
 497
 498 \begin{code}
 499 rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
 500 rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
 501   = bindPatSigTyVarsFV (collectRuleBndrSigTys vars)     $
 502
 503     bindLocatedLocalsFV doc (map get_var vars)          $ \ ids ->
 504     mapFvRn rn_var (vars `zip` ids)             `thenM` \ (vars', fv_vars) ->
 505
 506     rnLExpr lhs                                 `thenM` \ (lhs', fv_lhs') ->
 507     rnLExpr rhs                                 `thenM` \ (rhs', fv_rhs') ->
 508
 509     checkValidRule rule_name ids lhs' fv_lhs'   `thenM_`
 510
 511     returnM (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
 512              fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs')
 513   where
 514     doc = text "In the transformation rule" <+> ftext rule_name
 515
 516     get_var (RuleBndr v)      = v
 517     get_var (RuleBndrSig v _) = v
 518
 519     rn_var (RuleBndr (L loc _), id)
 520         = returnM (RuleBndr (L loc id), emptyFVs)
 521     rn_var (RuleBndrSig (L loc _) t, id)
 522         = rnHsTypeFVs doc t     `thenM` \ (t', fvs) ->
 523           returnM (RuleBndrSig (L loc id) t', fvs)
 524
 525 badRuleVar :: FastString -> Name -> SDoc
 526 badRuleVar name var
 527   = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon,
 528          ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+>
 529                 ptext (sLit "does not appear on left hand side")]
 530 \end{code}
 531
 532 Note [Rule LHS validity checking]
 533 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 534 Check the shape of a transformation rule LHS.  Currently we only allow
 535 LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
 536 @forall@'d variables.
 537
 538 We used restrict the form of the 'ei' to prevent you writing rules
 539 with LHSs with a complicated desugaring (and hence unlikely to match);
 540 (e.g. a case expression is not allowed: too elaborate.)
 541
 542 But there are legitimate non-trivial args ei, like sections and
 543 lambdas.  So it seems simmpler not to check at all, and that is why
 544 check_e is commented out.
 545
 546 \begin{code}
 547 checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM [()]
 548 checkValidRule rule_name ids lhs' fv_lhs'
 549   = do  {       -- Check for the form of the LHS
 550           case (validRuleLhs ids lhs') of
 551                 Nothing  -> return ()
 552                 Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
 553
 554                 -- Check that LHS vars are all bound
 555         ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
 556         ; mappM (addErr . badRuleVar rule_name) bad_vars }
 557
 558 validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
 559 -- Nothing => OK
 560 -- Just e  => Not ok, and e is the offending expression
 561 validRuleLhs foralls lhs
 562   = checkl lhs
 563   where
 564     checkl (L _ e) = check e
 565
 566     check (OpApp e1 op _ e2)              = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
 567     check (HsApp e1 e2)                   = checkl e1 `mplus` checkl_e e2
 568     check (HsVar v) | v `notElem` foralls = Nothing
 569     check other                           = Just other  -- Failure
 570
 571         -- Check an argument
 572     checkl_e (L _ _e) = Nothing         -- Was (check_e e); see Note [Rule LHS validity checking]
 573
 574 {-      Commented out; see Note [Rule LHS validity checking] above
 575     check_e (HsVar v)     = Nothing
 576     check_e (HsPar e)     = checkl_e e
 577     check_e (HsLit e)     = Nothing
 578     check_e (HsOverLit e) = Nothing
 579
 580     check_e (OpApp e1 op _ e2)   = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2
 581     check_e (HsApp e1 e2)        = checkl_e e1 `mplus` checkl_e e2
 582     check_e (NegApp e _)         = checkl_e e
 583     check_e (ExplicitList _ es)  = checkl_es es
 584     check_e (ExplicitTuple es _) = checkl_es es
 585     check_e other                = Just other   -- Fails
 586
 587     checkl_es es = foldr (mplus . checkl_e) Nothing es
 588 -}
 589
 590 badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc
 591 badRuleLhsErr name lhs bad_e
 592   = sep [ptext (sLit "Rule") <+> ftext name <> colon,
 593          nest 4 (vcat [ptext (sLit "Illegal expression:") <+> ppr bad_e,
 594                        ptext (sLit "in left-hand side:") <+> ppr lhs])]
 595     $$
 596     ptext (sLit "LHS must be of form (f e1 .. en) where f is not forall'd")
 597 \end{code}
 598
 599
 600 %*********************************************************
 601 %*                                                      *
 602 \subsection{Type, class and iface sig declarations}
 603 %*                                                      *
 604 %*********************************************************
 605
 606 @rnTyDecl@ uses the `global name function' to create a new type
 607 declaration in which local names have been replaced by their original
 608 names, reporting any unknown names.
 609
 610 Renaming type variables is a pain. Because they now contain uniques,
 611 it is necessary to pass in an association list which maps a parsed
 612 tyvar to its @Name@ representation.
 613 In some cases (type signatures of values),
 614 it is even necessary to go over the type first
 615 in order to get the set of tyvars used by it, make an assoc list,
 616 and then go over it again to rename the tyvars!
 617 However, we can also do some scoping checks at the same time.
 618
 619 \begin{code}
 620 rnTyClDecl :: TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars)
 621 rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_name})
 622   = lookupLocatedTopBndrRn name         `thenM` \ name' ->
 623     returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
 624              emptyFVs)
 625
 626 -- all flavours of type family declarations ("type family", "newtype fanily",
 627 -- and "data family")
 628 rnTyClDecl (tydecl@TyFamily {}) =
 629   rnFamily tydecl bindTyVarsRn
 630
 631 -- "data", "newtype", "data instance, and "newtype instance" declarations
 632 rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 633                            tcdLName = tycon, tcdTyVars = tyvars,
 634                            tcdTyPats = typatsMaybe, tcdCons = condecls,
 635                            tcdKindSig = sig, tcdDerivs = derivs})
 636   | is_vanilla            -- Normal Haskell data type decl
 637   = ASSERT( isNothing sig )     -- In normal H98 form, kind signature on the
 638                                 -- data type is syntactically illegal
 639     bindTyVarsRn data_doc tyvars                $ \ tyvars' ->
 640     do  { tycon' <- if isFamInstDecl tydecl
 641                     then lookupLocatedOccRn     tycon -- may be imported family
 642                     else lookupLocatedTopBndrRn tycon
 643         ; context' <- rnContext data_doc context
 644         ; typats' <- rnTyPats data_doc typatsMaybe
 645         ; (derivs', deriv_fvs) <- rn_derivs derivs
 646         ; condecls' <- rnConDecls (unLoc tycon') condecls
 647                 -- No need to check for duplicate constructor decls
 648                 -- since that is done by RnNames.extendGlobalRdrEnvRn
 649         ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context',
 650                            tcdLName = tycon', tcdTyVars = tyvars',
 651                            tcdTyPats = typats', tcdKindSig = Nothing,
 652                            tcdCons = condecls', tcdDerivs = derivs'},
 653                    delFVs (map hsLTyVarName tyvars')    $
 654                    extractHsCtxtTyNames context'        `plusFV`
 655                    plusFVs (map conDeclFVs condecls')   `plusFV`
 656                    deriv_fvs                            `plusFV`
 657                    (if isFamInstDecl tydecl
 658                    then unitFV (unLoc tycon')   -- type instance => use
 659                    else emptyFVs))
 660         }
 661
 662   | otherwise             -- GADT
 663   = ASSERT( none typatsMaybe )    -- GADTs cannot have type patterns for now
 664     do  { tycon' <- if isFamInstDecl tydecl
 665                     then lookupLocatedOccRn     tycon -- may be imported family
 666                     else lookupLocatedTopBndrRn tycon
 667         ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
 668         ; tyvars' <- bindTyVarsRn data_doc tyvars
 669                                   (\ tyvars' -> return tyvars')
 670                 -- For GADTs, the type variables in the declaration
 671                 -- do not scope over the constructor signatures
 672                 --      data T a where { T1 :: forall b. b-> b }
 673         ; (derivs', deriv_fvs) <- rn_derivs derivs
 674         ; condecls' <- rnConDecls (unLoc tycon') condecls
 675                 -- No need to check for duplicate constructor decls
 676                 -- since that is done by RnNames.extendGlobalRdrEnvRn
 677         ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [],
 678                            tcdLName = tycon', tcdTyVars = tyvars',
 679                            tcdTyPats = Nothing, tcdKindSig = sig,
 680                            tcdCons = condecls', tcdDerivs = derivs'},
 681                    plusFVs (map conDeclFVs condecls') `plusFV`
 682                    deriv_fvs                          `plusFV`
 683                    (if isFamInstDecl tydecl
 684                    then unitFV (unLoc tycon')   -- type instance => use
 685                    else emptyFVs))
 686         }
 687   where
 688     is_vanilla = case condecls of       -- Yuk
 689                      []                    -> True
 690                      L _ (ConDecl { con_res = ResTyH98 }) : _  -> True
 691                      _                     -> False
 692
 693     none Nothing   = True
 694     none (Just []) = True
 695     none _         = False
 696
 697     data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
 698
 699     rn_derivs Nothing   = returnM (Nothing, emptyFVs)
 700     rn_derivs (Just ds) = rnLHsTypes data_doc ds        `thenM` \ ds' ->
 701                           returnM (Just ds', extractHsTyNames_s ds')
 702
 703 -- "type" and "type instance" declarations
 704 rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
 705                               tcdTyPats = typatsMaybe, tcdSynRhs = ty})
 706   = bindTyVarsRn syn_doc tyvars                 $ \ tyvars' ->
 707     do { name' <- if isFamInstDecl tydecl
 708                   then lookupLocatedOccRn     name -- may be imported family
 709                   else lookupLocatedTopBndrRn name
 710        ; typats' <- rnTyPats syn_doc typatsMaybe
 711        ; (ty', fvs) <- rnHsTypeFVs syn_doc ty
 712        ; returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars',
 713                              tcdTyPats = typats', tcdSynRhs = ty'},
 714                   delFVs (map hsLTyVarName tyvars') $
 715                   fvs                         `plusFV`
 716                    (if isFamInstDecl tydecl
 717                    then unitFV (unLoc name')    -- type instance => use
 718                    else emptyFVs))
 719        }
 720   where
 721     syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
 722
 723 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
 724                        tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
 725                        tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs})
 726   = do  { cname' <- lookupLocatedTopBndrRn cname
 727
 728         -- Tyvars scope over superclass context and method signatures
 729         ; (tyvars', context', fds', ats', ats_fvs, sigs')
 730             <- bindTyVarsRn cls_doc tyvars $ \ tyvars' -> do
 731              { context' <- rnContext cls_doc context
 732              ; fds' <- rnFds cls_doc fds
 733              ; (ats', ats_fvs) <- rnATs ats
 734              ; sigs' <- renameSigs okClsDclSig sigs
 735              ; return   (tyvars', context', fds', ats', ats_fvs, sigs') }
 736
 737         -- No need to check for duplicate associated type decls
 738         -- since that is done by RnNames.extendGlobalRdrEnvRn
 739
 740         -- Check the signatures
 741         -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
 742         ; let sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs]
 743         ; checkDupRdrNames sig_doc sig_rdr_names_w_locs
 744                 -- Typechecker is responsible for checking that we only
 745                 -- give default-method bindings for things in this class.
 746                 -- The renamer *could* check this for class decls, but can't
 747                 -- for instance decls.
 748
 749         -- The newLocals call is tiresome: given a generic class decl
 750         --      class C a where
 751         --        op :: a -> a
 752         --        op {| x+y |} (Inl a) = ...
 753         --        op {| x+y |} (Inr b) = ...
 754         --        op {| a*b |} (a*b)   = ...
 755         -- we want to name both "x" tyvars with the same unique, so that they are
 756         -- easy to group together in the typechecker.
 757         ; (mbinds', meth_fvs)
 758             <- extendTyVarEnvForMethodBinds tyvars' $ do
 759             { name_env <- getLocalRdrEnv
 760             ; let gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds,
 761                                                  not (unLoc tv `elemLocalRdrEnv` name_env) ]
 762                 -- No need to check for duplicate method signatures
 763                 -- since that is done by RnNames.extendGlobalRdrEnvRn
 764                 -- and the methods are already in scope
 765             ; gen_tyvars <- newLocalsRn gen_rdr_tyvars_w_locs
 766             ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds }
 767
 768   -- Haddock docs
 769         ; docs' <- mapM (wrapLocM rnDocDecl) docs
 770
 771         ; return (ClassDecl { tcdCtxt = context', tcdLName = cname',
 772                               tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
 773                               tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'},
 774
 775                   delFVs (map hsLTyVarName tyvars')     $
 776                   extractHsCtxtTyNames context'         `plusFV`
 777                   plusFVs (map extractFunDepNames (map unLoc fds'))  `plusFV`
 778                   hsSigsFVs sigs'                       `plusFV`
 779                   meth_fvs                              `plusFV`
 780                   ats_fvs) }
 781   where
 782     cls_doc  = text "In the declaration for class"      <+> ppr cname
 783     sig_doc  = text "In the signatures for class"       <+> ppr cname
 784
 785 badGadtStupidTheta :: Located RdrName -> SDoc
 786 badGadtStupidTheta _
 787   = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"),
 788           ptext (sLit "(You can put a context on each contructor, though.)")]
 789 \end{code}
 790
 791 %*********************************************************
 792 %*                                                      *
 793 \subsection{Support code for type/data declarations}
 794 %*                                                      *
 795 %*********************************************************
 796
 797 \begin{code}
 798 -- Although, we are processing type patterns here, all type variables will
 799 -- already be in scope (they are the same as in the 'tcdTyVars' field of the
 800 -- type declaration to which these patterns belong)
 801 --
 802 rnTyPats :: SDoc -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name])
 803 rnTyPats _   Nothing       = return Nothing
 804 rnTyPats doc (Just typats) = liftM Just $ rnLHsTypes doc typats
 805
 806 rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
 807 rnConDecls _tycon condecls
 808   = mappM (wrapLocM rnConDecl) condecls
 809
 810 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
 811 rnConDecl (ConDecl name expl tvs cxt details res_ty mb_doc)
 812   = do  { addLocM checkConName name
 813
 814         ; new_name <- lookupLocatedTopBndrRn name
 815         ; name_env <- getLocalRdrEnv
 816
 817         -- For H98 syntax, the tvs are the existential ones
 818         -- For GADT syntax, the tvs are all the quantified tyvars
 819         -- Hence the 'filter' in the ResTyH98 case only
 820         ; let not_in_scope  = not . (`elemLocalRdrEnv` name_env) . unLoc
 821               arg_tys       = hsConDeclArgTys details
 822               implicit_tvs  = case res_ty of
 823                                 ResTyH98 -> filter not_in_scope $
 824                                                 get_rdr_tvs arg_tys
 825                                 ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
 826               tvs' = case expl of
 827                         Explicit -> tvs
 828                         Implicit -> userHsTyVarBndrs implicit_tvs
 829
 830         ; mb_doc' <- rnMbLHsDoc mb_doc
 831
 832         ; bindTyVarsRn doc tvs' $ \new_tyvars -> do
 833         { new_context <- rnContext doc cxt
 834         ; new_details <- rnConDeclDetails doc details
 835         ; (new_details', new_res_ty)  <- rnConResult doc new_details res_ty
 836         ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty mb_doc') }}
 837  where
 838     doc = text "In the definition of data constructor" <+> quotes (ppr name)
 839     get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
 840
 841 rnConResult :: SDoc
 842             -> HsConDetails (LHsType Name) [ConDeclField Name]
 843             -> ResType RdrName
 844             -> RnM (HsConDetails (LHsType Name) [ConDeclField Name],
 845                     ResType Name)
 846 rnConResult _ details ResTyH98 = return (details, ResTyH98)
 847
 848 rnConResult doc details (ResTyGADT ty) = do
 849     ty' <- rnHsSigType doc ty
 850     let (arg_tys, res_ty) = splitHsFunType ty'
 851         -- We can split it up, now the renamer has dealt with fixities
 852     case details of
 853         PrefixCon _xs -> ASSERT( null _xs ) return (PrefixCon arg_tys, ResTyGADT res_ty)
 854         RecCon _ -> return (details, ResTyGADT ty')
 855         InfixCon {}   -> panic "rnConResult"
 856
 857 rnConDeclDetails :: SDoc
 858                  -> HsConDetails (LHsType RdrName) [ConDeclField RdrName]
 859                  -> RnM (HsConDetails (LHsType Name) [ConDeclField Name])
 860 rnConDeclDetails doc (PrefixCon tys)
 861   = mappM (rnLHsType doc) tys   `thenM` \ new_tys  ->
 862     returnM (PrefixCon new_tys)
 863
 864 rnConDeclDetails doc (InfixCon ty1 ty2)
 865   = rnLHsType doc ty1           `thenM` \ new_ty1 ->
 866     rnLHsType doc ty2           `thenM` \ new_ty2 ->
 867     returnM (InfixCon new_ty1 new_ty2)
 868
 869 rnConDeclDetails doc (RecCon fields)
 870   = do  { new_fields <- mappM (rnField doc) fields
 871                 -- No need to check for duplicate fields
 872                 -- since that is done by RnNames.extendGlobalRdrEnvRn
 873         ; return (RecCon new_fields) }
 874
 875 rnField :: SDoc -> ConDeclField RdrName -> RnM (ConDeclField Name)
 876 rnField doc (ConDeclField name ty haddock_doc)
 877   = lookupLocatedTopBndrRn name `thenM` \ new_name ->
 878     rnLHsType doc ty            `thenM` \ new_ty ->
 879     rnMbLHsDoc haddock_doc      `thenM` \ new_haddock_doc ->
 880     returnM (ConDeclField new_name new_ty new_haddock_doc)
 881
 882 -- Rename family declarations
 883 --
 884 -- * This function is parametrised by the routine handling the index
 885 --   variables.  On the toplevel, these are defining occurences, whereas they
 886 --   are usage occurences for associated types.
 887 --
 888 rnFamily :: TyClDecl RdrName
 889          -> (SDoc -> [LHsTyVarBndr RdrName] ->
 890              ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
 891              RnM (TyClDecl Name, FreeVars))
 892          -> RnM (TyClDecl Name, FreeVars)
 893
 894 rnFamily (tydecl@TyFamily {tcdFlavour = flavour,
 895                            tcdLName = tycon, tcdTyVars = tyvars})
 896         bindIdxVars =
 897       do { checkM (isDataFlavour flavour                      -- for synonyms,
 898                    || not (null tyvars)) $ addErr needOneIdx  -- #indexes >= 1
 899          ; bindIdxVars (family_doc tycon) tyvars $ \tyvars' -> do {
 900          ; tycon' <- lookupLocatedTopBndrRn tycon
 901          ; returnM (TyFamily {tcdFlavour = flavour, tcdLName = tycon',
 902                               tcdTyVars = tyvars', tcdKind = tcdKind tydecl},
 903                     emptyFVs)
 904          } }
 905       where
 906         isDataFlavour DataFamily = True
 907         isDataFlavour _          = False
 908 rnFamily d _ = pprPanic "rnFamily" (ppr d)
 909
 910 family_doc :: Located RdrName -> SDoc
 911 family_doc tycon = text "In the family declaration for" <+> quotes (ppr tycon)
 912
 913 needOneIdx :: SDoc
 914 needOneIdx = text "Type family declarations requires at least one type index"
 915
 916 -- Rename associated type declarations (in classes)
 917 --
 918 -- * This can be family declarations and (default) type instances
 919 --
 920 rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
 921 rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
 922   where
 923     rn_at (tydecl@TyFamily  {}) = rnFamily tydecl lookupIdxVars
 924     rn_at (tydecl@TySynonym {}) =
 925       do
 926         checkM (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
 927         rnTyClDecl tydecl
 928     rn_at _                      = panic "RnSource.rnATs: invalid TyClDecl"
 929
 930     lookupIdxVars _ tyvars cont =
 931       do { checkForDups tyvars;
 932          ; tyvars' <- mappM lookupIdxVar tyvars
 933          ; cont tyvars'
 934          }
 935     -- Type index variables must be class parameters, which are the only
 936     -- type variables in scope at this point.
 937     lookupIdxVar (L l tyvar) =
 938       do
 939         name' <- lookupOccRn (hsTyVarName tyvar)
 940         return $ L l (replaceTyVarName tyvar name')
 941
 942     -- Type variable may only occur once.
 943     --
 944     checkForDups [] = return ()
 945     checkForDups (L loc tv:ltvs) =
 946       do { setSrcSpan loc $
 947              when (hsTyVarName tv `ltvElem` ltvs) $
 948                addErr (repeatedTyVar tv)
 949          ; checkForDups ltvs
 950          }
 951
 952     _       `ltvElem` [] = False
 953     rdrName `ltvElem` (L _ tv:ltvs)
 954       | rdrName == hsTyVarName tv = True
 955       | otherwise                 = rdrName `ltvElem` ltvs
 956
 957 noPatterns :: SDoc
 958 noPatterns = text "Default definition for an associated synonym cannot have"
 959              <+> text "type pattern"
 960
 961 repeatedTyVar :: HsTyVarBndr RdrName -> SDoc
 962 repeatedTyVar tv = ptext (sLit "Illegal repeated type variable") <+>
 963                    quotes (ppr tv)
 964
 965 -- This data decl will parse OK
 966 --      data T = a Int
 967 -- treating "a" as the constructor.
 968 -- It is really hard to make the parser spot this malformation.
 969 -- So the renamer has to check that the constructor is legal
 970 --
 971 -- We can get an operator as the constructor, even in the prefix form:
 972 --      data T = :% Int Int
 973 -- from interface files, which always print in prefix form
 974
 975 checkConName :: RdrName -> TcRn ()
 976 checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
 977
 978 badDataCon :: RdrName -> SDoc
 979 badDataCon name
 980    = hsep [ptext (sLit "Illegal data constructor name"), quotes (ppr name)]
 981 \end{code}
 982
 983
 984 %*********************************************************
 985 %*                                                      *
 986 \subsection{Support code for type/data declarations}
 987 %*                                                      *
 988 %*********************************************************
 989
 990 Get the mapping from constructors to fields for this module.
 991 It's convenient to do this after the data type decls have been renamed
 992 \begin{code}
 993 extendRecordFieldEnv :: [LTyClDecl RdrName] -> TcM TcGblEnv
 994 extendRecordFieldEnv decls
 995   = do  { tcg_env <- getGblEnv
 996         ; field_env' <- foldrM get (tcg_field_env tcg_env) decls
 997         ; return (tcg_env { tcg_field_env = field_env' }) }
 998   where
 999     -- we want to lookup:
1000     --  (a) a datatype constructor
1001     --  (b) a record field
1002     -- knowing that they're from this module.
1003     -- lookupLocatedTopBndrRn does this, because it does a lookupGreLocalRn,
1004     -- which keeps only the local ones.
1005     lookup x = do { x' <- lookupLocatedTopBndrRn x
1006                     ; return $ unLoc x'}
1007
1008     get (L _ (TyData { tcdCons = cons })) env = foldrM get_con env cons
1009     get _                            env = return env
1010
1011     get_con (L _ (ConDecl { con_name = con, con_details = RecCon flds })) env
1012         = do { con' <- lookup con
1013             ; flds' <- mappM lookup (map cd_fld_name flds)
1014             ; return $ extendNameEnv env con' flds' }
1015     get_con _ env
1016         = return env
1017 \end{code}
1018
1019 %*********************************************************
1020 %*                                                      *
1021 \subsection{Support code to rename types}
1022 %*                                                      *
1023 %*********************************************************
1024
1025 \begin{code}
1026 rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
1027
1028 rnFds doc fds
1029   = mappM (wrapLocM rn_fds) fds
1030   where
1031     rn_fds (tys1, tys2)
1032       = rnHsTyVars doc tys1             `thenM` \ tys1' ->
1033         rnHsTyVars doc tys2             `thenM` \ tys2' ->
1034         returnM (tys1', tys2')
1035
1036 rnHsTyVars :: SDoc -> [RdrName] -> RnM [Name]
1037 rnHsTyVars doc tvs  = mappM (rnHsTyVar doc) tvs
1038
1039 rnHsTyVar :: SDoc -> RdrName -> RnM Name
1040 rnHsTyVar _doc tyvar = lookupOccRn tyvar
1041 \end{code}
1042
1043
1044 %*********************************************************
1045 %*                                                      *
1046                 Splices
1047 %*                                                      *
1048 %*********************************************************
1049
1050 Note [Splices]
1051 ~~~~~~~~~~~~~~
1052 Consider
1053         f = ...
1054         h = ...$(thing "f")...
1055
1056 The splice can expand into literally anything, so when we do dependency
1057 analysis we must assume that it might mention 'f'.  So we simply treat
1058 all locally-defined names as mentioned by any splice.  This is terribly
1059 brutal, but I don't see what else to do.  For example, it'll mean
1060 that every locally-defined thing will appear to be used, so no unused-binding
1061 warnings.  But if we miss the dependency, then we might typecheck 'h' before 'f',
1062 and that will crash the type checker because 'f' isn't in scope.
1063
1064 Currently, I'm not treating a splice as also mentioning every import,
1065 which is a bit inconsistent -- but there are a lot of them.  We might
1066 thereby get some bogus unused-import warnings, but we won't crash the
1067 type checker.  Not very satisfactory really.
1068
1069 \begin{code}
1070 rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
1071 rnSplice (HsSplice n expr)
1072   = do  { checkTH expr "splice"
1073         ; loc  <- getSrcSpanM
1074         ; [n'] <- newLocalsRn [L loc n]
1075         ; (expr', fvs) <- rnLExpr expr
1076
1077         -- Ugh!  See Note [Splices] above
1078         ; lcl_rdr <- getLocalRdrEnv
1079         ; gbl_rdr <- getGlobalRdrEnv
1080         ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr,
1081                                                     isLocalGRE gre]
1082               lcl_names = mkNameSet (occEnvElts lcl_rdr)
1083
1084         ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }
1085
1086 checkTH :: Outputable a => a -> String -> RnM ()
1087 #ifdef GHCI
1088 checkTH _ _ = returnM ()        -- OK
1089 #else
1090 checkTH e what  -- Raise an error in a stage-1 compiler
1091   = addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+>
1092                   ptext (sLit "illegal in a stage-1 compiler"),
1093                   nest 2 (ppr e)])
1094 #endif
1095 \end{code}