[project @ 2002-02-06 12:12:25 by keithw]

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

diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 1fd4d95..85c7cb5 100644 (file)
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -4,130 +4,261 @@
 \section[RnSource]{Main pass of renamer}
 
 \begin{code}
 \section[RnSource]{Main pass of renamer}
 
 \begin{code}

-module RnSource ( rnIfaceDecl, rnSourceDecls, rnHsType, rnHsSigType ) where
+module RnSource ( rnTyClDecl, rnIfaceRuleDecl, rnInstDecl, rnSourceDecls, 
+       ) where

 
 #include "HsVersions.h"
 
 import RnExpr
 import HsSyn
 
 #include "HsVersions.h"
 
 import RnExpr
 import HsSyn

-import HsDecls         ( HsIdInfo(..), HsStrictnessInfo(..) )
-import HsPragmas
-import HsTypes         ( getTyVarName, pprClassAssertion, cmpHsTypes )
-import RdrName         ( RdrName, isRdrDataCon, rdrNameOcc )
-import RdrHsSyn                ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
-                         extractHsTyVars
+import HscTypes                ( GlobalRdrEnv, AvailEnv )
+import RdrName         ( RdrName, isRdrDataCon, elemRdrEnv )
+import RdrHsSyn                ( RdrNameConDecl, RdrNameTyClDecl,
+                         extractGenericPatTyVars

                        )
 import RnHsSyn
 import HsCore
 
                        )
 import RnHsSyn
 import HsCore
 

-import RnBinds         ( rnTopBinds, rnMethodBinds, renameSigs )
-import RnEnv           ( bindTyVarsRn, lookupBndrRn, lookupOccRn, 
-                         lookupImplicitOccRn, addImplicitOccRn,
-                         bindLocalsRn, 
-                         bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn,
-                         checkDupOrQualNames, checkDupNames,
-                         newLocallyDefinedGlobalName, newImportedGlobalName, 
-                         newImportedGlobalFromRdrName,
-                         newDFunName,
-                         FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV
+import RnTypes         ( rnHsType, rnHsSigType, rnHsTypeFVs, rnContext )
+
+import RnBinds         ( rnTopBinds, rnMethodBinds, renameSigs, renameSigsFVs )
+import RnEnv           ( lookupTopBndrRn, lookupOccRn, lookupIfaceName,
+                         lookupSysBinder, newLocalsRn,
+                         bindLocalsFVRn, bindPatSigTyVars,
+                         bindTyVarsRn, extendTyVarEnvFVRn,
+                         bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames,
+                         checkDupOrQualNames, checkDupNames, mapFvRn

                        )
 import RnMonad
 
                        )
 import RnMonad
 

-import Name            ( Name, OccName,
-                         ExportFlag(..), Provenance(..), 
-                         nameOccName, NamedThing(..),
-                         mkDefaultMethodOcc, mkDFunOcc
-                       )
+import Class           ( FunDep, DefMeth (..) )
+import DataCon         ( dataConId )
+import Name            ( Name, NamedThing(..) )

 import NameSet
 import NameSet

-import BasicTypes      ( TopLevelFlag(..) )
-import TysWiredIn      ( tupleTyCon, unboxedTupleTyCon, listTyCon )
-import Type            ( funTyCon )
-import FiniteMap       ( elemFM )
-import PrelInfo                ( derivingOccurrences, numClass_RDR, 
-                         deRefStablePtr_NAME, makeStablePtr_NAME,
-                         bindIO_NAME
+import PrelNames       ( deRefStablePtrName, newStablePtrName,
+                         bindIOName, returnIOName

                        )
                        )

-import Bag             ( bagToList )
+import TysWiredIn      ( tupleCon )
+import List            ( partition )

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

-import UniqFM          ( lookupUFM )
+import CmdLineOpts     ( DynFlag(..) )
+                               -- Warn of unused for-all'd tyvars

 import Maybes          ( maybeToBool )
 import Maybes          ( maybeToBool )

-import Util
+import Maybe            ( maybe )

 \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}
 
 
 %*********************************************************
 %*                                                     *

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

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

-rnSourceDecls :: [RdrNameHsDecl] -> RnMS s ([RenamedHsDecl], FreeVars)
+rnSourceDecls :: GlobalRdrEnv -> AvailEnv -> LocalFixityEnv
+             -> [RdrNameHsDecl] 
+             -> RnMG ([RenamedHsDecl], FreeVars)

        -- The decls get reversed, but that's ok
 
        -- The decls get reversed, but that's ok
 

-rnSourceDecls decls
-  = go emptyFVs [] decls
+rnSourceDecls gbl_env avails local_fixity_env decls
+  = initRnMS gbl_env avails emptyRdrEnv local_fixity_env SourceMode (go emptyFVs [] decls)

   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
