[project @ 2002-06-07 07:16:04 by chak]

[ghc-hetmet.git] / ghc / compiler / types / Generics.lhs

diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs
index 89e36c4..cc61161 100644 (file)
--- a/ghc/compiler/types/Generics.lhs
+++ b/ghc/compiler/types/Generics.lhs
@@ -5,39 +5,41 @@ module Generics ( mkTyConGenInfo, mkGenericRhs,
 
 
 import RnHsSyn         ( RenamedHsExpr )
 
 
 import RnHsSyn         ( RenamedHsExpr )

-import HsSyn           ( HsExpr(..), InPat(..), mkSimpleMatch )
+import HsSyn           ( HsExpr(..), InPat(..), mkSimpleMatch, placeHolderType )

 
 

-import Type             ( Type, isUnLiftedType, applyTys, tyVarsOfType, tyVarsOfTypes,
-                         mkTyVarTys, mkForAllTys, mkTyConApp, splitFunTys,
-                         mkFunTy, isTyVarTy,
-                         splitSigmaTy, getTyVar, splitTyConApp_maybe, funTyCon
+import Type             ( Type, isUnLiftedType, tyVarsOfType, tyVarsOfTypes,
+                         mkTyVarTys, mkForAllTys, mkTyConApp, 
+                         mkFunTy, isTyVarTy, getTyVar_maybe,
+                         funTyCon

                        )
                        )

+import TcType          ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitSigmaTy )
+import DataCon          ( DataCon, dataConOrigArgTys, dataConWrapId, isExistentialDataCon )

 
 

-import DataCon          ( DataCon, dataConOrigArgTys, dataConWrapId, dataConId )
-
-import TyCon            ( TyCon, tyConTyVars, tyConDataConsIfAvailable, 
+import TyCon            ( TyCon, tyConTyVars, tyConDataCons_maybe, 

                          tyConGenInfo, isNewTyCon, newTyConRep, isBoxedTupleTyCon
                        )
                          tyConGenInfo, isNewTyCon, newTyConRep, isBoxedTupleTyCon
                        )

-import Name            ( Name, mkSysLocalName )
-import CoreSyn          ( mkLams, Expr(..), CoreExpr, AltCon(..), Note(..),
+import Name            ( Name, mkSystemName )
+import CoreSyn          ( mkLams, Expr(..), CoreExpr, AltCon(..), 

                          mkConApp, Alt, mkTyApps, mkVarApps )
                          mkConApp, Alt, mkTyApps, mkVarApps )

+import CoreUtils       ( exprArity )

 import BasicTypes       ( EP(..), Boxity(..) )
 import Var              ( TyVar )
 import BasicTypes       ( EP(..), Boxity(..) )
 import Var              ( TyVar )

-import VarSet          ( isEmptyVarSet )
-import Id               ( Id, mkTemplateLocal, idType, idName, 
-                         mkTemplateLocalsNum, mkId
-                       ) 
+import VarSet          ( varSetElems )
+import Id               ( Id, mkVanillaGlobal, idType, idName, mkSysLocal )
+import MkId            ( mkReboxingAlt, mkNewTypeBody )

 import TysWiredIn       ( genericTyCons,
                          genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon,
                          inlDataCon, crossTyCon, crossDataCon
                        )
 import TysWiredIn       ( genericTyCons,
                          genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon,
                          inlDataCon, crossTyCon, crossDataCon
                        )

-import IdInfo           ( vanillaIdInfo, setUnfoldingInfo )
+import IdInfo           ( noCafNoTyGenIdInfo, setUnfoldingInfo, setArityInfo )

 import CoreUnfold       ( mkTopUnfolding ) 
 
 import CoreUnfold       ( mkTopUnfolding ) 
 

-import Unique          ( mkBuiltinUnique )
+import Maybe           ( isNothing )

 import SrcLoc          ( builtinSrcLoc )
 import SrcLoc          ( builtinSrcLoc )

-import Maybes          ( expectJust )
+import Unique          ( Unique, builtinUniques, mkBuiltinUnique )
+import Util             ( takeList, dropList )

 import Outputable 
 import Outputable 

+import FastString

 
 #include "HsVersions.h"
 \end{code}
 
 #include "HsVersions.h"
 \end{code}

