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