+ 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 (tyConDataCons vect_tc)
+ return $ Lam arg result
+ where
+ ty_args = mkTyVarTys (tyConTyVars vect_tc)
+
+ wrap = wrapFamInstBody repr_tc ty_args
+
+ to_sum _ _ _ []
+ = do
+ void <- builtin voidVar
+ return $ wrap (Var void)
+
+ to_sum arg arg_ty res_ty [con]
+ = do
+ (prod, vars) <- to_prod (dataConRepArgTys con)
+ return $ mkWildCase arg arg_ty res_ty
+ [(DataAlt con, vars, wrap prod)]
+
+ to_sum arg arg_ty res_ty cons
+ = do
+ (prods, vars) <- mapAndUnzipM (to_prod . dataConRepArgTys) cons
+ (sum_tc, _, _, sum_ty_args) <- reprSumTyCons vect_tc
+ let sum_cons = [mkConApp con (map Type sum_ty_args)
+ | con <- tyConDataCons sum_tc]
+ return . mkWildCase arg arg_ty res_ty
+ $ zipWith4 mk_alt cons vars sum_cons prods
+ where
+ mk_alt con vars sum_con expr
+ = (DataAlt con, vars, wrap $ sum_con `App` expr)
+
+ to_prod []
+ = do
+ void <- builtin voidVar
+ return (Var void, [])
+ to_prod [ty]
+ = do
+ var <- newLocalVar (fsLit "x") ty
+ return (Var var, [var])
+ to_prod tys
+ = do
+ prod_con <- builtin (prodDataCon (length tys))
+ vars <- newLocalVars (fsLit "x") tys
+ return (mkConApp prod_con (map Type tys ++ map Var vars), vars)
+
+buildFromPRepr :: TyCon -> TyCon -> TyCon -> VM CoreExpr
+buildFromPRepr vect_tc repr_tc _
+ = do
+ arg_ty <- mkPReprType res_ty
+ arg <- newLocalVar (fsLit "x") arg_ty
+
+ result <- from_sum (unwrapFamInstScrut repr_tc ty_args (Var arg))
+ (tyConDataCons vect_tc)
+ return $ Lam arg result
+ where
+ ty_args = mkTyVarTys (tyConTyVars vect_tc)
+ res_ty = mkTyConApp vect_tc ty_args
+
+ from_sum _ [] = pprPanic "buildFromPRepr" (ppr vect_tc)
+ from_sum expr [con] = from_prod expr con
+ from_sum expr cons
+ = do
+ (sum_tc, _, _, sum_ty_args) <- reprSumTyCons vect_tc
+ let sum_cons = tyConDataCons sum_tc
+ vars <- newLocalVars (fsLit "x") sum_ty_args
+ prods <- zipWithM from_prod (map Var vars) cons
+ return . mkWildCase expr (exprType expr) res_ty
+ $ zipWith3 mk_alt sum_cons vars prods
+ where
+ mk_alt con var expr = (DataAlt con, [var], expr)
+
+ from_prod expr con
+ = case dataConRepArgTys con of
+ [] -> return $ apply_con []
+ [_] -> return $ apply_con [expr]
+ tys -> do
+ prod_con <- builtin (prodDataCon (length tys))
+ vars <- newLocalVars (fsLit "y") tys
+ return $ mkWildCase expr (exprType expr) res_ty
+ [(DataAlt prod_con, vars, apply_con (map Var vars))]
+ where
+ apply_con exprs = mkConApp con (map Type ty_args) `mkApps` exprs
+
+buildToArrPRepr :: TyCon -> TyCon -> TyCon -> VM CoreExpr
+buildToArrPRepr vect_tc prepr_tc pdata_tc
+ = do
+ arg_ty <- mkPDataType el_ty
+ res_ty <- mkPDataType =<< mkPReprType el_ty
+ arg <- newLocalVar (fsLit "xs") arg_ty
+
+ pdata_co <- mkBuiltinCo pdataTyCon
+ let Just repr_co = tyConFamilyCoercion_maybe prepr_tc
+ co = mkAppCoercion pdata_co
+ . mkSymCoercion
+ $ mkTyConApp repr_co ty_args
+
+ scrut = unwrapFamInstScrut pdata_tc ty_args (Var arg)
+
+ (vars, result) <- to_sum (tyConDataCons vect_tc)