+data CompRepr = Keep Type
+ CoreExpr -- PR dictionary for the type
+ | Wrap Type
+
+data ProdRepr = EmptyProd
+ | UnaryProd CompRepr
+ | Prod { repr_tup_tc :: TyCon -- representation tuple tycon
+ , repr_ptup_tc :: TyCon -- PData representation tycon
+ , repr_comp_tys :: [Type] -- representation types of
+ , repr_comps :: [CompRepr] -- components
+ }
+data ConRepr = ConRepr DataCon ProdRepr
+
+data SumRepr = EmptySum
+ | UnarySum ConRepr
+ | Sum { repr_sum_tc :: TyCon -- representation sum tycon
+ , repr_psum_tc :: TyCon -- PData representation tycon
+ , repr_sel_ty :: Type -- type of selector
+ , repr_con_tys :: [Type] -- representation types of
+ , repr_cons :: [ConRepr] -- components
+ }
+
+tyConRepr :: TyCon -> VM SumRepr
+tyConRepr tc = sum_repr (tyConDataCons tc)
+ where
+ sum_repr [] = return EmptySum
+ sum_repr [con] = liftM UnarySum (con_repr con)
+ sum_repr cons = do
+ rs <- mapM con_repr cons
+ sum_tc <- builtin (sumTyCon arity)
+ tys <- mapM conReprType rs
+ (psum_tc, _) <- pdataReprTyCon (mkTyConApp sum_tc tys)
+ sel_ty <- builtin (selTy arity)
+ return $ Sum { repr_sum_tc = sum_tc
+ , repr_psum_tc = psum_tc
+ , repr_sel_ty = sel_ty
+ , repr_con_tys = tys
+ , repr_cons = rs
+ }
+ where
+ arity = length cons
+
+ con_repr con = liftM (ConRepr con) (prod_repr (dataConRepArgTys con))
+
+ prod_repr [] = return EmptyProd
+ prod_repr [ty] = liftM UnaryProd (comp_repr ty)
+ prod_repr tys = do
+ rs <- mapM comp_repr tys
+ tup_tc <- builtin (prodTyCon arity)
+ tys' <- mapM compReprType rs
+ (ptup_tc, _) <- pdataReprTyCon (mkTyConApp tup_tc tys')
+ return $ Prod { repr_tup_tc = tup_tc
+ , repr_ptup_tc = ptup_tc
+ , repr_comp_tys = tys'
+ , repr_comps = rs
+ }
+ where
+ arity = length tys
+
+ comp_repr ty = liftM (Keep ty) (prDictOfType ty)
+ `orElseV` return (Wrap ty)
+
+sumReprType :: SumRepr -> VM Type
+sumReprType EmptySum = voidType
+sumReprType (UnarySum r) = conReprType r
+sumReprType (Sum { repr_sum_tc = sum_tc, repr_con_tys = tys })
+ = return $ mkTyConApp sum_tc tys
+
+conReprType :: ConRepr -> VM Type
+conReprType (ConRepr _ r) = prodReprType r
+
+prodReprType :: ProdRepr -> VM Type
+prodReprType EmptyProd = voidType
+prodReprType (UnaryProd r) = compReprType r
+prodReprType (Prod { repr_tup_tc = tup_tc, repr_comp_tys = tys })
+ = return $ mkTyConApp tup_tc tys
+
+compReprType :: CompRepr -> VM Type
+compReprType (Keep ty _) = return ty
+compReprType (Wrap ty) = do
+ wrap_tc <- builtin wrapTyCon
+ return $ mkTyConApp wrap_tc [ty]
+
+compOrigType :: CompRepr -> Type
+compOrigType (Keep ty _) = ty
+compOrigType (Wrap ty) = ty
+
+buildToPRepr :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr
+buildToPRepr vect_tc repr_tc _ repr