-{-
-mkPRepr :: [[Type]] -> VM Type
-mkPRepr tys
- = do
- embed_tc <- builtin embedTyCon
- sum_tcs <- builtins sumTyCon
- prod_tcs <- builtins prodTyCon
-
- let mk_sum [] = unitTy
- mk_sum [ty] = ty
- mk_sum tys = mkTyConApp (sum_tcs $ length tys) tys
-
- mk_prod [] = unitTy
- mk_prod [ty] = ty
- mk_prod tys = mkTyConApp (prod_tcs $ length tys) tys
-
- mk_embed ty = mkTyConApp embed_tc [ty]
-
- return . mk_sum
- . map (mk_prod . map mk_embed)
- $ tys
--}
-
-mkToPRepr :: [[CoreExpr]] -> VM ([CoreExpr], Type)
-mkToPRepr ess
- = do
- embed_tc <- builtin embedTyCon
- embed_dc <- builtin embedDataCon
- sum_tcs <- builtins sumTyCon
- prod_tcs <- builtins prodTyCon
-
- let mk_sum [] = ([Var unitDataConId], unitTy)
- mk_sum [(expr, ty)] = ([expr], ty)
- mk_sum es = (zipWith mk_alt (tyConDataCons sum_tc) exprs,
- mkTyConApp sum_tc tys)
- where
- (exprs, tys) = unzip es
- sum_tc = sum_tcs (length es)
- mk_alt dc expr = mkConApp dc (map Type tys ++ [expr])
-
- mk_prod [] = (Var unitDataConId, unitTy)
- mk_prod [(expr, ty)] = (expr, ty)
- mk_prod es = (mkConApp prod_dc (map Type tys ++ exprs),
- mkTyConApp prod_tc tys)
- where
- (exprs, tys) = unzip es
- prod_tc = prod_tcs (length es)
- [prod_dc] = tyConDataCons prod_tc
-
- mk_embed expr = (mkConApp embed_dc [Type ty, expr],
- mkTyConApp embed_tc [ty])
- where ty = exprType expr
-
- return . mk_sum $ map (mk_prod . map mk_embed) ess
-