typereg: store cliques, not just single defs; add map

src/typereg/imandrakit_typereg.ml

@@ -2,14 +2,18 @@ module Tbl = Str_tbl
 module Ty_expr = Ty_expr
 module Ty_def = Ty_def
 
-type t = { tbl: Ty_def.t Tbl.t } [@@unboxed]
+type t = {
+  tbl: (Ty_def.t * Ty_def.clique) Tbl.t;
+  mutable cliques: Ty_def.clique list;
+}
 
 let[@inline] key_ ~path ~name : string = spf "%s$%s" path name
 let[@inline] key_of_d_ (d : Ty_def.t) : string = key_ ~path:d.path ~name:d.name
-let create () : t = { tbl = Tbl.create 8 }
+let create () : t = { tbl = Tbl.create 8; cliques = [] }
 let top = create ()
 
-let declare (self : t) ~__FILE__ (decls : Ty_def.t list) : unit =
+let declare (self : t) ~__FILE__ (clique : Ty_def.clique) : unit =
+  self.cliques <- clique :: self.cliques;
   List.iter
     (fun d ->
       let key = key_of_d_ d in
@@ -18,10 +22,10 @@ let declare (self : t) ~__FILE__ (decls : Ty_def.t list) : unit =
           (spf
              "typereg collision in '%s': type def %S in %S is already present."
              __FILE__ d.name d.path);
-      Tbl.add self.tbl key d)
-    decls
+      Tbl.add self.tbl key (d, clique))
+    clique
 
-let[@inline] to_iter self k : unit = Tbl.iter (fun _ d -> k d) self.tbl
+let[@inline] to_iter self k : unit = List.iter k self.cliques
 let[@inline] find self ~path ~name () = Tbl.get self.tbl (key_ ~path ~name)
 let[@inline] find_exn self ~path ~name () = Tbl.find self.tbl (key_ ~path ~name)
 

src/typereg/imandrakit_typereg.mli

@@ -16,13 +16,17 @@ val top : t
 (** Toplevel (default) register *)
 
 val declare : t -> __FILE__:string -> Ty_def.t list -> unit
