From afcc92ea6bff03ba42e8f76cd74e9687049a0bdd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fran=C3=A7ois=20Pottier?= Date: Tue, 21 Feb 2017 20:22:30 +0100 Subject: [PATCH] Add [BindingCombinators.endo] as a copy of [map]. --- src/BindingCombinators.ml | 56 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 56 insertions(+) diff --git a/src/BindingCombinators.ml b/src/BindingCombinators.ml index 878c4c5..4b3bedf 100644 --- a/src/BindingCombinators.ml +++ b/src/BindingCombinators.ml @@ -166,6 +166,62 @@ end (* -------------------------------------------------------------------------- *) +(* [endo] *) + +(* Because the combinators do not have a runtime representation, [endo] is + the same thing as [map]. *) + +class virtual ['self] endo = object (self : 'self) + + method private virtual extend: 'env -> 'bn -> 'env * 'bn + + method private visit_abstraction: 'env 'p . + ('env context -> 'p -> 'p) -> + 'env -> 'p abstraction -> 'p abstraction + = fun visit_p env p -> + visit_p (abstraction env) p + + method private visit_binder: + _ -> + 'env context -> 'bn binder -> 'bn binder + = fun _ ctx x -> + let env = !(ctx.current) in + let env, x = self#extend env x in + ctx.current := env; + x + + method private visit_inner: 'env 't . + ('env -> 't -> 't) -> + 'env context -> 't inner -> 't inner + = fun visit_t ctx t -> + self#visit_rebind (self#visit_outer visit_t) ctx t + + method private visit_outer: 'env 't . + ('env -> 't -> 't) -> + 'env context -> 't outer -> 't outer + = fun visit_t ctx t -> + visit_t ctx.outer t + + method private visit_rebind: 'env 'p . + ('env context -> 'p -> 'p) -> + 'env context -> 'p rebind -> 'p rebind + = fun visit_p ctx p -> + visit_p (rebind ctx) p + + method private visit_bind: 'env 'p 't . + ('env context -> 'p -> 'p) -> + ('env -> 't -> 't) -> + 'env -> ('p, 't) bind -> ('p, 't) bind + = fun visit_p visit_t env (p, t) -> + let ctx = abstraction env in + let p = visit_p ctx p in + let t = self#visit_inner visit_t ctx t in + p, t + +end + +(* -------------------------------------------------------------------------- *) + (* [iter] *) class virtual ['self] iter = object (self : 'self) -- GitLab