[project @ 2003-10-29 18:10:57 by simonpj]

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

diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs
index 674dc3b..a0297ad 100644 (file)
--- a/ghc/compiler/types/Generics.lhs
+++ b/ghc/compiler/types/Generics.lhs
@@ -1,44 +1,34 @@
 \begin{code}
 \begin{code}

-module Generics ( mkTyConGenInfo, mkGenericRhs, 
+module Generics ( canDoGenerics, mkGenericBinds,
+                 mkGenericRhs, 

                  validGenericInstanceType, validGenericMethodType
     ) where
 
 
                  validGenericInstanceType, validGenericMethodType
     ) where
 
 

-import CmdLineOpts     ( DynFlags, DynFlag(..), dopt )
-import RnHsSyn         ( RenamedHsExpr )
-import HsSyn           ( HsExpr(..), InPat(..), mkSimpleMatch )
-
-import Type             ( Type, isUnLiftedType, applyTys, tyVarsOfType, tyVarsOfTypes,
-                         mkTyVarTys, mkForAllTys, mkTyConApp, splitFunTys,
-                         mkFunTy, funResultTy, isTyVarTy, splitForAllTys,
-                         splitSigmaTy, getTyVar, splitTyConApp_maybe, funTyCon
+import HsSyn
+import Type             ( Type, isUnLiftedType, tyVarsOfType, tyVarsOfTypes,
+                         isTyVarTy, getTyVar_maybe, funTyCon

                        )
                        )

+import TcType          ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitSigmaTy, isTauTy )
+import DataCon          ( DataCon, dataConOrigArgTys, isExistentialDataCon,
+                         dataConSourceArity )

 
 

-import DataCon          ( DataCon, dataConOrigArgTys, dataConWrapId, dataConId )
-
-import TyCon            ( TyCon, tyConTyVars, tyConDataConsIfAvailable, 
-                         tyConGenInfo, isNewTyCon, newTyConRep, isBoxedTupleTyCon
+import TyCon            ( TyCon, tyConName, tyConDataCons, 
+                         tyConHasGenerics, isBoxedTupleTyCon

                        )
                        )

-import Name            ( Name, mkSysLocalName )
-import CoreSyn          ( mkLams, Expr(..), CoreExpr, AltCon(..), Note(..),
-                         mkConApp, Alt, Bind (..), mkTyApps, mkVarApps )
-import BasicTypes       ( RecFlag(..), EP(..), Boxity(..) )
+import Name            ( nameModuleName, nameOccName, getSrcLoc )
+import OccName         ( mkGenOcc1, mkGenOcc2 )
+import RdrName         ( RdrName, getRdrName, mkVarUnqual, mkOrig )
+import BasicTypes       ( EP(..), Boxity(..) )

 import Var              ( TyVar )
 import Var              ( TyVar )

-import VarSet          ( isEmptyVarSet )
-import Id               ( Id, mkTemplateLocal, mkTemplateLocals, idType, idName, 
-                         mkTemplateLocalsNum, mkVanillaId, mkId
-                       ) 
-import TysWiredIn       ( genericTyCons,
-                         genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon,
-                         inlDataCon, crossTyCon, crossDataCon
-                       )
-import IdInfo           ( vanillaIdInfo, setUnfoldingInfo )
-import CoreUnfold       ( mkTopUnfolding ) 
-
-import Unique          ( Uniquable(..), mkBuiltinUnique )
-import SrcLoc          ( builtinSrcLoc )
-import Maybes          ( maybeToBool, expectJust )
+import VarSet          ( varSetElems )
+import Id               ( Id, idType )
+import PrelNames
+       
+import SrcLoc          ( generatedSrcLoc )
+import Util             ( takeList )

 import Outputable 
 import Outputable 

+import FastString

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

@@ -81,7 +71,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
 

