+ el_ty = mkTyConApp vect_tc var_tys
+
+ [pdata_dc] = tyConDataCons pdata_tc
+
+ from_sum res_ty expr [] = return ([], mk)
+ where
+ mk body = mkWildCase expr (exprType expr) res_ty [(DEFAULT, [], body)]
+ from_sum res_ty expr [con] = from_prod res_ty expr con
+ from_sum res_ty expr cons
+ = do
+ (_, pdata_tc, sel_ty, arg_tys) <- reprSumTyCons vect_tc
+ sel <- newLocalVar (fsLit "sel") sel_ty
+ vars <- newLocalVars (fsLit "xs") arg_tys
+ rs <- zipWithM (from_prod res_ty) (map Var vars) cons
+ let (prods, mks) = unzip rs
+ [pdata_con] = tyConDataCons pdata_tc
+ scrut = unwrapFamInstScrut pdata_tc arg_tys expr
+
+ mk body = mkWildCase scrut (exprType scrut) res_ty
+ [(DataAlt pdata_con, sel : vars, foldr ($) body mks)]
+ return (Var sel : concat prods, mk)
+
+
+ from_prod res_ty expr con
+ | [] <- tys = return ([], id)
+ | [_] <- tys = return ([expr], id)
+ | otherwise
+ = do
+ prod_tc <- builtin (prodTyCon (length tys))
+ (pdata_tc, _) <- pdataReprTyCon (mkTyConApp prod_tc tys)
+ pdata_tys <- mapM mkPDataType tys
+ vars <- newLocalVars (fsLit "ys") pdata_tys
+ let [pdata_con] = tyConDataCons pdata_tc
+ scrut = unwrapFamInstScrut pdata_tc tys expr
+
+ mk body = mkWildCase scrut (exprType scrut) res_ty
+ [(DataAlt pdata_con, vars, body)]
+
+ return (map Var vars, mk)
+ where
+ tys = dataConRepArgTys con
+
+buildPRDict :: TyCon -> TyCon -> TyCon -> VM CoreExpr
+buildPRDict vect_tc prepr_tc _
+ = do
+ dict <- sum_dict (tyConDataCons vect_tc)
+ pr_co <- mkBuiltinCo prTyCon
+ let co = mkAppCoercion pr_co
+ . mkSymCoercion
+ $ mkTyConApp arg_co ty_args
+ return (mkCoerce co dict)
+ where
+ ty_args = mkTyVarTys (tyConTyVars vect_tc)
+ Just arg_co = tyConFamilyCoercion_maybe prepr_tc
+
+ sum_dict [] = prDFunOfTyCon =<< builtin voidTyCon
+ sum_dict [con] = prod_dict con
+ sum_dict cons = do
+ dicts <- mapM prod_dict cons
+ (sum_tc, _, _, sum_ty_args) <- reprSumTyCons vect_tc
+ dfun <- prDFunOfTyCon sum_tc
+ return $ dfun `mkTyApps` sum_ty_args `mkApps` dicts
+
+ prod_dict con
+ | [] <- tys = prDFunOfTyCon =<< builtin voidTyCon
+ | [ty] <- tys = mkPR ty
+ | otherwise = do
+ dicts <- mapM mkPR tys
+ prod_tc <- builtin (prodTyCon (length tys))
+ dfun <- prDFunOfTyCon prod_tc
+ return $ dfun `mkTyApps` tys `mkApps` dicts
+ where
+ tys = dataConRepArgTys con