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