From 9828d551eab6acb46cc6f90863f8a5015067c7dd Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?David=20B=C3=BChler?= <david.buhler@cea.fr>
Date: Thu, 5 May 2022 14:45:42 +0200
Subject: [PATCH] [Eva] Structure: implements iterators iter, fold and map.

---
 src/plugins/value/utils/structure.ml  | 72 +++++++++++++++++++++++++++
 src/plugins/value/utils/structure.mli | 17 +++++++
 2 files changed, 89 insertions(+)

diff --git a/src/plugins/value/utils/structure.ml b/src/plugins/value/utils/structure.ml
index 0df7cdad3ee..72cda0e2668 100644
--- a/src/plugins/value/utils/structure.ml
+++ b/src/plugins/value/utils/structure.ml
@@ -147,6 +147,21 @@ module type External = sig
   val mem : 'a key -> bool
   val get : 'a key -> (t -> 'a) option
   val set : 'a key -> 'a -> t -> t
+
+  type polymorphic_iter_fun = {
+    iter: 'a. 'a key -> 'a data -> 'a -> unit;
+  }
+  val iter: polymorphic_iter_fun -> t -> unit
+
+  type 'b polymorphic_fold_fun = {
+    fold: 'a. 'a key -> 'a data -> 'a -> 'b -> 'b;
+  }
+  val fold: 'b polymorphic_fold_fun -> t -> 'b -> 'b
+
+  type polymorphic_map_fun = {
+    map: 'a. 'a key -> 'a data -> 'a -> 'a;
+  }
+  val map: polymorphic_map_fun -> t -> t
 end
 
 module Open
@@ -228,4 +243,61 @@ module Open
     | Some (Set (k, set)) -> match Shape.eq_type key k with
       | None -> fun _ t -> t
       | Some Eq -> set
+
+  type polymorphic_iter_fun = {
+    iter: 'a. 'a Shape.key -> 'a Shape.data -> 'a -> unit;
+  }
+
+  let rec iter: type a. a structure -> (polymorphic_iter_fun -> a -> unit) =
+    function
+    | Unit -> fun _ () -> ()
+    | Void -> fun _ _ -> ()
+    | Leaf (key, data) -> fun poly v -> poly.iter key data v
+    | Node (left, right) ->
+      let left = iter left
+      and right = iter right in
+      fun poly (a, b) -> left poly a; right poly b;
+    | Option (s, _) ->
+      let iter = iter s in
+      fun poly v -> Option.iter (iter poly) v
+
+  let iter = iter M.structure
+
+  type 'b polymorphic_fold_fun = {
+    fold: 'a. 'a Shape.key -> 'a Shape.data -> 'a -> 'b -> 'b;
+  }
+
+  let rec fold: type a. a structure -> ('b polymorphic_fold_fun -> a -> 'b -> 'b) =
+    function
+    | Unit -> fun _ () acc -> acc
+    | Void -> fun _ _ acc -> acc
+    | Leaf (key, data) -> fun poly v acc -> poly.fold key data v acc
+    | Node (left, right) ->
+      let left = fold left
+      and right = fold right in
+      fun poly (a, b) acc -> right poly b (left poly a acc)
+    | Option (s, _) ->
+      let fold = fold s in
+      fun poly v acc -> Option.fold ~none:acc ~some:(fun v -> fold poly v acc) v
+
+  let fold x = fold M.structure x
+
+  type polymorphic_map_fun = {
+    map: 'a. 'a Shape.key -> 'a Shape.data -> 'a -> 'a;
+  }
+
+  let rec map: type a. a structure -> (polymorphic_map_fun -> a -> a) =
+    function
+    | Unit -> fun _ () -> ()
+    | Void -> fun _ x -> x
+    | Leaf (key, data) -> fun poly v -> poly.map key data v
+    | Node (left, right) ->
+      let left = map left
+      and right = map right in
+      fun poly (a, b) -> (left poly a, right poly b)
+    | Option (s, _) ->
+      let map = map s in
+      fun poly v -> Option.map (map poly) v
+
+  let map = map M.structure
 end
diff --git a/src/plugins/value/utils/structure.mli b/src/plugins/value/utils/structure.mli
index 942ffb87331..792d6a8376e 100644
--- a/src/plugins/value/utils/structure.mli
+++ b/src/plugins/value/utils/structure.mli
@@ -106,6 +106,23 @@ module type External = sig
         this subpart has been replaced by [v].
       - otherwise, [set key _] is the identity function. *)
   val set : 'a key -> 'a -> t -> t
+
+  (** Iterators on the components of a structure. *)
+
+  type polymorphic_iter_fun = {
+    iter: 'a. 'a key -> 'a data -> 'a -> unit;
+  }
+  val iter: polymorphic_iter_fun -> t -> unit
+
+  type 'b polymorphic_fold_fun = {
+    fold: 'a. 'a key -> 'a data -> 'a -> 'b -> 'b;
+  }
+  val fold: 'b polymorphic_fold_fun -> t -> 'b -> 'b
+
+  type polymorphic_map_fun = {
+    map: 'a. 'a key -> 'a data -> 'a -> 'a;
+  }
+  val map: polymorphic_map_fun -> t -> t
 end
 
 (** Opens an internal tree module into an external one. *)
-- 
GitLab