projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[project @ 2000-03-24 17:49:29 by simonpj]
[ghc-hetmet.git] / ghc / compiler / rename / RnSource.lhs
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 0c0475f..982acda 100644 (file)
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -4,25 +4,25 @@
 \section[RnSource]{Main pass of renamer}
 
 \begin{code}
 \section[RnSource]{Main pass of renamer}
 
 \begin{code}
-module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType ) where
+module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType, rnHsPolyType ) where
 
 #include "HsVersions.h"
 
 import RnExpr
 import HsSyn
 import HsPragmas
 
 #include "HsVersions.h"
 
 import RnExpr
 import HsSyn
 import HsPragmas
-import HsTypes         ( getTyVarName, pprClassAssertion, cmpHsTypes )
+import HsTypes         ( getTyVarName, pprHsPred, cmpHsTypes )
 import RdrName         ( RdrName, isRdrDataCon, rdrNameOcc, isRdrTyVar )
 import RdrHsSyn                ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
 import RdrName         ( RdrName, isRdrDataCon, rdrNameOcc, isRdrTyVar )
 import RdrHsSyn                ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
-                         extractRuleBndrsTyVars, extractHsTyRdrTyVars
+                         extractRuleBndrsTyVars, extractHsTyRdrTyVars, extractHsTysRdrTyVars
                        )
 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, 
+import RnEnv           ( bindTyVarsRn, lookupBndrRn, lookupOccRn, getIPName,
                          lookupImplicitOccRn, 
                          lookupImplicitOccRn, 
-                         bindLocalsRn, bindLocalRn, bindLocalsFVRn,
+                         bindLocalsRn, bindLocalRn, bindLocalsFVRn, bindUVarRn,
                          bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn,
                          bindCoreLocalFVRn, bindCoreLocalsFVRn,
                          checkDupOrQualNames, checkDupNames,
                          bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn,
                          bindCoreLocalFVRn, bindCoreLocalsFVRn,
                          checkDupOrQualNames, checkDupNames,
@@ -32,6 +32,8 @@ import RnEnv          ( bindTyVarsRn, lookupBndrRn, lookupOccRn,
                        )
 import RnMonad
 
                        )
 import RnMonad
 
+import FunDeps         ( oclose )
+
 import Name            ( Name, OccName,
                          ExportFlag(..), Provenance(..), 
                          nameOccName, NamedThing(..)
 import Name            ( Name, OccName,
                          ExportFlag(..), Provenance(..), 
                          nameOccName, NamedThing(..)
@@ -40,16 +42,18 @@ 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,
+                         deRefStablePtr_NAME, makeStablePtr_NAME, bindIO_NAME
                        )
 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}
@@ -61,6 +65,8 @@ It also does the following error checks:
 \item
 Checks that tyvars are used properly. This includes checking
 for undefined tyvars, and tyvars in contexts that are ambiguous.
 \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 
