Merge branch 'feature-weakly-typed-adt-creation' into 'dev'

ADT generator support to help building a JSON deserializer

See merge request ligolang/ligo!686

src/stages/5-ast_typed/PP_generic.ml

@@ -42,10 +42,10 @@ module M = struct
   let op ppf : (no_state, unit) fold_config = {
       generic = (fun NoState info ->
         match info.node_instance.instance_kind with
-        | RecordInstance { fields } ->
+        | RecordInstance { field_instances } ->
            let aux ppf (fld : ('xi , 'xo) Adt_info.ctor_or_field_instance) =
              fprintf ppf "%s = %a" fld.cf.name (fun _ppf -> fld.cf_continue) NoState in
-           fprintf ppf "{@,@[<hv 2> %a @]@,}" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) fields
+           fprintf ppf "{@,@[<hv 2> %a @]@,}" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) field_instances
         | VariantInstance { constructor ; _ } ->
            if constructor.cf_new_fold needs_parens NoState
            then fprintf ppf "%s (%a)" constructor.cf.name (fun _ppf -> constructor.cf_continue) NoState

src/stages/5-ast_typed/PP_json.ml

@@ -10,12 +10,12 @@ module M = struct
   let to_json : (no_state, json) fold_config = {
       generic = (fun NoState info ->
         match info.node_instance.instance_kind with
-        | RecordInstance { fields } ->
+        | RecordInstance { field_instances } ->
-          let fields' = List.fold_left
+          let field_instances' = List.fold_left
             (fun acc (fld : ('xi, json) Adt_info.ctor_or_field_instance) -> (fld.cf.name, fld.cf_continue NoState)::acc)
-            [] fields 
+            [] field_instances 
           in
-          `Assoc fields'
+          `Assoc field_instances'
         | VariantInstance { constructor ; _ } ->
           `List [ `String constructor.cf.name ; constructor.cf_continue NoState ]
         | PolyInstance { poly=_; arguments=_; poly_continue } ->

src/stages/5-ast_typed/compare_generic.ml

@@ -36,10 +36,10 @@ module M = struct
   let op : (no_state, t) fold_config = {
       generic = (fun NoState info ->
         match info.node_instance.instance_kind with
-        | RecordInstance { fields } ->
+        | RecordInstance { field_instances } ->
            let aux (fld : ('xi, 'xo) Adt_info.ctor_or_field_instance) =
              ( fld.cf.name , fun () -> fld.cf_continue NoState ) in
-           Record ("name_of_the_record", List.map aux fields)
+           Record ("name_of_the_record", List.map aux field_instances)
         | VariantInstance { constructor ; _ } ->
            VariantConstructor ("name_of_the_variant", constructor.cf.name, fun () -> constructor.cf_continue NoState)
         | PolyInstance { poly=_; arguments=_; poly_continue } ->

src/stages/5-ast_typed/types_utils.ml

@@ -127,3 +127,33 @@ let fold_map__poly_set : type a state new_a err . new_a extra_info__comparable -
     ok (state , PolySet.add new_elt s) in
   let%bind (state , m) = PolySet.fold_inc aux s ~init:(ok (state, PolySet.create ~cmp:new_compare)) in
   ok (state , m)
+
+
+(* This takes a fold_map__xxx function and turns it into a make__xxx
+   function.
+   It just swaps the error monad with the option monad, and uses unit
+   as the type for the state and for "errors". *)
+let fold_map_to_make fold_map = fun f v ->
+  match fold_map (fun () x -> match f x with Some x' -> ok ((), x') | None -> Pervasives.Error ()) () v with
+    Pervasives.Ok (((), v'), _) -> Some v'
+  | Pervasives.Error () -> None
+
+(* This can't be done automatically, because the auto-generated
+   comparison functions make use of the fold, the fold supplies to
+   users some "make" functions, and there's no deterministic way to
+   extract the comparison functions (or other typeclass-like
+   functions).
+
+   Instead of writing the following functions, we could just write the
+   get_typeclass_compare functions for poly_unionfind and poly_set,
+   but the resulting code wouldn't be much clearer. *)
+let make__constructor_map f v = fold_map_to_make fold_map__constructor_map f v
+let make__label_map f v = fold_map_to_make fold_map__label_map f v
+let make__list f v = fold_map_to_make fold_map__list f v
+let make__location_wrap f v = fold_map_to_make fold_map__location_wrap f v
+let make__list_ne f v = fold_map_to_make fold_map__list_ne f v
+let make__option f v = fold_map_to_make fold_map__option f v
+let make__poly_unionfind f v = fold_map_to_make (fold_map__poly_unionfind { compare = failwith "TODO" (*UnionFind.Poly2.get_compare v*) }) f v
+let make__PolyMap f v = fold_map_to_make fold_map__PolyMap f v
+let make__typeVariableMap f v = fold_map_to_make fold_map__typeVariableMap f v
+let make__poly_set f v = fold_map_to_make (fold_map__poly_set { compare = failwith "TODO" (*PolySet.get_compare v*) }) f v

src/stages/adt_generator/common.ml

@@ -1,3 +1,7 @@
 type ('a,'err) monad = ('a,'err) Simple_utils.Trace.result;;
 let (>>?) v f = Simple_utils.Trace.bind f v;;
 let return v = Simple_utils.Trace.ok v;;
+
+let sorted_bindings m =
+  List.sort (fun (a , _) (b , _) -> String.compare a b)
+  @@ RedBlackTrees.PolyMap.bindings m

src/stages/adt_generator/dune

@@ -3,5 +3,6 @@
   (public_name ligo.adt_generator)
   (libraries
     simple-utils
+    RedBlackTrees
   )
 )

src/stages/adt_generator/generator.raku

@@ -94,6 +94,12 @@ $*OUT = open $folder_filename, :w;
     for $statements -> $statement { say "$statement" }
     say "open $moduleName;;";
 
+    say "  (* must be provided by one of the open or include statements: *)";
+    say "  module CheckFolderInputSignature = struct";
+    for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant}).map({$_<kind>}).unique -> $poly
+    { say "    let make__$poly : type a b . (a -> b option) -> a $poly -> b $poly option = make__$poly;;"; }
+    say "  end";
+
     say "";
     say "  include Adt_generator.Generic.BlahBluh";
     say "  type ('in_state, 'out_state , 'adt_info_node_instance_info) _fold_config = \{";
@@ -107,9 +113,25 @@ $*OUT = open $folder_filename, :w;
     { say "      $poly : 'a . ('in_state , 'out_state , 'adt_info_node_instance_info) _fold_config -> ('in_state -> 'a -> 'out_state) -> 'in_state -> 'a $poly -> 'out_state;"; }
     say '    };;';
 
+    say "";
+    say "  type whatever =";
+    say "  | NoArgument (* supplied to make constructors with no arguments *)";
+    # look for builtins, filtering out the "implicit unit-like fake argument of emtpy constructors" (represented by '')
+    for $adts.map({ $_<ctorsOrFields> })[*;*].grep({$_<isBuiltin> && $_<type> ne ''}).map({$_<type>}).unique -> $builtin
+    { say "  | Whatever_{tc $builtin} of $builtin"; }
+    for $adts.list -> $t
+    { say "  | Whatever_{tc $t<name>} of $t<name>" }
+
+    say "  type make_poly =";
+    # look for built-in polymorphic types
+    for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant}).map({$_<kind>}).unique -> $poly
+    { say "  | Make_{tc $poly} of (whatever $poly -> whatever option)"; }
+
     say "";
     say "  module Adt_info = Adt_generator.Generic.Adt_info (struct";
     say "    type nonrec ('in_state , 'out_state , 'adt_info_node_instance_info) fold_config = ('in_state , 'out_state , 'adt_info_node_instance_info) _fold_config;;";
+    say "    type nonrec whatever = whatever;;";
+    say "    type nonrec make_poly = make_poly;;";
     say "  end);;";
     say "  include Adt_info;;";
     say "  type ('in_state, 'out_state) fold_config = ('in_state , 'out_state , ('in_state , 'out_state) Adt_info.node_instance_info) _fold_config;;";
@@ -127,14 +149,31 @@ $*OUT = open $folder_filename, :w;
     for $adts.list -> $t
     { for $t<ctorsOrFields>.list -> $c
       { say "  (* info for field or ctor $t<name>.$c<name> *)";
+        if ($t<kind> eq $variant) {
+	    say "  let info__$t<name>__$c<name> : Adt_info.constructor_type = \{";
+	    say "      ctor = \{";
+	    say "        name = \"$c<name>\";";
+	    say "        is_builtin = {$c<isBuiltin> ?? 'true' !! 'false'};";
+	    say "        type_ = \"$c<type>\";";
+	    say "      \};";
+	    if ($c<type> eq '') {
+		# this constructor has no arguments.
+		say "      make_ctor = (function NoArgument -> Some (Whatever_{tc $t<name>} $c<name>) | _ -> None);";
+	    } else {
+		say "      make_ctor = (function Whatever_{tc $c<type>} v -> Some (Whatever_{tc $t<name>} ($c<name> v)) | _ -> None);";
+	    }
+	    say '    };;';
+        } else {
 	    say "  let info__$t<name>__$c<name> : Adt_info.ctor_or_field = \{";
 	    say "        name = \"$c<name>\";";
 	    say "        is_builtin = {$c<isBuiltin> ?? 'true' !! 'false'};";
 	    say "        type_ = \"$c<type>\";";
 	    say '    };;';
+	}
         # say "";
         say "  let continue_info__$t<name>__$c<name> : type in_qstate out_qstate . the_folds -> (in_qstate , out_qstate) fold_config -> {$c<type> || 'unit'} -> (in_qstate, out_qstate) Adt_info.ctor_or_field_instance = fun the_folds visitor x -> \{";
-        say "        cf = info__$t<name>__$c<name>;";
+        my $dotctor = ($t<kind> eq $variant) ?? ".ctor" !! ""; # TODO: give the full constructor info with its "make" function instead of extracting the .ctor part.
+        say "        cf = info__$t<name>__$c<name>$dotctor;";
         say "        cf_continue = (fun state -> the_folds.fold__$t<name>__$c<name> the_folds visitor state x);";
         say "        cf_new_fold = (fun visitor state -> the_folds.fold__$t<name>__$c<name> the_folds visitor state x);";
         say '      };;';
@@ -142,16 +181,40 @@ $*OUT = open $folder_filename, :w;
       }
       say "  (* info for node $t<name> *)";
       say "  let info__$t<name> : Adt_info.node = \{";
-      my $kind = do given $t<kind> {
+      print "      kind = ";
-          when $record { "Record" }
+      do given $t<kind> {
-          when $variant { "Variant" }
+          when $record {
-          default { "Poly \"$_\"" }
+	      say "RecordType \{";
-      };
+	      say "        fields = [";
-      say "      kind = $kind;";
+	      for $t<ctorsOrFields>.list -> $f {
-      say "      declaration_name = \"$t<name>\";";
+		  say "          info__$t<name>__$f<name>;";
-      print "      ctors_or_fields = [ ";
+	      }
+	      say "        ];";
+	      say "        make_record = (fun r -> match Adt_generator.Common.sorted_bindings r with";
+	      say "        | [";
+	      for $t<ctorsOrFields>.list.sort({$_<name>}) -> $f {
+		  say "          (\"$f<name>\" , Whatever_{tc $f<type>} $f<name>) ;";
+	      }	    
+	      say "          ] -> Some (Whatever_{tc $t<name>} \{";
+	      for $t<ctorsOrFields>.list -> $f { say "          $f<name> ;"; }
+	      say "        \})";
+	      say "        | _ -> None)";
+	      say "      \};"; }
+          when $variant {
+	      say "VariantType \{";
+	      print "        constructors = [ ";
 	      for $t<ctorsOrFields>.list -> $c { print "info__$t<name>__$c<name> ; "; }
 	      say "];";
+	      say "      \};"; }
+          default {
+	      say "PolyType \{";
+	      say "        poly_name = \"$_\";";
+	      print "        make_poly = Make_{tc $_} (fun p -> match make__$_ ";
+	      for $t<ctorsOrFields>.list -> $a { print "(function Whatever_{tc $a<type>} v -> Some v | _ -> None)"; }
+	      say " p with Some p -> Some (Whatever_{tc $t<name>} p) | None -> None);";
+	      say "      \};"; }
+      };
+      say "      declaration_name = \"$t<name>\";";
       say '    };;';
       # say "";
       # TODO: factor out some of the common bits here.
@@ -161,7 +224,7 @@ $*OUT = open $folder_filename, :w;
       do given $t<kind> {
           when $record {
               say '      instance_kind = RecordInstance {';
-              print "      fields = [ ";
+              print "          field_instances = [ ";
               for $t<ctorsOrFields>.list -> $c { print "continue_info__$t<name>__$c<name> the_folds visitor x.$c<name> ; "; }
               say "];";
               say '        };';
@@ -174,7 +237,7 @@ $*OUT = open $folder_filename, :w;
               for $t<ctorsOrFields>.list -> $c { say "               | $c<name> { $c<type> ?? 'v ' !! '' }-> continue_info__$t<name>__$c<name> the_folds visitor { $c<type> ?? 'v' !! '()' }"; }
               say "              );";
               print "            variant = [ ";
-              for $t<ctorsOrFields>.list -> $c { print "info__$t<name>__$c<name> ; "; }
+              for $t<ctorsOrFields>.list -> $c { print "info__$t<name>__$c<name>.ctor ; "; } # TODO: give the full constructor info with its "make" function.
               say "];";
               say '          };';
           }
@@ -183,9 +246,7 @@ $*OUT = open $folder_filename, :w;
               say '        PolyInstance {';
               say "            poly = \"$_\";";
               print "            arguments = [";
-              # TODO: sort by c<name> (currently we only have one-argument
+              for $t<ctorsOrFields>.list.sort({$_<name>}) -> $c { print "\"$c<type>\""; }
-              # polymorphic types so it happens to work but should be fixed.
-              for $t<ctorsOrFields>.list -> $c { print "\"$c<type>\""; }
               say "];";
               print "            poly_continue = (fun state -> visitor.$_ visitor (";
               print $t<ctorsOrFields>
@@ -201,10 +262,11 @@ $*OUT = open $folder_filename, :w;
 
     say "";
     say "  (* info for adt $moduleName *)";
-    print "  let whole_adt_info : unit -> Adt_info.adt = fun () -> [ ";
+    say "  let whole_adt_info : unit -> Adt_info.adt = fun () ->";
+    print "  match RedBlackTrees.PolyMap.from_list ~cmp:String.compare [ ";
     for $adts.list -> $t
-    { print "info__$t<name> ; "; }
+    { print "\"$t<name>\" , info__$t<name> ; "; }
-    say "];;";
+    say "] with Some x -> x | None -> failwith \"Internal error: duplicate nodes in ADT info\";;";
 
     # fold functions
     say "";
@@ -300,7 +362,7 @@ $*OUT = open $mapper_filename, :w;
     }
 
     say "";
-    for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant && $typeclasses{$_<kind>}}).unique(:as({$_<ctorsOrFields>, $_<kind>})) -> $t
+    for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant && $typeclasses{$_<kind>}}).unique(:as({$_<ctorsOrFields>, $_<kind>}), :with(&[eqv])) -> $t
     { my $ty = $t<ctorsOrFields>[0]<type>;
       my $typeclass = $typeclasses{$t<kind>};
       say "  val extra_info__{$ty}__$typeclass : $ty extra_info__$typeclass;;"; }
