- pa_ty <- paArgType' (TyVarTy bndr) (tyVarKind bndr)
- pa_var <- newLocalVar FSLIT("dPA") pa_ty
- (vbody, lbody) <- localV
- $ do
- extendTyVarPA bndr (Var pa_var)
- -- FIXME: what about shadowing here (bndr in lc)?
- vectExpr lc body
- return (mkLams [bndr, pa_var] vbody,
- mkLams [bndr, pa_var] lbody)
-
--- ----------------------------------------------------------------------------
--- PA dictionaries
-
-paArgType :: Type -> Kind -> VM (Maybe Type)
-paArgType ty k
- | Just k' <- kindView k = paArgType ty k'
-
--- Here, we assume that for a kind (k1 -> k2) to be valid, k1 and k2 can only
--- be made up of * and (->), i.e., they can't be coercion kinds or #.
-paArgType ty (FunTy k1 k2)
- = do
- tv <- newTyVar FSLIT("a") k1
- ty1 <- paArgType' (TyVarTy tv) k1
- ty2 <- paArgType' (AppTy ty (TyVarTy tv)) k2
- return . Just $ ForAllTy tv (FunTy ty1 ty2)
-
-paArgType ty k
- | isLiftedTypeKind k
- = do
- tc <- builtin paDictTyCon
- return . Just $ TyConApp tc [ty]
-
- | otherwise
- = return Nothing
-
-paArgType' :: Type -> Kind -> VM Type
-paArgType' ty k
- = do
- r <- paArgType ty k
- case r of
- Just ty' -> return ty'
- Nothing -> pprPanic "paArgType'" (ppr ty)
-
-paOfTyCon :: TyCon -> VM CoreExpr
--- FIXME: just for now
-paOfTyCon tc = maybeV (readGEnv $ \env -> lookupNameEnv (global_tycon_pa env) (tyConName tc))
-
-paOfType :: Type -> VM CoreExpr
-paOfType ty | Just ty' <- coreView ty = paOfType ty'
-
-paOfType (TyVarTy tv) = maybeV (readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv)
-paOfType (AppTy ty1 ty2)
- = do
- e1 <- paOfType ty1
- e2 <- paOfType ty2
- return $ mkApps e1 [Type ty2, e2]
-paOfType (TyConApp tc tys)
- = do
- e <- paOfTyCon tc
- es <- mapM paOfType tys
- return $ mkApps e [arg | (t,e) <- zip tys es, arg <- [Type t, e]]
-paOfType (FunTy ty1 ty2) = paOfType (TyConApp funTyCon [ty1,ty2])
-paOfType t@(ForAllTy tv ty) = pprPanic "paOfType:" (ppr t)
-paOfType ty = pprPanic "paOfType:" (ppr ty)
-
-
+ r <- paDictArgType bndr
+ (upd_env, add_lam) <- get_upd r
+ (vbody, lbody) <- localV (upd_env >> vectExpr lc body)
+ return (Lam bndr (add_lam vbody), Lam bndr (add_lam lbody))
+ where
+ get_upd Nothing = return (deleteTyVarPA bndr, id)
+ get_upd (Just pa_ty) = do
+ pa_var <- newLocalVar FSLIT("dPA") pa_ty
+ return (extendTyVarPA bndr (Var pa_var),
+ Lam pa_var)