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