From afcc92ea6bff03ba42e8f76cd74e9687049a0bdd Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Fran=C3=A7ois=20Pottier?= <francois.pottier@inria.fr>
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