[project @ 1997-06-18 23:52:36 by simonpj]
[ghc-hetmet.git] / ghc / compiler / rename / RnSource.lhs
index 16cd506..ff3620e 100644 (file)
@@ -6,35 +6,62 @@
 \begin{code}
 #include "HsVersions.h"
 
-module RnSource ( rnSource, rnPolyType ) where
+module RnSource ( rnDecl, rnHsType, rnHsSigType ) where
 
-import Ubiq
-import RnLoop          -- *check* the RnPass4/RnExpr4/RnBinds4 loop-breaking
+IMPORT_1_3(List(partition))
+IMP_Ubiq()
+
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
+IMPORT_DELOOPER(RnLoop)                -- *check* the RnPass/RnExpr/RnBinds loop-breaking
+#else
+import {-# SOURCE #-} RnExpr
+#endif
 
 import HsSyn
+import HsDecls         ( HsIdInfo(..) )
 import HsPragmas
+import HsTypes         ( getTyVarName )
 import RdrHsSyn
 import RnHsSyn
-import RnMonad
+import HsCore
+import CmdLineOpts     ( opt_IgnoreIfacePragmas )
+
 import RnBinds         ( rnTopBinds, rnMethodBinds )
+import RnEnv           ( bindTyVarsRn, lookupBndrRn, lookupOccRn, lookupImplicitOccRn, bindLocalsRn,
+                         newSysName, newDfunName, checkDupOrQualNames, checkDupNames,
+                         listType_RDR, tupleType_RDR )
+import RnMonad
 
-import Bag             ( bagToList )
-import Class           ( derivableClassKeys )
+import Name            ( Name, isLocallyDefined, 
+                         OccName(..), occNameString, prefixOccName,
+                         ExportFlag(..),
+                         Provenance,
+                         SYN_IE(NameSet), unionNameSets, emptyNameSet, mkNameSet, unitNameSet,
+                         elemNameSet
+                       )
+import ErrUtils                ( addErrLoc, addShortErrLocLine, addShortWarnLocLine )
+import FiniteMap       ( emptyFM, lookupFM, addListToFM_C )
+import Id              ( GenId{-instance NamedThing-} )
+import IdInfo          ( IdInfo, StrictnessInfo(..), FBTypeInfo, DemandInfo, ArgUsageInfo )
+import SpecEnv         ( SpecEnv )
+import Lex             ( isLexCon )
+import CoreUnfold      ( Unfolding(..), SimpleUnfolding )
+import MagicUFs                ( MagicUnfoldingFun )
+import PrelInfo                ( derivingOccurrences, evalClass_RDR, numClass_RDR, allClass_NAME )
 import ListSetOps      ( unionLists, minusList )
 import Maybes          ( maybeToBool, catMaybes )
-import Name            ( isLocallyDefined, isAvarid, getLocalName, ExportFlag(..), RdrName )
+import Bag             ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList )
+import Outputable      ( PprStyle(..), Outputable(..){-instances-} )
 import Pretty
 import SrcLoc          ( SrcLoc )
 import Unique          ( Unique )