@@ -106,7 +112,7 @@ rnDecl (ValD binds) = rnTopBinds binds      `thenRn` \ (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 doc_str ty                `thenRn` \ (ty',fvs1) ->
+    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
     mapFvRn rnIdInfo id_infos  `thenRn` \ (id_infos', fvs2) -> 
     returnRn (SigD (IfaceSig name' ty' id_infos' loc), fvs1 `plusFV` fvs2)
   where
@@ -153,13 +159,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) ->
+    rnHsPolyType 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' ->
@@ -173,6 +184,7 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas
        -- 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
@@ -181,6 +193,9 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas
        -- Check the superclasses
     rnContext cls_doc context                  `thenRn` \ (context', cxt_fvs) ->
 
        -- 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.
        -- Check the signatures
     let
            -- First process the class op sigs, then the fixity sigs.
@@ -188,11 +203,11 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas
          (fix_sigs, non_sigs)   = partition isFixitySig  non_op_sigs
     in
     checkDupOrQualNames sig_doc sig_rdr_names_w_locs   `thenRn_` 
          (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) op_sigs
+    mapFvRn (rn_op cname' clas_tyvar_names fds') op_sigs
     `thenRn` \ (sigs', sig_fvs) ->
     mapRn_  (unknownSigErr) non_sigs                   `thenRn_`
     let
     `thenRn` \ (sigs', sig_fvs) ->
     mapRn_  (unknownSigErr) non_sigs                   `thenRn_`
     let
-     binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
+     binders = mkNameSet [ nm | (ClassOpSig nm _ _ _ _) <- sigs' ]
     in
     renameSigs False binders lookupOccRn fix_sigs
     `thenRn` \ (fixs', fix_fvs) ->
     in
     renameSigs False binders lookupOccRn fix_sigs
     `thenRn` \ (fixs', fix_fvs) ->
@@ -208,11 +223,12 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas
        -- 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' (fixs' ++ 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
             )
     )
@@ -221,11 +237,11 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas
     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 ->
 
       = pushSrcLocRn locn $
        lookupBndrRn op                         `thenRn` \ op_name ->
 
@@ -233,39 +249,29 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas
        rnHsSigType (quotes (ppr op)) ty        `thenRn` \ (new_ty, op_ty_fvs)  ->
        let
            check_in_op_ty clas_tyvar =
        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)
+                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 ->
                         (classTyVarNotInOpTyErr clas_tyvar sig)
        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
                    lookupImplicitOccRn dm_rdr_name     `thenRn` \ dm_name ->
                ->      -- 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
+                   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) ->
 
 
-           (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)
+       returnRn (ClassOpSig op_name dm_name final_explicit_dm new_ty locn, op_ty_fvs `plusFV` dm_fvs)
 \end{code}
 
 
 \end{code}
 
 
@@ -348,8 +354,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}
@@ -363,22 +368,28 @@ 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 
+       ok_ext_nm Dynamic                = True
+       ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb
+       ok_ext_nm (ExtName nm Nothing)   = isCLabelString nm
+
        fvs1 = case imp_exp of
                FoImport _ | not isDyn  -> emptyFVs
                FoLabel                 -> emptyFVs
                FoExport   | isDyn      -> mkNameSet [makeStablePtr_NAME,
                                                      deRefStablePtr_NAME,
                                                      bindIO_NAME]
        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
                _ -> emptyFVs
     in
-    rnHsSigType fo_decl_msg ty                 `thenRn` \ (ty', fvs2) ->
+    checkRn (ok_ext_nm ext_nm) (badExtName ext_nm)     `thenRn_`
+    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
 \end{code}
 
 %*********************************************************
 \end{code}
 
 %*********************************************************
@@ -420,7 +431,7 @@ rnDecl (RuleD (RuleDecl rule_name tvs vars lhs rhs src_loc))
     get_var (RuleBndrSig v _) = v
 
     rn_var (RuleBndr v, id)     = returnRn (RuleBndr id, emptyFVs)
     get_var (RuleBndrSig v _) = v
 
     rn_var (RuleBndr v, id)     = returnRn (RuleBndr id, emptyFVs)
-    rn_var (RuleBndrSig v t, id) = rnHsType doc t      `thenRn` \ (t', fvs) ->
+    rn_var (RuleBndrSig v t, id) = rnHsPolyType doc t  `thenRn` \ (t', fvs) ->
                                   returnRn (RuleBndrSig id t', fvs)
 \end{code}
 
                                   returnRn (RuleBndrSig id t', fvs)
 \end{code}
 
@@ -437,37 +448,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)
@@ -482,7 +489,7 @@ rnConDetails doc locn (InfixCon ty1 ty2)
     returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2)
 
 rnConDetails doc locn (NewCon ty mb_field)
     returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2)
 
 rnConDetails doc locn (NewCon ty mb_field)
-  = rnHsType doc ty                    `thenRn` \ (new_ty, fvs) ->
+  = 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 mb_field                  `thenRn` \ new_mb_field  ->
     returnRn (NewCon new_ty new_mb_field, fvs)
   where
@@ -504,15 +511,15 @@ rnField doc (names, ty)
     returnRn ((new_names, new_ty), fvs) 
 
 rnBangTy doc (Banged ty)
     returnRn ((new_names, new_ty), fvs) 
 
 rnBangTy doc (Banged ty)
-  = rnHsType doc ty            `thenRn` \ (new_ty, fvs) ->
+  = rnHsPolyType doc ty                `thenRn` \ (new_ty, fvs) ->
     returnRn (Banged new_ty, fvs)
 
 rnBangTy doc (Unbanged ty)
     returnRn (Banged new_ty, fvs)
 
 rnBangTy doc (Unbanged ty)
-  = rnHsType doc ty            `thenRn` \ (new_ty, fvs) ->
+  = rnHsPolyType doc ty        `thenRn` \ (new_ty, fvs) ->
     returnRn (Unbanged new_ty, fvs)
 
 rnBangTy doc (Unpacked ty)
     returnRn (Unbanged new_ty, fvs)
 
 rnBangTy doc (Unpacked ty)
-  = rnHsType doc ty            `thenRn` \ (new_ty, fvs) ->
+  = rnHsPolyType doc ty        `thenRn` \ (new_ty, fvs) ->
     returnRn (Unpacked new_ty, fvs)
 
 -- This data decl will parse OK
     returnRn (Unpacked new_ty, fvs)
 
 -- This data decl will parse OK
@@ -542,37 +549,16 @@ rnHsSigType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
        -- rnHsSigType is used for source-language type signatures,
        -- which use *implicit* universal quantification.
 rnHsSigType doc_str ty
        -- rnHsSigType is used for source-language type signatures,
        -- which use *implicit* universal quantification.
 rnHsSigType doc_str ty
-  = rnHsType (text "the type signature for" <+> doc_str) ty
+  = rnHsPolyType (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) . extractHsTyRdrTyVars)
-                            False
-                            tys
-
-rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
-
-rnHsType doc (HsForAllTy Nothing ctxt ty)
-       -- From source code (no kinds on tyvars)
+---------------------------------------
+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)
+       -- 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 ->
        -- Given the signature  C => T  we universally quantify 
        -- over FV(T) \ {in-scope-tyvars} 
   = getLocalNameEnv            `thenRn` \ name_env ->
@@ -580,10 +566,10 @@ rnHsType doc (HsForAllTy Nothing ctxt ty)
        mentioned_in_tau = extractHsTyRdrTyVars ty
        forall_tyvars    = filter (not . (`elemFM` name_env)) mentioned_in_tau
     in
        mentioned_in_tau = extractHsTyRdrTyVars ty
        forall_tyvars    = filter (not . (`elemFM` name_env)) mentioned_in_tau
     in
-    checkConstraints False doc forall_tyvars ctxt ty   `thenRn` \ ctxt' ->
+    checkConstraints doc forall_tyvars mentioned_in_tau 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)
+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
        -- Explicit quantification.
        -- Check that the forall'd tyvars are a subset of the
        -- free tyvars in the tau-type part
@@ -591,9 +577,11 @@ rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
        -- context in which case it's an error
   = let
        mentioned_in_tau  = extractHsTyRdrTyVars tau
        -- context in which case it's an error
   = let
        mentioned_in_tau  = extractHsTyRdrTyVars tau
-       mentioned_in_ctxt = nub [tv | (_,tys) <- ctxt,
-                                     ty <- tys,
+       mentioned_in_ctxt = nub [tv | p <- ctxt,
+                                     ty <- tys_of_pred p,
                                      tv <- extractHsTyRdrTyVars ty]
                                      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
 
        dubious_guys          = filter (`notElem` mentioned_in_tau) forall_tyvar_names
                -- dubious = explicitly quantified but not mentioned in tau type
@@ -604,27 +592,69 @@ rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
  
        forall_tyvar_names    = map getTyVarName forall_tyvars
     in
  
        forall_tyvar_names    = map getTyVarName forall_tyvars
     in
-    mapRn_ (forAllErr doc tau) bad_guys                        `thenRn_`
-    mapRn_ (forAllWarn doc tau) warn_guys                      `thenRn_`
-    checkConstraints True doc forall_tyvar_names ctxt tau      `thenRn` \ ctxt' ->
+    -- 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
 
     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' ->
     returnRn (MonoTyVar tyvar', unitFV tyvar')
 
 rnHsType doc (MonoFunTy ty1 ty2)
 rnHsType doc (MonoTyVar tyvar)
   = lookupOccRn tyvar          `thenRn` \ tyvar' ->
     returnRn (MonoTyVar tyvar', unitFV tyvar')
 
 rnHsType doc (MonoFunTy ty1 ty2)
-  = rnHsType doc ty1   `thenRn` \ (ty1', fvs1) ->
-    rnHsType doc ty2   `thenRn` \ (ty2', fvs2) ->
+  = 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)
 
     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)
 rnHsType doc (MonoTupleTy tys boxed)
-  = rnHsTypes doc tys                  `thenRn` \ (tys', fvs) ->
-    returnRn (MonoTupleTy tys' boxed, fvs `addOneFV` tup_con_name)
+  = (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)
 
   where
     tup_con_name = tupleTyCon_name boxed (length tys)
 
@@ -633,14 +663,34 @@ rnHsType doc (MonoTyApp ty1 ty2)
     rnHsType doc ty2           `thenRn` \ (ty2', fvs2) ->
     returnRn (MonoTyApp ty1' ty2', fvs1 `plusFV` fvs2)
 
     rnHsType doc ty2           `thenRn` \ (ty2', fvs2) ->
     returnRn (MonoTyApp ty1' ty2', fvs1 `plusFV` fvs2)
 
+rnHsType doc (MonoIParamTy n ty)
+  = getIPName n                        `thenRn` \ name ->
+    rnHsType doc ty            `thenRn` \ (ty', fvs) ->
+    returnRn (MonoIParamTy name ty', fvs)
+
 rnHsType doc (MonoDictTy clas tys)
   = lookupOccRn clas           `thenRn` \ clas' ->
     rnHsTypes doc tys          `thenRn` \ (tys', fvs) ->
     returnRn (MonoDictTy clas' tys', fvs `addOneFV` clas')
 
 rnHsType doc (MonoDictTy clas tys)
   = lookupOccRn clas           `thenRn` \ clas' ->
     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)
 rnHsType doc (MonoUsgTy usg ty)
-  = rnHsType doc ty             `thenRn` \ (ty', fvs) ->
-    returnRn (MonoUsgTy usg ty', fvs)
+  = 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
+    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}
 
 rnHsTypes doc tys = mapFvRn (rnHsType doc) tys
 \end{code}
@@ -650,25 +700,43 @@ rnHsTypes doc tys = mapFvRn (rnHsType doc) tys
 rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
 
 rnContext doc ctxt
 rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
 
 rnContext doc ctxt
-  = mapAndUnzipRn rn_ctxt ctxt         `thenRn` \ (theta, fvs_s) ->
+  = mapAndUnzipRn (rnPred doc) ctxt    `thenRn` \ (theta, fvs_s) ->
     let
     let
-       (_, dup_asserts) = removeDups cmp_assert theta
+       (_, dup_asserts) = removeDups (cmpHsPred compare) theta
     in
        -- Check for duplicate assertions
        -- If this isn't an error, then it ought to be:
     mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts  `thenRn_`
 
     returnRn (theta, plusFVs fvs_s)
     in
        -- Check for duplicate assertions
        -- If this isn't an error, then it ought to be:
     mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts  `thenRn_`
 
     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)
 
 
-    cmp_assert (c1,tys1) (c2,tys2)
-      = (c1 `compare` c2) `thenCmp` (cmpHsTypes compare tys1 tys2)
+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}
 
 \end{code}
 
+\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
+    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}
 
 %*********************************************************
 %*                                                      *
 
 %*********************************************************
 %*                                                      *
@@ -683,13 +751,12 @@ 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 HsNoCafRefs           = returnRn (HsNoCafRefs, emptyFVs)
+rnIdInfo HsCprInfo             = returnRn (HsCprInfo, emptyFVs)
 rnIdInfo (HsSpecialise rule_body) = rnRuleBody rule_body
                                    `thenRn` \ (rule_body', fvs) ->
                                    returnRn (HsSpecialise rule_body', fvs)
 rnIdInfo (HsSpecialise rule_body) = rnRuleBody rule_body
                                    `thenRn` \ (rule_body', fvs) ->
                                    returnRn (HsSpecialise rule_body', fvs)
@@ -705,17 +772,23 @@ rnRuleBody (UfRuleBody str vars args rhs)
 
 \begin{code}
 rnCoreExpr (UfType ty)
 
 \begin{code}
 rnCoreExpr (UfType ty)
-  = rnHsType (text "unfolding type") ty        `thenRn` \ (ty', fvs) ->
+  = rnHsPolyType (text "unfolding type") ty    `thenRn` \ (ty', fvs) ->
     returnRn (UfType ty', fvs)
 
 rnCoreExpr (UfVar v)
   = lookupOccRn v      `thenRn` \ v' ->
     returnRn (UfVar v', unitFV v')
 
     returnRn (UfType ty', fvs)
 
 rnCoreExpr (UfVar 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)
+  = rnHsPolyType (text "ccall") ty     `thenRn` \ (ty', fvs) ->
+    returnRn (UfCCall cc ty', fvs)
 
 rnCoreExpr (UfTuple con args) 
   = lookupOccRn con            `thenRn` \ con' ->
 
 rnCoreExpr (UfTuple con args) 
   = lookupOccRn con            `thenRn` \ con' ->
@@ -764,7 +837,7 @@ rnCoreExpr (UfLet (UfRec pairs) body)
 
 \begin{code}
 rnCoreBndr (UfValBinder name ty) thing_inside
 
 \begin{code}
 rnCoreBndr (UfValBinder name ty) thing_inside
-  = rnHsType doc ty            `thenRn` \ (ty', fvs1) ->
+  = rnHsPolyType doc ty                `thenRn` \ (ty', fvs1) ->
     bindCoreLocalFVRn name     ( \ name' ->
            thing_inside (UfValBinder name' ty')
     )                          `thenRn` \ (result, fvs2) ->
     bindCoreLocalFVRn name     ( \ name' ->
            thing_inside (UfValBinder name' ty')
     )                          `thenRn` \ (result, fvs2) ->
@@ -792,7 +865,7 @@ rnCoreAlt (con, bndrs, rhs)
     returnRn (result, fvs1 `plusFV` fvs3)
 
 rnNote (UfCoerce ty)
     returnRn (result, fvs1 `plusFV` fvs3)
 
 rnNote (UfCoerce ty)
-  = rnHsType (text "unfolding coerce") ty      `thenRn` \ (ty', fvs) ->
+  = rnHsPolyType (text "unfolding coerce") ty  `thenRn` \ (ty', fvs) ->
     returnRn (UfCoerce ty', fvs)
 
 rnNote (UfSCC cc)   = returnRn (UfSCC cc, emptyFVs)
     returnRn (UfCoerce ty', fvs)
 
 rnNote (UfSCC cc)   = returnRn (UfSCC cc, emptyFVs)
@@ -803,23 +876,16 @@ rnNote UfInlineMe   = returnRn (UfInlineMe, emptyFVs)
 rnUfCon UfDefault
   = returnRn (UfDefault, emptyFVs)
 
 rnUfCon UfDefault
   = returnRn (UfDefault, emptyFVs)
 
-rnUfCon (UfDataCon con)
+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)
-  = 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)
+rnUfCon (UfLitLitAlt lit ty)
+  = rnHsPolyType (text "litlit") ty            `thenRn` \ (ty', fvs) ->
+    returnRn (UfLitLitAlt lit ty', fvs)
 \end{code}
 
 %*********************************************************
 \end{code}
 
 %*********************************************************
@@ -860,9 +926,9 @@ 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 <+> ptext SLIT("..."))]
+        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)]
@@ -893,17 +959,25 @@ 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 (pprHsPred 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)
 
+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 =>."))]
+    $$
+    (ptext SLIT("In") <+> doc)
+
+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)]
 badRuleLhsErr name lhs
   = sep [ptext SLIT("Rule") <+> ptext name <> colon,
         nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
@@ -914,4 +988,8 @@ 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")]
 \end{code}
 \end{code}
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)