@@ -188,8 +179,8 @@ validGenericInstanceType :: Type -> Bool
   --   f {| a + Int |}
 
 validGenericInstanceType inst_ty
   --   f {| a + Int |}
 
 validGenericInstanceType inst_ty

-  = case splitTyConApp_maybe inst_ty of
-       Just (tycon, tys) ->  all isTyVarTy tys && tycon `elem` genericTyCons
+  = case tcSplitTyConApp_maybe inst_ty of
+       Just (tycon, tys) ->  all isTyVarTy tys && tyConName tycon `elem` genericTyConNames

        Nothing           ->  False
 
 validGenericMethodType :: Type -> Bool
        Nothing           ->  False
 
 validGenericMethodType :: Type -> Bool

@@ -198,17 +189,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}
 
 

@@ -219,80 +217,67 @@ valid ty
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-mkTyConGenInfo :: DynFlags -> TyCon -> Name -> Name -> Maybe (EP Id)
--- mkTyConGenInfo is called twice
---     once from TysWiredIn for Tuples
---     once the typechecker TcTyDecls 
--- to generate generic types and conversion functions for all datatypes.
--- 
--- Must only be called with an algebraic type.
--- 
--- The two names are the names constructed by the renamer
--- for the fromT and toT conversion functions.
-
-mkTyConGenInfo dflags tycon from_name to_name
-  | dopt Opt_Generics dflags
-  = Nothing
-
-  | null 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
+canDoGenerics :: [DataCon] -> Bool
+-- Called on source-code data types, to see if we should generate
+-- generic functions for them.  (This info is recorded in the interface file for
+-- imported data types.)
+
+canDoGenerics data_cons
+  =  not (any bad_con data_cons)       -- See comment below
+  && not (null data_cons)              -- No values of the type
+  where
+    bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || isExistentialDataCon dc
+       -- 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
-  = Nothing

 
 

-  | otherwise
-  = Just (EP { fromEP = mkId from_name from_ty from_id_info,
-              toEP   = mkId to_name   to_ty   to_id_info })
+       -- Nor can we do the job if it's an existential data constructor,
+
+       -- Nor if the args are polymorphic types (I don't think)
+    bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
+\end{code}
+
+%************************************************************************
+%*                                                                     *
+\subsection{Generating the RHS of a generic default method}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+type US = Int  -- Local unique supply, just a plain Int
+type FromAlt = (Pat RdrName, HsExpr RdrName)
+
+mkGenericBinds :: [TyCon] -> MonoBinds RdrName
+mkGenericBinds tcs = andMonoBindList [ mkTyConGenBinds tc 
+                                    | tc <- tcs, tyConHasGenerics tc]
+
+mkTyConGenBinds :: TyCon -> MonoBinds RdrName
+mkTyConGenBinds tycon
+  = FunMonoBind from_RDR False {- Not infix -}
+               [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
+               loc
+       `AndMonoBinds`
+    FunMonoBind to_RDR False 
+               [mkSimpleHsAlt (VarPat to_arg) to_body] loc

   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
-
-    from_id_info = vanillaIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
-    to_id_info   = vanillaIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn
-
-    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),
-           Var (dataConWrapId the_datacon),
-           newrep_ty )
-
-       | otherwise
-       = ( mkLams tyvars $ Lam x     $ Case (Var x) x from_alts,
-           mkLams tyvars $ Lam rep_var to_inner,
-           idType rep_var )
-
-    -- x :: T a b c
-    x  = mkTemplateLocal 1 tycon_ty
-
-           ----------------------
-           --  Newtypes only
-    [the_datacon]  = datacons
-    newrep_ty = applyTys (expectJust "mkGenTyConInfo" (newTyConRep tycon)) tyvar_tys
-       
-           ----------------------
-           --  Non-newtypes only
+    loc             = getSrcLoc tycon
+    datacons = tyConDataCons tycon
+    (from_RDR, to_RDR) = mkGenericNames tycon
+

     -- Recurse over the sum first
     -- 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 :: [FromAlt]