@@ -80,7 +82,8 @@ patterns (not Unit, this is done differently) is done in mk_inst_info
 HsOpTy is tied to Generic definitions which is not a very good design
 feature, indeed a bug. However, the check is easy to move from
 tcHsType back to mk_inst_info and everything will be fine. Also see
 HsOpTy is tied to Generic definitions which is not a very good design
 feature, indeed a bug. However, the check is easy to move from
 tcHsType back to mk_inst_info and everything will be fine. Also see

-bug #5.
+bug #5. [I don't think that this is the case anymore after SPJ's latest
+changes in that regard.  Delete this comment?  -=chak/7Jun2]

 
 Generics.lhs
 
 
 Generics.lhs
 

@@ -187,7 +190,7 @@ validGenericInstanceType :: Type -> Bool
   --   f {| a + Int |}
 
 validGenericInstanceType inst_ty
   --   f {| a + Int |}
 
 validGenericInstanceType inst_ty

-  = case splitTyConApp_maybe inst_ty of
+  = case tcSplitTyConApp_maybe inst_ty of

        Just (tycon, tys) ->  all isTyVarTy tys && tycon `elem` genericTyCons
        Nothing           ->  False
 
        Just (tycon, tys) ->  all isTyVarTy tys && tycon `elem` genericTyCons
        Nothing           ->  False
 

@@ -197,17 +200,24 @@ validGenericMethodType :: Type -> Bool
   --   * function arrow
   --   * boxed tuples
   --   * an arbitrary type not involving the class type variables
   --   * function arrow
   --   * boxed tuples
   --   * an arbitrary type not involving the class type variables

-validGenericMethodType ty = valid ty
-
-valid ty
-  | isTyVarTy ty = True
-  | not (null arg_tys)  = all valid arg_tys && valid res_ty
-  | no_tyvars_in_ty    = True
-  | otherwise          = isBoxedTupleTyCon tc && all valid tys
+  --           e.g. this is ok:        forall b. Ord b => [b] -> a
+  --                where a is the class variable
+validGenericMethodType ty 
+  = valid tau

   where
   where

-    (arg_tys, res_ty) = splitFunTys ty
-    no_tyvars_in_ty   = isEmptyVarSet (tyVarsOfType ty)
-    Just (tc,tys)     = splitTyConApp_maybe ty
+    (local_tvs, _, tau) = tcSplitSigmaTy ty
+
+    valid ty
+      | isTyVarTy ty    = True
+      | no_tyvars_in_ty        = True
+      | otherwise      = case tcSplitTyConApp_maybe ty of
+                               Just (tc,tys) -> valid_tycon tc && all valid tys
+                               Nothing       -> False
+      where
+       no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
+
+    valid_tycon tc = tc == funTyCon || isBoxedTupleTyCon tc 
+       -- Compare bimapApp, below

 \end{code}
 
 
 \end{code}
 
 

@@ -218,7 +228,7 @@ valid ty
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-mkTyConGenInfo :: TyCon -> Name -> Name -> Maybe (EP Id)
+mkTyConGenInfo :: TyCon -> [Name] -> Maybe (EP Id)

 -- mkTyConGenInfo is called twice
 --     once from TysWiredIn for Tuples
 --     once the typechecker TcTyDecls 
 -- mkTyConGenInfo is called twice
 --     once from TysWiredIn for Tuples
 --     once the typechecker TcTyDecls 

@@ -229,35 +239,52 @@ mkTyConGenInfo :: TyCon -> Name -> Name -> Maybe (EP Id)
 -- The two names are the names constructed by the renamer
 -- for the fromT and toT conversion functions.
 
 -- The two names are the names constructed by the renamer
 -- for the fromT and toT conversion functions.
 

-mkTyConGenInfo tycon from_name to_name
-  | null datacons      -- Abstractly imported types don't have
-  = Nothing            -- to/from operations, (and should not need them)
+mkTyConGenInfo tycon []
+  = Nothing    -- This happens when we deal with the interface-file type
+               -- decl for a module compiled without -fgenerics

 
 

-       -- If any of the constructor has an unboxed type as argument
+mkTyConGenInfo tycon [from_name, to_name]
+  | isNothing maybe_datacons   -- Abstractly imported types don't have
+  = Nothing                    -- to/from operations, (and should not need them)
+
+       -- If any of the constructor has an unboxed type as argument,

        -- then we can't build the embedding-projection pair, because
        -- it relies on instantiating *polymorphic* sum and product types
        -- at the argument types of the constructors
        -- then we can't build the embedding-projection pair, because
        -- it relies on instantiating *polymorphic* sum and product types
        -- at the argument types of the constructors

