- mk_method abstract (name, build)
- = localV
- $ do
- body <- liftM abstract $ build vect_tc arr_tc
- var <- newLocalVar name (exprType body)
- return (var, mkInlineMe body)
-
-paMethods = [(FSLIT("lengthPA"), buildLengthPA),
- (FSLIT("replicatePA"), buildReplicatePA)]
+ [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