+ tyvars = tyConTyVars vect_tc
+
+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
+ = do
+ let arg_ty = mkTyConApp vect_tc ty_args
+ res_ty <- mkPReprType arg_ty
+ arg <- newLocalVar (fsLit "x") arg_ty
+ result <- to_sum (Var arg) arg_ty res_ty repr
+ return $ Lam arg result
+ where
+ ty_args = mkTyVarTys (tyConTyVars vect_tc)
+
+ wrap_repr_inst = wrapFamInstBody repr_tc ty_args
+
+ to_sum _ _ _ EmptySum
+ = do
+ void <- builtin voidVar
+ return $ wrap_repr_inst $ Var void
+
+ to_sum arg arg_ty res_ty (UnarySum r)
+ = do
+ (pat, vars, body) <- con_alt r
+ return $ mkWildCase arg arg_ty res_ty
+ [(pat, vars, wrap_repr_inst body)]
+
+ to_sum arg arg_ty res_ty (Sum { repr_sum_tc = sum_tc
+ , repr_con_tys = tys
+ , repr_cons = cons })
+ = do
+ alts <- mapM con_alt cons
+ let alts' = [(pat, vars, wrap_repr_inst
+ $ mkConApp sum_con (map Type tys ++ [body]))
+ | ((pat, vars, body), sum_con)
+ <- zip alts (tyConDataCons sum_tc)]
+ return $ mkWildCase arg arg_ty res_ty alts'
+
+ con_alt (ConRepr con r)
+ = do
+ (vars, body) <- to_prod r
+ return (DataAlt con, vars, body)
+
+ to_prod EmptyProd
+ = do
+ void <- builtin voidVar
+ return ([], Var void)
+
+ to_prod (UnaryProd comp)
+ = do
+ var <- newLocalVar (fsLit "x") (compOrigType comp)
+ body <- to_comp (Var var) comp
+ return ([var], body)
+
+ to_prod(Prod { repr_tup_tc = tup_tc
+ , repr_comp_tys = tys
+ , repr_comps = comps })
+ = do
+ vars <- newLocalVars (fsLit "x") (map compOrigType comps)
+ exprs <- zipWithM to_comp (map Var vars) comps
+ return (vars, mkConApp tup_con (map Type tys ++ exprs))
+ where
+ [tup_con] = tyConDataCons tup_tc
+
+ to_comp expr (Keep _ _) = return expr
+ to_comp expr (Wrap ty) = do
+ wrap_tc <- builtin wrapTyCon
+ return $ wrapNewTypeBody wrap_tc [ty] expr