[project @ 2004-01-09 12:09:23 by simonmar]

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

diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index c9704e5..43e644e 100644 (file)
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -4,225 +4,312 @@
 \section[RnSource]{Main pass of renamer}
 
 \begin{code}
 \section[RnSource]{Main pass of renamer}
 
 \begin{code}

-module RnSource ( rnDecl, rnHsSigType ) where
+module RnSource ( 
+       rnSrcDecls, addTcgDUs, 
+       rnTyClDecls, checkModDeprec,
+       rnBindGroups, rnBindGroupsAndThen, rnSplice
+    ) where

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

-import RnExpr

 import HsSyn
 import HsSyn

-import HsDecls         ( HsIdInfo(..), HsStrictnessInfo(..) )
-import HsPragmas
-import HsTypes         ( getTyVarName, pprClassAssertion, cmpHsTypes )
-import RdrHsSyn
+import RdrName         ( RdrName, isRdrDataCon, rdrNameOcc, elemLocalRdrEnv )
+import RdrHsSyn                ( extractGenericPatTyVars )

 import RnHsSyn
 import RnHsSyn

-import HsCore
-
-import RnBinds         ( rnTopBinds, rnMethodBinds, renameSigs )
-import RnEnv           ( bindTyVarsRn, lookupBndrRn, lookupOccRn, 
-                         lookupImplicitOccRn, addImplicitOccRn,
-                         bindLocalsRn,
-                         newDfunName, checkDupOrQualNames, checkDupNames,
-                         newLocallyDefinedGlobalName, newImportedGlobalName, 
-                         ifaceFlavour, listTyCon_name, tupleTyCon_name )
-import RnMonad
-
-import Name            ( Name, OccName(..), occNameString, prefixOccName,
-                         ExportFlag(..), Provenance(..),
-                         nameOccName, NamedThing(..), isLexCon,
-                         mkDefaultMethodName
+import RnExpr          ( rnLExpr, checkTH )
+import RnTypes         ( rnLHsType, rnHsSigType, rnHsTypeFVs, rnContext )
+import RnBinds         ( rnTopBinds, rnBinds, rnMethodBinds, 
+                         rnBindsAndThen, renameSigs, checkSigs )
+import RnEnv           ( lookupTopBndrRn, lookupTopFixSigNames,
+                         lookupLocatedTopBndrRn, lookupLocatedOccRn,
+                         lookupOccRn, newLocalsRn, 
+                         bindLocatedLocalsFV, bindPatSigTyVarsFV,
+                         bindTyVarsRn, extendTyVarEnvFVRn,
+                         bindLocalNames, newIPNameRn,
+                         checkDupNames, mapFvRn,
+                         unknownNameErr

                        )
                        )

+import TcRnMonad
+
+import BasicTypes      ( TopLevelFlag(..)  )
+import HscTypes                ( FixityEnv, FixItem(..),
+                         Deprecations, Deprecs(..), DeprecTxt, plusDeprecs )
+import Class           ( FunDep )
+import Name            ( Name )

 import NameSet
 import NameSet

-import BasicTypes      ( TopLevelFlag(..) )
-import FiniteMap       ( elemFM )
-import PrelInfo                ( derivingOccurrences, numClass_RDR, 
-                         deRefStablePtr_NAME, makeStablePtr_NAME,
-                         bindIO_NAME
-                       )
-import Bag             ( bagToList )
+import NameEnv

 import Outputable
 import Outputable

