2 collectAnnTypeBinders, collectAnnTypeArgs, isAnnTypeArg,
4 mkPADictType, mkPArrayType,
5 paDictArgType, paDictOfType
8 #include "HsVersions.h"
21 import Control.Monad ( liftM )
23 collectAnnTypeArgs :: AnnExpr b ann -> (AnnExpr b ann, [Type])
24 collectAnnTypeArgs expr = go expr []
26 go (_, AnnApp f (_, AnnType ty)) tys = go f (ty : tys)
29 collectAnnTypeBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann)
30 collectAnnTypeBinders expr = go [] expr
32 go bs (_, AnnLam b e) | isTyVar b = go (b:bs) e
33 go bs e = (reverse bs, e)
35 isAnnTypeArg :: AnnExpr b ann -> Bool
36 isAnnTypeArg (_, AnnType t) = True
37 isAnnTypeArg _ = False
39 isClosureTyCon :: TyCon -> Bool
40 isClosureTyCon tc = tyConUnique tc == closureTyConKey
42 splitClosureTy :: Type -> (Type, Type)
44 | Just (tc, [arg_ty, res_ty]) <- splitTyConApp_maybe ty
48 | otherwise = pprPanic "splitClosureTy" (ppr ty)
50 mkPADictType :: Type -> VM Type
53 tc <- builtin paDictTyCon
54 return $ TyConApp tc [ty]
56 mkPArrayType :: Type -> VM Type
59 tc <- builtin parrayTyCon
60 return $ TyConApp tc [ty]
62 paDictArgType :: TyVar -> VM (Maybe Type)
63 paDictArgType tv = go (TyVarTy tv) (tyVarKind tv)
65 go ty k | Just k' <- kindView k = go ty k'
68 tv <- newTyVar FSLIT("a") k1
69 mty1 <- go (TyVarTy tv) k1
72 mty2 <- go (AppTy ty (TyVarTy tv)) k2
73 return $ fmap (ForAllTy tv . FunTy ty1) mty2
78 = liftM Just (mkPADictType ty)
80 go ty k = return Nothing
82 paDictOfType :: Type -> VM CoreExpr
83 paDictOfType ty = paDictOfTyApp ty_fn ty_args
85 (ty_fn, ty_args) = splitAppTys ty
87 paDictOfTyApp :: Type -> [Type] -> VM CoreExpr
88 paDictOfTyApp ty_fn ty_args
89 | Just ty_fn' <- coreView ty_fn = paDictOfTyApp ty_fn' ty_args
90 paDictOfTyApp (TyVarTy tv) ty_args
92 dfun <- maybeV (lookupTyVarPA tv)
93 paDFunApply dfun ty_args
94 paDictOfTyApp (TyConApp tc _) ty_args
96 pa_class <- builtin paClass
97 (dfun, ty_args') <- lookupInst pa_class [TyConApp tc ty_args]
98 paDFunApply (Var dfun) ty_args'
99 paDictOfTyApp ty ty_args = pprPanic "paDictOfTyApp" (ppr ty)
101 paDFunApply :: CoreExpr -> [Type] -> VM CoreExpr
104 dicts <- mapM paDictOfType tys
105 return $ mkApps (mkTyApps dfun tys) dicts