-
-rnIfaceDecl :: RdrNameHsDecl -> RnMS s RenamedHsDecl
-rnIfaceDecl d
-  = rnDecl d   `thenRn` \ (d', fvs) ->
-    returnRn d'
+       -- Fixity and deprecations 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' (DeprecD _:ds) = go fvs ds' ds
+    go fvs ds' (d:ds)         = rnSourceDecl d `thenRn` \(d', fvs') ->
+                               go (fvs `plusFV` fvs') (d':ds') ds
+
+
+rnSourceDecl :: RdrNameHsDecl -> RnMS (RenamedHsDecl, FreeVars)
+
+rnSourceDecl (ValD binds) = rnTopBinds binds   `thenRn` \ (new_binds, fvs) ->
+                           returnRn (ValD new_binds, fvs)
+
+rnSourceDecl (TyClD tycl_decl)
+  = rnTyClDecl tycl_decl                       `thenRn` \ new_decl ->
+    finishSourceTyClDecl tycl_decl new_decl    `thenRn` \ (new_decl', fvs) ->
+    returnRn (TyClD new_decl', fvs `plusFV` tyClDeclFVs new_decl')
+
+rnSourceDecl (InstD inst)
+  = rnInstDecl inst                    `thenRn` \ new_inst ->
+    finishSourceInstDecl inst new_inst `thenRn` \ (new_inst', fvs) ->
+    returnRn (InstD new_inst', fvs `plusFV` instDeclFVs new_inst')
+
+rnSourceDecl (RuleD rule)
+  = rnHsRuleDecl rule          `thenRn` \ (new_rule, fvs) ->
+    returnRn (RuleD new_rule, fvs)
+
+rnSourceDecl (ForD ford)
+  = rnHsForeignDecl ford               `thenRn` \ (new_ford, fvs) ->
+    returnRn (ForD new_ford, fvs)
+
+rnSourceDecl (DefD (DefaultDecl tys src_loc))
+  = pushSrcLocRn src_loc $
+    mapFvRn (rnHsTypeFVs doc_str) tys          `thenRn` \ (tys', fvs) ->
+    returnRn (DefD (DefaultDecl tys' src_loc), fvs)
+  where
+    doc_str = text "In a `default' declaration"

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

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

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

--- rnDecl does all the work
-rnDecl :: RdrNameHsDecl -> RnMS s (RenamedHsDecl, FreeVars)
+rnHsForeignDecl (ForeignImport name ty spec isDeprec src_loc)
+  = pushSrcLocRn src_loc               $
+    lookupTopBndrRn name               `thenRn` \ name' ->
+    rnHsTypeFVs (fo_decl_msg name) ty  `thenRn` \ (ty', fvs) ->
+    returnRn (ForeignImport name' ty' spec isDeprec src_loc, 
+             fvs `plusFV` extras spec)
+  where
+    extras (CImport _ _ _ _ CWrapper) = mkFVs [newStablePtrName,
+                                              deRefStablePtrName,  
+                                              bindIOName, returnIOName]
+    extras _                         = emptyFVs
+
+rnHsForeignDecl (ForeignExport name ty spec isDeprec src_loc)
+  = pushSrcLocRn src_loc                       $
+    lookupOccRn name                           `thenRn` \ name' ->
+    rnHsTypeFVs (fo_decl_msg name) ty                  `thenRn` \ (ty', fvs) ->
+    returnRn (ForeignExport name' ty' spec isDeprec src_loc, 
+             mkFVs [bindIOName, returnIOName] `plusFV` fvs)
+
+fo_decl_msg name = ptext SLIT("The foreign declaration for") <+> ppr name
+\end{code}

 
 

-rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) ->
-                     returnRn (ValD new_binds, fvs)

 
 

+%*********************************************************
+%*                                                     *
+\subsection{Instance declarations}
+%*                                                     *
+%*********************************************************

 
 

-rnDecl (SigD (IfaceSig name ty id_infos loc))
-  = pushSrcLocRn loc $
-    lookupBndrRn name          `thenRn` \ name' ->
-    rnIfaceType doc_str ty     `thenRn` \ ty' ->
-
-       -- Get the pragma info (if any).
-    setModeRn (InterfaceMode Optional)                 $
-       -- In all the rest of the signature we read in optional mode,
-       -- so that (a) we don't die
-    mapRn rnIdInfo id_infos    `thenRn` \ id_infos' -> 
-    returnRn (SigD (IfaceSig name' ty' id_infos' loc), emptyFVs)
-               -- Don't need free-var info for iface binds
+\begin{code}
+rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc)
+       -- Used for both source and interface file decls
+  = pushSrcLocRn src_loc $
+    rnHsSigType (text "an instance decl") inst_ty      `thenRn` \ inst_ty' ->
+
+    (case maybe_dfun_rdr_name of
+       Nothing            -> returnRn Nothing
+       Just dfun_rdr_name -> lookupIfaceName dfun_rdr_name     `thenRn` \ dfun_name ->
+                             returnRn (Just dfun_name)
+    )                                                  `thenRn` \ maybe_dfun_name ->
+
+    -- The typechecker checks that all the bindings are for the right class.
+    returnRn (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
+       meth_doc    = text "In the bindings in an instance declaration"
+       meth_names  = collectLocatedMonoBinders mbinds
+       (inst_tyvars, (cls,_)) = getHsInstHead inst_ty
+       -- (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 (map hsTyVarName inst_tyvars) (         
+       rnMethodBinds cls [] mbinds
+    )                                          `thenRn` \ (mbinds', meth_fvs) ->
+    let 
+       binders    = collectMonoBinders mbinds'
+       binder_set = mkNameSet binders
+    in
+       -- 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
+    bindLocalNames binders (
+       renameSigsFVs (okInstDclSig binder_set) uprags
+    )                                                  `thenRn` \ (uprags', prag_fvs) ->
+
+    returnRn (InstDecl inst_ty mbinds' uprags' maybe_dfun_name src_loc,
+             meth_fvs `plusFV` prag_fvs)
+\end{code}
+
+%*********************************************************
+%*                                                     *
+\subsection{Rules}
+%*                                                     *
+%*********************************************************
+
+\begin{code}
+rnIfaceRuleDecl (IfaceRule rule_name act vars fn args rhs src_loc)
+  = pushSrcLocRn src_loc       $
+    lookupOccRn fn             `thenRn` \ fn' ->
+    rnCoreBndrs vars           $ \ vars' ->
+    mapRn rnCoreExpr args      `thenRn` \ args' ->
+    rnCoreExpr rhs             `thenRn` \ rhs' ->
+    returnRn (IfaceRule rule_name act vars' fn' args' rhs' src_loc)
+
+rnIfaceRuleDecl (IfaceRuleOut fn rule)         -- Builtin rules come this way
+  = lookupOccRn fn             `thenRn` \ fn' ->
+    returnRn (IfaceRuleOut fn' rule)
+
+rnHsRuleDecl (HsRule rule_name act vars lhs rhs src_loc)
+  = pushSrcLocRn src_loc                               $
+    bindPatSigTyVars (collectRuleBndrSigTys vars)      $
+
+    bindLocalsFVRn doc (map get_var vars)      $ \ ids ->
+    mapFvRn rn_var (vars `zip` ids)            `thenRn` \ (vars', fv_vars) ->
+
+    rnExpr lhs                                 `thenRn` \ (lhs', fv_lhs) ->
+    rnExpr rhs                                 `thenRn` \ (rhs', fv_rhs) ->
+    checkRn (validRuleLhs ids lhs')
+           (badRuleLhsErr rule_name lhs')      `thenRn_`
+    let
+       bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
+    in
+    mapRn (addErrRn . badRuleVar rule_name) bad_vars   `thenRn_`
+    returnRn (HsRule rule_name act vars' lhs' rhs' src_loc,
+             fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)

   where
   where

-    doc_str = text "the interface signature for" <+> quotes (ppr name)
+    doc = text "In the transformation rule" <+> ptext rule_name
+  
+    get_var (RuleBndr v)      = v
+    get_var (RuleBndrSig v _) = v
+
+    rn_var (RuleBndr v, id)     = returnRn (RuleBndr id, emptyFVs)
+    rn_var (RuleBndrSig v t, id) = rnHsTypeFVs doc t   `thenRn` \ (t', fvs) ->
+                                  returnRn (RuleBndrSig id t', fvs)

 \end{code}
 
 \end{code}
 

+

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

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

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

@@ -137,210 +268,185 @@ 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
 
 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.
+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 (TyClD (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc))
+rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc = loc})
+  = pushSrcLocRn loc $
+    lookupTopBndrRn name               `thenRn` \ name' ->
+    rnHsType doc_str ty                        `thenRn` \ ty' ->
+    mapRn rnIdInfo id_infos            `thenRn` \ id_infos' -> 
+    returnRn (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})
+  = pushSrcLocRn loc                   $
+    lookupTopBndrRn name               `thenRn` \ name' ->
+    returnRn (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, tcdNCons = nconstrs,
+                   tcdDerivs = derivs, tcdLoc = src_loc, tcdSysNames = sys_names})

   = pushSrcLocRn 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_`
-    mapAndUnzipRn rnConDecl condecls                   `thenRn` \ (condecls', con_fvs_s) ->
-    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` plusFVs con_fvs_s `plusFV` deriv_fvs)
+    lookupTopBndrRn tycon                      `thenRn` \ tycon' ->
+    bindTyVarsRn data_doc tyvars               $ \ tyvars' ->
+    rnContext data_doc context                         `thenRn` \ context' ->
+    rn_derivs derivs                           `thenRn` \ derivs' ->
+    checkDupOrQualNames data_doc con_names     `thenRn_`
+
+       -- Check that there's at least one condecl,
+       -- or else we're reading an interface file, or -fglasgow-exts
+    (if null condecls then
+       doptRn Opt_GlasgowExts  `thenRn` \ glaExts ->
+       getModeRn               `thenRn` \ mode ->
+       checkRn (glaExts || isInterfaceMode mode)
+               (emptyConDeclsErr tycon)
+     else returnRn ()
+    )                                          `thenRn_` 
+
+    mapRn rnConDecl condecls                   `thenRn` \ condecls' ->
+    mapRn lookupSysBinder sys_names            `thenRn` \ sys_names' ->
+    returnRn (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon',
+                     tcdTyVars = tyvars', tcdCons = condecls', tcdNCons = nconstrs,
+                     tcdDerivs = derivs', tcdLoc = src_loc, tcdSysNames = sys_names'})

   where
   where

-    data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
+    data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)

     con_names = map conDeclName condecls
 
     con_names = map conDeclName condecls
 

-rnDecl (TyClD (TySynonym name tyvars ty src_loc))
+    rn_derivs Nothing   = returnRn Nothing
+    rn_derivs (Just ds) = rnContext data_doc ds        `thenRn` \ ds' -> returnRn (Just ds')
+    
+rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc})

   = pushSrcLocRn 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)
+    lookupTopBndrRn name                       `thenRn` \ name' ->
+    bindTyVarsRn syn_doc tyvars                $ \ tyvars' ->
+    rnHsType syn_doc ty                                `thenRn` \ ty' ->
+    returnRn (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc})

   where
   where

-    syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
+    syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)

 
 

-rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname src_loc))
+rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname, 
+                      tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
+                      tcdSysNames = names, tcdLoc = src_loc})
+       -- Used for both source and interface file decls

   = pushSrcLocRn src_loc $
 
   = pushSrcLocRn src_loc $
 

-    lookupBndrRn cname                                 `thenRn` \ cname' ->
+    lookupTopBndrRn cname                      `thenRn` \ cname' ->

 
        -- 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!
 
        -- 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
-    newImportedGlobalFromRdrName tname                 `thenRn` \ tname' ->
-    newImportedGlobalFromRdrName dname                 `thenRn` \ dname' ->
+    mapRn lookupSysBinder names                        `thenRn` \ names' ->

 
        -- Tyvars scope over bindings and context
 
        -- Tyvars scope over bindings and context

-    bindTyVarsFV2Rn cls_doc tyvars                     ( \ clas_tyvar_names tyvars' ->
+    bindTyVarsRn cls_doc tyvars                        $ \ tyvars' ->

 
        -- Check the superclasses
 
        -- Check the superclasses

-    rnContext cls_doc context                          `thenRn` \ (context', cxt_fvs) ->
+    rnContext cls_doc context                  `thenRn` \ context' ->
+
+       -- Check the functional dependencies
+    rnFds cls_doc fds                          `thenRn` \ fds' ->

 
        -- Check the signatures
 
        -- Check the signatures

+       -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).

     let
     let

-               -- Filter out fixity signatures;
-               -- they are done at top level
-         nofix_sigs = nonFixitySigs sigs
+       (op_sigs, non_op_sigs) = partition isClassOpSig sigs
+       sig_rdr_names_w_locs   = [(op,locn) | ClassOpSig op _ _ locn <- sigs]

     in
     in

-    checkDupOrQualNames sig_doc sig_rdr_names_w_locs           `thenRn_` 
-    mapAndUnzipRn (rn_op cname' clas_tyvar_names) nofix_sigs   `thenRn` \ (sigs', sig_fvs_s) ->
-
-       -- Check the methods
-    checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
-    rnMethodBinds mbinds                               `thenRn` \ (mbinds', meth_fvs) ->
+    checkDupOrQualNames sig_doc sig_rdr_names_w_locs   `thenRn_` 
+    mapRn (rnClassOp cname' fds') op_sigs              `thenRn` \ sigs' ->
+    let
+       binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
+    in
+    renameSigs (okClsDclSig binders) non_op_sigs         `thenRn` \ non_ops' ->

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

-    ASSERT(isNoClassPragmas pragmas)
-    returnRn (TyClD (ClassDecl context' cname' tyvars' sigs' mbinds' NoClassPragmas tname' dname' src_loc),
-             plusFVs sig_fvs_s `plusFV` cxt_fvs `plusFV` meth_fvs)
-    )
+    returnRn (ClassDecl { tcdCtxt = context', tcdName = cname', tcdTyVars = tyvars',
+                         tcdFDs = fds', tcdSigs = non_ops' ++ sigs', tcdMeths = Nothing, 
+                         tcdSysNames = names', tcdLoc = src_loc})

   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
-       let
-           dm_occ = mkDefaultMethodOcc (rdrNameOcc op)
-       in
-       getModuleRn                     `thenRn` \ mod_name ->
-       getModeRn                       `thenRn` \ mode ->
-       (case (mode, maybe_dm) of 
-           (SourceMode, _) | op `elem` meth_rdr_names
-               ->      -- There's an explicit method decl
-                  newLocallyDefinedGlobalName mod_name dm_occ 
-                                              (\_ -> Exported) locn    `thenRn` \ dm_name ->
-                  returnRn (Just dm_name)
-
-           (InterfaceMode _, Just _) 
-               ->      -- Imported class that has a default method decl
-                   newImportedGlobalName mod_name dm_occ       `thenRn` \ dm_name ->
-                   addOccurrenceName dm_name                   `thenRn_`
-                   returnRn (Just dm_name)
-
-           other -> returnRn Nothing
-       )                                       `thenRn` \ maybe_dm_name ->
-
-
-       returnRn (ClassOpSig op_name maybe_dm_name new_ty locn, op_ty_fvs)
-\end{code}
+    cls_doc  = text "In the declaration for class"     <+> ppr cname
+    sig_doc  = text "In the signatures for class"      <+> ppr cname

 
 

-
-%*********************************************************
-%*                                                     *
-\subsection{Instance declarations}
-%*                                                     *
-%*********************************************************
-
-\begin{code}
-rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc))
-  = pushSrcLocRn src_loc $
-    rnHsSigType (text "an instance decl") inst_ty      `thenRn` \ (inst_ty', inst_fvs) ->
+rnClassOp clas clas_fds sig@(ClassOpSig op dm_stuff ty locn)
+  = pushSrcLocRn locn $
+    lookupTopBndrRn op                 `thenRn` \ op_name ->
+    
+       -- Check the signature
+    rnHsSigType (quotes (ppr op)) ty   `thenRn` \ new_ty ->
+    
+       -- Make the default-method name
+    (case dm_stuff of 
+        DefMeth dm_rdr_name
+           ->  -- Imported class that has a default method decl
+               -- See comments with tname, snames, above
+               lookupSysBinder dm_rdr_name     `thenRn` \ dm_name ->
+               returnRn (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 -> returnRn GenDefMeth
+        NoDefMeth  -> returnRn NoDefMeth
+    )                                          `thenRn` \ dm_stuff' ->
+    
+    returnRn (ClassOpSig op_name dm_stuff' new_ty locn)
+
+finishSourceTyClDecl :: RdrNameTyClDecl -> RenamedTyClDecl -> RnMS (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 
+    pushSrcLocRn src_loc                               $
+    extendTyVarEnvFVRn (map hsTyVarName tyvars)                $
+    getLocalNameEnv                                    `thenRn` \ name_env ->

     let
     let

-       inst_tyvars = case inst_ty' of
-                       HsForAllTy inst_tyvars _ _ -> inst_tyvars
-                       other                      -> []
-       -- (Slightly strangely) the forall-d tyvars scope over
-       -- the method bindings too
-    in
-    extendTyVarEnvFVRn inst_tyvars             $
-
-       -- Rename the bindings
-       -- NB meth_names can be qualified!
-    checkDupNames meth_doc meth_names          `thenRn_`
-    rnMethodBinds mbinds                       `thenRn` \ (mbinds', meth_fvs) ->
-    let 
-       binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds')))
+       meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds
+       gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds,
+                                               not (tv `elemRdrEnv` name_env)]

     in
     in

-    renameSigs NotTopLevel True binders uprags `thenRn` \ (new_uprags, prag_fvs) ->
-    mkDFunName inst_ty' maybe_dfun src_loc     `thenRn` \ dfun_name ->
-    addOccurrenceName dfun_name                        `thenRn_`
-                       -- The dfun is not optional, because we use its version number
-                       -- to identify the version of the instance declaration
-
-       -- The typechecker checks that all the bindings are for the right class.
-    returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags (Just dfun_name) src_loc),
-             inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs)
-  where
-    meth_doc = text "the bindings in an instance declaration"
-    meth_names   = bagToList (collectMonoBinders mbinds)
-\end{code}
-
-%*********************************************************
-%*                                                     *
-\subsection{Default declarations}
-%*                                                     *
-%*********************************************************
-
-\begin{code}
-rnDecl (DefD (DefaultDecl tys src_loc))
-  = pushSrcLocRn src_loc $
-    rnHsTypes doc_str tys              `thenRn` \ (tys', fvs) ->
-    lookupImplicitOccRn numClass_RDR   `thenRn_` 
-    returnRn (DefD (DefaultDecl tys' src_loc), fvs)
+    checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
+    newLocalsRn gen_rdr_tyvars_w_locs                  `thenRn` \ gen_tyvars ->
+    rnMethodBinds cls gen_tyvars mbinds                        `thenRn` \ (mbinds', meth_fvs) ->
+    returnRn (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs)

   where
   where

-    doc_str = text "a `default' declaration"
+    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.
+  = returnRn (tycl_decl,
+              maybe emptyFVs extractHsCtxtTyNames derivings)
+
+finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs)
+       -- Not a class declaration

 \end{code}
 
 \end{code}
 

-%*********************************************************
-%*                                                     *
-\subsection{Foreign declarations}
-%*                                                     *
-%*********************************************************
-
-\begin{code}
-rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
-  = pushSrcLocRn src_loc $
-    lookupBndrRn name                  `thenRn` \ name' ->
-    (case imp_exp of
-       FoImport _ | not isDyn -> addImplicitOccRn name'
-       FoLabel    -> addImplicitOccRn name'
-       FoExport   | isDyn ->
-          addImplicitOccRn makeStablePtr_NAME  `thenRn_`
-          addImplicitOccRn deRefStablePtr_NAME `thenRn_`
-          addImplicitOccRn bindIO_NAME         `thenRn_`
-          returnRn name'
-       _ -> returnRn name')            `thenRn_`
-    rnHsSigType fo_decl_msg ty         `thenRn` \ (ty', fvs) ->
-    returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc), fvs)
- where
-  fo_decl_msg = ptext SLIT("a foreign declaration")
-  isDyn              = isDynamic ext_nm
-
-\end{code}

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

@@ -349,85 +455,49 @@ rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
 %*********************************************************
 
 \begin{code}
 %*********************************************************
 
 \begin{code}

-rnDerivs :: Maybe [RdrName] -> RnMS s (Maybe [Name], FreeVars)
-
-rnDerivs Nothing -- derivs not specified
-  = returnRn (Nothing, emptyFVs)
-
-rnDerivs (Just ds)
-  = mapRn rn_deriv ds `thenRn` \ derivs ->
-    returnRn (Just derivs, foldl addOneFV emptyFVs derivs)
-  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
-
-               Just occs -> mapRn lookupImplicitOccRn occs     `thenRn_`
-                            returnRn clas_name
-
-\end{code}
-
-\begin{code}

 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)

-conDeclName (ConDecl n _ _ _ l) = (n,l)
+conDeclName (ConDecl n _ _ _ _ l) = (n,l)

 
 

-rnConDecl :: RdrNameConDecl -> RnMS s (RenamedConDecl, FreeVars)
-rnConDecl (ConDecl name tvs cxt details locn)
+rnConDecl :: RdrNameConDecl -> RnMS RenamedConDecl
+rnConDecl (ConDecl name wkr tvs cxt details locn)

   = pushSrcLocRn 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)
+    checkConName name          `thenRn_` 
+    lookupTopBndrRn name       `thenRn` \ new_name ->
+
+    lookupSysBinder wkr                `thenRn` \ new_wkr ->
+       -- See comments with ClassDecl
+
+    bindTyVarsRn doc tvs               $ \ new_tyvars ->
+    rnContext doc cxt                  `thenRn` \ new_context ->
+    rnConDetails doc locn details      `thenRn` \ new_details -> 
+    returnRn (ConDecl new_name new_wkr 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)
 
 rnConDetails doc locn (VanillaCon tys)

-  = mapAndUnzipRn (rnBangTy doc) tys   `thenRn` \ (new_tys, fvs_s)  ->
-    returnRn (VanillaCon new_tys, plusFVs fvs_s)
+  = mapRn (rnBangTy doc) tys   `thenRn` \ new_tys  ->
+    returnRn (VanillaCon 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           `thenRn` \ new_ty1 ->
+    rnBangTy doc ty2           `thenRn` \ new_ty2 ->
+    returnRn (InfixCon new_ty1 new_ty2)

 
 rnConDetails doc locn (RecCon fields)
   = checkDupOrQualNames doc field_names        `thenRn_`
 
 rnConDetails doc locn (RecCon fields)
   = checkDupOrQualNames doc field_names        `thenRn_`

-    mapAndUnzipRn (rnField doc) fields `thenRn` \ (new_fields, fvs_s) ->
-    returnRn (RecCon new_fields, plusFVs fvs_s)
+    mapRn (rnField doc) fields         `thenRn` \ new_fields ->
+    returnRn (RecCon new_fields)

   where
     field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
 
 rnField doc (names, ty)
   where
     field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
 
 rnField doc (names, ty)

-  = mapRn lookupBndrRn names   `thenRn` \ new_names ->
-    rnBangTy doc ty            `thenRn` \ (new_ty, fvs) ->
-    returnRn ((new_names, new_ty), fvs) 
-
-rnBangTy doc (Banged ty)
-  = rnHsType doc ty            `thenRn` \ (new_ty, fvs) ->
-    returnRn (Banged new_ty, fvs)
+  = mapRn lookupTopBndrRn names        `thenRn` \ new_names ->
+    rnBangTy doc ty            `thenRn` \ new_ty ->
+    returnRn (new_names, new_ty) 

 
 

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

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

@@ -447,244 +517,87 @@ checkConName name
 
 %*********************************************************
 %*                                                     *
 
 %*********************************************************
 %*                                                     *

-\subsection{Naming a dfun}
-%*                                                     *
-%*********************************************************
-
-Make a name for the dict fun for an instance decl
-
-\begin{code}
-mkDFunName :: RenamedHsType    -- Instance type
-           -> Maybe RdrName    -- Dfun thing from decl; Nothing <=> source
-           -> SrcLoc
-           -> RnMS s Name
-
-mkDFunName inst_ty maybe_df src_loc
-  = newDFunName cl_occ tycon_occ maybe_df src_loc
-  where
-    (cl_occ, tycon_occ) = get_key inst_ty
-
-    get_key (HsForAllTy _ _ ty)     = get_key ty
-    get_key (MonoFunTy _ ty)        = get_key ty
-    get_key (MonoDictTy cls (ty:_)) = (nameOccName cls, get_tycon_key ty)
-
-    get_tycon_key (MonoTyVar tv)   = nameOccName (getName tv)
-    get_tycon_key (MonoTyApp ty _) = get_tycon_key ty
-    get_tycon_key (MonoTupleTy tys True)  = getOccName (tupleTyCon        (length tys))
-    get_tycon_key (MonoTupleTy tys False) = getOccName (unboxedTupleTyCon (length tys))
-    get_tycon_key (MonoListTy _)   = getOccName listTyCon
-    get_tycon_key (MonoFunTy _ _)  = getOccName funTyCon
-\end{code}
-
-
-%*********************************************************
-%*                                                     *

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

-rnHsSigType :: SDoc -> RdrNameHsType -> RnMS s (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
-    
-rnIfaceType :: SDoc -> RdrNameHsType -> RnMS s RenamedHsType
-rnIfaceType doc ty 
- = rnHsType doc ty     `thenRn` \ (ty,_) ->
-   returnRn ty
-
-rnHsType :: SDoc -> RdrNameHsType -> RnMS s (RenamedHsType, FreeVars)
-
-rnHsType doc (HsForAllTy [] ctxt ty)
-       -- From source code (no kinds on tyvars)
-
-       -- Given the signature  C => T  we universally quantify 
-       -- over FV(T) \ {in-scope-tyvars} 
-       -- 
-       -- We insist that the universally quantified type vars is a superset of FV(C)
-       -- It follows that FV(T) is a superset of FV(C), so that the context constrains
-       -- no type variables that don't appear free in the tau-type part.
-
-  = getLocalNameEnv            `thenRn` \ name_env ->
-    let
-       mentioned_tyvars = extractHsTyVars ty
-       forall_tyvars    = filter (not . (`elemFM` name_env)) mentioned_tyvars
-
-       ctxt_w_ftvs :: [((RdrName,[RdrNameHsType]), [RdrName])]
-       ctxt_w_ftvs  = [ (constraint, foldr ((++) . extractHsTyVars) [] tys)
-                      | constraint@(_,tys) <- ctxt]
-
-       -- A 'non-poly constraint' is one that does not mention *any*
-       -- of the forall'd type variables
-       non_poly_constraints = filter non_poly ctxt_w_ftvs
-       non_poly (c,ftvs)    = not (any (`elem` forall_tyvars) ftvs)
-
-       -- A 'non-mentioned' constraint is one that mentions a
-       -- type variable that does not appear in 'ty'
-       non_mentioned_constraints = filter non_mentioned ctxt_w_ftvs
-       non_mentioned (c,ftvs)    = any (not . (`elem` mentioned_tyvars)) ftvs
-
-       -- Zap the context if there's a problem, to avoid duplicate error message.
-       ctxt' | null non_poly_constraints && null non_mentioned_constraints = ctxt
-             | otherwise = []
-    in
-    mapRn (ctxtErr1 doc forall_tyvars ty) non_poly_constraints         `thenRn_`
-    mapRn (ctxtErr2 doc ty)               non_mentioned_constraints    `thenRn_`
-
-    (bindTyVarsFVRn doc (map UserTyVar 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)
-    )
-
-rnHsType doc (HsForAllTy tvs ctxt ty)
-       -- tvs are non-empty, hence must be from an interface file
-       --      (tyvars may be kinded)
-  = bindTyVarsFVRn doc tvs             $ \ 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)
-
-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)
-  = addImplicitOccRn listTyCon_name            `thenRn_`
-    rnHsType doc ty                            `thenRn` \ (ty', fvs) ->
-    returnRn (MonoListTy ty', fvs `addOneFV` listTyCon_name)
-
-rnHsType doc (MonoTupleTy tys boxed)
-  = addImplicitOccRn tup_con_name      `thenRn_`
-    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')
-
-rnHsTypes doc tys
-  = mapAndUnzipRn (rnHsType doc) tys   `thenRn` \ (tys, fvs_s) ->
-    returnRn (tys, plusFVs fvs_s)
-\end{code}
-
-
-\begin{code}
-rnContext :: SDoc -> RdrNameContext -> RnMS s (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_`
+rnFds :: SDoc -> [FunDep RdrName] -> RnMS [FunDep Name]

 
 

-    returnRn (theta, plusFVs fvs_s)
+rnFds doc fds
+  = mapRn 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             `thenRn` \ tys1' ->
+       rnHsTyVars doc tys2             `thenRn` \ tys2' ->
+       returnRn (tys1', tys2')

 
 

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

 \end{code}
 
 \end{code}
 

-

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

-%*                                                     *
+%*                                                      *

 \subsection{IdInfo}
 \subsection{IdInfo}

-%*                                                     *
+%*                                                      *

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

-rnIdInfo (HsStrictness strict)
-  = rnStrict strict    `thenRn` \ strict' ->
-    returnRn (HsStrictness strict')
-
-rnIdInfo (HsUnfold inline (Just expr)) = rnCoreExpr expr       `thenRn` \ expr' ->
-                                         returnRn (HsUnfold inline (Just expr'))
-rnIdInfo (HsUnfold inline Nothing)     = returnRn (HsUnfold inline Nothing)
-rnIdInfo (HsArity arity)       = returnRn (HsArity arity)
-rnIdInfo (HsUpdate update)     = returnRn (HsUpdate update)
-rnIdInfo (HsNoCafRefs)         = returnRn (HsNoCafRefs)
-rnIdInfo (HsSpecialise tyvars tys expr)
-  = bindTyVarsRn doc tyvars    $ \ tyvars' ->
-    rnCoreExpr expr            `thenRn` \ expr' ->
-    mapRn (rnIfaceType doc) tys        `thenRn` \ tys' ->
-    returnRn (HsSpecialise tyvars' tys' expr')
-  where
-    doc = text "Specialise in interface pragma"
-    
-
-rnStrict (HsStrictnessInfo demands (Just (worker,cons)))
-       -- The sole purpose of the "cons" field is so that we can mark the constructors
-       -- needed to build the wrapper as "needed", so that their data type decl will be
-       -- slurped in. After that their usefulness is o'er, so we just put in the empty list.
+rnIdInfo (HsWorker worker arity)

   = lookupOccRn worker                 `thenRn` \ worker' ->
   = lookupOccRn worker                 `thenRn` \ worker' ->

-    mapRn lookupOccRn cons             `thenRn_` 
-    returnRn (HsStrictnessInfo demands (Just (worker',[])))
+    returnRn (HsWorker worker' arity)

 
 

--- Boring, but necessary for the type checker.
-rnStrict (HsStrictnessInfo demands Nothing) = returnRn (HsStrictnessInfo demands Nothing)
-rnStrict HsBottom                        = returnRn HsBottom
+rnIdInfo (HsUnfold inline expr)        = rnCoreExpr expr `thenRn` \ expr' ->
+                                 returnRn (HsUnfold inline expr')
+rnIdInfo (HsStrictness str)     = returnRn (HsStrictness str)
+rnIdInfo (HsArity arity)       = returnRn (HsArity arity)
+rnIdInfo HsNoCafRefs           = returnRn HsNoCafRefs

 \end{code}
 
 \end{code}
 

-UfCore expressions.
+@UfCore@ expressions.

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

-  = rnIfaceType (text "unfolding type") ty     `thenRn` \ ty' ->
+  = rnHsType (text "unfolding type") ty        `thenRn` \ ty' ->

     returnRn (UfType ty')
 
 rnCoreExpr (UfVar v)
   = lookupOccRn v      `thenRn` \ v' ->
     returnRn (UfVar v')
 
     returnRn (UfType ty')
 
 rnCoreExpr (UfVar v)
   = lookupOccRn v      `thenRn` \ v' ->
     returnRn (UfVar v')
 

-rnCoreExpr (UfCon con args) 
-  = rnUfCon con                        `thenRn` \ con' ->
-    mapRn rnCoreExpr args      `thenRn` \ args' ->
-    returnRn (UfCon con' args')
+rnCoreExpr (UfLit l)
+  = returnRn (UfLit l)

 
 

-rnCoreExpr (UfTuple con args) 
-  = lookupOccRn con            `thenRn` \ con' ->
-    mapRn rnCoreExpr args      `thenRn` \ args' ->
-    returnRn (UfTuple con' args')
+rnCoreExpr (UfLitLit l ty)
+  = rnHsType (text "litlit") ty        `thenRn` \ ty' ->
+    returnRn (UfLitLit l ty')
+
+rnCoreExpr (UfFCall cc ty)
+  = rnHsType (text "ccall") ty `thenRn` \ ty' ->
+    returnRn (UfFCall cc ty')
+
+rnCoreExpr (UfTuple (HsTupCon _ boxity arity) args) 
+  = mapRn rnCoreExpr args              `thenRn` \ args' ->
+    returnRn (UfTuple (HsTupCon tup_name boxity arity) args')
+  where
+    tup_name = getName (dataConId (tupleCon boxity arity))
+       -- Get the *worker* name and use that

 
 rnCoreExpr (UfApp fun arg)
   = rnCoreExpr fun             `thenRn` \ fun' ->
     rnCoreExpr arg             `thenRn` \ arg' ->
     returnRn (UfApp fun' arg')
 
 
 rnCoreExpr (UfApp fun arg)
   = rnCoreExpr fun             `thenRn` \ fun' ->
     rnCoreExpr arg             `thenRn` \ arg' ->
     returnRn (UfApp fun' arg')
 

-rnCoreExpr (UfCase scrut bndr alts) 
+rnCoreExpr (UfCase scrut bndr alts)

   = rnCoreExpr scrut                   `thenRn` \ scrut' ->
   = rnCoreExpr scrut                   `thenRn` \ scrut' ->

-    bindLocalsRn "a UfCase" [bndr]     $ \ [bndr'] ->
+    bindCoreLocalRn bndr               $ \ bndr' ->

     mapRn rnCoreAlt alts               `thenRn` \ alts' ->
     returnRn (UfCase scrut' bndr' alts')
 
 rnCoreExpr (UfNote note expr) 
   = rnNote note                        `thenRn` \ note' ->
     rnCoreExpr expr            `thenRn` \ expr' ->
     mapRn rnCoreAlt alts               `thenRn` \ alts' ->
     returnRn (UfCase scrut' bndr' alts')
 
 rnCoreExpr (UfNote note expr) 
   = rnNote note                        `thenRn` \ note' ->
     rnCoreExpr expr            `thenRn` \ expr' ->

-    returnRn  (UfNote note' expr') 
+    returnRn  (UfNote note' expr')

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

@@ -708,106 +621,101 @@ rnCoreExpr (UfLet (UfRec pairs) body)
 
 \begin{code}
 rnCoreBndr (UfValBinder name ty) thing_inside
 
 \begin{code}
 rnCoreBndr (UfValBinder name ty) thing_inside

-  = rnIfaceType (text str) ty  `thenRn` \ ty' ->
-    bindLocalsRn str [name]    $ \ [name'] ->
+  = rnHsType doc ty            `thenRn` \ ty' ->
+    bindCoreLocalRn name       $ \ name' ->

     thing_inside (UfValBinder name' ty')
   where
     thing_inside (UfValBinder name' ty')
   where

-    str = "unfolding id"
+    doc = text "unfolding id"

     
 rnCoreBndr (UfTyBinder name kind) thing_inside
     
 rnCoreBndr (UfTyBinder name kind) thing_inside

-  = bindLocalsRn "an unfolding tyvar" [name] $ \ [name'] ->
+  = bindCoreLocalRn name               $ \ name' ->

     thing_inside (UfTyBinder name' kind)
     
     thing_inside (UfTyBinder name' kind)
     

-rnCoreBndrs bndrs thing_inside         -- Expect them all to be ValBinders
-  = mapRn (rnIfaceType (text str)) tys `thenRn` \ tys' ->
-    bindLocalsRn str names             $ \ names' ->
-    thing_inside (zipWith UfValBinder names' tys')
-  where
-    str   = "unfolding id"
-    names = map (\ (UfValBinder name _ ) -> name) bndrs
-    tys   = map (\ (UfValBinder _    ty) -> ty)   bndrs
+rnCoreBndrs []     thing_inside = thing_inside []
+rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b         $ \ name' ->
+                                 rnCoreBndrs bs        $ \ names' ->
+                                 thing_inside (name':names')

 \end{code}    
 
 \begin{code}
 rnCoreAlt (con, bndrs, rhs)
 \end{code}    
 
 \begin{code}
 rnCoreAlt (con, bndrs, rhs)

-  = rnUfCon con                                        `thenRn` \ con' ->
-    bindLocalsRn "an unfolding alt" bndrs      $ \ bndrs' ->
-    rnCoreExpr rhs                             `thenRn` \ rhs' ->
+  = rnUfCon con                        `thenRn` \ con' ->
+    bindCoreLocalsRn bndrs             $ \ bndrs' ->
+    rnCoreExpr rhs                     `thenRn` \ rhs' ->

     returnRn (con', bndrs', rhs')
 
     returnRn (con', bndrs', rhs')
 

-

 rnNote (UfCoerce ty)
 rnNote (UfCoerce ty)

-  = rnIfaceType (text "unfolding coerce") ty   `thenRn` \ ty' ->
+  = rnHsType (text "unfolding coerce") ty      `thenRn` \ ty' ->

     returnRn (UfCoerce ty')
 
 rnNote (UfSCC cc)   = returnRn (UfSCC cc)
 rnNote UfInlineCall = returnRn UfInlineCall
     returnRn (UfCoerce ty')
 
 rnNote (UfSCC cc)   = returnRn (UfSCC cc)
 rnNote UfInlineCall = returnRn UfInlineCall

+rnNote UfInlineMe   = returnRn UfInlineMe

 
 
 rnUfCon UfDefault
   = returnRn UfDefault
 
 
 
 rnUfCon UfDefault
   = returnRn UfDefault
 

-rnUfCon (UfDataCon con)
-  = lookupOccRn con            `thenRn` \ con' ->
-    returnRn (UfDataCon con')
-
-rnUfCon (UfLitCon lit)
-  = returnRn (UfLitCon lit)
+rnUfCon (UfTupleAlt (HsTupCon _ boxity arity))
+  = returnRn (UfTupleAlt (HsTupCon tup_name boxity arity))
+  where
+    tup_name = getName (tupleCon boxity arity)

 
 

-rnUfCon (UfLitLitCon lit ty)
-  = rnIfaceType (text "litlit") ty             `thenRn` \ ty' ->
-    returnRn (UfLitLitCon lit ty')
+rnUfCon (UfDataAlt con)
+  = lookupOccRn con            `thenRn` \ con' ->
+    returnRn (UfDataAlt con')

 
 

-rnUfCon (UfPrimOp op)
-  = lookupOccRn op             `thenRn` \ op' ->
-    returnRn (UfPrimOp op')
+rnUfCon (UfLitAlt lit)
+  = returnRn (UfLitAlt lit)

 
 

-rnUfCon (UfCCallOp str is_dyn casm gc)
-  = returnRn (UfCCallOp str is_dyn casm gc)
+rnUfCon (UfLitLitAlt lit ty)
+  = rnHsType (text "litlit") ty                `thenRn` \ ty' ->
+    returnRn (UfLitLitAlt lit ty')

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

-%*                                                     *
-\subsection{Errors}
-%*                                                     *
+%*                                                      *
+\subsection{Rule shapes}
+%*                                                      *

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

+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}

-derivingNonStdClassErr clas
-  = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
+validRuleLhs foralls lhs
+  = check lhs
+  where
+    check (OpApp _ op _ _)               = check op
+    check (HsApp e1 e2)                  = check e1
+    check (HsVar v) | v `notElem` foralls = True
+    check other                                  = False
+\end{code}

 
 

-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("..."))]
+%*********************************************************
+%*                                                      *
+\subsection{Errors}
+%*                                                      *
+%*********************************************************

 
 

+\begin{code}

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

-ctxtErr1 doc tyvars ty (constraint, _)
-  = addErrRn (
-      sep [ptext SLIT("The constraint") <+> quotes (pprClassAssertion constraint) <+>
-                  ptext SLIT("does not mention any of"),
-          nest 4 (ptext SLIT("the universally quantified type variables") <+> braces (interpp'SP tyvars)),
-          nest 4 (ptext SLIT("of the type") <+> quotes (ppr ty))
-      ]
-      $$
-      (ptext SLIT("In") <+> doc)
-    )
-
-ctxtErr2 doc ty (constraint,_)
-  = addErrRn (
-       sep [ptext SLIT("The constraint") <+> quotes (pprClassAssertion constraint),
-       nest 4 (ptext SLIT("mentions type variables that do not appear in the type")),
-       nest 4 (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)]
+    $$
+    ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
+
+badRuleVar name var
+  = sep [ptext SLIT("Rule") <+> doubleQuotes (ptext name) <> colon,
+        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)"))]

 \end{code}
 \end{code}