projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[project @ 2000-02-10 18:39:51 by lewie]
[ghc-hetmet.git] / ghc / compiler / rename / RnSource.lhs
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 4d774dd..26e6dee 100644 (file)
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -1,62 +1,74 @@
 %
 %
-% (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}
-module RnSource ( rnDecl, rnHsType, rnHsSigType ) where
+module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType, rnHsPolyType ) where
 
 #include "HsVersions.h"
 
 import RnExpr
 import HsSyn
 
 #include "HsVersions.h"
 
 import RnExpr
 import HsSyn
-import HsDecls         ( HsIdInfo(..), HsStrictnessInfo(..) )
 import HsPragmas
 import HsPragmas
-import HsTypes         ( getTyVarName, pprClassAssertion, cmpHsTypes )
-import RdrHsSyn
+import HsTypes         ( getTyVarName, pprHsPred, cmpHsTypes )
+import RdrName         ( RdrName, isRdrDataCon, rdrNameOcc, isRdrTyVar )
+import RdrHsSyn                ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
+                         extractRuleBndrsTyVars, extractHsTyRdrTyVars, extractHsTysRdrTyVars
+                       )
 import RnHsSyn
 import HsCore
 import RnHsSyn
 import HsCore
-import CmdLineOpts     ( opt_IgnoreIfacePragmas )
 
 
-import RnBinds         ( rnTopBinds, rnMethodBinds, renameSigs )
-import RnEnv           ( bindTyVarsRn, lookupBndrRn, lookupOccRn, lookupImplicitOccRn, bindLocalsRn,
-                         newDfunName, checkDupOrQualNames, checkDupNames,
-                         newLocallyDefinedGlobalName, newImportedGlobalName, ifaceFlavour,
-                         listType_RDR, tupleType_RDR )
+import RnBinds         ( rnTopBinds, rnMethodBinds, renameSigs, unknownSigErr )
+import RnEnv           ( bindTyVarsRn, lookupBndrRn, lookupOccRn, getIPName,
+                         lookupImplicitOccRn, 
+                         bindLocalsRn, bindLocalRn, bindLocalsFVRn, bindUVarRn,
+                         bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn,
+                         bindCoreLocalFVRn, bindCoreLocalsFVRn,
+                         checkDupOrQualNames, checkDupNames,
+                         mkImportedGlobalName, mkImportedGlobalFromRdrName,
+                         newDFunName, getDFunKey, newImplicitBinder,
+                         FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV, mapFvRn
+                       )
 import RnMonad
 
 import RnMonad
 
-import Name            ( Name, OccName(..), occNameString, prefixOccName,
-                         ExportFlag(..), Provenance(..), NameSet, mkNameSet,
-                         elemNameSet, nameOccName, NamedThing(..)
+import FunDeps         ( oclose )
+
+import Name            ( Name, OccName,
+                         ExportFlag(..), Provenance(..), 
+                         nameOccName, NamedThing(..)
                        )
                        )
+import NameSet
+import OccName         ( mkDefaultMethodOcc )
 import BasicTypes      ( TopLevelFlag(..) )
 import BasicTypes      ( TopLevelFlag(..) )
-import FiniteMap       ( lookupFM )
-import Id              ( GenId{-instance NamedThing-} )
-import IdInfo          ( FBTypeInfo, ArgUsageInfo )
-import Lex             ( isLexCon )
-import PrelInfo                ( derivingOccurrences, evalClass_RDR, numClass_RDR, allClass_NAME )
-import Maybes          ( maybeToBool )
+import FiniteMap       ( elemFM )
+import PrelInfo                ( derivableClassKeys,
+                         deRefStablePtr_NAME, makeStablePtr_NAME, bindIO_NAME
+                       )
 import Bag             ( bagToList )
 import Bag             ( bagToList )
+import List            ( partition, nub )
 import Outputable
 import SrcLoc          ( SrcLoc )
 import Outputable
 import SrcLoc          ( SrcLoc )
-import Unique          ( Unique )
-import UniqSet         ( UniqSet )
-import UniqFM          ( UniqFM, lookupUFM )
+import CmdLineOpts     ( opt_WarnUnusedMatches )       -- Warn of unused for-all'd tyvars
+import Unique          ( Uniquable(..) )
+import UniqFM          ( lookupUFM )
+import Maybes          ( maybeToBool, catMaybes )
 import Util
 import Util
-import List            ( partition, nub )
 \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}
 
 
@@ -67,24 +79,42 @@ 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
+
+rnSourceDecls decls
+  = go emptyFVs [] decls
+  where
+       -- Fixity decls have been dealt with already; ignore them
+    go fvs ds' []          = returnRn (ds', fvs)
+    go fvs ds' (FixD _:ds) = go fvs ds' ds
+    go fvs ds' (d:ds)      = rnDecl d  `thenRn` \(d', fvs') ->
+                            go (fvs `plusFV` fvs') (d':ds') ds
+\end{code}
+
+
+%*********************************************************
+%*                                                     *
+\subsection{Value declarations}
+%*                                                     *
+%*********************************************************
+
+\begin{code}
+-- rnDecl does all the work
+rnDecl :: RdrNameHsDecl -> RnMS (RenamedHsDecl, FreeVars)
 
 
-rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ new_binds ->
-                     returnRn (ValD new_binds)
+rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) ->
+                     returnRn (ValD new_binds, fvs)
 
 
 rnDecl (SigD (IfaceSig name ty id_infos loc))
   = pushSrcLocRn loc $
     lookupBndrRn name          `thenRn` \ name' ->
 
 
 rnDecl (SigD (IfaceSig name ty id_infos loc))
   = pushSrcLocRn loc $
     lookupBndrRn name          `thenRn` \ name' ->
