3 mkPADictType, mkPArrayType,
4 paDictArgType, paDictOfType
7 #include "HsVersions.h"
20 import Control.Monad ( liftM )
22 isClosureTyCon :: TyCon -> Bool
23 isClosureTyCon tc = tyConUnique tc == closureTyConKey
25 splitClosureTy :: Type -> (Type, Type)
27 | Just (tc, [arg_ty, res_ty]) <- splitTyConApp_maybe ty
31 | otherwise = pprPanic "splitClosureTy" (ppr ty)
33 mkPADictType :: Type -> VM Type
36 tc <- builtin paDictTyCon
37 return $ TyConApp tc [ty]
39 mkPArrayType :: Type -> VM Type
42 tc <- builtin parrayTyCon
43 return $ TyConApp tc [ty]
45 paDictArgType :: TyVar -> VM (Maybe Type)
46 paDictArgType tv = go (TyVarTy tv) (tyVarKind tv)
48 go ty k | Just k' <- kindView k = go ty k'
51 tv <- newTyVar FSLIT("a") k1
52 mty1 <- go (TyVarTy tv) k1
55 mty2 <- go (AppTy ty (TyVarTy tv)) k2
56 return $ fmap (ForAllTy tv . FunTy ty1) mty2
61 = liftM Just (mkPADictType ty)
63 go ty k = return Nothing
65 paDictOfType :: Type -> VM CoreExpr
66 paDictOfType ty = paDictOfTyApp ty_fn ty_args
68 (ty_fn, ty_args) = splitAppTys ty
70 paDictOfTyApp :: Type -> [Type] -> VM CoreExpr
71 paDictOfTyApp ty_fn ty_args
72 | Just ty_fn' <- coreView ty_fn = paDictOfTyApp ty_fn' ty_args
73 paDictOfTyApp (TyVarTy tv) ty_args
75 dfun <- maybeV (lookupTyVarPA tv)
76 paDFunApply dfun ty_args
77 paDictOfTyApp (TyConApp tc _) ty_args
79 pa_class <- builtin paClass
80 (dfun, ty_args') <- lookupInst pa_class [TyConApp tc ty_args]
81 paDFunApply (Var dfun) ty_args'
82 paDictOfTyApp ty ty_args = pprPanic "paDictOfTyApp" (ppr ty)
84 paDFunApply :: CoreExpr -> [Type] -> VM CoreExpr
87 dicts <- mapM paDictOfType tys
88 return $ mkApps (mkTyApps dfun tys) dicts