- let scrut = unwrapFamInstScrut tycon tys expr
- scrut_ty = mkTyConApp tycon tys
- ty <- arrReprType prod
-
- return $ Case scrut (mkWildId scrut_ty) res_ty
- [(DataAlt data_con, shape_vars ++ repr_vars, body)]
-
- from_prod (IdRepr ty)
- expr
- shape_vars
- [repr_var]
- res_ty
- body
- = return $ Let (NonRec repr_var expr) body
-
-buildPRDictRepr :: Repr -> VM CoreExpr
-buildPRDictRepr (IdRepr ty) = mkPR ty
-buildPRDictRepr (ProdRepr {
- prod_components = tys
- , prod_tycon = tycon
- })
- = do
- prs <- mapM mkPR tys
- dfun <- prDFunOfTyCon tycon
- return $ dfun `mkTyApps` tys `mkApps` prs
-
-buildPRDictRepr (SumRepr {
- sum_components = prods
- , sum_tycon = tycon })
- = do
- prs <- mapM buildPRDictRepr prods
- dfun <- prDFunOfTyCon tycon
- return $ dfun `mkTyApps` map reprType prods `mkApps` prs
+ (_, 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