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])))
-
+ = unitBag (L loc (mkFunBind (L loc from_RDR) from_matches))
`unionBags`
- unitBag (L loc (FunBind (L loc to_RDR) False
- (mkMatchGroup [mkSimpleHsAlt to_pat to_body])))
+ unitBag (L loc (mkFunBind (L loc to_RDR) to_matches))
where
+ 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
mkGenericRhs :: Id -> TyVar -> TyCon -> LHsExpr RdrName
mkGenericRhs sel_id tyvar tycon
= 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]) $
+-- 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
toEP = mkHsLam [noLoc tuple_pat] (noLoc to_body) }
where
names = takeList eps gs_RDR
- tuple_pat = TuplePat (map nlVarPat names) Boxed
+ tuple_pat = TuplePat (map nlVarPat names) Boxed placeHolderType
eps_w_names = eps `zip` names
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