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