[project @ 2002-10-23 14:30:00 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 9044b87..0e53b07 100644 (file)
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -4,260 +4,327 @@
 \section[RnSource]{Main pass of renamer}
 
 \begin{code}
 \section[RnSource]{Main pass of renamer}
 
 \begin{code}

-module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType ) where
+module RnSource ( 
+       rnSrcDecls, checkModDeprec,
+       rnTyClDecl, rnIfaceRuleDecl, rnInstDecl, 
+       rnBinds, rnBindsAndThen, rnStats,
+    ) where

 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

-import RnExpr

 import HsSyn
 import HsSyn

-import HsPragmas
-import HsTypes         ( getTyVarName, pprClassAssertion, cmpHsTypes )
-import RdrName         ( RdrName, isRdrDataCon, rdrNameOcc, isRdrTyVar )
-import RdrHsSyn                ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
-                         extractHsTyRdrNames, extractRuleBndrsTyVars
+import RdrName         ( RdrName, isRdrDataCon, elemRdrEnv )
+import RdrHsSyn                ( RdrNameConDecl, RdrNameTyClDecl, 
+                         RdrNameDeprecation, RdrNameFixitySig,
+                         RdrNameHsBinds,
+                         extractGenericPatTyVars

                        )
 import RnHsSyn
 import HsCore
                        )
 import RnHsSyn
 import HsCore

-
-import RnBinds         ( rnTopBinds, rnMethodBinds, renameSigs, unknownSigErr )
-import RnEnv           ( bindTyVarsRn, lookupBndrRn, lookupOccRn, 
-                         lookupImplicitOccRn, 
-                         bindLocalsRn, bindLocalRn, bindLocalsFVRn,
-                         bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn,
-                         bindCoreLocalFVRn, bindCoreLocalsFVRn,
-                         checkDupOrQualNames, checkDupNames,
-                         mkImportedGlobalName, mkImportedGlobalFromRdrName,
-                         newDFunName, getDFunKey, newImplicitBinder,
-                         FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV, mapFvRn
-                       )
-import RnMonad
-
-import Name            ( Name, OccName,
-                         ExportFlag(..), Provenance(..), 
-                         nameOccName, NamedThing(..)
+import RnExpr          ( rnExpr )
+import RnTypes         ( rnHsType, rnHsSigType, rnHsTypeFVs, rnContext )
+
+import RnBinds         ( rnTopMonoBinds, rnMonoBinds, rnMethodBinds, 
+                         rnMonoBindsAndThen, renameSigs, checkSigs )
+import RnEnv           ( lookupTopBndrRn, lookupOccRn, lookupSysBndr,
+                         newLocalsRn, lookupGlobalOccRn,
+                         bindLocalsFVRn, bindPatSigTyVars,
+                         bindTyVarsRn, extendTyVarEnvFVRn,
+                         bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames,
+                         checkDupOrQualNames, checkDupNames, mapFvRn,
+                         lookupTopSrcBndr_maybe, lookupTopSrcBndr,
+                         dataTcOccs, newIPName, unknownNameErr

                        )
                        )

+import TcRnMonad
+
+import BasicTypes      ( FixitySig(..) )
+import HscTypes                ( ExternalPackageState(..), FixityEnv, 
+                         Deprecations(..), plusDeprecs )
+import Module          ( moduleEnvElts )
+import Class           ( FunDep, DefMeth (..) )
+import TyCon           ( DataConDetails(..), visibleDataCons )
+import Name            ( Name )

 import NameSet
 import NameSet

-import OccName         ( mkDefaultMethodOcc )
-import BasicTypes      ( TopLevelFlag(..) )
-import FiniteMap       ( elemFM )
-import PrelInfo                ( derivingOccurrences, numClass_RDR, 
-                         deRefStablePtr_NAME, makeStablePtr_NAME,
-                         bindIO_NAME
-                       )
+import NameEnv
+import ErrUtils                ( dumpIfSet )
+import PrelNames       ( newStablePtrName, bindIOName, returnIOName )
+import List            ( partition )

 import Bag             ( bagToList )
 import Bag             ( bagToList )

-import List            ( partition, nub )

 import Outputable
 import SrcLoc          ( SrcLoc )
 import Outputable
 import SrcLoc          ( SrcLoc )

-import CmdLineOpts     ( opt_WarnUnusedMatches )       -- Warn of unused for-all'd tyvars
-import UniqFM          ( lookupUFM )
-import Maybes          ( maybeToBool, catMaybes )
-import Util
+import CmdLineOpts     ( DynFlag(..) )
+                               -- Warn of unused for-all'd tyvars
+import Maybes          ( maybeToBool, seqMaybe )
+import Maybe            ( maybe, catMaybes, isNothing )

 \end{code}
 
 \end{code}
 

-rnDecl `renames' declarations.
+@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}
 
 
 \end{enumerate}
 
 

+\begin{code}
+rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name, FreeVars)
+
+rnSrcDecls (HsGroup { hs_valds  = MonoBind 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,
+                     hs_coreds = core_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 {
+
+       failIfErrsM ;   -- No point in continuing if (say) we have duplicate declarations
+
+               -- Rename other declarations
+       (rn_val_decls, src_fvs1)     <- rnTopMonoBinds binds sigs ;
+       (rn_inst_decls, src_fvs2)    <- mapFvRn rnSrcInstDecl inst_decls ;
+       (rn_tycl_decls, src_fvs3)    <- mapFvRn rnSrcTyClDecl tycl_decls ;
+       (rn_rule_decls, src_fvs4)    <- mapFvRn rnHsRuleDecl rule_decls ;
+       (rn_foreign_decls, src_fvs5) <- mapFvRn rnHsForeignDecl foreign_decls ;
+       (rn_default_decls, src_fvs6) <- mapFvRn rnDefaultDecl default_decls ;
+       (rn_core_decls,    src_fvs7) <- mapFvRn rnCoreDecl core_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,
+                               hs_coreds = rn_core_decls } ;
+          src_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, 
+                             src_fvs5, src_fvs6, src_fvs7] } ;
+
+       traceRn (text "rnSrcDecls" <+> ppr (nameSetToList src_fvs)) ;
+       tcg_env <- getGblEnv ;
+       return (tcg_env, rn_group, src_fvs)
+    }}}
+\end{code}
+
+

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

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

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

-rnSourceDecls :: [RdrNameHsDecl] -> RnMS ([RenamedHsDecl], FreeVars)
-       -- The decls get reversed, but that's ok
-
-rnSourceDecls decls
-  = go emptyFVs [] decls
+rnSrcFixityDecls :: [RdrNameFixitySig] -> TcRn m FixityEnv
+rnSrcFixityDecls fix_decls
+  = getGblEnv                                  `thenM` \ gbl_env ->
+    foldlM rnFixityDecl (tcg_fix_env gbl_env) 
+           fix_decls                           `thenM` \ fix_env ->
+    traceRn (text "fixity env" <+> ppr fix_env)        `thenM_`
+    returnM fix_env
+
+rnFixityDecl :: FixityEnv -> RdrNameFixitySig -> TcRn m FixityEnv
+rnFixityDecl fix_env (FixitySig rdr_name fixity 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
+     mappM lookupTopSrcBndr_maybe (dataTcOccs rdr_name)        `thenM` \ maybe_ns ->
+     case catMaybes maybe_ns of
+         [] -> addSrcLoc loc                   $
+               addErr (unknownNameErr rdr_name)        `thenM_`
+               returnM fix_env
+         ns -> foldlM add fix_env ns

   where
   where

-       -- Fixity decls have been dealt with already; ignore them
-    go fvs ds' []          = returnRn (ds', fvs)
-    go fvs ds' (FixD _:ds) = go fvs ds' ds
-    go fvs ds' (d:ds)      = rnDecl d  `thenRn` \(d', fvs') ->
-                            go (fvs `plusFV` fvs') (d':ds') ds
+    add fix_env name 
+      = case lookupNameEnv fix_env name of
+          Just (FixitySig _ _ loc') -> addErr (dupFixityDecl rdr_name loc loc')        `thenM_`
+                                      returnM fix_env
+         Nothing -> returnM (extendNameEnv fix_env name (FixitySig name fixity loc))
+
+dupFixityDecl rdr_name loc1 loc2
+  = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
+         ptext SLIT("at ") <+> ppr loc1,
+         ptext SLIT("and") <+> ppr loc2]

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

+%*                                                      *
+       Source-code deprecations declarations
+%*                                                      *
+%*********************************************************
+
+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}
+rnSrcDeprecDecls :: [RdrNameDeprecation] -> TcRn m Deprecations
+rnSrcDeprecDecls [] 
+  = returnM NoDeprecs
+
+rnSrcDeprecDecls decls
+  = mappM rn_deprec decls      `thenM` \ pairs ->
+    returnM (DeprecSome (mkNameEnv (catMaybes pairs)))
+ where
+   rn_deprec (Deprecation rdr_name txt loc)
+     = addSrcLoc loc                   $
+       lookupTopSrcBndr rdr_name       `thenM` \ name ->
+       returnM (Just (name, (name,txt)))
+
+checkModDeprec :: Maybe DeprecTxt -> Deprecations
+-- Check for a module deprecation; done once at top level
+checkModDeprec Nothing    = NoDeprecs
+checkModdeprec (Just txt) = DeprecAll txt
+
+badDeprec d
+  = sep [ptext SLIT("Illegal deprecation when whole module is deprecated"),
+        nest 4 (ppr d)]
+\end{code}
+
+%*********************************************************

 %*                                                     *
 %*                                                     *

-\subsection{Value declarations}
+\subsection{Source code declarations}

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

--- rnDecl does all the work
-rnDecl :: RdrNameHsDecl -> RnMS (RenamedHsDecl, FreeVars)
-
-rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) ->
-                     returnRn (ValD new_binds, fvs)
+rnSrcTyClDecl tycl_decl
+  = rnTyClDecl tycl_decl                       `thenM` \ new_decl ->
+    finishSourceTyClDecl tycl_decl new_decl    `thenM` \ (new_decl', fvs) ->
+    returnM (new_decl', fvs `plusFV` tyClDeclFVs new_decl')
+
+rnSrcInstDecl inst
+  = rnInstDecl inst                    `thenM` \ new_inst ->
+    finishSourceInstDecl inst new_inst `thenM` \ (new_inst', fvs) ->
+    returnM (new_inst', fvs `plusFV` instDeclFVs new_inst')
+
+rnDefaultDecl (DefaultDecl tys src_loc)
+  = addSrcLoc src_loc $
+    mapFvRn (rnHsTypeFVs doc_str) tys          `thenM` \ (tys', fvs) ->
+    returnM (DefaultDecl tys' src_loc, fvs)
+  where
+    doc_str = text "In a `default' declaration"

 
 
 
 