-  | any (any isUnLiftedType . dataConOrigArgTys) datacons
+       -- Nor can we do the job if it's an existential data constructor,
+  | or [ any isUnLiftedType (dataConOrigArgTys dc) || isExistentialDataCon dc
+       | dc <- datacons ]

   = Nothing
 
   = Nothing
 

+  | null datacons      -- There are no constructors; 
+  = Nothing            -- there are no values of this type
+

   | otherwise
   | otherwise

-  = Just (EP { fromEP = mkId from_name from_ty from_id_info,
-              toEP   = mkId to_name   to_ty   to_id_info })
+  = ASSERT( not (null datacons) )      -- mk_sum_stuff loops if no datacons
+    Just (EP { fromEP = mkVanillaGlobal from_name from_ty from_id_info,
+              toEP   = mkVanillaGlobal to_name   to_ty   to_id_info })

   where
   where

-    tyvars      = tyConTyVars tycon                    -- [a, b, c]
-    datacons    = tyConDataConsIfAvailable tycon       -- [C, D]
-    tycon_ty    = mkTyConApp tycon tyvar_tys           -- T a b c
-    tyvar_tys    = mkTyVarTys tyvars
+    maybe_datacons = tyConDataCons_maybe tycon
+    Just datacons  = maybe_datacons            -- [C, D]

 
 

-    from_id_info = vanillaIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
-    to_id_info   = vanillaIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn
+    tyvars        = tyConTyVars tycon          -- [a, b, c]
+    tycon_ty      = mkTyConApp tycon tyvar_tys -- T a b c
+    tyvar_tys      = mkTyVarTys tyvars
+
+    from_id_info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
+                                     `setArityInfo`     exprArity from_fn
+    to_id_info   = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn
+                                     `setArityInfo`     exprArity to_fn
+       -- It's important to set the arity info, so that
+       -- the calling convention (gotten from arity) 
+       -- matches reality.

 
     from_ty = mkForAllTys tyvars (mkFunTy tycon_ty rep_ty)
     to_ty   = mkForAllTys tyvars (mkFunTy rep_ty tycon_ty)
 
     (from_fn, to_fn, rep_ty) 
        | isNewTyCon tycon
 
     from_ty = mkForAllTys tyvars (mkFunTy tycon_ty rep_ty)
     to_ty   = mkForAllTys tyvars (mkFunTy rep_ty tycon_ty)
 
     (from_fn, to_fn, rep_ty) 
        | isNewTyCon tycon

-       = ( mkLams tyvars $ Lam x  $ Note (Coerce newrep_ty tycon_ty) (Var x),
+       = ( mkLams tyvars $ Lam x  $ mkNewTypeBody tycon newrep_ty (Var x),

            Var (dataConWrapId the_datacon),
            newrep_ty )
 
            Var (dataConWrapId the_datacon),
            newrep_ty )
 

@@ -267,25 +294,27 @@ mkTyConGenInfo tycon from_name to_name
            idType rep_var )
 
     -- x :: T a b c
            idType rep_var )
 
     -- x :: T a b c

-    x  = mkTemplateLocal 1 tycon_ty
+    x = mkGenericLocal u1 tycon_ty
+    (u1 : uniqs) = builtinUniques

 
            ----------------------
            --  Newtypes only
     [the_datacon]  = datacons
 
            ----------------------
            --  Newtypes only
     [the_datacon]  = datacons

-    newrep_ty = applyTys (expectJust "mkGenTyConInfo" (newTyConRep tycon)) tyvar_tys
+    (_, newrep_ty) = newTyConRep tycon

        
            ----------------------
            --  Non-newtypes only
     -- Recurse over the sum first
     -- The "2" is the first free unique
        
            ----------------------
            --  Non-newtypes only
     -- Recurse over the sum first
     -- The "2" is the first free unique

-    (from_alts, to_inner, rep_var) = mk_sum_stuff 2 tyvars datacons
+    (from_alts, to_inner, rep_var) = mk_sum_stuff uniqs tyvars datacons

     
     

