[project @ 2004-10-11 16:16:20 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 9be3138..61b1a0f 100644 (file)
--- a/ghc/compiler/types/Generics.lhs
+++ b/ghc/compiler/types/Generics.lhs
@@ -1,44 +1,38 @@
 \begin{code}
 \begin{code}

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

                  validGenericInstanceType, validGenericMethodType
     ) where
 
 
                  validGenericInstanceType, validGenericMethodType
     ) where
 
 

-import CmdLineOpts     ( opt_GlasgowExts )
-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 DataCon          ( DataCon, dataConOrigArgTys, dataConWrapId, dataConId )
-
-import TyCon            ( TyCon, tyConTyVars, tyConDataConsIfAvailable, 
-                         tyConGenInfo, isNewTyCon, newTyConRep, isBoxedTupleTyCon
+import TcHsSyn         ( mkSimpleHsAlt )
+import TcType          ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitPhiTy, applyTy, 
+                         isTauTy, mkTyVarTy )
+import DataCon          ( DataCon, dataConOrigArgTys, isVanillaDataCon,
+                         dataConSourceArity )
+
+import TyCon            ( TyCon, tyConName, tyConDataCons, 
+                         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          ( mkBuiltinSrcLoc )
-import Maybes          ( maybeToBool, expectJust )
+import VarSet          ( varSetElems )
+import Id               ( Id, idType )
+import TysWiredIn      ( listTyCon )
+import PrelNames
+       
+import SrcLoc          ( srcLocSpan, noLoc, Located(..) )
+import Util             ( takeList, isSingleton )
+import Bag

 import Outputable 
 import Outputable 

+import FastString

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

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

@@ -197,18 +192,26 @@ validGenericMethodType :: Type -> Bool
   --   * type variables
   --   * function arrow
   --   * boxed tuples
   --   * type variables
   --   * function arrow
   --   * boxed tuples

+  --    * lists

   --   * an arbitrary type not involving the class type variables
   --   * 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 || tc == listTyCon || isBoxedTupleTyCon tc 
+       -- Compare bimapApp, below

 \end{code}
 
 
 \end{code}
 
 

@@ -219,80 +222,63 @@ valid ty
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-mkTyConGenInfo :: 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 tycon from_name to_name
-  | not opt_GlasgowExts
-  = 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) || not (isVanillaDataCon 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 = (LPat RdrName, LHsExpr RdrName)
+
+mkTyConGenericBinds :: TyCon -> LHsBinds RdrName
+mkTyConGenericBinds tycon
+  = unitBag (L loc (FunBind (L loc from_RDR) False {- Not infix -}
+                           (mkMatchGroup [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts])))
+
+       `unionBags`
+    unitBag (L loc (FunBind (L loc to_RDR) False 
+                           (mkMatchGroup [mkSimpleHsAlt to_pat to_body])))

   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             = srcLocSpan (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_pat, 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
+                InPat RdrName, LHsExpr 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 +290,111 @@ 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_pat, 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      = nlHsVarApps datacon_rdr datacon_vars
+     from_alt     = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
+
+     (_, from_alt_rhs, to_pat, 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,
+     nlVarPat to_arg,
+     noLoc (HsCase (nlHsVar to_arg) 
+           (mkMatchGroup [mkSimpleHsAlt (nlConPat inlDataCon_RDR [l_to_pat]) l_to_body,
+                          mkSimpleHsAlt (nlConPat inrDataCon_RDR [r_to_pat]) r_to_body])))

   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_pat, l_to_body) = mk_sum_stuff us' l_datacons
+    (r_from_alts, r_to_pat, 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, noLoc (HsApp (nlHsVar 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
+                 LHsExpr RdrName,                      -- from-rhs: puts together the representation from the arg_ids
+                 InPat RdrName,                        -- to_pat: 
+                 LHsExpr RdrName -> LHsExpr 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),
+--                              abc,
+--                              \<body-code> -> case abc of { a :*: bc ->
+--                                              case bc  of { b :*: c  -> 
+--                                              <body-code> )

 
 

--- 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,
+     nlHsVar genUnitDataCon_RDR,
+     noLoc (SigPatIn (nlVarPat (mkGenericLocal us)) 
+                    (noLoc (HsTyVar (getRdrName genUnitTyConName)))),
+       -- Give a signature to the pattern so we get 
+       --      data S a = Nil | S a
+       --      toS = \x -> case x of { Inl (g :: Unit) -> Nil
+       --                              Inr x -> S x }
+       -- The (:: Unit) signature ensures that we'll infer the right
+       -- type for toS. If we leave it out, the type is too polymorphic
+
+     \x -> x)
+
+mk_prod_stuff us [arg_var]     -- Singleton case
+  = (us, nlHsVar arg_var, nlVarPat arg_var, \x -> x)
+
+mk_prod_stuff us arg_vars      -- Two or more
+  = (us'', 
+     nlHsApps crossDataCon_RDR [l_alt_rhs, r_alt_rhs],
+     nlVarPat to_arg, 
+-- gaw 2004 FIX?
+     \x -> noLoc (HsCase (nlHsVar to_arg) 
+                 (mkMatchGroup [mkSimpleHsAlt pat (l_to_body_fn (r_to_body_fn x))])))

   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_pat, l_to_body_fn) = mk_prod_stuff (us+1)  l_arg_vars
+    (us'', r_alt_rhs, r_to_pat, r_to_body_fn) = mk_prod_stuff us' r_arg_vars
+    pat = nlConPat crossDataCon_RDR [l_to_pat, r_to_pat]

 
 

-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 +405,143 @@ 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.
+
+
+Note [Polymorphic methods]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+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 -> LHsExpr RdrName

 mkGenericRhs sel_id tyvar tycon
 mkGenericRhs sel_id tyvar tycon

-  = HsApp (toEP bimap) (HsVar (idName sel_id))
+  = ASSERT( isSingleton ctxt )         -- Checks shape of selector-id context
+    pprTrace "mkGenericRhs" (vcat [ppr sel_id, ppr (idType sel_id), ppr tyvar, ppr tycon, ppr local_tvs, ppr final_ty]) $
+    mkHsApp (toEP bimap) (nlHsVar (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 
+
+        -- Instantiate the selector type, and strip off its class context
+       (ctxt, op_ty) = tcSplitPhiTy (applyTy (idType sel_id) (mkTyVarTy tyvar))

 
 

-        -- 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 Note [Polymorphic methods] 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 (nlHsVar from_RDR) (nlHsVar 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 (LHsExpr 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 (LHsExpr 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 (LHsExpr RdrName)
+bimapApp env Nothing               = panic "TcClassDecl: Type Application!"
+bimapApp env (Just (tycon, ty_args)) 

   | tycon == funTyCon       = bimapArrow arg_eps
   | tycon == funTyCon       = bimapArrow arg_eps

+  | tycon == listTyCon      = bimapList arg_eps

   | isBoxedTupleTyCon tycon = bimapTuple arg_eps
   | otherwise              =   -- Otherwise validGenericMethodType will 
                                -- have checked that the type is a constant type
   | 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 = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] from_body, 
+        toEP   = mkHsLam [nlVarPat a_RDR, nlVarPat 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 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ toEP   ep1 `mkHsApp` nlHsVar b_RDR))
+    to_body   = toEP   ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ fromEP ep1 `mkHsApp` nlHsVar b_RDR))

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

+-- bimapTuple :: [EP a1 b1, ... EP an bn] -> EP (a1,...an) (b1,..bn)

 bimapTuple eps 
 bimapTuple eps 

-  = EP { fromEP = mk_hs_lam [tuple_pat] from_body,
-        toEP   = mk_hs_lam [tuple_pat] to_body }
+  = EP { fromEP = mkHsLam [noLoc tuple_pat] (noLoc from_body),
+        toEP   = mkHsLam [noLoc tuple_pat] (noLoc to_body) }

   where
   where

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

     eps_w_names = eps `zip` names
     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
+    to_body     = ExplicitTuple [toEP   ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed
+    from_body   = ExplicitTuple [fromEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed

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

-genericNames :: [Name]
-genericNames = [mkSysLocalName (mkBuiltinUnique i) (_PK_ ('g' : show i)) | i <- [1..]]
-(g1:g2:g3:_) = genericNames
+-- bimapList :: EP a b -> EP [a] [b]
+bimapList [ep]
+  = EP { fromEP = nlHsApp (nlHsVar map_RDR) (fromEP ep),
+        toEP   = nlHsApp (nlHsVar map_RDR) (toEP ep) }

 
 

-mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body Nothing mkBuiltinSrcLoc))
-idexpr             = mk_hs_lam [VarPatIn g3] (HsVar g3)
+-------------------
+a_RDR  = mkVarUnqual FSLIT("a")
+b_RDR  = mkVarUnqual FSLIT("b")
+gs_RDR = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ]
+
+idEP :: EP (LHsExpr RdrName)
+idEP = EP idexpr idexpr
+     where
+       idexpr = mkHsLam [nlVarPat a_RDR] (nlHsVar a_RDR)

 \end{code}
 \end{code}