-rnDecl (SigD (IfaceSig name ty id_infos loc))
-  = pushSrcLocRn loc $
-    lookupBndrRn name          `thenRn` \ name' ->
-    rnHsType doc_str ty                `thenRn` \ (ty',fvs1) ->
-    mapFvRn rnIdInfo id_infos  `thenRn` \ (id_infos', fvs2) -> 
-    returnRn (SigD (IfaceSig name' ty' id_infos' loc), fvs1 `plusFV` fvs2)
+rnCoreDecl (CoreDecl name ty rhs loc)
+  = addSrcLoc loc $
+    lookupTopBndrRn name               `thenM` \ name' ->
+    rnHsTypeFVs doc_str ty             `thenM` \ (ty', ty_fvs) ->
+    rnCoreExpr rhs                      `thenM` \ rhs' ->
+    returnM (CoreDecl name' ty' rhs' loc, 
+            ty_fvs `plusFV` ufExprFVs rhs')

   where
   where

-    doc_str = text "the interface signature for" <+> quotes (ppr name)
+    doc_str = text "In the Core declaration for" <+> quotes (ppr name)

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

-\subsection{Type declarations}
+               Bindings

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

-@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.
+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.

 
 \begin{code}
 
 \begin{code}

-rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc))
-  = pushSrcLocRn src_loc $
-    lookupBndrRn tycon                                 `thenRn` \ tycon' ->
-    bindTyVarsFVRn data_doc tyvars                     $ \ tyvars' ->
-    rnContext data_doc context                                 `thenRn` \ (context', cxt_fvs) ->
-    checkDupOrQualNames data_doc con_names             `thenRn_`
-    mapFvRn rnConDecl condecls                         `thenRn` \ (condecls', con_fvs) ->
-    rnDerivs derivings                                 `thenRn` \ (derivings', deriv_fvs) ->
-    ASSERT(isNoDataPragmas pragmas)
-    returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc),
-             cxt_fvs `plusFV` con_fvs `plusFV` deriv_fvs)
-  where
-    data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
-    con_names = map conDeclName condecls
-
-rnDecl (TyClD (TySynonym name tyvars ty src_loc))
-  = pushSrcLocRn src_loc $
-    lookupBndrRn name                          `thenRn` \ name' ->
-    bindTyVarsFVRn syn_doc tyvars              $ \ tyvars' ->
-    rnHsType syn_doc ty                                `thenRn` \ (ty', ty_fvs) ->
-    returnRn (TyClD (TySynonym name' tyvars' ty' src_loc), ty_fvs)
-  where
-    syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
-
-rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname snames src_loc))
-  = pushSrcLocRn src_loc $
-
-    lookupBndrRn cname                                 `thenRn` \ cname' ->
+rnTopBinds    :: RdrNameHsBinds -> RnM (RenamedHsBinds, FreeVars)
+rnTopBinds EmptyBinds            = returnM (EmptyBinds, emptyFVs)
+rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs
+  -- The parser doesn't produce other forms
+
+rnBinds    :: RdrNameHsBinds -> RnM (RenamedHsBinds, FreeVars)
+-- This version assumes that the binders are already in scope
+-- It's used only in 'mdo'
+rnBinds EmptyBinds            = returnM (EmptyBinds, emptyFVs)
+rnBinds (MonoBind bind sigs _) = rnMonoBinds bind sigs
+rnBinds b@(IPBinds bind _)     = addErr (badIpBinds b) `thenM_` 
+                                returnM (EmptyBinds, emptyFVs)
+
+rnBindsAndThen :: RdrNameHsBinds 
+               -> (RenamedHsBinds -> 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
+rnBindsAndThen EmptyBinds             thing_inside = thing_inside EmptyBinds
+rnBindsAndThen (MonoBind bind sigs _)  thing_inside = rnMonoBindsAndThen bind sigs thing_inside
+rnBindsAndThen (IPBinds binds is_with) thing_inside
+  = warnIf is_with withWarning                 `thenM_`
+    rnIPBinds binds                            `thenM` \ (binds',fvBinds) ->
+    thing_inside (IPBinds binds' is_with)
+\end{code}

 
 

-       -- Deal with the implicit tycon and datacon name
-       -- They aren't in scope (because they aren't visible to the user)
-       -- and what we want to do is simply look them up in the cache;
-       -- we jolly well ought to get a 'hit' there!
-       -- So the 'Imported' part of this call is not relevant. 
-       -- Unclean; but since these two are the only place this happens
-       -- I can't work up the energy to do it more beautifully
-    mkImportedGlobalFromRdrName tname                  `thenRn` \ tname' ->
-    mkImportedGlobalFromRdrName dname                  `thenRn` \ dname' ->
-    mapRn mkImportedGlobalFromRdrName snames           `thenRn` \ snames' ->

 
 

-       -- Tyvars scope over bindings and context
-    bindTyVarsFV2Rn cls_doc tyvars                     ( \ clas_tyvar_names tyvars' ->
+%************************************************************************
+%*                                                                     *
+\subsubsection{@rnIPBinds@s: in implicit parameter bindings}           *
+%*                                                                     *
+%************************************************************************

 
 

-       -- Check the superclasses
-    rnContext cls_doc context                          `thenRn` \ (context', cxt_fvs) ->
+\begin{code}
+rnIPBinds [] = returnM ([], emptyFVs)
+rnIPBinds ((n, expr) : binds)
+  = newIPName n                        `thenM` \ name ->
+    rnExpr expr                        `thenM` \ (expr',fvExpr) ->
+    rnIPBinds binds            `thenM` \ (binds',fvBinds) ->
+    returnM ((name, expr') : binds', fvExpr `plusFV` fvBinds)

 
 

-       -- Check the signatures
-    let
-           -- First process the class op sigs, then the fixity sigs.
-         (op_sigs, non_op_sigs) = partition isClassOpSig sigs
-         (fix_sigs, non_sigs)   = partition isFixitySig  non_op_sigs
-    in
-    checkDupOrQualNames sig_doc sig_rdr_names_w_locs   `thenRn_` 
-    mapFvRn (rn_op cname' clas_tyvar_names) op_sigs    `thenRn` \ (sigs', sig_fvs) ->
-    mapRn_  (unknownSigErr) non_sigs                   `thenRn_`
-    let
-     binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
-    in
-    renameSigs False binders lookupOccRn fix_sigs        `thenRn` \ (fixs', fix_fvs) ->
+\end{code}

 
 

-       -- Check the methods
-    checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
-    rnMethodBinds mbinds                               `thenRn` \ (mbinds', meth_fvs) ->

 
 

-       -- 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.
+%*********************************************************
+%*                                                     *
+\subsection{Foreign declarations}
+%*                                                     *
+%*********************************************************

 
 

-    ASSERT(isNoClassPragmas pragmas)
-    returnRn (TyClD (ClassDecl context' cname' tyvars' (fixs' ++ sigs') 
-                              mbinds' NoClassPragmas tname' dname' snames' src_loc),
-             sig_fvs   `plusFV`
-             fix_fvs   `plusFV`
-             cxt_fvs   `plusFV`
-             meth_fvs
-            )
-    )
+\begin{code}
+rnHsForeignDecl (ForeignImport name ty spec isDeprec src_loc)
+  = addSrcLoc src_loc          $
+    lookupTopBndrRn name               `thenM` \ name' ->
+    rnHsTypeFVs (fo_decl_msg name) ty  `thenM` \ (ty', fvs) ->
+    returnM (ForeignImport name' ty' spec isDeprec src_loc, 
+             fvs `plusFV` extras spec)

   where
   where

-    cls_doc  = text "the declaration for class"        <+> ppr cname
-    sig_doc  = text "the signatures for class"         <+> ppr cname
-    meth_doc = text "the default-methods for class"    <+> ppr cname
-
-    sig_rdr_names_w_locs  = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
-    meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds)
-    meth_rdr_names       = map fst meth_rdr_names_w_locs
-
-    rn_op clas clas_tyvars sig@(ClassOpSig op maybe_dm ty locn)
-      = pushSrcLocRn locn $
-       lookupBndrRn op                         `thenRn` \ op_name ->
-
-               -- Check the signature
-       rnHsSigType (quotes (ppr op)) ty        `thenRn` \ (new_ty, op_ty_fvs)  ->
-       let
-           check_in_op_ty clas_tyvar = checkRn (clas_tyvar `elemNameSet` op_ty_fvs)
-                                               (classTyVarNotInOpTyErr clas_tyvar sig)
-       in
-        mapRn_ check_in_op_ty clas_tyvars               `thenRn_`
-
-               -- Make the default-method name
-       getModeRn                                       `thenRn` \ mode ->
-       (case (mode, maybe_dm) of 
-           (SourceMode, _)
-               | op `elem` meth_rdr_names
-               ->      -- Source class decl with an explicit method decl
-                       newImplicitBinder (mkDefaultMethodOcc (rdrNameOcc op)) locn     `thenRn` \ dm_name ->
-                       returnRn (Just dm_name, emptyFVs)
-
-               | otherwise     
-               ->      -- Source class dec, no explicit method decl
-                       returnRn (Nothing, emptyFVs)
-
-           (InterfaceMode, Just dm_rdr_name)
-               ->      -- Imported class that has a default method decl
-                       -- See comments with tname, snames, above
-                   lookupImplicitOccRn dm_rdr_name             `thenRn` \ dm_name ->
-                   returnRn (Just dm_name, unitFV dm_name)
-                           -- An imported class decl mentions, rather than defines,
-                           -- the default method, so we must arrange to pull it in
-
-           (InterfaceMode, Nothing)
-                       -- Imported class with no default metho
-               ->      returnRn (Nothing, emptyFVs)
-       )                                               `thenRn` \ (maybe_dm_name, dm_fvs) ->
-
-       returnRn (ClassOpSig op_name maybe_dm_name new_ty locn, op_ty_fvs `plusFV` dm_fvs)
+    extras (CImport _ _ _ _ CWrapper) = mkFVs [newStablePtrName,
+                                              bindIOName, returnIOName]
+    extras _                         = emptyFVs
+
+rnHsForeignDecl (ForeignExport name ty spec isDeprec src_loc)
+  = addSrcLoc src_loc                  $
+    lookupOccRn name                           `thenM` \ name' ->
+    rnHsTypeFVs (fo_decl_msg name) ty                  `thenM` \ (ty', fvs) ->
+    returnM (ForeignExport name' ty' spec isDeprec src_loc, 
+             mkFVs [name', bindIOName, returnIOName] `plusFV` 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}
 
 

@@ -268,150 +335,325 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname sn
 %*********************************************************
 
 \begin{code}
 %*********************************************************
 
 \begin{code}

-rnDecl (InstD (InstDecl inst_ty mbinds uprags dfun_rdr_name src_loc))
-  = pushSrcLocRn src_loc $
-    rnHsSigType (text "an instance decl") inst_ty      `thenRn` \ (inst_ty', inst_fvs) ->
+rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc)
+       -- Used for both source and interface file decls
+  = addSrcLoc src_loc $
+    rnHsSigType (text "an instance decl") inst_ty      `thenM` \ inst_ty' ->
+
+    (case maybe_dfun_rdr_name of
+       Nothing            -> returnM Nothing
+       Just dfun_rdr_name -> lookupGlobalOccRn dfun_rdr_name   `thenM` \ dfun_name ->
+                             returnM (Just dfun_name)
+    )                                                  `thenM` \ maybe_dfun_name ->
+
+    -- The typechecker checks that all the bindings are for the right class.
+    returnM (InstDecl inst_ty' EmptyMonoBinds [] maybe_dfun_name src_loc)
+
+-- Compare finishSourceTyClDecl
+finishSourceInstDecl (InstDecl _       mbinds uprags _               _      )
+                    (InstDecl inst_ty _      _      maybe_dfun_name src_loc)
+       -- Used for both source decls only
+  = ASSERT( not (maybeToBool maybe_dfun_name) )        -- Source decl!

     let
     let

-       inst_tyvars = case inst_ty' of
-                       HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
-                       other                             -> []
+       meth_doc    = text "In the bindings in an instance declaration"
+       meth_names  = collectLocatedMonoBinders mbinds
+       (inst_tyvars, _, cls,_) = splitHsInstDeclTy inst_ty

        -- (Slightly strangely) the forall-d tyvars scope over
        -- the method bindings too
     in
 
        -- Rename the bindings
        -- NB meth_names can be qualified!
        -- (Slightly strangely) the forall-d tyvars scope over
        -- the method bindings too
     in
 
        -- Rename the bindings
        -- NB meth_names can be qualified!

-    checkDupNames meth_doc meth_names          `thenRn_`
-    extendTyVarEnvFVRn inst_tyvars (           
-       rnMethodBinds mbinds
-    )                                          `thenRn` \ (mbinds', meth_fvs) ->
+    checkDupNames meth_doc meth_names          `thenM_`
+    extendTyVarEnvForMethodBinds inst_tyvars (         
+       rnMethodBinds cls [] mbinds
+    )                                          `thenM` \ (mbinds', meth_fvs) ->

     let 
     let 

-       binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds')))
-
-       -- Delete sigs (&report) sigs that aren't allowed inside an
-       -- instance decl:
-       --
-       --  + type signatures
-       --  + fixity decls
-       --
-       (ok_sigs, not_ok_idecl_sigs) = partition okInInstDecl uprags
-       
-       okInInstDecl (FixSig _)  = False
-       okInInstDecl (Sig _ _ _) = False
-       okInInstDecl _           = True
-       
+       binders = collectMonoBinders mbinds'

     in
     in

-      -- You can't have fixity decls & type signatures
-      -- within an instance declaration.
-    mapRn_ unknownSigErr not_ok_idecl_sigs       `thenRn_`
-

        -- 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. 
        -- 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. 

-    renameSigs False binders lookupOccRn ok_sigs `thenRn` \ (new_uprags, prag_fvs) ->
-
-    getModeRn          `thenRn` \ mode ->
-    (case mode of
-       InterfaceMode -> lookupImplicitOccRn dfun_rdr_name              `thenRn` \ dfun_name ->
-                        returnRn (dfun_name, unitFV dfun_name)
-       SourceMode    -> newDFunName (getDFunKey inst_ty') src_loc      `thenRn` \ dfun_name ->
-                        returnRn (dfun_name, emptyFVs)
-    )                                                          `thenRn` \ (dfun_name, dfun_fv) ->
-
-       -- The typechecker checks that all the bindings are for the right class.
-    returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags dfun_name src_loc),
-             inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs `plusFV` dfun_fv)
-  where
-    meth_doc = text "the bindings in an instance declaration"
-    meth_names   = bagToList (collectMonoBinders mbinds)
+       --
+       -- But the (unqualified) method names are in scope
+    bindLocalNames binders (renameSigs uprags)                 `thenM` \ uprags' ->
+    checkSigs okInstDclSig (mkNameSet binders) uprags'         `thenM_`
+
+    returnM (InstDecl inst_ty mbinds' uprags' maybe_dfun_name src_loc,
+             meth_fvs `plusFV` hsSigsFVs uprags')

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

-\subsection{Default declarations}
+\subsection{Rules}

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

-rnDecl (DefD (DefaultDecl tys src_loc))
-  = pushSrcLocRn src_loc $
-    rnHsTypes doc_str tys              `thenRn` \ (tys', fvs) ->
-    lookupImplicitOccRn numClass_RDR   `thenRn` \ num ->
-    returnRn (DefD (DefaultDecl tys' src_loc), fvs `addOneFV` num)
+rnIfaceRuleDecl (IfaceRule rule_name act vars fn args rhs src_loc)
+  = addSrcLoc src_loc  $
+    lookupOccRn fn             `thenM` \ fn' ->
+    rnCoreBndrs vars           $ \ vars' ->
+    mappM rnCoreExpr args      `thenM` \ args' ->
+    rnCoreExpr rhs             `thenM` \ rhs' ->
+    returnM (IfaceRule rule_name act vars' fn' args' rhs' src_loc)
+
+rnIfaceRuleDecl (IfaceRuleOut fn rule)         -- Builtin rules come this way
+  = lookupOccRn fn             `thenM` \ fn' ->
+    returnM (IfaceRuleOut fn' rule)
+
+rnHsRuleDecl (HsRule rule_name act vars lhs rhs src_loc)
+  = addSrcLoc src_loc                          $
+    bindPatSigTyVars (collectRuleBndrSigTys vars)      $
+
+    bindLocalsFVRn doc (map get_var vars)      $ \ ids ->
+    mapFvRn rn_var (vars `zip` ids)            `thenM` \ (vars', fv_vars) ->
+
+    rnExpr lhs                                 `thenM` \ (lhs', fv_lhs) ->
+    rnExpr rhs                                 `thenM` \ (rhs', fv_rhs) ->
+    let
+       mb_bad = validRuleLhs ids lhs'
+    in
+    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' src_loc,
+             fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)

   where
   where

-    doc_str = text "a `default' declaration"
+    doc = text "In the transformation rule" <+> ftext rule_name
+  
+    get_var (RuleBndr v)      = v
+    get_var (RuleBndrSig v _) = v
+
+    rn_var (RuleBndr v, id)     = returnM (RuleBndr id, emptyFVs)
+    rn_var (RuleBndrSig v t, id) = rnHsTypeFVs doc t   `thenM` \ (t', fvs) ->
+                                  returnM (RuleBndrSig id t', fvs)

 \end{code}
 
 \end{code}
 

-%*********************************************************
-%*                                                     *
-\subsection{Foreign declarations}
-%*                                                     *
-%*********************************************************
+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}
 
 \begin{code}

-rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
-  = pushSrcLocRn src_loc $
-    lookupBndrRn name                  `thenRn` \ name' ->
-    let 
-       fvs1 = case imp_exp of
-               FoImport _ | not isDyn  -> emptyFVs
-               FoLabel                 -> emptyFVs
-               FoExport   | isDyn      -> mkNameSet [makeStablePtr_NAME,
-                                                     deRefStablePtr_NAME,
-                                                     bindIO_NAME]
-               _ -> emptyFVs
-    in
-    rnHsSigType fo_decl_msg ty                 `thenRn` \ (ty', fvs2) ->
-    returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc), 
-             fvs1 `plusFV` fvs2)
- where
-  fo_decl_msg = ptext SLIT("a foreign declaration")
-  isDyn              = isDynamic ext_nm
+validRuleLhs :: [Name] -> RenamedHsExpr -> Maybe RenamedHsExpr
+-- Nothing => OK
+-- Just e  => Not ok, and e is the offending expression
+validRuleLhs foralls lhs
+  = check lhs
+  where
+    check (OpApp e1 op _ e2)             = check op `seqMaybe` check_e e1 `seqMaybe` check_e e2
+    check (HsApp e1 e2)                  = check e1 `seqMaybe` check_e e2
+    check (HsVar v) | v `notElem` foralls = Nothing
+    check other                                  = Just other  -- Failure
+
+    check_e (HsVar v)     = Nothing
+    check_e (HsPar e)    = check_e e
+    check_e (HsLit e)    = Nothing
+    check_e (HsOverLit e) = Nothing
+
+    check_e (OpApp e1 op _ e2)          = check_e e1 `seqMaybe` check_e op `seqMaybe` check_e e2
+    check_e (HsApp e1 e2)               = check_e e1 `seqMaybe` check_e e2
+    check_e (NegApp e _)                = check_e e
+    check_e (ExplicitList _ es)         = check_es es
+    check_e (ExplicitTuple es _) = check_es es
+    check_e other               = Just other   -- Fails
+
+    check_es es = foldr (seqMaybe . check_e) Nothing es

 \end{code}
 
 \end{code}
 

+

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

-\subsection{Rules}
+\subsection{Type, class and iface sig 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.
+

 \begin{code}
 \begin{code}

-rnDecl (RuleD (IfaceRuleDecl var body src_loc))
-  = pushSrcLocRn src_loc                       $
-    lookupOccRn var            `thenRn` \ var' ->
-    rnRuleBody body            `thenRn` \ (body', fvs) ->
-    returnRn (RuleD (IfaceRuleDecl var' body' src_loc), fvs `addOneFV` var')
+rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc = loc})
+  = addSrcLoc loc $
+    lookupTopBndrRn name               `thenM` \ name' ->
+    rnHsType doc_str ty                        `thenM` \ ty' ->
+    mappM rnIdInfo id_infos            `thenM` \ id_infos' -> 
+    returnM (IfaceSig {tcdName = name', tcdType = ty', tcdIdInfo = id_infos', tcdLoc = loc})
+  where
+    doc_str = text "In the interface signature for" <+> quotes (ppr name)
+
+rnTyClDecl (ForeignType {tcdName = name, tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
+  = addSrcLoc loc                      $
+    lookupTopBndrRn name               `thenM` \ name' ->
+    returnM (ForeignType {tcdName = name', tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
+
+rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
+                   tcdTyVars = tyvars, tcdCons = condecls, tcdGeneric = want_generic,
+                   tcdDerivs = derivs, tcdLoc = src_loc})
+  = addSrcLoc src_loc $
+    lookupTopBndrRn tycon                      `thenM` \ tycon' ->
+    bindTyVarsRn data_doc tyvars               $ \ tyvars' ->
+    rnContext data_doc context                         `thenM` \ context' ->
+    rn_derivs derivs                           `thenM` \ derivs' ->
+    checkDupOrQualNames data_doc con_names     `thenM_`
+
+    rnConDecls tycon' condecls                 `thenM` \ condecls' ->
+    returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon',
+                    tcdTyVars = tyvars', tcdCons = condecls', tcdGeneric = want_generic,
+                    tcdDerivs = derivs', tcdLoc = src_loc})
+  where
+    data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
+    con_names = map conDeclName (visibleDataCons condecls)
+
+    rn_derivs Nothing   = returnM Nothing
+    rn_derivs (Just ds) = rnContext data_doc ds        `thenM` \ ds' -> returnM (Just ds')
+    
+rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc})
+  = addSrcLoc src_loc $
+    lookupTopBndrRn name                       `thenM` \ name' ->
+    bindTyVarsRn syn_doc tyvars                $ \ tyvars' ->
+    rnHsType syn_doc ty                                `thenM` \ ty' ->
+    returnM (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc})
+  where
+    syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)

 
 

-rnDecl (RuleD (RuleDecl rule_name tvs vars lhs rhs src_loc))
-  = ASSERT( null tvs )
-    pushSrcLocRn src_loc                       $
+rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname, 
+                      tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
+                      tcdLoc = src_loc})
+       -- Used for both source and interface file decls
+  = addSrcLoc src_loc $

 
 

-    bindTyVarsFV2Rn doc (map UserTyVar sig_tvs)        $ \ sig_tvs' _ ->
-    bindLocalsFVRn doc (map get_var vars)      $ \ ids ->
-    mapFvRn rn_var (vars `zip` ids)            `thenRn` \ (vars', fv_vars) ->
+    lookupTopBndrRn cname                      `thenM` \ cname' ->

 
 

-    rnExpr lhs                                 `thenRn` \ (lhs', fv_lhs) ->
-    rnExpr rhs                                 `thenRn` \ (rhs', fv_rhs) ->
-    checkRn (validRuleLhs ids lhs')
-           (badRuleLhsErr rule_name lhs')      `thenRn_`
+       -- Tyvars scope over superclass context and method signatures
+    bindTyVarsRn cls_doc tyvars                        $ \ tyvars' ->
+
+       -- Check the superclasses
+    rnContext cls_doc context                  `thenM` \ context' ->
+
+       -- Check the functional dependencies
+    rnFds cls_doc fds                          `thenM` \ fds' ->
+
+       -- Check the signatures
+       -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).

     let
     let

-       bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
+       (op_sigs, non_op_sigs) = partition isClassOpSig sigs
+       sig_rdr_names_w_locs   = [(op,locn) | ClassOpSig op _ _ locn <- sigs]

     in
     in

-    mapRn (addErrRn . badRuleVar rule_name) bad_vars   `thenRn_`
-    returnRn (RuleD (RuleDecl rule_name sig_tvs' vars' lhs' rhs' src_loc),
-             fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
+    checkDupOrQualNames sig_doc sig_rdr_names_w_locs   `thenM_` 
+    mappM (rnClassOp cname' fds') op_sigs              `thenM` \ sigs' ->
+    let
+       binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
+    in
+    renameSigs non_op_sigs                     `thenM` \ non_ops' ->
+    checkSigs okClsDclSig binders non_ops'     `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.
+
+    returnM (ClassDecl { tcdCtxt = context', tcdName = cname', tcdTyVars = tyvars',
+                        tcdFDs = fds', tcdSigs = non_ops' ++ sigs', tcdMeths = Nothing, 
+                        tcdLoc = src_loc})

   where
   where

-    doc = text "the transformation rule" <+> ptext rule_name
-    sig_tvs = extractRuleBndrsTyVars vars
-  
-    get_var (RuleBndr v)      = v
-    get_var (RuleBndrSig v _) = v
+    cls_doc  = text "In the declaration for class"     <+> ppr cname
+    sig_doc  = text "In the signatures for class"      <+> ppr cname

 
 

-    rn_var (RuleBndr v, id)     = returnRn (RuleBndr id, emptyFVs)
-    rn_var (RuleBndrSig v t, id) = rnHsType doc t      `thenRn` \ (t', fvs) ->
-                                  returnRn (RuleBndrSig id t', fvs)
+rnClassOp clas clas_fds sig@(ClassOpSig op dm_stuff ty locn)
+  = addSrcLoc locn $
+    lookupTopBndrRn op                 `thenM` \ op_name ->
+    
+       -- Check the signature
+    rnHsSigType (quotes (ppr op)) ty   `thenM` \ new_ty ->
+    
+       -- Make the default-method name
+    (case dm_stuff of 
+        DefMeth dm_rdr_name
+           ->  -- Imported class that has a default method decl
+               lookupSysBndr dm_rdr_name       `thenM` \ dm_name ->
+               returnM (DefMeth dm_name)
+                       -- An imported class decl for a class decl that had an explicit default
+                       -- method, mentions, rather than defines,
+                       -- the default method, so we must arrange to pull it in
+
+        GenDefMeth -> returnM GenDefMeth
+        NoDefMeth  -> returnM NoDefMeth
+    )                                          `thenM` \ dm_stuff' ->
+    
+    returnM (ClassOpSig op_name dm_stuff' new_ty locn)
+
+finishSourceTyClDecl :: RdrNameTyClDecl -> RenamedTyClDecl -> RnM (RenamedTyClDecl, FreeVars)
+       -- Used for source file decls only
+       -- Renames the default-bindings of a class decl
+finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc})    -- Get mbinds from here
+        rn_cls_decl@(ClassDecl {tcdName = cls, tcdTyVars = tyvars})            -- Everything else is here
+  -- There are some default-method bindings (abeit possibly empty) so 
+  -- this is a source-code class declaration
+  =    -- 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.  
+       -- Hence the 
+    addSrcLoc src_loc                          $
+    extendTyVarEnvForMethodBinds tyvars                        $
+    getLocalRdrEnv                                     `thenM` \ name_env ->
+    let
+       meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds
+       gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds,
+                                               not (tv `elemRdrEnv` name_env)]
+    in
+    checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenM_`
+    newLocalsRn gen_rdr_tyvars_w_locs                  `thenM` \ gen_tyvars ->
+    rnMethodBinds cls gen_tyvars mbinds                        `thenM` \ (mbinds', meth_fvs) ->
+    returnM (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs)
+  where
+    meth_doc = text "In the default-methods for class" <+> ppr (tcdName rn_cls_decl)
+
+finishSourceTyClDecl _ tycl_decl@(TyData {tcdDerivs = derivings})
+  -- Derivings are returned here so that they don't form part of the tyClDeclFVs.
+  -- This is important, because tyClDeclFVs should contain only the
+  -- FVs that are `needed' by the interface file declaration, and
+  -- derivings do not appear in this.  It also means that the tcGroups
+  -- are smaller, which turned out to be important for the usage inference. KSW 2002-02.
+  = returnM (tycl_decl,
+              maybe emptyFVs extractHsCtxtTyNames derivings)
+
+finishSourceTyClDecl _ tycl_decl = returnM (tycl_decl, emptyFVs)
+       -- Not a class declaration
+\end{code}
+
+For the method bindings in class and instance decls, we extend the 
+type variable environment iff -fglasgow-exts
+
+\begin{code}
+extendTyVarEnvForMethodBinds tyvars thing_inside
+  = doptM Opt_GlasgowExts                      `thenM` \ opt_GlasgowExts ->
+    if opt_GlasgowExts then
+       extendTyVarEnvFVRn (map hsTyVarName tyvars) thing_inside
+    else
+       thing_inside

 \end{code}
 
 
 \end{code}
 
 

@@ -422,88 +664,63 @@ rnDecl (RuleD (RuleDecl rule_name tvs vars lhs rhs src_loc))
 %*********************************************************
 
 \begin{code}
 %*********************************************************
 
 \begin{code}

-rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name], FreeVars)
-
-rnDerivs Nothing -- derivs not specified
-  = returnRn (Nothing, emptyFVs)
-
-rnDerivs (Just ds)
-  = mapFvRn rn_deriv ds                `thenRn` \ (derivs, fvs) ->
-    returnRn (Just derivs, fvs)
-  where
-    rn_deriv clas
-      = lookupOccRn clas           `thenRn` \ clas_name ->
-
-               -- Now add extra "occurrences" for things that
-               -- the deriving mechanism will later need in order to
-               -- generate code for this class.
-       case lookupUFM derivingOccurrences clas_name of
-               Nothing -> addErrRn (derivingNonStdClassErr clas_name)  `thenRn_`
-                          returnRn (clas_name, unitFV clas_name)
-
-               Just occs -> mapRn lookupImplicitOccRn occs     `thenRn` \ names ->
-                            returnRn (clas_name, mkNameSet (clas_name : names))
-\end{code}
-
-\begin{code}

 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
 conDeclName (ConDecl n _ _ _ l) = (n,l)
 
 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
 conDeclName (ConDecl n _ _ _ l) = (n,l)
 

-rnConDecl :: RdrNameConDecl -> RnMS (RenamedConDecl, FreeVars)
+rnConDecls :: Name -> DataConDetails RdrNameConDecl -> RnM (DataConDetails RenamedConDecl)
+rnConDecls tycon Unknown     = returnM Unknown
+rnConDecls tycon (HasCons n) = returnM (HasCons n)
+rnConDecls tycon (DataCons 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 ->
+       getModeRn               `thenM` \ mode ->
+       checkErr (glaExts || isInterfaceMode mode)
+               (emptyConDeclsErr tycon)
+     else returnM ()
+    )                                          `thenM_` 
+
+    mappM rnConDecl condecls                   `thenM` \ condecls' ->
+    returnM (DataCons condecls')
+
+rnConDecl :: RdrNameConDecl -> RnM RenamedConDecl

 rnConDecl (ConDecl name tvs cxt details locn)
 rnConDecl (ConDecl name tvs cxt details locn)

-  = pushSrcLocRn locn $
-    checkConName name                  `thenRn_` 
-    lookupBndrRn name                  `thenRn` \ new_name ->
-    bindTyVarsFVRn doc tvs             $ \ new_tyvars ->
-    rnContext doc cxt                  `thenRn` \ (new_context, cxt_fvs) ->
-    rnConDetails doc locn details      `thenRn` \ (new_details, det_fvs) -> 
-    returnRn (ConDecl new_name new_tyvars new_context new_details locn,
-             cxt_fvs `plusFV` det_fvs)
+  = addSrcLoc locn $
+    checkConName name          `thenM_` 
+    lookupTopBndrRn name       `thenM` \ new_name ->
+
+    bindTyVarsRn doc tvs               $ \ new_tyvars ->
+    rnContext doc cxt                  `thenM` \ new_context ->
+    rnConDetails doc locn details      `thenM` \ new_details -> 
+    returnM (ConDecl new_name new_tyvars new_context new_details locn)

   where
   where

-    doc = text "the definition of data constructor" <+> quotes (ppr name)
+    doc = text "In the definition of data constructor" <+> quotes (ppr name)

 
 

-rnConDetails doc locn (VanillaCon tys)
-  = mapFvRn (rnBangTy doc) tys `thenRn` \ (new_tys, fvs)  ->
-    returnRn (VanillaCon new_tys, fvs)
+rnConDetails doc locn (PrefixCon tys)
+  = mappM (rnBangTy doc) tys   `thenM` \ new_tys  ->
+    returnM (PrefixCon new_tys)

 
 rnConDetails doc locn (InfixCon ty1 ty2)
 
 rnConDetails doc locn (InfixCon ty1 ty2)

-  = rnBangTy doc ty1           `thenRn` \ (new_ty1, fvs1) ->
-    rnBangTy doc ty2           `thenRn` \ (new_ty2, fvs2) ->
-    returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2)
-
-rnConDetails doc locn (NewCon ty mb_field)
-  = rnHsType doc ty                    `thenRn` \ (new_ty, fvs) ->
-    rn_field mb_field                  `thenRn` \ new_mb_field  ->
-    returnRn (NewCon new_ty new_mb_field, fvs)
-  where
-    rn_field Nothing  = returnRn Nothing
-    rn_field (Just f) =
-       lookupBndrRn f      `thenRn` \ new_f ->
-       returnRn (Just new_f)
+  = rnBangTy doc ty1           `thenM` \ new_ty1 ->
+    rnBangTy doc ty2           `thenM` \ new_ty2 ->
+    returnM (InfixCon new_ty1 new_ty2)

 
 rnConDetails doc locn (RecCon fields)
 
 rnConDetails doc locn (RecCon fields)

-  = checkDupOrQualNames doc field_names        `thenRn_`
-    mapFvRn (rnField doc) fields       `thenRn` \ (new_fields, fvs) ->
-    returnRn (RecCon new_fields, fvs)
+  = checkDupOrQualNames doc field_names        `thenM_`
+    mappM (rnField doc) fields         `thenM` \ new_fields ->
+    returnM (RecCon new_fields)

   where
   where

-    field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
+    field_names = [(fld, locn) | (fld, _) <- fields]

 
 

-rnField doc (names, ty)
-  = mapRn lookupBndrRn names   `thenRn` \ new_names ->
-    rnBangTy doc ty            `thenRn` \ (new_ty, fvs) ->
-    returnRn ((new_names, new_ty), fvs) 
+rnField doc (name, ty)
+  = lookupTopBndrRn name       `thenM` \ new_name ->
+    rnBangTy doc ty            `thenM` \ new_ty ->
+    returnM (new_name, new_ty) 

 
 

-rnBangTy doc (Banged ty)
-  = rnHsType doc ty            `thenRn` \ (new_ty, fvs) ->
-    returnRn (Banged new_ty, fvs)
-
-rnBangTy doc (Unbanged ty)
-  = rnHsType doc ty            `thenRn` \ (new_ty, fvs) ->
-    returnRn (Unbanged new_ty, fvs)
-
-rnBangTy doc (Unpacked ty)
-  = rnHsType doc ty            `thenRn` \ (new_ty, fvs) ->
-    returnRn (Unpacked new_ty, fvs)
+rnBangTy doc (BangType s ty)
+  = rnHsType doc ty            `thenM` \ new_ty ->
+    returnM (BangType s new_ty)

 
 -- This data decl will parse OK
 --     data T = a Int
 
 -- This data decl will parse OK
 --     data T = a Int

@@ -516,8 +733,7 @@ rnBangTy doc (Unpacked ty)
 -- from interface files, which always print in prefix form
 
 checkConName name
 -- from interface files, which always print in prefix form
 
 checkConName name

-  = checkRn (isRdrDataCon name)
-           (badDataCon name)
+  = checkErr (isRdrDataCon name) (badDataCon name)

 \end{code}
 
 
 \end{code}
 
 

@@ -528,244 +744,110 @@ checkConName name
 %*********************************************************
 
 \begin{code}
 %*********************************************************
 
 \begin{code}

-rnHsSigType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
-       -- rnHsSigType is used for source-language type signatures,
-       -- which use *implicit* universal quantification.
-rnHsSigType doc_str ty
-  = rnHsType (text "the type signature for" <+> doc_str) ty
-    
-rnForAll doc forall_tyvars ctxt ty
-  = bindTyVarsFVRn doc forall_tyvars                   $ \ new_tyvars ->
-    rnContext doc ctxt                                 `thenRn` \ (new_ctxt, cxt_fvs) ->
-    rnHsType doc ty                                    `thenRn` \ (new_ty, ty_fvs) ->
-    returnRn (mkHsForAllTy new_tyvars new_ctxt new_ty,
-             cxt_fvs `plusFV` ty_fvs)
-
--- Check that each constraint mentions at least one of the forall'd type variables
--- Since the forall'd type variables are a subset of the free tyvars
--- of the tau-type part, this guarantees that every constraint mentions
--- at least one of the free tyvars in ty
-checkConstraints explicit_forall doc forall_tyvars ctxt ty
-   = mapRn check ctxt                  `thenRn` \ maybe_ctxt' ->
-     returnRn (catMaybes maybe_ctxt')
-           -- Remove problem ones, to avoid duplicate error message.
-   where
-     check ct@(_,tys)
-       | forall_mentioned = returnRn (Just ct)
-       | otherwise        = addErrRn (ctxtErr explicit_forall doc forall_tyvars ct ty) `thenRn_`
-                            returnRn Nothing
-        where
-         forall_mentioned = foldr ((||) . any (`elem` forall_tyvars) . extractHsTyRdrNames)
-                            False
-                            tys
-
-freeRdrTyVars   :: RdrNameHsType -> [RdrName]
-freeRdrTyVars ty =  filter isRdrTyVar (extractHsTyRdrNames ty)
-
-rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
-
-rnHsType doc (HsForAllTy Nothing ctxt ty)
-       -- From source code (no kinds on tyvars)
-       -- Given the signature  C => T  we universally quantify 
-       -- over FV(T) \ {in-scope-tyvars} 
-  = getLocalNameEnv            `thenRn` \ name_env ->
-    let
-       mentioned_in_tau = freeRdrTyVars ty
-       forall_tyvars    = filter (not . (`elemFM` name_env)) mentioned_in_tau
-    in
-    checkConstraints False doc forall_tyvars ctxt ty   `thenRn` \ ctxt' ->
-    rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty
-
-rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
-       -- Explicit quantification.
-       -- Check that the forall'd tyvars are a subset of the
-       -- free tyvars in the tau-type part
-       -- That's only a warning... unless the tyvar is constrained by a 
-       -- context in which case it's an error
-  = let
-       mentioned_in_tau  = freeRdrTyVars tau
-       mentioned_in_ctxt = nub [tv | (_,tys) <- ctxt,
-                                     ty <- tys,
-                                     tv <- freeRdrTyVars ty]
-
-       dubious_guys          = filter (`notElem` mentioned_in_tau) forall_tyvar_names
-               -- dubious = explicitly quantified but not mentioned in tau type
-
-       (bad_guys, warn_guys) = partition (`elem` mentioned_in_ctxt) dubious_guys
-               -- bad  = explicitly quantified and constrained, but not mentioned in tau
-               -- warn = explicitly quantified but not mentioned in ctxt or tau
- 
-       forall_tyvar_names    = map getTyVarName forall_tyvars
-    in
-    mapRn_ (forAllErr doc tau) bad_guys                        `thenRn_`
-    mapRn_ (forAllWarn doc tau) warn_guys                      `thenRn_`
-    checkConstraints True doc forall_tyvar_names ctxt tau      `thenRn` \ ctxt' ->
-    rnForAll doc forall_tyvars ctxt' tau
-
-rnHsType doc (MonoTyVar tyvar)
-  = lookupOccRn tyvar          `thenRn` \ tyvar' ->
-    returnRn (MonoTyVar tyvar', unitFV tyvar')
-
-rnHsType doc (MonoFunTy ty1 ty2)
-  = rnHsType doc ty1   `thenRn` \ (ty1', fvs1) ->
-    rnHsType doc ty2   `thenRn` \ (ty2', fvs2) ->
-    returnRn (MonoFunTy ty1' ty2', fvs1 `plusFV` fvs2)
-
-rnHsType doc (MonoListTy ty)
-  = rnHsType doc ty                            `thenRn` \ (ty', fvs) ->
-    returnRn (MonoListTy ty', fvs `addOneFV` listTyCon_name)
-
-rnHsType doc (MonoTupleTy tys boxed)
-  = rnHsTypes doc tys                  `thenRn` \ (tys', fvs) ->
-    returnRn (MonoTupleTy tys' boxed, fvs `addOneFV` tup_con_name)
-  where
-    tup_con_name = tupleTyCon_name boxed (length tys)
-
-rnHsType doc (MonoTyApp ty1 ty2)
-  = rnHsType doc ty1           `thenRn` \ (ty1', fvs1) ->
-    rnHsType doc ty2           `thenRn` \ (ty2', fvs2) ->
-    returnRn (MonoTyApp ty1' ty2', fvs1 `plusFV` fvs2)
-
-rnHsType doc (MonoDictTy clas tys)
-  = lookupOccRn clas           `thenRn` \ clas' ->
-    rnHsTypes doc tys          `thenRn` \ (tys', fvs) ->
-    returnRn (MonoDictTy clas' tys', fvs `addOneFV` clas')
-
-rnHsType doc (MonoUsgTy usg ty)
-  = rnHsType doc ty             `thenRn` \ (ty', fvs) ->
-    returnRn (MonoUsgTy usg ty', fvs)
-
-rnHsTypes doc tys = mapFvRn (rnHsType doc) tys
-\end{code}
+rnFds :: SDoc -> [FunDep RdrName] -> RnM [FunDep Name]

 
 

-
-\begin{code}
-rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
-
-rnContext doc ctxt
-  = mapAndUnzipRn rn_ctxt ctxt         `thenRn` \ (theta, fvs_s) ->
-    let
-       (_, dup_asserts) = removeDups cmp_assert theta
-    in
-       -- Check for duplicate assertions
-       -- If this isn't an error, then it ought to be:
-    mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts  `thenRn_`
-
-    returnRn (theta, plusFVs fvs_s)
+rnFds doc fds
+  = mappM rn_fds fds

   where
   where

-    rn_ctxt (clas, tys)
-      =        lookupOccRn clas                `thenRn` \ clas_name ->
-       rnHsTypes doc tys               `thenRn` \ (tys', fvs) ->
-       returnRn ((clas_name, tys'), fvs `addOneFV` clas_name)
+    rn_fds (tys1, tys2)
+      =        rnHsTyVars doc tys1             `thenM` \ tys1' ->
+       rnHsTyVars doc tys2             `thenM` \ tys2' ->
+       returnM (tys1', tys2')

 
 

-    cmp_assert (c1,tys1) (c2,tys2)
-      = (c1 `compare` c2) `thenCmp` (cmpHsTypes compare tys1 tys2)
+rnHsTyVars doc tvs  = mappM (rnHsTyvar doc) tvs
+rnHsTyvar doc tyvar = lookupOccRn tyvar

 \end{code}
 
 \end{code}
 

-

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

-%*                                                     *
+%*                                                      *

 \subsection{IdInfo}
 \subsection{IdInfo}

-%*                                                     *
+%*                                                      *

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

-rnIdInfo (HsStrictness str) = returnRn (HsStrictness str, emptyFVs)
-
-rnIdInfo (HsWorker worker)
-  = lookupOccRn worker                 `thenRn` \ worker' ->
-    returnRn (HsWorker worker', unitFV worker')
-
-rnIdInfo (HsUnfold inline (Just expr)) = rnCoreExpr expr       `thenRn` \ (expr', fvs) ->
-                                         returnRn (HsUnfold inline (Just expr'), fvs)
-rnIdInfo (HsUnfold inline Nothing)     = returnRn (HsUnfold inline Nothing, emptyFVs)
-rnIdInfo (HsArity arity)       = returnRn (HsArity arity, emptyFVs)
-rnIdInfo (HsUpdate update)     = returnRn (HsUpdate update, emptyFVs)
-rnIdInfo (HsNoCafRefs)         = returnRn (HsNoCafRefs, emptyFVs)
-rnIdInfo (HsCprInfo cpr_info)  = returnRn (HsCprInfo cpr_info, emptyFVs)
-rnIdInfo (HsSpecialise rule_body) = rnRuleBody rule_body       `thenRn` \ (rule_body', fvs) ->
-                                   returnRn (HsSpecialise rule_body', fvs)
-
-rnRuleBody (UfRuleBody str vars args rhs)
-  = rnCoreBndrs vars           $ \ vars' ->
-    mapFvRn rnCoreExpr args    `thenRn` \ (args', fvs1) ->
-    rnCoreExpr rhs             `thenRn` \ (rhs',  fvs2) ->
-    returnRn (UfRuleBody str vars' args' rhs', fvs1 `plusFV` fvs2)
+rnIdInfo (HsWorker worker arity)
+  = lookupOccRn worker                 `thenM` \ worker' ->
+    returnM (HsWorker worker' arity)
+
+rnIdInfo (HsUnfold inline expr)        = rnCoreExpr expr `thenM` \ expr' ->
+                                 returnM (HsUnfold inline expr')
+rnIdInfo (HsStrictness str)     = returnM (HsStrictness str)
+rnIdInfo (HsArity arity)       = returnM (HsArity arity)
+rnIdInfo HsNoCafRefs           = returnM HsNoCafRefs

 \end{code}
 
 \end{code}
 

-UfCore expressions.
+@UfCore@ expressions.

 
 \begin{code}
 rnCoreExpr (UfType ty)
 
 \begin{code}
 rnCoreExpr (UfType ty)

-  = rnHsType (text "unfolding type") ty        `thenRn` \ (ty', fvs) ->
-    returnRn (UfType ty', fvs)
+  = rnHsType (text "unfolding type") ty        `thenM` \ ty' ->
+    returnM (UfType ty')

 
 rnCoreExpr (UfVar v)
 
 rnCoreExpr (UfVar v)

-  = lookupOccRn v      `thenRn` \ v' ->
-    returnRn (UfVar v', unitFV v')
+  = lookupOccRn v      `thenM` \ v' ->
+    returnM (UfVar v')
+
+rnCoreExpr (UfLit l)
+  = returnM (UfLit l)
+
+rnCoreExpr (UfLitLit l ty)
+  = rnHsType (text "litlit") ty        `thenM` \ ty' ->
+    returnM (UfLitLit l ty')

 
 

-rnCoreExpr (UfCon con args) 
-  = rnUfCon con                        `thenRn` \ (con', fvs1) ->
-    mapFvRn rnCoreExpr args    `thenRn` \ (args', fvs2) ->
-    returnRn (UfCon con' args', fvs1 `plusFV` fvs2)
+rnCoreExpr (UfFCall cc ty)
+  = rnHsType (text "ccall") ty `thenM` \ ty' ->
+    returnM (UfFCall cc ty')

 
 

-rnCoreExpr (UfTuple con args) 
-  = lookupOccRn con            `thenRn` \ con' ->
-    mapFvRn rnCoreExpr args    `thenRn` \ (args', fvs) ->
-    returnRn (UfTuple con' args', fvs `addOneFV` con')
+rnCoreExpr (UfTuple (HsTupCon boxity arity) args) 
+  = mappM rnCoreExpr args              `thenM` \ args' ->
+    returnM (UfTuple (HsTupCon boxity arity) args')

 
 rnCoreExpr (UfApp fun arg)
 
 rnCoreExpr (UfApp fun arg)

-  = rnCoreExpr fun             `thenRn` \ (fun', fv1) ->
-    rnCoreExpr arg             `thenRn` \ (arg', fv2) ->
-    returnRn (UfApp fun' arg', fv1 `plusFV` fv2)
+  = rnCoreExpr fun             `thenM` \ fun' ->
+    rnCoreExpr arg             `thenM` \ arg' ->
+    returnM (UfApp fun' arg')

 
 rnCoreExpr (UfCase scrut bndr alts)
 
 rnCoreExpr (UfCase scrut bndr alts)

-  = rnCoreExpr scrut                   `thenRn` \ (scrut', fvs1) ->
-    bindCoreLocalFVRn bndr             ( \ bndr' ->
-       mapFvRn rnCoreAlt alts          `thenRn` \ (alts', fvs2) ->
-       returnRn (UfCase scrut' bndr' alts', fvs2)
-    )                                          `thenRn` \ (case', fvs3) ->
-    returnRn (case', fvs1 `plusFV` fvs3)
+  = rnCoreExpr scrut                   `thenM` \ scrut' ->
+    bindCoreLocalRn bndr               $ \ bndr' ->
+    mappM rnCoreAlt alts               `thenM` \ alts' ->
+    returnM (UfCase scrut' bndr' alts')

 
 rnCoreExpr (UfNote note expr) 
 
 rnCoreExpr (UfNote note expr) 

-  = rnNote note                        `thenRn` \ (note', fvs1) ->
-    rnCoreExpr expr            `thenRn` \ (expr', fvs2) ->
-    returnRn  (UfNote note' expr', fvs1 `plusFV` fvs2) 
+  = rnNote note                        `thenM` \ note' ->
+    rnCoreExpr expr            `thenM` \ expr' ->
+    returnM  (UfNote note' expr')

 
 rnCoreExpr (UfLam bndr body)
   = rnCoreBndr bndr            $ \ bndr' ->
 
 rnCoreExpr (UfLam bndr body)
   = rnCoreBndr bndr            $ \ bndr' ->

-    rnCoreExpr body            `thenRn` \ (body', fvs) ->
-    returnRn (UfLam bndr' body', fvs)
+    rnCoreExpr body            `thenM` \ body' ->
+    returnM (UfLam bndr' body')

 
 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
 
 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)

-  = rnCoreExpr rhs             `thenRn` \ (rhs', fvs1) ->
-    rnCoreBndr bndr            ( \ bndr' ->
-       rnCoreExpr body         `thenRn` \ (body', fvs2) ->
-       returnRn (UfLet (UfNonRec bndr' rhs') body', fvs2)
-    )                          `thenRn` \ (result, fvs3) ->
-    returnRn (result, fvs1 `plusFV` fvs3)
+  = rnCoreExpr rhs             `thenM` \ rhs' ->
+    rnCoreBndr bndr            $ \ bndr' ->
+    rnCoreExpr body            `thenM` \ body' ->
+    returnM (UfLet (UfNonRec bndr' rhs') body')

 
 rnCoreExpr (UfLet (UfRec pairs) body)
   = rnCoreBndrs bndrs          $ \ bndrs' ->
 
 rnCoreExpr (UfLet (UfRec pairs) body)
   = rnCoreBndrs bndrs          $ \ bndrs' ->

-    mapFvRn rnCoreExpr rhss    `thenRn` \ (rhss', fvs1) ->
-    rnCoreExpr body            `thenRn` \ (body', fvs2) ->
-    returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body', fvs1 `plusFV` fvs2)
+    mappM rnCoreExpr rhss      `thenM` \ rhss' ->
+    rnCoreExpr body            `thenM` \ body' ->
+    returnM (UfLet (UfRec (bndrs' `zip` rhss')) body')

   where
     (bndrs, rhss) = unzip pairs
 \end{code}
 
 \begin{code}
 rnCoreBndr (UfValBinder name ty) thing_inside
   where
     (bndrs, rhss) = unzip pairs
 \end{code}
 
 \begin{code}
 rnCoreBndr (UfValBinder name ty) thing_inside

-  = rnHsType doc ty            `thenRn` \ (ty', fvs1) ->
-    bindCoreLocalFVRn name     ( \ name' ->
-           thing_inside (UfValBinder name' ty')
-    )                          `thenRn` \ (result, fvs2) ->
-    returnRn (result, fvs1 `plusFV` fvs2)
+  = rnHsType doc ty            `thenM` \ ty' ->
+    bindCoreLocalRn name       $ \ name' ->
+    thing_inside (UfValBinder name' ty')

   where
     doc = text "unfolding id"
     
 rnCoreBndr (UfTyBinder name kind) thing_inside
   where
     doc = text "unfolding id"
     
 rnCoreBndr (UfTyBinder name kind) thing_inside

-  = bindCoreLocalFVRn name             $ \ name' ->
+  = bindCoreLocalRn name               $ \ name' ->

     thing_inside (UfTyBinder name' kind)
     
 rnCoreBndrs []     thing_inside = thing_inside []
     thing_inside (UfTyBinder name' kind)
     
 rnCoreBndrs []     thing_inside = thing_inside []

@@ -776,134 +858,125 @@ rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b          $ \ name' ->
 
 \begin{code}
 rnCoreAlt (con, bndrs, rhs)
 
 \begin{code}
 rnCoreAlt (con, bndrs, rhs)

-  = rnUfCon con                                `thenRn` \ (con', fvs1) ->
-    bindCoreLocalsFVRn bndrs           ( \ bndrs' ->
-       rnCoreExpr rhs                  `thenRn` \ (rhs', fvs2) ->
-       returnRn ((con', bndrs', rhs'), fvs2)
-    )                                  `thenRn` \ (result, fvs3) ->
-    returnRn (result, fvs1 `plusFV` fvs3)
+  = rnUfCon con                        `thenM` \ con' ->
+    bindCoreLocalsRn bndrs             $ \ bndrs' ->
+    rnCoreExpr rhs                     `thenM` \ rhs' ->
+    returnM (con', bndrs', rhs')

 
 rnNote (UfCoerce ty)
 
 rnNote (UfCoerce ty)

-  = rnHsType (text "unfolding coerce") ty      `thenRn` \ (ty', fvs) ->
-    returnRn (UfCoerce ty', fvs)
+  = rnHsType (text "unfolding coerce") ty      `thenM` \ ty' ->
+    returnM (UfCoerce ty')

 
 

-rnNote (UfSCC cc)   = returnRn (UfSCC cc, emptyFVs)
-rnNote UfInlineCall = returnRn (UfInlineCall, emptyFVs)
-rnNote UfInlineMe   = returnRn (UfInlineMe, emptyFVs)
+rnNote (UfSCC cc)   = returnM (UfSCC cc)
+rnNote UfInlineCall = returnM UfInlineCall
+rnNote UfInlineMe   = returnM UfInlineMe

 
 
 rnUfCon UfDefault
 
 
 rnUfCon UfDefault

-  = returnRn (UfDefault, emptyFVs)
+  = returnM UfDefault

 
 

-rnUfCon (UfDataCon con)
-  = lookupOccRn con            `thenRn` \ con' ->
-    returnRn (UfDataCon con', unitFV con')
+rnUfCon (UfTupleAlt tup_con)
+  = returnM (UfTupleAlt tup_con)

 
 

-rnUfCon (UfLitCon lit)
-  = returnRn (UfLitCon lit, emptyFVs)
+rnUfCon (UfDataAlt con)
+  = lookupOccRn con            `thenM` \ con' ->
+    returnM (UfDataAlt con')

 
 

-rnUfCon (UfLitLitCon lit ty)
-  = rnHsType (text "litlit") ty                `thenRn` \ (ty', fvs) ->
-    returnRn (UfLitLitCon lit ty', fvs)
+rnUfCon (UfLitAlt lit)
+  = returnM (UfLitAlt lit)

 
 

-rnUfCon (UfPrimOp op)
-  = lookupOccRn op             `thenRn` \ op' ->
-    returnRn (UfPrimOp op', emptyFVs)
-
-rnUfCon (UfCCallOp str is_dyn casm gc)
-  = returnRn (UfCCallOp str is_dyn casm gc, emptyFVs)
+rnUfCon (UfLitLitAlt lit ty)
+  = rnHsType (text "litlit") ty                `thenM` \ ty' ->
+    returnM (UfLitLitAlt lit ty')

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

-\subsection{Rule shapes}
+\subsection{Statistics}

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

-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.
-

 \begin{code}
 \begin{code}

-validRuleLhs foralls lhs
-  = check lhs
+rnStats :: [RenamedHsDecl]     -- Imported decls
+       -> TcRn m ()
+rnStats imp_decls
+  = doptM Opt_D_dump_rn_trace  `thenM` \ dump_rn_trace ->
+    doptM Opt_D_dump_rn_stats  `thenM` \ dump_rn_stats ->
+    doptM Opt_D_dump_rn        `thenM` \ dump_rn ->
+    getEps                     `thenM` \ eps ->
+
+    ioToTcRn (dumpIfSet (dump_rn_trace || dump_rn_stats || dump_rn)
+                       "Renamer statistics"
+                       (getRnStats eps imp_decls))     `thenM_`
+    returnM ()
+
+getRnStats :: ExternalPackageState -> [RenamedHsDecl] -> SDoc
+getRnStats eps imported_decls
+  = hcat [text "Renamer stats: ", stats]

   where
   where

-    check (HsApp e1 e2)                  = check e1
-    check (HsVar v) | v `notElem` foralls = True
-    check other                                  = False
-\end{code}
+    n_mods = length [() | _ <- moduleEnvElts (eps_PIT eps)]
+       -- This is really only right for a one-shot compile

 
 

+    (decls_map, n_decls_slurped) = eps_decls eps
+    
+    n_decls_left   = length [decl | (avail, True, (_,decl)) <- nameEnvElts decls_map
+                       -- Data, newtype, and class decls are in the decls_fm
+                       -- under multiple names; the tycon/class, and each
+                       -- constructor/class op too.
+                       -- The 'True' selects just the 'main' decl
+                    ]
+    
+    (insts_left, n_insts_slurped) = eps_insts eps
+    n_insts_left  = length (bagToList insts_left)
+    
+    (rules_left, n_rules_slurped) = eps_rules eps
+    n_rules_left  = length (bagToList rules_left)
+    
+    stats = vcat 
+       [int n_mods <+> text "interfaces read",
+        hsep [ int n_decls_slurped, text "type/class/variable imported, out of", 
+               int (n_decls_slurped + n_decls_left), text "read"],
+        hsep [ int n_insts_slurped, text "instance decls imported, out of",  
+               int (n_insts_slurped + n_insts_left), text "read"],
+        hsep [ int n_rules_slurped, text "rule decls imported, out of",  
+               int (n_rules_slurped + n_rules_left), text "read"]
+       ]
+\end{code}    

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

-%*                                                     *
+%*                                                      *

 \subsection{Errors}
 \subsection{Errors}

-%*                                                     *
+%*                                                      *

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

-derivingNonStdClassErr clas
-  = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
-
-classTyVarNotInOpTyErr clas_tyvar sig
-  = hang (hsep [ptext SLIT("Class type variable"),
-                      quotes (ppr clas_tyvar),
-                      ptext SLIT("does not appear in method signature")])
-        4 (ppr sig)
-
-dupClassAssertWarn ctxt (assertion : dups)
-  = sep [hsep [ptext SLIT("Duplicate class assertion"), 
-              quotes (pprClassAssertion assertion),
-              ptext SLIT("in the context:")],
-        nest 4 (pprContext ctxt <+> ptext SLIT("..."))]
-

 badDataCon name
    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 
 badDataCon name
    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 

-forAllWarn doc ty tyvar
-  | not opt_WarnUnusedMatches = returnRn ()
-  | otherwise
-  = getModeRn          `thenRn` \ mode ->
-    case mode of {
-#ifndef DEBUG
-       InterfaceMode -> returnRn () ;  -- Don't warn of unused tyvars in interface files
-                                       -- unless DEBUG is on, in which case it is slightly
-                                       -- informative.  They can arise from mkRhsTyLam,
-#endif                                 -- leading to (say)     f :: forall a b. [b] -> [b]
-       other ->
-
-    addWarnRn (
-      sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
-          nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
-      $$
-      (ptext SLIT("In") <+> doc))
-    }
-
-forAllErr doc ty tyvar
-  = addErrRn (
-      sep [ptext SLIT("The constrained type variable") <+> quotes (ppr tyvar),
-          nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
-      $$
-      (ptext SLIT("In") <+> doc))
-
-ctxtErr explicit_forall doc tyvars constraint ty
-  = sep [ptext SLIT("None of the type variable(s) in the constraint") <+> quotes (pprClassAssertion constraint) <+>
-                  ptext SLIT("does not mention any of"),
-        if explicit_forall then
-          nest 4 (ptext SLIT("is universally quantified (i.e. bound by the forall)"))
-        else
-          nest 4 (ptext SLIT("appears in the type") <+> quotes (ppr ty))
-    ]
-    $$
-    (ptext SLIT("In") <+> doc)
-
-badRuleLhsErr name lhs
-  = sep [ptext SLIT("Rule") <+> ptext name <> colon,
-        nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
+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
     $$
     ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
 
 badRuleVar name var

-  = sep [ptext SLIT("Rule") <+> ptext name <> colon,
+  = 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")]
         ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+> 
                ptext SLIT("does not appear on left hand side")]

+
+emptyConDeclsErr tycon
+  = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
+        nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))]
+
+withWarning
+  = sep [quotes (ptext SLIT("with")),
+        ptext SLIT("is deprecated, use"),
+        quotes (ptext SLIT("let")),
+        ptext SLIT("instead")]
+
+badIpBinds binds
+  = hang (ptext SLIT("Implicit-parameter bindings illegal in 'mdo':")) 4
+        (ppr binds)

 \end{code}
 \end{code}

+