+    (from_alts, to_arg, to_body) = mk_sum_stuff init_us datacons
+    init_us = 1::Int           -- Unique supply

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

-mk_sum_stuff :: Int            -- Base for generating unique names
-            -> [TyVar]         -- Type variables over which the tycon is abstracted
-            -> [DataCon]       -- The data constructors
-            -> ([Alt Id], CoreExpr, Id)
+
+mk_sum_stuff :: US                     -- Base for generating unique names
+            -> [DataCon]               -- The data constructors
+            -> ([FromAlt],                     -- Alternatives for the T->Trep "from" function
+                RdrName, HsExpr RdrName)       -- Arg and body of the Trep->T "to" function

 
 -- For example, given
 --     data T = C | D Int Int Int
 
 -- For example, given
 --     data T = C | D Int Int Int

@@ -304,99 +289,103 @@ 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]
-   = ([from_alt], to_body_fn app_exp, rep_var)
+mk_sum_stuff us [datacon]
+   = ([from_alt], to_arg, to_body_fn app_exp)

    where
    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)
-     
-     (_, from_alt_rhs, to_body_fn, rep_var) = mk_prod_stuff new_i datacon_vars
-
-mk_sum_stuff i 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)
+     n_args = dataConSourceArity datacon       -- Existentials already excluded
+
+     datacon_vars = map mkGenericLocal [us .. us+n_args-1]
+     us'          = us + n_args
+
+     datacon_rdr  = getRdrName datacon
+     app_exp      = mkHsVarApps datacon_rdr datacon_vars
+     from_alt     = (mkConPat datacon_rdr datacon_vars, from_alt_rhs)
+
+     (_, from_alt_rhs, to_arg, to_body_fn) = mk_prod_stuff us' datacon_vars
+
+mk_sum_stuff us datacons
+  = (wrap inlDataCon_RDR l_from_alts ++ wrap inrDataCon_RDR r_from_alts,
+     to_arg,
+     HsCase (HsVar to_arg) 
+           [mkSimpleHsAlt (mkConPat inlDataCon_RDR [l_to_arg]) l_to_body,
+            mkSimpleHsAlt (mkConPat inrDataCon_RDR [r_to_arg]) r_to_body]
+           generatedSrcLoc)

   where
   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
-    rep_tys                            = [idType l_rep_var, idType r_rep_var]
-    rep_ty                             = mkTyConApp plusTyCon rep_tys
-    rep_var                            = mkTemplateLocal i rep_ty
-
-    wrap :: DataCon -> [Alt Id] -> [Alt Id] 
-       -- Wrap an application of the Inl or Inr constructor round each alternative
-    wrap datacon alts
-       = [(dc, args, App datacon_app rhs) | (dc,args,rhs) <- alts]
-       where
-         datacon_app = mkTyApps (Var (dataConWrapId datacon)) rep_tys
+    (l_datacons, r_datacons)           = splitInHalf datacons
+    (l_from_alts, l_to_arg, l_to_body) = mk_sum_stuff us' l_datacons
+    (r_from_alts, r_to_arg, r_to_body) = mk_sum_stuff us' r_datacons

 
 

+    to_arg = mkGenericLocal us
+    us'           = us+1

 
 

--- 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
+    wrap :: RdrName -> [FromAlt] -> [FromAlt]
+       -- Wrap an application of the Inl or Inr constructor round each alternative
+    wrap dc alts = [(pat, HsApp (HsVar dc) rhs) | (pat,rhs) <- alts]

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

-mk_prod_stuff :: Int                   -- Base for unique names
-             -> [Id]                   -- arg-ids; args of the original user-defined constructor
+mk_prod_stuff :: US                    -- Base for unique names
+             -> [RdrName]              -- arg-ids; args of the original user-defined constructor

                                        --      They are bound enclosing from_rhs
                                        --      Please bind these in the to_body_fn 
                                        --      They are bound enclosing from_rhs
                                        --      Please bind these in the to_body_fn 

