[project @ 2004-11-09 13:28:13 by simonpj]

[ghc-hetmet.git] / ghc / compiler / rename / RnSource.lhs

diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 7b85d5d..6ee9f8a 100644 (file)
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -1,430 +1,319 @@
 %
 %

-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998

 %
 \section[RnSource]{Main pass of renamer}
 
 \begin{code}
 %
 \section[RnSource]{Main pass of renamer}
 
 \begin{code}

-#include "HsVersions.h"
-
-module RnSource ( rnSource, rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType ) where
+module RnSource ( 
+       rnSrcDecls, addTcgDUs, 
+       rnTyClDecls, checkModDeprec,
+       rnBindGroups, rnBindGroupsAndThen, rnSplice
+    ) where

 
 

-import Ubiq
-import RnLoop          -- *check* the RnPass/RnExpr/RnBinds loop-breaking
+#include "HsVersions.h"

 
 import HsSyn
 
 import HsSyn

-import HsPragmas
-import RdrHsSyn
+import RdrName         ( RdrName, isRdrDataCon, rdrNameOcc, elemLocalRdrEnv )
+import RdrHsSyn                ( extractGenericPatTyVars )

 import RnHsSyn
 import RnHsSyn

-import RnMonad
-import RnBinds         ( rnTopBinds, rnMethodBinds )
-import RnUtils         ( lookupGlobalRnEnv, lubExportFlag )
-
-import Bag             ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList )
-import Class           ( derivableClassKeys )
-import ErrUtils                ( addErrLoc, addShortErrLocLine )
-import FiniteMap       ( emptyFM, lookupFM, addListToFM_C )
-import ListSetOps      ( unionLists, minusList )
-import Maybes          ( maybeToBool, catMaybes )
-import Name            ( Name, isLocallyDefined, isLexVarId, getLocalName, ExportFlag(..), 
-                         nameImportFlag, RdrName, pprNonSym )
-import Outputable -- ToDo:rm
-import PprStyle -- ToDo:rm 
-import Pretty
-import SrcLoc          ( SrcLoc )
-import Unique          ( Unique )
-import UniqFM          ( emptyUFM, addListToUFM_C, listToUFM, lookupUFM, eltsUFM )
-import UniqSet         ( UniqSet(..) )
-import Util            ( isIn, isn'tIn, sortLt, removeDups, cmpPString, assertPanic, pprTrace{-ToDo:rm-} )
+import RnExpr          ( rnLExpr, checkTH )
+import RnTypes         ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
+import RnBinds         ( rnTopBinds, rnBinds, rnMethodBinds, 
+                         rnBindsAndThen, renameSigs, checkSigs )
+import RnEnv           ( lookupTopBndrRn, lookupTopFixSigNames,
+                         lookupLocatedTopBndrRn, lookupLocatedOccRn,
+                         lookupOccRn, newLocalsRn, 
+                         bindLocatedLocalsFV, bindPatSigTyVarsFV,
+                         bindTyVarsRn, extendTyVarEnvFVRn,
+                         bindLocalNames, newIPNameRn,
+                         checkDupNames, mapFvRn,
+                         unknownNameErr
+                       )
+import TcRnMonad
+
+import BasicTypes      ( TopLevelFlag(..)  )
+import HscTypes                ( FixityEnv, FixItem(..),
+                         Deprecations, Deprecs(..), DeprecTxt, plusDeprecs )
+import Class           ( FunDep )
+import Name            ( Name, nameOccName )
+import NameSet
+import NameEnv
+import Outputable
+import SrcLoc          ( Located(..), unLoc, getLoc, noLoc )
+import CmdLineOpts     ( DynFlag(..) )
+                               -- Warn of unused for-all'd tyvars
+import Maybes          ( seqMaybe )
+import Maybe            ( catMaybes, isNothing )

 \end{code}
 
 \end{code}
 

-rnSource `renames' the source module and export list.
+@rnSourceDecl@ `renames' declarations.

 It simultaneously performs dependency analysis and precedence parsing.
 It also does the following error checks:
 \begin{enumerate}
 \item
 Checks that tyvars are used properly. This includes checking
 for undefined tyvars, and tyvars in contexts that are ambiguous.
 It simultaneously performs dependency analysis and precedence parsing.
 It also does the following error checks:
 \begin{enumerate}
 \item
 Checks that tyvars are used properly. This includes checking
 for undefined tyvars, and tyvars in contexts that are ambiguous.

+(Some of this checking has now been moved to module @TcMonoType@,
+since we don't have functional dependency information at this point.)

 \item
 Checks that all variable occurences are defined.
 \item 
 \item
 Checks that all variable occurences are defined.
 \item 

-Checks the (..) etc constraints in the export list.
+Checks the @(..)@ etc constraints in the export list.

 \end{enumerate}
 
 
 \begin{code}
 \end{enumerate}
 
 
 \begin{code}

-rnSource :: [Module]
-        -> Bag (Module,RnName)         -- unqualified imports from module
-        -> Bag RenamedFixityDecl       -- fixity info for imported names
-        -> RdrNameHsModule
-        -> RnM s (RenamedHsModule,
-                  Name -> ExportFlag,          -- export info
-                  Bag (RnName, RdrName))       -- occurrence info
-
-rnSource imp_mods unqual_imps imp_fixes
-       (HsModule mod version exports _ fixes
-          ty_decls specdata_sigs class_decls
-          inst_decls specinst_sigs defaults
-          binds _ src_loc)
-
-  = pushSrcLocRn src_loc $
-
-    rnExports (mod:imp_mods) unqual_imps exports       `thenRn` \ exported_fn ->
-    rnFixes fixes                                      `thenRn` \ src_fixes ->
-    let
-       pair_name inf = (nameFixDecl inf, inf)
-
-       all_fixes    = src_fixes ++ bagToList imp_fixes
-       all_fixes_fm = listToUFM (map pair_name all_fixes)
-    in
-    setExtraRn all_fixes_fm $
-
-    mapRn rnTyDecl     ty_decls        `thenRn` \ new_ty_decls ->
-    mapRn rnSpecDataSig specdata_sigs  `thenRn` \ new_specdata_sigs ->
-    mapRn rnClassDecl  class_decls     `thenRn` \ new_class_decls ->
-    mapRn rnInstDecl   inst_decls      `thenRn` \ new_inst_decls ->
-    mapRn rnSpecInstSig specinst_sigs   `thenRn` \ new_specinst_sigs ->
-    rnDefaultDecl      defaults        `thenRn` \ new_defaults ->
-    rnTopBinds binds                   `thenRn` \ new_binds ->
-
-    getOccurrenceUpRn                  `thenRn` \ occ_info ->
-
-    returnRn (
-             HsModule mod version
-               trashed_exports trashed_imports all_fixes
-               new_ty_decls new_specdata_sigs new_class_decls
-               new_inst_decls new_specinst_sigs new_defaults
-               new_binds [] src_loc,
-             exported_fn,
-             occ_info
-            )
-  where
-    trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing
-    trashed_imports = {-trace "rnSource:trashed_imports"-} []
+rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
+
+rnSrcDecls (HsGroup { hs_valds  = [HsBindGroup binds sigs _],
+                     hs_tyclds = tycl_decls,
+                     hs_instds = inst_decls,
+                     hs_fixds  = fix_decls,
+                     hs_depds  = deprec_decls,
+                     hs_fords  = foreign_decls,
+                     hs_defds  = default_decls,
+                     hs_ruleds = rule_decls })
+
+ = do {                -- Deal with deprecations (returns only the extra deprecations)
+       deprecs <- rnSrcDeprecDecls deprec_decls ;
+       updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` deprecs })
+                 $ do {
+
+               -- Deal with top-level fixity decls 
+               -- (returns the total new fixity env)
+       fix_env <- rnSrcFixityDecls fix_decls ;
+       updGblEnv (\gbl -> gbl { tcg_fix_env = fix_env })
+                 $ do {
+
+               -- Rename other declarations
+       traceRn (text "Start rnmono") ;
+       (rn_val_decls, bind_dus) <- rnTopBinds binds sigs ;
+       traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
+
+               -- You might think that we could build proper def/use information
+               -- for type and class declarations, but they can be involved
+               -- in mutual recursion across modules, and we only do the SCC
+               -- analysis for them in the type checker.
+               -- So we content ourselves with gathering uses only; that
+               -- means we'll only report a declaration as unused if it isn't
+               -- mentioned at all.  Ah well.
+       (rn_tycl_decls,    src_fvs1)
+          <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls ;
+       (rn_inst_decls,    src_fvs2)
+          <- mapFvRn (wrapLocFstM rnSrcInstDecl) inst_decls ;
+       (rn_rule_decls,    src_fvs3)
+          <- mapFvRn (wrapLocFstM rnHsRuleDecl) rule_decls ;
+       (rn_foreign_decls, src_fvs4)
+          <- mapFvRn (wrapLocFstM rnHsForeignDecl) foreign_decls ;
+       (rn_default_decls, src_fvs5)
+          <- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ;
+       
+       let {
+          rn_group = HsGroup { hs_valds  = rn_val_decls,
+                               hs_tyclds = rn_tycl_decls,
+                               hs_instds = rn_inst_decls,
+                               hs_fixds  = [],
+                               hs_depds  = [],
+                               hs_fords  = rn_foreign_decls,
+                               hs_defds  = rn_default_decls,
+                               hs_ruleds = rn_rule_decls } ;
+
+          other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, 
+                               src_fvs4, src_fvs5] ;
+          src_dus = bind_dus `plusDU` usesOnly other_fvs 
+               -- Note: src_dus will contain *uses* for locally-defined types
+               -- and classes, but no *defs* for them.  (Because rnTyClDecl 
+               -- returns only the uses.)  This is a little 
+               -- surprising but it doesn't actually matter at all.
+       } ;
+
+       traceRn (text "finish rnSrc" <+> ppr rn_group) ;
+       traceRn (text "finish Dus" <+> ppr src_dus ) ;
+       tcg_env <- getGblEnv ;
+       return (tcg_env `addTcgDUs` src_dus, rn_group)
+    }}}
+
+rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name]
+rnTyClDecls tycl_decls = do 
+  (decls', fvs) <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls
+  return decls'
+
+addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv 
+addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }

 \end{code}
 
 
 %*********************************************************
 \end{code}
 
 
 %*********************************************************

-%*                                                     *
-\subsection{Export list}
-%*                                                     *
+%*                                                      *
+       Source-code fixity declarations
+%*                                                      *

 %*********************************************************
 
 \begin{code}
 %*********************************************************
 
 \begin{code}

-rnExports :: [Module]
-         -> Bag (Module,RnName)
-         -> Maybe [RdrNameIE]
-         -> RnM s (Name -> ExportFlag)
+rnSrcFixityDecls :: [LFixitySig RdrName] -> RnM FixityEnv
+rnSrcFixityDecls fix_decls
+  = getGblEnv                                  `thenM` \ gbl_env ->
+    foldlM rnFixityDecl (tcg_fix_env gbl_env) 
+           fix_decls                                   `thenM` \ fix_env ->
+    traceRn (text "fixity env" <+> pprFixEnv fix_env)  `thenM_`
+    returnM fix_env
+
+rnFixityDecl :: FixityEnv -> LFixitySig RdrName -> RnM FixityEnv
+rnFixityDecl fix_env (L loc (FixitySig rdr_name fixity))
+  = setSrcSpan loc $
+        -- GHC extension: look up both the tycon and data con 
+       -- for con-like things
+       -- If neither are in scope, report an error; otherwise
+       -- add both to the fixity env
+     addLocM lookupTopFixSigNames rdr_name     `thenM` \ names ->
+     if null names then
+         addLocErr rdr_name unknownNameErr     `thenM_`
+         returnM fix_env
+     else
+         foldlM add fix_env names
+  where
+    add fix_env name
+      = case lookupNameEnv fix_env name of
+          Just (FixItem _ _ loc') 
+                 -> addLocErr rdr_name (dupFixityDecl loc')    `thenM_`
+                    returnM fix_env
+         Nothing -> returnM (extendNameEnv fix_env name fix_item)
+      where
+       fix_item = FixItem (nameOccName name) fixity (getLoc rdr_name)

 
 

-rnExports mods unqual_imps Nothing
-  = returnRn (\n -> if isLocallyDefined n then ExportAll else NotExported)
+pprFixEnv :: FixityEnv -> SDoc
+pprFixEnv env 
+  = pprWithCommas (\ (FixItem n f _) -> ppr f <+> ppr n)
+                 (nameEnvElts env)

 
 

-rnExports mods unqual_imps (Just exps)
-  = mapAndUnzipRn (rnIE mods) exps `thenRn` \ (mod_maybes, exp_bags) ->
-    let 
-        exp_names = bagToList (unionManyBags exp_bags)
-        exp_mods  = catMaybes mod_maybes
-
-       -- Warn for duplicate names and modules
-       (uniq_exp_names, dup_names) = removeDups cmp_fst exp_names
-       (uniq_exp_mods,  dup_mods)  = removeDups cmpPString exp_mods
-       cmp_fst (x,_) (y,_) = x `cmp` y
-
-       -- Build finite map of exported names to export flag
-       exp_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst uniq_exp_names)
-       (exp_map1, empty_mods) = foldl add_mod_names (exp_map0, []) uniq_exp_mods
-
-       mod_fm = addListToFM_C unionBags emptyFM
-                [(mod, unitBag (getName rn, nameImportFlag (getName rn)))
-                 | (mod,rn) <- bagToList unqual_imps]
-
-        add_mod_names (exp_map, empty) mod
-         = case lookupFM mod_fm mod of
-             Nothing        -> (exp_map, mod:empty)
-             Just mod_names -> (addListToUFM_C lub_expflag exp_map (map pair_fst (bagToList mod_names)), empty)
-
-       pair_fst p@(f,_) = (f,p)
-       lub_expflag (n, flag1) (_, flag2) = (n, lubExportFlag flag1 flag2)
-
-       -- Check for exporting of duplicate local names
-       exp_locals = [(getLocalName n, n) | (n,_) <- eltsUFM exp_map1]
-       (_, dup_locals) = removeDups cmp_local exp_locals
-       cmp_local (x,_) (y,_) = x `cmpPString` y
-
-       -- Build export flag function
-       exp_fn n = case lookupUFM exp_map1 n of
-                    Nothing       -> NotExported
-                    Just (_,flag) -> flag
-    in
-    getSrcLocRn                                                `thenRn` \ src_loc ->
-    mapRn (addWarnRn . dupNameExportWarn  src_loc) dup_names   `thenRn_`
-    mapRn (addWarnRn . dupModExportWarn   src_loc) dup_mods    `thenRn_`
-    mapRn (addWarnRn . emptyModExportWarn src_loc) empty_mods  `thenRn_`
-    mapRn (addErrRn  . dupLocalsExportErr src_loc) dup_locals  `thenRn_`
-    returnRn exp_fn
-
-
-rnIE mods (IEVar name)
-  = lookupValue name   `thenRn` \ rn ->
-    checkIEVar rn      `thenRn` \ exps ->
-    returnRn (Nothing, exps)
-  where
-    checkIEVar (RnName n)         = returnRn (unitBag (n,ExportAll))
-    checkIEVar rn@(RnClassOp _ _) = getSrcLocRn `thenRn` \ src_loc ->
-                                   failButContinueRn emptyBag (classOpExportErr rn src_loc)
-    checkIEVar rn                = returnRn emptyBag
-
-rnIE mods (IEThingAbs name)
-  = lookupTyConOrClass name    `thenRn` \ rn ->
-    checkIEAbs rn              `thenRn` \ exps ->
-    returnRn (Nothing, exps)
-  where
-    checkIEAbs (RnSyn n)      = returnRn (unitBag (n,ExportAbs))
-    checkIEAbs (RnData n _ _) = returnRn (unitBag (n,ExportAbs))
-    checkIEAbs (RnClass n _)  = returnRn (unitBag (n,ExportAbs))
-    checkIEAbs rn             = returnRn emptyBag
-
-rnIE mods (IEThingAll name)
-  = lookupTyConOrClass name    `thenRn` \ rn ->
-    checkIEAll rn              `thenRn` \ exps ->
-    checkImportAll rn           `thenRn_`
-    returnRn (Nothing, exps)
-  where
-    checkIEAll (RnData n cons fields) = returnRn (exp_all n `consBag` listToBag (map exp_all cons)
-                                                         `unionBags` listToBag (map exp_all fields))
-    checkIEAll (RnClass n ops)        = returnRn (exp_all n `consBag` listToBag (map exp_all ops))
-    checkIEAll rn@(RnSyn _)           = getSrcLocRn `thenRn` \ src_loc ->
-                                       warnAndContinueRn emptyBag (synAllExportErr rn src_loc)
-    checkIEAll rn                     = returnRn emptyBag
-
-    exp_all n = (n, ExportAll)
-
-rnIE mods (IEThingWith name names)
-  = lookupTyConOrClass name    `thenRn` \ rn ->
-    mapRn lookupValue names    `thenRn` \ rns ->
-    checkIEWith rn rns         `thenRn` \ exps ->
-    checkImportAll rn          `thenRn_`
-    returnRn (Nothing, exps)
-  where
-    checkIEWith rn@(RnData n cons fields) rns
-       | same_names (cons++fields) rns
-       = returnRn (consBag (exp_all n) (listToBag (map exp_all cons)))
-       | otherwise
-       = rnWithErr "constructrs (and fields)" rn (cons++fields) rns 
-    checkIEWith rn@(RnClass n ops) rns
-       | same_names ops rns
-       = returnRn (consBag (exp_all n) (listToBag (map exp_all ops)))
-       | otherwise
-       = rnWithErr "class ops" rn ops rns
-    checkIEWith rn@(RnSyn _) rns
-       = getSrcLocRn `thenRn` \ src_loc ->
-         failButContinueRn emptyBag (synAllExportErr rn src_loc)
-    checkIEWith rn rns
-       = returnRn emptyBag
-
-    exp_all n = (n, ExportAll)
-
-    same_names has rns
-      = all (not.isRnUnbound) rns &&
-       sortLt (<) (map uniqueOf has) == sortLt (<) (map uniqueOf rns)
-
-    rnWithErr str rn has rns
-      = getSrcLocRn `thenRn` \ src_loc ->
-       failButContinueRn emptyBag (withExportErr str rn has rns src_loc)
-
-rnIE mods (IEModuleContents mod)
-  | isIn "rnIE:IEModule" mod mods
-  = returnRn (Just mod, emptyBag)
-  | otherwise
-  = getSrcLocRn `thenRn` \ src_loc ->
-    failButContinueRn (Nothing,emptyBag) (badModExportErr mod src_loc)
-
-
-checkImportAll rn 
-  = case nameImportFlag (getName rn) of
-      ExportAll -> returnRn ()
-      exp      -> getSrcLocRn `thenRn` \ src_loc ->
-                  addErrRn (importAllErr rn src_loc)
+dupFixityDecl loc rdr_name
+  = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
+         ptext SLIT("also at ") <+> ppr loc
+       ]

 \end{code}
 
 \end{code}
 

+

 %*********************************************************
 %*********************************************************

-%*                                                     *
-\subsection{Type declarations}
-%*                                                     *
+%*                                                      *
+       Source-code deprecations declarations
+%*                                                      *

 %*********************************************************
 
 %*********************************************************
 

-@rnTyDecl@ uses the `global name function' to create a new type
-declaration in which local names have been replaced by their original
-names, reporting any unknown names.
-
-Renaming type variables is a pain. Because they now contain uniques,
-it is necessary to pass in an association list which maps a parsed
-tyvar to its Name representation. In some cases (type signatures of
-values), it is even necessary to go over the type first in order to
-get the set of tyvars used by it, make an assoc list, and then go over
-it again to rename the tyvars! However, we can also do some scoping
-checks at the same time.
+For deprecations, all we do is check that the names are in scope.
+It's only imported deprecations, dealt with in RnIfaces, that we
+gather them together.

 
 \begin{code}
 
 \begin{code}

-rnTyDecl :: RdrNameTyDecl -> RnM_Fixes s RenamedTyDecl
-
-rnTyDecl (TyData context tycon tyvars condecls derivings pragmas src_loc)
-  = pushSrcLocRn src_loc $
-    lookupTyCon tycon                 `thenRn` \ tycon' ->
-    mkTyVarNamesEnv src_loc tyvars     `thenRn` \ (tv_env, tyvars') ->
-    rnContext tv_env context          `thenRn` \ context' ->
-    rnConDecls tv_env condecls        `thenRn` \ condecls' ->
-    rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
-    ASSERT(isNoDataPragmas pragmas)
-    returnRn (TyData context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc)
-
-rnTyDecl (TyNew context tycon tyvars condecl derivings pragmas src_loc)
-  = pushSrcLocRn src_loc $
-    lookupTyCon tycon                `thenRn` \ tycon' ->
-    mkTyVarNamesEnv src_loc tyvars    `thenRn` \ (tv_env, tyvars') ->
-    rnContext tv_env context         `thenRn` \ context' ->
-    rnConDecls tv_env condecl        `thenRn` \ condecl' ->
-    rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
-    ASSERT(isNoDataPragmas pragmas)
-    returnRn (TyNew context' tycon' tyvars' condecl' derivings' noDataPragmas src_loc)
-
-rnTyDecl (TySynonym name tyvars ty src_loc)
-  = pushSrcLocRn src_loc $
-    lookupTyCon name               `thenRn` \ name' ->
-    mkTyVarNamesEnv src_loc tyvars  `thenRn` \ (tv_env, tyvars') ->
-    rnMonoType tv_env ty           `thenRn` \ ty' ->
-    returnRn (TySynonym name' tyvars' ty' src_loc)
-
-rn_derivs tycon2 locn Nothing -- derivs not specified
-  = returnRn Nothing
-
-rn_derivs tycon2 locn (Just ds)
-  = mapRn (rn_deriv tycon2 locn) ds `thenRn` \ derivs ->
-    returnRn (Just derivs)
-  where
-    rn_deriv tycon2 locn clas
-      = lookupClass clas           `thenRn` \ clas_name ->
-       addErrIfRn (uniqueOf clas_name `not_elem` derivableClassKeys)
-                  (derivingNonStdClassErr clas locn)
-                                   `thenRn_`
-       returnRn clas_name
-      where
-       not_elem = isn'tIn "rn_deriv"
+rnSrcDeprecDecls :: [LDeprecDecl RdrName] -> RnM Deprecations
+rnSrcDeprecDecls [] 
+  = returnM NoDeprecs
+
+rnSrcDeprecDecls decls
+  = mappM (addLocM rn_deprec) decls    `thenM` \ pairs ->
+    returnM (DeprecSome (mkNameEnv (catMaybes pairs)))
+ where
+   rn_deprec (Deprecation rdr_name txt)
+     = lookupTopBndrRn rdr_name        `thenM` \ name ->
+       returnM (Just (name, (rdrNameOcc rdr_name, txt)))
+
+checkModDeprec :: Maybe DeprecTxt -> Deprecations
+-- Check for a module deprecation; done once at top level
+checkModDeprec Nothing    = NoDeprecs
+checkModDeprec (Just txt) = DeprecAll txt

 \end{code}
 
 \end{code}
 

-@rnConDecls@ uses the `global name function' to create a new
-constructor in which local names have been replaced by their original
-names, reporting any unknown names.
+%*********************************************************
+%*                                                     *
+\subsection{Source code declarations}
+%*                                                     *
+%*********************************************************

 
 \begin{code}
 
 \begin{code}

-rnConDecls :: TyVarNamesEnv
-          -> [RdrNameConDecl]
-          -> RnM_Fixes s [RenamedConDecl]
-
-rnConDecls tv_env con_decls
-  = mapRn rn_decl con_decls
+rnDefaultDecl (DefaultDecl tys)
+  = mapFvRn (rnHsTypeFVs doc_str) tys  `thenM` \ (tys', fvs) ->
+    returnM (DefaultDecl tys', fvs)

   where
   where

-    rn_decl (ConDecl name tys src_loc)
-      = pushSrcLocRn src_loc $
-       lookupConstr name       `thenRn` \ new_name ->
-       mapRn rn_bang_ty tys    `thenRn` \ new_tys  ->
-       returnRn (ConDecl new_name new_tys src_loc)
-
-    rn_decl (ConOpDecl ty1 op ty2 src_loc)
-      = pushSrcLocRn src_loc $
-       lookupConstr op         `thenRn` \ new_op  ->
-       rn_bang_ty ty1          `thenRn` \ new_ty1 ->
-       rn_bang_ty ty2          `thenRn` \ new_ty2 ->
-       returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc)
-
-    rn_decl (NewConDecl name ty src_loc)
-      = pushSrcLocRn src_loc $
-       lookupConstr name       `thenRn` \ new_name ->
-       rn_mono_ty ty           `thenRn` \ new_ty  ->
-       returnRn (NewConDecl new_name new_ty src_loc)
-
-    rn_decl (RecConDecl name fields src_loc)
-      = pushSrcLocRn src_loc $
-       lookupConstr name       `thenRn` \ new_name ->
-       mapRn rn_field fields   `thenRn` \ new_fields ->
-       returnRn (RecConDecl new_name new_fields src_loc)
-
-    rn_field (names, ty)
-      = mapRn lookupField names `thenRn` \ new_names ->
-       rn_bang_ty ty           `thenRn` \ new_ty ->
-       returnRn (new_names, new_ty) 
-
-    rn_mono_ty = rnMonoType tv_env
-
-    rn_bang_ty (Banged ty)
-      = rn_mono_ty ty `thenRn` \ new_ty ->
-       returnRn (Banged new_ty)
-    rn_bang_ty (Unbanged ty)
-      = rn_mono_ty ty `thenRn` \ new_ty ->
-       returnRn (Unbanged new_ty)
+    doc_str = text "In a `default' declaration"

 \end{code}
 
 %*********************************************************
 \end{code}
 
 %*********************************************************

-%*                                                      *
-\subsection{SPECIALIZE data pragmas}
-%*                                                      *
+%*                                                     *
+               Bindings
+%*                                                     *

 %*********************************************************
 
 %*********************************************************
 

-\begin{code}
-rnSpecDataSig :: RdrNameSpecDataSig
-             -> RnM_Fixes s RenamedSpecDataSig
-
-rnSpecDataSig (SpecDataSig tycon ty src_loc)
-  = pushSrcLocRn src_loc $
-    let
-       tyvars = extractMonoTyNames is_tyvar_name ty
-    in
-    mkTyVarNamesEnv src_loc tyvars             `thenRn` \ (tv_env,_) ->
-    lookupTyCon tycon                  `thenRn` \ tycon' ->
-    rnMonoType tv_env ty               `thenRn` \ ty' ->
-    returnRn (SpecDataSig tycon' ty' src_loc)
+These chaps are here, rather than in TcBinds, so that there
+is just one hi-boot file (for RnSource).  rnSrcDecls is part
+of the loop too, and it must be defined in this module.

 
 

-is_tyvar_name n = isLexVarId (getLocalName n)
+\begin{code}
+rnBindGroups :: [HsBindGroup RdrName] -> RnM ([HsBindGroup Name], DefUses)
+-- This version assumes that the binders are already in scope
+-- It's used only in 'mdo'
+rnBindGroups []
+   = returnM ([], emptyDUs)
+rnBindGroups [HsBindGroup bind sigs _]
+   = rnBinds NotTopLevel bind sigs
+rnBindGroups b@[HsIPBinds bind]
+   = do addErr (badIpBinds b)  
+       returnM ([], emptyDUs)
+rnBindGroups _
+   = panic "rnBindGroups"
+
+rnBindGroupsAndThen 
+  :: [HsBindGroup RdrName]
+  -> ([HsBindGroup Name] -> RnM (result, FreeVars))
+  -> RnM (result, FreeVars)
+-- This version (a) assumes that the binding vars are not already in scope
+--             (b) removes the binders from the free vars of the thing inside
+-- The parser doesn't produce ThenBinds
+rnBindGroupsAndThen [] thing_inside
+  = thing_inside []
+rnBindGroupsAndThen [HsBindGroup bind sigs _] thing_inside
+  = rnBindsAndThen bind sigs $ \ groups -> thing_inside groups
+rnBindGroupsAndThen [HsIPBinds binds] thing_inside
+  = rnIPBinds binds                    `thenM` \ (binds',fv_binds) ->
+    thing_inside [HsIPBinds binds']    `thenM` \ (thing, fvs_thing) ->
+    returnM (thing, fvs_thing `plusFV` fv_binds)
+
+rnIPBinds [] = returnM ([], emptyFVs)
+rnIPBinds (bind : binds)
+  = wrapLocFstM rnIPBind bind  `thenM` \ (bind', fvBind) ->
+    rnIPBinds binds            `thenM` \ (binds',fvBinds) ->
+    returnM (bind' : binds', fvBind `plusFV` fvBinds)
+
+rnIPBind (IPBind n expr)
+  = newIPNameRn  n             `thenM` \ name ->
+    rnLExpr expr               `thenM` \ (expr',fvExpr) ->
+    return (IPBind name expr', fvExpr)
+
+badIpBinds binds
+  = hang (ptext SLIT("Implicit-parameter bindings illegal in 'mdo':")) 4
+        (ppr binds)

 \end{code}
 
 \end{code}
 

+

 %*********************************************************
 %*                                                     *
 %*********************************************************
 %*                                                     *

-\subsection{Class declarations}
+\subsection{Foreign declarations}

 %*                                                     *
 %*********************************************************
 
 %*                                                     *
 %*********************************************************
 

-@rnClassDecl@ uses the `global name function' to create a new
-class declaration in which local names have been replaced by their
-original names, reporting any unknown names.
-

 \begin{code}
 \begin{code}

-rnClassDecl :: RdrNameClassDecl -> RnM_Fixes s RenamedClassDecl
-
-rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
-  = pushSrcLocRn src_loc $
-    mkTyVarNamesEnv src_loc [tyvar]    `thenRn` \ (tv_env, [tyvar']) ->
-    rnContext tv_env context           `thenRn` \ context' ->
-    lookupClass cname                  `thenRn` \ cname' ->
-    mapRn (rn_op cname' tv_env) sigs    `thenRn` \ sigs' ->
-    rnMethodBinds cname' mbinds        `thenRn` \ mbinds' ->
-    ASSERT(isNoClassPragmas pragmas)
-    returnRn (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc)
-  where
-    rn_op clas tv_env (ClassOpSig op ty pragmas locn)
-      = pushSrcLocRn locn $
-       lookupClassOp clas op           `thenRn` \ op_name ->
-       rnPolyType tv_env ty            `thenRn` \ new_ty  ->
-
-{-
-*** Please check here that tyvar' appears in new_ty ***
-*** (used to be in tcClassSig, but it's better here)
-***        not_elem = isn'tIn "tcClassSigs"
-***        -- Check that the class type variable is mentioned
-***    checkTc (clas_tyvar `not_elem` extractTyVarTemplatesFromTy local_ty)
-***            (methodTypeLacksTyVarErr clas_tyvar (_UNPK_ op_name) src_loc) `thenTc_`
--}
-
-       ASSERT(isNoClassOpPragmas pragmas)
-       returnRn (ClassOpSig op_name new_ty noClassOpPragmas locn)
+rnHsForeignDecl (ForeignImport name ty spec isDeprec)
+  = lookupLocatedTopBndrRn name                `thenM` \ name' ->
+    rnHsTypeFVs (fo_decl_msg name) ty  `thenM` \ (ty', fvs) ->
+    returnM (ForeignImport name' ty' spec isDeprec, fvs)
+
+rnHsForeignDecl (ForeignExport name ty spec isDeprec)
+  = lookupLocatedOccRn name            `thenM` \ name' ->
+    rnHsTypeFVs (fo_decl_msg name) ty          `thenM` \ (ty', fvs) ->
+    returnM (ForeignExport name' ty' spec isDeprec, fvs )
+       -- NB: a foreign export is an *occurrence site* for name, so 
+       --     we add it to the free-variable list.  It might, for example,
+       --     be imported from another module
+
+fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name

 \end{code}
 
 
 \end{code}
 
 

@@ -434,286 +323,407 @@ rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
 %*                                                     *
 %*********************************************************
 
 %*                                                     *
 %*********************************************************
 

-
-@rnInstDecl@ uses the `global name function' to create a new of
-instance declaration in which local names have been replaced by their
-original names, reporting any unknown names.
-

 \begin{code}
 \begin{code}

-rnInstDecl :: RdrNameInstDecl -> RnM_Fixes s RenamedInstDecl
+rnSrcInstDecl (InstDecl inst_ty mbinds uprags)
+       -- Used for both source and interface file decls
+  = rnHsSigType (text "an instance decl") inst_ty      `thenM` \ inst_ty' ->

 
 

-rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc)
-  = pushSrcLocRn src_loc $
-    lookupClass cname                  `thenRn` \ cname' ->
+       -- Rename the bindings
+       -- The typechecker (not the renamer) checks that all 
+       -- the bindings are for the right class
+    let
+       meth_doc    = text "In the bindings in an instance declaration"
+       meth_names  = collectHsBindLocatedBinders mbinds
+       (inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
+    in
+    checkDupNames meth_doc meth_names  `thenM_`
+    extendTyVarEnvForMethodBinds inst_tyvars (         
+       -- (Slightly strangely) the forall-d tyvars scope over
+       -- the method bindings too
+       rnMethodBinds cls [] mbinds
+    )                                          `thenM` \ (mbinds', meth_fvs) ->
+       -- Rename the prags and signatures.
+       -- Note that the type variables are not in scope here,
+       -- so that      instance Eq a => Eq (T a) where
+       --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
+       -- works OK. 
+       --
+       -- But the (unqualified) method names are in scope
+    let 
+       binders = collectHsBindBinders mbinds'
+    in
+    bindLocalNames binders (renameSigs uprags)                 `thenM` \ uprags' ->
+    checkSigs (okInstDclSig (mkNameSet binders)) uprags'       `thenM_`

 
 

-    rnPolyType [] ty                   `thenRn` \ ty' ->
-       -- [] tv_env ensures that tyvars will be foralled
+    returnM (InstDecl inst_ty' mbinds' uprags',
+            meth_fvs `plusFV` hsSigsFVs uprags'
+                     `plusFV` extractHsTyNames inst_ty')
+\end{code}

 
 

-    rnMethodBinds cname' mbinds                `thenRn` \ mbinds' ->
-    mapRn (rn_uprag cname') uprags     `thenRn` \ new_uprags ->
+For the method bindings in class and instance decls, we extend the 
+type variable environment iff -fglasgow-exts

 
 

-    ASSERT(isNoInstancePragmas pragmas)
-    returnRn (InstDecl cname' ty' mbinds'
-                      from_here modname new_uprags noInstancePragmas src_loc)
-  where
-    rn_uprag class_name (SpecSig op ty using locn)
-      = pushSrcLocRn src_loc $
-       lookupClassOp class_name op     `thenRn` \ op_name ->
-       rnPolyType nullTyVarNamesEnv ty `thenRn` \ new_ty ->
-       rn_using using                  `thenRn` \ new_using ->
-       returnRn (SpecSig op_name new_ty new_using locn)
-
-    rn_uprag class_name (InlineSig op locn)
-      = pushSrcLocRn locn $
-       lookupClassOp class_name op     `thenRn` \ op_name ->
-       returnRn (InlineSig op_name locn)
-
-    rn_uprag class_name (DeforestSig op locn)
-      = pushSrcLocRn locn $
-       lookupClassOp class_name op     `thenRn` \ op_name ->
-       returnRn (DeforestSig op_name locn)
-
-    rn_uprag class_name (MagicUnfoldingSig op str locn)
-      = pushSrcLocRn locn $
-       lookupClassOp class_name op     `thenRn` \ op_name ->
-       returnRn (MagicUnfoldingSig op_name str locn)
-
-    rn_using Nothing 
-      = returnRn Nothing
-    rn_using (Just v)
-      = lookupValue v  `thenRn` \ new_v ->
-       returnRn (Just new_v)
+\begin{code}
+extendTyVarEnvForMethodBinds tyvars thing_inside
+  = doptM Opt_GlasgowExts                      `thenM` \ opt_GlasgowExts ->
+    if opt_GlasgowExts then
+       extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
+    else
+       thing_inside

 \end{code}
 
 \end{code}
 

+

 %*********************************************************
 %*                                                     *
 %*********************************************************
 %*                                                     *

-\subsection{@SPECIALIZE instance@ user-pragmas}
+\subsection{Rules}

 %*                                                     *
 %*********************************************************
 
 \begin{code}
 %*                                                     *
 %*********************************************************
 
 \begin{code}

-rnSpecInstSig :: RdrNameSpecInstSig
-             -> RnM_Fixes s RenamedSpecInstSig
+rnHsRuleDecl (HsRule rule_name act vars lhs rhs)
+  = bindPatSigTyVarsFV (collectRuleBndrSigTys vars)    $
+
+    bindLocatedLocalsFV doc (map get_var vars)         $ \ ids ->
+    mapFvRn rn_var (vars `zip` ids)            `thenM` \ (vars', fv_vars) ->

 
 

-rnSpecInstSig (SpecInstSig clas ty src_loc)
-  = pushSrcLocRn src_loc $
+    rnLExpr lhs                                        `thenM` \ (lhs', fv_lhs) ->
+    rnLExpr rhs                                        `thenM` \ (rhs', fv_rhs) ->

     let
     let

-       tyvars = extractMonoTyNames is_tyvar_name ty
+       mb_bad = validRuleLhs ids lhs'

     in
     in

-    mkTyVarNamesEnv src_loc tyvars             `thenRn` \ (tv_env,_) ->
-    lookupClass clas                   `thenRn` \ new_clas ->
-    rnMonoType tv_env ty               `thenRn` \ new_ty ->
-    returnRn (SpecInstSig new_clas new_ty src_loc)
+    checkErr (isNothing mb_bad)
+            (badRuleLhsErr rule_name lhs' mb_bad)      `thenM_`
+    let
+       bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
+    in
+    mappM (addErr . badRuleVar rule_name) bad_vars     `thenM_`
+    returnM (HsRule rule_name act vars' lhs' rhs',
+            fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
+  where
+    doc = text "In the transformation rule" <+> ftext rule_name
+  
+    get_var (RuleBndr v)      = v
+    get_var (RuleBndrSig v _) = v
+
+    rn_var (RuleBndr (L loc v), id)
+       = returnM (RuleBndr (L loc id), emptyFVs)
+    rn_var (RuleBndrSig (L loc v) t, id)
+       = rnHsTypeFVs doc t     `thenM` \ (t', fvs) ->
+         returnM (RuleBndrSig (L loc id) t', fvs)
+\end{code}
+
+Check the shape of a transformation rule LHS.  Currently
+we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
+not one of the @forall@'d variables.  We also restrict the form of the LHS so
+that it may be plausibly matched.  Basically you only get to write ordinary 
+applications.  (E.g. a case expression is not allowed: too elaborate.)
+
+NB: if you add new cases here, make sure you add new ones to TcRule.ruleLhsTvs
+
+\begin{code}
+validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
+-- Nothing => OK
+-- Just e  => Not ok, and e is the offending expression
+validRuleLhs foralls lhs
+  = checkl lhs
+  where
+    checkl (L loc e) = check e
+
+    check (OpApp e1 op _ e2)             = checkl op `seqMaybe` checkl_e e1 `seqMaybe` checkl_e e2
+    check (HsApp e1 e2)                  = checkl e1 `seqMaybe` checkl_e e2
+    check (HsVar v) | v `notElem` foralls = Nothing
+    check other                                  = Just other  -- Failure
+
+    checkl_e (L loc e) = check_e e
+
+    check_e (HsVar v)     = Nothing
+    check_e (HsPar e)    = checkl_e e
+    check_e (HsLit e)    = Nothing
+    check_e (HsOverLit e) = Nothing
+
+    check_e (OpApp e1 op _ e2)          = checkl_e e1 `seqMaybe` checkl_e op `seqMaybe` checkl_e e2
+    check_e (HsApp e1 e2)               = checkl_e e1 `seqMaybe` checkl_e e2
+    check_e (NegApp e _)                = checkl_e e
+    check_e (ExplicitList _ es)         = checkl_es es
+    check_e (ExplicitTuple es _) = checkl_es es
+    check_e other               = Just other   -- Fails
+
+    checkl_es es = foldr (seqMaybe . checkl_e) Nothing es
+
+badRuleLhsErr name lhs (Just bad_e)
+  = sep [ptext SLIT("Rule") <+> ftext name <> colon,
+        nest 4 (vcat [ptext SLIT("Illegal expression:") <+> ppr bad_e, 
+                      ptext SLIT("in left-hand side:") <+> ppr lhs])]
+    $$
+    ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
+
+badRuleVar name var
+  = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon,
+        ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+> 
+               ptext SLIT("does not appear on left hand side")]

 \end{code}
 
 \end{code}
 

+

 %*********************************************************
 %*                                                     *
 %*********************************************************
 %*                                                     *

-\subsection{Default declarations}
+\subsection{Type, class and iface sig declarations}

 %*                                                     *
 %*********************************************************
 
 %*                                                     *
 %*********************************************************
 

-@rnDefaultDecl@ uses the `global name function' to create a new set
-of default declarations in which local names have been replaced by
-their original names, reporting any unknown names.
-
-\begin{code}
-rnDefaultDecl :: [RdrNameDefaultDecl] -> RnM_Fixes s [RenamedDefaultDecl]
-
-rnDefaultDecl [] = returnRn []
-rnDefaultDecl [DefaultDecl tys src_loc]
-  = pushSrcLocRn src_loc $
-    mapRn (rnMonoType nullTyVarNamesEnv) tys `thenRn` \ tys' ->
-    returnRn [DefaultDecl tys' src_loc]
-rnDefaultDecl defs@(d:ds)
-  = addErrRn (dupDefaultDeclErr defs) `thenRn_`
-    rnDefaultDecl [d]
-\end{code}
+@rnTyDecl@ uses the `global name function' to create a new type
+declaration in which local names have been replaced by their original
+names, reporting any unknown names.

 
 

-%*************************************************************************
-%*                                                                     *
-\subsection{Fixity declarations}
-%*                                                                     *
-%*************************************************************************
+Renaming type variables is a pain. Because they now contain uniques,
+it is necessary to pass in an association list which maps a parsed
+tyvar to its @Name@ representation.
+In some cases (type signatures of values),
+it is even necessary to go over the type first
+in order to get the set of tyvars used by it, make an assoc list,
+and then go over it again to rename the tyvars!
+However, we can also do some scoping checks at the same time.

 
 \begin{code}
 
 \begin{code}

-rnFixes :: [RdrNameFixityDecl]  -> RnM s [RenamedFixityDecl]
+rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_name})
+  = lookupLocatedTopBndrRn name                `thenM` \ name' ->
+    returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
+            emptyFVs)
+
+rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon,
+                   tcdTyVars = tyvars, tcdCons = condecls, 
+                   tcdKindSig = sig, tcdDerivs = derivs})
+  | is_vanilla -- Normal Haskell data type decl
+  = ASSERT( isNothing sig )    -- In normal H98 form, kind signature on the 
+                               -- data type is syntactically illegal
+    bindTyVarsRn data_doc tyvars               $ \ tyvars' ->
+    do { tycon' <- lookupLocatedTopBndrRn tycon
+       ; context' <- rnContext data_doc context
+       ; (derivs', deriv_fvs) <- rn_derivs derivs
+       ; checkDupNames data_doc con_names
+       ; condecls' <- rnConDecls (unLoc tycon') condecls
+       ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon',
+                          tcdTyVars = tyvars', tcdKindSig = Nothing, tcdCons = condecls', 
+                          tcdDerivs = derivs'}, 
+                  delFVs (map hsLTyVarName tyvars')    $
+                  extractHsCtxtTyNames context'        `plusFV`
+                  plusFVs (map conDeclFVs condecls') `plusFV`
+                  deriv_fvs) }
+
+  | otherwise  -- GADT
+  = ASSERT( null (unLoc context) )
+    do { tycon' <- lookupLocatedTopBndrRn tycon
+       ; tyvars' <- bindTyVarsRn data_doc tyvars 
+                                 (\ tyvars' -> return tyvars')
+               -- For GADTs, the type variables in the declaration 
+               -- do not scope over the constructor signatures
+               --      data T a where { T1 :: forall b. b-> b }
+       ; (derivs', deriv_fvs) <- rn_derivs derivs
+       ; checkDupNames data_doc con_names
+       ; condecls' <- rnConDecls (unLoc tycon') condecls
+       ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], tcdLName = tycon',
+                          tcdTyVars = tyvars', tcdCons = condecls', tcdKindSig = sig,
+                          tcdDerivs = derivs'}, 
+                  plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) }

 
 

-rnFixes fixities
-  = getSrcLocRn        `thenRn` \ src_loc ->
+  where
+    is_vanilla = case condecls of      -- Yuk
+                    []                    -> True
+                    L _ (ConDecl {}) : _  -> True
+                    other                 -> False
+
+    data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
+    con_names = map con_names_helper condecls
+
+    con_names_helper (L _ (ConDecl n _ _ _)) = n
+    con_names_helper (L _ (GadtDecl n _)) = n
+
+    rn_derivs Nothing   = returnM (Nothing, emptyFVs)
+    rn_derivs (Just ds) = rnLHsTypes data_doc ds       `thenM` \ ds' -> 
+                         returnM (Just ds', extractHsTyNames_s ds')
+    
+rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars, tcdSynRhs = ty})
+  = lookupLocatedTopBndrRn name                        `thenM` \ name' ->
+    bindTyVarsRn syn_doc tyvars                $ \ tyvars' ->
+    rnHsTypeFVs syn_doc ty                     `thenM` \ (ty', fvs) ->
+    returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars', 
+                       tcdSynRhs = ty'},
+            delFVs (map hsLTyVarName tyvars') fvs)
+  where
+    syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
+
+rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, 
+                      tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
+                      tcdMeths = mbinds})
+  = lookupLocatedTopBndrRn cname               `thenM` \ cname' ->
+
+       -- Tyvars scope over superclass context and method signatures
+    bindTyVarsRn cls_doc tyvars                        ( \ tyvars' ->
+       rnContext cls_doc context       `thenM` \ context' ->
+       rnFds cls_doc fds               `thenM` \ fds' ->
+       renameSigs sigs                 `thenM` \ sigs' ->
+       returnM   (tyvars', context', fds', sigs')
+    )  `thenM` \ (tyvars', context', fds', sigs') ->
+
+       -- Check the signatures
+       -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).

     let
     let

-        (_, dup_fixes) = removeDups cmp_fix fixities
-       cmp_fix fix1 fix2 = nameFixDecl fix1 `cmp` nameFixDecl fix2
-
-        rn_fixity fix@(InfixL name i)
-         = rn_fixity_pieces InfixL name i fix
-       rn_fixity fix@(InfixR name i)
-         = rn_fixity_pieces InfixR name i fix
-       rn_fixity fix@(InfixN name i)
-         = rn_fixity_pieces InfixN name i fix
-
-       rn_fixity_pieces mk_fixity name i fix
-         = getRnEnv `thenRn` \ env ->
-             case lookupGlobalRnEnv env name of
-               Just res | isLocallyDefined res
-                 -> returnRn (Just (mk_fixity res i))
-               _ -> failButContinueRn Nothing (undefinedFixityDeclErr src_loc fix)
+       sig_rdr_names_w_locs   = [op | L _ (Sig op _) <- sigs]

     in
     in

-    mapRn (addErrRn . dupFixityDeclErr src_loc) dup_fixes `thenRn_`
-    mapRn rn_fixity fixities                             `thenRn` \ fixes_maybe ->
-    returnRn (catMaybes fixes_maybe)
-
-nameFixDecl (InfixL name i) = name
-nameFixDecl (InfixR name i) = name
-nameFixDecl (InfixN name i) = name
+    checkDupNames sig_doc sig_rdr_names_w_locs `thenM_` 
+    checkSigs okClsDclSig sigs'                                `thenM_`
+       -- Typechecker is responsible for checking that we only
+       -- give default-method bindings for things in this class.
+       -- The renamer *could* check this for class decls, but can't
+       -- for instance decls.
+
+       -- The newLocals call is tiresome: given a generic class decl
+       --      class C a where
+       --        op :: a -> a
+       --        op {| x+y |} (Inl a) = ...
+       --        op {| x+y |} (Inr b) = ...
+       --        op {| a*b |} (a*b)   = ...
+       -- we want to name both "x" tyvars with the same unique, so that they are
+       -- easy to group together in the typechecker.  
+    extendTyVarEnvForMethodBinds tyvars' (
+        getLocalRdrEnv                                 `thenM` \ name_env ->
+        let
+            meth_rdr_names_w_locs = collectHsBindLocatedBinders mbinds
+            gen_rdr_tyvars_w_locs = 
+               [ tv | tv <- extractGenericPatTyVars mbinds,
+                     not (unLoc tv `elemLocalRdrEnv` name_env) ]
+        in
+        checkDupNames meth_doc meth_rdr_names_w_locs   `thenM_`
+        newLocalsRn gen_rdr_tyvars_w_locs      `thenM` \ gen_tyvars ->
+        rnMethodBinds (unLoc cname') gen_tyvars mbinds
+    ) `thenM` \ (mbinds', meth_fvs) ->
+
+    returnM (ClassDecl { tcdCtxt = context', tcdLName = cname', tcdTyVars = tyvars',
+                        tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds'},
+            delFVs (map hsLTyVarName tyvars')  $
+            extractHsCtxtTyNames context'          `plusFV`
+            plusFVs (map extractFunDepNames (map unLoc fds'))  `plusFV`
+            hsSigsFVs sigs'                        `plusFV`
+            meth_fvs)
+  where
+    meth_doc = text "In the default-methods for class" <+> ppr cname
+    cls_doc  = text "In the declaration for class"     <+> ppr cname
+    sig_doc  = text "In the signatures for class"      <+> ppr cname

 \end{code}
 
 %*********************************************************
 %*                                                     *
 \end{code}
 
 %*********************************************************
 %*                                                     *

-\subsection{Support code to rename types}
+\subsection{Support code for type/data declarations}

 %*                                                     *
 %*********************************************************
 
 \begin{code}
 %*                                                     *
 %*********************************************************
 
 \begin{code}

-rnPolyType :: TyVarNamesEnv
-          -> RdrNamePolyType
-          -> RnM_Fixes s RenamedPolyType
-
-rnPolyType tv_env (HsForAllTy tvs ctxt ty)
-  = rn_poly_help tv_env tvs ctxt ty
+rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
+rnConDecls tycon condecls
+  =    -- Check that there's at least one condecl,
+       -- or else we're reading an interface file, or -fglasgow-exts
+    (if null condecls then
+       doptM Opt_GlasgowExts   `thenM` \ glaExts ->
+       checkErr glaExts (emptyConDeclsErr tycon)
+     else returnM ()
+    )                                          `thenM_` 
+    mappM (wrapLocM rnConDecl) condecls
+
+rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
+rnConDecl (ConDecl name tvs cxt details)
+  = addLocM checkConName name          `thenM_` 
+    lookupLocatedTopBndrRn name                `thenM` \ new_name ->
+
+    bindTyVarsRn doc tvs               $ \ new_tyvars ->
+    rnContext doc cxt                  `thenM` \ new_context ->
+    rnConDetails doc details           `thenM` \ new_details -> 
+    returnM (ConDecl new_name new_tyvars new_context new_details)
+  where
+    doc = text "In the definition of data constructor" <+> quotes (ppr name)

 
 

-rnPolyType tv_env (HsPreForAllTy ctxt ty)
-  = rn_poly_help tv_env forall_tyvars ctxt ty
+rnConDecl (GadtDecl name ty) 
+  = addLocM checkConName name          `thenM_` 
+    lookupLocatedTopBndrRn name                `thenM` \ new_name ->
+    rnHsSigType doc ty                  `thenM` \ new_ty ->
+    returnM (GadtDecl new_name new_ty)

   where
   where

-    mentioned_tyvars = extractCtxtTyNames ctxt `unionLists` extractMonoTyNames is_tyvar_name ty
-    forall_tyvars    = --pprTrace "mentioned:" (ppCat (map (ppr PprShowAll) mentioned_tyvars)) $
-                      --pprTrace "from_ty:" (ppCat (map (ppr PprShowAll) (extractMonoTyNames is_tyvar_name ty))) $
-                      mentioned_tyvars `minusList` domTyVarNamesEnv tv_env
-
-------------
-rn_poly_help :: TyVarNamesEnv
-            -> [RdrName]
-            -> RdrNameContext
-            -> RdrNameMonoType
-            -> RnM_Fixes s RenamedPolyType
-
-rn_poly_help tv_env tyvars ctxt ty
-  = --pprTrace "rnPolyType:" (ppCat [ppCat (map (ppr PprShowAll . snd) tv_env),
-    --                            ppStr ";tvs=", ppCat (map (ppr PprShowAll) tyvars),
-    --                            ppStr ";ctxt=", ppCat (map (ppr PprShowAll) ctxt),
-    --                            ppStr ";ty=", ppr PprShowAll ty]
-    --                    ) $
-    getSrcLocRn                                `thenRn` \ src_loc ->
-    mkTyVarNamesEnv src_loc tyvars             `thenRn` \ (tv_env1, new_tyvars) ->
-    let
-       tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
-    in
-    rnContext tv_env2 ctxt     `thenRn` \ new_ctxt ->
-    rnMonoType tv_env2 ty      `thenRn` \ new_ty ->
-    returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
-\end{code}
+    doc = text "In the definition of data constructor" <+> quotes (ppr name)

 
 

-\begin{code}
-rnMonoType :: TyVarNamesEnv
-          -> RdrNameMonoType
-          -> RnM_Fixes s RenamedMonoType
-
-rnMonoType tv_env (MonoTyVar tyvar)
-  = lookupTyVarName tv_env tyvar       `thenRn` \ tyvar' ->
-    returnRn (MonoTyVar tyvar')
-
-rnMonoType tv_env (MonoListTy ty)
-  = rnMonoType tv_env ty       `thenRn` \ ty' ->
-    returnRn (MonoListTy ty')
-
-rnMonoType tv_env (MonoFunTy ty1 ty2)
-  = andRn MonoFunTy (rnMonoType tv_env ty1)
-                   (rnMonoType tv_env ty2)
-
-rnMonoType  tv_env (MonoTupleTy tys)
-  = mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
-    returnRn (MonoTupleTy tys')
-
-rnMonoType tv_env (MonoTyApp name tys)
-  = let
-       lookup_fn = if isLexVarId (getLocalName name) 
-                   then lookupTyVarName tv_env
-                   else lookupTyCon
-    in
-    lookup_fn name                     `thenRn` \ name' ->
-    mapRn (rnMonoType tv_env) tys      `thenRn` \ tys' ->
-    returnRn (MonoTyApp name' tys')
-\end{code}
+rnConDetails doc (PrefixCon tys)
+  = mappM (rnLHsType doc) tys  `thenM` \ new_tys  ->
+    returnM (PrefixCon new_tys)

 
 

-\begin{code}
-rnContext :: TyVarNamesEnv -> RdrNameContext -> RnM_Fixes s RenamedContext
+rnConDetails doc (InfixCon ty1 ty2)
+  = rnLHsType doc ty1                  `thenM` \ new_ty1 ->
+    rnLHsType doc ty2                  `thenM` \ new_ty2 ->
+    returnM (InfixCon new_ty1 new_ty2)

 
 

-rnContext tv_env ctxt
-  = mapRn rn_ctxt ctxt
+rnConDetails doc (RecCon fields)
+  = checkDupNames doc field_names      `thenM_`
+    mappM (rnField doc) fields         `thenM` \ new_fields ->
+    returnM (RecCon new_fields)

   where
   where

-    rn_ctxt (clas, tyvar)
-     = lookupClass clas                    `thenRn` \ clas_name ->
-       lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name ->
-       returnRn (clas_name, tyvar_name)
+    field_names = [fld | (fld, _) <- fields]
+
+rnField doc (name, ty)
+  = lookupLocatedTopBndrRn name        `thenM` \ new_name ->
+    rnLHsType doc ty           `thenM` \ new_ty ->
+    returnM (new_name, new_ty) 
+
+-- This data decl will parse OK
+--     data T = a Int
+-- treating "a" as the constructor.
+-- It is really hard to make the parser spot this malformation.
+-- So the renamer has to check that the constructor is legal
+--
+-- We can get an operator as the constructor, even in the prefix form:
+--     data T = :% Int Int
+-- from interface files, which always print in prefix form
+
+checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
+
+badDataCon name
+   = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
+
+emptyConDeclsErr tycon
+  = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
+        nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))]

 \end{code}
 
 
 \end{code}
 
 

+%*********************************************************
+%*                                                     *
+\subsection{Support code to rename types}
+%*                                                     *
+%*********************************************************
+

 \begin{code}
 \begin{code}

-dupNameExportWarn locn names@((n,_):_)
-  = addShortErrLocLine locn (\ sty ->
-    ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times"])
-
-dupLocalsExportErr locn locals@((str,_):_)
-  = addErrLoc locn "exported names have same local name" (\ sty ->
-    ppInterleave ppSP (map (pprNonSym sty . snd) locals))
-
-classOpExportErr op locn
-  = addShortErrLocLine locn (\ sty ->
-    ppBesides [ppStr "class operation `", ppr sty op, ppStr "' can only be exported with class"])
-
-synAllExportErr syn locn
-  = addShortErrLocLine locn (\ sty ->
-    ppBesides [ppStr "type synonym `", ppr sty syn, ppStr "' should be exported abstractly"])
-
-withExportErr str rn has rns locn
-  = addErrLoc locn "" (\ sty ->
-    ppAboves [ ppBesides [ppStr "inconsistent list of", ppStr str, ppStr "in export list for `", ppr sty rn, ppStr "'"],
-              ppCat [ppStr "    expected:", ppInterleave ppComma (map (ppr sty) has)],
-              ppCat [ppStr "    found:   ", ppInterleave ppComma (map (ppr sty) rns)] ])
-
-importAllErr rn locn
-  = addShortErrLocLine locn (\ sty ->
-    ppBesides [ ppStr "`", pprNonSym sty rn, ppStr "' has been exported with (..), but is only imported abstractly"])
-
-badModExportErr mod locn
-  = addShortErrLocLine locn (\ sty ->
-    ppCat [ ppStr "unknown module in export list:", ppPStr mod])
-
-dupModExportWarn locn mods@(mod:_)
-  = addShortErrLocLine locn (\ sty ->
-    ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"])
-
-emptyModExportWarn locn mod
-  = addShortErrLocLine locn (\ sty ->
-    ppCat [ppStr "module", ppPStr mod, ppStr "has no unqualified imports to export"])
-
-derivingNonStdClassErr clas locn
-  = addShortErrLocLine locn (\ sty ->
-    ppCat [ppStr "non-standard class in deriving:", ppr sty clas])
-
-dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) sty
-  = ppAboves (item1 : map dup_item dup_things)
+rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
+
+rnFds doc fds
+  = mappM (wrapLocM rn_fds) fds

   where
   where

-    item1
-      = addShortErrLocLine locn1 (\ sty -> ppStr "multiple default declarations") sty
+    rn_fds (tys1, tys2)
+      =        rnHsTyVars doc tys1             `thenM` \ tys1' ->
+       rnHsTyVars doc tys2             `thenM` \ tys2' ->
+       returnM (tys1', tys2')

 
 

-    dup_item (DefaultDecl _ locn)
-      = addShortErrLocLine locn (\ sty -> ppStr "here was another default declaration") sty
+rnHsTyVars doc tvs  = mappM (rnHsTyvar doc) tvs
+rnHsTyvar doc tyvar = lookupOccRn tyvar
+\end{code}

 
 

-undefinedFixityDeclErr locn decl
-  = addErrLoc locn "fixity declaration for unknown operator" (\ sty ->
-    ppr sty decl)

 
 

-dupFixityDeclErr locn dups
-  = addErrLoc locn "multiple fixity declarations for same operator" (\ sty ->
-    ppAboves (map (ppr sty) dups))
+%*********************************************************
+%*                                                     *
+               Splices
+%*                                                     *
+%*********************************************************
+
+\begin{code}
+rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
+rnSplice (HsSplice n expr)
+  = checkTH expr "splice"      `thenM_`
+    getSrcSpanM                `thenM` \ loc ->
+    newLocalsRn [L loc n]      `thenM` \ [n'] ->
+    rnLExpr expr               `thenM` \ (expr', fvs) ->
+    returnM (HsSplice n' expr', fvs)

 \end{code}
 \end{code}