X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FGenerics.lhs;h=2c973649cfcf8c8836e9d8c8dd65b9cb0b700bd8;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=6c48a1fb270e8f5307853157336c75b7ad707489;hpb=da162afcfc9db8335834bb279217c4707fb67988;p=ghc-hetmet.git diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs index 6c48a1f..2c97364 100644 --- a/ghc/compiler/types/Generics.lhs +++ b/ghc/compiler/types/Generics.lhs @@ -1,44 +1,38 @@ \begin{code} -module Generics ( mkTyConGenInfo, mkGenericRhs, +module Generics ( canDoGenerics, mkTyConGenericBinds, + mkGenericRhs, 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, isTyVarTy, - 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, mkTyApps, mkVarApps ) +import Name ( nameModule, nameOccName, getSrcLoc ) +import OccName ( mkGenOcc1, mkGenOcc2 ) +import RdrName ( RdrName, getRdrName, mkVarUnqual, mkOrig ) import BasicTypes ( EP(..), Boxity(..) ) import Var ( TyVar ) -import VarSet ( isEmptyVarSet ) -import Id ( Id, mkTemplateLocal, idType, idName, - mkTemplateLocalsNum, mkId - ) -import TysWiredIn ( genericTyCons, - genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon, - inlDataCon, crossTyCon, crossDataCon - ) -import IdInfo ( vanillaIdInfo, setUnfoldingInfo ) -import CoreUnfold ( mkTopUnfolding ) - -import Unique ( mkBuiltinUnique ) -import SrcLoc ( builtinSrcLoc ) -import Maybes ( 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 FastString #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 -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 @@ -188,8 +183,8 @@ validGenericInstanceType :: Type -> Bool -- 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 @@ -197,18 +192,26 @@ validGenericMethodType :: Type -> Bool -- * type variables -- * function arrow -- * boxed tuples + -- * lists -- * 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 - (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} @@ -219,80 +222,62 @@ valid ty %************************************************************************ \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 - | not (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) || 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 - | 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 (mkFunBind (L loc from_RDR) from_matches)) + `unionBags` + unitBag (L loc (mkFunBind (L loc to_RDR) to_matches)) 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 + 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 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 ---------------------------------------------------- -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 @@ -304,99 +289,111 @@ mk_sum_stuff :: Int -- Base for generating unique names -- 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 - 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 - (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 ---------------------------------------------------- -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 - -> (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: --- 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 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 - (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} - -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 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 = nameModule tc_name + from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ) + to_RDR = mkOrig tc_mod (mkGenOcc2 tc_occ) \end{code} %************************************************************************ @@ -407,72 +404,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 -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 = + +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} -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 + + -- 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. - 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. -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 == listTyCon = bimapList 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 - 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 } + = 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 = take (length 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 = [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 builtinSrcLoc)) -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}