-import SrcLoc          ( SrcLoc )
-import UniqFM          ( lookupUFM )
-import Maybes          ( maybeToBool )
-import Util
+import SrcLoc          ( Located(..), unLoc, getLoc )
+import CmdLineOpts     ( DynFlag(..) )
+                               -- Warn of unused for-all'd tyvars
+import Maybes          ( seqMaybe )
+import 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)
+
+rnSrcDecls (HsGroup { hs_valds  = [HsBindGroup binds sigs _],
+                     hs_tyclds = tycl_decls,
+                     hs_instds = inst_decls,
+                     hs_fixds  = fix_decls,
+                     hs_depds  = deprec_decls,
+                     hs_fords  = foreign_decls,
+                     hs_defds  = default_decls,
+                     hs_ruleds = rule_decls })
+
+ = do {                -- Deal with deprecations (returns only the extra deprecations)
+       deprecs <- rnSrcDeprecDecls deprec_decls ;
+       updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` deprecs })
+                 $ do {
+
+               -- Deal with top-level fixity decls 
+               -- (returns the total new fixity env)
+       fix_env <- rnSrcFixityDecls fix_decls ;
+       updGblEnv (\gbl -> gbl { tcg_fix_env = fix_env })
+                 $ do {
+
+               -- Rename other declarations
+       traceRn (text "Start rnmono") ;
+       (rn_val_decls, bind_dus) <- rnTopBinds binds sigs ;
+       traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
+
+               -- You might think that we could build proper def/use information
+               -- for type and class declarations, but they can be involved
+               -- in mutual recursion across modules, and we only do the SCC
+               -- analysis for them in the type checker.
+               -- So we content ourselves with gathering uses only; that
+               -- means we'll only report a declaration as unused if it isn't
+               -- mentioned at all.  Ah well.
+       (rn_tycl_decls,    src_fvs1)
+          <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls ;
+       (rn_inst_decls,    src_fvs2)
+          <- mapFvRn (wrapLocFstM rnSrcInstDecl) inst_decls ;
+       (rn_rule_decls,    src_fvs3)
+          <- mapFvRn (wrapLocFstM rnHsRuleDecl) rule_decls ;
+       (rn_foreign_decls, src_fvs4)
+          <- mapFvRn (wrapLocFstM rnHsForeignDecl) foreign_decls ;
+       (rn_default_decls, src_fvs5)
+          <- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ;
+       
+       let {
+          rn_group = HsGroup { hs_valds  = rn_val_decls,
+                               hs_tyclds = rn_tycl_decls,
+                               hs_instds = rn_inst_decls,
+                               hs_fixds  = [],
+                               hs_depds  = [],
+                               hs_fords  = rn_foreign_decls,
+                               hs_defds  = rn_default_decls,
+                               hs_ruleds = rn_rule_decls } ;
+
+          other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, 
+                               src_fvs4, src_fvs5] ;
+          src_dus = bind_dus `plusDU` usesOnly other_fvs 
+       } ;
+
+       traceRn (text "finish rnSrc" <+> ppr rn_group) ;
+       tcg_env <- getGblEnv ;
+       return (tcg_env `addTcgDUs` src_dus, rn_group)
+    }}}
+
+rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name]
+rnTyClDecls tycl_decls = do 
+  (decls', fvs) <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls
+  return decls'
+
+addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv 
+addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
+\end{code}
+
+

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

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

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

-rnDecl :: RdrNameHsDecl -> RnMS s RenamedHsDecl
+rnSrcFixityDecls :: [LFixitySig RdrName] -> RnM FixityEnv
+rnSrcFixityDecls fix_decls
+  = getGblEnv                                  `thenM` \ gbl_env ->
+    foldlM rnFixityDecl (tcg_fix_env gbl_env) 
+           fix_decls                                   `thenM` \ fix_env ->
+    traceRn (text "fixity env" <+> pprFixEnv fix_env)  `thenM_`
+    returnM fix_env
+
+rnFixityDecl :: FixityEnv -> LFixitySig RdrName -> RnM FixityEnv
+rnFixityDecl fix_env (L loc (FixitySig rdr_name fixity))
+  = addSrcSpan loc $
+        -- GHC extension: look up both the tycon and data con 
+       -- for con-like things
+       -- If neither are in scope, report an error; otherwise
+       -- add both to the fixity env
+     addLocM lookupTopFixSigNames rdr_name     `thenM` \ names ->
+     if null names then
+         addLocErr rdr_name unknownNameErr     `thenM_`
+         returnM fix_env
+     else
+         foldlM add fix_env names
+  where
+    add fix_env name
+      = case lookupNameEnv fix_env name of
+          Just (FixItem _ _ loc') 
+                 -> addLocErr rdr_name (dupFixityDecl loc')    `thenM_`
+                    returnM fix_env
+         Nothing -> returnM (extendNameEnv fix_env name fix_item)
+      where
+       fix_item = FixItem (rdrNameOcc (unLoc rdr_name)) fixity
+                        (getLoc rdr_name)
+
+pprFixEnv :: FixityEnv -> SDoc
+pprFixEnv env 
+  = pprWithCommas (\ (FixItem n f _) -> ppr f <+> ppr n)
+                 (nameEnvElts env)
+
+dupFixityDecl loc rdr_name
+  = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
+         ptext SLIT("also at ") <+> ppr loc
+       ]
+\end{code}

 
 

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

 
 

+%*********************************************************
+%*                                                      *
+       Source-code deprecations declarations
+%*                                                      *
+%*********************************************************

 
 

-rnDecl (SigD (IfaceSig name ty id_infos loc))
-  = pushSrcLocRn loc $
-    lookupBndrRn name          `thenRn` \ name' ->
-    rnHsType doc_str ty                `thenRn` \ ty' ->
+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.

 
 

-       -- Get the pragma info (if any).
-    getModeRn                  `thenRn` \ (InterfaceMode _ print_unqual) ->
-    setModeRn (InterfaceMode Optional print_unqual) $
-       -- 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))
-  where
-    doc_str = text "the interface signature for" <+> quotes (ppr name)
+\begin{code}
+rnSrcDeprecDecls :: [LDeprecDecl RdrName] -> RnM Deprecations
+rnSrcDeprecDecls [] 
+  = returnM NoDeprecs
+
+rnSrcDeprecDecls decls
+  = mappM (addLocM rn_deprec) decls    `thenM` \ pairs ->
+    returnM (DeprecSome (mkNameEnv (catMaybes pairs)))
+ where
+   rn_deprec (Deprecation rdr_name txt)
+     = lookupTopBndrRn rdr_name        `thenM` \ name ->
+       returnM (Just (name, (rdrNameOcc rdr_name, txt)))
+
+checkModDeprec :: Maybe DeprecTxt -> Deprecations
+-- Check for a module deprecation; done once at top level
+checkModDeprec Nothing    = NoDeprecs
+checkModDeprec (Just txt) = DeprecAll txt

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

-\subsection{Type declarations}
+\subsection{Source code 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 (TyD (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc))
-  = pushSrcLocRn src_loc $
-    lookupBndrRn tycon                                 `thenRn` \ tycon' ->
-    bindTyVarsRn data_doc tyvars                       $ \ tyvars' ->
-    rnContext data_doc context                                 `thenRn` \ context' ->
-    checkDupOrQualNames data_doc con_names             `thenRn_`
-    mapRn rnConDecl condecls                           `thenRn` \ condecls' ->
-    rnDerivs derivings                                 `thenRn` \ derivings' ->
-    ASSERT(isNoDataPragmas pragmas)
-    returnRn (TyD (TyData new_or_data context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc))
-  where
-    data_doc = text "the data type declaration for" <+> ppr tycon
-    con_names = map conDeclName condecls
-
-rnDecl (TyD (TySynonym name tyvars ty src_loc))
-  = pushSrcLocRn src_loc $
-    lookupBndrRn name                          `thenRn` \ name' ->
-    bindTyVarsRn syn_doc tyvars                $ \ tyvars' ->
-    rnHsType syn_doc ty                                `thenRn` \ ty' ->
-    returnRn (TyD (TySynonym name' tyvars' ty' src_loc))
+rnDefaultDecl (DefaultDecl tys)
+  = mapFvRn (rnHsTypeFVs doc_str) tys  `thenM` \ (tys', fvs) ->
+    returnM (DefaultDecl tys', fvs)

   where
   where

-    syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
+    doc_str = text "In a `default' declaration"

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

-\subsection{Class declarations}
+               Bindings

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

-@rnClassDecl@ uses the `global name function' to create a new
-class declaration in which local names have been replaced by their
-original names, reporting any unknown names.
+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 (ClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname src_loc))
-  = pushSrcLocRn src_loc $
-
-    lookupBndrRn cname                                 `thenRn` \ cname' ->
-    lookupBndrRn tname                                 `thenRn` \ tname' ->
-    lookupBndrRn dname                                 `thenRn` \ dname' ->
-
-    bindTyVarsRn cls_doc tyvars                                        ( \ tyvars' ->
-       rnContext cls_doc context                               `thenRn` \ context' ->
-
-            -- Check the signatures
-       let
-         clas_tyvar_names = map getTyVarName tyvars'
-       in
-       checkDupOrQualNames sig_doc sig_rdr_names_w_locs        `thenRn_` 
-       mapRn (rn_op cname' clas_tyvar_names) sigs              `thenRn` \ sigs' ->
-       returnRn (tyvars', context', sigs')
-    )                                                  `thenRn` \ (tyvars', context', sigs') ->
+rnBindGroups :: [HsBindGroup RdrName] -> RnM ([HsBindGroup Name], DefUses)
+-- This version assumes that the binders are already in scope
+-- It's used only in 'mdo'
+rnBindGroups []
+   = returnM ([], emptyDUs)
+rnBindGroups [HsBindGroup bind sigs _]
+   = rnBinds NotTopLevel bind sigs
+rnBindGroups b@[HsIPBinds bind]
+   = do addErr (badIpBinds b)  
+       returnM ([], emptyDUs)
+rnBindGroups _
+   = panic "rnBindGroups"
+
+rnBindGroupsAndThen 
+  :: [HsBindGroup RdrName]
+  -> ([HsBindGroup Name] -> RnM (result, FreeVars))
+  -> RnM (result, FreeVars)
+-- This version (a) assumes that the binding vars are not already in scope
+--             (b) removes the binders from the free vars of the thing inside
+-- The parser doesn't produce ThenBinds
+rnBindGroupsAndThen [] thing_inside
+  = thing_inside []
+rnBindGroupsAndThen [HsBindGroup bind sigs _] thing_inside
+  = rnBindsAndThen bind sigs $ \ groups -> thing_inside groups
+rnBindGroupsAndThen [HsIPBinds binds] thing_inside
+  = rnIPBinds binds                    `thenM` \ (binds',fv_binds) ->
+    thing_inside [HsIPBinds binds']    `thenM` \ (thing, fvs_thing) ->
+    returnM (thing, fvs_thing `plusFV` fv_binds)
+
+rnIPBinds [] = returnM ([], emptyFVs)
+rnIPBinds (bind : binds)
+  = wrapLocFstM rnIPBind bind  `thenM` \ (bind', fvBind) ->
+    rnIPBinds binds            `thenM` \ (binds',fvBinds) ->
+    returnM (bind' : binds', fvBind `plusFV` fvBinds)
+
+rnIPBind (IPBind n expr)
+  = newIPNameRn  n             `thenM` \ name ->
+    rnLExpr expr               `thenM` \ (expr',fvExpr) ->
+    return (IPBind name expr', fvExpr)
+
+badIpBinds binds
+  = hang (ptext SLIT("Implicit-parameter bindings illegal in 'mdo':")) 4
+        (ppr binds)
+\end{code}

 
 

-       -- Check the methods
-    checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
-    rnMethodBinds mbinds                               `thenRn` \ mbinds' ->

 
 

-       -- 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 (ClD (ClassDecl context' cname' tyvars' sigs' mbinds' NoClassPragmas tname' dname' src_loc))
-  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 ->
-       rnHsSigType (quotes (ppr op)) ty        `thenRn` \ new_ty  ->
-
-               -- Make the default-method name
-       let
-           dm_occ = mkDefaultMethodName (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 (ifaceFlavour clas)   `thenRn` \ dm_name ->
-                   addOccurrenceName dm_name                                   `thenRn_`
-                   returnRn (Just dm_name)
-
-           other -> returnRn Nothing
-       )                                       `thenRn` \ maybe_dm_name ->
-
-               -- Check that each class tyvar appears in op_ty
-       let
-           (ctxt, op_ty) = case new_ty of
-                               HsForAllTy tvs ctxt op_ty -> (ctxt, op_ty)
-                               other                     -> ([], new_ty)
-           ctxt_fvs  = extractHsCtxtTyNames ctxt       -- Includes tycons/classes but we
-           op_ty_fvs = extractHsTyNames op_ty          -- don't care about that
-
-           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_`
-
-       returnRn (ClassOpSig op_name maybe_dm_name new_ty locn)
+\begin{code}
+rnHsForeignDecl (ForeignImport name ty spec isDeprec)
+  = lookupLocatedTopBndrRn name                `thenM` \ name' ->
+    rnHsTypeFVs (fo_decl_msg name) ty  `thenM` \ (ty', fvs) ->
+    returnM (ForeignImport name' ty' spec isDeprec, fvs)
+
+rnHsForeignDecl (ForeignExport name ty spec isDeprec)
+  = lookupLocatedOccRn name            `thenM` \ name' ->
+    rnHsTypeFVs (fo_decl_msg name) ty          `thenM` \ (ty', fvs) ->
+    returnM (ForeignExport name' ty' spec isDeprec, fvs )
+       -- NB: a foreign export is an *occurrence site* for name, so 
+       --     we add it to the free-variable list.  It might, for example,
+       --     be imported from another module
+
+fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name

 \end{code}
 
 
 \end{code}
 
 

@@ -233,515 +320,376 @@ rnDecl (ClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname src_
 %*********************************************************
 
 \begin{code}
 %*********************************************************
 
 \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' ->
-
+rnSrcInstDecl (InstDecl inst_ty mbinds uprags)
+       -- Used for both source and interface file decls
+  = rnHsSigType (text "an instance decl") inst_ty      `thenM` \ inst_ty' ->

 
        -- Rename the bindings
 
        -- Rename the bindings

-       -- NB meth_names can be qualified!
-    checkDupNames meth_doc meth_names          `thenRn_`
-    rnMethodBinds mbinds                       `thenRn` \ mbinds' ->
-    let 
-       binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds')))
-    in
-    renameSigs NotTopLevel True binders uprags `thenRn` \ new_uprags ->
-   
+       -- The typechecker (not the renamer) checks that all 
+       -- the bindings are for the right class

     let
     let

-     -- We use the class name and the name of the first
-     -- type constructor the class is applied to.
-     (cl_nm, tycon_nm) = mkDictPrefix inst_ty'
-     
-     mkDictPrefix (MonoDictTy cl tys) = 
-        case tys of
-         []     -> (c_nm, nilOccName )
-         (ty:_) -> (c_nm, getInstHeadTy ty)
-       where
-        c_nm = nameOccName (getName cl)
-
-     mkDictPrefix (HsForAllTy _ _ ty)  = mkDictPrefix ty  -- can this 
-     mkDictPrefix _                   = (nilOccName, nilOccName)
-
-     getInstHeadTy t 
-      = case t of
-          MonoTyVar tv    -> nameOccName (getName tv)
-          MonoTyApp t _   -> getInstHeadTy t
-         _               -> nilOccName
-           -- I cannot see how the rest of HsType constructors
-           -- can occur, but this isn't really a failure condition,
-           -- so we return silently.
-
-     nilOccName = (VarOcc _NIL_) -- ToDo: add OccName constructor fun for this.
+       meth_doc    = text "In the bindings in an instance declaration"
+       meth_names  = collectHsBindLocatedBinders mbinds
+       (inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')

     in
     in

-    newDfunName cl_nm tycon_nm 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
+    checkDupNames meth_doc meth_names  `thenM_`
+    extendTyVarEnvForMethodBinds inst_tyvars (         
+       -- (Slightly strangely) the forall-d tyvars scope over
+       -- the method bindings too
+       rnMethodBinds cls [] mbinds
+    )                                          `thenM` \ (mbinds', meth_fvs) ->
+       -- Rename the prags and signatures.
+       -- Note that the type variables are not in scope here,
+       -- so that      instance Eq a => Eq (T a) where
+       --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
+       -- works OK. 
+       --
+       -- But the (unqualified) method names are in scope
+    let 
+       binders = collectHsBindBinders mbinds'
+    in
+    bindLocalNames binders (renameSigs uprags)                 `thenM` \ uprags' ->
+    checkSigs (okInstDclSig (mkNameSet binders)) uprags'       `thenM_`

 
 

-       -- 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))
-  where
-    meth_doc = text "the bindings in an instance declaration"
-    meth_names   = bagToList (collectMonoBinders mbinds)
+    returnM (InstDecl inst_ty' mbinds' uprags',
+            meth_fvs `plusFV` hsSigsFVs uprags'
+                     `plusFV` extractHsTyNames inst_ty')

 \end{code}
 
 \end{code}
 

-%*********************************************************
-%*                                                     *
-\subsection{Default declarations}
-%*                                                     *
-%*********************************************************
+For the method bindings in class and instance decls, we extend the 
+type variable environment iff -fglasgow-exts

 
 \begin{code}
 
 \begin{code}

-rnDecl (DefD (DefaultDecl tys src_loc))
-  = pushSrcLocRn src_loc $
-    mapRn (rnHsType doc_str) tys       `thenRn` \ tys' ->
-    lookupImplicitOccRn numClass_RDR   `thenRn_` 
-    returnRn (DefD (DefaultDecl tys' src_loc))
-  where
-    doc_str = text "a `default' declaration"
+extendTyVarEnvForMethodBinds tyvars thing_inside
+  = doptM Opt_GlasgowExts                      `thenM` \ opt_GlasgowExts ->
+    if opt_GlasgowExts then
+       extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
+    else
+       thing_inside

 \end{code}
 
 \end{code}
 

-%*********************************************************
-%*                                                     *
-\subsection{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' ->
-    returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc))
- where
-  fo_decl_msg = ptext SLIT("a foreign declaration")
-  isDyn              = isDynamic ext_nm
-
-\end{code}

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

-\subsection{Support code for type/data declarations}
+\subsection{Rules}

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

-rnDerivs :: Maybe [RdrName] -> RnMS s (Maybe [Name])
+rnHsRuleDecl (HsRule rule_name act vars lhs rhs)
+  = bindPatSigTyVarsFV (collectRuleBndrSigTys vars)    $

 
 

-rnDerivs Nothing -- derivs not specified
-  = returnRn Nothing
+    bindLocatedLocalsFV doc (map get_var vars)         $ \ ids ->
+    mapFvRn rn_var (vars `zip` ids)            `thenM` \ (vars', fv_vars) ->

 
 

-rnDerivs (Just ds)
-  = mapRn rn_deriv ds `thenRn` \ derivs ->
-    returnRn (Just derivs)
+    rnLExpr lhs                                        `thenM` \ (lhs', fv_lhs) ->
+    rnLExpr 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',
+            fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)

   where
   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
+    doc = text "In the transformation rule" <+> ftext rule_name
+  
+    get_var (RuleBndr v)      = v
+    get_var (RuleBndrSig v _) = v
+
+    rn_var (RuleBndr (L loc v), id)
+       = returnM (RuleBndr (L loc id), emptyFVs)
+    rn_var (RuleBndrSig (L loc v) t, id)
+       = rnHsTypeFVs doc t     `thenM` \ (t', fvs) ->
+         returnM (RuleBndrSig (L loc id) t', fvs)

 \end{code}
 
 \end{code}
 

-\begin{code}
-conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
-conDeclName (ConDecl n _ _ _ l) = (n,l)
-
-rnConDecl :: RdrNameConDecl -> RnMS s RenamedConDecl
-rnConDecl (ConDecl name tvs cxt details locn)
-  = pushSrcLocRn locn $
-    checkConName name                  `thenRn_` 
-    lookupBndrRn name                  `thenRn` \ new_name ->
-    bindTyVarsRn doc tvs               $ \ new_tyvars ->
-    rnContext doc cxt                  `thenRn` \ new_context ->
-    rnConDetails doc locn details      `thenRn` \ new_details -> 
-    returnRn (ConDecl new_name new_tyvars new_context new_details locn)
-  where
-    doc = text "the definition of data constructor" <+> quotes (ppr name)
-
-rnConDetails doc locn (VanillaCon tys)
-  = mapRn (rnBangTy doc) tys           `thenRn` \ new_tys  ->
-    returnRn (VanillaCon new_tys)
+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.)

 
 

-rnConDetails doc locn (InfixCon ty1 ty2)
-  = rnBangTy doc ty1           `thenRn` \ new_ty1 ->
-    rnBangTy doc ty2           `thenRn` \ new_ty2 ->
-    returnRn (InfixCon new_ty1 new_ty2)
+NB: if you add new cases here, make sure you add new ones to TcRule.ruleLhsTvs

 
 

-rnConDetails doc locn (NewCon ty)
-  = rnHsType doc ty                    `thenRn` \ new_ty  ->
-    returnRn (NewCon new_ty)
-
-rnConDetails doc locn (RecCon fields)
-  = checkDupOrQualNames doc field_names        `thenRn_`
-    mapRn (rnField doc) fields         `thenRn` \ new_fields ->
-    returnRn (RecCon new_fields)
+\begin{code}
+validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
+-- Nothing => OK
+-- Just e  => Not ok, and e is the offending expression
+validRuleLhs foralls lhs
+  = checkl lhs

   where
   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 ->
-    returnRn (new_names, new_ty) 
-
-rnBangTy doc (Banged ty)
-  = rnHsType doc ty `thenRn` \ new_ty ->
-    returnRn (Banged new_ty)
-
-rnBangTy doc (Unbanged ty)
-  = rnHsType doc ty `thenRn` \ new_ty ->
-    returnRn (Unbanged new_ty)
-
--- This data decl will parse OK
---     data T = a Int
--- treating "a" as the constructor.
--- It is really hard to make the parser spot this malformation.
--- So the renamer has to check that the constructor is legal
---
--- We can get an operator as the constructor, even in the prefix form:
---     data T = :% Int Int
--- from interface files, which always print in prefix form
-
-checkConName name
-  = checkRn (isLexCon (occNameString (rdrNameOcc name)))
-           (badDataCon name)
+    checkl (L loc e) = check e
+
+    check (OpApp e1 op _ e2)             = checkl op `seqMaybe` checkl_e e1 `seqMaybe` checkl_e e2
+    check (HsApp e1 e2)                  = checkl e1 `seqMaybe` checkl_e e2
+    check (HsVar v) | v `notElem` foralls = Nothing
+    check other                                  = Just other  -- Failure
+
+    checkl_e (L loc e) = check_e e
+
+    check_e (HsVar v)     = Nothing
+    check_e (HsPar e)    = checkl_e e
+    check_e (HsLit e)    = Nothing
+    check_e (HsOverLit e) = Nothing
+
+    check_e (OpApp e1 op _ e2)          = checkl_e e1 `seqMaybe` checkl_e op `seqMaybe` checkl_e e2
+    check_e (HsApp e1 e2)               = checkl_e e1 `seqMaybe` checkl_e e2
+    check_e (NegApp e _)                = checkl_e e
+    check_e (ExplicitList _ es)         = checkl_es es
+    check_e (ExplicitTuple es _) = checkl_es es
+    check_e other               = Just other   -- Fails
+
+    checkl_es es = foldr (seqMaybe . checkl_e) Nothing es
+
+badRuleLhsErr name lhs (Just bad_e)
+  = sep [ptext SLIT("Rule") <+> ftext name <> colon,
+        nest 4 (vcat [ptext SLIT("Illegal expression:") <+> ppr bad_e, 
+                      ptext SLIT("in left-hand side:") <+> ppr lhs])]
+    $$
+    ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
+
+badRuleVar name var
+  = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon,
+        ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+> 
+               ptext SLIT("does not appear on left hand side")]

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

-\subsection{Support code to rename types}
+\subsection{Type, class and iface sig declarations}

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

-\begin{code}
-rnHsSigType :: SDoc -> RdrNameHsType -> RnMS s RenamedHsType 
-       -- 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
-
-
-
-
-rnHsType :: SDoc -> RdrNameHsType -> RnMS s RenamedHsType
-
-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_`
-
-    (bindTyVarsRn doc (map UserTyVar forall_tyvars)    $ \ new_tyvars ->
-    rnContext doc ctxt'                                        `thenRn` \ new_ctxt ->
-    rnHsType doc ty                                    `thenRn` \ new_ty ->
-    returnRn (mkHsForAllTy new_tyvars new_ctxt new_ty))
-
-rnHsType doc (HsForAllTy tvs ctxt ty)
-       -- tvs are non-empty, hence must be from an interface file
-       --      (tyvars may be kinded)
-  = bindTyVarsRn doc tvs               $ \ new_tyvars ->
-    rnContext doc ctxt                 `thenRn` \ new_ctxt ->
-    rnHsType doc ty                    `thenRn` \ new_ty ->
-    returnRn (mkHsForAllTy new_tyvars new_ctxt new_ty)
-
-
-rnHsType doc (MonoTyVar tyvar)
-  = lookupOccRn tyvar          `thenRn` \ tyvar' ->
-    returnRn (MonoTyVar tyvar')
-
-rnHsType doc (MonoFunTy ty1 ty2)
-  = andRn MonoFunTy (rnHsType doc ty1) (rnHsType doc ty2)
-
-rnHsType doc (MonoListTy ty)
-  = addImplicitOccRn listTyCon_name            `thenRn_`
-    rnHsType doc ty                            `thenRn` \ ty' ->
-    returnRn (MonoListTy ty')
-
-rnHsType doc (MonoTupleTy tys boxed)
-  = addImplicitOccRn (tupleTyCon_name boxed (length tys)) `thenRn_`
-    mapRn (rnHsType doc) tys                             `thenRn` \ tys' ->
-    returnRn (MonoTupleTy tys' boxed)
-
-rnHsType doc (MonoTyApp ty1 ty2)
-  = rnHsType doc ty1           `thenRn` \ ty1' ->
-    rnHsType doc ty2           `thenRn` \ ty2' ->
-    returnRn (MonoTyApp ty1' ty2')
-
-rnHsType doc (MonoDictTy clas tys)
-  = lookupOccRn clas           `thenRn` \ clas' ->
-    mapRn (rnHsType doc) tys   `thenRn` \ tys' ->
-    returnRn (MonoDictTy clas' tys')
-\end{code}
+@rnTyDecl@ uses the `global name function' to create a new type
+declaration in which local names have been replaced by their original
+names, reporting any unknown names.

 
 

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

-rnContext :: SDoc -> RdrNameContext -> RnMS s RenamedContext
+rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_name})
+  = lookupLocatedTopBndrRn name                `thenM` \ name' ->
+    returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
+            emptyFVs)
+
+rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon,
+                      tcdTyVars = tyvars, tcdCons = condecls, 
+                      tcdDerivs = derivs})
+  = lookupLocatedTopBndrRn tycon               `thenM` \ tycon' ->
+    bindTyVarsRn data_doc tyvars               $ \ tyvars' ->
+    rnContext data_doc context                         `thenM` \ context' ->
+    rn_derivs derivs                           `thenM` \ (derivs', deriv_fvs) ->
+    checkDupNames data_doc con_names   `thenM_`
+    rnConDecls (unLoc tycon') condecls `thenM` \ condecls' ->
+    returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon',
+                    tcdTyVars = tyvars', tcdCons = condecls', 
+                    tcdDerivs = derivs'}, 
+            delFVs (map hsLTyVarName tyvars')  $
+            extractHsCtxtTyNames context'      `plusFV`
+            plusFVs (map conDeclFVs condecls') `plusFV`
+            deriv_fvs)
+  where
+    data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
+    con_names = [ n | L _ (ConDecl n _ _ _) <- condecls ]

 
 

-rnContext doc ctxt
-  = mapRn rn_ctxt ctxt         `thenRn` \ theta  ->
+    rn_derivs Nothing   = returnM (Nothing, emptyFVs)
+    rn_derivs (Just ds) = rnContext data_doc ds        `thenM` \ ds' -> 
+                         returnM (Just ds', extractHsCtxtTyNames ds')
+    
+rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars, tcdSynRhs = ty})
+  = lookupLocatedTopBndrRn name                        `thenM` \ name' ->
+    bindTyVarsRn syn_doc tyvars                $ \ tyvars' ->
+    rnHsTypeFVs syn_doc ty                     `thenM` \ (ty', fvs) ->
+    returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars', 
+                       tcdSynRhs = ty'},
+            delFVs (map hsLTyVarName tyvars') fvs)
+  where
+    syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
+
+rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, 
+                      tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
+                      tcdMeths = mbinds})
+  = lookupLocatedTopBndrRn cname               `thenM` \ cname' ->
+
+       -- Tyvars scope over superclass context and method signatures
+    bindTyVarsRn cls_doc tyvars                        ( \ tyvars' ->
+       rnContext cls_doc context       `thenM` \ context' ->
+       rnFds cls_doc fds               `thenM` \ fds' ->
+       renameSigs sigs                 `thenM` \ sigs' ->
+       returnM   (tyvars', context', fds', sigs')
+    )  `thenM` \ (tyvars', context', fds', sigs') ->
+
+       -- Check the signatures
+       -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).

     let
     let

-       (_, dup_asserts) = removeDups cmp_assert theta
+       sig_rdr_names_w_locs   = [op | L _ (Sig op _) <- sigs]

     in
     in

-       -- Check for duplicate assertions
-       -- If this isn't an error, then it ought to be:
-    mapRn (addWarnRn . dupClassAssertWarn theta) dup_asserts   `thenRn_`
+    checkDupNames sig_doc sig_rdr_names_w_locs `thenM_` 
+    checkSigs okClsDclSig sigs'                                `thenM_`
+       -- Typechecker is responsible for checking that we only
+       -- give default-method bindings for things in this class.
+       -- The renamer *could* check this for class decls, but can't
+       -- for instance decls.

 
 

-    returnRn theta
+       -- The newLocals call is tiresome: given a generic class decl
+       --      class C a where
+       --        op :: a -> a
+       --        op {| x+y |} (Inl a) = ...
+       --        op {| x+y |} (Inr b) = ...
+       --        op {| a*b |} (a*b)   = ...
+       -- we want to name both "x" tyvars with the same unique, so that they are
+       -- easy to group together in the typechecker.  
+    extendTyVarEnvForMethodBinds tyvars' (
+        getLocalRdrEnv                                 `thenM` \ name_env ->
+        let
+            meth_rdr_names_w_locs = collectHsBindLocatedBinders mbinds
+            gen_rdr_tyvars_w_locs = 
+               [ tv | tv <- extractGenericPatTyVars mbinds,
+                     not (unLoc tv `elemLocalRdrEnv` name_env) ]
+        in
+        checkDupNames meth_doc meth_rdr_names_w_locs   `thenM_`
+        newLocalsRn gen_rdr_tyvars_w_locs      `thenM` \ gen_tyvars ->
+        rnMethodBinds (unLoc cname') gen_tyvars mbinds
+    ) `thenM` \ (mbinds', meth_fvs) ->
+
+    returnM (ClassDecl { tcdCtxt = context', tcdLName = cname', tcdTyVars = tyvars',
+                        tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds'},
+            delFVs (map hsLTyVarName tyvars')  $
+            extractHsCtxtTyNames context'          `plusFV`
+            plusFVs (map extractFunDepNames (map unLoc fds'))  `plusFV`
+            hsSigsFVs sigs'                        `plusFV`
+            meth_fvs)

   where
   where

-    rn_ctxt (clas, tys)
-      =        lookupBndrRn clas               `thenRn` \ clas_name ->
-       addOccurrenceName clas_name     `thenRn_`
-       mapRn (rnHsType doc) tys        `thenRn` \ tys' ->
-       returnRn (clas_name, tys')
-
-    cmp_assert (c1,tys1) (c2,tys2)
-      = (c1 `compare` c2) `thenCmp` (cmpHsTypes compare tys1 tys2)
+    meth_doc = text "In the default-methods for class" <+> ppr cname
+    cls_doc  = text "In the declaration for class"     <+> ppr cname
+    sig_doc  = text "In the signatures for class"      <+> ppr cname

 \end{code}
 
 \end{code}
 

-

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

-\subsection{IdInfo}
+\subsection{Support code for type/data declarations}

 %*                                                     *
 %*********************************************************
 
 \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 (rnHsType doc) tys   `thenRn` \ tys' ->
-    returnRn (HsSpecialise tyvars' tys' expr')
+rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
+rnConDecls tycon condecls
+  =    -- Check that there's at least one condecl,
+       -- or else we're reading an interface file, or -fglasgow-exts
+    (if null condecls then
+       doptM Opt_GlasgowExts   `thenM` \ glaExts ->
+       checkErr glaExts (emptyConDeclsErr tycon)
+     else returnM ()
+    )                                          `thenM_` 
+    mappM (wrapLocM rnConDecl) condecls
+
+rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
+rnConDecl (ConDecl name tvs cxt details)
+  = addLocM checkConName name          `thenM_` 
+    lookupLocatedTopBndrRn name                `thenM` \ new_name ->
+
+    bindTyVarsRn doc tvs               $ \ new_tyvars ->
+    rnContext doc cxt                  `thenM` \ new_context ->
+    rnConDetails doc details           `thenM` \ new_details -> 
+    returnM (ConDecl new_name new_tyvars new_context new_details)

   where
   where

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

 
 

-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.
-  = lookupOccRn worker                 `thenRn` \ worker' ->
-    mapRn lookupOccRn cons             `thenRn_` 
-    returnRn (HsStrictnessInfo demands (Just (worker',[])))
-
--- Boring, but necessary for the type checker.
-rnStrict (HsStrictnessInfo demands Nothing) = returnRn (HsStrictnessInfo demands Nothing)
-rnStrict HsBottom                        = returnRn HsBottom
-\end{code}
+rnConDetails doc (PrefixCon tys)
+  = mappM (rnLBangTy doc) tys  `thenM` \ new_tys  ->
+    returnM (PrefixCon new_tys)

 
 

-UfCore expressions.
+rnConDetails doc (InfixCon ty1 ty2)
+  = rnLBangTy doc ty1                  `thenM` \ new_ty1 ->
+    rnLBangTy doc ty2                  `thenM` \ new_ty2 ->
+    returnM (InfixCon new_ty1 new_ty2)

 
 

-\begin{code}
-rnCoreExpr (UfType ty)
-  = rnHsType (text "unfolding type") ty        `thenRn` \ ty' ->
-    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 (UfTuple con args) 
-  = lookupOccRn con            `thenRn` \ con' ->
-    mapRn rnCoreExpr args      `thenRn` \ args' ->
-    returnRn (UfTuple con' args')
-
-rnCoreExpr (UfApp fun arg)
-  = rnCoreExpr fun             `thenRn` \ fun' ->
-    rnCoreExpr arg             `thenRn` \ arg' ->
-    returnRn (UfApp fun' arg')
-
-rnCoreExpr (UfCase scrut bndr alts) 
-  = rnCoreExpr scrut                   `thenRn` \ scrut' ->
-    bindLocalsRn "UfCase" [bndr]       $ \ [bndr'] ->
-    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') 
-
-rnCoreExpr (UfLam bndr body)
-  = rnCoreBndr bndr            $ \ bndr' ->
-    rnCoreExpr body            `thenRn` \ body' ->
-    returnRn (UfLam bndr' body')
-
-rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
-  = rnCoreExpr rhs             `thenRn` \ rhs' ->
-    rnCoreBndr bndr            $ \ bndr' ->
-    rnCoreExpr body            `thenRn` \ body' ->
-    returnRn (UfLet (UfNonRec bndr' rhs') body')
-
-rnCoreExpr (UfLet (UfRec pairs) body)
-  = rnCoreBndrs bndrs          $ \ bndrs' ->
-    mapRn rnCoreExpr rhss      `thenRn` \ rhss' ->
-    rnCoreExpr body            `thenRn` \ body' ->
-    returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body')
+rnConDetails doc (RecCon fields)
+  = checkDupNames doc field_names      `thenM_`
+    mappM (rnField doc) fields         `thenM` \ new_fields ->
+    returnM (RecCon new_fields)

   where
   where

-    (bndrs, rhss) = unzip pairs
-\end{code}
+    field_names = [fld | (fld, _) <- fields]

 
 

-\begin{code}
-rnCoreBndr (UfValBinder name ty) thing_inside
-  = rnHsType (text str) ty     `thenRn` \ ty' ->
-    bindLocalsRn str [name]    $ \ [name'] ->
-    thing_inside (UfValBinder name' ty')
-  where
-    str = "unfolding id"
-    
-rnCoreBndr (UfTyBinder name kind) thing_inside
-  = bindLocalsRn "unfolding tyvar" [name] $ \ [name'] ->
-    thing_inside (UfTyBinder name' kind)
-    
-rnCoreBndrs bndrs thing_inside         -- Expect them all to be ValBinders
-  = mapRn (rnHsType (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
-\end{code}    
+rnField doc (name, ty)
+  = lookupLocatedTopBndrRn name        `thenM` \ new_name ->
+    rnLBangTy doc ty           `thenM` \ new_ty ->
+    returnM (new_name, new_ty) 

 
 

-\begin{code}
-rnCoreAlt (con, bndrs, rhs)
-  = rnUfCon con                                `thenRn` \ con' ->
-    bindLocalsRn "unfolding alt" bndrs $ \ bndrs' ->
-    rnCoreExpr rhs                     `thenRn` \ rhs' ->
-    returnRn (con', bndrs', rhs')
+rnLBangTy doc = wrapLocM (rnBangTy doc)

 
 

+rnBangTy doc (BangType s ty)
+  = rnLHsType doc ty           `thenM` \ new_ty ->
+    returnM (BangType s new_ty)

 
 

-rnNote (UfCoerce ty)
-  = rnHsType (text "unfolding coerce") ty      `thenRn` \ ty' ->
-    returnRn (UfCoerce ty')
+-- This data decl will parse OK
+--     data T = a Int
+-- treating "a" as the constructor.
+-- It is really hard to make the parser spot this malformation.
+-- So the renamer has to check that the constructor is legal
+--
+-- We can get an operator as the constructor, even in the prefix form:
+--     data T = :% Int Int
+-- from interface files, which always print in prefix form

 
 

-rnNote (UfSCC cc)   = returnRn (UfSCC cc)
-rnNote UfInlineCall = returnRn UfInlineCall
+checkConName name = checkErr (isRdrDataCon name) (badDataCon name)

 
 

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

 
 

-rnUfCon UfDefault
-  = returnRn UfDefault
+emptyConDeclsErr tycon
+  = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
+        nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))]
+\end{code}

 
 

-rnUfCon (UfDataCon con)
-  = lookupOccRn con            `thenRn` \ con' ->
-    returnRn (UfDataCon con')

 
 

-rnUfCon (UfLitCon lit)
-  = returnRn (UfLitCon lit)
+%*********************************************************
+%*                                                     *
+\subsection{Support code to rename types}
+%*                                                     *
+%*********************************************************

 
 

-rnUfCon (UfLitLitCon lit ty)
-  = rnHsType (text "litlit") ty                `thenRn` \ ty' ->
-    returnRn (UfLitLitCon lit ty')
+\begin{code}
+rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]

 
 

-rnUfCon (UfPrimOp op)
-  = lookupOccRn op             `thenRn` \ op' ->
-    returnRn (UfPrimOp op')
+rnFds doc fds
+  = mappM (wrapLocM rn_fds) fds
+  where
+    rn_fds (tys1, tys2)
+      =        rnHsTyVars doc tys1             `thenM` \ tys1' ->
+       rnHsTyVars doc tys2             `thenM` \ tys2' ->
+       returnM (tys1', tys2')

 
 

-rnUfCon (UfCCallOp str casm gc)
-  = returnRn (UfCCallOp str casm gc)
+rnHsTyVars doc tvs  = mappM (rnHsTyvar doc) tvs
+rnHsTyvar doc tyvar = lookupOccRn tyvar

 \end{code}
 
 \end{code}
 

+

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

-\subsection{Errors}
+               Splices

 %*                                                     *
 %*********************************************************
 
 \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)]
-
-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)
-    )
-\end{code}
+rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
+rnSplice (HsSplice n expr)
+  = checkTH expr "splice"      `thenM_`
+    getSrcSpanM                `thenM` \ loc ->
+    newLocalsRn [L loc n]      `thenM` \ [n'] ->
+    rnLExpr expr               `thenM` \ (expr', fvs) ->
+    returnM (HsSplice n' expr', fvs)
+\end{code}
\ No newline at end of file