ghc/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, checkModDeprec,
  10         rnBindGroups, rnBindGroupsAndThen, rnSplice
  11     ) where
  12
  13 #include "HsVersions.h"
  14
  15 import HsSyn
  16 import RdrName          ( RdrName, isRdrDataCon, rdrNameOcc, elemLocalRdrEnv )
  17 import RdrHsSyn         ( extractGenericPatTyVars )
  18 import RnHsSyn
  19 import RnExpr           ( rnLExpr, checkTH )
  20 import RnTypes          ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
  21 import RnBinds          ( rnTopBinds, rnBinds, rnMethodBinds,
  22                           rnBindsAndThen, renameSigs, checkSigs )
  23 import RnEnv            ( lookupTopBndrRn, lookupTopFixSigNames,
  24                           lookupLocatedTopBndrRn, lookupLocatedOccRn,
  25                           lookupOccRn, newLocalsRn,
  26                           bindLocatedLocalsFV, bindPatSigTyVarsFV,
  27                           bindTyVarsRn, extendTyVarEnvFVRn,
  28                           bindLocalNames, newIPNameRn,
  29                           checkDupNames, mapFvRn,
  30                           unknownNameErr
  31                         )
  32 import TcRnMonad
  33
  34 import BasicTypes       ( TopLevelFlag(..)  )
  35 import HscTypes         ( FixityEnv, FixItem(..),
  36                           Deprecations, Deprecs(..), DeprecTxt, plusDeprecs )
  37 import Class            ( FunDep )
  38 import Name             ( Name )
  39 import NameSet
  40 import NameEnv
  41 import Outputable
  42 import SrcLoc           ( Located(..), unLoc, getLoc, noLoc )
  43 import CmdLineOpts      ( DynFlag(..) )
  44                                 -- Warn of unused for-all'd tyvars
  45 import Maybes           ( seqMaybe )
  46 import Maybe            ( catMaybes, isNothing )
  47 \end{code}
  48
  49 @rnSourceDecl@ `renames' declarations.
  50 It simultaneously performs dependency analysis and precedence parsing.
  51 It also does the following error checks:
  52 \begin{enumerate}
  53 \item
  54 Checks that tyvars are used properly. This includes checking
  55 for undefined tyvars, and tyvars in contexts that are ambiguous.
  56 (Some of this checking has now been moved to module @TcMonoType@,
  57 since we don't have functional dependency information at this point.)
  58 \item
  59 Checks that all variable occurences are defined.
  60 \item
  61 Checks the @(..)@ etc constraints in the export list.
  62 \end{enumerate}
  63
  64
  65 \begin{code}
  66 rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
  67
  68 rnSrcDecls (HsGroup { hs_valds  = [HsBindGroup binds sigs _],
  69                       hs_tyclds = tycl_decls,
  70                       hs_instds = inst_decls,
  71                       hs_fixds  = fix_decls,
  72                       hs_depds  = deprec_decls,
  73                       hs_fords  = foreign_decls,
  74                       hs_defds  = default_decls,
  75                       hs_ruleds = rule_decls })
  76
  77  = do {         -- Deal with deprecations (returns only the extra deprecations)
  78         deprecs <- rnSrcDeprecDecls deprec_decls ;
  79         updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` deprecs })
  80                   $ do {
  81
  82                 -- Deal with top-level fixity decls
  83                 -- (returns the total new fixity env)
  84         fix_env <- rnSrcFixityDecls fix_decls ;
  85         updGblEnv (\gbl -> gbl { tcg_fix_env = fix_env })
  86                   $ do {
  87
  88                 -- Rename other declarations
  89         traceRn (text "Start rnmono") ;
  90         (rn_val_decls, bind_dus) <- rnTopBinds binds sigs ;
  91         traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
  92
  93                 -- You might think that we could build proper def/use information
  94                 -- for type and class declarations, but they can be involved
  95                 -- in mutual recursion across modules, and we only do the SCC
  96                 -- analysis for them in the type checker.
  97                 -- So we content ourselves with gathering uses only; that
  98                 -- means we'll only report a declaration as unused if it isn't
  99                 -- mentioned at all.  Ah well.
 100         (rn_tycl_decls,    src_fvs1)
 101            <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls ;
 102         (rn_inst_decls,    src_fvs2)
 103            <- mapFvRn (wrapLocFstM rnSrcInstDecl) inst_decls ;
 104         (rn_rule_decls,    src_fvs3)
 105            <- mapFvRn (wrapLocFstM rnHsRuleDecl) rule_decls ;
 106         (rn_foreign_decls, src_fvs4)
 107            <- mapFvRn (wrapLocFstM rnHsForeignDecl) foreign_decls ;
 108         (rn_default_decls, src_fvs5)
 109            <- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ;
 110
 111         let {
 112            rn_group = HsGroup { hs_valds  = rn_val_decls,
 113                                 hs_tyclds = rn_tycl_decls,
 114                                 hs_instds = rn_inst_decls,
 115                                 hs_fixds  = [],
 116                                 hs_depds  = [],
 117                                 hs_fords  = rn_foreign_decls,
 118                                 hs_defds  = rn_default_decls,
 119                                 hs_ruleds = rn_rule_decls } ;
 120
 121            other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3,
 122                                 src_fvs4, src_fvs5] ;
 123            src_dus = bind_dus `plusDU` usesOnly other_fvs
 124                 -- Note: src_dus will contain *uses* for locally-defined types
 125                 -- and classes, but no *defs* for them.  (Because rnTyClDecl
 126                 -- returns only the uses.)  This is a little
 127                 -- surprising but it doesn't actually matter at all.
 128         } ;
 129
 130         traceRn (text "finish rnSrc" <+> ppr rn_group) ;
 131         traceRn (text "finish Dus" <+> ppr src_dus ) ;
 132         tcg_env <- getGblEnv ;
 133         return (tcg_env `addTcgDUs` src_dus, rn_group)
 134     }}}
 135
 136 rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name]
 137 rnTyClDecls tycl_decls = do
 138   (decls', fvs) <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls
 139   return decls'
 140
 141 addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
 142 addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
 143 \end{code}
 144
 145
 146 %*********************************************************
 147 %*                                                       *
 148         Source-code fixity declarations
 149 %*                                                       *
 150 %*********************************************************
 151
 152 \begin{code}
 153 rnSrcFixityDecls :: [LFixitySig RdrName] -> RnM FixityEnv
 154 rnSrcFixityDecls fix_decls
 155   = getGblEnv                                   `thenM` \ gbl_env ->
 156     foldlM rnFixityDecl (tcg_fix_env gbl_env)
 157             fix_decls                                   `thenM` \ fix_env ->
 158     traceRn (text "fixity env" <+> pprFixEnv fix_env)   `thenM_`
 159     returnM fix_env
 160
 161 rnFixityDecl :: FixityEnv -> LFixitySig RdrName -> RnM FixityEnv
 162 rnFixityDecl fix_env (L loc (FixitySig rdr_name fixity))
 163   = setSrcSpan loc $
 164         -- GHC extension: look up both the tycon and data con
 165         -- for con-like things
 166         -- If neither are in scope, report an error; otherwise
 167         -- add both to the fixity env
 168      addLocM lookupTopFixSigNames rdr_name      `thenM` \ names ->
 169      if null names then
 170           addLocErr rdr_name unknownNameErr     `thenM_`
 171           returnM fix_env
 172      else
 173           foldlM add fix_env names
 174   where
 175     add fix_env name
 176       = case lookupNameEnv fix_env name of
 177           Just (FixItem _ _ loc')
 178                   -> addLocErr rdr_name (dupFixityDecl loc')    `thenM_`
 179                      returnM fix_env
 180           Nothing -> returnM (extendNameEnv fix_env name fix_item)
 181       where
 182         fix_item = FixItem (rdrNameOcc (unLoc rdr_name)) fixity
 183                          (getLoc rdr_name)
 184
 185 pprFixEnv :: FixityEnv -> SDoc
 186 pprFixEnv env
 187   = pprWithCommas (\ (FixItem n f _) -> ppr f <+> ppr n)
 188                   (nameEnvElts env)
 189
 190 dupFixityDecl loc rdr_name
 191   = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
 192           ptext SLIT("also at ") <+> ppr loc
 193         ]
 194 \end{code}
 195
 196
 197 %*********************************************************
 198 %*                                                       *
 199         Source-code deprecations declarations
 200 %*                                                       *
 201 %*********************************************************
 202
 203 For deprecations, all we do is check that the names are in scope.
 204 It's only imported deprecations, dealt with in RnIfaces, that we
 205 gather them together.
 206
 207 \begin{code}
 208 rnSrcDeprecDecls :: [LDeprecDecl RdrName] -> RnM Deprecations
 209 rnSrcDeprecDecls []
 210   = returnM NoDeprecs
 211
 212 rnSrcDeprecDecls decls
 213   = mappM (addLocM rn_deprec) decls     `thenM` \ pairs ->
 214     returnM (DeprecSome (mkNameEnv (catMaybes pairs)))
 215  where
 216    rn_deprec (Deprecation rdr_name txt)
 217      = lookupTopBndrRn rdr_name `thenM` \ name ->
 218        returnM (Just (name, (rdrNameOcc rdr_name, txt)))
 219
 220 checkModDeprec :: Maybe DeprecTxt -> Deprecations
 221 -- Check for a module deprecation; done once at top level
 222 checkModDeprec Nothing    = NoDeprecs
 223 checkModDeprec (Just txt) = DeprecAll txt
 224 \end{code}
 225
 226 %*********************************************************
 227 %*                                                      *
 228 \subsection{Source code declarations}
 229 %*                                                      *
 230 %*********************************************************
 231
 232 \begin{code}
 233 rnDefaultDecl (DefaultDecl tys)
 234   = mapFvRn (rnHsTypeFVs doc_str) tys   `thenM` \ (tys', fvs) ->
 235     returnM (DefaultDecl tys', fvs)
 236   where
 237     doc_str = text "In a `default' declaration"
 238 \end{code}
 239
 240 %*********************************************************
 241 %*                                                      *
 242                 Bindings
 243 %*                                                      *
 244 %*********************************************************
 245
 246 These chaps are here, rather than in TcBinds, so that there
 247 is just one hi-boot file (for RnSource).  rnSrcDecls is part
 248 of the loop too, and it must be defined in this module.
 249
 250 \begin{code}
 251 rnBindGroups :: [HsBindGroup RdrName] -> RnM ([HsBindGroup Name], DefUses)
 252 -- This version assumes that the binders are already in scope
 253 -- It's used only in 'mdo'
 254 rnBindGroups []
 255    = returnM ([], emptyDUs)
 256 rnBindGroups [HsBindGroup bind sigs _]
 257    = rnBinds NotTopLevel bind sigs
 258 rnBindGroups b@[HsIPBinds bind]
 259    = do addErr (badIpBinds b)
 260         returnM ([], emptyDUs)
 261 rnBindGroups _
 262    = panic "rnBindGroups"
 263
 264 rnBindGroupsAndThen
 265   :: [HsBindGroup RdrName]
 266   -> ([HsBindGroup Name] -> RnM (result, FreeVars))
 267   -> RnM (result, FreeVars)
 268 -- This version (a) assumes that the binding vars are not already in scope
 269 --              (b) removes the binders from the free vars of the thing inside
 270 -- The parser doesn't produce ThenBinds
 271 rnBindGroupsAndThen [] thing_inside
 272   = thing_inside []
 273 rnBindGroupsAndThen [HsBindGroup bind sigs _] thing_inside
 274   = rnBindsAndThen bind sigs $ \ groups -> thing_inside groups
 275 rnBindGroupsAndThen [HsIPBinds binds] thing_inside
 276   = rnIPBinds binds                     `thenM` \ (binds',fv_binds) ->
 277     thing_inside [HsIPBinds binds']     `thenM` \ (thing, fvs_thing) ->
 278     returnM (thing, fvs_thing `plusFV` fv_binds)
 279
 280 rnIPBinds [] = returnM ([], emptyFVs)
 281 rnIPBinds (bind : binds)
 282   = wrapLocFstM rnIPBind bind   `thenM` \ (bind', fvBind) ->
 283     rnIPBinds binds             `thenM` \ (binds',fvBinds) ->
 284     returnM (bind' : binds', fvBind `plusFV` fvBinds)
 285
 286 rnIPBind (IPBind n expr)
 287   = newIPNameRn  n              `thenM` \ name ->
 288     rnLExpr expr                `thenM` \ (expr',fvExpr) ->
 289     return (IPBind name expr', fvExpr)
 290
 291 badIpBinds binds
 292   = hang (ptext SLIT("Implicit-parameter bindings illegal in 'mdo':")) 4
 293          (ppr binds)
 294 \end{code}
 295
 296
 297 %*********************************************************
 298 %*                                                      *
 299 \subsection{Foreign declarations}
 300 %*                                                      *
 301 %*********************************************************
 302
 303 \begin{code}
 304 rnHsForeignDecl (ForeignImport name ty spec isDeprec)
 305   = lookupLocatedTopBndrRn name         `thenM` \ name' ->
 306     rnHsTypeFVs (fo_decl_msg name) ty   `thenM` \ (ty', fvs) ->
 307     returnM (ForeignImport name' ty' spec isDeprec, fvs)
 308
 309 rnHsForeignDecl (ForeignExport name ty spec isDeprec)
 310   = lookupLocatedOccRn name             `thenM` \ name' ->
 311     rnHsTypeFVs (fo_decl_msg name) ty   `thenM` \ (ty', fvs) ->
 312     returnM (ForeignExport name' ty' spec isDeprec, fvs )
 313         -- NB: a foreign export is an *occurrence site* for name, so
 314         --     we add it to the free-variable list.  It might, for example,
 315         --     be imported from another module
 316
 317 fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name
 318 \end{code}
 319
 320
 321 %*********************************************************
 322 %*                                                      *
 323 \subsection{Instance declarations}
 324 %*                                                      *
 325 %*********************************************************
 326
 327 \begin{code}
 328 rnSrcInstDecl (InstDecl inst_ty mbinds uprags)
 329         -- Used for both source and interface file decls
 330   = rnHsSigType (text "an instance decl") inst_ty       `thenM` \ inst_ty' ->
 331
 332         -- Rename the bindings
 333         -- The typechecker (not the renamer) checks that all
 334         -- the bindings are for the right class
 335     let
 336         meth_doc    = text "In the bindings in an instance declaration"
 337         meth_names  = collectHsBindLocatedBinders mbinds
 338         (inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
 339     in
 340     checkDupNames meth_doc meth_names   `thenM_`
 341     extendTyVarEnvForMethodBinds inst_tyvars (
 342         -- (Slightly strangely) the forall-d tyvars scope over
 343         -- the method bindings too
 344         rnMethodBinds cls [] mbinds
 345     )                                           `thenM` \ (mbinds', meth_fvs) ->
 346         -- Rename the prags and signatures.
 347         -- Note that the type variables are not in scope here,
 348         -- so that      instance Eq a => Eq (T a) where
 349         --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
 350         -- works OK.
 351         --
 352         -- But the (unqualified) method names are in scope
 353     let
 354         binders = collectHsBindBinders mbinds'
 355     in
 356     bindLocalNames binders (renameSigs uprags)                  `thenM` \ uprags' ->
 357     checkSigs (okInstDclSig (mkNameSet binders)) uprags'        `thenM_`
 358
 359     returnM (InstDecl inst_ty' mbinds' uprags',
 360              meth_fvs `plusFV` hsSigsFVs uprags'
 361                       `plusFV` extractHsTyNames inst_ty')
 362 \end{code}
 363
 364 For the method bindings in class and instance decls, we extend the
 365 type variable environment iff -fglasgow-exts
 366
 367 \begin{code}
 368 extendTyVarEnvForMethodBinds tyvars thing_inside
 369   = doptM Opt_GlasgowExts                       `thenM` \ opt_GlasgowExts ->
 370     if opt_GlasgowExts then
 371         extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
 372     else
 373         thing_inside
 374 \end{code}
 375
 376
 377 %*********************************************************
 378 %*                                                      *
 379 \subsection{Rules}
 380 %*                                                      *
 381 %*********************************************************
 382
 383 \begin{code}
 384 rnHsRuleDecl (HsRule rule_name act vars lhs rhs)
 385   = bindPatSigTyVarsFV (collectRuleBndrSigTys vars)     $
 386
 387     bindLocatedLocalsFV doc (map get_var vars)          $ \ ids ->
 388     mapFvRn rn_var (vars `zip` ids)             `thenM` \ (vars', fv_vars) ->
 389
 390     rnLExpr lhs                                 `thenM` \ (lhs', fv_lhs) ->
 391     rnLExpr rhs                                 `thenM` \ (rhs', fv_rhs) ->
 392     let
 393         mb_bad = validRuleLhs ids lhs'
 394     in
 395     checkErr (isNothing mb_bad)
 396              (badRuleLhsErr rule_name lhs' mb_bad)      `thenM_`
 397     let
 398         bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
 399     in
 400     mappM (addErr . badRuleVar rule_name) bad_vars      `thenM_`
 401     returnM (HsRule rule_name act vars' lhs' rhs',
 402              fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
 403   where
 404     doc = text "In the transformation rule" <+> ftext rule_name
 405
 406     get_var (RuleBndr v)      = v
 407     get_var (RuleBndrSig v _) = v
 408
 409     rn_var (RuleBndr (L loc v), id)
 410         = returnM (RuleBndr (L loc id), emptyFVs)
 411     rn_var (RuleBndrSig (L loc v) t, id)
 412         = rnHsTypeFVs doc t     `thenM` \ (t', fvs) ->
 413           returnM (RuleBndrSig (L loc id) t', fvs)
 414 \end{code}
 415
 416 Check the shape of a transformation rule LHS.  Currently
 417 we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
 418 not one of the @forall@'d variables.  We also restrict the form of the LHS so
 419 that it may be plausibly matched.  Basically you only get to write ordinary
 420 applications.  (E.g. a case expression is not allowed: too elaborate.)
 421
 422 NB: if you add new cases here, make sure you add new ones to TcRule.ruleLhsTvs
 423
 424 \begin{code}
 425 validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
 426 -- Nothing => OK
 427 -- Just e  => Not ok, and e is the offending expression
 428 validRuleLhs foralls lhs
 429   = checkl lhs
 430   where
 431     checkl (L loc e) = check e
 432
 433     check (OpApp e1 op _ e2)              = checkl op `seqMaybe` checkl_e e1 `seqMaybe` checkl_e e2
 434     check (HsApp e1 e2)                   = checkl e1 `seqMaybe` checkl_e e2
 435     check (HsVar v) | v `notElem` foralls = Nothing
 436     check other                           = Just other  -- Failure
 437
 438     checkl_e (L loc e) = check_e e
 439
 440     check_e (HsVar v)     = Nothing
 441     check_e (HsPar e)     = checkl_e e
 442     check_e (HsLit e)     = Nothing
 443     check_e (HsOverLit e) = Nothing
 444
 445     check_e (OpApp e1 op _ e2)   = checkl_e e1 `seqMaybe` checkl_e op `seqMaybe` checkl_e e2
 446     check_e (HsApp e1 e2)        = checkl_e e1 `seqMaybe` checkl_e e2
 447     check_e (NegApp e _)         = checkl_e e
 448     check_e (ExplicitList _ es)  = checkl_es es
 449     check_e (ExplicitTuple es _) = checkl_es es
 450     check_e other                = Just other   -- Fails
 451
 452     checkl_es es = foldr (seqMaybe . checkl_e) Nothing es
 453
 454 badRuleLhsErr name lhs (Just bad_e)
 455   = sep [ptext SLIT("Rule") <+> ftext name <> colon,
 456          nest 4 (vcat [ptext SLIT("Illegal expression:") <+> ppr bad_e,
 457                        ptext SLIT("in left-hand side:") <+> ppr lhs])]
 458     $$
 459     ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
 460
 461 badRuleVar name var
 462   = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon,
 463          ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
 464                 ptext SLIT("does not appear on left hand side")]
 465 \end{code}
 466
 467
 468 %*********************************************************
 469 %*                                                      *
 470 \subsection{Type, class and iface sig declarations}
 471 %*                                                      *
 472 %*********************************************************
 473
 474 @rnTyDecl@ uses the `global name function' to create a new type
 475 declaration in which local names have been replaced by their original
 476 names, reporting any unknown names.
 477
 478 Renaming type variables is a pain. Because they now contain uniques,
 479 it is necessary to pass in an association list which maps a parsed
 480 tyvar to its @Name@ representation.
 481 In some cases (type signatures of values),
 482 it is even necessary to go over the type first
 483 in order to get the set of tyvars used by it, make an assoc list,
 484 and then go over it again to rename the tyvars!
 485 However, we can also do some scoping checks at the same time.
 486
 487 \begin{code}
 488 rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_name})
 489   = lookupLocatedTopBndrRn name         `thenM` \ name' ->
 490     returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
 491              emptyFVs)
 492
 493 rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon,
 494                     tcdTyVars = tyvars, tcdCons = condecls,
 495                     tcdKindSig = sig, tcdDerivs = derivs})
 496   | is_vanilla  -- Normal Haskell data type decl
 497   = ASSERT( isNothing sig )     -- In normal H98 form, kind signature on the
 498                                 -- data type is syntactically illegal
 499     bindTyVarsRn data_doc tyvars                $ \ tyvars' ->
 500     do  { tycon' <- lookupLocatedTopBndrRn tycon
 501         ; context' <- rnContext data_doc context
 502         ; (derivs', deriv_fvs) <- rn_derivs derivs
 503         ; checkDupNames data_doc con_names
 504         ; condecls' <- rnConDecls (unLoc tycon') condecls
 505         ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon',
 506                            tcdTyVars = tyvars', tcdKindSig = Nothing, tcdCons = condecls',
 507                            tcdDerivs = derivs'},
 508                    delFVs (map hsLTyVarName tyvars')    $
 509                    extractHsCtxtTyNames context'        `plusFV`
 510                    plusFVs (map conDeclFVs condecls') `plusFV`
 511                    deriv_fvs) }
 512
 513   | otherwise   -- GADT
 514   = ASSERT( null (unLoc context) )
 515     do  { tycon' <- lookupLocatedTopBndrRn tycon
 516         ; tyvars' <- bindTyVarsRn data_doc tyvars
 517                                   (\ tyvars' -> return tyvars')
 518                 -- For GADTs, the type variables in the declaration
 519                 -- do not scope over the constructor signatures
 520                 --      data T a where { T1 :: forall b. b-> b }
 521         ; (derivs', deriv_fvs) <- rn_derivs derivs
 522         ; checkDupNames data_doc con_names
 523         ; condecls' <- rnConDecls (unLoc tycon') condecls
 524         ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], tcdLName = tycon',
 525                            tcdTyVars = tyvars', tcdCons = condecls', tcdKindSig = sig,
 526                            tcdDerivs = derivs'},
 527                    plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) }
 528
 529   where
 530     is_vanilla = case condecls of       -- Yuk
 531                      []                    -> True
 532                      L _ (ConDecl {}) : _  -> True
 533                      other                 -> False
 534
 535     data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
 536     con_names = map con_names_helper condecls
 537
 538     con_names_helper (L _ (ConDecl n _ _ _)) = n
 539     con_names_helper (L _ (GadtDecl n _)) = n
 540
 541     rn_derivs Nothing   = returnM (Nothing, emptyFVs)
 542     rn_derivs (Just ds) = rnLHsTypes data_doc ds        `thenM` \ ds' ->
 543                           returnM (Just ds', extractHsTyNames_s ds')
 544
 545 rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars, tcdSynRhs = ty})
 546   = lookupLocatedTopBndrRn name                 `thenM` \ name' ->
 547     bindTyVarsRn syn_doc tyvars                 $ \ tyvars' ->
 548     rnHsTypeFVs syn_doc ty                      `thenM` \ (ty', fvs) ->
 549     returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars',
 550                         tcdSynRhs = ty'},
 551              delFVs (map hsLTyVarName tyvars') fvs)
 552   where
 553     syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
 554
 555 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
 556                        tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
 557                        tcdMeths = mbinds})
 558   = lookupLocatedTopBndrRn cname                `thenM` \ cname' ->
 559
 560         -- Tyvars scope over superclass context and method signatures
 561     bindTyVarsRn cls_doc tyvars                 ( \ tyvars' ->
 562         rnContext cls_doc context       `thenM` \ context' ->
 563         rnFds cls_doc fds               `thenM` \ fds' ->
 564         renameSigs sigs                 `thenM` \ sigs' ->
 565         returnM   (tyvars', context', fds', sigs')
 566     )   `thenM` \ (tyvars', context', fds', sigs') ->
 567
 568         -- Check the signatures
 569         -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
 570     let
 571         sig_rdr_names_w_locs   = [op | L _ (Sig op _) <- sigs]
 572     in
 573     checkDupNames sig_doc sig_rdr_names_w_locs  `thenM_`
 574     checkSigs okClsDclSig sigs'                         `thenM_`
 575         -- Typechecker is responsible for checking that we only
 576         -- give default-method bindings for things in this class.
 577         -- The renamer *could* check this for class decls, but can't
 578         -- for instance decls.
 579
 580         -- The newLocals call is tiresome: given a generic class decl
 581         --      class C a where
 582         --        op :: a -> a
 583         --        op {| x+y |} (Inl a) = ...
 584         --        op {| x+y |} (Inr b) = ...
 585         --        op {| a*b |} (a*b)   = ...
 586         -- we want to name both "x" tyvars with the same unique, so that they are
 587         -- easy to group together in the typechecker.
 588     extendTyVarEnvForMethodBinds tyvars' (
 589          getLocalRdrEnv                                 `thenM` \ name_env ->
 590          let
 591              meth_rdr_names_w_locs = collectHsBindLocatedBinders mbinds
 592              gen_rdr_tyvars_w_locs =
 593                 [ tv | tv <- extractGenericPatTyVars mbinds,
 594                       not (unLoc tv `elemLocalRdrEnv` name_env) ]
 595          in
 596          checkDupNames meth_doc meth_rdr_names_w_locs   `thenM_`
 597          newLocalsRn gen_rdr_tyvars_w_locs      `thenM` \ gen_tyvars ->
 598          rnMethodBinds (unLoc cname') gen_tyvars mbinds
 599     ) `thenM` \ (mbinds', meth_fvs) ->
 600
 601     returnM (ClassDecl { tcdCtxt = context', tcdLName = cname', tcdTyVars = tyvars',
 602                          tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds'},
 603              delFVs (map hsLTyVarName tyvars')  $
 604              extractHsCtxtTyNames context'          `plusFV`
 605              plusFVs (map extractFunDepNames (map unLoc fds'))  `plusFV`
 606              hsSigsFVs sigs'                        `plusFV`
 607              meth_fvs)
 608   where
 609     meth_doc = text "In the default-methods for class"  <+> ppr cname
 610     cls_doc  = text "In the declaration for class"      <+> ppr cname
 611     sig_doc  = text "In the signatures for class"       <+> ppr cname
 612 \end{code}
 613
 614 %*********************************************************
 615 %*                                                      *
 616 \subsection{Support code for type/data declarations}
 617 %*                                                      *
 618 %*********************************************************
 619
 620 \begin{code}
 621 rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
 622 rnConDecls tycon condecls
 623   =     -- Check that there's at least one condecl,
 624         -- or else we're reading an interface file, or -fglasgow-exts
 625     (if null condecls then
 626         doptM Opt_GlasgowExts   `thenM` \ glaExts ->
 627         checkErr glaExts (emptyConDeclsErr tycon)
 628      else returnM ()
 629     )                                           `thenM_`
 630     mappM (wrapLocM rnConDecl) condecls
 631
 632 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
 633 rnConDecl (ConDecl name tvs cxt details)
 634   = addLocM checkConName name           `thenM_`
 635     lookupLocatedTopBndrRn name         `thenM` \ new_name ->
 636
 637     bindTyVarsRn doc tvs                $ \ new_tyvars ->
 638     rnContext doc cxt                   `thenM` \ new_context ->
 639     rnConDetails doc details            `thenM` \ new_details ->
 640     returnM (ConDecl new_name new_tyvars new_context new_details)
 641   where
 642     doc = text "In the definition of data constructor" <+> quotes (ppr name)
 643
 644 rnConDecl (GadtDecl name ty)
 645   = addLocM checkConName name           `thenM_`
 646     lookupLocatedTopBndrRn name         `thenM` \ new_name ->
 647     rnHsSigType doc ty                  `thenM` \ new_ty ->
 648     returnM (GadtDecl new_name new_ty)
 649   where
 650     doc = text "In the definition of data constructor" <+> quotes (ppr name)
 651
 652 rnConDetails doc (PrefixCon tys)
 653   = mappM (rnLHsType doc) tys   `thenM` \ new_tys  ->
 654     returnM (PrefixCon new_tys)
 655
 656 rnConDetails doc (InfixCon ty1 ty2)
 657   = rnLHsType doc ty1           `thenM` \ new_ty1 ->
 658     rnLHsType doc ty2           `thenM` \ new_ty2 ->
 659     returnM (InfixCon new_ty1 new_ty2)
 660
 661 rnConDetails doc (RecCon fields)
 662   = checkDupNames doc field_names       `thenM_`
 663     mappM (rnField doc) fields          `thenM` \ new_fields ->
 664     returnM (RecCon new_fields)
 665   where
 666     field_names = [fld | (fld, _) <- fields]
 667
 668 rnField doc (name, ty)
 669   = lookupLocatedTopBndrRn name `thenM` \ new_name ->
 670     rnLHsType doc ty            `thenM` \ new_ty ->
 671     returnM (new_name, new_ty)
 672
 673 -- This data decl will parse OK
 674 --      data T = a Int
 675 -- treating "a" as the constructor.
 676 -- It is really hard to make the parser spot this malformation.
 677 -- So the renamer has to check that the constructor is legal
 678 --
 679 -- We can get an operator as the constructor, even in the prefix form:
 680 --      data T = :% Int Int
 681 -- from interface files, which always print in prefix form
 682
 683 checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
 684
 685 badDataCon name
 686    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 687
 688 emptyConDeclsErr tycon
 689   = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
 690          nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))]
 691 \end{code}
 692
 693
 694 %*********************************************************
 695 %*                                                      *
 696 \subsection{Support code to rename types}
 697 %*                                                      *
 698 %*********************************************************
 699
 700 \begin{code}
 701 rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
 702
 703 rnFds doc fds
 704   = mappM (wrapLocM rn_fds) fds
 705   where
 706     rn_fds (tys1, tys2)
 707       = rnHsTyVars doc tys1             `thenM` \ tys1' ->
 708         rnHsTyVars doc tys2             `thenM` \ tys2' ->
 709         returnM (tys1', tys2')
 710
 711 rnHsTyVars doc tvs  = mappM (rnHsTyvar doc) tvs
 712 rnHsTyvar doc tyvar = lookupOccRn tyvar
 713 \end{code}
 714
 715
 716 %*********************************************************
 717 %*                                                      *
 718                 Splices
 719 %*                                                      *
 720 %*********************************************************
 721
 722 \begin{code}
 723 rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
 724 rnSplice (HsSplice n expr)
 725   = checkTH expr "splice"       `thenM_`
 726     getSrcSpanM                 `thenM` \ loc ->
 727     newLocalsRn [L loc n]       `thenM` \ [n'] ->
 728     rnLExpr expr                `thenM` \ (expr', fvs) ->
 729     returnM (HsSplice n' expr', fvs)
 730 \end{code}