@@ -311,7 +373,7 @@ $*OUT = open $mapper_filename, :w;
     say "  module O : OSig = $oModuleName";
     say "";
     say "  (* must be provided by one of the open or include statements: *)";
-    say "  module CheckInputSignature = struct";
+    say "  module CheckMapperInputSignature = struct";
     for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant}).map({$_<kind>}).unique -> $poly
     { say "    let fold_map__$poly : type a new_a state err .{ $typeclasses{$poly} ?? " new_a extra_info__{$typeclasses{$poly}} ->" !! "" } (state -> a -> (state * new_a, err) monad) -> state -> a $poly -> (state * new_a $poly , err) monad = fold_map__$poly;;"; }
     say "  end";
@@ -500,7 +562,7 @@ $*OUT = open $combinators_filename, :w;
     }
 
     say "";
-    for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant && $typeclasses{$_<kind>}}).unique(:as({$_<ctorsOrFields>, $_<kind>})) -> $t
+    for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant && $typeclasses{$_<kind>}}).unique(:as({$_<ctorsOrFields>, $_<kind>}), :with(&[eqv])) -> $t
     { my $ty = $t<ctorsOrFields>[0]<type>;
       my $typeclass = $typeclasses{$t<kind>};
       say "let extra_info__{$ty}__$typeclass : $ty extra_info__$typeclass = {tc $typeclass}.$ty;;";

src/stages/adt_generator/generic.ml

@@ -10,14 +10,35 @@ module BlahBluh = struct
   type 'state generic_continue_fold = ('state generic_continue_fold_node) StringMap.t;;
 end
 
