X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FGenerics.lhs;h=2c973649cfcf8c8836e9d8c8dd65b9cb0b700bd8;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=cc611618f350b32c408ed25fd01c4f14179d4b70;hpb=2205f0ceeb65d8acb7db953bf4fd2ad673dc55ee;p=ghc-hetmet.git diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs index cc61161..2c97364 100644 --- a/ghc/compiler/types/Generics.lhs +++ b/ghc/compiler/types/Generics.lhs @@ -1,43 +1,36 @@ \begin{code} -module Generics ( mkTyConGenInfo, mkGenericRhs, +module Generics ( canDoGenerics, mkTyConGenericBinds, + mkGenericRhs, validGenericInstanceType, validGenericMethodType ) where -import RnHsSyn ( RenamedHsExpr ) -import HsSyn ( HsExpr(..), InPat(..), mkSimpleMatch, placeHolderType ) - +import HsSyn import Type ( Type, isUnLiftedType, tyVarsOfType, tyVarsOfTypes, - mkTyVarTys, mkForAllTys, mkTyConApp, - mkFunTy, isTyVarTy, getTyVar_maybe, - funTyCon + isTyVarTy, getTyVar_maybe, funTyCon ) -import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitSigmaTy ) -import DataCon ( DataCon, dataConOrigArgTys, dataConWrapId, isExistentialDataCon ) - -import TyCon ( TyCon, tyConTyVars, tyConDataCons_maybe, - 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, mkSystemName ) -import CoreSyn ( mkLams, Expr(..), CoreExpr, AltCon(..), - mkConApp, Alt, mkTyApps, mkVarApps ) -import CoreUtils ( exprArity ) +import Name ( nameModule, nameOccName, getSrcLoc ) +import OccName ( mkGenOcc1, mkGenOcc2 ) +import RdrName ( RdrName, getRdrName, mkVarUnqual, mkOrig ) import BasicTypes ( EP(..), Boxity(..) ) import Var ( TyVar ) 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 IdInfo ( noCafNoTyGenIdInfo, setUnfoldingInfo, setArityInfo ) -import CoreUnfold ( mkTopUnfolding ) - -import Maybe ( isNothing ) -import SrcLoc ( builtinSrcLoc ) -import Unique ( Unique, builtinUniques, mkBuiltinUnique ) -import Util ( takeList, dropList ) +import Id ( Id, idType ) +import TysWiredIn ( listTyCon ) +import PrelNames + +import SrcLoc ( srcLocSpan, noLoc, Located(..) ) +import Util ( takeList, isSingleton ) +import Bag import Outputable import FastString @@ -191,7 +184,7 @@ validGenericInstanceType :: Type -> Bool validGenericInstanceType inst_ty = case tcSplitTyConApp_maybe inst_ty of - Just (tycon, tys) -> all isTyVarTy tys && tycon `elem` genericTyCons + Just (tycon, tys) -> all isTyVarTy tys && tyConName tycon `elem` genericTyConNames Nothing -> False validGenericMethodType :: Type -> Bool @@ -199,6 +192,7 @@ validGenericMethodType :: Type -> Bool -- * type variables -- * function arrow -- * boxed tuples + -- * lists -- * an arbitrary type not involving the class type variables -- e.g. this is ok: forall b. Ord b => [b] -> a -- where a is the class variable @@ -216,7 +210,7 @@ validGenericMethodType ty where no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty)) - valid_tycon tc = tc == funTyCon || isBoxedTupleTyCon tc + valid_tycon tc = tc == funTyCon || tc == listTyCon || isBoxedTupleTyCon tc -- Compare bimapApp, below \end{code} @@ -228,96 +222,62 @@ validGenericMethodType ty %************************************************************************ \begin{code} -mkTyConGenInfo :: TyCon -> [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 [] - = Nothing -- This happens when we deal with the interface-file type - -- decl for a module compiled without -fgenerics - -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, +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 + -- Nor can we do the job if it's an existential data constructor, - | or [ any isUnLiftedType (dataConOrigArgTys dc) || isExistentialDataCon dc - | dc <- datacons ] - = Nothing - | null datacons -- There are no constructors; - = Nothing -- there are no values of this type + -- 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} +%* * +%************************************************************************ - | otherwise - = 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 }) +\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 (mkFunBind (L loc from_RDR) from_matches)) + `unionBags` + unitBag (L loc (mkFunBind (L loc to_RDR) to_matches)) where - maybe_datacons = tyConDataCons_maybe tycon - Just datacons = maybe_datacons -- [C, D] - - 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 - = ( mkLams tyvars $ Lam x $ mkNewTypeBody tycon newrep_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 = mkGenericLocal u1 tycon_ty - (u1 : uniqs) = builtinUniques - - ---------------------- - -- Newtypes only - [the_datacon] = datacons - (_, newrep_ty) = newTyConRep tycon - - ---------------------- - -- Non-newtypes only + from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts] + to_matches = [mkSimpleHsAlt to_pat to_body] + loc = srcLocSpan (getSrcLoc tycon) + datacons = tyConDataCons tycon + (from_RDR, to_RDR) = mkGenericNames tycon + -- Recurse over the sum first - -- The "2" is the first free unique - (from_alts, to_inner, rep_var) = mk_sum_stuff uniqs tyvars datacons - -mkTyConGenInfo tycon names = pprPanic "mkTyConGenInfo" (ppr tycon <+> ppr names) - + from_alts :: [FromAlt] + (from_alts, to_pat, to_body) = mk_sum_stuff init_us datacons + init_us = 1::Int -- Unique supply ---------------------------------------------------- -- Dealing with sums ---------------------------------------------------- -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) + +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 @@ -329,93 +289,93 @@ mk_sum_stuff :: [Unique] -- Base for generating unique names -- D a b c }} }, -- cd) -mk_sum_stuff us 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 - 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 us'' datacon_vars - -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) + 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 - (l_datacons, r_datacons) = splitInHalf 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_var = mkGenericLocal u rep_ty - - wrap :: DataCon -> [Alt Id] -> [Alt Id] + (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 + + wrap :: RdrName -> [FromAlt] -> [FromAlt] -- 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 + wrap dc alts = [(pat, noLoc (HsApp (nlHsVar dc) rhs)) | (pat,rhs) <- alts] + ---------------------------------------------------- -- Dealing with products ---------------------------------------------------- -mk_prod_stuff :: [Unique] -- 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 - -> ([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 + -> (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: --- 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, +-- \ -> case abc of { a :*: bc -> +-- case bc of { b :*: c -> +-- ) --- 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 -mk_prod_stuff (u:us) [] -- Unit case - = (us, - Var (dataConWrapId genUnitDataCon), - \x -> x, - mkGenericLocal u (mkTyConApp genUnitTyCon [])) +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, Var arg_var, \x -> x, arg_var) + = (us, nlHsVar arg_var, nlVarPat arg_var, \x -> x) -mk_prod_stuff (u:us) arg_vars -- Two or more +mk_prod_stuff 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) + 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 - (l_arg_vars, r_arg_vars) = splitInHalf arg_vars - (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} - -A little utility function + 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] -\begin{code} splitInHalf :: [a] -> ([a],[a]) splitInHalf list = (left, right) where @@ -423,8 +383,17 @@ splitInHalf list = (left, right) left = take half list right = drop half list -mkGenericLocal :: Unique -> Type -> Id -mkGenericLocal uniq ty = mkSysLocal FSLIT("g") uniq ty +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 = nameModule tc_name + from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ) + to_RDR = mkOrig tc_mod (mkGenOcc2 tc_occ) \end{code} %************************************************************************ @@ -462,7 +431,9 @@ 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: +Note [Polymorphic methods] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose the class op is polymorphic: class Baz a where op :: forall b. Ord b => a -> b -> b @@ -482,36 +453,37 @@ By the time the type checker has done its stuff we'll get op = \b. \dict::Ord b. toOp b (op Trep b dict) \begin{code} -mkGenericRhs :: Id -> TyVar -> TyCon -> RenamedHsExpr +mkGenericRhs :: Id -> TyVar -> TyCon -> LHsExpr RdrName 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 - 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) + -- Instantiate the selector type, and strip off its class context + (ctxt, op_ty) = tcSplitPhiTy (applyTy (idType sel_id) (mkTyVarTy tyvar)) -- Do it again! This deals with the case where the method type - -- is polymorphic -- see notes above + -- 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. + ep = EP (nlHsVar from_RDR) (nlHsVar to_RDR) bimap = generate_bimap (tyvar, ep, local_tvs) final_ty -type EPEnv = (TyVar, -- The class type variable - EP RenamedHsExpr, -- The EP it maps to - [TyVar] -- Other in-scope tyvars; they have an identity 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 :: EPEnv -> Type - -> EP RenamedHsExpr + -> EP (LHsExpr RdrName) -- Top level case - splitting the TyCon. generate_bimap env@(tv,ep,local_tvs) ty = case getTyVar_maybe ty of @@ -521,10 +493,11 @@ generate_bimap env@(tv,ep,local_tvs) ty Nothing -> bimapApp env (tcSplitTyConApp_maybe ty) ------------------- -bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP RenamedHsExpr +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 == listTyCon = bimapList arg_eps | isBoxedTupleTyCon tycon = bimapTuple arg_eps | otherwise = -- Otherwise validGenericMethodType will -- have checked that the type is a constant type @@ -537,32 +510,37 @@ bimapApp env (Just (tycon, ty_args)) ------------------- -- 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 } + = EP { fromEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] from_body, + toEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] to_body } 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 - = 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 - names = takeList eps genericNames - tuple_pat = TuplePatIn (map VarPatIn names) Boxed + names = takeList eps gs_RDR + tuple_pat = TuplePat (map nlVarPat names) Boxed placeHolderType 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 = [mkSystemName (mkBuiltinUnique i) (mkFastString ('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 placeHolderType builtinSrcLoc)) +------------------- +a_RDR = mkVarUnqual FSLIT("a") +b_RDR = mkVarUnqual FSLIT("b") +gs_RDR = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ] -idEP :: EP RenamedHsExpr +idEP :: EP (LHsExpr RdrName) idEP = EP idexpr idexpr where - idexpr = mk_hs_lam [VarPatIn g3] (HsVar g3) + idexpr = mkHsLam [nlVarPat a_RDR] (nlHsVar a_RDR) \end{code}