+mkTyConGenInfo tycon names = pprPanic "mkTyConGenInfo" (ppr tycon <+> ppr names)

     
 
 ----------------------------------------------------
 --     Dealing with sums
 ----------------------------------------------------
     
 
 ----------------------------------------------------
 --     Dealing with sums
 ----------------------------------------------------

-mk_sum_stuff :: Int            -- Base for generating unique names
+mk_sum_stuff :: [Unique]       -- Base for generating unique names

             -> [TyVar]         -- Type variables over which the tycon is abstracted
             -> [DataCon]       -- The data constructors
             -> ([Alt Id], CoreExpr, Id)
             -> [TyVar]         -- Type variables over which the tycon is abstracted
             -> [DataCon]       -- The data constructors
             -> ([Alt Id], CoreExpr, Id)

@@ -300,29 +329,36 @@ mk_sum_stuff :: Int               -- Base for generating unique names
 --                                                D a b c }} },
 --                        cd)
 
 --                                                D a b c }} },
 --                        cd)
 

-mk_sum_stuff i tyvars [datacon]
+mk_sum_stuff us tyvars [datacon]

    = ([from_alt], to_body_fn app_exp, rep_var)
    where
    = ([from_alt], to_body_fn app_exp, rep_var)
    where

-     types        = dataConOrigArgTys datacon 
-     datacon_vars = mkTemplateLocalsNum i types
-     new_i        = i + length types 
-     app_exp      = mkVarApps (Var (dataConId datacon)) (tyvars ++ datacon_vars)
-     from_alt     = (DataAlt datacon, datacon_vars, from_alt_rhs)
+     types        = dataConOrigArgTys datacon  -- Existentials already excluded
+     datacon_vars = zipWith mkGenericLocal us types
+     us'          = dropList types us
+
+     app_exp      = mkVarApps (Var (dataConWrapId datacon)) (tyvars ++ datacon_vars)
+     from_alt     = mkReboxingAlt us' datacon datacon_vars from_alt_rhs
+                       -- We are talking about *user* datacons here; hence
+                       --      dataConWrapId
+                       --      mkReboxingAlt
+
+     (_,args',_)  = from_alt
+     us''        = dropList args' us'  -- Conservative, but safe

      
      

-     (_, from_alt_rhs, to_body_fn, rep_var) = mk_prod_stuff new_i datacon_vars
+     (_, from_alt_rhs, to_body_fn, rep_var) = mk_prod_stuff us'' datacon_vars

 
 

-mk_sum_stuff i tyvars datacons
+mk_sum_stuff (u:us) tyvars datacons

   = (wrap inlDataCon l_from_alts ++ wrap inrDataCon r_from_alts,
      Case (Var rep_var) rep_var [(DataAlt inlDataCon, [l_rep_var], l_to_body),
                                 (DataAlt inrDataCon, [r_rep_var], r_to_body)],
      rep_var)
   where
     (l_datacons, r_datacons)           = splitInHalf datacons
   = (wrap inlDataCon l_from_alts ++ wrap inrDataCon r_from_alts,
      Case (Var rep_var) rep_var [(DataAlt inlDataCon, [l_rep_var], l_to_body),
                                 (DataAlt inrDataCon, [r_rep_var], r_to_body)],
      rep_var)
   where
     (l_datacons, r_datacons)           = splitInHalf datacons

-    (l_from_alts, l_to_body, l_rep_var) = mk_sum_stuff (i+2) tyvars l_datacons
-    (r_from_alts, r_to_body, r_rep_var) = mk_sum_stuff (i+2) tyvars r_datacons
+    (l_from_alts, l_to_body, l_rep_var) = mk_sum_stuff us tyvars l_datacons
+    (r_from_alts, r_to_body, r_rep_var) = mk_sum_stuff us tyvars r_datacons

     rep_tys                            = [idType l_rep_var, idType r_rep_var]
     rep_ty                             = mkTyConApp plusTyCon rep_tys
     rep_tys                            = [idType l_rep_var, idType r_rep_var]
     rep_ty                             = mkTyConApp plusTyCon rep_tys

-    rep_var                            = mkTemplateLocal i rep_ty
+    rep_var                            = mkGenericLocal u rep_ty

 
     wrap :: DataCon -> [Alt Id] -> [Alt Id] 
        -- Wrap an application of the Inl or Inr constructor round each alternative
 
     wrap :: DataCon -> [Alt Id] -> [Alt Id] 
        -- Wrap an application of the Inl or Inr constructor round each alternative

@@ -331,21 +367,14 @@ mk_sum_stuff i tyvars datacons
        where
          datacon_app = mkTyApps (Var (dataConWrapId datacon)) rep_tys
 
        where
          datacon_app = mkTyApps (Var (dataConWrapId datacon)) rep_tys
 

-
--- This constructs the c_of datatype from a DataCon and a Type
--- The identity function at the moment.
-cOfConstr :: DataCon -> Type -> Type
-cOfConstr y z = z
-
-

 ----------------------------------------------------
 --     Dealing with products
 ----------------------------------------------------
 ----------------------------------------------------
 --     Dealing with products
 ----------------------------------------------------

-mk_prod_stuff :: Int                   -- Base for unique names
+mk_prod_stuff :: [Unique]              -- Base for unique names

              -> [Id]                   -- arg-ids; args of the original user-defined constructor
                                        --      They are bound enclosing from_rhs
                                        --      Please bind these in the to_body_fn 
              -> [Id]                   -- arg-ids; args of the original user-defined constructor
                                        --      They are bound enclosing from_rhs
                                        --      Please bind these in the to_body_fn 

-             -> (Int,                  -- Depleted unique-name supply
+             -> ([Unique],             -- Depleted unique-name supply

                  CoreExpr,             -- from-rhs: puts together the representation from the arg_ids
                  CoreExpr -> CoreExpr, -- to_body_fn: takes apart the representation
                  Id)                   -- The rep-id; please bind this to the representation
                  CoreExpr,             -- from-rhs: puts together the representation from the arg_ids
                  CoreExpr -> CoreExpr, -- to_body_fn: takes apart the representation
                  Id)                   -- The rep-id; please bind this to the representation

@@ -361,26 +390,26 @@ mk_prod_stuff :: Int                      -- Base for unique names
 -- because the returned to_body_fns are nested.  
 -- Hence the returned unqique-name supply
 
 -- because the returned to_body_fns are nested.  
 -- Hence the returned unqique-name supply
 

-mk_prod_stuff i []             -- Unit case
-  = (i,
+mk_prod_stuff (u:us) []                -- Unit case
+  = (us,

      Var (dataConWrapId genUnitDataCon),
      \x -> x, 
      Var (dataConWrapId genUnitDataCon),
      \x -> x, 

-     mkTemplateLocal i (mkTyConApp genUnitTyCon []))
+     mkGenericLocal u (mkTyConApp genUnitTyCon []))

 
 

-mk_prod_stuff i [arg_var]      -- Singleton case
-  = (i, Var arg_var, \x -> x, arg_var)
+mk_prod_stuff us [arg_var]     -- Singleton case
+  = (us, Var arg_var, \x -> x, arg_var)

 
 

-mk_prod_stuff i arg_vars       -- Two or more
-  = (r_i, 
+mk_prod_stuff (u:us) arg_vars  -- Two or more
+  = (us'', 

      mkConApp crossDataCon (map Type rep_tys ++ [l_alt_rhs, r_alt_rhs]),
      \x -> Case (Var rep_var) rep_var 
                [(DataAlt crossDataCon, [l_rep_var, r_rep_var], l_to_body_fn (r_to_body_fn x))],
      rep_var)
   where
     (l_arg_vars, r_arg_vars)            = splitInHalf arg_vars
      mkConApp crossDataCon (map Type rep_tys ++ [l_alt_rhs, r_alt_rhs]),
      \x -> Case (Var rep_var) rep_var 
                [(DataAlt crossDataCon, [l_rep_var, r_rep_var], l_to_body_fn (r_to_body_fn x))],
      rep_var)
   where
     (l_arg_vars, r_arg_vars)            = splitInHalf arg_vars

-    (l_i, l_alt_rhs, l_to_body_fn, l_rep_var) = mk_prod_stuff (i+1) l_arg_vars
-    (r_i, r_alt_rhs, r_to_body_fn, r_rep_var) = mk_prod_stuff l_i   r_arg_vars
-    rep_var = mkTemplateLocal i (mkTyConApp crossTyCon rep_tys)
+    (us', l_alt_rhs, l_to_body_fn, l_rep_var) = mk_prod_stuff us  l_arg_vars
+    (us'', r_alt_rhs, r_to_body_fn, r_rep_var) = mk_prod_stuff us' r_arg_vars
+    rep_var = mkGenericLocal u (mkTyConApp crossTyCon rep_tys)

     rep_tys = [idType l_rep_var, idType r_rep_var]
 \end{code}
 
     rep_tys = [idType l_rep_var, idType r_rep_var]
 \end{code}
 

@@ -393,6 +422,9 @@ splitInHalf list = (left, right)
                   half  = length list `div` 2
                   left  = take half list
                   right = drop half list
                   half  = length list `div` 2
                   left  = take half list
                   right = drop half list

+
+mkGenericLocal :: Unique -> Type -> Id
+mkGenericLocal uniq ty = mkSysLocal FSLIT("g") uniq ty

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

@@ -403,7 +435,51 @@ splitInHalf list = (left, right)
 
 Generating the Generic default method.  Uses the bimaps to generate the
 actual method. All of this is rather incomplete, but it would be nice
 
 Generating the Generic default method.  Uses the bimaps to generate the
 actual method. All of this is rather incomplete, but it would be nice

-to make even this work.
+to make even this work.  Example
+
+       class Foo a where
+         op :: Op a
+
+       instance Foo T
+
+Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
+
+       instance Foo T where
+          op = <mkGenericRhs op a T>
+
+To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
+
+       toOp   :: Op Trep -> Op T
+       fromOp :: Op T    -> Op Trep
+
+(the bimap) and then fill in the RHS with
+
+       instance Foo T where
+          op = toOp op
+
+Remember, we're generating a RenamedHsExpr, so the result of all this
+will be fed to the type checker.  So the 'op' on the RHS will be 
+at the representation type for T, Trep.
+
+
+A note about polymorphism.  Suppose the class op is polymorphic:
+
+       class Baz a where
+         op :: forall b. Ord b => a -> b -> b
+
+Then we can still generate a bimap with
+
+       toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
+
+and fill in the instance decl thus
+
+       instance Foo T where
+          op = toOp op
+
+By the time the type checker has done its stuff we'll get
+
+       instance Foo T where
+          op = \b. \dict::Ord b. toOp b (op Trep b dict)

 
 \begin{code}
 mkGenericRhs :: Id -> TyVar -> TyCon -> RenamedHsExpr
 
 \begin{code}
 mkGenericRhs :: Id -> TyVar -> TyCon -> RenamedHsExpr

@@ -415,37 +491,51 @@ mkGenericRhs sel_id tyvar tycon
        Just (EP from to) = tyConGenInfo tycon  -- Caller checked this will succeed
         ep               = EP (HsVar (idName from)) (HsVar (idName to)) 
 
        Just (EP from to) = tyConGenInfo tycon  -- Caller checked this will succeed
         ep               = EP (HsVar (idName from)) (HsVar (idName to)) 
 

-        -- Takes out the ForAll and the Class rstrictions in front of the
-        -- type of the method.
-       (_,_,op_ty) = splitSigmaTy (idType sel_id)
+        -- Takes out the ForAll and the Class restrictions 
+        -- in front of the type of the method.
+       (_,_,op_ty) = tcSplitSigmaTy (idType sel_id)
+
+        -- Do it again!  This deals with the case where the method type 
+       -- is polymorphic -- see notes above
+       (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty

 
        -- Now we probably have a tycon in front
         -- of us, quite probably a FunTyCon.
 
        -- Now we probably have a tycon in front
         -- of us, quite probably a FunTyCon.

-        bimap = generate_bimap (tyvar, ep) op_ty
+        bimap = generate_bimap (tyvar, ep, local_tvs) final_ty

 
 

--- EP is the environment of to/from bimaps, but as we only have one type 
--- variable at the moment, there is only one EP.
+type EPEnv = (TyVar,           -- The class type variable
+             EP RenamedHsExpr, -- The EP it maps to
+             [TyVar]           -- Other in-scope tyvars; they have an identity EP
+            )

 
 -------------------
 
 -------------------

-generate_bimap ::  (TyVar, EP RenamedHsExpr) -> Type -> EP RenamedHsExpr
+generate_bimap :: EPEnv
+              -> Type
+              -> EP RenamedHsExpr

 -- Top level case - splitting the TyCon.
 -- Top level case - splitting the TyCon.

-generate_bimap (tv,ep) ty | isTyVarTy ty = ASSERT( getTyVar "Generics.generate_bimap" ty == tv) ep
-                         | otherwise    = bimapApp (tv,ep) (splitTyConApp_maybe ty)
+generate_bimap env@(tv,ep,local_tvs) ty 
+  = case getTyVar_maybe ty of
+       Just tv1 |  tv == tv1 -> ep                             -- The class tyvar
+                |  otherwise -> ASSERT( tv1 `elem` local_tvs)  -- One of the polymorphic tyvars of the method
+                                idEP   
+       Nothing  -> bimapApp env (tcSplitTyConApp_maybe ty)

 
 -------------------
 
 -------------------

-bimapApp :: (TyVar, EP RenamedHsExpr) -> Maybe (TyCon, [Type]) -> EP RenamedHsExpr
-bimapApp ep Nothing                = panic "TcClassDecl: Type Application!"
-bimapApp ep (Just (tycon, ty_args)) 
+bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP RenamedHsExpr
+bimapApp env Nothing               = panic "TcClassDecl: Type Application!"
+bimapApp env (Just (tycon, ty_args)) 

   | tycon == funTyCon       = bimapArrow arg_eps
   | isBoxedTupleTyCon tycon = bimapTuple arg_eps
   | otherwise              =   -- Otherwise validGenericMethodType will 
                                -- have checked that the type is a constant type
   | tycon == funTyCon       = bimapArrow arg_eps
   | isBoxedTupleTyCon tycon = bimapTuple arg_eps
   | otherwise              =   -- Otherwise validGenericMethodType will 
                                -- have checked that the type is a constant type

-                             ASSERT( isEmptyVarSet (tyVarsOfTypes ty_args) )
-                             EP idexpr idexpr
+                             ASSERT( all (`elem` local_tvs) (varSetElems (tyVarsOfTypes ty_args)) )
+                             idEP

     where
     where

-      arg_eps = map (generate_bimap ep) ty_args
+      arg_eps = map (generate_bimap env) ty_args
+      (_,_,local_tvs) = env

 
 -------------------
 
 -------------------

+-- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')

 bimapArrow [ep1, ep2]
   = EP { fromEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] from_body, 
         toEP   = mk_hs_lam [VarPatIn g1, VarPatIn g2] to_body }
 bimapArrow [ep1, ep2]
   = EP { fromEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] from_body, 
         toEP   = mk_hs_lam [VarPatIn g1, VarPatIn g2] to_body }

@@ -458,7 +548,7 @@ bimapTuple eps
   = EP { fromEP = mk_hs_lam [tuple_pat] from_body,
         toEP   = mk_hs_lam [tuple_pat] to_body }
   where
   = EP { fromEP = mk_hs_lam [tuple_pat] from_body,
         toEP   = mk_hs_lam [tuple_pat] to_body }
   where

-    names      = take (length eps) genericNames
+    names      = takeList eps genericNames

     tuple_pat  = TuplePatIn (map VarPatIn names) Boxed
     eps_w_names = eps `zip` names
     to_body     = ExplicitTuple [toEP   ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
     tuple_pat  = TuplePatIn (map VarPatIn names) Boxed
     eps_w_names = eps `zip` names
     to_body     = ExplicitTuple [toEP   ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed

@@ -466,9 +556,13 @@ bimapTuple eps
 
 -------------------
 genericNames :: [Name]
 
 -------------------
 genericNames :: [Name]

-genericNames = [mkSysLocalName (mkBuiltinUnique i) (_PK_ ('g' : show i)) | i <- [1..]]
+genericNames = [mkSystemName (mkBuiltinUnique i) (mkFastString ('g' : show i)) | i <- [1..]]

 (g1:g2:g3:_) = genericNames
 
 (g1:g2:g3:_) = genericNames
 

-mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body Nothing builtinSrcLoc))
-idexpr             = mk_hs_lam [VarPatIn g3] (HsVar g3)
+mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType builtinSrcLoc))
+
+idEP :: EP RenamedHsExpr
+idEP = EP idexpr idexpr
+     where
+       idexpr = mk_hs_lam [VarPatIn g3] (HsVar g3)

 \end{code}
 \end{code}