-module Adt_info (M : sig type ('in_state , 'out_state , 'adt_info_node_instance_info) fold_config end) = struct
+module Adt_info (M : sig type ('in_state , 'out_state , 'adt_info_node_instance_info) fold_config;; type whatever;; type make_poly;; end) = struct
   type kind =
-  | Record
+  | RecordType of record_type
-  | Variant
+  | VariantType of variant_type
-  | Poly of string
+  | PolyType of poly_type
 
-  type ('in_state , 'out_state) record_instance = {
+  and ctor_or_field =
-    fields : ('in_state , 'out_state) ctor_or_field_instance list;
+    {
+      name : string;
+      is_builtin : bool;
+      type_ : string;
+    }
+
+  and record_type = {
+    fields : ctor_or_field list;
+    make_record : (string , M.whatever) RedBlackTrees.PolyMap.t -> M.whatever option
+  }
+
+  and ('in_state , 'out_state) record_instance = {
+    field_instances : ('in_state , 'out_state) ctor_or_field_instance list;
+  }
+
+  and variant_type = {
+    constructors : constructor_type list;
+  }
+
+  and constructor_type = {
+    ctor : ctor_or_field;
+    make_ctor : M.whatever -> M.whatever option;
   }
 
   and ('in_state , 'out_state) constructor_instance = {
@@ -25,6 +46,11 @@ module Adt_info (M : sig type ('in_state , 'out_state , 'adt_info_node_instance_
     variant : ctor_or_field list
   }
 
+  and poly_type = {
+    poly_name : string;
+    make_poly : M.make_poly;
+  }
+
   and ('in_state , 'out_state) poly_instance = {
     poly : string;
     arguments : string list;
@@ -41,13 +67,6 @@ module Adt_info (M : sig type ('in_state , 'out_state , 'adt_info_node_instance_
     instance_kind : ('in_state , 'out_state) kind_instance;
   }
 
-  and ctor_or_field =
-    {
-      name : string;
-      is_builtin : bool;
-      type_ : string;
-    }
-
   and ('in_state , 'out_state) ctor_or_field_instance =
     {
       cf : ctor_or_field;
@@ -59,11 +78,10 @@ module Adt_info (M : sig type ('in_state , 'out_state , 'adt_info_node_instance_
     {
       kind : kind;
       declaration_name : string;
-      ctors_or_fields : ctor_or_field list;
     }
 
   (* TODO: rename things a bit in this file. *)
-  and adt = node list
+  and adt = (string, node) RedBlackTrees.PolyMap.t
   and ('in_state , 'out_state) node_instance_info = {
     adt           : adt ;
     node_instance : ('in_state , 'out_state) instance ;

src/test/adt_generator/amodule_utils.ml

@@ -12,3 +12,10 @@ let fold_map__option continue state v =
   match v with
     Some x -> continue state x
   | None -> ok None
+
+let make__list f l =
+  List.fold_right
+    (fun elt acc -> match acc, f elt with
+         Some acc, Some x -> Some (x :: acc)
+       | _ -> None)
+    l (Some [])

src/test/adt_generator/use_a_fold.ml

@@ -61,14 +61,13 @@ let _noi : (int, _) fold_map_config__Amodule = no_op (* (fun _ -> ()) *)
 let _nob : (bool, _) fold_map_config__Amodule = no_op (* (fun _ -> ()) *)
 
 type no_state = NoState
-let () =
+let to_string some_root =
-  let some_root : root = A [ { a1 = X (A [ { a1 = X (B [ 1 ; 2 ; 3 ]) ; a2 = W () } ]) ; a2 = Z (W ()) } ] in
   let op : ('i, 'o) Generated_fold.fold_config = {
     generic = (fun NoState info ->
         match info.node_instance.instance_kind with
-        | RecordInstance { fields } ->
+        | RecordInstance { field_instances } ->
-           false, "{ " ^ String.concat " ; " (List.map (fun (fld : ('xi , 'xo) Adt_info.ctor_or_field_instance) -> fld.cf.name ^ " = " ^ snd (fld.cf_continue NoState)) fields) ^ " }"
+          false, "{ " ^ String.concat " ; " (List.map (fun (fld : ('xi , 'xo) Adt_info.ctor_or_field_instance) -> fld.cf.name ^ " = " ^ snd (fld.cf_continue NoState)) field_instances) ^ " }"
-        | VariantInstance { constructor={ cf = { name; is_builtin=_; type_=_ }; cf_continue; cf_new_fold=_ }; variant=_ } ->
+        | VariantInstance { constructor={ cf = { name; is_builtin=_; type_=_; }; cf_continue; cf_new_fold=_ }; variant=_ } ->
           (match cf_continue NoState with
            | true,  arg -> true, name ^ " (" ^ arg ^ ")"
            | false, arg -> true, name ^ " "  ^ arg)
@@ -87,8 +86,50 @@ let () =
      * ); *)
   } in
   let (_ , state) = Generated_fold.fold__root op NoState some_root in
+  state
+
+let () =
+  let some_root : root = A [ { a1 = X (A [ { a1 = X (B [ 1 ; 2 ; 3 ]) ; a2 = W () } ]) ; a2 = Z (W ()) } ] in
   let expected = "A [ { a1 = X (A [ { a1 = X (B [ 1 ; 2 ; 3 ]) ; a2 = W () } ]) ; a2 = Z (W ()) } ]" in
+  let state = to_string some_root in
   if String.equal state expected; then
     ()
   else
     failwith (Printf.sprintf "Test failed: expected\n  %s\n but got\n  %s" expected state)
+
+(* Test generic creation of nodes *)
+let () =
+  let i = whole_adt_info () in
+  let dynamic =
+    match RedBlackTrees.PolyMap.find_opt "rootB" i with
+    | Some { kind = PolyType { poly_name = _; make_poly }; declaration_name = _ } ->
+      (match make_poly with
+         Make_List mk ->
+         match mk [ Whatever_Int 42 ; Whatever_Int 43 ] with
+           Some l ->
+           (match RedBlackTrees.PolyMap.find_opt "root" i with
+              Some { kind = VariantType { constructors }; declaration_name = _ } ->
+              (* TODO: use a PolyMap.t *)
+              let { ctor = _ ; make_ctor } = List.find (fun { ctor = { name; is_builtin = _; type_ = _ }; make_ctor = _ } -> String.equal name "B") constructors in
+              let _ =
+                (match l with
+                 | Whatever_RootB _ -> () | _ -> failwith "whoops")
+              in
+              (match make_ctor l with (* Wrap the int list with the B constructor *)
+                 Some b -> b
+               | None -> failwith "Couldn't create instance of the B constructor, did you supply the right argument type?")
+            | Some { kind = _ ; _ } -> failwith "unexpected node info for root: wrong kind !!!"
+            | None -> failwith "can't find node info for root !!!")
+         | None -> failwith "Couldn't create list, did you supply the wrong element type?"
+         (* | _ -> failwith "unexpected maker function for rootB: expected rootB to be a list !!!" *)
+      )
+    | Some { kind = _ ; _ } -> failwith "unexpected node info for rootB: wrong kind !!!"
+    | None -> failwith "can't find node info for rootB !!!"
+  in
+  (match dynamic with
+     Whatever_Root root ->
+     (match root with
+        B [ 42 ; 43 ] -> () (* Victory, we created the expected value *)
+      | _ -> failwith ("Incorrect value " ^ to_string root))
+   | _ -> failwith "Incorrect result type: expected a dynamically-typed root, but got something else")
+

vendors/Red-Black_Trees/PolyMap.ml

@@ -31,11 +31,30 @@ let find key map =
 let find_opt key map =
   try Some (find key map) with Not_found -> None
 
+let has_key key map =
+  match find_opt key map with
+    Some _ -> true
+  | None -> false
+
 let update key updater map =
   match updater (find_opt key map) with
   | None -> remove key map
   | Some v -> add key v map
 
+type ('key, 'value) added = {map : ('key, 'value) t; duplicates : ('key * 'value) list; added : ('key * 'value) list}
+let add_list elts map =
+  let aux = fun {map ; duplicates ; added} ((key, value) as kv) ->
+    if has_key key map
+    then {map; duplicates = kv :: duplicates ; added}
+    else {map = add key value map; duplicates; added = kv :: added} in
+  List.fold_left aux {map; duplicates=[]; added = []} elts
+
+let from_list ~cmp elts =
+  match add_list elts (create ~cmp) with
+    { map; duplicates = []; added = _ } -> Some map
+  | _ -> None (* Refuse to create a map from a list with duplicates *)
+
+
 let bindings map =
   RB.fold_dec (fun ~elt ~acc -> elt::acc) ~init:[] map.tree
 

vendors/Red-Black_Trees/PolyMap.mli

@@ -20,6 +20,13 @@ type ('key, 'value) map = ('key, 'value) t
 
 val create : cmp:('key -> 'key -> int) -> ('key, 'value) t
 
+(* The value of the call [from_list ~cmp elts] is a [Some map] with
+   [cmp] being the comparison over the keys. The map initially
+   contains the bindings listed in [elts]. If the same (w.r.t. [cmp])
+   key occurs twice [elts] then [None] is returned instead to indicate
+   the error. *)
+val from_list : cmp:('key -> 'key -> int) -> ('key * 'value) list -> ('key, 'value) t option
+
 val empty : ('key, 'value) t -> ('key, 'new_value) t
 
 (* Emptiness *)
@@ -50,6 +57,12 @@ val find : 'key -> ('key, 'value) t -> 'value
 
 val find_opt : 'key -> ('key, 'value) t -> 'value option
 
+(* The value of the call [find_opt key map] is [true] if the key
+   [key] is bound to some value in the map [map], and [None]
+   otherwise. *)
+
+val has_key : 'key -> ('key, 'value) t -> bool
+
 (* The value of the call [update key f map] is a map containing all
    the bindings of the map [map], extended by the binding of [key] to
    the value returned by [f], when [f maybe_value] returns
@@ -66,6 +79,18 @@ val update : 'key -> ('value option -> 'value option) -> ('key, 'value) map -> (
    (with respect to the total comparison function used to create the
    map). *)
 
+(* The value of the call [add_list kv_list map] is a record of type
+   [('key, 'value) added]. The elements from the [kv_list] are added
+   to the [map] starting from the head of the list. The elements for
+   which the key is already present in the [map] at the point at which
+   they are added are gathered in the [duplicates] list (and the [map]
+   is not updated for these elements, i.e. it keeps the pre-existing
+   version of the value associated to that key). The elements for
+   which the key is not already present in the [map] are added to the
+   [map], and gathered in the [added] list. *)
+type ('key, 'value) added = {map : ('key, 'value) t; duplicates : ('key * 'value) list; added : ('key * 'value) list}
+val add_list : ('key * 'value) list -> ('key, 'value) t -> ('key, 'value) added
+
 val bindings : ('key, 'value) t -> ('key * 'value) list
 
 (* The side-effect of evaluating the call [iter f map] is the

vendors/Red-Black_Trees/PolySet.ml

@@ -36,6 +36,8 @@ let add_list elts set =
 
 let elements set = RB.elements set.tree
 
+let get_compare set = set.cmp
+
 let iter f set = RB.iter f set.tree
 
 let fold_inc f set = RB.fold_inc (fun ~elt -> f elt) set.tree

vendors/Red-Black_Trees/PolySet.mli

@@ -63,13 +63,17 @@ val mem : 'elt -> 'elt t -> bool
    are already part of the [set] at the point at which they are added
    are gathered in the [duplicates] list (and the [set] is not updated
    for these elements, i.e. it keeps the pre-existing version of the
-   element). The elements which are not already members of the set are
+   element). The elements which are not already members of the [set]
-   added to the [set], and gathered in the [added] list. *)
+   are added to the [set], and gathered in the [added] list. *)
 type 'a added = {set : 'a set; duplicates : 'a list; added : 'a list}
 val add_list : 'a list -> 'a set -> 'a added
 
 val elements : 'elt t -> 'elt list
 
+(* The value of the call [get_compare set] is the comparison function
+   used by the given set *)
+val get_compare : 'elt t -> ('elt -> 'elt -> int)
+
 (* The side-effect of evaluating the call [iter f set] is the
    successive side-effects of the calls [f elt], for all the elements
    [elt] of the set [set], sorted in increasing order (with respect to

vendors/UnionFind/Poly2.ml

@@ -145,6 +145,8 @@ let partitions : 'item . 'item partition -> 'item list list =
   let partitions = List.sort (compare_lists_by_first compare) partitions in
   partitions
 
+let get_compare p = p.compare
+
 (** {1 Printing} *)
 
 let print ppf (p: 'item partition) =

vendors/UnionFind/Poly2.mli

@@ -54,6 +54,11 @@ val elements : 'item partition -> 'item list
    have the same order). *)
 val partitions : 'item partition -> 'item list list
 
+(** The value of the call [get_compare p] is the comparison function
+    used by p *)
+val get_compare : 'item partition -> ('item -> 'item -> int)
+
+
 (** The call [print p] is a value of type [Buffer.t] containing
         strings denoting the partition [p], based on
         [Ord.to_string]. *)