\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, 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 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 TysWiredIn ( listTyCon )
+import PrelNames
+
+import SrcLoc ( srcLocSpan, noLoc, Located(..) )
+import Util ( takeList, isSingleton )
+import Bag
import Outputable
+import FastString
#include "HsVersions.h"
\end{code}
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
-- 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
-- * 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}
%************************************************************************
\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) || 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 (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
- 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
- -- 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
-- 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,
+-- \<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
-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}
+ 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
+
+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}
%************************************************************************
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}
-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
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}
projects / ghc-hetmet.git / blobdiff