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