+ 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