-mkBuiltinTyConApps1 :: (Builtins -> TyCon) -> Type -> [Type] -> VM Type
-mkBuiltinTyConApps1 get_tc dft [] = return dft
-mkBuiltinTyConApps1 get_tc dft tys
- = do
- tc <- builtin get_tc
- case tys of
- [] -> pprPanic "mkBuiltinTyConApps1" (ppr tc)
- _ -> return $ foldr1 (mk tc) tys
- where
- mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2]
-
-data TyConRepr = TyConRepr {
- repr_tyvars :: [TyVar]
- , repr_tys :: [[Type]]
-
- , repr_prod_tycons :: [Maybe TyCon]
- , repr_prod_tys :: [Type]
- , repr_sum_tycon :: Maybe TyCon
- , repr_type :: Type
- }
-
-mkTyConRepr :: TyCon -> VM TyConRepr
-mkTyConRepr vect_tc
- = do
- prod_tycons <- mapM (mk_tycon prodTyCon) rep_tys
- let prod_tys = zipWith mk_tc_app_maybe prod_tycons rep_tys
- sum_tycon <- mk_tycon sumTyCon prod_tys
-
- return $ TyConRepr {
- repr_tyvars = tyvars
- , repr_tys = rep_tys
-
- , repr_prod_tycons = prod_tycons
- , repr_prod_tys = prod_tys
- , repr_sum_tycon = sum_tycon
- , repr_type = mk_tc_app_maybe sum_tycon prod_tys
- }
- where
- tyvars = tyConTyVars vect_tc
- data_cons = tyConDataCons vect_tc
- rep_tys = map dataConRepArgTys data_cons
-
- mk_tycon get_tc tys
- | n > 1 = builtin (Just . get_tc n)
- | otherwise = return Nothing
- where n = length tys
-
- mk_tc_app_maybe Nothing [] = unitTy
- mk_tc_app_maybe Nothing [ty] = ty
- mk_tc_app_maybe (Just tc) tys = mkTyConApp tc tys
-
-{-
-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 :: TyConRepr -> [[CoreExpr]] -> [CoreExpr]
-mkToPRepr (TyConRepr {
- repr_tys = repr_tys
- , repr_prod_tycons = prod_tycons
- , repr_prod_tys = prod_tys
- , repr_sum_tycon = repr_sum_tycon
- })
- = mk_sum . zipWith3 mk_prod prod_tycons repr_tys
- where
- Just sum_tycon = repr_sum_tycon
-
- mk_sum [] = [Var unitDataConId]
- mk_sum [expr] = [expr]
- mk_sum exprs = zipWith (mk_alt prod_tys) (tyConDataCons sum_tycon) exprs
-
- mk_alt tys dc expr = mk_con_app dc tys [expr]
-
- mk_prod _ _ [] = Var unitDataConId
- mk_prod _ _ [expr] = expr
- mk_prod (Just tc) tys exprs = mk_con_app dc tys exprs
- where
- [dc] = tyConDataCons tc