projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[project @ 2000-06-12 13:40:20 by panne]
[ghc-hetmet.git] / ghc / compiler / rename / RnSource.lhs
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 68b817f..60615a9 100644 (file)
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -11,27 +11,32 @@ module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType ) where
 import RnExpr
 import HsSyn
 import HsPragmas
 import RnExpr
 import HsSyn
 import HsPragmas
-import HsTypes         ( getTyVarName, pprClassAssertion, cmpHsTypes )
-import RdrName         ( RdrName, isRdrDataCon, rdrNameOcc, isRdrTyVar )
+import HsTypes         ( getTyVarName )
+import RdrName         ( RdrName, isRdrDataCon, rdrNameOcc, isRdrTyVar, mkRdrNameWkr )
 import RdrHsSyn                ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
 import RdrHsSyn                ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
-                         extractHsTyRdrNames, extractRuleBndrsTyVars
+                         extractRuleBndrsTyVars, extractHsTyRdrTyVars,
+                         extractHsTysRdrTyVars, extractHsCtxtRdrTyVars
                        )
 import RnHsSyn
 import HsCore
 
 import RnBinds         ( rnTopBinds, rnMethodBinds, renameSigs, unknownSigErr )
                        )
 import RnHsSyn
 import HsCore
 
 import RnBinds         ( rnTopBinds, rnMethodBinds, renameSigs, unknownSigErr )
-import RnEnv           ( bindTyVarsRn, lookupBndrRn, lookupOccRn, 
-                         lookupImplicitOccRn, 
-                         bindLocalsRn, bindLocalRn, bindLocalsFVRn,
+import RnEnv           ( bindTyVarsRn, lookupBndrRn, lookupOccRn, getIPName,
+                         lookupImplicitOccRn, lookupImplicitOccsRn,
+                         bindLocalsRn, bindLocalRn, bindLocalsFVRn, bindUVarRn,
                          bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn,
                          bindCoreLocalFVRn, bindCoreLocalsFVRn,
                          checkDupOrQualNames, checkDupNames,
                          mkImportedGlobalName, mkImportedGlobalFromRdrName,
                          newDFunName, getDFunKey, newImplicitBinder,
                          bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn,
                          bindCoreLocalFVRn, bindCoreLocalsFVRn,
                          checkDupOrQualNames, checkDupNames,
                          mkImportedGlobalName, mkImportedGlobalFromRdrName,
                          newDFunName, getDFunKey, newImplicitBinder,
-                         FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV, mapFvRn
+                         FreeVars, emptyFVs, plusFV, plusFVs, unitFV, 
+                         addOneFV, mapFvRn
                        )
 import RnMonad
 
                        )
 import RnMonad
 
+import FunDeps         ( oclose )
+import Class           ( FunDep )
+
 import Name            ( Name, OccName,
                          ExportFlag(..), Provenance(..), 
                          nameOccName, NamedThing(..)
 import Name            ( Name, OccName,
                          ExportFlag(..), Provenance(..), 
                          nameOccName, NamedThing(..)
@@ -40,31 +45,36 @@ import NameSet
 import OccName         ( mkDefaultMethodOcc )
 import BasicTypes      ( TopLevelFlag(..) )
 import FiniteMap       ( elemFM )
 import OccName         ( mkDefaultMethodOcc )
 import BasicTypes      ( TopLevelFlag(..) )
 import FiniteMap       ( elemFM )
-import PrelInfo                ( derivingOccurrences, numClass_RDR, 
-                         deRefStablePtr_NAME, makeStablePtr_NAME,
-                         bindIO_NAME
+import PrelInfo                ( derivableClassKeys, cCallishClassKeys,
+                         deRefStablePtr_RDR, makeStablePtr_RDR, 
+                         bindIO_RDR, returnIO_RDR
                        )
 import Bag             ( bagToList )
 import List            ( partition, nub )
 import Outputable
 import SrcLoc          ( SrcLoc )
                        )
 import Bag             ( bagToList )
 import List            ( partition, nub )
 import Outputable
 import SrcLoc          ( SrcLoc )
-import CmdLineOpts     ( opt_WarnUnusedMatches )       -- Warn of unused for-all'd tyvars
+import CmdLineOpts     ( opt_GlasgowExts, opt_WarnUnusedMatches )      -- Warn of unused for-all'd tyvars
+import Unique          ( Uniquable(..) )
 import UniqFM          ( lookupUFM )
 import UniqFM          ( lookupUFM )
+import ErrUtils                ( Message )
+import CStrings                ( isCLabelString )
 import Maybes          ( maybeToBool, catMaybes )
 import Util
 \end{code}
 
 import Maybes          ( maybeToBool, catMaybes )
 import Util
 \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}
 
 
@@ -81,11 +91,12 @@ rnSourceDecls :: [RdrNameHsDecl] -> RnMS ([RenamedHsDecl], FreeVars)
 rnSourceDecls decls
   = go emptyFVs [] decls
   where
 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
+       -- 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}
 
 
@@ -105,9 +116,9 @@ rnDecl (ValD binds) = rnTopBinds binds      `thenRn` \ (new_binds, fvs) ->
 
 rnDecl (SigD (IfaceSig name ty id_infos loc))
   = pushSrcLocRn loc $
 
 rnDecl (SigD (IfaceSig name ty id_infos loc))
   = pushSrcLocRn loc $