-    rnHsType ty                        `thenRn` \ ty' ->
-
-       -- 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))
+    rnHsPolyType doc_str ty    `thenRn` \ (ty',fvs1) ->
+    mapFvRn rnIdInfo id_infos  `thenRn` \ (id_infos', fvs2) -> 
+    returnRn (SigD (IfaceSig name' ty' id_infos' loc), fvs1 `plusFV` fvs2)
+  where
+    doc_str = text "the interface signature for" <+> quotes (ppr name)
 \end{code}
 
 %*********************************************************
 \end{code}
 
 %*********************************************************
@@ -99,70 +129,85 @@ names, reporting any unknown names.
 
 Renaming type variables is a pain. Because they now contain uniques,
 it is necessary to pass in an association list which maps a parsed
 
 Renaming type variables is a pain. Because they now contain uniques,
 it is necessary to pass in an association list which maps a parsed
-tyvar to its Name representation. In some cases (type signatures of
-values), it is even necessary to go over the type first in order to
-get the set of tyvars used by it, make an assoc list, and then go over
-it again to rename the tyvars! However, we can also do some scoping
-checks at the same time.
+tyvar to its @Name@ representation.
+In some cases (type signatures of values),
+it is even necessary to go over the type first
+in order to get the set of tyvars used by it, make an assoc list,
+and then go over it again to rename the tyvars!
+However, we can also do some scoping checks at the same time.
 
 \begin{code}
 
 \begin{code}
-rnDecl (TyD (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc))
+rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls derivings pragmas 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' ->
+    lookupBndrRn tycon                         `thenRn` \ tycon' ->
+    bindTyVarsFVRn data_doc tyvars             $ \ tyvars' ->
+    rnContext data_doc context                         `thenRn` \ (context', cxt_fvs) ->
+    checkDupOrQualNames data_doc con_names     `thenRn_`
+    mapFvRn rnConDecl condecls                 `thenRn` \ (condecls', con_fvs) ->
+    rnDerivs derivings                         `thenRn` \ (derivings', deriv_fvs) ->
     ASSERT(isNoDataPragmas pragmas)
     ASSERT(isNoDataPragmas pragmas)
-    returnRn (TyD (TyData new_or_data context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc))
+    returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls'
+                     derivings' noDataPragmas src_loc),
+             cxt_fvs `plusFV` con_fvs `plusFV` deriv_fvs)
   where
   where
-    data_doc = text "the data type declaration for" <+> ppr tycon
+    data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
     con_names = map conDeclName condecls
 
     con_names = map conDeclName condecls
 
-rnDecl (TyD (TySynonym name tyvars ty src_loc))
+rnDecl (TyClD (TySynonym name tyvars ty src_loc))
   = pushSrcLocRn src_loc $
     lookupBndrRn name                          `thenRn` \ name' ->
   = pushSrcLocRn src_loc $
     lookupBndrRn name                          `thenRn` \ name' ->
-    bindTyVarsRn syn_doc tyvars                $ \ tyvars' ->
-    rnHsType ty                                        `thenRn` \ ty' ->
-    returnRn (TyD (TySynonym name' tyvars' ty' src_loc))
+    bindTyVarsFVRn syn_doc tyvars              $ \ tyvars' ->
+    rnHsType syn_doc ty                                `thenRn` \ (ty', ty_fvs) ->
+    returnRn (TyClD (TySynonym name' tyvars' ty' src_loc), ty_fvs)
   where
   where
-    syn_doc = text "the declaration for type synonym" <+> ppr name
-\end{code}
+    syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
 
 
-%*********************************************************
-%*                                                     *
-\subsection{Class 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}
-rnDecl (ClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname src_loc))
+rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas
+               tname dname snames src_loc))
   = pushSrcLocRn src_loc $
 
     lookupBndrRn cname                                 `thenRn` \ cname' ->
   = pushSrcLocRn src_loc $
 
     lookupBndrRn cname                                 `thenRn` \ cname' ->
-    lookupBndrRn tname                                 `thenRn` \ tname' ->
-    lookupBndrRn dname                                 `thenRn` \ dname' ->
 
 
-    bindTyVarsRn cls_doc tyvars                                        ( \ tyvars' ->
-       rnContext context                                       `thenRn` \ context' ->
+       -- Deal with the implicit tycon and datacon name
+       -- They aren't in scope (because they aren't visible to the user)
+       -- and what we want to do is simply look them up in the cache;
+       -- we jolly well ought to get a 'hit' there!
+       -- So the 'Imported' part of this call is not relevant. 
+       -- Unclean; but since these two are the only place this happens
+       -- I can't work up the energy to do it more beautifully
+    mkImportedGlobalFromRdrName tname                  `thenRn` \ tname' ->
+    mkImportedGlobalFromRdrName dname                  `thenRn` \ dname' ->
+    mapRn mkImportedGlobalFromRdrName snames           `thenRn` \ snames' ->
 
 
-            -- 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') ->
+       -- Tyvars scope over bindings and context
+    bindTyVarsFV2Rn cls_doc tyvars             ( \ clas_tyvar_names tyvars' ->
+
+       -- Check the superclasses
+    rnContext cls_doc context                  `thenRn` \ (context', cxt_fvs) ->
+
+       -- Check the functional dependencies
+    rnFds cls_doc fds                  `thenRn` \ (fds', fds_fvs) ->
+
+       -- Check the signatures
+    let
+           -- First process the class op sigs, then the fixity sigs.
+         (op_sigs, non_op_sigs) = partition isClassOpSig sigs
+         (fix_sigs, non_sigs)   = partition isFixitySig  non_op_sigs
+    in
+    checkDupOrQualNames sig_doc sig_rdr_names_w_locs   `thenRn_` 
+    mapFvRn (rn_op cname' clas_tyvar_names fds') op_sigs
+    `thenRn` \ (sigs', sig_fvs) ->
+    mapRn_  (unknownSigErr) non_sigs                   `thenRn_`
+    let
+     binders = mkNameSet [ nm | (ClassOpSig nm _ _ _ _) <- sigs' ]
+    in
+    renameSigs False binders lookupOccRn fix_sigs
+    `thenRn` \ (fixs', fix_fvs) ->
 
        -- Check the methods
     checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
 
        -- Check the methods
     checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
-    rnMethodBinds mbinds                               `thenRn` \ mbinds' ->
+    rnMethodBinds mbinds
+    `thenRn` \ (mbinds', meth_fvs) ->
 
        -- Typechecker is responsible for checking that we only
        -- give default-method bindings for things in this class.
 
        -- Typechecker is responsible for checking that we only
        -- give default-method bindings for things in this class.
@@ -170,57 +215,55 @@ rnDecl (ClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname src_
        -- for instance decls.
 
     ASSERT(isNoClassPragmas pragmas)
        -- for instance decls.
 
     ASSERT(isNoClassPragmas pragmas)
-    returnRn (ClD (ClassDecl context' cname' tyvars' sigs' mbinds' NoClassPragmas tname' dname' src_loc))
+    returnRn (TyClD (ClassDecl context' cname' tyvars' fds' (fixs' ++ sigs') mbinds'
+                              NoClassPragmas tname' dname' snames' src_loc),
+             sig_fvs   `plusFV`
+             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
 
   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]
+    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
 
     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)
+    rn_op clas clas_tyvars clas_fds sig@(ClassOpSig op dm_rdr_name explicit_dm ty locn)
       = pushSrcLocRn locn $
       = pushSrcLocRn locn $
-       lookupBndrRn op                         `thenRn` \ op_name ->
-       rnHsSigType (quotes (ppr op)) ty        `thenRn` \ new_ty  ->
+       lookupBndrRn op                         `thenRn` \ op_name ->
 
 
-               -- Make the default-method name
+               -- Check the signature
+       rnHsSigType (quotes (ppr op)) ty        `thenRn` \ (new_ty, op_ty_fvs)  ->
        let
        let
-           dm_occ = prefixOccName SLIT("$m") (rdrNameOcc op)
+           check_in_op_ty clas_tyvar =
+                checkRn (clas_tyvar `elemNameSet` oclose clas_fds op_ty_fvs)
+                        (classTyVarNotInOpTyErr clas_tyvar sig)
        in
        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)
+        mapRn_ check_in_op_ty clas_tyvars               `thenRn_`
 
 
-           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_`
+               -- Make the default-method name
+       getModeRn                                       `thenRn` \ mode ->
+       (case mode of 
+           SourceMode -> -- Source class decl
+                  newImplicitBinder (mkDefaultMethodOcc (rdrNameOcc op)) locn     `thenRn` \ dm_name ->
+                  returnRn (dm_name, op `elem` meth_rdr_names, emptyFVs)
 
 
-       returnRn (ClassOpSig op_name maybe_dm_name new_ty locn)
+           InterfaceMode
+               ->      -- Imported class that has a default method decl
+                       -- See comments with tname, snames, above
+                   lookupImplicitOccRn dm_rdr_name     `thenRn` \ dm_name ->
+                   returnRn (dm_name, explicit_dm, if explicit_dm then unitFV dm_name else emptyFVs)
+                       -- 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
+       )                                               `thenRn` \ (dm_name, final_explicit_dm, dm_fvs) ->
+
+       returnRn (ClassOpSig op_name dm_name final_explicit_dm new_ty locn, op_ty_fvs `plusFV` dm_fvs)
 \end{code}
 
 
 \end{code}
 
 
@@ -231,54 +274,63 @@ 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))
+rnDecl (InstD (InstDecl inst_ty mbinds uprags dfun_rdr_name src_loc))
   = pushSrcLocRn src_loc $
   = pushSrcLocRn src_loc $
-    rnHsSigType (text "an instance decl") inst_ty      `thenRn` \ inst_ty' ->
-
+    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
 
        -- Rename the bindings
        -- NB meth_names can be qualified!
     checkDupNames meth_doc meth_names          `thenRn_`
 
        -- Rename the bindings
        -- NB meth_names can be qualified!
     checkDupNames meth_doc meth_names          `thenRn_`
-    rnMethodBinds mbinds                       `thenRn` \ mbinds' ->
+    extendTyVarEnvFVRn inst_tyvars (           
+       rnMethodBinds mbinds
+    )                                          `thenRn` \ (mbinds', meth_fvs) ->
     let 
        binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds')))
     let 
        binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds')))
+
+       -- Delete sigs (&report) sigs that aren't allowed inside an
+       -- instance decl:
+       --
+       --  + type signatures
+       --  + fixity decls
+       --
+       (ok_sigs, not_ok_idecl_sigs) = partition okInInstDecl uprags
+       
+       okInInstDecl (FixSig _)  = False
+       okInInstDecl (Sig _ _ _) = False
+       okInInstDecl _           = True
+       
     in
     in
-    renameSigs NotTopLevel True binders uprags `thenRn` \ new_uprags ->
-   
-    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 (HsPreForAllTy _ ty) = mkDictPrefix ty
-     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.
-    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
+      -- You can't have fixity decls & type signatures
+      -- within an instance declaration.
+    mapRn_ unknownSigErr not_ok_idecl_sigs       `thenRn_`
+
+       -- Rename the prags and signatures.
+       -- Note that the type variables are not in scope here,
+       -- so that      instance Eq a => Eq (T a) where
+       --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
+       -- works OK. 
+    renameSigs False binders lookupOccRn ok_sigs `thenRn` \ (new_uprags, prag_fvs) ->
+
+    getModeRn          `thenRn` \ mode ->
+    (case mode of
+       InterfaceMode -> lookupImplicitOccRn dfun_rdr_name      `thenRn` \ dfun_name ->
+                        returnRn (dfun_name, unitFV dfun_name)
+       SourceMode    -> newDFunName (getDFunKey inst_ty') src_loc
+                         `thenRn` \ dfun_name ->
+                        returnRn (dfun_name, emptyFVs)
+    )
+    `thenRn` \ (dfun_name, dfun_fv) ->
 
 
-       -- The typechecker checks that all the bindings are for the right class.
-    returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags (Just dfun_name) src_loc))
+    -- The typechecker checks that all the bindings are for the right class.
+    returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags dfun_name src_loc),
+             inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs `plusFV` dfun_fv)
   where
     meth_doc = text "the bindings in an instance declaration"
     meth_names   = bagToList (collectMonoBinders mbinds)
   where
     meth_doc = text "the bindings in an instance declaration"
     meth_names   = bagToList (collectMonoBinders mbinds)
@@ -293,11 +345,84 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc))
 \begin{code}
 rnDecl (DefD (DefaultDecl tys src_loc))
   = pushSrcLocRn src_loc $
 \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))
+    rnHsTypes doc_str tys              `thenRn` \ (tys', fvs) ->
+    returnRn (DefD (DefaultDecl tys' src_loc), fvs)
+  where
+    doc_str = text "a `default' declaration"
+\end{code}
+
+%*********************************************************
+%*                                                     *
+\subsection{Foreign declarations}
+%*                                                     *
+%*********************************************************
+
+\begin{code}
+rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
+  = pushSrcLocRn src_loc $
+    lookupOccRn name                   `thenRn` \ name' ->
+    let 
+       fvs1 = case imp_exp of
+               FoImport _ | not isDyn  -> emptyFVs
+               FoLabel                 -> emptyFVs
+               FoExport   | isDyn      -> mkNameSet [makeStablePtr_NAME,
+                                                     deRefStablePtr_NAME,
+                                                     bindIO_NAME]
+                          | otherwise  -> mkNameSet [name']
+               _ -> emptyFVs
+    in
+    rnHsSigType fo_decl_msg ty                 `thenRn` \ (ty', fvs2) ->
+    returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc), 
+             fvs1 `plusFV` fvs2)
+ where
+  fo_decl_msg = ptext SLIT("a foreign declaration")
+  isDyn              = isDynamic ext_nm
+\end{code}
+
+%*********************************************************
+%*                                                     *
+\subsection{Rules}
+%*                                                     *
+%*********************************************************
+
+\begin{code}
+rnDecl (RuleD (IfaceRuleDecl var body src_loc))
+  = pushSrcLocRn src_loc                       $
+    lookupOccRn var            `thenRn` \ var' ->
+    rnRuleBody body            `thenRn` \ (body', fvs) ->
+    returnRn (RuleD (IfaceRuleDecl var' body' src_loc), fvs `addOneFV` var')
+
+rnDecl (RuleD (RuleDecl 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 (RuleD (RuleDecl 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) = rnHsPolyType doc t  `thenRn` \ (t', fvs) ->
+                                  returnRn (RuleBndrSig id t', fvs)
 \end{code}
 
 \end{code}
 
+
 %*********************************************************
 %*                                                     *
 \subsection{Support code for type/data declarations}
 %*********************************************************
 %*                                                     *
 \subsection{Support code for type/data declarations}
@@ -305,77 +430,80 @@ 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 tvs cxt details locn)
   = pushSrcLocRn locn $
     checkConName name                  `thenRn_` 
     lookupBndrRn name                  `thenRn` \ new_name ->
   = 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)
+    bindTyVarsFVRn doc tvs             $ \ new_tyvars ->
+    rnContext doc cxt                  `thenRn` \ (new_context, cxt_fvs) ->
+    rnConDetails doc locn details      `thenRn` \ (new_details, det_fvs) -> 
+    returnRn (ConDecl new_name new_tyvars new_context new_details locn,
+             cxt_fvs `plusFV` det_fvs)
+  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 (NewCon ty mb_field)
+  = rnHsPolyType doc ty                        `thenRn` \ (new_ty, fvs) ->
+    rn_field mb_field                  `thenRn` \ new_mb_field  ->
+    returnRn (NewCon new_ty new_mb_field, fvs)
+  where
+    rn_field Nothing  = returnRn Nothing
+    rn_field (Just f) =
+       lookupBndrRn f      `thenRn` \ new_f ->
+       returnRn (Just new_f)
+
+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 = text "the fields of constructor" <> ppr con
     field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
 
     field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
 
-rnField (names, ty)
+rnField doc (names, ty)
   = mapRn lookupBndrRn names   `thenRn` \ new_names ->
   = mapRn lookupBndrRn names   `thenRn` \ new_names ->
-    rnBangTy ty                        `thenRn` \ new_ty ->
-    returnRn (new_names, new_ty) 
+    rnBangTy doc ty            `thenRn` \ (new_ty, fvs) ->
+    returnRn ((new_names, new_ty), fvs) 
+
+rnBangTy doc (Banged ty)
+  = rnHsPolyType doc ty                `thenRn` \ (new_ty, fvs) ->
+    returnRn (Banged new_ty, fvs)
 
 
-rnBangTy (Banged ty)
-  = rnHsType ty `thenRn` \ new_ty ->
-    returnRn (Banged new_ty)
+rnBangTy doc (Unbanged ty)
+  = rnHsPolyType doc ty        `thenRn` \ (new_ty, fvs) ->
+    returnRn (Unbanged new_ty, fvs)
 
 
-rnBangTy (Unbanged ty)
-  = rnHsType ty `thenRn` \ new_ty ->
-    returnRn (Unbanged new_ty)
+rnBangTy doc (Unpacked ty)
+  = rnHsPolyType 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
@@ -388,7 +516,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}
 
@@ -400,310 +528,369 @@ checkConName name
 %*********************************************************
 
 \begin{code}
 %*********************************************************
 
 \begin{code}
-rnHsSigType :: SDoc -> 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)
+rnHsSigType doc_str ty
+  = rnHsPolyType (text "the type signature for" <+> doc_str) ty
+    
+---------------------------------------
+rnHsPolyType, rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
+-- rnHsPolyType is prepared to see a for-all; rnHsType is not
+-- The former is called for the top level of type sigs and function args.
+
+---------------------------------------
+rnHsPolyType doc (HsForAllTy Nothing ctxt ty)
+       -- From source code (no kinds on tyvars)
+       -- Given the signature  C => T  we universally quantify 
+       -- over FV(T) \ {in-scope-tyvars} 
   = getLocalNameEnv            `thenRn` \ name_env ->
     let
   = getLocalNameEnv            `thenRn` \ name_env ->
     let
-       mentioned_tyvars = extractHsTyVars ty
-       forall_tyvars    = filter (not . in_scope) mentioned_tyvars
-       in_scope tv      = maybeToBool (lookupFM name_env tv)
-
-       constrained_tyvars            = extractHsCtxtTyVars 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
+       forall_tyvars    = filter (not . (`elemFM` name_env)) mentioned_in_tau
     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 = text "the type signature for" <+> doc_str
-                            
-
-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
-  = getLocalNameEnv            `thenRn` \ name_env ->
-    let
-       forall_tyvars = extractHsCtxtTyVars ctxt
+    checkConstraints doc forall_tyvars mentioned_in_tau ctxt ty        `thenRn` \ ctxt' ->
+    rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty
+
+rnHsPolyType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
+       -- Explicit quantification.
+       -- Check that the forall'd tyvars are a subset of the
+       -- free tyvars in the tau-type part
+       -- That's only a warning... unless the tyvar is constrained by a 
+       -- context in which case it's an error
+  = let
+       mentioned_in_tau  = extractHsTyRdrTyVars tau
+       mentioned_in_ctxt = nub [tv | p <- ctxt,
+                                     ty <- tys_of_pred p,
+                                     tv <- extractHsTyRdrTyVars ty]
+       tys_of_pred (HsPClass clas tys) = tys
+       tys_of_pred (HsPIParam n ty) = [ty]
+
+       dubious_guys          = filter (`notElem` mentioned_in_tau) forall_tyvar_names
+               -- dubious = explicitly quantified but not mentioned in tau type
+
+       (bad_guys, warn_guys) = partition (`elem` mentioned_in_ctxt) dubious_guys
+               -- bad  = explicitly quantified and constrained, but not mentioned in tau
+               -- warn = explicitly quantified but not mentioned in ctxt or tau
+ 
+       forall_tyvar_names    = map getTyVarName forall_tyvars
     in
     in
-    rn_poly_help (map UserTyVar forall_tyvars) ctxt ty
-
-rnHsType (MonoTyVar tyvar)
+    -- mapRn_ (forAllErr doc tau) bad_guys                                     `thenRn_`
+    mapRn_ (forAllWarn doc tau) warn_guys                                      `thenRn_`
+    checkConstraints doc forall_tyvar_names mentioned_in_tau ctxt tau  `thenRn` \ ctxt' ->
+    rnForAll doc forall_tyvars ctxt' tau
+
+rnHsPolyType doc other_ty = rnHsType doc other_ty
+
+
+-- Check that each constraint mentions at least one of the forall'd type variables
+-- Since the forall'd type variables are a subset of the free tyvars
+-- of the tau-type part, this guarantees that every constraint mentions
+-- at least one of the free tyvars in ty
+checkConstraints doc forall_tyvars tau_vars ctxt ty
+   = mapRn (checkPred doc forall_tyvars ty) ctxt `thenRn` \ maybe_ctxt' ->
+     returnRn (catMaybes maybe_ctxt')
+           -- Remove problem ones, to avoid duplicate error message.
+       
+checkPred doc forall_tyvars ty p@(HsPClass clas tys)
+  | not_univ  = failWithRn Nothing (univErr  doc p ty)
+  | otherwise = returnRn (Just p)
+  where
+      ct_vars  = extractHsTysRdrTyVars tys
+      not_univ =  -- At least one of the tyvars in each constraint must
+                 -- be universally quantified. This restriction isn't in Hugs
+                 not (any (`elem` forall_tyvars) ct_vars)
+checkPred doc forall_tyvars ty p@(HsPIParam _ _)
+  = returnRn (Just p)
+
+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)
+
+---------------------------------------
+rnHsType doc ty@(HsForAllTy _ _ inner_ty)
+  = addWarnRn (unexpectedForAllTy ty)  `thenRn_`
+    rnHsPolyType doc ty
+
+rnHsType doc (MonoTyVar 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')
+    returnRn (MonoTyVar tyvar', unitFV tyvar')
+
+rnHsType doc (MonoFunTy ty1 ty2)
+  = rnHsPolyType doc ty1       `thenRn` \ (ty1', fvs1) ->
+       -- Might find a for-all as the arg of a function type
+    rnHsPolyType 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 (MonoFunTy ty1' ty2', fvs1 `plusFV` fvs2)
+
+rnHsType doc (MonoListTy ty)
+  = rnHsType doc ty                            `thenRn` \ (ty', fvs) ->
+    returnRn (MonoListTy 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 (MonoTupleTy tys boxed)
+  = (if boxed 
+      then mapFvRn (rnHsType doc)     tys
+      else mapFvRn (rnHsPolyType doc) tys)  `thenRn` \ (tys', fvs) ->
+    returnRn (MonoTupleTy tys' boxed, fvs   `addOneFV` tup_con_name)
+  where
+    tup_con_name = tupleTyCon_name boxed (length tys)
 
 
-rnHsType (MonoTyApp ty1 ty2)
-  = rnHsType ty1               `thenRn` \ ty1' ->
-    rnHsType ty2               `thenRn` \ ty2' ->
-    returnRn (MonoTyApp ty1' ty2')
+rnHsType doc (MonoTyApp ty1 ty2)
+  = rnHsType doc ty1           `thenRn` \ (ty1', fvs1) ->
+    rnHsType doc ty2           `thenRn` \ (ty2', fvs2) ->
+    returnRn (MonoTyApp ty1' ty2', fvs1 `plusFV` fvs2)
 
 
-rnHsType (MonoDictTy clas tys)
+rnHsType doc (MonoDictTy clas tys)
   = lookupOccRn clas           `thenRn` \ clas' ->
   = lookupOccRn clas           `thenRn` \ clas' ->
-    mapRn rnHsType tys         `thenRn` \ tys' ->
-    returnRn (MonoDictTy clas' tys')
-
-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)
+    rnHsTypes doc tys          `thenRn` \ (tys', fvs) ->
+    returnRn (MonoDictTy clas' tys', fvs `addOneFV` clas')
+
+rnHsType doc (MonoUsgForAllTy uv_rdr ty)
+  = bindUVarRn doc uv_rdr $ \ uv_name ->
+    rnHsType doc ty       `thenRn` \ (ty', fvs) ->
+    returnRn (MonoUsgForAllTy uv_name ty',
+              fvs )
+
+rnHsType doc (MonoUsgTy usg ty)
+  = newUsg usg                          `thenRn` \ (usg', usg_fvs) ->
+    rnHsPolyType doc ty                 `thenRn` \ (ty', ty_fvs) ->
+       -- A for-all can occur inside a usage annotation
+    returnRn (MonoUsgTy usg' ty',
+              usg_fvs `plusFV` ty_fvs)
   where
   where
-    sig_doc = text "a nested for-all type"
+    newUsg usg = case usg of
+                   MonoUsOnce       -> returnRn (MonoUsOnce, emptyFVs)
+                   MonoUsMany       -> returnRn (MonoUsMany, emptyFVs)
+                   MonoUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name ->
+                                       returnRn (MonoUsVar uv_name, emptyFVs)
+
+rnHsTypes doc tys = mapFvRn (rnHsType doc) tys
 \end{code}
 
 
 \begin{code}
 \end{code}
 
 
 \begin{code}
-rnContext :: RdrNameContext -> RnMS s RenamedContext
+rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
 
 
-rnContext  ctxt
-  = mapRn rn_ctxt ctxt `thenRn` \ result ->
+rnContext doc ctxt
+  = mapAndUnzipRn (rnPred doc) ctxt    `thenRn` \ (theta, fvs_s) ->
     let
     let
-       (_, dup_asserts) = removeDups cmp_assert result
-       (alls, theta)    = partition (\(c,_) -> c == allClass_NAME) result
+       (_, dup_asserts) = removeDups (cmpHsPred compare) theta
     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_`
+    mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts  `thenRn_`
+
+    returnRn (theta, plusFVs fvs_s)
+
+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)
+  = getIPName n                        `thenRn` \ name ->
+    rnHsType doc ty            `thenRn` \ (ty', fvs) ->
+    returnRn (HsPIParam name ty', fvs)
+\end{code}
 
 
-       -- Check for All constraining a non-type-variable
-    mapRn check_All 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
+\begin{code}
+rnFds :: SDoc -> [([RdrName],[RdrName])] -> RnMS ([([Name],[Name])], FreeVars)
+
+rnFds doc fds
+  = mapAndUnzipRn rn_fds fds           `thenRn` \ (theta, fvs_s) ->
+    returnRn (theta, plusFVs fvs_s)
   where
   where
-    rn_ctxt (clas, tys)
-      =                -- 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_`
-       mapRn rnHsType tys      `thenRn` \ tys' ->
-       returnRn (clas_name, tys')
-
-
-    cmp_assert (c1,tys1) (c2,tys2)
-      = (c1 `compare` c2) `thenCmp` (cmpHsTypes compare tys1 tys2)
-
-    check_All (c, [MonoTyVar _]) = returnRn () -- OK!
-    check_All assertion                 = addErrRn (wierdAllErr assertion)
-\end{code}
+    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)
-rnIdInfo (HsSpecialise tyvars tys expr)
-  = bindTyVarsRn doc tyvars    $ \ tyvars' ->
-    rnCoreExpr expr            `thenRn` \ expr' ->
-    mapRn rnHsType tys         `thenRn` \ tys' ->
-    returnRn (HsSpecialise tyvars' tys' expr')
-  where
-    doc = text "Specialise in interface pragma"
-    
+rnIdInfo (HsStrictness str) = returnRn (HsStrictness str, emptyFVs)
 
 
-rnStrict (HsStrictnessInfo demands (Just (worker,cons)))
-       -- The sole purpose of the "cons" field is so that we can mark the constructors
-       -- needed to build the wrapper as "needed", so that their data type decl will be
-       -- slurped in. After that their usefulness is o'er, so we just put in the empty list.
+rnIdInfo (HsWorker worker)
   = lookupOccRn worker                 `thenRn` \ worker' ->
   = 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
+    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 (HsUpdate update)     = returnRn (HsUpdate update, emptyFVs)
+rnIdInfo (HsNoCafRefs)         = returnRn (HsNoCafRefs, emptyFVs)
+rnIdInfo (HsCprInfo cpr_info)  = returnRn (HsCprInfo cpr_info, emptyFVs)
+rnIdInfo (HsSpecialise rule_body) = rnRuleBody rule_body
+                                   `thenRn` \ (rule_body', fvs) ->
+                                   returnRn (HsSpecialise rule_body', fvs)
+
+rnRuleBody (UfRuleBody str vars args rhs)
+  = rnCoreBndrs vars           $ \ vars' ->
+    mapFvRn rnCoreExpr args    `thenRn` \ (args', fvs1) ->
+    rnCoreExpr rhs             `thenRn` \ (rhs',  fvs2) ->
+    returnRn (UfRuleBody str vars' args' rhs', fvs1 `plusFV` fvs2)
 \end{code}
 
 \end{code}
 
-UfCore expressions.
+@UfCore@ expressions.
 
 \begin{code}
 
 \begin{code}
+rnCoreExpr (UfType ty)
+  = rnHsPolyType (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) 
 
 rnCoreExpr (UfCon con args) 
-  = lookupOccRn con            `thenRn` \ con' ->
-    mapRn rnCoreArg args       `thenRn` \ args' ->
-    returnRn (UfCon con' args')
+  = rnUfCon con                        `thenRn` \ (con', fvs1) ->
+    mapFvRn rnCoreExpr args    `thenRn` \ (args', fvs2) ->
+    returnRn (UfCon con' args', fvs1 `plusFV` fvs2)
 
 
-rnCoreExpr (UfPrim prim args) 
-  = rnCorePrim prim            `thenRn` \ prim' ->
-    mapRn rnCoreArg args       `thenRn` \ args' ->
-    returnRn (UfPrim prim' args')
+rnCoreExpr (UfTuple con args) 
+  = lookupOccRn con            `thenRn` \ con' ->
+    mapFvRn rnCoreExpr args    `thenRn` \ (args', fvs) ->
+    returnRn (UfTuple con' args', fvs `addOneFV` con')
 
 rnCoreExpr (UfApp fun arg)
 
 rnCoreExpr (UfApp fun arg)
-  = rnCoreExpr fun             `thenRn` \ fun' ->
-    rnCoreArg arg              `thenRn` \ arg' ->
-    returnRn (UfApp fun' arg')
-
-rnCoreExpr (UfCase scrut alts) 
-  = rnCoreExpr scrut           `thenRn` \ scrut' ->
-    rnCoreAlts alts            `thenRn` \ alts' ->
-    returnRn (UfCase scrut' alts')
+  = 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) 
 
 rnCoreExpr (UfNote note expr) 
-  = rnNote note                        `thenRn` \ note' ->
-    rnCoreExpr expr            `thenRn` \ expr' ->
-    returnRn  (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')
+  = rnHsPolyType 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)
     
-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 (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')
-
-rnCoreDefault UfNoDefault = returnRn UfNoDefault
-rnCoreDefault (UfBindDefault bndr rhs) = bindLocalsRn "unfolding default" [bndr]       $ \ [bndr'] ->
-                                        rnCoreExpr rhs                                 `thenRn` \ rhs' ->
-                                        returnRn (UfBindDefault bndr' rhs')
+rnCoreAlt (con, bndrs, rhs)
+  = rnUfCon con                                `thenRn` \ (con', fvs1) ->
+    bindCoreLocalsFVRn bndrs           ( \ bndrs' ->
+       rnCoreExpr rhs                  `thenRn` \ (rhs', fvs2) ->
+       returnRn ((con', bndrs', rhs'), fvs2)
+    )                                  `thenRn` \ (result, fvs3) ->
+    returnRn (result, fvs1 `plusFV` fvs3)
 
 rnNote (UfCoerce ty)
 
 rnNote (UfCoerce ty)
-  = rnHsType ty                        `thenRn` \ ty' ->
-    returnRn (UfCoerce ty')
+  = rnHsPolyType (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)
+
 
 
-rnNote (UfSCC cc)   = returnRn (UfSCC cc)
-rnNote UfInlineCall = returnRn UfInlineCall
+rnUfCon UfDefault
+  = returnRn (UfDefault, emptyFVs)
 
 
-rnCorePrim (UfOtherOp op) 
-  = lookupOccRn op     `thenRn` \ op' ->
-    returnRn (UfOtherOp op')
+rnUfCon (UfDataCon con)
+  = lookupOccRn con            `thenRn` \ con' ->
+    returnRn (UfDataCon con', unitFV con')
+
+rnUfCon (UfLitCon lit)
+  = returnRn (UfLitCon lit, emptyFVs)
+
+rnUfCon (UfLitLitCon lit ty)
+  = rnHsPolyType (text "litlit") ty            `thenRn` \ (ty', fvs) ->
+    returnRn (UfLitLitCon lit ty', fvs)
 
 
-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 (UfPrimOp op)
+  = lookupOccRn op             `thenRn` \ op' ->
+    returnRn (UfPrimOp op', emptyFVs)
+
+rnUfCon (UfCCallOp str is_dyn casm gc)
+  = returnRn (UfCCallOp str is_dyn casm gc, emptyFVs)
 \end{code}
 
 %*********************************************************
 \end{code}
 
 %*********************************************************
-%*                                                     *
+%*                                                      *
+\subsection{Rule shapes}
+%*                                                      *
+%*********************************************************
+
+Check the shape of a transformation rule LHS.  Currently
+we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
+not one of the @forall@'d variables.
+
+\begin{code}
+validRuleLhs foralls lhs
+  = check lhs
+  where
+    check (HsApp e1 e2)                  = check e1
+    check (HsVar v) | v `notElem` foralls = True
+    check other                                  = False
+\end{code}
+
+
+%*********************************************************
+%*                                                      *
 \subsection{Errors}
 \subsection{Errors}
-%*                                                     *
+%*                                                      *
 %*********************************************************
 
 \begin{code}
 %*********************************************************
 
 \begin{code}
@@ -718,26 +905,66 @@ classTyVarNotInOpTyErr clas_tyvar sig
 
 dupClassAssertWarn ctxt (assertion : dups)
   = sep [hsep [ptext SLIT("Duplicate class assertion"), 
 
 dupClassAssertWarn ctxt (assertion : dups)
   = sep [hsep [ptext SLIT("Duplicate class assertion"), 
-              quotes (pprClassAssertion assertion),
+              quotes (pprHsPred assertion),
               ptext SLIT("in the context:")],
               ptext SLIT("in the context:")],
-        nest 4 (pprContext ctxt)]
+        nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
 
 badDataCon name
    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 
 
 badDataCon name
    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 
-wierdAllErr assertion
-  = ptext SLIT("Mal-formed use of `All':") <+> pprClassAssertion assertion
+forAllWarn doc ty tyvar
+  | not opt_WarnUnusedMatches = returnRn ()
+  | otherwise
+  = getModeRn          `thenRn` \ mode ->
+    case mode of {
+#ifndef DEBUG
+       InterfaceMode -> returnRn () ;  -- Don't warn of unused tyvars in interface files
+                                       -- unless DEBUG is on, in which case it is slightly
+                                       -- informative.  They can arise from mkRhsTyLam,
+#endif                                 -- leading to (say)     f :: forall a b. [b] -> [b]
+       other ->
+
+    addWarnRn (
+      sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
+          nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
+      $$
+      (ptext SLIT("In") <+> doc))
+    }
+
+forAllErr doc ty tyvar
+  = addErrRn (
+      sep [ptext SLIT("The constrained type variable") <+> quotes (ppr tyvar),
+          nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
+      $$
+      (ptext SLIT("In") <+> doc))
+
+univErr doc constraint ty
+  = sep [ptext SLIT("All of the type variable(s) in the constraint")
+          <+> quotes (pprHsPred constraint) 
+         <+> ptext SLIT("are already in scope"),
+        nest 4 (ptext SLIT("At least one must be universally quantified here"))
+    ]
+    $$
+    (ptext SLIT("In") <+> doc)
 
 
-ctxtErr1 doc tyvars
-  = hsep [ptext SLIT("Context constrains in-scope type variable(s)"), 
-         pprQuotedList tyvars]
+ambigErr doc constraint ty
+  = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprHsPred constraint),
+        nest 4 (ptext SLIT("in the type:") <+> ppr ty),
+        nest 4 (ptext SLIT("Each forall-d type variable mentioned by the constraint must appear after the =>."))]
     $$
     $$
-    nest 4 (ptext SLIT("in") <+> doc)
+    (ptext SLIT("In") <+> doc)
 
 
-ctxtErr2 doc tyvars ty
-  = (ptext SLIT("Context constrains type variable(s)")
-       <+> pprQuotedList tyvars)
+unexpectedForAllTy ty
+  = ptext SLIT("Unexpected forall type:") <+> ppr ty
+
+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") <+> quotes (ppr ty),
-                 ptext SLIT("in") <+> doc])
+    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")]
 \end{code}
 \end{code}
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)