buildPReprRhsTy = buildPReprTy . map dataConRepArgTys . tyConDataCons
buildPReprTy :: [[Type]] -> VM Type
-buildPReprTy [] = panic "mkPRepr"
-buildPReprTy tys
- = do
- embed <- builtin embedTyCon
- plus <- builtin plusTyCon
- cross <- builtin crossTyCon
-
- return . foldr1 (mk_bin plus)
- . map (mkprod cross)
- . map (map (mk_un embed))
- $ tys
- where
- mkprod cross [] = unitTy
- mkprod cross tys = foldr1 (mk_bin cross) tys
-
- mk_un tc ty = mkTyConApp tc [ty]
- mk_bin tc ty1 ty2 = mkTyConApp tc [ty1,ty2]
+buildPReprTy tys = mkPlusTypes unitTy
+ =<< mapM (mkCrossTypes unitTy)
+ =<< mapM (mapM mkEmbedType) tys
buildPArrayTyCon :: TyCon -> TyCon -> VM TyCon
buildPArrayTyCon orig_tc vect_tc = fixV $ \repr_tc ->
collectAnnValBinders,
mkDataConTag,
splitClosureTy,
+ mkPlusType, mkPlusTypes, mkCrossType, mkCrossTypes, mkEmbedType,
mkPADictType, mkPArrayType,
parrayReprTyCon, parrayReprDataCon, mkVScrut,
paDictArgType, paDictOfType, paDFunType,
where
mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2]
-mkBuiltinTyConApps1 :: (Builtins -> TyCon) -> [Type] -> VM Type
-mkBuiltinTyConApps1 get_tc tys
+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
where
mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2]
+mkPlusType :: Type -> Type -> VM Type
+mkPlusType ty1 ty2 = mkBuiltinTyConApp plusTyCon [ty1, ty2]
+
+mkPlusTypes :: Type -> [Type] -> VM Type
+mkPlusTypes = mkBuiltinTyConApps1 plusTyCon
+
+mkCrossType :: Type -> Type -> VM Type
+mkCrossType ty1 ty2 = mkBuiltinTyConApp crossTyCon [ty1, ty2]
+
+mkCrossTypes :: Type -> [Type] -> VM Type
+mkCrossTypes = mkBuiltinTyConApps1 crossTyCon
+
+mkEmbedType :: Type -> VM Type
+mkEmbedType ty = mkBuiltinTyConApp embedTyCon [ty]
+
mkClosureType :: Type -> Type -> VM Type
mkClosureType arg_ty res_ty = mkBuiltinTyConApp closureTyCon [arg_ty, res_ty]