[project @ 2000-10-24 17:09:44 by simonpj]

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

diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 33d156d..e3ceb96 100644 (file)
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -1,79 +1,71 @@
 %
 %

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

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

-#include "HsVersions.h"
-
-module RnSource ( rnDecl, rnHsType, rnHsSigType ) where
+module RnSource ( rnDecl, rnTyClDecl, rnRuleDecl, rnInstDecl,
+                 rnSourceDecls, rnHsType, rnHsSigType
+       ) where

 
 

-IMPORT_1_3(List(partition))
-IMP_Ubiq()
+#include "HsVersions.h"

 
 

-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
-IMPORT_DELOOPER(RnLoop)                -- *check* the RnPass/RnExpr/RnBinds loop-breaking
-#else

 import RnExpr
 import RnExpr

---import {-# SOURCE #-} RnExpr
-#endif
-

 import HsSyn
 import HsSyn

-import HsDecls         ( HsIdInfo(..), HsStrictnessInfo(..) )
-import HsPragmas
-import HsTypes         ( getTyVarName )
-import RdrHsSyn
+import HsTypes         ( hsTyVarNames, pprHsContext )
+import RdrName         ( RdrName, isRdrDataCon, rdrNameOcc, mkRdrNameWkr )
+import RdrHsSyn                ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
+                         extractRuleBndrsTyVars, extractHsTyRdrTyVars,
+                         extractHsCtxtRdrTyVars, extractGenericPatTyVars
+                       )

 import RnHsSyn
 import HsCore
 import RnHsSyn
 import HsCore

-import CmdLineOpts     ( opt_IgnoreIfacePragmas )

 
 

-import RnBinds         ( rnTopBinds, rnMethodBinds )
-import RnEnv           ( bindTyVarsRn, lookupBndrRn, lookupOccRn, lookupImplicitOccRn, bindLocalsRn,
-                         newDfunName, checkDupOrQualNames, checkDupNames,
-                         newLocallyDefinedGlobalName, newGlobalName, ifaceFlavour,
-                         listType_RDR, tupleType_RDR )
+import RnBinds         ( rnTopBinds, rnMethodBinds, renameSigs )
+import RnEnv           ( lookupTopBndrRn, lookupOccRn, newIPName,
+                         lookupOrigNames, lookupSysBinder, newLocalsRn,
+                         bindLocalsFVRn, bindUVarRn,
+                         bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn,
+                         bindCoreLocalFVRn, bindCoreLocalsFVRn, bindLocalNames,
+                         checkDupOrQualNames, checkDupNames,
+                         FreeVars, emptyFVs, plusFV, plusFVs, unitFV, 
+                         addOneFV, mapFvRn
+                       )

 import RnMonad
 
 import RnMonad
 

-import Name            ( Name, isLocallyDefined, 
-                         OccName(..), occNameString, prefixOccName,
-                         ExportFlag(..),
-                         Provenance(..), getNameProvenance,
-                         SYN_IE(NameSet), unionNameSets, emptyNameSet, mkNameSet, unitNameSet,
-                         elemNameSet
+import FunDeps         ( oclose )
+import Class           ( FunDep, DefMeth (..) )
+import Name            ( Name, OccName, nameOccName, NamedThing(..) )
+import NameSet
+import FiniteMap       ( elemFM )
+import PrelInfo                ( derivableClassKeys, cCallishClassKeys )
+import PrelNames       ( deRefStablePtr_RDR, makeStablePtr_RDR,
+                         bindIO_RDR, returnIO_RDR

                        )
                        )

-import ErrUtils                ( addErrLoc, addShortErrLocLine, addShortWarnLocLine )
-import FiniteMap       ( emptyFM, lookupFM, addListToFM_C )
-import Id              ( GenId{-instance NamedThing-} )
-import IdInfo          ( IdInfo, StrictnessInfo(..), FBTypeInfo, DemandInfo, ArgUsageInfo )
-import SpecEnv         ( SpecEnv )
-import Lex             ( isLexCon )
-import CoreUnfold      ( Unfolding(..), SimpleUnfolding )
-import MagicUFs                ( MagicUnfoldingFun )
-import PrelInfo                ( derivingOccurrences, evalClass_RDR, numClass_RDR, allClass_NAME )
-import ListSetOps      ( unionLists, minusList )
-import Maybes          ( maybeToBool, catMaybes )
-import Bag             ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList )
-import Outputable      ( PprStyle(..), Outputable(..){-instances-}, pprQuote )
-import Pretty
+import List            ( partition, nub )
+import Outputable

 import SrcLoc          ( SrcLoc )
 import SrcLoc          ( SrcLoc )

-import Unique          ( Unique )
-import UniqSet         ( SYN_IE(UniqSet) )
-import UniqFM          ( UniqFM, lookupUFM )
-import Util
-IMPORT_1_3(List(nub))
+import CmdLineOpts     ( DynFlag(..) )
+                               -- Warn of unused for-all'd tyvars
+import Unique          ( Uniquable(..) )
+import ErrUtils                ( Message )
+import CStrings                ( isCLabelString )
+import ListSetOps      ( removeDupsEq )

 \end{code}
 
 \end{code}
 

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

@@ -84,221 +76,355 @@ Checks the (..) etc constraints in the export list.
 %*********************************************************
 
 \begin{code}
 %*********************************************************
 
 \begin{code}

-rnDecl :: RdrNameHsDecl -> RnMS s RenamedHsDecl
+rnSourceDecls :: [RdrNameHsDecl] -> RnMS ([RenamedHsDecl], FreeVars)
+       -- The decls get reversed, but that's ok

 
 

-rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ new_binds ->
-                     returnRn (ValD new_binds)
-
-
-rnDecl (SigD (IfaceSig name ty id_infos loc))
-  = pushSrcLocRn loc $
-    lookupBndrRn name          `thenRn` \ name' ->
-    rnHsType 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))
+rnSourceDecls decls
+  = go emptyFVs [] decls
+  where
+       -- 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)         = rnDecl d       `thenRn` \(d', fvs') ->
+                               go (fvs `plusFV` fvs') (d':ds') ds

 \end{code}
 
 \end{code}
 

+

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

-\subsection{Type declarations}
+\subsection{Value 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.
+\begin{code}
+-- rnDecl does all the work
+rnDecl :: RdrNameHsDecl -> RnMS (RenamedHsDecl, FreeVars)

 
 

-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.
+rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) ->
+                     returnRn (ValD new_binds, fvs)

 
 

-\begin{code}
-rnDecl (TyD (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc))
+rnDecl (TyClD tycl_decl) = rnTyClDecl tycl_decl        `thenRn` \ (new_decl, fvs) ->
+                          returnRn (TyClD new_decl, fvs)
+
+rnDecl (RuleD rule)
+  = rnRuleDecl rule    `thenRn` \ (new_rule, fvs) ->
+    returnRn (RuleD new_rule, fvs)
+
+rnDecl (InstD inst)
+  = rnInstDecl inst    `thenRn` \ (new_inst, fvs) ->
+    returnRn (InstD new_inst, fvs)
+
+rnDecl (DefD (DefaultDecl tys src_loc))

   = pushSrcLocRn src_loc $
   = pushSrcLocRn src_loc $

-    lookupBndrRn tycon                                 `thenRn` \ tycon' ->
-    bindTyVarsRn data_doc tyvars                       $ \ tyvars' ->
-    rnContext 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))
+    rnHsTypes doc_str tys              `thenRn` \ (tys', fvs) ->
+    returnRn (DefD (DefaultDecl tys' src_loc), fvs)

   where
   where

-    data_doc sty = text "the data type declaration for" <+> ppr sty tycon
-    con_names = map conDeclName condecls
+    doc_str = text "a `default' declaration"

 
 

-rnDecl (TyD (TySynonym name tyvars ty src_loc))
+rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))

   = pushSrcLocRn src_loc $
   = pushSrcLocRn src_loc $

-    lookupBndrRn name                          `thenRn` \ name' ->
-    bindTyVarsRn syn_doc tyvars                $ \ tyvars' ->
-    rnHsType ty                                        `thenRn` \ ty' ->
-    returnRn (TyD (TySynonym name' tyvars' ty' src_loc))
-  where
-    syn_doc sty = text "the declaration for type synonym" <+> ppr sty name
+    lookupOccRn name                   `thenRn` \ name' ->
+    let 
+       extra_fvs FoExport 
+         | isDyn = lookupOrigNames [makeStablePtr_RDR, deRefStablePtr_RDR,
+                                    bindIO_RDR, returnIO_RDR]
+         | otherwise =
+               lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs ->
+               returnRn (addOneFV fvs name')
+       extra_fvs other = returnRn emptyFVs
+    in
+    checkRn (ok_ext_nm ext_nm) (badExtName ext_nm)     `thenRn_`
+
+    extra_fvs imp_exp                                  `thenRn` \ fvs1 -> 
+
+    rnHsSigType fo_decl_msg ty                         `thenRn` \ (ty', fvs2) ->
+    returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc), 
+             fvs1 `plusFV` fvs2)
+ where
+  fo_decl_msg = ptext SLIT("a foreign declaration")
+  isDyn              = isDynamicExtName ext_nm
+
+  ok_ext_nm Dynamic               = True
+  ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb
+  ok_ext_nm (ExtName nm Nothing)   = isCLabelString nm

 \end{code}
 
 \end{code}
 

+

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

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

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

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

 \begin{code}
 \begin{code}

-rnDecl (ClD (ClassDecl context cname tyvar sigs mbinds pragmas src_loc))
+rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc)

   = pushSrcLocRn src_loc $
   = pushSrcLocRn src_loc $

+    rnHsSigType (text "an instance decl") inst_ty `thenRn` \ (inst_ty', inst_fvs) ->
+    let
+       inst_tyvars = case inst_ty' of
+                       HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
+                       other                             -> []
+       -- (Slightly strangely) the forall-d tyvars scope over
+       -- the method bindings too
+    in

 
 

-    bindTyVarsRn cls_doc [tyvar]                       ( \ [tyvar'] ->
-       rnContext context                                       `thenRn` \ context' ->
-       lookupBndrRn cname                                      `thenRn` \ cname' ->
+       -- Rename the bindings
+       -- NB meth_names can be qualified!
+    checkDupNames meth_doc meth_names          `thenRn_`
+    extendTyVarEnvFVRn (map hsTyVarName inst_tyvars) (         
+       rnMethodBinds [] 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 (
+       renameSigs (okInstDclSig binder_set) uprags
+    )                                                  `thenRn` \ (new_uprags, prag_fvs) ->
+
+    (case maybe_dfun_rdr_name of
+       Nothing            -> returnRn (Nothing, emptyFVs)
+
+       Just dfun_rdr_name -> lookupSysBinder dfun_rdr_name     `thenRn` \ dfun_name ->
+                             returnRn (Just dfun_name, unitFV dfun_name)
+    )                                                  `thenRn` \ (maybe_dfun_name, dfun_fv) ->
+
+    -- The typechecker checks that all the bindings are for the right class.
+    returnRn (InstDecl inst_ty' mbinds' new_uprags maybe_dfun_name src_loc,
+             inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs `plusFV` dfun_fv)
+  where
+    meth_doc   = text "the bindings in an instance declaration"
+    meth_names = collectLocatedMonoBinders mbinds
+\end{code}

 
 

-            -- Check the signatures
-       checkDupOrQualNames sig_doc sig_rdr_names_w_locs        `thenRn_` 
-       mapRn (rn_op cname' (getTyVarName tyvar')) sigs         `thenRn` \ sigs' ->
-       returnRn (tyvar', context', cname', sigs')
-    )                                                  `thenRn` \ (tyvar', context', cname', sigs') ->
+%*********************************************************
+%*                                                     *
+\subsection{Rules}
+%*                                                     *
+%*********************************************************

 
 

-       -- Check the methods
-    checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
-    rnMethodBinds mbinds                               `thenRn` \ mbinds' ->
+\begin{code}
+rnRuleDecl (IfaceRule rule_name vars fn args rhs src_loc)
+  = pushSrcLocRn src_loc       $
+    lookupOccRn fn             `thenRn` \ fn' ->
+    rnCoreBndrs vars           $ \ vars' ->
+    mapFvRn rnCoreExpr args    `thenRn` \ (args', fvs1) ->
+    rnCoreExpr rhs             `thenRn` \ (rhs',  fvs2) ->
+    returnRn (IfaceRule rule_name vars' fn' args' rhs' src_loc, 
+             (fvs1 `plusFV` fvs2) `addOneFV` fn')
+
+rnRuleDecl (HsRule rule_name tvs vars lhs rhs src_loc)
+  = ASSERT( null tvs )
+    pushSrcLocRn src_loc                       $
+
+    bindTyVarsFV2Rn doc (map UserTyVar sig_tvs)        $ \ sig_tvs' _ ->
+    bindLocalsFVRn doc (map get_var vars)      $ \ ids ->
+    mapFvRn rn_var (vars `zip` ids)            `thenRn` \ (vars', fv_vars) ->
+
+    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 sig_tvs' vars' lhs' rhs' src_loc,
+             fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
+  where
+    doc = text "the transformation rule" <+> ptext rule_name
+    sig_tvs = extractRuleBndrsTyVars vars
+  
+    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) = rnHsType doc t      `thenRn` \ (t', fvs) ->
+                                  returnRn (RuleBndrSig id t', fvs)
+\end{code}

 
 

-       -- 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 (ClD (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc))
+%*********************************************************
+%*                                                     *
+\subsection{Type, class and iface sig declarations}
+%*                                                     *
+%*********************************************************
+
+@rnTyDecl@ uses the `global name function' to create a new type
+declaration in which local names have been replaced by their original
+names, reporting any unknown names.
+
+Renaming type variables is a pain. Because they now contain uniques,
+it is necessary to pass in an association list which maps a parsed
+tyvar to its @Name@ representation.
+In some cases (type signatures of values),
+it is even necessary to go over the type first
+in order to get the set of tyvars used by it, make an assoc list,
+and then go over it again to rename the tyvars!
+However, we can also do some scoping checks at the same time.
+
+\begin{code}
+rnTyClDecl (IfaceSig name ty id_infos loc)
+  = pushSrcLocRn loc $
+    lookupTopBndrRn name               `thenRn` \ name' ->
+    rnHsType doc_str ty                        `thenRn` \ (ty',fvs1) ->
+    mapFvRn rnIdInfo id_infos          `thenRn` \ (id_infos', fvs2) -> 
+    returnRn (IfaceSig name' ty' id_infos' loc, fvs1 `plusFV` fvs2)

   where
   where

-    cls_doc sty  = text "the declaration for class"    <+> ppr sty cname
-    sig_doc sty  = text "the signatures for class"     <+> ppr sty cname
-    meth_doc sty = text "the default-methods for class" <+> ppr sty cname
+    doc_str = text "the interface signature for" <+> quotes (ppr name)

 
 

-    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
+rnTyClDecl (TyData new_or_data context tycon tyvars condecls nconstrs derivings src_loc gen_name1 gen_name2)
+  = pushSrcLocRn src_loc $
+    lookupTopBndrRn tycon                      `thenRn` \ tycon' ->
+    bindTyVarsFVRn data_doc tyvars             $ \ tyvars' ->
+    rnContext data_doc context                         `thenRn` \ (context', cxt_fvs) ->
+    checkDupOrQualNames data_doc con_names     `thenRn_`
+    mapFvRn rnConDecl condecls                 `thenRn` \ (condecls', con_fvs) ->
+    lookupSysBinder gen_name1                  `thenRn` \ name1' ->
+    lookupSysBinder gen_name2                  `thenRn` \ name2' ->
+    rnDerivs derivings                         `thenRn` \ (derivings', deriv_fvs) ->
+    returnRn (TyData new_or_data context' tycon' tyvars' condecls' nconstrs
+                     derivings' src_loc name1' name2',
+             cxt_fvs `plusFV` con_fvs `plusFV` deriv_fvs)
+  where
+    data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
+    con_names = map conDeclName condecls

 
 

-    rn_op clas clas_tyvar sig@(ClassOpSig op maybe_dm ty locn)
-      = pushSrcLocRn locn $
-       lookupBndrRn op                         `thenRn` \ op_name ->
-       rnHsSigType (\sty -> ppr sty op) ty     `thenRn` \ new_ty  ->
+rnTyClDecl (TySynonym name tyvars ty src_loc)
+  = pushSrcLocRn src_loc $
+    doptRn Opt_GlasgowExts                     `thenRn` \ glaExts ->
+    lookupTopBndrRn name                       `thenRn` \ name' ->
+    bindTyVarsFVRn syn_doc tyvars              $ \ tyvars' ->
+    rnHsType syn_doc (unquantify glaExts ty)   `thenRn` \ (ty', ty_fvs) ->
+    returnRn (TySynonym name' tyvars' ty' src_loc, ty_fvs)
+  where
+    syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)

 
 

-               -- Make the default-method name
-       let
-           dm_occ = prefixOccName SLIT("$m") (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
-                   newGlobalName mod_name dm_occ (ifaceFlavour clas)   `thenRn` \ dm_name ->
-                   addOccurrenceName dm_name                           `thenRn_`
-                   returnRn (Just dm_name)
+       -- For H98 we do *not* universally quantify on the RHS of a synonym
+       -- Silently discard context... but the tyvars in the rest won't be in scope
+    unquantify glaExts (HsForAllTy Nothing ctxt ty) | glaExts = ty
+    unquantify glaExys ty                                    = ty

 
 

-           other -> returnRn Nothing
-       )                                       `thenRn` \ maybe_dm_name ->
+rnTyClDecl (ClassDecl context cname tyvars fds sigs mbinds names src_loc)
+  = pushSrcLocRn src_loc $

 
 

-               -- Checks.....
-       let
-           (ctxt, op_ty) = case new_ty of
-                               HsForAllTy tvs ctxt op_ty -> (ctxt, op_ty)
-                               other                     -> ([], new_ty)
-           ctxt_fvs  = extractCtxtTyNames ctxt
-           op_ty_fvs = extractHsTyNames op_ty          -- Includes tycons/classes but we
-                                                       -- don't care about that
-       in
-               -- Check that class tyvar appears in op_ty
-        checkRn (clas_tyvar `elemNameSet` op_ty_fvs)
-               (classTyVarNotInOpTyErr clas_tyvar sig)
-                                                        `thenRn_`
+    lookupTopBndrRn cname                      `thenRn` \ cname' ->

 
 

-       returnRn (ClassOpSig op_name maybe_dm_name new_ty locn)
-\end{code}
+       -- Deal with the implicit tycon and datacon name
+       -- They aren't in scope (because they aren't visible to the user)
+       -- and what we want to do is simply look them up in the cache;
+       -- we jolly well ought to get a 'hit' there!
+       -- So the 'Imported' part of this call is not relevant. 
+       -- Unclean; but since these two are the only place this happens
+       -- I can't work up the energy to do it more beautifully

 
 

+    mapRn lookupSysBinder names                `thenRn` \ names' ->

 
 

-%*********************************************************
-%*                                                     *
-\subsection{Instance declarations}
-%*                                                     *
-%*********************************************************
+       -- Tyvars scope over bindings and context
+    bindTyVarsFV2Rn cls_doc tyvars             ( \ clas_tyvar_names tyvars' ->

 
 

-\begin{code}
-rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc))
-  = pushSrcLocRn src_loc $
-    rnHsSigType (\sty -> text "an instance decl") inst_ty      `thenRn` \ inst_ty' ->
+       -- Check the superclasses
+    rnContext cls_doc context                  `thenRn` \ (context', cxt_fvs) ->

 
 

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

 
 

-       -- Rename the bindings
-       -- NB meth_names can be qualified!
-    checkDupNames meth_doc meth_names          `thenRn_`
-    rnMethodBinds mbinds                       `thenRn` \ mbinds' ->
-    mapRn rn_uprag uprags                      `thenRn` \ new_uprags ->
+       -- Check the signatures
+       -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
+    let
+       (op_sigs, non_op_sigs) = partition isClassOpSig sigs
+       sig_rdr_names_w_locs   = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
+    in
+    checkDupOrQualNames sig_doc sig_rdr_names_w_locs     `thenRn_` 
+    mapFvRn (rn_op cname' clas_tyvar_names fds') op_sigs  `thenRn` \ (sigs', sig_fvs) ->
+    let
+       binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
+    in
+    renameSigs (okClsDclSig binders) non_op_sigs         `thenRn` \ (non_ops', fix_fvs) ->

 
 

-    newDfunName 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
+       -- Check the methods
+       -- 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 
+    getLocalNameEnv                                    `thenRn` \ name_env ->
+    let
+       meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds
+       gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds,
+                                               not (tv `elemFM` name_env)]
+    in
+    checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
+    newLocalsRn mkLocalName gen_rdr_tyvars_w_locs      `thenRn` \ gen_tyvars ->
+    rnMethodBinds gen_tyvars mbinds                    `thenRn` \ (mbinds', meth_fvs) ->

 
 

-       -- 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 sty = text "the bindings in an instance declaration"
-    meth_names   = bagToList (collectMonoBinders 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.

 
 

-    rn_uprag (SpecSig op ty using locn)
-      = pushSrcLocRn src_loc $
-       lookupBndrRn op                         `thenRn` \ op_name ->
-       rnHsSigType (\sty -> ppr sty op) ty     `thenRn` \ new_ty ->
-       rn_using using                          `thenRn` \ new_using ->
-       returnRn (SpecSig op_name new_ty new_using locn)
+    returnRn (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') mbinds'
+                              names' src_loc,
+             sig_fvs   `plusFV`

 
 

-    rn_uprag (InlineSig op locn)
-      = pushSrcLocRn locn $
-       lookupBndrRn op                 `thenRn` \ op_name ->
-       returnRn (InlineSig op_name locn)
+             fix_fvs   `plusFV`
+             cxt_fvs   `plusFV`
+             fds_fvs   `plusFV`
+             meth_fvs
+            )
+    )
+  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

 
 

-    rn_uprag (MagicUnfoldingSig op str locn)
+    rn_op clas clas_tyvars clas_fds sig@(ClassOpSig op maybe_dm_stuff ty locn)

       = pushSrcLocRn locn $
       = pushSrcLocRn locn $

-       lookupBndrRn op                 `thenRn` \ op_name ->
-       returnRn (MagicUnfoldingSig op_name str locn)
+       lookupTopBndrRn op                      `thenRn` \ op_name ->

 
 

-    rn_using Nothing  = returnRn Nothing
-    rn_using (Just v) = lookupOccRn v  `thenRn` \ new_v ->
-                       returnRn (Just new_v)
-\end{code}
+               -- 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` oclose clas_fds op_ty_fvs)
+                        (classTyVarNotInOpTyErr clas_tyvar sig)
+       in
+        mapRn_ check_in_op_ty clas_tyvars               `thenRn_`

 
 

-%*********************************************************
-%*                                                     *
-\subsection{Default declarations}
-%*                                                     *
-%*********************************************************
+               -- Make the default-method name
+       (case maybe_dm_stuff of 
+           Nothing -> returnRn (Nothing, emptyFVs)             -- Source-file class decl

 
 

-\begin{code}
-rnDecl (DefD (DefaultDecl tys src_loc))
-  = pushSrcLocRn src_loc $
-    mapRn rnHsType tys                         `thenRn` \ tys' ->
-    lookupImplicitOccRn numClass_RDR   `thenRn_` 
-    returnRn (DefD (DefaultDecl tys' src_loc))
+           Just (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 (Just (DefMeth dm_name), unitFV 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
+           Just GenDefMeth
+               -> returnRn (Just GenDefMeth, emptyFVs)
+           Just NoDefMeth
+               -> returnRn (Just NoDefMeth, emptyFVs)
+       )                                               `thenRn` \ (maybe_dm_stuff', dm_fvs) ->
+
+       returnRn (ClassOpSig op_name maybe_dm_stuff' new_ty locn, op_ty_fvs `plusFV` dm_fvs)

 \end{code}
 
 \end{code}
 

+

 %*********************************************************
 %*                                                     *
 \subsection{Support code for type/data declarations}
 %*********************************************************
 %*                                                     *
 \subsection{Support code for type/data declarations}

@@ -306,77 +432,74 @@ rnDecl (DefD (DefaultDecl tys src_loc))
 %*********************************************************
 
 \begin{code}
 %*********************************************************
 
 \begin{code}

-rnDerivs :: Maybe [RdrName] -> RnMS s (Maybe [Name])
+rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name], FreeVars)

 
 rnDerivs Nothing -- derivs not specified
 
 rnDerivs Nothing -- derivs not specified

-  = lookupImplicitOccRn evalClass_RDR          `thenRn_`
-    returnRn Nothing
+  = returnRn (Nothing, emptyFVs)

 
 

-rnDerivs (Just ds)
-  = lookupImplicitOccRn evalClass_RDR          `thenRn_`
-    mapRn rn_deriv ds `thenRn` \ derivs ->
-    returnRn (Just derivs)
+rnDerivs (Just clss)
+  = mapRn do_one clss  `thenRn` \ clss' ->
+    returnRn (Just clss', mkNameSet clss')

   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
+    do_one cls = lookupOccRn cls       `thenRn` \ clas_name ->
+                checkRn (getUnique clas_name `elem` derivableClassKeys)
+                        (derivingNonStdClassErr clas_name)     `thenRn_`
+                returnRn clas_name

 \end{code}
 
 \begin{code}
 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
 \end{code}
 
 \begin{code}
 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)

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

 
 

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

   = pushSrcLocRn locn $
   = pushSrcLocRn locn $

-    checkConName name                  `thenRn_` 
-    lookupBndrRn name                  `thenRn` \ new_name ->
-    rnConDetails name locn details     `thenRn` \ new_details -> 
-    rnContext cxt                      `thenRn` \ new_context ->
-    returnRn (ConDecl new_name new_context new_details locn)
-
-rnConDetails con locn (VanillaCon tys)
-  = mapRn rnBangTy tys         `thenRn` \ new_tys  ->
-    returnRn (VanillaCon new_tys)
-
-rnConDetails con locn (InfixCon ty1 ty2)
-  = rnBangTy ty1               `thenRn` \ new_ty1 ->
-    rnBangTy ty2               `thenRn` \ new_ty2 ->
-    returnRn (InfixCon new_ty1 new_ty2)
-
-rnConDetails con locn (NewCon ty)
-  = rnHsType ty                        `thenRn` \ new_ty  ->
-    returnRn (NewCon new_ty)
-
-rnConDetails con locn (RecCon fields)
-  = checkDupOrQualNames fld_doc field_names    `thenRn_`
-    mapRn rnField fields                       `thenRn` \ new_fields ->
-    returnRn (RecCon new_fields)
+    checkConName name          `thenRn_` 
+    lookupTopBndrRn name       `thenRn` \ new_name ->
+
+    lookupSysBinder wkr                `thenRn` \ new_wkr ->
+       -- See comments with ClassDecl
+
+    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_wkr new_tyvars new_context new_details locn,
+             cxt_fvs `plusFV` det_fvs)
+  where
+    doc = text "the definition of data constructor" <+> quotes (ppr name)
+
+rnConDetails doc locn (VanillaCon tys)
+  = mapFvRn (rnBangTy doc) tys `thenRn` \ (new_tys, fvs)  ->
+    returnRn (VanillaCon new_tys, fvs)
+
+rnConDetails doc locn (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 (RecCon fields)
+  = checkDupOrQualNames doc field_names        `thenRn_`
+    mapFvRn (rnField doc) fields       `thenRn` \ (new_fields, fvs) ->
+    returnRn (RecCon new_fields, fvs)

   where
   where

-    fld_doc sty = text "the fields of constructor" <> ppr sty con

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

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

 
 

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

 
 

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

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

@@ -389,7 +512,7 @@ rnBangTy (Unbanged ty)
 -- from interface files, which always print in prefix form
 
 checkConName name
 -- from interface files, which always print in prefix form
 
 checkConName name

-  = checkRn (isLexCon (occNameString (rdrNameOcc name)))
+  = checkRn (isRdrDataCon name)

            (badDataCon name)
 \end{code}
 
            (badDataCon name)
 \end{code}
 

@@ -401,342 +524,419 @@ checkConName name
 %*********************************************************
 
 \begin{code}
 %*********************************************************
 
 \begin{code}

-rnHsSigType :: (PprStyle -> Doc) -> RdrNameHsType -> RnMS s RenamedHsType 
+rnHsSigType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)

        -- rnHsSigType is used for source-language type signatures,
        -- which use *implicit* universal quantification.
        -- rnHsSigType is used for source-language type signatures,
        -- which use *implicit* universal quantification.

-
--- 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.
-
-rnHsSigType doc_str full_ty@(HsPreForAllTy ctxt ty)    -- From source code (no kinds on tyvars)
-  = getNameEnv         `thenRn` \ name_env ->
+rnHsSigType doc_str ty
+  = rnHsType (text "the type signature for" <+> doc_str) ty
+    
+---------------------------------------
+rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
+
+rnHsType doc (HsForAllTy Nothing ctxt ty)
+       -- Implicit quantifiction in source code (no kinds on tyvars)
+       -- Given the signature  C => T  we universally quantify 
+       -- over FV(T) \ {in-scope-tyvars} 
+  = getLocalNameEnv            `thenRn` \ name_env ->

     let
     let

-       mentioned_tyvars = extractHsTyVars ty
-       forall_tyvars    = filter (not . in_scope) mentioned_tyvars
-       in_scope tv      = maybeToBool (lookupFM name_env tv)
-
-       constrained_tyvars            = nub (concat (map (extractHsTyVars . snd) ctxt))
-       constrained_and_in_scope      = filter in_scope constrained_tyvars
-       constrained_and_not_mentioned = filter (not . (`elem` mentioned_tyvars)) constrained_tyvars
-
-       -- Zap the context if there's a problem, to avoid duplicate error message.
-       ctxt' | null constrained_and_in_scope && null constrained_and_not_mentioned = ctxt
-             | otherwise = []
+       mentioned_in_tau  = extractHsTyRdrTyVars ty
+       mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
+       mentioned         = nub (mentioned_in_tau ++ mentioned_in_ctxt)
+       forall_tyvars     = filter (not . (`elemFM` name_env)) mentioned

     in
     in

-    checkRn (null constrained_and_in_scope)
-           (ctxtErr1 sig_doc constrained_and_in_scope) `thenRn_`
-    checkRn (null constrained_and_not_mentioned)
-           (ctxtErr2 sig_doc constrained_and_not_mentioned ty) `thenRn_`
-
-    (bindTyVarsRn sig_doc (map UserTyVar forall_tyvars)        $ \ new_tyvars ->
-     rnContext ctxt'                                   `thenRn` \ new_ctxt ->
-     rnHsType ty                                       `thenRn` \ new_ty ->
-     returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
-    )
-  where
-    sig_doc sty = text "the type signature for" <+> doc_str sty
-                            
-
-rnHsSigType doc_str other_ty = rnHsType other_ty
-
-rnHsType :: RdrNameHsType -> RnMS s RenamedHsType
-rnHsType (HsForAllTy tvs ctxt ty)              -- From an interface file (tyvars may be kinded)
-  = rn_poly_help tvs ctxt ty
-
-rnHsType full_ty@(HsPreForAllTy ctxt ty)       -- A (context => ty) embedded in a type.
-                                               -- Universally quantify over tyvars in context
-  = getNameEnv         `thenRn` \ name_env ->
-    let
-       forall_tyvars = foldr unionLists [] (map (extractHsTyVars . snd) ctxt)
+    rnForAll doc (map UserTyVar forall_tyvars) ctxt ty
+
+rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
+       -- Explicit quantification.
+       -- Check that the forall'd tyvars are actually 
+       -- mentioned in the type, and produce a warning if not
+  = let
+       mentioned_in_tau                = extractHsTyRdrTyVars tau
+       mentioned_in_ctxt               = extractHsCtxtRdrTyVars ctxt
+       mentioned                       = nub (mentioned_in_tau ++ mentioned_in_ctxt)
+       forall_tyvar_names              = hsTyVarNames forall_tyvars
+
+       -- Explicitly quantified but not mentioned in ctxt or tau
+       warn_guys                       = filter (`notElem` mentioned) forall_tyvar_names

     in
     in

-    rn_poly_help (map UserTyVar forall_tyvars) ctxt ty
+    mapRn_ (forAllWarn doc tau) warn_guys      `thenRn_`
+    rnForAll doc forall_tyvars ctxt tau

 
 

-rnHsType (MonoTyVar tyvar)
+rnHsType doc (HsTyVar tyvar)

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

-    returnRn (MonoTyVar tyvar')
-
-rnHsType (MonoFunTy ty1 ty2)
-  = andRn MonoFunTy (rnHsType ty1) (rnHsType ty2)
-
-rnHsType (MonoListTy _ ty)
-  = lookupImplicitOccRn listType_RDR           `thenRn` \ tycon_name ->
-    rnHsType ty                                        `thenRn` \ ty' ->
-    returnRn (MonoListTy tycon_name ty')
-
-rnHsType (MonoTupleTy _ tys)
-  = lookupImplicitOccRn (tupleType_RDR (length tys))   `thenRn` \ tycon_name ->
-    mapRn rnHsType tys                                 `thenRn` \ tys' ->
-    returnRn (MonoTupleTy tycon_name tys')
-
-rnHsType (MonoTyApp ty1 ty2)
-  = rnHsType ty1               `thenRn` \ ty1' ->
-    rnHsType ty2               `thenRn` \ ty2' ->
-    returnRn (MonoTyApp ty1' ty2')
-
-rnHsType (MonoDictTy clas ty)
-  = lookupOccRn clas           `thenRn` \ clas' ->
-    rnHsType ty                        `thenRn` \ ty' ->
-    returnRn (MonoDictTy clas' ty')
-
-rn_poly_help :: [HsTyVar RdrName]              -- Universally quantified tyvars
-            -> RdrNameContext
-            -> RdrNameHsType
-            -> RnMS s RenamedHsType
-rn_poly_help tyvars ctxt ty
-  = bindTyVarsRn sig_doc tyvars                                $ \ new_tyvars ->
-    rnContext ctxt                                     `thenRn` \ new_ctxt ->
-    rnHsType ty                                                `thenRn` \ new_ty ->
-    returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
+    returnRn (HsTyVar tyvar', unitFV tyvar')
+
+rnHsType doc (HsOpTy ty1 opname ty2)
+  = lookupOccRn opname `thenRn` \ name' ->
+    rnHsType doc ty1   `thenRn` \ (ty1', fvs1) ->
+    rnHsType doc ty2   `thenRn` \ (ty2',fvs2) -> 
+    returnRn (HsOpTy ty1' name' ty2', fvs1 `plusFV` fvs2 `addOneFV` name')
+
+rnHsType doc (HsNumTy i)
+  | i == 1    = returnRn (HsNumTy i, emptyFVs)
+  | otherwise = failWithRn (HsNumTy i, emptyFVs)
+                          (ptext SLIT("Only unit numeric type pattern is valid"))
+
+rnHsType doc (HsFunTy ty1 ty2)
+  = rnHsType doc ty1   `thenRn` \ (ty1', fvs1) ->
+       -- Might find a for-all as the arg of a function type
+    rnHsType doc ty2   `thenRn` \ (ty2', fvs2) ->
+       -- Or as the result.  This happens when reading Prelude.hi
+       -- when we find return :: forall m. Monad m -> forall a. a -> m a
+    returnRn (HsFunTy ty1' ty2', fvs1 `plusFV` fvs2)
+
+rnHsType doc (HsListTy ty)
+  = rnHsType doc ty                            `thenRn` \ (ty', fvs) ->
+    returnRn (HsListTy ty', fvs `addOneFV` listTyCon_name)
+
+-- Unboxed tuples are allowed to have poly-typed arguments.  These
+-- sometimes crop up as a result of CPR worker-wrappering dictionaries.
+rnHsType doc (HsTupleTy (HsTupCon _ boxity) tys)
+       -- Don't do lookupOccRn, because this is built-in syntax
+       -- so it doesn't need to be in scope
+  = mapFvRn (rnHsType doc) tys         `thenRn` \ (tys', fvs) ->
+    returnRn (HsTupleTy (HsTupCon n' boxity) tys', fvs `addOneFV` n')

   where
   where

-    sig_doc sty = text "a nested for-all type"
+    n' = tupleTyCon_name boxity (length tys)
+  
+
+rnHsType doc (HsAppTy ty1 ty2)
+  = rnHsType doc ty1           `thenRn` \ (ty1', fvs1) ->
+    rnHsType doc ty2           `thenRn` \ (ty2', fvs2) ->
+    returnRn (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2)
+
+rnHsType doc (HsPredTy pred)
+  = rnPred doc pred    `thenRn` \ (pred', fvs) ->
+    returnRn (HsPredTy pred', fvs)
+
+rnHsType doc (HsUsgForAllTy uv_rdr ty)
+  = bindUVarRn doc uv_rdr $ \ uv_name ->
+    rnHsType doc ty       `thenRn` \ (ty', fvs) ->
+    returnRn (HsUsgForAllTy uv_name ty',
+              fvs )
+
+rnHsType doc (HsUsgTy usg ty)
+  = newUsg usg                      `thenRn` \ (usg', usg_fvs) ->
+    rnHsType doc ty                 `thenRn` \ (ty', ty_fvs) ->
+       -- A for-all can occur inside a usage annotation
+    returnRn (HsUsgTy usg' ty',
+              usg_fvs `plusFV` ty_fvs)
+  where
+    newUsg usg = case usg of
+                   HsUsOnce       -> returnRn (HsUsOnce, emptyFVs)
+                   HsUsMany       -> returnRn (HsUsMany, emptyFVs)
+                   HsUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name ->
+                                       returnRn (HsUsVar uv_name, emptyFVs)
+
+rnHsTypes doc tys = mapFvRn (rnHsType doc) tys

 \end{code}
 
 \end{code}
 

+\begin{code}
+-- We use lookupOcc here because this is interface file only stuff
+-- and we need the workers...
+rnHsTupCon (HsTupCon n boxity)
+  = lookupOccRn n      `thenRn` \ n' ->
+    returnRn (HsTupCon n' boxity, unitFV n')
+
+rnHsTupConWkr (HsTupCon n boxity)
+       -- Tuple construtors are for the *worker* of the tuple
+       -- Going direct saves needless messing about 
+  = lookupOccRn (mkRdrNameWkr n)       `thenRn` \ n' ->
+    returnRn (HsTupCon n' boxity, unitFV n')
+\end{code}

 
 \begin{code}
 
 \begin{code}

-rnContext :: RdrNameContext -> RnMS s RenamedContext
+rnForAll doc forall_tyvars ctxt ty
+  = bindTyVarsFVRn doc forall_tyvars   $ \ new_tyvars ->
+    rnContext doc ctxt                 `thenRn` \ (new_ctxt, cxt_fvs) ->
+    rnHsType doc ty                    `thenRn` \ (new_ty, ty_fvs) ->
+    returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty,
+             cxt_fvs `plusFV` ty_fvs)
+\end{code}

 
 

-rnContext  ctxt
-  = mapRn rn_ctxt ctxt `thenRn` \ result ->
+\begin{code}
+rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
+rnContext doc ctxt
+  = mapAndUnzipRn rn_pred ctxt         `thenRn` \ (theta, fvs_s) ->

     let
     let

-       (_, dup_asserts) = removeDups cmp_assert result
-       (alls, theta)    = partition (\(c,_) -> c == allClass_NAME) result
-       non_tyvar_alls   = [(c,t) | (c,t) <- alls, not (is_tyvar t)]
+       (_, dups) = removeDupsEq theta
+               -- We only have equality, not ordering

     in
     in

-

        -- Check for duplicate assertions
        -- If this isn't an error, then it ought to be:
        -- Check for duplicate assertions
        -- If this isn't an error, then it ought to be:

-    mapRn (addWarnRn . dupClassAssertWarn theta) dup_asserts `thenRn_`
-
-       -- Check for All constraining a non-type-variable
-    mapRn (addWarnRn . allOfNonTyVar) non_tyvar_alls   `thenRn_`
-    
-       -- Done.  Return a theta omitting all the "All" constraints.
-       -- They have done done their work by ensuring that we universally
-       -- quantify over their tyvar.
-    returnRn theta
+    mapRn (addWarnRn . dupClassAssertWarn theta) dups          `thenRn_`
+    returnRn (theta, plusFVs fvs_s)

   where
   where

-    rn_ctxt (clas, ty)
-      =                -- Mini hack here.  If the class is our pseudo-class "All",
-               -- then we don't want to record it as an occurrence, otherwise
-               -- we try to slurp it in later and it doesn't really exist at all.
-               -- Easiest thing is simply not to put it in the occurrence set.
-       lookupBndrRn clas       `thenRn` \ clas_name ->
-       (if clas_name /= allClass_NAME then
-               addOccurrenceName clas_name
-        else
-               returnRn clas_name
-       )                       `thenRn_`
-       rnHsType ty             `thenRn` \ ty' ->
-       returnRn (clas_name, ty')
-
-    cmp_assert (c1,ty1) (c2,ty2)
-      = (c1 `cmp` c2) `thenCmp` (cmpHsType cmp ty1 ty2)
-
-    is_tyvar (MonoTyVar _) = True
-    is_tyvar other         = False
+       --Someone discovered that @CCallable@ and @CReturnable@
+       -- could be used in contexts such as:
+       --      foo :: CCallable a => a -> PrimIO Int
+       -- Doing this utterly wrecks the whole point of introducing these
+       -- classes so we specifically check that this isn't being done.
+    rn_pred pred = rnPred doc pred                             `thenRn` \ (pred', fvs)->
+                  checkRn (not (bad_pred pred'))
+                          (naughtyCCallContextErr pred')       `thenRn_`
+                  returnRn (pred', fvs)
+
+    bad_pred (HsPClass clas _) = getUnique clas `elem` cCallishClassKeys
+    bad_pred other            = False
+
+
+rnPred doc (HsPClass clas tys)
+  = lookupOccRn clas           `thenRn` \ clas_name ->
+    rnHsTypes doc tys          `thenRn` \ (tys', fvs) ->
+    returnRn (HsPClass clas_name tys', fvs `addOneFV` clas_name)
+
+rnPred doc (HsPIParam n ty)
+  = newIPName n                        `thenRn` \ name ->
+    rnHsType doc ty            `thenRn` \ (ty', fvs) ->
+    returnRn (HsPIParam name ty', fvs)

 \end{code}
 
 \end{code}
 

+\begin{code}
+rnFds :: SDoc -> [FunDep RdrName] -> RnMS ([FunDep Name], FreeVars)
+
+rnFds doc fds
+  = mapAndUnzipRn rn_fds fds           `thenRn` \ (theta, fvs_s) ->
+    returnRn (theta, plusFVs fvs_s)
+  where
+    rn_fds (tys1, tys2)
+      =        rnHsTyVars doc tys1             `thenRn` \ (tys1', fvs1) ->
+       rnHsTyVars doc tys2             `thenRn` \ (tys2', fvs2) ->
+       returnRn ((tys1', tys2'), fvs1 `plusFV` fvs2)
+
+rnHsTyVars doc tvs = mapFvRn (rnHsTyvar doc) tvs
+rnHsTyvar doc tyvar
+  = lookupOccRn tyvar          `thenRn` \ tyvar' ->
+    returnRn (tyvar', unitFV tyvar')
+\end{code}

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

-%*                                                     *
+%*                                                      *

 \subsection{IdInfo}
 \subsection{IdInfo}

-%*                                                     *
+%*                                                      *

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

-rnIdInfo (HsStrictness strict)
-  = rnStrict strict    `thenRn` \ strict' ->
-    returnRn (HsStrictness strict')
-
-rnIdInfo (HsUnfold inline expr)        = rnCoreExpr expr       `thenRn` \ expr' ->
-                                 returnRn (HsUnfold inline expr')
-rnIdInfo (HsArity arity)       = returnRn (HsArity arity)
-rnIdInfo (HsUpdate update)     = returnRn (HsUpdate update)
-rnIdInfo (HsFBType fb)         = returnRn (HsFBType fb)
-rnIdInfo (HsArgUsage au)       = returnRn (HsArgUsage au)
-
-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 (HsStrictness str) = returnRn (HsStrictness str, emptyFVs)
+
+rnIdInfo (HsWorker worker)

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

-    mapRn lookupOccRn cons             `thenRn_` 
-    returnRn (HsStrictnessInfo demands (Just (worker',[])))
+    returnRn (HsWorker worker', unitFV worker')
+
+rnIdInfo (HsUnfold inline expr)        = rnCoreExpr expr `thenRn` \ (expr', fvs) ->
+                                 returnRn (HsUnfold inline expr', fvs)
+rnIdInfo (HsArity arity)       = returnRn (HsArity arity, emptyFVs)
+rnIdInfo HsNoCafRefs           = returnRn (HsNoCafRefs, emptyFVs)
+rnIdInfo HsCprInfo             = returnRn (HsCprInfo, emptyFVs)

 
 

--- Boring, but necessary for the type checker.
-rnStrict (HsStrictnessInfo demands Nothing) = returnRn (HsStrictnessInfo demands Nothing)
-rnStrict HsBottom                        = returnRn HsBottom

 \end{code}
 
 \end{code}
 

-UfCore expressions.
+@UfCore@ expressions.

 
 \begin{code}
 
 \begin{code}

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

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

-    returnRn (UfVar v')
-
-rnCoreExpr (UfLit lit) = returnRn (UfLit lit)
+    returnRn (UfVar v', unitFV v')

 
 

-rnCoreExpr (UfCon con args) 
-  = lookupOccRn con            `thenRn` \ con' ->
-    mapRn rnCoreArg args       `thenRn` \ args' ->
-    returnRn (UfCon con' args')
-
-rnCoreExpr (UfPrim prim args) 
-  = rnCorePrim prim            `thenRn` \ prim' ->
-    mapRn rnCoreArg args       `thenRn` \ args' ->
-    returnRn (UfPrim prim' args')
+rnCoreExpr (UfLit l)
+  = returnRn (UfLit l, emptyFVs)

 
 

-rnCoreExpr (UfApp fun arg)
-  = rnCoreExpr fun             `thenRn` \ fun' ->
-    rnCoreArg arg              `thenRn` \ arg' ->
-    returnRn (UfApp fun' arg')
+rnCoreExpr (UfLitLit l ty)
+  = rnHsType (text "litlit") ty        `thenRn` \ (ty', fvs) ->
+    returnRn (UfLitLit l ty', fvs)

 
 

-rnCoreExpr (UfCase scrut alts) 
-  = rnCoreExpr scrut           `thenRn` \ scrut' ->
-    rnCoreAlts alts            `thenRn` \ alts' ->
-    returnRn (UfCase scrut' alts')
+rnCoreExpr (UfCCall cc ty)
+  = rnHsType (text "ccall") ty `thenRn` \ (ty', fvs) ->
+    returnRn (UfCCall cc ty', fvs)

 
 

-rnCoreExpr (UfSCC cc expr) 
-  = rnCoreExpr expr            `thenRn` \ expr' ->
-    returnRn  (UfSCC cc expr') 
+rnCoreExpr (UfTuple con args) 
+  = rnHsTupConWkr con                  `thenRn` \ (con', fvs1) ->
+    mapFvRn rnCoreExpr args            `thenRn` \ (args', fvs2) ->
+    returnRn (UfTuple con' args', fvs1 `plusFV` fvs2)

 
 

-rnCoreExpr(UfCoerce coercion ty body)
-  = rnCoercion coercion                `thenRn` \ coercion' ->
-    rnHsType ty                        `thenRn` \ ty' ->
-    rnCoreExpr body            `thenRn` \ body' ->
-    returnRn (UfCoerce coercion' ty' body')
+rnCoreExpr (UfApp fun arg)
+  = rnCoreExpr fun             `thenRn` \ (fun', fv1) ->
+    rnCoreExpr arg             `thenRn` \ (arg', fv2) ->
+    returnRn (UfApp fun' arg', fv1 `plusFV` fv2)
+
+rnCoreExpr (UfCase scrut bndr alts)
+  = rnCoreExpr scrut                   `thenRn` \ (scrut', fvs1) ->
+    bindCoreLocalFVRn bndr             ( \ bndr' ->
+       mapFvRn rnCoreAlt alts          `thenRn` \ (alts', fvs2) ->
+       returnRn (UfCase scrut' bndr' alts', fvs2)
+    )                                          `thenRn` \ (case', fvs3) ->
+    returnRn (case', fvs1 `plusFV` fvs3)
+
+rnCoreExpr (UfNote note expr) 
+  = rnNote note                        `thenRn` \ (note', fvs1) ->
+    rnCoreExpr expr            `thenRn` \ (expr', fvs2) ->
+    returnRn  (UfNote note' expr', fvs1 `plusFV` fvs2) 

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

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

 
 rnCoreExpr (UfLet (UfNonRec bndr rhs) 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 rhs             `thenRn` \ (rhs', fvs1) ->
+    rnCoreBndr bndr            ( \ bndr' ->
+       rnCoreExpr body         `thenRn` \ (body', fvs2) ->
+       returnRn (UfLet (UfNonRec bndr' rhs') body', fvs2)
+    )                          `thenRn` \ (result, fvs3) ->
+    returnRn (result, fvs1 `plusFV` fvs3)

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

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

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

-  = rnHsType ty                        `thenRn` \ ty' ->
-    bindLocalsRn "unfolding value" [name] $ \ [name'] ->
-    thing_inside (UfValBinder name' ty')
+  = rnHsType doc ty            `thenRn` \ (ty', fvs1) ->
+    bindCoreLocalFVRn name     ( \ name' ->
+           thing_inside (UfValBinder name' ty')
+    )                          `thenRn` \ (result, fvs2) ->
+    returnRn (result, fvs1 `plusFV` fvs2)
+  where
+    doc = text "unfolding id"

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

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

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

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

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

-rnCoreArg (UfVarArg v)  = lookupOccRn v        `thenRn` \ v' -> returnRn (UfVarArg v')
-rnCoreArg (UfUsageArg u) = lookupOccRn u       `thenRn` \ u' -> returnRn (UfUsageArg u')
-rnCoreArg (UfTyArg ty)  = rnHsType ty                  `thenRn` \ ty' -> returnRn (UfTyArg ty')
-rnCoreArg (UfLitArg lit) = returnRn (UfLitArg lit)
-
-rnCoreAlts (UfAlgAlts alts deflt)
-  = mapRn rn_alt alts          `thenRn` \ alts' ->
-    rnCoreDefault deflt                `thenRn` \ deflt' ->
-    returnRn (UfAlgAlts alts' deflt')
-  where
-    rn_alt (con, bndrs, rhs) = lookupOccRn con                 `thenRn` \ con' ->
-                               bindLocalsRn "unfolding alt" bndrs      $ \ bndrs' ->
-                               rnCoreExpr rhs                          `thenRn` \ rhs' ->
-                               returnRn (con', bndrs', rhs')
-
-rnCoreAlts (UfPrimAlts alts deflt)
-  = mapRn rn_alt alts          `thenRn` \ alts' ->
-    rnCoreDefault deflt                `thenRn` \ deflt' ->
-    returnRn (UfPrimAlts alts' deflt')
-  where
-    rn_alt (lit, rhs) =        rnCoreExpr rhs          `thenRn` \ rhs' ->
-                       returnRn (lit, rhs')
+rnCoreAlt (con, bndrs, rhs)
+  = rnUfCon con bndrs                  `thenRn` \ (con', fvs1) ->
+    bindCoreLocalsFVRn bndrs           ( \ bndrs' ->
+       rnCoreExpr rhs                  `thenRn` \ (rhs', fvs2) ->
+       returnRn ((con', bndrs', rhs'), fvs2)
+    )                                  `thenRn` \ (result, fvs3) ->
+    returnRn (result, fvs1 `plusFV` fvs3)
+
+rnNote (UfCoerce ty)
+  = rnHsType (text "unfolding coerce") ty      `thenRn` \ (ty', fvs) ->
+    returnRn (UfCoerce ty', fvs)
+
+rnNote (UfSCC cc)   = returnRn (UfSCC cc, emptyFVs)
+rnNote UfInlineCall = returnRn (UfInlineCall, emptyFVs)
+rnNote UfInlineMe   = returnRn (UfInlineMe, emptyFVs)
+

 
 

-rnCoreDefault UfNoDefault = returnRn UfNoDefault
-rnCoreDefault (UfBindDefault bndr rhs) = bindLocalsRn "unfolding default" [bndr]       $ \ [bndr'] ->
-                                        rnCoreExpr rhs                                 `thenRn` \ rhs' ->
-                                        returnRn (UfBindDefault bndr' rhs')
+rnUfCon UfDefault _
+  = returnRn (UfDefault, emptyFVs)

 
 

-rnCoercion (UfIn  n) = lookupOccRn n `thenRn` \ n' -> returnRn (UfIn  n')
-rnCoercion (UfOut n) = lookupOccRn n `thenRn` \ n' -> returnRn (UfOut n')
+rnUfCon (UfTupleAlt tup_con) bndrs
+  = rnHsTupCon tup_con                 `thenRn` \ (HsTupCon con' _, fvs) -> 
+    returnRn (UfDataAlt con', fvs)
+       -- Makes the type checker a little easier

 
 

-rnCorePrim (UfOtherOp op) 
-  = lookupOccRn op     `thenRn` \ op' ->
-    returnRn (UfOtherOp op')
+rnUfCon (UfDataAlt con) _
+  = lookupOccRn con            `thenRn` \ con' ->
+    returnRn (UfDataAlt con', unitFV con')
+
+rnUfCon (UfLitAlt lit) _
+  = returnRn (UfLitAlt lit, emptyFVs)

 
 

-rnCorePrim (UfCCallOp str casm gc arg_tys res_ty)
-  = mapRn rnHsType arg_tys     `thenRn` \ arg_tys' ->
-    rnHsType res_ty            `thenRn` \ res_ty' ->
-    returnRn (UfCCallOp str casm gc arg_tys' res_ty')
+rnUfCon (UfLitLitAlt lit ty) _
+  = rnHsType (text "litlit") ty                `thenRn` \ (ty', fvs) ->
+    returnRn (UfLitLitAlt lit ty', fvs)

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

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

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

-\begin{code}
-derivingNonStdClassErr clas sty
-  = hsep [ptext SLIT("non-standard class"), ppr sty clas, ptext SLIT("in deriving clause")]
+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.

 
 

-classTyVarNotInOpTyErr clas_tyvar sig sty
-  = hang (hsep [ptext SLIT("Class type variable"), 
-                      ppr sty clas_tyvar, 
-                      ptext SLIT("does not appear in method signature")])
-        4 (ppr sty sig)
-
-dupClassAssertWarn ctxt ((clas,ty) : dups) sty
-  = sep [hsep [ptext SLIT("Duplicated class assertion"), 
-              pprQuote sty $ \ sty -> ppr sty clas <+> ppr sty ty,
-              ptext SLIT("in context:")],
-        nest 4 (pprQuote sty $ \ sty -> pprContext sty ctxt)]
+\begin{code}
+validRuleLhs foralls lhs
+  = check lhs
+  where
+    check (HsApp e1 e2)                  = check e1
+    check (HsVar v) | v `notElem` foralls = True
+    check other                                  = False
+\end{code}

 
 

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

 
 

-allOfNonTyVar ty sty
-  = hsep [ptext SLIT("`All' applied to a non-type variable"), ppr sty ty]
+%*********************************************************
+%*                                                      *
+\subsection{Errors}
+%*                                                      *
+%*********************************************************

 
 

-ctxtErr1 doc tyvars sty
-  = hsep [ptext SLIT("Context constrains in-scope type variable(s)"), 
-         hsep (punctuate comma (map (ppr sty) tyvars))]
-    $$
-    nest 4 (ptext SLIT("in") <+> doc sty)
+\begin{code}
+derivingNonStdClassErr clas
+  = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]

 
 

-ctxtErr2 doc tyvars ty sty
-  = (ptext SLIT("Context constrains type variable(s)")
-       <+> hsep (punctuate comma (map (ppr sty) tyvars)))
+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)
+
+badDataCon name
+   = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
+
+forAllWarn doc ty tyvar
+  = doptRn Opt_WarnUnusedMatches `thenRn` \ warn_unused -> case () of
+    () | not warn_unused -> returnRn ()
+       | otherwise
+       -> getModeRn            `thenRn` \ mode ->
+          case mode of {
+#ifndef DEBUG
+            InterfaceMode -> returnRn () ; -- Don't warn of unused tyvars in interface files
+                                           -- unless DEBUG is on, in which case it is slightly
+                                           -- informative.  They can arise from mkRhsTyLam,
+#endif                                     -- leading to (say)         f :: forall a b. [b] -> [b]
+            other ->
+               addWarnRn (
+                  sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
+                  nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
+                  $$
+                  (ptext SLIT("In") <+> doc)
+                )
+          }
+
+badRuleLhsErr name lhs
+  = sep [ptext SLIT("Rule") <+> ptext name <> colon,
+        nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]

     $$
     $$

-    nest 4 (vcat [ptext SLIT("that do not appear in") <+> ppr sty ty,
-                 ptext SLIT("in") <+> doc sty])
+    ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
+
+badRuleVar name var
+  = sep [ptext SLIT("Rule") <+> ptext name <> colon,
+        ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+> 
+               ptext SLIT("does not appear on left hand side")]
+
+badExtName :: ExtName -> Message
+badExtName ext_nm
+  = sep [quotes (ppr ext_nm) <+> ptext SLIT("is not a valid C identifier")]
+
+dupClassAssertWarn ctxt (assertion : dups)
+  = sep [hsep [ptext SLIT("Duplicate class assertion"), 
+              quotes (ppr assertion),
+              ptext SLIT("in the context:")],
+        nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
+
+naughtyCCallContextErr (HsPClass clas _)
+  = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas), 
+        ptext SLIT("in a context")]

 \end{code}
 \end{code}