-             -> (Int,                  -- 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
+             -> (US,                   -- Depleted unique-name supply
+                 HsExpr RdrName,                       -- from-rhs: puts together the representation from the arg_ids
+                 RdrName,                              -- to_arg: 
+                 HsExpr RdrName -> HsExpr RdrName)     -- to_body_fn: takes apart the representation

 
 -- For example:
 
 -- For example:

--- mk_prod_stuff [a,b,c] = ( a :*: (b :*: c),
---                          \x -> case abc of { a :*: bc ->
---                                case bc  of { b :*: c  -> 
---                                x,
---                          abc )
+-- mk_prod_stuff abc [a,b,c] = ( a :*: (b :*: c),
+--                              \x -> case abc of { a :*: bc ->
+--                                    case bc  of { b :*: c  -> 
+--                                    x)

 
 

--- We need to use different uqiques in the branches 
+-- We need to use different uniques in the branches 

 -- 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,
-     Var (dataConWrapId genUnitDataCon),
-     \x -> x, 
-     mkTemplateLocal i (mkTyConApp genUnitTyCon []))
-
-mk_prod_stuff i [arg_var]      -- Singleton case
-  = (i, Var arg_var, \x -> x, arg_var)
-
-mk_prod_stuff i arg_vars       -- Two or more
-  = (r_i, 
-     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)
+mk_prod_stuff us []            -- Unit case
+  = (us+1,
+     HsVar genUnitDataCon_RDR,
+     mkGenericLocal us,
+     \x -> x)
+
+mk_prod_stuff us [arg_var]     -- Singleton case
+  = (us, HsVar arg_var, arg_var, \x -> x)
+
+mk_prod_stuff us arg_vars      -- Two or more
+  = (us'', 
+     HsVar crossDataCon_RDR `HsApp` l_alt_rhs `HsApp` r_alt_rhs,
+     to_arg, 
+     \x -> HsCase (HsVar to_arg)
+                 [mkSimpleHsAlt (mkConPat crossDataCon_RDR [l_to_arg, r_to_arg])
+                                (l_to_body_fn (r_to_body_fn x))] generatedSrcLoc)

   where
   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)
-    rep_tys = [idType l_rep_var, idType r_rep_var]
-\end{code}
+    to_arg = mkGenericLocal us
+    (l_arg_vars, r_arg_vars)                 = splitInHalf arg_vars
+    (us',  l_alt_rhs, l_to_arg, l_to_body_fn) = mk_prod_stuff (us+1)  l_arg_vars
+    (us'', r_alt_rhs, r_to_arg, r_to_body_fn) = mk_prod_stuff us' r_arg_vars

 
 

-A little utility function

 
 

-\begin{code}

 splitInHalf :: [a] -> ([a],[a])
 splitInHalf list = (left, right)
                 where
                   half  = length list `div` 2
                   left  = take half list
                   right = drop half list
 splitInHalf :: [a] -> ([a],[a])
 splitInHalf list = (left, right)
                 where
                   half  = length list `div` 2
                   left  = take half list
                   right = drop half list

+
+mkGenericLocal :: US -> RdrName
+mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
+
+mkGenericNames tycon
+  = (from_RDR, to_RDR)
+  where
+    tc_name  = tyConName tycon
+    tc_occ   = nameOccName tc_name
+    tc_mod   = nameModuleName tc_name
+    from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ)
+    to_RDR   = mkOrig tc_mod (mkGenOcc2 tc_occ)

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

@@ -407,72 +396,134 @@ 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}
 
 \begin{code}

-mkGenericRhs :: Id -> TyVar -> TyCon -> RenamedHsExpr
+mkGenericRhs :: Id -> TyVar -> TyCon -> HsExpr RdrName

 mkGenericRhs sel_id tyvar tycon
 mkGenericRhs sel_id tyvar tycon

-  = HsApp (toEP bimap) (HsVar (idName sel_id))
+  = HsApp (toEP bimap) (HsVar (getRdrName sel_id))

   where 
        -- Initialising the "Environment" with the from/to functions
        -- on the datatype (actually tycon) in question
   where 
        -- Initialising the "Environment" with the from/to functions
        -- on the datatype (actually tycon) in question

-       Just (EP from to) = tyConGenInfo tycon  -- Caller checked this will succeed
-        ep               = EP (HsVar (idName from)) (HsVar (idName to)) 
+       (from_RDR, to_RDR) = mkGenericNames tycon 
+
+        -- Takes out the ForAll and the Class restrictions 
+        -- in front of the type of the method.
+       (_,_,op_ty) = tcSplitSigmaTy (idType sel_id)

 
 

-        -- Takes out the ForAll and the Class rstrictions in front of the
-        -- type of the method.
-       (_,_,op_ty) = splitSigmaTy (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
+        ep    = EP (HsVar from_RDR) (HsVar to_RDR) 
+        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 (HsExpr RdrName),      -- 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 (HsExpr RdrName)

 -- 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 (HsExpr RdrName)
+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]
 bimapArrow [ep1, ep2]

-  = EP { fromEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] from_body, 
-        toEP   = mk_hs_lam [VarPatIn g1, VarPatIn g2] to_body }
+  = EP { fromEP = mk_hs_lam [VarPat a_RDR, VarPat b_RDR] from_body, 
+        toEP   = mk_hs_lam [VarPat a_RDR, VarPat b_RDR] to_body }

   where
   where

-    from_body = fromEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ toEP   ep1 `HsApp` HsVar g2))
-    to_body   = toEP   ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ fromEP ep1 `HsApp` HsVar g2))
+    from_body = fromEP ep2 `HsApp` (HsPar $ HsVar a_RDR `HsApp` (HsPar $ toEP   ep1 `HsApp` HsVar b_RDR))
+    to_body   = toEP   ep2 `HsApp` (HsPar $ HsVar a_RDR `HsApp` (HsPar $ fromEP ep1 `HsApp` HsVar b_RDR))

 
 -------------------
 bimapTuple eps 
   = EP { fromEP = mk_hs_lam [tuple_pat] from_body,
         toEP   = mk_hs_lam [tuple_pat] to_body }
   where
 
 -------------------
 bimapTuple eps 
   = EP { fromEP = mk_hs_lam [tuple_pat] from_body,
         toEP   = mk_hs_lam [tuple_pat] to_body }
   where

