compiler/rename/RnSource.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[RnSource]{Main pass of renamer}
   5
   6 \begin{code}
   7 module RnSource (
   8         rnSrcDecls, addTcgDUs,
   9         rnTyClDecls,
  10         rnSplice, checkTH
  11     ) where
  12
  13 #include "HsVersions.h"
  14
  15 import {-# SOURCE #-} RnExpr( rnLExpr )
  16
  17 import HsSyn
  18 import RdrName          ( RdrName, isRdrDataCon, elemLocalRdrEnv,
  19                           globalRdrEnvElts, GlobalRdrElt(..), isLocalGRE, rdrNameOcc )
  20 import RdrHsSyn         ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
  21 import RnHsSyn
  22 import RnTypes          ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
  23 import RnBinds          ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn,
  24                                 makeMiniFixityEnv)
  25 import RnEnv            ( lookupLocalDataTcNames,
  26                           lookupLocatedTopBndrRn, lookupLocatedOccRn,
  27                           lookupOccRn, newLocalsRn,
  28                           bindLocatedLocalsFV, bindPatSigTyVarsFV,
  29                           bindTyVarsRn, extendTyVarEnvFVRn,
  30                           bindLocalNames, checkDupRdrNames, mapFvRn,
  31                         )
  32 import RnNames          ( getLocalNonValBinders, extendGlobalRdrEnvRn )
  33 import HscTypes         ( GenAvailInfo(..) )
  34 import RnHsDoc          ( rnHsDoc, rnMbLHsDoc )
  35 import TcRnMonad
  36
  37 import HscTypes         ( Warnings(..), plusWarns )
  38 import Class            ( FunDep )
  39 import Name             ( Name, nameOccName )
  40 import NameSet
  41 import NameEnv
  42 import OccName
  43 import Outputable
  44 import Bag
  45 import FastString
  46 import SrcLoc           ( Located(..), unLoc, noLoc )
  47 import DynFlags ( DynFlag(..) )
  48 import Maybe            ( isNothing )
  49 import BasicTypes       ( Boxity(..) )
  50
  51 import ListSetOps    (findDupsEq)
  52
  53 import Control.Monad
  54 \end{code}
  55
  56 \begin{code}
  57 -- XXX
  58 thenM :: Monad a => a b -> (b -> a c) -> a c
  59 thenM = (>>=)
  60
  61 thenM_ :: Monad a => a b -> a c -> a c
  62 thenM_ = (>>)
  63
  64 returnM :: Monad m => a -> m a
  65 returnM = return
  66
  67 mappM :: (Monad m) => (a -> m b) -> [a] -> m [b]
  68 mappM = mapM
  69
  70 mappM_ :: (Monad m) => (a -> m b) -> [a] -> m ()
  71 mappM_ = mapM_
  72
  73 checkM :: Monad m => Bool -> m () -> m ()
  74 checkM = unless
  75 \end{code}
  76
  77 @rnSourceDecl@ `renames' declarations.
  78 It simultaneously performs dependency analysis and precedence parsing.
  79 It also does the following error checks:
  80 \begin{enumerate}
  81 \item
  82 Checks that tyvars are used properly. This includes checking
  83 for undefined tyvars, and tyvars in contexts that are ambiguous.
  84 (Some of this checking has now been moved to module @TcMonoType@,
  85 since we don't have functional dependency information at this point.)
  86 \item
  87 Checks that all variable occurences are defined.
  88 \item
  89 Checks the @(..)@ etc constraints in the export list.
  90 \end{enumerate}
  91
  92
  93 \begin{code}
  94 -- Brings the binders of the group into scope in the appropriate places;
  95 -- does NOT assume that anything is in scope already
  96 --
  97 -- The Bool determines whether (True) names in the group shadow existing
  98 -- Unquals in the global environment (used in Template Haskell) or
  99 -- (False) whether duplicates are reported as an error
 100 rnSrcDecls :: Bool -> HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
 101
 102 rnSrcDecls shadowP group@(HsGroup {hs_valds  = val_decls,
 103                                    hs_tyclds = tycl_decls,
 104                                    hs_instds = inst_decls,
 105                                    hs_derivds = deriv_decls,
 106                                    hs_fixds  = fix_decls,
 107                                    hs_warnds  = warn_decls,
 108                                    hs_fords  = foreign_decls,
 109                                    hs_defds  = default_decls,
 110                                    hs_ruleds = rule_decls,
 111                                    hs_docs   = docs })
 112  = do {
 113    -- (A) Process the fixity declarations, creating a mapping from
 114    --     FastStrings to FixItems.
 115    --     Also checks for duplcates.
 116    local_fix_env <- makeMiniFixityEnv fix_decls;
 117
 118    -- (B) Bring top level binders (and their fixities) into scope,
 119    --     *except* for the value bindings, which get brought in below.
 120    avails <- getLocalNonValBinders group ;
 121    tc_envs <- extendGlobalRdrEnvRn shadowP avails local_fix_env ;
 122    setEnvs tc_envs $ do {
 123
 124    failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
 125
 126    -- (C) Extract the mapping from data constructors to field names and
 127    --     extend the record field env.
 128    --     This depends on the data constructors and field names being in
 129    --     scope from (B) above
 130    inNewEnv (extendRecordFieldEnv tycl_decls) $ \ _ -> do {
 131
 132    -- (D) Rename the left-hand sides of the value bindings.
 133    --     This depends on everything from (B) being in scope,
 134    --     and on (C) for resolving record wild cards.
 135    --     It uses the fixity env from (A) to bind fixities for view patterns.
 136    new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
 137    -- bind the LHSes (and their fixities) in the global rdr environment
 138    let { lhs_binders = map unLoc $ collectHsValBinders new_lhs;
 139          lhs_avails = map Avail lhs_binders
 140        } ;
 141    (tcg_env, tcl_env) <- extendGlobalRdrEnvRn shadowP lhs_avails local_fix_env ;
 142    setEnvs (tcg_env, tcl_env) $ do {
 143
 144    --  Now everything is in scope, as the remaining renaming assumes.
 145
 146    -- (E) Rename type and class decls
 147    --     (note that value LHSes need to be in scope for default methods)
 148    --
 149    -- You might think that we could build proper def/use information
 150    -- for type and class declarations, but they can be involved
 151    -- in mutual recursion across modules, and we only do the SCC
 152    -- analysis for them in the type checker.
 153    -- So we content ourselves with gathering uses only; that
 154    -- means we'll only report a declaration as unused if it isn't
 155    -- mentioned at all.  Ah well.
 156    traceRn (text "Start rnTyClDecls") ;
 157    (rn_tycl_decls, src_fvs1) <- rnList rnTyClDecl tycl_decls ;
 158
 159    -- (F) Rename Value declarations right-hand sides
 160    traceRn (text "Start rnmono") ;
 161    (rn_val_decls, bind_dus) <- rnTopBindsRHS lhs_binders new_lhs ;
 162    traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
 163
 164    -- (G) Rename Fixity and deprecations
 165
 166    -- rename fixity declarations and error if we try to
 167    -- fix something from another module (duplicates were checked in (A))
 168    rn_fix_decls                 <- rnSrcFixityDecls fix_decls ;
 169    -- rename deprec decls;
 170    -- check for duplicates and ensure that deprecated things are defined locally
 171    -- at the moment, we don't keep these around past renaming
 172    rn_warns <- rnSrcWarnDecls warn_decls ;
 173
 174    -- (H) Rename Everything else
 175
 176    (rn_inst_decls,    src_fvs2) <- rnList rnSrcInstDecl   inst_decls ;
 177    (rn_rule_decls,    src_fvs3) <- 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_warnds = [], -- warns 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_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
 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 rnSrcWarnDecls :: [LWarnDecl RdrName] -> RnM Warnings
 304 rnSrcWarnDecls []
 305   = returnM NoWarnings
 306
 307 rnSrcWarnDecls decls
 308   = do { -- check for duplicates
 309        ; mappM_ (\ (lrdr:lrdr':_) -> addLocErr lrdr (dupWarnDecl lrdr')) warn_rdr_dups
 310        ; mappM (addLocM rn_deprec) decls        `thenM` \ pairs_s ->
 311          returnM (WarnSome ((concat pairs_s))) }
 312  where
 313    rn_deprec (Warning 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    warn_rdr_dups = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
 322                      (map (\ (L loc (Warning rdr_name _)) -> L loc rdr_name) decls)
 323
 324 dupWarnDecl :: Located RdrName -> RdrName -> SDoc
 325 -- Located RdrName -> DeprecDecl RdrName -> SDoc
 326 dupWarnDecl (L loc _) rdr_name
 327   = vcat [ptext (sLit "Multiple warning 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     bindLocatedLocalsFV doc (map get_var vars)          $ \ ids ->
 504     do  { (vars', fv_vars) <- mapFvRn rn_var (vars `zip` ids)
 505                 -- NB: The binders in a rule are always Ids
 506                 --     We don't (yet) support type variables
 507
 508         ; (lhs', fv_lhs') <- rnLExpr lhs
 509         ; (rhs', fv_rhs') <- rnLExpr rhs
 510
 511         ; checkValidRule rule_name ids lhs' fv_lhs'
 512
 513         ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
 514                   fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs') }
 515   where
 516     doc = text "In the transformation rule" <+> ftext rule_name
 517
 518     get_var (RuleBndr v)      = v
 519     get_var (RuleBndrSig v _) = v
 520
 521     rn_var (RuleBndr (L loc _), id)
 522         = returnM (RuleBndr (L loc id), emptyFVs)
 523     rn_var (RuleBndrSig (L loc _) t, id)
 524         = rnHsTypeFVs doc t     `thenM` \ (t', fvs) ->
 525           returnM (RuleBndrSig (L loc id) t', fvs)
 526
 527 badRuleVar :: FastString -> Name -> SDoc
 528 badRuleVar name var
 529   = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon,
 530          ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+>
 531                 ptext (sLit "does not appear on left hand side")]
 532 \end{code}
 533
 534 Note [Rule LHS validity checking]
 535 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 536 Check the shape of a transformation rule LHS.  Currently we only allow
 537 LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
 538 @forall@'d variables.
 539
 540 We used restrict the form of the 'ei' to prevent you writing rules
 541 with LHSs with a complicated desugaring (and hence unlikely to match);
 542 (e.g. a case expression is not allowed: too elaborate.)
 543
 544 But there are legitimate non-trivial args ei, like sections and
 545 lambdas.  So it seems simmpler not to check at all, and that is why
 546 check_e is commented out.
 547
 548 \begin{code}
 549 checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM ()
 550 checkValidRule rule_name ids lhs' fv_lhs'
 551   = do  {       -- Check for the form of the LHS
 552           case (validRuleLhs ids lhs') of
 553                 Nothing  -> return ()
 554                 Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
 555
 556                 -- Check that LHS vars are all bound
 557         ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
 558         ; mapM_ (addErr . badRuleVar rule_name) bad_vars }
 559
 560 validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
 561 -- Nothing => OK
 562 -- Just e  => Not ok, and e is the offending expression
 563 validRuleLhs foralls lhs
 564   = checkl lhs
 565   where
 566     checkl (L _ e) = check e
 567
 568     check (OpApp e1 op _ e2)              = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
 569     check (HsApp e1 e2)                   = checkl e1 `mplus` checkl_e e2
 570     check (HsVar v) | v `notElem` foralls = Nothing
 571     check other                           = Just other  -- Failure
 572
 573         -- Check an argument
 574     checkl_e (L _ _e) = Nothing         -- Was (check_e e); see Note [Rule LHS validity checking]
 575
 576 {-      Commented out; see Note [Rule LHS validity checking] above
 577     check_e (HsVar v)     = Nothing
 578     check_e (HsPar e)     = checkl_e e
 579     check_e (HsLit e)     = Nothing
 580     check_e (HsOverLit e) = Nothing
 581
 582     check_e (OpApp e1 op _ e2)   = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2
 583     check_e (HsApp e1 e2)        = checkl_e e1 `mplus` checkl_e e2
 584     check_e (NegApp e _)         = checkl_e e
 585     check_e (ExplicitList _ es)  = checkl_es es
 586     check_e (ExplicitTuple es _) = checkl_es es
 587     check_e other                = Just other   -- Fails
 588
 589     checkl_es es = foldr (mplus . checkl_e) Nothing es
 590 -}
 591
 592 badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc
 593 badRuleLhsErr name lhs bad_e
 594   = sep [ptext (sLit "Rule") <+> ftext name <> colon,
 595          nest 4 (vcat [ptext (sLit "Illegal expression:") <+> ppr bad_e,
 596                        ptext (sLit "in left-hand side:") <+> ppr lhs])]
 597     $$
 598     ptext (sLit "LHS must be of form (f e1 .. en) where f is not forall'd")
 599 \end{code}
 600
 601
 602 %*********************************************************
 603 %*                                                      *
 604 \subsection{Type, class and iface sig declarations}
 605 %*                                                      *
 606 %*********************************************************
 607
 608 @rnTyDecl@ uses the `global name function' to create a new type
 609 declaration in which local names have been replaced by their original
 610 names, reporting any unknown names.
 611
 612 Renaming type variables is a pain. Because they now contain uniques,
 613 it is necessary to pass in an association list which maps a parsed
 614 tyvar to its @Name@ representation.
 615 In some cases (type signatures of values),
 616 it is even necessary to go over the type first
 617 in order to get the set of tyvars used by it, make an assoc list,
 618 and then go over it again to rename the tyvars!
 619 However, we can also do some scoping checks at the same time.
 620
 621 \begin{code}
 622 rnTyClDecl :: TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars)
 623 rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_name})
 624   = lookupLocatedTopBndrRn name         `thenM` \ name' ->
 625     returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
 626              emptyFVs)
 627
 628 -- all flavours of type family declarations ("type family", "newtype fanily",
 629 -- and "data family")
 630 rnTyClDecl (tydecl@TyFamily {}) =
 631   rnFamily tydecl bindTyVarsRn
 632
 633 -- "data", "newtype", "data instance, and "newtype instance" declarations
 634 rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 635                            tcdLName = tycon, tcdTyVars = tyvars,
 636                            tcdTyPats = typatsMaybe, tcdCons = condecls,
 637                            tcdKindSig = sig, tcdDerivs = derivs})
 638   | is_vanilla            -- Normal Haskell data type decl
 639   = ASSERT( isNothing sig )     -- In normal H98 form, kind signature on the
 640                                 -- data type is syntactically illegal
 641     bindTyVarsRn data_doc tyvars                $ \ tyvars' ->
 642     do  { tycon' <- if isFamInstDecl tydecl
 643                     then lookupLocatedOccRn     tycon -- may be imported family
 644                     else lookupLocatedTopBndrRn tycon
 645         ; context' <- rnContext data_doc context
 646         ; typats' <- rnTyPats data_doc typatsMaybe
 647         ; (derivs', deriv_fvs) <- rn_derivs derivs
 648         ; condecls' <- rnConDecls (unLoc tycon') condecls
 649                 -- No need to check for duplicate constructor decls
 650                 -- since that is done by RnNames.extendGlobalRdrEnvRn
 651         ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context',
 652                            tcdLName = tycon', tcdTyVars = tyvars',
 653                            tcdTyPats = typats', tcdKindSig = Nothing,
 654                            tcdCons = condecls', tcdDerivs = derivs'},
 655                    delFVs (map hsLTyVarName tyvars')    $
 656                    extractHsCtxtTyNames context'        `plusFV`
 657                    plusFVs (map conDeclFVs condecls')   `plusFV`
 658                    deriv_fvs                            `plusFV`
 659                    (if isFamInstDecl tydecl
 660                    then unitFV (unLoc tycon')   -- type instance => use
 661                    else emptyFVs))
 662         }
 663
 664   | otherwise             -- GADT
 665   = ASSERT( none typatsMaybe )    -- GADTs cannot have type patterns for now
 666     do  { tycon' <- if isFamInstDecl tydecl
 667                     then lookupLocatedOccRn     tycon -- may be imported family
 668                     else lookupLocatedTopBndrRn tycon
 669         ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
 670         ; tyvars' <- bindTyVarsRn data_doc tyvars
 671                                   (\ tyvars' -> return tyvars')
 672                 -- For GADTs, the type variables in the declaration
 673                 -- do not scope over the constructor signatures
 674                 --      data T a where { T1 :: forall b. b-> b }
 675         ; (derivs', deriv_fvs) <- rn_derivs derivs
 676         ; condecls' <- rnConDecls (unLoc tycon') condecls
 677                 -- No need to check for duplicate constructor decls
 678                 -- since that is done by RnNames.extendGlobalRdrEnvRn
 679         ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [],
 680                            tcdLName = tycon', tcdTyVars = tyvars',
 681                            tcdTyPats = Nothing, tcdKindSig = sig,
 682                            tcdCons = condecls', tcdDerivs = derivs'},
 683                    plusFVs (map conDeclFVs condecls') `plusFV`
 684                    deriv_fvs                          `plusFV`
 685                    (if isFamInstDecl tydecl
 686                    then unitFV (unLoc tycon')   -- type instance => use
 687                    else emptyFVs))
 688         }
 689   where
 690     is_vanilla = case condecls of       -- Yuk
 691                      []                    -> True
 692                      L _ (ConDecl { con_res = ResTyH98 }) : _  -> True
 693                      _                     -> False
 694
 695     none Nothing   = True
 696     none (Just []) = True
 697     none _         = False
 698
 699     data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
 700
 701     rn_derivs Nothing   = returnM (Nothing, emptyFVs)
 702     rn_derivs (Just ds) = rnLHsTypes data_doc ds        `thenM` \ ds' ->
 703                           returnM (Just ds', extractHsTyNames_s ds')
 704
 705 -- "type" and "type instance" declarations
 706 rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
 707                               tcdTyPats = typatsMaybe, tcdSynRhs = ty})
 708   = bindTyVarsRn syn_doc tyvars                 $ \ tyvars' ->
 709     do { name' <- if isFamInstDecl tydecl
 710                   then lookupLocatedOccRn     name -- may be imported family
 711                   else lookupLocatedTopBndrRn name
 712        ; typats' <- rnTyPats syn_doc typatsMaybe
 713        ; (ty', fvs) <- rnHsTypeFVs syn_doc ty
 714        ; returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars',
 715                              tcdTyPats = typats', tcdSynRhs = ty'},
 716                   delFVs (map hsLTyVarName tyvars') $
 717                   fvs                         `plusFV`
 718                    (if isFamInstDecl tydecl
 719                    then unitFV (unLoc name')    -- type instance => use
 720                    else emptyFVs))
 721        }
 722   where
 723     syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
 724
 725 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
 726                        tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
 727                        tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs})
 728   = do  { cname' <- lookupLocatedTopBndrRn cname
 729
 730         -- Tyvars scope over superclass context and method signatures
 731         ; (tyvars', context', fds', ats', ats_fvs, sigs')
 732             <- bindTyVarsRn cls_doc tyvars $ \ tyvars' -> do
 733              { context' <- rnContext cls_doc context
 734              ; fds' <- rnFds cls_doc fds
 735              ; (ats', ats_fvs) <- rnATs ats
 736              ; sigs' <- renameSigs Nothing okClsDclSig sigs
 737              ; return   (tyvars', context', fds', ats', ats_fvs, sigs') }
 738
 739         -- No need to check for duplicate associated type decls
 740         -- since that is done by RnNames.extendGlobalRdrEnvRn
 741
 742         -- Check the signatures
 743         -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
 744         ; let sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs]
 745         ; checkDupRdrNames sig_doc sig_rdr_names_w_locs
 746                 -- Typechecker is responsible for checking that we only
 747                 -- give default-method bindings for things in this class.
 748                 -- The renamer *could* check this for class decls, but can't
 749                 -- for instance decls.
 750
 751         -- The newLocals call is tiresome: given a generic class decl
 752         --      class C a where
 753         --        op :: a -> a
 754         --        op {| x+y |} (Inl a) = ...
 755         --        op {| x+y |} (Inr b) = ...
 756         --        op {| a*b |} (a*b)   = ...
 757         -- we want to name both "x" tyvars with the same unique, so that they are
 758         -- easy to group together in the typechecker.
 759         ; (mbinds', meth_fvs)
 760             <- extendTyVarEnvForMethodBinds tyvars' $ do
 761             { name_env <- getLocalRdrEnv
 762             ; let gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds,
 763                                                  not (unLoc tv `elemLocalRdrEnv` name_env) ]
 764                 -- No need to check for duplicate method signatures
 765                 -- since that is done by RnNames.extendGlobalRdrEnvRn
 766                 -- and the methods are already in scope
 767             ; gen_tyvars <- newLocalsRn gen_rdr_tyvars_w_locs
 768             ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds }
 769
 770   -- Haddock docs
 771         ; docs' <- mapM (wrapLocM rnDocDecl) docs
 772
 773         ; return (ClassDecl { tcdCtxt = context', tcdLName = cname',
 774                               tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
 775                               tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'},
 776
 777                   delFVs (map hsLTyVarName tyvars')     $
 778                   extractHsCtxtTyNames context'         `plusFV`
 779                   plusFVs (map extractFunDepNames (map unLoc fds'))  `plusFV`
 780                   hsSigsFVs sigs'                       `plusFV`
 781                   meth_fvs                              `plusFV`
 782                   ats_fvs) }
 783   where
 784     cls_doc  = text "In the declaration for class"      <+> ppr cname
 785     sig_doc  = text "In the signatures for class"       <+> ppr cname
 786
 787 badGadtStupidTheta :: Located RdrName -> SDoc
 788 badGadtStupidTheta _
 789   = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"),
 790           ptext (sLit "(You can put a context on each contructor, though.)")]
 791 \end{code}
 792
 793 %*********************************************************
 794 %*                                                      *
 795 \subsection{Support code for type/data declarations}
 796 %*                                                      *
 797 %*********************************************************
 798
 799 \begin{code}
 800 -- Although, we are processing type patterns here, all type variables will
 801 -- already be in scope (they are the same as in the 'tcdTyVars' field of the
 802 -- type declaration to which these patterns belong)
 803 --
 804 rnTyPats :: SDoc -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name])
 805 rnTyPats _   Nothing       = return Nothing
 806 rnTyPats doc (Just typats) = liftM Just $ rnLHsTypes doc typats
 807
 808 rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
 809 rnConDecls _tycon condecls
 810   = mappM (wrapLocM rnConDecl) condecls
 811
 812 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
 813 rnConDecl (ConDecl name expl tvs cxt details res_ty mb_doc)
 814   = do  { addLocM checkConName name
 815
 816         ; new_name <- lookupLocatedTopBndrRn name
 817         ; name_env <- getLocalRdrEnv
 818
 819         -- For H98 syntax, the tvs are the existential ones
 820         -- For GADT syntax, the tvs are all the quantified tyvars
 821         -- Hence the 'filter' in the ResTyH98 case only
 822         ; let not_in_scope  = not . (`elemLocalRdrEnv` name_env) . unLoc
 823               arg_tys       = hsConDeclArgTys details
 824               implicit_tvs  = case res_ty of
 825                                 ResTyH98 -> filter not_in_scope $
 826                                                 get_rdr_tvs arg_tys
 827                                 ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
 828               tvs' = case expl of
 829                         Explicit -> tvs
 830                         Implicit -> userHsTyVarBndrs implicit_tvs
 831
 832         ; mb_doc' <- rnMbLHsDoc mb_doc
 833
 834         ; bindTyVarsRn doc tvs' $ \new_tyvars -> do
 835         { new_context <- rnContext doc cxt
 836         ; new_details <- rnConDeclDetails doc details
 837         ; (new_details', new_res_ty)  <- rnConResult doc new_details res_ty
 838         ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty mb_doc') }}
 839  where
 840     doc = text "In the definition of data constructor" <+> quotes (ppr name)
 841     get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
 842
 843 rnConResult :: SDoc
 844             -> HsConDetails (LHsType Name) [ConDeclField Name]
 845             -> ResType RdrName
 846             -> RnM (HsConDetails (LHsType Name) [ConDeclField Name],
 847                     ResType Name)
 848 rnConResult _ details ResTyH98 = return (details, ResTyH98)
 849
 850 rnConResult doc details (ResTyGADT ty) = do
 851     ty' <- rnHsSigType doc ty
 852     let (arg_tys, res_ty) = splitHsFunType ty'
 853         -- We can split it up, now the renamer has dealt with fixities
 854     case details of
 855         PrefixCon _xs -> ASSERT( null _xs ) return (PrefixCon arg_tys, ResTyGADT res_ty)
 856         RecCon _ -> return (details, ResTyGADT ty')
 857         InfixCon {}   -> panic "rnConResult"
 858
 859 rnConDeclDetails :: SDoc
 860                  -> HsConDetails (LHsType RdrName) [ConDeclField RdrName]
 861                  -> RnM (HsConDetails (LHsType Name) [ConDeclField Name])
 862 rnConDeclDetails doc (PrefixCon tys)
 863   = mappM (rnLHsType doc) tys   `thenM` \ new_tys  ->
 864     returnM (PrefixCon new_tys)
 865
 866 rnConDeclDetails doc (InfixCon ty1 ty2)
 867   = rnLHsType doc ty1           `thenM` \ new_ty1 ->
 868     rnLHsType doc ty2           `thenM` \ new_ty2 ->
 869     returnM (InfixCon new_ty1 new_ty2)
 870
 871 rnConDeclDetails doc (RecCon fields)
 872   = do  { new_fields <- mappM (rnField doc) fields
 873                 -- No need to check for duplicate fields
 874                 -- since that is done by RnNames.extendGlobalRdrEnvRn
 875         ; return (RecCon new_fields) }
 876
 877 rnField :: SDoc -> ConDeclField RdrName -> RnM (ConDeclField Name)
 878 rnField doc (ConDeclField name ty haddock_doc)
 879   = lookupLocatedTopBndrRn name `thenM` \ new_name ->
 880     rnLHsType doc ty            `thenM` \ new_ty ->
 881     rnMbLHsDoc haddock_doc      `thenM` \ new_haddock_doc ->
 882     returnM (ConDeclField new_name new_ty new_haddock_doc)
 883
 884 -- Rename family declarations
 885 --
 886 -- * This function is parametrised by the routine handling the index
 887 --   variables.  On the toplevel, these are defining occurences, whereas they
 888 --   are usage occurences for associated types.
 889 --
 890 rnFamily :: TyClDecl RdrName
 891          -> (SDoc -> [LHsTyVarBndr RdrName] ->
 892              ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
 893              RnM (TyClDecl Name, FreeVars))
 894          -> RnM (TyClDecl Name, FreeVars)
 895
 896 rnFamily (tydecl@TyFamily {tcdFlavour = flavour,
 897                            tcdLName = tycon, tcdTyVars = tyvars})
 898         bindIdxVars =
 899       do { checkM (isDataFlavour flavour                      -- for synonyms,
 900                    || not (null tyvars)) $ addErr needOneIdx  -- no. of indexes >= 1
 901          ; bindIdxVars (family_doc tycon) tyvars $ \tyvars' -> do {
 902          ; tycon' <- lookupLocatedTopBndrRn tycon
 903          ; returnM (TyFamily {tcdFlavour = flavour, tcdLName = tycon',
 904                               tcdTyVars = tyvars', tcdKind = tcdKind tydecl},
 905                     emptyFVs)
 906          } }
 907       where
 908         isDataFlavour DataFamily = True
 909         isDataFlavour _          = False
 910 rnFamily d _ = pprPanic "rnFamily" (ppr d)
 911
 912 family_doc :: Located RdrName -> SDoc
 913 family_doc tycon = text "In the family declaration for" <+> quotes (ppr tycon)
 914
 915 needOneIdx :: SDoc
 916 needOneIdx = text "Type family declarations requires at least one type index"
 917
 918 -- Rename associated type declarations (in classes)
 919 --
 920 -- * This can be family declarations and (default) type instances
 921 --
 922 rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
 923 rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
 924   where
 925     rn_at (tydecl@TyFamily  {}) = rnFamily tydecl lookupIdxVars
 926     rn_at (tydecl@TySynonym {}) =
 927       do
 928         checkM (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
 929         rnTyClDecl tydecl
 930     rn_at _                      = panic "RnSource.rnATs: invalid TyClDecl"
 931
 932     lookupIdxVars _ tyvars cont =
 933       do { checkForDups tyvars;
 934          ; tyvars' <- mappM lookupIdxVar tyvars
 935          ; cont tyvars'
 936          }
 937     -- Type index variables must be class parameters, which are the only
 938     -- type variables in scope at this point.
 939     lookupIdxVar (L l tyvar) =
 940       do
 941         name' <- lookupOccRn (hsTyVarName tyvar)
 942         return $ L l (replaceTyVarName tyvar name')
 943
 944     -- Type variable may only occur once.
 945     --
 946     checkForDups [] = return ()
 947     checkForDups (L loc tv:ltvs) =
 948       do { setSrcSpan loc $
 949              when (hsTyVarName tv `ltvElem` ltvs) $
 950                addErr (repeatedTyVar tv)
 951          ; checkForDups ltvs
 952          }
 953
 954     _       `ltvElem` [] = False
 955     rdrName `ltvElem` (L _ tv:ltvs)
 956       | rdrName == hsTyVarName tv = True
 957       | otherwise                 = rdrName `ltvElem` ltvs
 958
 959 noPatterns :: SDoc
 960 noPatterns = text "Default definition for an associated synonym cannot have"
 961              <+> text "type pattern"
 962
 963 repeatedTyVar :: HsTyVarBndr RdrName -> SDoc
 964 repeatedTyVar tv = ptext (sLit "Illegal repeated type variable") <+>
 965                    quotes (ppr tv)
 966
 967 -- This data decl will parse OK
 968 --      data T = a Int
 969 -- treating "a" as the constructor.
 970 -- It is really hard to make the parser spot this malformation.
 971 -- So the renamer has to check that the constructor is legal
 972 --
 973 -- We can get an operator as the constructor, even in the prefix form:
 974 --      data T = :% Int Int
 975 -- from interface files, which always print in prefix form
 976
 977 checkConName :: RdrName -> TcRn ()
 978 checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
 979
 980 badDataCon :: RdrName -> SDoc
 981 badDataCon name
 982    = hsep [ptext (sLit "Illegal data constructor name"), quotes (ppr name)]
 983 \end{code}
 984
 985
 986 %*********************************************************
 987 %*                                                      *
 988 \subsection{Support code for type/data declarations}
 989 %*                                                      *
 990 %*********************************************************
 991
 992 Get the mapping from constructors to fields for this module.
 993 It's convenient to do this after the data type decls have been renamed
 994 \begin{code}
 995 extendRecordFieldEnv :: [LTyClDecl RdrName] -> TcM TcGblEnv
 996 extendRecordFieldEnv decls
 997   = do  { tcg_env <- getGblEnv
 998         ; field_env' <- foldrM get (tcg_field_env tcg_env) decls
 999         ; return (tcg_env { tcg_field_env = field_env' }) }
1000   where
1001     -- we want to lookup:
1002     --  (a) a datatype constructor
1003     --  (b) a record field
1004     -- knowing that they're from this module.
1005     -- lookupLocatedTopBndrRn does this, because it does a lookupGreLocalRn,
1006     -- which keeps only the local ones.
1007     lookup x = do { x' <- lookupLocatedTopBndrRn x
1008                     ; return $ unLoc x'}
1009
1010     get (L _ (TyData { tcdCons = cons })) env = foldrM get_con env cons
1011     get _                            env = return env
1012
1013     get_con (L _ (ConDecl { con_name = con, con_details = RecCon flds })) env
1014         = do { con' <- lookup con
1015             ; flds' <- mappM lookup (map cd_fld_name flds)
1016             ; return $ extendNameEnv env con' flds' }
1017     get_con _ env
1018         = return env
1019 \end{code}
1020
1021 %*********************************************************
1022 %*                                                      *
1023 \subsection{Support code to rename types}
1024 %*                                                      *
1025 %*********************************************************
1026
1027 \begin{code}
1028 rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
1029
1030 rnFds doc fds
1031   = mappM (wrapLocM rn_fds) fds
1032   where
1033     rn_fds (tys1, tys2)
1034       = rnHsTyVars doc tys1             `thenM` \ tys1' ->
1035         rnHsTyVars doc tys2             `thenM` \ tys2' ->
1036         returnM (tys1', tys2')
1037
1038 rnHsTyVars :: SDoc -> [RdrName] -> RnM [Name]
1039 rnHsTyVars doc tvs  = mappM (rnHsTyVar doc) tvs
1040
1041 rnHsTyVar :: SDoc -> RdrName -> RnM Name
1042 rnHsTyVar _doc tyvar = lookupOccRn tyvar
1043 \end{code}
1044
1045
1046 %*********************************************************
1047 %*                                                      *
1048                 Splices
1049 %*                                                      *
1050 %*********************************************************
1051
1052 Note [Splices]
1053 ~~~~~~~~~~~~~~
1054 Consider
1055         f = ...
1056         h = ...$(thing "f")...
1057
1058 The splice can expand into literally anything, so when we do dependency
1059 analysis we must assume that it might mention 'f'.  So we simply treat
1060 all locally-defined names as mentioned by any splice.  This is terribly
1061 brutal, but I don't see what else to do.  For example, it'll mean
1062 that every locally-defined thing will appear to be used, so no unused-binding
1063 warnings.  But if we miss the dependency, then we might typecheck 'h' before 'f',
1064 and that will crash the type checker because 'f' isn't in scope.
1065
1066 Currently, I'm not treating a splice as also mentioning every import,
1067 which is a bit inconsistent -- but there are a lot of them.  We might
1068 thereby get some bogus unused-import warnings, but we won't crash the
1069 type checker.  Not very satisfactory really.
1070
1071 \begin{code}
1072 rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
1073 rnSplice (HsSplice n expr)
1074   = do  { checkTH expr "splice"
1075         ; loc  <- getSrcSpanM
1076         ; [n'] <- newLocalsRn [L loc n]
1077         ; (expr', fvs) <- rnLExpr expr
1078
1079         -- Ugh!  See Note [Splices] above
1080         ; lcl_rdr <- getLocalRdrEnv
1081         ; gbl_rdr <- getGlobalRdrEnv
1082         ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr,
1083                                                     isLocalGRE gre]
1084               lcl_names = mkNameSet (occEnvElts lcl_rdr)
1085
1086         ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }
1087
1088 checkTH :: Outputable a => a -> String -> RnM ()
1089 #ifdef GHCI
1090 checkTH _ _ = returnM ()        -- OK
1091 #else
1092 checkTH e what  -- Raise an error in a stage-1 compiler
1093   = addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+>
1094                   ptext (sLit "illegal in a stage-1 compiler"),
1095                   nest 2 (ppr e)])
1096 #endif
1097 \end{code}