-(** [declare reg ~__FILE__ tys] declares types to the registry,
+(** [declare reg ~__FILE__ tys] declares a clique of
+      types to the registry,
       with these types being declared in [__FILE__].
     @raise Failure if some types are already registered. *)
 
-val to_iter : t -> Ty_def.t Iter.t
-val find : t -> path:string -> name:string -> unit -> Ty_def.t option
+val to_iter : t -> Ty_def.clique Iter.t
 
-val find_exn : t -> path:string -> name:string -> unit -> Ty_def.t
+val find :
+  t -> path:string -> name:string -> unit -> (Ty_def.t * Ty_def.clique) option
+
+val find_exn :
+  t -> path:string -> name:string -> unit -> Ty_def.t * Ty_def.clique
 (** Same as {!find} but:
   @raise Not_found if not present *)

src/typereg/ty_def.ml

@@ -5,6 +5,9 @@ type ty = Ty_expr.t [@@deriving show, eq, yojson]
 type record = { fields: (string * ty) list }
 [@@deriving show { with_path = false }, eq, yojson]
 
+let map_record ~f { fields } : record =
+  { fields = List.map (fun (s, ty) -> s, f ty) fields }
+
 type cstor = {
   c: string;  (** Constructor name *)
   args: ty list;
@@ -13,13 +16,21 @@ type cstor = {
 }
 [@@deriving show { with_path = false }, eq, yojson]
 
+let map_cstor ~f (c : cstor) : cstor = { c with args = List.map f c.args }
+
 (** Definition *)
 type decl =
   | Alias of ty
   | Alg of cstor list
   | Record of record
 [@@deriving show { with_path = false }, eq, yojson]
 
+let map_decl ~f (d : decl) : decl =
+  match d with
+  | Alias ty -> Alias (f ty)
+  | Alg cs -> Alg (List.map (map_cstor ~f) cs)
+  | Record r -> Record (map_record ~f r)
+
 type t = {
   path: string;  (** Path *)
   name: string;  (** Name of the type *)
@@ -28,5 +39,9 @@ type t = {
 }
 [@@deriving show { with_path = false }, eq, yojson]
 
+type clique = t list
+
+let map ~f (self : t) : t = { self with decl = map_decl ~f self.decl }
+
 let compare_by_name (d1 : t) (d2 : t) =
   compare (d1.path, d1.name) (d2.path, d2.name)

src/typereg/ty_expr.ml

@@ -12,6 +12,13 @@ type t =
   | Tuple of t list
 [@@deriving show { with_path = false }, eq, yojson]
 
+let map_shallow ~f (self : t) =
+  match self with
+  | Var _ -> self
+  | Cstor (s, l) -> Cstor (s, List.map f l)
+  | Arrow (lbl, a, b) -> Arrow (lbl, f a, f b)
+  | Tuple l -> Tuple (List.map f l)
+
 let var v : t = Var v
 let cstor c l : t = Cstor (c, l)
 let arrow ?label a b : t = Arrow (label, a, b)

test/typereg/dune

@@ -1,6 +1,6 @@
 (tests
  (names t1 t2 t3)
- (libraries imandrakit.typereg hex ppx_deriving.runtime)
+ (libraries containers imandrakit.typereg hex ppx_deriving.runtime)
  (package imandrakit)
  (flags :standard -w -34-60)
  (preprocess

test/typereg/fail/t1.ml

@@ -1,8 +1,9 @@
 let dump () =
   Imandrakit_typereg.(
     to_iter top |> Iter.to_rev_list
-    |> List.sort Ty_def.compare_by_name
-    |> List.iter (fun d -> Format.printf "%a@." Ty_def.pp d))
+    |> List.sort (CCList.compare Ty_def.compare_by_name)
+    |> List.iter (fun d ->
+           Format.printf "%a@." (CCFormat.Dump.list Ty_def.pp) d))
 
 module Yolo = struct
   type t = float option list array [@@deriving typereg]

test/typereg/t1.expected

@@ -1,16 +1,16 @@
 t1:
-{ path = "Dune__exe__T1"; name = "bar"; params = [];
-  decl =
-  (Alias
-     (Tuple
-        [(Cstor ("foo", []));
-          (Cstor ("option", [(Cstor ("list", [(Cstor ("int", []))]))]))]))
-  }
-{ path = "Dune__exe__T1"; name = "foo"; params = [];
-  decl = (Alias (Cstor ("int", []))) }
-{ path = "Dune__exe__T1"; name = "t"; params = [];
-  decl =
-  (Alias
-     (Cstor ("array",
-        [(Cstor ("list", [(Cstor ("option", [(Cstor ("float", []))]))]))])))
-  }
+[{ path = "Dune__exe__T1"; name = "bar"; params = [];
+   decl =
+   (Alias
+      (Tuple
+         [(Cstor ("foo", []));
+           (Cstor ("option", [(Cstor ("list", [(Cstor ("int", []))]))]))]))
+   }]
+[{ path = "Dune__exe__T1"; name = "foo"; params = [];
+   decl = (Alias (Cstor ("int", []))) }]
+[{ path = "Dune__exe__T1"; name = "t"; params = [];
+   decl =
+   (Alias
+      (Cstor ("array",
+         [(Cstor ("list", [(Cstor ("option", [(Cstor ("float", []))]))]))])))
+   }]

test/typereg/t2.expected

@@ -1,25 +1,25 @@
 t2:
-{ path = "Dune__exe__T2"; name = "bar"; params = [];
-  decl =
-  (Alg
-     [{ c = "A"; args = []; labels = None };
-       { c = "B"; args = [(Cstor ("int", []))]; labels = None };
-       { c = "C"; args = [(Cstor ("int", [])); (Cstor ("string", []))];
-         labels = None };
-       { c = "D";
-         args =
-         [(Cstor ("int", []));
-           (Cstor ("list",
-              [(Tuple [(Cstor ("string", [])); (Cstor ("foo", []))])]))
-           ];
-         labels = (Some ["x"; "y"]) }
-       ])
-  }
-{ path = "Dune__exe__T2"; name = "foo"; params = [];
-  decl =
-  (Record
-     { fields =
-       [("x", (Cstor ("int", [])));
-         ("y", (Cstor ("option", [(Cstor ("float", []))])))]
-       })
-  }
+[{ path = "Dune__exe__T2"; name = "bar"; params = [];
+   decl =
+   (Alg
+      [{ c = "A"; args = []; labels = None };
+        { c = "B"; args = [(Cstor ("int", []))]; labels = None };
+        { c = "C"; args = [(Cstor ("int", [])); (Cstor ("string", []))];
+          labels = None };
+        { c = "D";
+          args =
+          [(Cstor ("int", []));
+            (Cstor ("list",
+               [(Tuple [(Cstor ("string", [])); (Cstor ("foo", []))])]))
+            ];
+          labels = (Some ["x"; "y"]) }
+        ])
+   }]
+[{ path = "Dune__exe__T2"; name = "foo"; params = [];
+   decl =
+   (Record
+      { fields =
+        [("x", (Cstor ("int", [])));
+          ("y", (Cstor ("option", [(Cstor ("float", []))])))]
+        })
+   }]

test/typereg/t2.ml

@@ -1,5 +1,7 @@
 open Util_
 
+[@@@ocaml.warning "-37-69"]
+
 type foo = {
   x: int;
   y: float option;

test/typereg/t3.expected

@@ -1,5 +1,5 @@
 t3:
-{ path = "Dune__exe__T3"; name = "A.t"; params = [];
-  decl = (Alias (Cstor ("int", []))) }
-{ path = "Dune__exe__T3"; name = "B.t"; params = [];
-  decl = (Alias (Cstor ("bool", []))) }
+[{ path = "Dune__exe__T3"; name = "A.t"; params = [];
+   decl = (Alias (Cstor ("int", []))) }]
+[{ path = "Dune__exe__T3"; name = "B.t"; params = [];
+   decl = (Alias (Cstor ("bool", []))) }]

test/typereg/util_.ml

@@ -1,5 +1,6 @@
 let dump () =
   Imandrakit_typereg.(
     to_iter top |> Iter.to_rev_list
-    |> List.sort Ty_def.compare_by_name
-    |> List.iter (fun d -> Format.printf "%a@." Ty_def.pp d))
+    |> List.sort (CCList.compare Ty_def.compare_by_name)
+    |> List.iter (fun d ->
+           Format.printf "%a@." (CCFormat.Dump.list Ty_def.pp) d))