Make the map_g_typed_value visitor polymorphic

1 files changed, 55 insertions, 57 deletions

diff --git a/src/Values.ml b/src/Values.ml
index 1720dfc2..bcacfefa 100644
--- a/src/Values.ml
+++ b/src/Values.ml
@@ -347,108 +347,102 @@ type abs = {
     which are a special kind of value.
 *)
 
-(** Monomorphic version of the map visitor for [g_typed_value].
-
-    The type variables are quantified at the level of the class (not at the
-    level of each method). As a consequence, the visit methods don't need to
-    take closures as parameters.
+(** Polymorphic version of the map visitor for [g_typed_value].
 
     The polymorphic visitor generated by the visitors macro caused some
-    trouble: it was in some cases not possible to override a function
-    to refine the behaviour of a visitor. With this version, it is
-    possible. Note that this works only because the polymorphism of
-    [g_value], [g_adt_value], etc. is "uniform": the type instantiation
-    is always the same.
-
+    trouble, especially because the map functions allowed to change the
+    type parameters (for instance the typed of `visit_'ty` was:
+    `'env 'r_0 'r_1. 'env -> 'r_0 ty -> 'r_1 ty`, which prevented from
+    initializing it as `fun ty -> ty`).
 *)
 class virtual ['self] map_g_typed_value =
   object (self : 'self)
     inherit [_] VisitorsRuntime.map
 
-    method virtual visit_'sv : 'monomorphic. 'env -> 'sv -> 'sv
-
-    method virtual visit_'bc : 'monomorphic. 'env -> 'bc -> 'bc
-
-    method virtual visit_'lc : 'monomorphic. 'env -> 'lc -> 'lc
-
     method visit_Concrete
-        : 'monomorphic. 'env -> constant_value -> ('r, 'sv, 'bc, 'lv) g_value =
+        : 'env -> constant_value -> ('r, 'sv, 'bc, 'lv) g_value =
       fun _env cv -> Concrete cv
 
     method visit_Adt
-        : 'monomorphic.
-          'env -> ('r, 'sv, 'bc, 'lc) g_adt_value -> ('r, 'sv, 'bc, 'lc) g_value
-        =
-      fun env av ->
-        let av = self#visit_g_adt_value env av in
+        : ('env -> 'sv -> 'sv) ->
+          ('env -> 'bc -> 'bc) ->
+          ('env -> 'lc -> 'lc) ->
+          'env ->
+          ('r, 'sv, 'bc, 'lc) g_adt_value ->
+          ('r, 'sv, 'bc, 'lc) g_value =
+      fun visit_'sv visit_'bc visit_'lc env av ->
+        let av = self#visit_g_adt_value visit_'sv visit_'bc visit_'lc env av in
         Adt av
 
-    method visit_Bottom : 'monomorphic. 'env -> ('r, 'sv, 'bc, 'lv) g_value =
+    method visit_Bottom : 'env -> ('r, 'sv, 'bc, 'lv) g_value =
       fun _env -> Bottom
 
     method visit_Borrow
-        : 'monomorphic. 'env -> 'bc -> ('r, 'sv, 'bc, 'lv) g_value =
-      fun env bc -> Borrow (self#visit_'bc env bc)
+        : ('env -> 'bc -> 'bc) -> 'env -> 'bc -> ('r, 'sv, 'bc, 'lv) g_value =
+      fun visit_'bc env bc -> Borrow (visit_'bc env bc)
 
-    method visit_Loan : 'monomorphic. 'env -> 'lc -> ('r, 'sv, 'bc, 'lv) g_value
-        =
-      fun env lc -> Loan (self#visit_'lc env lc)
+    method visit_Loan
+        : ('env -> 'lc -> 'lc) -> 'env -> 'lc -> ('r, 'sv, 'bc, 'lv) g_value =
+      fun visit_'lc env lc -> Loan (visit_'lc env lc)
 
     method visit_Symbolic
-        : 'monomorphic. 'env -> 'sv -> ('r, 'sv, 'bc, 'lv) g_value =
-      fun env sv -> Symbolic (self#visit_'sv env sv)
+        : ('env -> 'sv -> 'sv) -> 'env -> 'sv -> ('r, 'sv, 'bc, 'lv) g_value =
+      fun visit_'sv env sv -> Symbolic (visit_'sv env sv)
 
     method visit_g_value
-        : 'monomorphic.
-          'env -> ('r, 'sv, 'bc, 'lv) g_value -> ('r, 'sv, 'bc, 'lv) g_value =
-      fun env v ->
+        : ('env -> 'sv -> 'sv) ->
+          ('env -> 'bc -> 'bc) ->
+          ('env -> 'lc -> 'lc) ->
+          'env ->
+          ('r, 'sv, 'bc, 'lv) g_value ->
+          ('r, 'sv, 'bc, 'lv) g_value =
+      fun visit_'sv visit_'bc visit_'lc env v ->
         match v with
         | Concrete cv -> self#visit_Concrete env cv
-        | Adt av -> Adt (self#visit_g_adt_value env av)
+        | Adt av ->
+            Adt (self#visit_g_adt_value visit_'sv visit_'bc visit_'lc env av)
         | Bottom -> self#visit_Bottom env
-        | Borrow bc -> self#visit_Borrow env bc
-        | Loan lc -> self#visit_Loan env lc
-        | Symbolic sv -> self#visit_Symbolic env sv
+        | Borrow bc -> self#visit_Borrow visit_'bc env bc
+        | Loan lc -> self#visit_Loan visit_'lc env lc
+        | Symbolic sv -> self#visit_Symbolic visit_'sv env sv
 
     method visit_g_adt_value
-        : 'monomorphic.
+        : ('env -> 'sv -> 'sv) ->
+          ('env -> 'bc -> 'bc) ->
+          ('env -> 'lc -> 'lc) ->
           'env ->
           ('r, 'sv, 'bc, 'lv) g_adt_value ->
           ('r, 'sv, 'bc, 'lv) g_adt_value =
-      fun env av ->
+      fun visit_'sv visit_'bc visit_'lc env av ->
         let variant_id = av.variant_id in
         let field_values =
-          self#visit_list self#visit_g_typed_value env av.field_values
+          self#visit_list
+            (self#visit_g_typed_value visit_'sv visit_'bc visit_'lc)
+            env av.field_values
         in
         { variant_id; field_values }
 
     method visit_g_typed_value
-        : 'monomorphic.
+        : ('env -> 'sv -> 'sv) ->
+          ('env -> 'bc -> 'bc) ->
+          ('env -> 'lc -> 'lc) ->
           'env ->
           ('r, 'sv, 'bc, 'lv) g_typed_value ->
           ('r, 'sv, 'bc, 'lv) g_typed_value =
-      fun env v ->
-        let value = self#visit_g_value env v.value in
+      fun visit_'sv visit_'bc visit_'lc env v ->
+        let value =
+          self#visit_g_value visit_'sv visit_'bc visit_'lc env v.value
+        in
         let ty = self#visit_ty env v.ty in
         { value; ty }
 
-    method visit_ty : 'monomorphic. 'env -> 'r ty -> 'r ty = fun _env ty -> ty
+    method visit_ty : 'env -> 'r ty -> 'r ty = fun _env ty -> ty
   end
 
 class ['self] map_typed_value =
   object (self : 'self)
     inherit [_] map_g_typed_value
 
-    method visit_'sv
-        : 'monomorphic. 'env -> symbolic_proj_comp -> symbolic_proj_comp =
-      fun env sv -> self#visit_symbolic_proj_comp env sv
-
-    method visit_'bc : 'monomorphic. 'env -> borrow_content -> borrow_content =
-      fun env bc -> self#visit_borrow_content env bc
-
-    method visit_'lc : 'monomorphic. 'env -> loan_content -> loan_content =
-      fun env lc -> self#visit_loan_content env lc
-
     method visit_symbolic_proj_comp
         : 'monomorphic. 'env -> symbolic_proj_comp -> symbolic_proj_comp =
       fun _env sv -> sv
@@ -493,10 +487,14 @@ class ['self] map_typed_value =
 
     method visit_typed_value : 'monomorphic. 'env -> typed_value -> typed_value
         =
-      fun env v -> self#visit_g_typed_value env v
+      fun env v ->
+        self#visit_g_typed_value self#visit_symbolic_proj_comp
+          self#visit_borrow_content self#visit_loan_content env v
 
     method visit_adt_value : 'monomorphic. 'env -> adt_value -> adt_value =
-      fun env v -> self#visit_g_adt_value env v
+      fun env v ->
+        self#visit_g_adt_value self#visit_symbolic_proj_comp
+          self#visit_borrow_content self#visit_loan_content env v
   end
 
 (*class ['self] map_typed_avalue =