-    names      = take (length eps) genericNames
-    tuple_pat  = TuplePatIn (map VarPatIn names) Boxed
+    names      = takeList eps gs_RDR
+    tuple_pat  = TuplePat (map VarPat names) Boxed

     eps_w_names = eps `zip` names
     to_body     = ExplicitTuple [toEP   ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
     from_body   = ExplicitTuple [fromEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
 
 -------------------
     eps_w_names = eps `zip` names
     to_body     = ExplicitTuple [toEP   ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
     from_body   = ExplicitTuple [fromEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
 
 -------------------

-genericNames :: [Name]
-genericNames = [mkSysLocalName (mkBuiltinUnique i) (_PK_ ('g' : show i)) | i <- [1..]]
-(g1:g2:g3:_) = genericNames
+a_RDR  = mkVarUnqual FSLIT("a")
+b_RDR  = mkVarUnqual FSLIT("b")
+gs_RDR = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ]
+
+mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType generatedSrcLoc))

 
 

-mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body Nothing builtinSrcLoc))
-idexpr             = mk_hs_lam [VarPatIn g3] (HsVar g3)
+idEP :: EP (HsExpr RdrName)
+idEP = EP idexpr idexpr
+     where
+       idexpr = mk_hs_lam [VarPat a_RDR] (HsVar a_RDR)

 \end{code}
 \end{code}