-    lookupBndrRn name          `thenRn` \ name' ->
-    rnHsType doc_str ty                `thenRn` \ (ty',fvs1) ->
-    mapFvRn rnIdInfo id_infos  `thenRn` \ (id_infos', fvs2) -> 
+    mkImportedGlobalFromRdrName name   `thenRn` \ name' ->
+    rnHsType doc_str ty                        `thenRn` \ (ty',fvs1) ->
+    mapFvRn rnIdInfo id_infos          `thenRn` \ (id_infos', fvs2) -> 
     returnRn (SigD (IfaceSig name' ty' id_infos' loc), fvs1 `plusFV` fvs2)
   where
     doc_str = text "the interface signature for" <+> quotes (ppr name)
     returnRn (SigD (IfaceSig name' ty' id_infos' loc), fvs1 `plusFV` fvs2)
   where
     doc_str = text "the interface signature for" <+> quotes (ppr name)
@@ -125,23 +136,25 @@ names, reporting any unknown names.
 
 Renaming type variables is a pain. Because they now contain uniques,
 it is necessary to pass in an association list which maps a parsed
 
 Renaming type variables is a pain. Because they now contain uniques,
 it is necessary to pass in an association list which maps a parsed
-tyvar to its Name representation. In some cases (type signatures of
-values), it is even necessary to go over the type first in order to
-get the set of tyvars used by it, make an assoc list, and then go over
-it again to rename the tyvars! However, we can also do some scoping
-checks at the same time.
+tyvar to its @Name@ representation.
+In some cases (type signatures of values),
+it is even necessary to go over the type first
+in order to get the set of tyvars used by it, make an assoc list,
+and then go over it again to rename the tyvars!
+However, we can also do some scoping checks at the same time.
 
 \begin{code}
 
 \begin{code}
-rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc))
+rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls nconstrs derivings pragmas src_loc))
   = pushSrcLocRn src_loc $
   = pushSrcLocRn src_loc $
-    lookupBndrRn tycon                                 `thenRn` \ tycon' ->
-    bindTyVarsFVRn data_doc tyvars                     $ \ tyvars' ->
-    rnContext data_doc context                                 `thenRn` \ (context', cxt_fvs) ->
-    checkDupOrQualNames data_doc con_names             `thenRn_`
-    mapFvRn rnConDecl condecls                         `thenRn` \ (condecls', con_fvs) ->
-    rnDerivs derivings                                 `thenRn` \ (derivings', deriv_fvs) ->
+    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 (TyClD (TyData new_or_data context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc),
+    returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls' nconstrs
+                     derivings' noDataPragmas src_loc),
              cxt_fvs `plusFV` con_fvs `plusFV` deriv_fvs)
   where
     data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
              cxt_fvs `plusFV` con_fvs `plusFV` deriv_fvs)
   where
     data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
@@ -151,12 +164,18 @@ rnDecl (TyClD (TySynonym name tyvars ty src_loc))
   = pushSrcLocRn src_loc $
     lookupBndrRn name                          `thenRn` \ name' ->
     bindTyVarsFVRn syn_doc tyvars              $ \ tyvars' ->
   = pushSrcLocRn src_loc $
     lookupBndrRn name                          `thenRn` \ name' ->
     bindTyVarsFVRn syn_doc tyvars              $ \ tyvars' ->
-    rnHsType syn_doc ty                                `thenRn` \ (ty', ty_fvs) ->
+    rnHsType syn_doc (unquantify ty)           `thenRn` \ (ty', ty_fvs) ->
     returnRn (TyClD (TySynonym name' tyvars' ty' src_loc), ty_fvs)
   where
     syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
 
     returnRn (TyClD (TySynonym name' tyvars' ty' src_loc), ty_fvs)
   where
     syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
 
-rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname snames src_loc))
+       -- 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 (HsForAllTy Nothing ctxt ty) | not opt_GlasgowExts = ty
+    unquantify ty                                                = ty
+
+rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas
+               tname dname dwname snames src_loc))
   = pushSrcLocRn src_loc $
 
     lookupBndrRn cname                                 `thenRn` \ cname' ->
   = pushSrcLocRn src_loc $
 
     lookupBndrRn cname                                 `thenRn` \ cname' ->
@@ -170,31 +189,34 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname sn
        -- I can't work up the energy to do it more beautifully
     mkImportedGlobalFromRdrName tname                  `thenRn` \ tname' ->
     mkImportedGlobalFromRdrName dname                  `thenRn` \ dname' ->
        -- I can't work up the energy to do it more beautifully
     mkImportedGlobalFromRdrName tname                  `thenRn` \ tname' ->
     mkImportedGlobalFromRdrName dname                  `thenRn` \ dname' ->
+    mkImportedGlobalFromRdrName dwname                 `thenRn` \ dwname' ->
     mapRn mkImportedGlobalFromRdrName snames           `thenRn` \ snames' ->
 
        -- Tyvars scope over bindings and context
     mapRn mkImportedGlobalFromRdrName snames           `thenRn` \ snames' ->
 
        -- Tyvars scope over bindings and context
-    bindTyVarsFV2Rn cls_doc tyvars                     ( \ clas_tyvar_names tyvars' ->
+    bindTyVarsFV2Rn cls_doc tyvars             ( \ clas_tyvar_names tyvars' ->
 
        -- Check the superclasses
 
        -- Check the superclasses
-    rnContext cls_doc context                          `thenRn` \ (context', cxt_fvs) ->
+    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
 
        -- 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
     in
-    checkDupOrQualNames sig_doc sig_rdr_names_w_locs   `thenRn_` 
-    mapFvRn (rn_op cname' clas_tyvar_names) op_sigs    `thenRn` \ (sigs', sig_fvs) ->
-    mapRn_  (unknownSigErr) non_sigs                   `thenRn_`
+    checkDupOrQualNames sig_doc sig_rdr_names_w_locs     `thenRn_` 
+    mapFvRn (rn_op cname' clas_tyvar_names fds') op_sigs  `thenRn` \ (sigs', sig_fvs) ->
     let
     let
-     binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
+     binders = mkNameSet [ nm | (ClassOpSig nm _ _ _ _) <- sigs' ]
     in
     in
-    renameSigs False binders lookupOccRn fix_sigs        `thenRn` \ (fixs', fix_fvs) ->
+    renameSigs (okClsDclSig binders) non_op_sigs         `thenRn` \ (non_ops', 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', meth_fvs) ->
+    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.
@@ -202,11 +224,12 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname sn
        -- for instance decls.
 
     ASSERT(isNoClassPragmas pragmas)
        -- for instance decls.
 
     ASSERT(isNoClassPragmas pragmas)
-    returnRn (TyClD (ClassDecl context' cname' tyvars' (fixs' ++ sigs') 
-                              mbinds' NoClassPragmas tname' dname' snames' src_loc),
+    returnRn (TyClD (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') mbinds'
+                              NoClassPragmas tname' dname' dwname' snames' src_loc),
              sig_fvs   `plusFV`
              fix_fvs   `plusFV`
              cxt_fvs   `plusFV`
              sig_fvs   `plusFV`
              fix_fvs   `plusFV`
              cxt_fvs   `plusFV`
+             fds_fvs   `plusFV`
              meth_fvs
             )
     )
              meth_fvs
             )
     )
@@ -215,49 +238,41 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname sn
     sig_doc  = text "the signatures for class"         <+> ppr cname
     meth_doc = text "the default-methods 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 $
        lookupBndrRn op                         `thenRn` \ op_name ->
 
                -- Check the signature
        rnHsSigType (quotes (ppr op)) ty        `thenRn` \ (new_ty, op_ty_fvs)  ->
        let
       = pushSrcLocRn locn $
        lookupBndrRn op                         `thenRn` \ op_name ->
 
                -- Check the signature
        rnHsSigType (quotes (ppr op)) ty        `thenRn` \ (new_ty, op_ty_fvs)  ->
        let
-           check_in_op_ty clas_tyvar = checkRn (clas_tyvar `elemNameSet` op_ty_fvs)
-                                               (classTyVarNotInOpTyErr clas_tyvar sig)
+           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_`
 
                -- Make the default-method name
        getModeRn                                       `thenRn` \ mode ->
        in
         mapRn_ check_in_op_ty clas_tyvars               `thenRn_`
 
                -- Make the default-method name
        getModeRn                                       `thenRn` \ mode ->
-       (case (mode, maybe_dm) of 
-           (SourceMode, _)
-               | op `elem` meth_rdr_names
-               ->      -- Source class decl with an explicit method decl
-                       newImplicitBinder (mkDefaultMethodOcc (rdrNameOcc op)) locn     `thenRn` \ dm_name ->
-                       returnRn (Just dm_name, emptyFVs)
-
-               | otherwise     
-               ->      -- Source class dec, no explicit method decl
-                       returnRn (Nothing, emptyFVs)
-
-           (InterfaceMode, Just dm_rdr_name)
+       (case mode of 
+           SourceMode -> -- Source class decl
+                  newImplicitBinder (mkDefaultMethodOcc (rdrNameOcc op)) locn     `thenRn` \ dm_name ->
+                  returnRn (dm_name, op `elem` meth_rdr_names, emptyFVs)
+
+           InterfaceMode
                ->      -- Imported class that has a default method decl
                        -- See comments with tname, snames, above
                ->      -- Imported class that has a default method decl
                        -- See comments with tname, snames, above
-                   lookupImplicitOccRn dm_rdr_name             `thenRn` \ dm_name ->
-                   returnRn (Just dm_name, unitFV dm_name)
-                           -- An imported class decl mentions, rather than defines,
-                           -- the default method, so we must arrange to pull it in
-
-           (InterfaceMode, Nothing)
-                       -- Imported class with no default metho
-               ->      returnRn (Nothing, emptyFVs)
-       )                                               `thenRn` \ (maybe_dm_name, dm_fvs) ->
-
-       returnRn (ClassOpSig op_name maybe_dm_name new_ty locn, op_ty_fvs `plusFV` dm_fvs)
+                   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}
 
 
@@ -270,7 +285,7 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname sn
 \begin{code}
 rnDecl (InstD (InstDecl inst_ty mbinds uprags dfun_rdr_name src_loc))
   = pushSrcLocRn src_loc $
 \begin{code}
 rnDecl (InstD (InstDecl inst_ty mbinds uprags dfun_rdr_name src_loc))
   = pushSrcLocRn src_loc $
-    rnHsSigType (text "an instance decl") inst_ty      `thenRn` \ (inst_ty', inst_fvs) ->
+    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
     let
        inst_tyvars = case inst_ty' of
                        HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
@@ -287,40 +302,25 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags dfun_rdr_name src_loc))
     )                                          `thenRn` \ (mbinds', meth_fvs) ->
     let 
        binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds')))
     )                                          `thenRn` \ (mbinds', meth_fvs) ->
     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
-      -- You can't have fixity decls & type signatures
-      -- within an instance declaration.
-    mapRn_ unknownSigErr not_ok_idecl_sigs       `thenRn_`
-
        -- Rename the prags and signatures.
        -- Note that the type variables are not in scope here,
        -- so that      instance Eq a => Eq (T a) where
        --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
        -- works OK. 
        -- Rename the prags and signatures.
        -- Note that the type variables are not in scope here,
        -- so that      instance Eq a => Eq (T a) where
        --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
        -- works OK. 
-    renameSigs False binders lookupOccRn ok_sigs `thenRn` \ (new_uprags, prag_fvs) ->
+    renameSigs (okInstDclSig binders) uprags   `thenRn` \ (new_uprags, prag_fvs) ->
 
     getModeRn          `thenRn` \ mode ->
     (case mode of
 
     getModeRn          `thenRn` \ mode ->
     (case mode of
-       InterfaceMode -> lookupImplicitOccRn dfun_rdr_name              `thenRn` \ dfun_name ->
+       InterfaceMode -> lookupImplicitOccRn dfun_rdr_name      `thenRn` \ dfun_name ->
                         returnRn (dfun_name, unitFV dfun_name)
                         returnRn (dfun_name, unitFV dfun_name)
-       SourceMode    -> newDFunName (getDFunKey inst_ty') src_loc      `thenRn` \ dfun_name ->
+       SourceMode    -> newDFunName (getDFunKey inst_ty') src_loc
+                         `thenRn` \ dfun_name ->
                         returnRn (dfun_name, emptyFVs)
                         returnRn (dfun_name, emptyFVs)
-    )                                                          `thenRn` \ (dfun_name, dfun_fv) ->
+    )
+    `thenRn` \ (dfun_name, dfun_fv) ->
 
 
-       -- The typechecker checks that all the bindings are for the right class.
+    -- 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
     returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags dfun_name src_loc),
              inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs `plusFV` dfun_fv)
   where
@@ -338,8 +338,7 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags dfun_rdr_name src_loc))
 rnDecl (DefD (DefaultDecl tys src_loc))
   = pushSrcLocRn src_loc $
     rnHsTypes doc_str tys              `thenRn` \ (tys', fvs) ->
 rnDecl (DefD (DefaultDecl tys src_loc))
   = pushSrcLocRn src_loc $
     rnHsTypes doc_str tys              `thenRn` \ (tys', fvs) ->
-    lookupImplicitOccRn numClass_RDR   `thenRn` \ num ->
-    returnRn (DefD (DefaultDecl tys' src_loc), fvs `addOneFV` num)
+    returnRn (DefD (DefaultDecl tys' src_loc), fvs)
   where
     doc_str = text "a `default' declaration"
 \end{code}
   where
     doc_str = text "a `default' declaration"
 \end{code}
@@ -353,22 +352,31 @@ rnDecl (DefD (DefaultDecl tys src_loc))
 \begin{code}
 rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
   = pushSrcLocRn src_loc $
 \begin{code}
 rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
   = pushSrcLocRn src_loc $
-    lookupBndrRn name                  `thenRn` \ name' ->
+    lookupOccRn name                   `thenRn` \ name' ->
     let 
     let 
-       fvs1 = case imp_exp of
-               FoImport _ | not isDyn  -> emptyFVs
-               FoLabel                 -> emptyFVs
-               FoExport   | isDyn      -> mkNameSet [makeStablePtr_NAME,
-                                                     deRefStablePtr_NAME,
-                                                     bindIO_NAME]
-               _ -> emptyFVs
+       extra_fvs FoExport 
+         | isDyn = 
+               lookupImplicitOccsRn [makeStablePtr_RDR, deRefStablePtr_RDR,
+                                     bindIO_RDR, returnIO_RDR]
+         | otherwise = 
+               lookupImplicitOccsRn [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs ->
+               returnRn (addOneFV fvs name')
+       extra_fvs other = returnRn emptyFVs
     in
     in
-    rnHsSigType fo_decl_msg ty                 `thenRn` \ (ty', fvs2) ->
+    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")
     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
+  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}
 
 %*********************************************************
@@ -378,13 +386,23 @@ rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
 %*********************************************************
 
 \begin{code}
 %*********************************************************
 
 \begin{code}
-rnDecl (RuleD (IfaceRuleDecl var body src_loc))
-  = pushSrcLocRn src_loc                       $
-    lookupOccRn var            `thenRn` \ var' ->
-    rnRuleBody body            `thenRn` \ (body', fvs) ->
-    returnRn (RuleD (IfaceRuleDecl var' body' src_loc), fvs `addOneFV` var')
+rnDecl (RuleD (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 (RuleD (IfaceRule rule_name vars' fn' args' rhs' src_loc), 
+             (fvs1 `plusFV` fvs2) `addOneFV` fn')
+
+rnDecl (RuleD (IfaceRuleOut fn rule))
+       -- This one is used for BuiltInRules
+       -- The rule itself is already done, but the thing
+       -- to attach it to is not.
+  = lookupOccRn fn             `thenRn` \ fn' ->
+    returnRn (RuleD (IfaceRuleOut fn' rule), unitFV fn')
 
 
-rnDecl (RuleD (RuleDecl rule_name tvs vars lhs rhs src_loc))
+rnDecl (RuleD (HsRule rule_name tvs vars lhs rhs src_loc))
   = ASSERT( null tvs )
     pushSrcLocRn src_loc                       $
 
   = ASSERT( null tvs )
     pushSrcLocRn src_loc                       $
 
@@ -400,7 +418,7 @@ rnDecl (RuleD (RuleDecl rule_name tvs vars lhs rhs src_loc))
        bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
     in
     mapRn (addErrRn . badRuleVar rule_name) bad_vars   `thenRn_`
        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),
+    returnRn (RuleD (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
              fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
   where
     doc = text "the transformation rule" <+> ptext rule_name
@@ -427,37 +445,33 @@ rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name], FreeVars)
 rnDerivs Nothing -- derivs not specified
   = returnRn (Nothing, emptyFVs)
 
 rnDerivs Nothing -- derivs not specified
   = returnRn (Nothing, emptyFVs)
 
-rnDerivs (Just ds)
-  = mapFvRn rn_deriv ds                `thenRn` \ (derivs, fvs) ->
-    returnRn (Just derivs, fvs)
+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, unitFV clas_name)
-
-               Just occs -> mapRn lookupImplicitOccRn occs     `thenRn` \ names ->
-                            returnRn (clas_name, mkNameSet (clas_name : names))
+    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 (RenamedConDecl, FreeVars)
 
 rnConDecl :: RdrNameConDecl -> RnMS (RenamedConDecl, FreeVars)
-rnConDecl (ConDecl name tvs cxt details locn)
+rnConDecl (ConDecl name wkr tvs cxt details locn)
   = pushSrcLocRn locn $
     checkConName name                  `thenRn_` 
     lookupBndrRn name                  `thenRn` \ new_name ->
   = pushSrcLocRn locn $
     checkConName name                  `thenRn_` 
     lookupBndrRn name                  `thenRn` \ new_name ->
+
+    mkImportedGlobalFromRdrName 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) -> 
     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,
+    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)
              cxt_fvs `plusFV` det_fvs)
   where
     doc = text "the definition of data constructor" <+> quotes (ppr name)
@@ -534,139 +548,199 @@ rnHsSigType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
 rnHsSigType doc_str ty
   = rnHsType (text "the type signature for" <+> doc_str) ty
     
 rnHsSigType doc_str ty
   = rnHsType (text "the type signature for" <+> doc_str) ty
     
-rnForAll doc forall_tyvars ctxt ty
-  = bindTyVarsFVRn doc forall_tyvars                   $ \ new_tyvars ->
-    rnContext doc ctxt                                 `thenRn` \ (new_ctxt, cxt_fvs) ->
-    rnHsType doc ty                                    `thenRn` \ (new_ty, ty_fvs) ->
-    returnRn (mkHsForAllTy new_tyvars new_ctxt new_ty,
-             cxt_fvs `plusFV` ty_fvs)
-
--- Check that each constraint mentions at least one of the forall'd type variables
--- Since the forall'd type variables are a subset of the free tyvars
--- of the tau-type part, this guarantees that every constraint mentions
--- at least one of the free tyvars in ty
-checkConstraints explicit_forall doc forall_tyvars ctxt ty
-   = mapRn check ctxt                  `thenRn` \ maybe_ctxt' ->
-     returnRn (catMaybes maybe_ctxt')
-           -- Remove problem ones, to avoid duplicate error message.
-   where
-     check ct@(_,tys)
-       | forall_mentioned = returnRn (Just ct)
-       | otherwise        = addErrRn (ctxtErr explicit_forall doc forall_tyvars ct ty) `thenRn_`
-                            returnRn Nothing
-        where
-         forall_mentioned = foldr ((||) . any (`elem` forall_tyvars) . extractHsTyRdrNames)
-                            False
-                            tys
-
-freeRdrTyVars   :: RdrNameHsType -> [RdrName]
-freeRdrTyVars ty =  filter isRdrTyVar (extractHsTyRdrNames ty)
-
+---------------------------------------
 rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
 
 rnHsType doc (HsForAllTy Nothing ctxt ty)
 rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
 
 rnHsType doc (HsForAllTy Nothing ctxt ty)
-       -- From source code (no kinds on tyvars)
+       -- 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
        -- Given the signature  C => T  we universally quantify 
        -- over FV(T) \ {in-scope-tyvars} 
   = getLocalNameEnv            `thenRn` \ name_env ->
     let
-       mentioned_in_tau = freeRdrTyVars ty
-       forall_tyvars    = filter (not . (`elemFM` name_env)) mentioned_in_tau
+       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
-    checkConstraints False doc forall_tyvars ctxt ty   `thenRn` \ ctxt' ->
-    rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty
+    rnForAll doc (map UserTyVar forall_tyvars) ctxt ty
 
 rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
        -- Explicit quantification.
 
 rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
        -- Explicit quantification.
-       -- Check that the forall'd tyvars are a subset of the
-       -- free tyvars in the tau-type part
-       -- That's only a warning... unless the tyvar is constrained by a 
-       -- context in which case it's an error
+       -- Check that the forall'd tyvars are actually 
+       -- mentioned in the type, and produce a warning if not
   = let
   = let
-       mentioned_in_tau  = freeRdrTyVars tau
-       mentioned_in_ctxt = nub [tv | (_,tys) <- ctxt,
-                                     ty <- tys,
-                                     tv <- freeRdrTyVars ty]
-
-       dubious_guys          = filter (`notElem` mentioned_in_tau) forall_tyvar_names
-               -- dubious = explicitly quantified but not mentioned in tau type
-
-       (bad_guys, warn_guys) = partition (`elem` mentioned_in_ctxt) dubious_guys
-               -- bad  = explicitly quantified and constrained, but not mentioned in tau
-               -- warn = explicitly quantified but not mentioned in ctxt or tau
- 
-       forall_tyvar_names    = map getTyVarName forall_tyvars
+       mentioned_in_tau                = extractHsTyRdrTyVars tau
+       mentioned_in_ctxt               = extractHsCtxtRdrTyVars ctxt
+       mentioned                       = nub (mentioned_in_tau ++ mentioned_in_ctxt)
+       forall_tyvar_names              = map getTyVarName forall_tyvars
+
+       -- Explicitly quantified but not mentioned in ctxt or tau
+       warn_guys                       = filter (`notElem` mentioned) forall_tyvar_names
     in
     in
-    mapRn_ (forAllErr doc tau) bad_guys                        `thenRn_`
     mapRn_ (forAllWarn doc tau) warn_guys                      `thenRn_`
     mapRn_ (forAllWarn doc tau) warn_guys                      `thenRn_`
-    checkConstraints True doc forall_tyvar_names ctxt tau      `thenRn` \ ctxt' ->
-    rnForAll doc forall_tyvars ctxt' tau
+    rnForAll doc forall_tyvars ctxt tau
 
 
-rnHsType doc (MonoTyVar tyvar)
+rnHsType doc (HsTyVar tyvar)
   = lookupOccRn tyvar          `thenRn` \ tyvar' ->
   = lookupOccRn tyvar          `thenRn` \ tyvar' ->
-    returnRn (MonoTyVar tyvar', unitFV tyvar')
+    returnRn (HsTyVar tyvar', unitFV tyvar')
 
 
-rnHsType doc (MonoFunTy ty1 ty2)
+rnHsType doc (HsFunTy ty1 ty2)
   = rnHsType doc ty1   `thenRn` \ (ty1', fvs1) ->
   = rnHsType doc ty1   `thenRn` \ (ty1', fvs1) ->
+       -- Might find a for-all as the arg of a function type
     rnHsType doc ty2   `thenRn` \ (ty2', fvs2) ->
     rnHsType doc ty2   `thenRn` \ (ty2', fvs2) ->
-    returnRn (MonoFunTy ty1' ty2', fvs1 `plusFV` 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 (MonoListTy ty)
+rnHsType doc (HsListTy ty)
   = rnHsType doc ty                            `thenRn` \ (ty', fvs) ->
   = rnHsType doc ty                            `thenRn` \ (ty', fvs) ->
-    returnRn (MonoListTy ty', fvs `addOneFV` listTyCon_name)
-
-rnHsType doc (MonoTupleTy tys boxed)
-  = rnHsTypes doc tys                  `thenRn` \ (tys', fvs) ->
-    returnRn (MonoTupleTy tys' boxed, fvs `addOneFV` tup_con_name)
+    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
-    tup_con_name = tupleTyCon_name boxed (length tys)
+    n' = tupleTyCon_name boxity (length tys)
+  
 
 
-rnHsType doc (MonoTyApp ty1 ty2)
+rnHsType doc (HsAppTy ty1 ty2)
   = rnHsType doc ty1           `thenRn` \ (ty1', fvs1) ->
     rnHsType doc ty2           `thenRn` \ (ty2', fvs2) ->
   = rnHsType doc ty1           `thenRn` \ (ty1', fvs1) ->
     rnHsType doc ty2           `thenRn` \ (ty2', fvs2) ->
-    returnRn (MonoTyApp ty1' ty2', fvs1 `plusFV` fvs2)
-
-rnHsType doc (MonoDictTy clas tys)
-  = lookupOccRn clas           `thenRn` \ clas' ->
-    rnHsTypes doc tys          `thenRn` \ (tys', fvs) ->
-    returnRn (MonoDictTy clas' tys', fvs `addOneFV` clas')
-
-rnHsType doc (MonoUsgTy usg ty)
-  = rnHsType doc ty             `thenRn` \ (ty', fvs) ->
-    returnRn (MonoUsgTy usg ty', fvs)
+    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}
 
 
 rnHsTypes doc tys = mapFvRn (rnHsType doc) tys
 \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 :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
+-- 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)
+\end{code}
+
+\begin{code}
+rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
 rnContext doc ctxt
 rnContext doc ctxt
-  = mapAndUnzipRn rn_ctxt ctxt         `thenRn` \ (theta, fvs_s) ->
+  = mapAndUnzipRn rn_pred ctxt         `thenRn` \ (theta, fvs_s) ->
     let
     let
-       (_, dup_asserts) = removeDups cmp_assert theta
+       (_, dups) = removeDupsEq theta
+               -- We only have equality, not ordering
     in
        -- Check for duplicate assertions
        -- If this isn't an error, then it ought to be:
     in
        -- 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) dups          `thenRn_`
     returnRn (theta, plusFVs fvs_s)
   where
     returnRn (theta, plusFVs fvs_s)
   where
-    rn_ctxt (clas, tys)
-      =        lookupOccRn clas                `thenRn` \ clas_name ->
-       rnHsTypes doc tys               `thenRn` \ (tys', fvs) ->
-       returnRn ((clas_name, tys'), fvs `addOneFV` clas_name)
+       --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)
 
 
-    cmp_assert (c1,tys1) (c2,tys2)
-      = (c1 `compare` c2) `thenCmp` (cmpHsTypes compare tys1 tys2)
+rnPred doc (HsPIParam n ty)
+  = getIPName 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}
@@ -676,24 +750,16 @@ rnIdInfo (HsWorker worker)
   = lookupOccRn worker                 `thenRn` \ worker' ->
     returnRn (HsWorker worker', unitFV worker')
 
   = lookupOccRn worker                 `thenRn` \ worker' ->
     returnRn (HsWorker worker', unitFV worker')
 
-rnIdInfo (HsUnfold inline (Just expr)) = rnCoreExpr expr       `thenRn` \ (expr', fvs) ->
-                                         returnRn (HsUnfold inline (Just expr'), fvs)
-rnIdInfo (HsUnfold inline Nothing)     = returnRn (HsUnfold inline Nothing, emptyFVs)
+rnIdInfo (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 (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)
+rnIdInfo HsNoCafRefs           = returnRn (HsNoCafRefs, emptyFVs)
+rnIdInfo HsCprInfo             = returnRn (HsCprInfo, emptyFVs)
 
 
-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}
 rnCoreExpr (UfType ty)
 
 \begin{code}
 rnCoreExpr (UfType ty)
@@ -704,15 +770,21 @@ rnCoreExpr (UfVar v)
   = lookupOccRn v      `thenRn` \ v' ->
     returnRn (UfVar v', unitFV v')
 
   = lookupOccRn v      `thenRn` \ v' ->
     returnRn (UfVar v', unitFV v')
 
-rnCoreExpr (UfCon con args) 
-  = rnUfCon con                        `thenRn` \ (con', fvs1) ->
-    mapFvRn rnCoreExpr args    `thenRn` \ (args', fvs2) ->
-    returnRn (UfCon con' args', fvs1 `plusFV` fvs2)
+rnCoreExpr (UfLit l)
+  = returnRn (UfLit l, emptyFVs)
+
+rnCoreExpr (UfLitLit l ty)
+  = rnHsType (text "litlit") ty        `thenRn` \ (ty', fvs) ->
+    returnRn (UfLitLit l ty', fvs)
+
+rnCoreExpr (UfCCall cc ty)
+  = rnHsType (text "ccall") ty `thenRn` \ (ty', fvs) ->
+    returnRn (UfCCall cc ty', fvs)
 
 rnCoreExpr (UfTuple con args) 
 
 rnCoreExpr (UfTuple con args) 
-  = lookupOccRn con            `thenRn` \ con' ->
-    mapFvRn rnCoreExpr args    `thenRn` \ (args', fvs) ->
-    returnRn (UfTuple con' args', fvs `addOneFV` con')
+  = rnHsTupConWkr con                  `thenRn` \ (con', fvs1) ->
+    mapFvRn rnCoreExpr args            `thenRn` \ (args', fvs2) ->
+    returnRn (UfTuple con' args', fvs1 `plusFV` fvs2)
 
 rnCoreExpr (UfApp fun arg)
   = rnCoreExpr fun             `thenRn` \ (fun', fv1) ->
 
 rnCoreExpr (UfApp fun arg)
   = rnCoreExpr fun             `thenRn` \ (fun', fv1) ->
@@ -776,7 +848,7 @@ rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b              $ \ name' ->
 
 \begin{code}
 rnCoreAlt (con, bndrs, rhs)
 
 \begin{code}
 rnCoreAlt (con, bndrs, rhs)
-  = rnUfCon con                                `thenRn` \ (con', fvs1) ->
+  = rnUfCon con bndrs                  `thenRn` \ (con', fvs1) ->
     bindCoreLocalsFVRn bndrs           ( \ bndrs' ->
        rnCoreExpr rhs                  `thenRn` \ (rhs', fvs2) ->
        returnRn ((con', bndrs', rhs'), fvs2)
     bindCoreLocalsFVRn bndrs           ( \ bndrs' ->
        rnCoreExpr rhs                  `thenRn` \ (rhs', fvs2) ->
        returnRn ((con', bndrs', rhs'), fvs2)
@@ -792,37 +864,35 @@ rnNote UfInlineCall = returnRn (UfInlineCall, emptyFVs)
 rnNote UfInlineMe   = returnRn (UfInlineMe, emptyFVs)
 
 
 rnNote UfInlineMe   = returnRn (UfInlineMe, emptyFVs)
 
 
-rnUfCon UfDefault
+rnUfCon UfDefault _
   = returnRn (UfDefault, emptyFVs)
 
   = returnRn (UfDefault, emptyFVs)
 
-rnUfCon (UfDataCon con)
+rnUfCon (UfTupleAlt tup_con) bndrs
+  = rnHsTupCon tup_con                 `thenRn` \ (HsTupCon con' _, fvs) -> 
+    returnRn (UfDataAlt con', fvs)
+       -- Makes the type checker a little easier
+
+rnUfCon (UfDataAlt con) _
   = lookupOccRn con            `thenRn` \ con' ->
   = lookupOccRn con            `thenRn` \ con' ->
-    returnRn (UfDataCon con', unitFV con')
+    returnRn (UfDataAlt con', unitFV con')
 
 
-rnUfCon (UfLitCon lit)
-  = returnRn (UfLitCon lit, emptyFVs)
+rnUfCon (UfLitAlt lit) _
+  = returnRn (UfLitAlt lit, emptyFVs)
 
 
-rnUfCon (UfLitLitCon lit ty)
+rnUfCon (UfLitLitAlt lit ty) _
   = rnHsType (text "litlit") ty                `thenRn` \ (ty', fvs) ->
   = rnHsType (text "litlit") ty                `thenRn` \ (ty', fvs) ->
-    returnRn (UfLitLitCon lit ty', fvs)
-
-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)
+    returnRn (UfLitLitAlt lit ty', fvs)
 \end{code}
 
 %*********************************************************
 \end{code}
 
 %*********************************************************
-%*                                                     *
+%*                                                      *
 \subsection{Rule shapes}
 \subsection{Rule shapes}
-%*                                                     *
+%*                                                      *
 %*********************************************************
 
 Check the shape of a transformation rule LHS.  Currently
 %*********************************************************
 
 Check the shape of a transformation rule LHS.  Currently
-we only allow LHSs of the form (f e1 .. en), where f is
-not one of the forall'd variables.
+we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
+not one of the @forall@'d variables.
 
 \begin{code}
 validRuleLhs foralls lhs
 
 \begin{code}
 validRuleLhs foralls lhs
@@ -835,9 +905,9 @@ validRuleLhs foralls lhs
 
 
 %*********************************************************
 
 
 %*********************************************************
-%*                                                     *
+%*                                                      *
 \subsection{Errors}
 \subsection{Errors}
-%*                                                     *
+%*                                                      *
 %*********************************************************
 
 \begin{code}
 %*********************************************************
 
 \begin{code}
@@ -850,12 +920,6 @@ classTyVarNotInOpTyErr clas_tyvar sig
                       ptext SLIT("does not appear in method signature")])
         4 (ppr sig)
 
                       ptext SLIT("does not appear in method signature")])
         4 (ppr sig)
 
-dupClassAssertWarn ctxt (assertion : dups)
-  = sep [hsep [ptext SLIT("Duplicate class assertion"), 
-              quotes (pprClassAssertion assertion),
-              ptext SLIT("in the context:")],
-        nest 4 (pprContext ctxt <+> ptext SLIT("..."))]
-
 badDataCon name
    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 
 badDataCon name
    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 
@@ -885,12 +949,11 @@ forAllErr doc ty tyvar
       $$
       (ptext SLIT("In") <+> doc))
 
       $$
       (ptext SLIT("In") <+> doc))
 
-ctxtErr explicit_forall doc tyvars constraint ty
-  = sep [ptext SLIT("None of the type variable(s) in the constraint") <+> quotes (pprClassAssertion constraint),
-        if explicit_forall then
-          nest 4 (ptext SLIT("is universally quantified (i.e. bound by the forall)"))
-        else
-          nest 4 (ptext SLIT("appears in the type") <+> quotes (ppr ty))
+univErr doc constraint ty
+  = sep [ptext SLIT("All of the type variable(s) in the constraint")
+          <+> quotes (ppr constraint) 
+         <+> ptext SLIT("are already in scope"),
+        nest 4 (ptext SLIT("At least one must be universally quantified here"))
     ]
     $$
     (ptext SLIT("In") <+> doc)
     ]
     $$
     (ptext SLIT("In") <+> doc)
@@ -905,4 +968,18 @@ 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")]
   = 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 (ppr 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}
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)