-import UniqFM          ( addListToUFM, listToUFM )
-import UniqSet         ( UniqSet(..) )
-import Util            ( isn'tIn, panic, assertPanic )
-
-rnExports mods Nothing     = returnRn (\n -> ExportAll)
-rnExports mods (Just exps) = returnRn (\n -> ExportAll)
+import UniqSet         ( SYN_IE(UniqSet) )
+import UniqFM          ( UniqFM, lookupUFM )
+import Util
+IMPORT_1_3(List(nub))
 \end{code}
 
-rnSource `renames' the source module and export list.
+rnDecl `renames' declarations.
 It simultaneously performs dependency analysis and precedence parsing.
 It also does the following error checks:
 \begin{enumerate}
@@ -48,56 +75,29 @@ Checks the (..) etc constraints in the export list.
 \end{enumerate}
 
 
-\begin{code}
-rnSource :: [Module]                           -- imported modules
-        -> Bag RenamedFixityDecl               -- fixity info for imported names
-        -> RdrNameHsModule
-        -> RnM s (RenamedHsModule,
-                  Name -> ExportFlag,          -- export info
-                  Bag (RnName, RdrName))       -- occurrence info
-
-rnSource imp_mods imp_fixes (HsModule mod version exports _ fixes
-                              ty_decls specdata_sigs class_decls
-                              inst_decls specinst_sigs defaults
-                              binds _ src_loc)
-
-  = pushSrcLocRn src_loc $
-
-    rnExports (mod:imp_mods) exports   `thenRn` \ exported_fn ->
-    rnFixes fixes                      `thenRn` \ src_fixes ->
-    let
-       pair_name (InfixL n i) = (n, i)
-       pair_name (InfixR n i) = (n, i)
-       pair_name (InfixN n i) = (n, i)
+%*********************************************************
+%*                                                     *
+\subsection{Value declarations}
+%*                                                     *
+%*********************************************************
 
-       imp_fixes_fm = listToUFM (map pair_name (bagToList imp_fixes))
-       all_fixes_fm = addListToUFM imp_fixes_fm (map pair_name src_fixes)
-    in
-    setExtraRn {-all_fixes_fm-}(panic "rnSource:all_fixes_fm") $
-
-    mapRn rnTyDecl     ty_decls        `thenRn` \ new_ty_decls ->
-    mapRn rnSpecDataSig specdata_sigs  `thenRn` \ new_specdata_sigs ->
-    mapRn rnClassDecl  class_decls     `thenRn` \ new_class_decls ->
-    mapRn rnInstDecl   inst_decls      `thenRn` \ new_inst_decls ->
-    mapRn rnSpecInstSig specinst_sigs   `thenRn` \ new_specinst_sigs ->
-    rnDefaultDecl      defaults        `thenRn` \ new_defaults ->
-    rnTopBinds binds                   `thenRn` \ new_binds ->
-
-    getOccurrenceUpRn                  `thenRn` \ occ_info ->
-
-    returnRn (
-             HsModule mod version
-               trashed_exports trashed_imports
-               {-new_fixes-}(panic "rnSource:new_fixes (Hi, Patrick!)")
-               new_ty_decls new_specdata_sigs new_class_decls
-               new_inst_decls new_specinst_sigs new_defaults
-               new_binds [] src_loc,
-             exported_fn,
-             occ_info
-            )
-  where
-    trashed_exports = panic "rnSource:trashed_exports"
-    trashed_imports = panic "rnSource:trashed_imports"
+\begin{code}
+rnDecl :: RdrNameHsDecl -> RnMS s RenamedHsDecl
+
+rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ new_binds ->
+                     returnRn (ValD new_binds)
+
+
+rnDecl (SigD (IfaceSig name ty id_infos loc))
+  = pushSrcLocRn loc $
+    lookupBndrRn name          `thenRn` \ name' ->
+    rnHsType ty                        `thenRn` \ ty' ->
+       -- Get the pragma info (if any).
+    setModeRn (InterfaceMode Optional) $
+       -- In all the rest of the signature we read in optional mode,
+       -- so that (a) we don't die
+    mapRn rnIdInfo id_infos    `thenRn` \ id_infos' -> 
+    returnRn (SigD (IfaceSig name' ty' id_infos' loc))
 \end{code}
 
 %*********************************************************
@@ -119,116 +119,28 @@ it again to rename the tyvars! However, we can also do some scoping
 checks at the same time.
 
 \begin{code}
-rnTyDecl :: RdrNameTyDecl -> RnM_Fixes s RenamedTyDecl
-
-rnTyDecl (TyData context tycon tyvars condecls derivings pragmas src_loc)
-  = pushSrcLocRn src_loc $
-    lookupTyCon tycon                 `thenRn` \ tycon' ->
-    mkTyVarNamesEnv src_loc tyvars     `thenRn` \ (tv_env, tyvars') ->
-    rnContext tv_env context          `thenRn` \ context' ->
-    rnConDecls tv_env condecls        `thenRn` \ condecls' ->
-    rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
-    ASSERT(isNoDataPragmas pragmas)
-    returnRn (TyData context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc)
-
-rnTyDecl (TyNew context tycon tyvars condecl derivings pragmas src_loc)
+rnDecl (TyD (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc))
   = pushSrcLocRn src_loc $
-    lookupTyCon tycon                `thenRn` \ tycon' ->
-    mkTyVarNamesEnv src_loc tyvars    `thenRn` \ (tv_env, tyvars') ->
-    rnContext tv_env context         `thenRn` \ context' ->
-    rnConDecls tv_env condecl        `thenRn` \ condecl' ->
-    rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
+    lookupBndrRn tycon                                 `thenRn` \ tycon' ->
+    bindTyVarsRn data_doc tyvars                       $ \ tyvars' ->
+    rnContext context                                  `thenRn` \ context' ->
+    checkDupOrQualNames data_doc con_names             `thenRn_`
+    mapRn rnConDecl condecls                           `thenRn` \ condecls' ->
+    rnDerivs derivings                                 `thenRn` \ derivings' ->
     ASSERT(isNoDataPragmas pragmas)
-    returnRn (TyNew context' tycon' tyvars' condecl' derivings' noDataPragmas src_loc)
-
-rnTyDecl (TySynonym name tyvars ty src_loc)
-  = pushSrcLocRn src_loc $
-    lookupTyCon name               `thenRn` \ name' ->
-    mkTyVarNamesEnv src_loc tyvars  `thenRn` \ (tv_env, tyvars') ->
-    rnMonoType tv_env ty           `thenRn` \ ty' ->
-    returnRn (TySynonym name' tyvars' ty' src_loc)
-
-rn_derivs tycon2 locn Nothing -- derivs not specified
-  = returnRn Nothing
-
-rn_derivs tycon2 locn (Just ds)
-  = mapRn (rn_deriv tycon2 locn) ds `thenRn` \ derivs ->
-    returnRn (Just derivs)
-  where
-    rn_deriv tycon2 locn clas
-      = lookupClass clas           `thenRn` \ clas_name ->
-       addErrIfRn (uniqueOf clas_name `not_elem` derivableClassKeys)
-                  (derivingNonStdClassErr clas locn)
-                                   `thenRn_`
-       returnRn clas_name
-      where
-       not_elem = isn'tIn "rn_deriv"
-\end{code}
-
-@rnConDecls@ uses the `global name function' to create a new
-constructor in which local names have been replaced by their original
-names, reporting any unknown names.
-
-\begin{code}
-rnConDecls :: TyVarNamesEnv
-          -> [RdrNameConDecl]
-          -> RnM_Fixes s [RenamedConDecl]
-
-rnConDecls tv_env con_decls
-  = mapRn rn_decl con_decls
+    returnRn (TyD (TyData new_or_data context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc))
   where
-    rn_decl (ConDecl name tys src_loc)
-      = pushSrcLocRn src_loc $
-       lookupValue name        `thenRn` \ new_name ->
-       mapRn rn_bang_ty tys    `thenRn` \ new_tys  ->
-       returnRn (ConDecl new_name new_tys src_loc)
-
-    rn_decl (ConOpDecl ty1 op ty2 src_loc)
-      = pushSrcLocRn src_loc $
-       lookupValue op          `thenRn` \ new_op  ->
-       rn_bang_ty ty1          `thenRn` \ new_ty1 ->
-       rn_bang_ty ty2          `thenRn` \ new_ty2 ->
-       returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc)
-
-    rn_decl (NewConDecl name ty src_loc)
-      = pushSrcLocRn src_loc $
-       lookupValue name        `thenRn` \ new_name ->
-       rn_mono_ty ty           `thenRn` \ new_ty  ->
-       returnRn (NewConDecl new_name new_ty src_loc)
-
-    rn_decl (RecConDecl con fields src_loc)
-      = panic "rnConDecls:RecConDecl"
-
-    ----------
-    rn_mono_ty = rnMonoType tv_env
-
-    rn_bang_ty (Banged ty)
-      = rn_mono_ty ty `thenRn` \ new_ty ->
-       returnRn (Banged new_ty)
-    rn_bang_ty (Unbanged ty)
-      = rn_mono_ty ty `thenRn` \ new_ty ->
-       returnRn (Unbanged new_ty)
-\end{code}
-
-%*********************************************************
-%*                                                     *
-\subsection{SPECIALIZE data pragmas}
-%*                                                     *
-%*********************************************************
-
-\begin{code}
-rnSpecDataSig :: RdrNameSpecDataSig
-             -> RnM_Fixes s RenamedSpecDataSig
+    data_doc sty = text "the data type declaration for" <+> ppr sty tycon
+    con_names = map conDeclName condecls
 
-rnSpecDataSig (SpecDataSig tycon ty src_loc)
+rnDecl (TyD (TySynonym name tyvars ty src_loc))
   = pushSrcLocRn src_loc $
-    let
-       tyvars = extractMonoTyNames ty
-    in
-    mkTyVarNamesEnv src_loc tyvars             `thenRn` \ (tv_env,_) ->
-    lookupTyCon tycon                  `thenRn` \ tycon' ->
-    rnMonoType tv_env ty               `thenRn` \ ty' ->
-    returnRn (SpecDataSig tycon' ty' src_loc)
+    lookupBndrRn name                          `thenRn` \ name' ->
+    bindTyVarsRn syn_doc tyvars                $ \ tyvars' ->
+    rnHsType ty                                        `thenRn` \ ty' ->
+    returnRn (TyD (TySynonym name' tyvars' ty' src_loc))
+  where
+    syn_doc sty = text "the declaration for type synonym" <+> ppr sty name
 \end{code}
 
 %*********************************************************
@@ -242,34 +154,66 @@ class declaration in which local names have been replaced by their
 original names, reporting any unknown names.
 
 \begin{code}
-rnClassDecl :: RdrNameClassDecl -> RnM_Fixes s RenamedClassDecl
-
-rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
+rnDecl (ClD (ClassDecl context cname tyvar sigs mbinds pragmas src_loc))
   = pushSrcLocRn src_loc $
-    mkTyVarNamesEnv src_loc [tyvar]    `thenRn` \ (tv_env, [tyvar']) ->
-    rnContext tv_env context           `thenRn` \ context' ->
-    lookupClass cname                  `thenRn` \ cname' ->
-    mapRn (rn_op cname' tv_env) sigs    `thenRn` \ sigs' ->
-    rnMethodBinds cname' mbinds        `thenRn` \ mbinds' ->
+    bindTyVarsRn cls_doc [tyvar]                       ( \ [tyvar'] ->
+       rnContext context                                       `thenRn` \ context' ->
+       lookupBndrRn cname                                      `thenRn` \ cname' ->
+
+            -- Check the signatures
+       checkDupOrQualNames sig_doc sig_names           `thenRn_` 
+       mapRn (rn_op cname' (getTyVarName tyvar')) sigs `thenRn` \ sigs' ->
+       returnRn (tyvar', context', cname', sigs')
+    )                                                  `thenRn` \ (tyvar', context', cname', sigs') ->
+
+       -- Check the methods
+    checkDupOrQualNames meth_doc meth_names            `thenRn_`
+    rnMethodBinds mbinds                               `thenRn` \ mbinds' ->
+
+       -- Typechecker is responsible for checking that we only
+       -- give default-method bindings for things in this class.
+       -- The renamer *could* check this for class decls, but can't
+       -- for instance decls.
+
     ASSERT(isNoClassPragmas pragmas)
-    returnRn (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc)
+    returnRn (ClD (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc))
   where
-    rn_op clas tv_env (ClassOpSig op ty pragmas locn)
+    cls_doc sty  = text "the declaration for class"    <+> ppr sty cname
+    sig_doc sty  = text "the signatures for class"     <+> ppr sty cname
+    meth_doc sty = text "the default-methods for class" <+> ppr sty cname
+
+    sig_names   = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
+    meth_names   = bagToList (collectMonoBinders mbinds)
+
+    rn_op clas clas_tyvar sig@(ClassOpSig op _ ty locn)
       = pushSrcLocRn locn $
-       lookupClassOp clas op           `thenRn` \ op_name ->
-       rnPolyType tv_env ty            `thenRn` \ new_ty  ->
-
-{-
-*** Please check here that tyvar' appears in new_ty ***
-*** (used to be in tcClassSig, but it's better here)
-***        not_elem = isn'tIn "tcClassSigs"
-***        -- Check that the class type variable is mentioned
-***    checkTc (clas_tyvar `not_elem` extractTyVarTemplatesFromTy local_ty)
-***            (methodTypeLacksTyVarErr clas_tyvar (_UNPK_ op_name) src_loc) `thenTc_`
--}
-
-       ASSERT(isNoClassOpPragmas pragmas)
-       returnRn (ClassOpSig op_name new_ty noClassOpPragmas locn)
+       lookupBndrRn op                         `thenRn` \ op_name ->
+       rnHsSigType (\sty -> ppr sty op) ty     `thenRn` \ new_ty  ->
+
+               -- Call up interface info for default method, if such info exists
+       let
+           dm_occ = prefixOccName SLIT("$m") (rdrNameOcc op)
+       in
+        newSysName dm_occ Exported locn                `thenRn` \ dm_name ->
+       setModeRn (InterfaceMode Optional) (
+            addOccurrenceName dm_name
+       )                                               `thenRn_`
+
+               -- Checks.....
+       let
+           (ctxt, op_ty) = case new_ty of
+                               HsForAllTy tvs ctxt op_ty -> (ctxt, op_ty)
+                               other                     -> ([], new_ty)
+           ctxt_fvs  = extractCtxtTyNames ctxt
+           op_ty_fvs = extractHsTyNames op_ty          -- Includes tycons/classes but we
+                                                       -- don't care about that
+       in
+               -- Check that class tyvar appears in op_ty
+        checkRn (clas_tyvar `elemNameSet` op_ty_fvs)
+               (classTyVarNotInOpTyErr clas_tyvar sig)
+                                                        `thenRn_`
+
+       returnRn (ClassOpSig op_name dm_name new_ty locn)
 \end{code}
 
 
@@ -279,130 +223,165 @@ rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
 %*                                                     *
 %*********************************************************
 
-
-@rnInstDecl@ uses the `global name function' to create a new of
-instance declaration in which local names have been replaced by their
-original names, reporting any unknown names.
-
 \begin{code}
-rnInstDecl :: RdrNameInstDecl -> RnM_Fixes s RenamedInstDecl
-
-rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc)
+rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc))
   = pushSrcLocRn src_loc $
-    lookupClass cname                  `thenRn` \ cname' ->
+    rnHsSigType (\sty -> text "an instance decl") inst_ty      `thenRn` \ inst_ty' ->
 
-    rnPolyType [] ty                   `thenRn` \ ty' ->
-       -- [] tv_env ensures that tyvars will be foralled
 
-    rnMethodBinds cname' mbinds                `thenRn` \ mbinds' ->
-    mapRn (rn_uprag cname') uprags     `thenRn` \ new_uprags ->
+       -- Rename the bindings
+       -- NB meth_names can be qualified!
+    checkDupNames meth_doc meth_names          `thenRn_`
+    rnMethodBinds mbinds                       `thenRn` \ mbinds' ->
+    mapRn rn_uprag uprags                      `thenRn` \ new_uprags ->
 
-    ASSERT(isNoInstancePragmas pragmas)
-    returnRn (InstDecl cname' ty' mbinds'
-                      from_here modname new_uprags noInstancePragmas src_loc)
+    newDfunName maybe_dfun src_loc             `thenRn` \ dfun_name ->
+    addOccurrenceName dfun_name                        `thenRn_`
+                       -- The dfun is not optional, because we use its version number
+                       -- to identify the version of the instance declaration
+
+       -- The typechecker checks that all the bindings are for the right class.
+    returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags (Just dfun_name) src_loc))
   where
-    rn_uprag class_name (SpecSig op ty using locn)
+    meth_doc sty = text "the bindings in an instance declaration"
+    meth_names   = bagToList (collectMonoBinders mbinds)
+
+    rn_uprag (SpecSig op ty using locn)
       = pushSrcLocRn src_loc $
-       lookupClassOp class_name op     `thenRn` \ op_name ->
-       rnPolyType nullTyVarNamesEnv ty `thenRn` \ new_ty ->
-       rn_using using                  `thenRn` \ new_using ->
+       lookupBndrRn op                         `thenRn` \ op_name ->
+       rnHsSigType (\sty -> ppr sty op) ty     `thenRn` \ new_ty ->
+       rn_using using                          `thenRn` \ new_using ->
        returnRn (SpecSig op_name new_ty new_using locn)
 
-    rn_uprag class_name (InlineSig op locn)
+    rn_uprag (InlineSig op locn)
       = pushSrcLocRn locn $
-       lookupClassOp class_name op     `thenRn` \ op_name ->
+       lookupBndrRn op                 `thenRn` \ op_name ->
        returnRn (InlineSig op_name locn)
 
-    rn_uprag class_name (DeforestSig op locn)
+    rn_uprag (DeforestSig op locn)
       = pushSrcLocRn locn $
-       lookupClassOp class_name op     `thenRn` \ op_name ->
+       lookupBndrRn op                 `thenRn` \ op_name ->
        returnRn (DeforestSig op_name locn)
 
-    rn_uprag class_name (MagicUnfoldingSig op str locn)
+    rn_uprag (MagicUnfoldingSig op str locn)
       = pushSrcLocRn locn $
-       lookupClassOp class_name op     `thenRn` \ op_name ->
+       lookupBndrRn op                 `thenRn` \ op_name ->
        returnRn (MagicUnfoldingSig op_name str locn)
 
-    rn_using Nothing 
-      = returnRn Nothing
-    rn_using (Just v)
-      = lookupValue v  `thenRn` \ new_v ->
-       returnRn (Just new_v)
+    rn_using Nothing  = returnRn Nothing
+    rn_using (Just v) = lookupOccRn v  `thenRn` \ new_v ->
+                       returnRn (Just new_v)
 \end{code}
 
 %*********************************************************
 %*                                                     *
-\subsection{@SPECIALIZE instance@ user-pragmas}
+\subsection{Default declarations}
 %*                                                     *
 %*********************************************************
 
 \begin{code}
-rnSpecInstSig :: RdrNameSpecInstSig
-             -> RnM_Fixes s RenamedSpecInstSig
-
-rnSpecInstSig (SpecInstSig clas ty src_loc)
+rnDecl (DefD (DefaultDecl tys src_loc))
   = pushSrcLocRn src_loc $
-    let
-       tyvars = extractMonoTyNames ty
-    in
-    mkTyVarNamesEnv src_loc tyvars             `thenRn` \ (tv_env,_) ->
-    lookupClass clas                   `thenRn` \ new_clas ->
-    rnMonoType tv_env ty               `thenRn` \ new_ty ->
-    returnRn (SpecInstSig new_clas new_ty src_loc)
+    mapRn rnHsType tys                         `thenRn` \ tys' ->
+    lookupImplicitOccRn numClass_RDR   `thenRn_` 
+    returnRn (DefD (DefaultDecl tys' src_loc))
 \end{code}
 
 %*********************************************************
 %*                                                     *
-\subsection{Default declarations}
+\subsection{Support code for type/data declarations}
 %*                                                     *
 %*********************************************************
 
-@rnDefaultDecl@ uses the `global name function' to create a new set
-of default declarations in which local names have been replaced by
-their original names, reporting any unknown names.
-
 \begin{code}
-rnDefaultDecl :: [RdrNameDefaultDecl] -> RnM_Fixes s [RenamedDefaultDecl]
+rnDerivs :: Maybe [RdrName] -> RnMS s (Maybe [Name])
 
-rnDefaultDecl [] = returnRn []
-rnDefaultDecl [DefaultDecl tys src_loc]
-  = pushSrcLocRn src_loc $
-    mapRn (rnMonoType nullTyVarNamesEnv) tys `thenRn` \ tys' ->
-    returnRn [DefaultDecl tys' src_loc]
-rnDefaultDecl defs@(d:ds)
-  = addErrRn (dupDefaultDeclErr defs) `thenRn_`
-    rnDefaultDecl [d]
-\end{code}
+rnDerivs Nothing -- derivs not specified
+  = lookupImplicitOccRn evalClass_RDR          `thenRn_`
+    returnRn Nothing
 
-%*************************************************************************
-%*                                                                     *
-\subsection{Fixity declarations}
-%*                                                                     *
-%*************************************************************************
+rnDerivs (Just ds)
+  = lookupImplicitOccRn evalClass_RDR          `thenRn_`
+    mapRn rn_deriv ds `thenRn` \ derivs ->
+    returnRn (Just derivs)
+  where
+    rn_deriv clas
+      = lookupOccRn clas           `thenRn` \ clas_name ->
+
+               -- Now add extra "occurrences" for things that
+               -- the deriving mechanism will later need in order to
+               -- generate code for this class.
+       case lookupUFM derivingOccurrences clas_name of
+               Nothing -> addErrRn (derivingNonStdClassErr clas_name)  `thenRn_`
+                          returnRn clas_name
+
+               Just occs -> mapRn lookupImplicitOccRn occs     `thenRn_`
+                            returnRn clas_name
+\end{code}
 
 \begin{code}
-rnFixes :: [RdrNameFixityDecl]  -> RnM s [RenamedFixityDecl]
-
-rnFixes fixities
-  = mapRn rn_fixity fixities   `thenRn` \ fixes_maybe ->
-    returnRn (catMaybes fixes_maybe)
+conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
+conDeclName (ConDecl n _ _ l)     = (n,l)
+
+rnConDecl :: RdrNameConDecl -> RnMS s RenamedConDecl
+rnConDecl (ConDecl name cxt details locn)
+  = pushSrcLocRn locn $
+    checkConName name                  `thenRn_` 
+    lookupBndrRn name                  `thenRn` \ new_name ->
+    rnConDetails name locn details     `thenRn` \ new_details -> 
+    rnContext cxt                      `thenRn` \ new_context ->
+    returnRn (ConDecl new_name new_context new_details locn)
+
+rnConDetails con locn (VanillaCon tys)
+  = mapRn rnBangTy tys         `thenRn` \ new_tys  ->
+    returnRn (VanillaCon new_tys)
+
+rnConDetails con locn (InfixCon ty1 ty2)
+  = rnBangTy ty1               `thenRn` \ new_ty1 ->
+    rnBangTy ty2               `thenRn` \ new_ty2 ->
+    returnRn (InfixCon new_ty1 new_ty2)
+
+rnConDetails con locn (NewCon ty)
+  = rnHsType ty                        `thenRn` \ new_ty  ->
+    returnRn (NewCon new_ty)
+
+rnConDetails con locn (RecCon fields)
+  = checkDupOrQualNames fld_doc field_names    `thenRn_`
+    mapRn rnField fields                       `thenRn` \ new_fields ->
+    returnRn (RecCon new_fields)
   where
-    rn_fixity fix@(InfixL name i)
-      = rn_fixity_pieces InfixL name i fix
-    rn_fixity fix@(InfixR name i)
-      = rn_fixity_pieces InfixR name i fix
-    rn_fixity fix@(InfixN name i)
-      = rn_fixity_pieces InfixN name i fix
-
-    rn_fixity_pieces mk_fixity name i fix
-      = lookupValueMaybe name  `thenRn` \ maybe_res ->
-       case maybe_res of
-         Just res | isLocallyDefined res
-           -> returnRn (Just (mk_fixity res i))
-         _ -> failButContinueRn Nothing (undefinedFixityDeclErr fix)
-               
+    fld_doc sty = text "the fields of constructor" <> ppr sty con
+    field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
+
+rnField (names, ty)
+  = mapRn lookupBndrRn names   `thenRn` \ new_names ->
+    rnBangTy ty                        `thenRn` \ new_ty ->
+    returnRn (new_names, new_ty) 
+
+rnBangTy (Banged ty)
+  = rnHsType ty `thenRn` \ new_ty ->
+    returnRn (Banged new_ty)
+
+rnBangTy (Unbanged ty)
+  = rnHsType ty `thenRn` \ new_ty ->
+    returnRn (Unbanged new_ty)
+
+-- This data decl will parse OK
+--     data T = a Int
+-- treating "a" as the constructor.
+-- It is really hard to make the parser spot this malformation.
+-- So the renamer has to check that the constructor is legal
+--
+-- We can get an operator as the constructor, even in the prefix form:
+--     data T = :% Int Int
+-- from interface files, which always print in prefix form
+
+checkConName name
+  = checkRn (isLexCon (occNameString (rdrNameOcc name)))
+           (badDataCon name)
 \end{code}
 
+
 %*********************************************************
 %*                                                     *
 \subsection{Support code to rename types}
@@ -410,100 +389,344 @@ rnFixes fixities
 %*********************************************************
 
 \begin{code}
-rnPolyType :: TyVarNamesEnv
-          -> RdrNamePolyType
-          -> RnM_Fixes s RenamedPolyType
+rnHsSigType :: (PprStyle -> Doc) -> RdrNameHsType -> RnMS s RenamedHsType 
+       -- rnHsSigType is used for source-language type signatures,
+       -- which use *implicit* universal quantification.
+
+-- Given the signature  C => T  we universally quantify over FV(T) \ {in-scope-tyvars} 
+-- 
+-- We insist that the universally quantified type vars is a superset of FV(C)
+-- It follows that FV(T) is a superset of FV(C), so that the context constrains
+-- no type variables that don't appear free in the tau-type part.
+
+rnHsSigType doc_str full_ty@(HsPreForAllTy ctxt ty)    -- From source code (no kinds on tyvars)
+  = getNameEnv         `thenRn` \ name_env ->
+    let
+       mentioned_tyvars = extractHsTyVars ty
+       forall_tyvars    = filter (not . in_scope) mentioned_tyvars
+       in_scope tv      = maybeToBool (lookupFM name_env tv)
 
-rnPolyType tv_env (HsForAllTy tvs ctxt ty)
-  = rn_poly_help tv_env tvs ctxt ty
+       constrained_tyvars            = nub (concat (map (extractHsTyVars . snd) ctxt))
+       constrained_and_in_scope      = filter in_scope constrained_tyvars
+       constrained_and_not_mentioned = filter (not . (`elem` mentioned_tyvars)) constrained_tyvars
 
-rnPolyType tv_env poly_ty@(HsPreForAllTy ctxt ty)
-  = rn_poly_help tv_env forall_tyvars ctxt ty
+       -- Zap the context if there's a problem, to avoid duplicate error message.
+       ctxt' | null constrained_and_in_scope && null constrained_and_not_mentioned = ctxt
+             | otherwise = []
+    in
+    checkRn (null constrained_and_in_scope)
+           (ctxtErr1 sig_doc constrained_and_in_scope) `thenRn_`
+    checkRn (null constrained_and_not_mentioned)
+           (ctxtErr2 sig_doc constrained_and_not_mentioned ty) `thenRn_`
+
+    (bindTyVarsRn sig_doc (map UserTyVar forall_tyvars)        $ \ new_tyvars ->
+     rnContext ctxt'                                   `thenRn` \ new_ctxt ->
+     rnHsType ty                                       `thenRn` \ new_ty ->
+     returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
+    )
   where
-    mentioned_tyvars = extract_poly_ty_names poly_ty
-    forall_tyvars    = mentioned_tyvars `minusList` domTyVarNamesEnv tv_env
-
-------------
-extract_poly_ty_names (HsPreForAllTy ctxt ty)
-  = extractCtxtTyNames ctxt
-    `unionLists`
-    extractMonoTyNames ty
-
-------------
-rn_poly_help :: TyVarNamesEnv
-            -> [RdrName]
-            -> RdrNameContext
-            -> RdrNameMonoType
-            -> RnM_Fixes s RenamedPolyType
+    sig_doc sty = text "the type signature for" <+> doc_str sty
+                            
+
+rnHsSigType doc_str other_ty = rnHsType other_ty
 
-rn_poly_help tv_env tyvars ctxt ty
-  = getSrcLocRn                                `thenRn` \ src_loc ->
-    mkTyVarNamesEnv src_loc tyvars             `thenRn` \ (tv_env1, new_tyvars) ->
+rnHsType :: RdrNameHsType -> RnMS s RenamedHsType
+rnHsType (HsForAllTy tvs ctxt ty)              -- From an interface file (tyvars may be kinded)
+  = rn_poly_help tvs ctxt ty
+
+rnHsType full_ty@(HsPreForAllTy ctxt ty)       -- A (context => ty) embedded in a type.
+                                               -- Universally quantify over tyvars in context
+  = getNameEnv         `thenRn` \ name_env ->
     let
-       tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
+       forall_tyvars = foldr unionLists [] (map (extractHsTyVars . snd) ctxt)
     in
-    rnContext tv_env2 ctxt                     `thenRn` \ new_ctxt ->
-    rnMonoType tv_env2 ty      `thenRn` \ new_ty ->
+    rn_poly_help (map UserTyVar forall_tyvars) ctxt ty
+
+rnHsType (MonoTyVar tyvar)
+  = lookupOccRn tyvar          `thenRn` \ tyvar' ->
+    returnRn (MonoTyVar tyvar')
+
+rnHsType (MonoFunTy ty1 ty2)
+  = andRn MonoFunTy (rnHsType ty1) (rnHsType ty2)
+
+rnHsType (MonoListTy _ ty)
+  = lookupImplicitOccRn listType_RDR           `thenRn` \ tycon_name ->
+    rnHsType ty                                        `thenRn` \ ty' ->
+    returnRn (MonoListTy tycon_name ty')
+
+rnHsType (MonoTupleTy _ tys)
+  = lookupImplicitOccRn (tupleType_RDR (length tys))   `thenRn` \ tycon_name ->
+    mapRn rnHsType tys                                 `thenRn` \ tys' ->
+    returnRn (MonoTupleTy tycon_name tys')
+
+rnHsType (MonoTyApp ty1 ty2)
+  = rnHsType ty1               `thenRn` \ ty1' ->
+    rnHsType ty2               `thenRn` \ ty2' ->
+    returnRn (MonoTyApp ty1' ty2')
+
+rnHsType (MonoDictTy clas ty)
+  = lookupOccRn clas           `thenRn` \ clas' ->
+    rnHsType ty                        `thenRn` \ ty' ->
+    returnRn (MonoDictTy clas' ty')
+
+rn_poly_help :: [HsTyVar RdrName]              -- Universally quantified tyvars
+            -> RdrNameContext
+            -> RdrNameHsType
+            -> RnMS s RenamedHsType
+rn_poly_help tyvars ctxt ty
+  = bindTyVarsRn sig_doc tyvars                                $ \ new_tyvars ->
+    rnContext ctxt                                     `thenRn` \ new_ctxt ->
+    rnHsType ty                                                `thenRn` \ new_ty ->
     returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
+  where
+    sig_doc sty = text "a nested for-all type"
 \end{code}
 
+
 \begin{code}
-rnMonoType :: TyVarNamesEnv
-          -> RdrNameMonoType
-          -> RnM_Fixes s RenamedMonoType
+rnContext :: RdrNameContext -> RnMS s RenamedContext
 
-rnMonoType tv_env (MonoTyVar tyvar)
-  = lookupTyVarName tv_env tyvar       `thenRn` \ tyvar' ->
-    returnRn (MonoTyVar tyvar')
+rnContext  ctxt
+  = mapRn rn_ctxt ctxt `thenRn` \ result ->
+    let
+       (_, dup_asserts) = removeDups cmp_assert result
+       (alls, theta)    = partition (\(c,_) -> c == allClass_NAME) result
+       non_tyvar_alls   = [(c,t) | (c,t) <- alls, not (is_tyvar t)]
+    in
 
-rnMonoType tv_env (MonoListTy ty)
-  = rnMonoType tv_env ty       `thenRn` \ ty' ->
-    returnRn (MonoListTy ty')
+       -- Check for duplicate assertions
+       -- If this isn't an error, then it ought to be:
+    mapRn (addWarnRn . dupClassAssertWarn theta) dup_asserts `thenRn_`
+
+       -- Check for All constraining a non-type-variable
+    mapRn (addWarnRn . allOfNonTyVar) non_tyvar_alls   `thenRn_`
+    
+       -- Done.  Return a theta omitting all the "All" constraints.
+       -- They have done done their work by ensuring that we universally
+       -- quantify over their tyvar.
+    returnRn theta
+  where
+    rn_ctxt (clas, ty)
+      =                -- Mini hack here.  If the class is our pseudo-class "All",
+               -- then we don't want to record it as an occurrence, otherwise
+               -- we try to slurp it in later and it doesn't really exist at all.
+               -- Easiest thing is simply not to put it in the occurrence set.
+       lookupBndrRn clas       `thenRn` \ clas_name ->
+       (if clas_name /= allClass_NAME then
+               addOccurrenceName clas_name
+        else
+               returnRn clas_name
+       )                       `thenRn_`
+       rnHsType ty             `thenRn` \ ty' ->
+       returnRn (clas_name, ty')
+
+    cmp_assert (c1,ty1) (c2,ty2)
+      = (c1 `cmp` c2) `thenCmp` (cmpHsType cmp ty1 ty2)
+
+    is_tyvar (MonoTyVar _) = True
+    is_tyvar other         = False
+\end{code}
 
-rnMonoType tv_env (MonoFunTy ty1 ty2)
-  = andRn MonoFunTy (rnMonoType tv_env ty1)
-                   (rnMonoType tv_env ty2)
 
-rnMonoType  tv_env (MonoTupleTy tys)
-  = mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
-    returnRn (MonoTupleTy tys')
+%*********************************************************
+%*                                                     *
+\subsection{IdInfo}
+%*                                                     *
+%*********************************************************
 
-rnMonoType tv_env (MonoTyApp name tys)
-  = let
-       lookup_fn = if isAvarid (getLocalName name) 
-                   then lookupTyVarName tv_env
-                   else lookupTyCon
-    in
-    lookup_fn name                                     `thenRn` \ name' ->
-    mapRn (rnMonoType tv_env) tys      `thenRn` \ tys' ->
-    returnRn (MonoTyApp name' tys')
+\begin{code}
+rnIdInfo (HsStrictness strict)
+  = rnStrict strict    `thenRn` \ strict' ->
+    returnRn (HsStrictness strict')
+
+rnIdInfo (HsUnfold inline expr)        = rnCoreExpr expr       `thenRn` \ expr' ->
+                                 returnRn (HsUnfold inline expr')
+rnIdInfo (HsArity arity)       = returnRn (HsArity arity)
+rnIdInfo (HsUpdate update)     = returnRn (HsUpdate update)
+rnIdInfo (HsFBType fb)         = returnRn (HsFBType fb)
+rnIdInfo (HsArgUsage au)       = returnRn (HsArgUsage au)
+rnIdInfo (HsDeforest df)       = returnRn (HsDeforest df)
+
+rnStrict (StrictnessInfo demands (Just (worker,cons)))
+       -- The sole purpose of the "cons" field is so that we can mark the constructors
+       -- needed to build the wrapper as "needed", so that their data type decl will be
+       -- slurped in. After that their usefulness is o'er, so we just put in the empty list.
+  = lookupOccRn worker                 `thenRn` \ worker' ->
+    mapRn lookupOccRn cons             `thenRn_` 
+    returnRn (StrictnessInfo demands (Just (worker',[])))
+
+-- Boring, but necessary for the type checker.
+rnStrict (StrictnessInfo demands Nothing) = returnRn (StrictnessInfo demands Nothing)
+rnStrict BottomGuaranteed                = returnRn BottomGuaranteed
+rnStrict NoStrictnessInfo                = returnRn NoStrictnessInfo
 \end{code}
 
-\begin{code}
-rnContext :: TyVarNamesEnv -> RdrNameContext -> RnM_Fixes s RenamedContext
+UfCore expressions.
 
-rnContext tv_env ctxt
-  = mapRn rn_ctxt ctxt
+\begin{code}
+rnCoreExpr (UfVar v)
+  = lookupOccRn v      `thenRn` \ v' ->
+    returnRn (UfVar v')
+
+rnCoreExpr (UfLit lit) = returnRn (UfLit lit)
+
+rnCoreExpr (UfCon con args) 
+  = lookupOccRn con            `thenRn` \ con' ->
+    mapRn rnCoreArg args       `thenRn` \ args' ->
+    returnRn (UfCon con' args')
+
+rnCoreExpr (UfPrim prim args) 
+  = rnCorePrim prim            `thenRn` \ prim' ->
+    mapRn rnCoreArg args       `thenRn` \ args' ->
+    returnRn (UfPrim prim' args')
+
+rnCoreExpr (UfApp fun arg)
+  = rnCoreExpr fun             `thenRn` \ fun' ->
+    rnCoreArg arg              `thenRn` \ arg' ->
+    returnRn (UfApp fun' arg')
+
+rnCoreExpr (UfCase scrut alts) 
+  = rnCoreExpr scrut           `thenRn` \ scrut' ->
+    rnCoreAlts alts            `thenRn` \ alts' ->
+    returnRn (UfCase scrut' alts')
+
+rnCoreExpr (UfSCC cc expr) 
+  = rnCoreExpr expr            `thenRn` \ expr' ->
+    returnRn  (UfSCC cc expr') 
+
+rnCoreExpr(UfCoerce coercion ty body)
+  = rnCoercion coercion                `thenRn` \ coercion' ->
+    rnHsType ty                        `thenRn` \ ty' ->
+    rnCoreExpr body            `thenRn` \ body' ->
+    returnRn (UfCoerce coercion' ty' body')
+
+rnCoreExpr (UfLam bndr body)
+  = rnCoreBndr bndr            $ \ bndr' ->
+    rnCoreExpr body            `thenRn` \ body' ->
+    returnRn (UfLam bndr' body')
+
+rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
+  = rnCoreExpr rhs             `thenRn` \ rhs' ->
+    rnCoreBndr bndr            $ \ bndr' ->
+    rnCoreExpr body            `thenRn` \ body' ->
+    returnRn (UfLet (UfNonRec bndr' rhs') body')
+
+rnCoreExpr (UfLet (UfRec pairs) body)
+  = rnCoreBndrs bndrs          $ \ bndrs' ->
+    mapRn rnCoreExpr rhss      `thenRn` \ rhss' ->
+    rnCoreExpr body            `thenRn` \ body' ->
+    returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body')
   where
-    rn_ctxt (clas, tyvar)
-     = lookupClass clas                    `thenRn` \ clas_name ->
-       lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name ->
-       returnRn (clas_name, tyvar_name)
+    (bndrs, rhss) = unzip pairs
 \end{code}
 
-
 \begin{code}
-derivingNonStdClassErr clas locn sty
-  = ppHang (ppStr "Non-standard class in deriving")
-         4 (ppCat [ppr sty clas, ppr sty locn])
+rnCoreBndr (UfValBinder name ty) thing_inside
+  = rnHsType ty                        `thenRn` \ ty' ->
+    bindLocalsRn "unfolding value" [name] $ \ [name'] ->
+    thing_inside (UfValBinder name' ty')
+    
+rnCoreBndr (UfTyBinder name kind) thing_inside
+  = bindLocalsRn "unfolding tyvar" [name] $ \ [name'] ->
+    thing_inside (UfTyBinder name' kind)
+    
+rnCoreBndr (UfUsageBinder name) thing_inside
+  = bindLocalsRn "unfolding usage" [name] $ \ [name'] ->
+    thing_inside (UfUsageBinder name')
+
+rnCoreBndrs bndrs thing_inside         -- Expect them all to be ValBinders
+  = mapRn rnHsType tys                 `thenRn` \ tys' ->
+    bindLocalsRn "unfolding value" names $ \ names' ->
+    thing_inside (zipWith UfValBinder names' tys')
+  where
+    names = map (\ (UfValBinder name _) -> name) bndrs
+    tys   = map (\ (UfValBinder _   ty) -> ty)   bndrs
+
+rnCoreBndrNamess names thing_inside
+  = bindLocalsRn "unfolding value" names $ \ names' ->
+    thing_inside names'
+\end{code}    
 
-dupDefaultDeclErr defs sty
-  = ppHang (ppStr "Duplicate default declarations")
-         4 (ppAboves (map pp_def_loc defs))
+\begin{code}
+rnCoreArg (UfVarArg v)  = lookupOccRn v        `thenRn` \ v' -> returnRn (UfVarArg v')
+rnCoreArg (UfUsageArg u) = lookupOccRn u       `thenRn` \ u' -> returnRn (UfUsageArg u')
+rnCoreArg (UfTyArg ty)  = rnHsType ty                  `thenRn` \ ty' -> returnRn (UfTyArg ty')
+rnCoreArg (UfLitArg lit) = returnRn (UfLitArg lit)
+
+rnCoreAlts (UfAlgAlts alts deflt)
+  = mapRn rn_alt alts          `thenRn` \ alts' ->
+    rnCoreDefault deflt                `thenRn` \ deflt' ->
+    returnRn (UfAlgAlts alts' deflt')
+  where
+    rn_alt (con, bndrs, rhs) = lookupOccRn con                 `thenRn` \ con' ->
+                               bindLocalsRn "unfolding alt" bndrs      $ \ bndrs' ->
+                               rnCoreExpr rhs                          `thenRn` \ rhs' ->
+                               returnRn (con', bndrs', rhs')
+
+rnCoreAlts (UfPrimAlts alts deflt)
+  = mapRn rn_alt alts          `thenRn` \ alts' ->
+    rnCoreDefault deflt                `thenRn` \ deflt' ->
+    returnRn (UfPrimAlts alts' deflt')
   where
-    pp_def_loc (DefaultDecl _ src_loc) = ppr sty src_loc
+    rn_alt (lit, rhs) =        rnCoreExpr rhs          `thenRn` \ rhs' ->
+                       returnRn (lit, rhs')
 
-undefinedFixityDeclErr decl sty
-  = ppHang (ppStr "Fixity declaration for unknown operator")
-        4 (ppr sty decl)
+rnCoreDefault UfNoDefault = returnRn UfNoDefault
+rnCoreDefault (UfBindDefault bndr rhs) = bindLocalsRn "unfolding default" [bndr]       $ \ [bndr'] ->
+                                        rnCoreExpr rhs                                 `thenRn` \ rhs' ->
+                                        returnRn (UfBindDefault bndr' rhs')
+
+rnCoercion (UfIn  n) = lookupOccRn n `thenRn` \ n' -> returnRn (UfIn  n')
+rnCoercion (UfOut n) = lookupOccRn n `thenRn` \ n' -> returnRn (UfOut n')
+
+rnCorePrim (UfOtherOp op) 
+  = lookupOccRn op     `thenRn` \ op' ->
+    returnRn (UfOtherOp op')
+
+rnCorePrim (UfCCallOp str casm gc arg_tys res_ty)
+  = mapRn rnHsType arg_tys     `thenRn` \ arg_tys' ->
+    rnHsType res_ty            `thenRn` \ res_ty' ->
+    returnRn (UfCCallOp str casm gc arg_tys' res_ty')
+\end{code}
+
+%*********************************************************
+%*                                                     *
+\subsection{Errors}
+%*                                                     *
+%*********************************************************
+
+\begin{code}
+derivingNonStdClassErr clas sty
+  = hsep [ptext SLIT("non-standard class"), ppr sty clas, ptext SLIT("in deriving clause")]
+
+classTyVarNotInOpTyErr clas_tyvar sig sty
+  = hang (hsep [ptext SLIT("Class type variable"), 
+                      ppr sty clas_tyvar, 
+                      ptext SLIT("does not appear in method signature")])
+        4 (ppr sty sig)
+
+dupClassAssertWarn ctxt dups sty
+  = hang (hcat [ptext SLIT("Duplicate class assertion `"), 
+                      ppr sty dups, 
+                      ptext SLIT("' in context:")])
+        4 (ppr sty ctxt)
+
+badDataCon name sty
+   = hsep [ptext SLIT("Illegal data constructor name:"), ppr sty name]
+
+allOfNonTyVar ty sty
+  = hsep [ptext SLIT("`All' applied to a non-type variable:"), ppr sty ty]
+
+ctxtErr1 doc tyvars sty
+  = hsep [ptext SLIT("Context constrains in-scope type variable(s)"), 
+         hsep (punctuate comma (map (ppr sty) tyvars))]
+    $$
+    nest 4 (ptext SLIT("in") <+> doc sty)
+
+ctxtErr2 doc tyvars ty sty
+  = (ptext SLIT("Context constrains type variable(s)")
+       <+> hsep (punctuate comma (map (ppr sty) tyvars)))
+    $$
+    nest 4 (vcat [ptext SLIT("that do not appear in") <+> ppr sty ty,
+                 ptext SLIT("in") <+> doc sty])
 \end{code}