Add sexp conversion to univeral maps

Very useful for debugging

Signed-off-by: Rudi Grinberg <rudi.grinberg@gmail.com>

src/dune_project.ml

@@ -5,6 +5,12 @@ module Kind = struct
   type t =
     | Dune
     | Jbuilder
+
+  let sexp_of_t t =
+    Sexp.atom_or_quoted_string
+      (match t with
+       | Dune -> "dune"
+       | Jbuilder -> "jbuilder")
 end
 
 module Name : sig
@@ -116,6 +122,13 @@ module Project_file = struct
     { file           : Path.t
     ; mutable exists : bool
     }
+
+  let sexp_of_t { file; exists } =
+    Sexp.To_sexp.(
+      record
+        [ "file", Path.sexp_of_t file
+        ; "exists", bool exists
+        ])
 end
 
 type t =
@@ -289,7 +302,18 @@ let make_parsing_context ~(lang : Lang.instance) ~extensions =
     ~f:(fun acc (ext : Extension.instance) ->
       Univ_map.add acc (Syntax.key ext.extension.syntax) ext.version)
 
-let key = Univ_map.Key.create ()
+let key =
+  Univ_map.Key.create ~name:"dune-project"
+    (fun { name; root; version; project_file; kind
+         ; stanza_parser = _; packages = _ } ->
+      Sexp.To_sexp.record
+        [ "name", Name.sexp_of_t name
+        ; "root", Path.Local.sexp_of_t root
+        ; "version", Sexp.To_sexp.(option string) version
+        ; "project_file", Project_file.sexp_of_t project_file
+        ; "kind", Kind.sexp_of_t kind
+        ])
+
 let set t = Sexp.Of_sexp.set key t
 let get_exn () =
   let open Sexp.Of_sexp in

src/fiber/fiber.ml

@@ -232,6 +232,9 @@ module Var = struct
   let set var x fiber ctx k =
     let ctx = EC.set_vars ctx (Univ_map.add (EC.vars ctx) var x) in
     fiber ctx k
+
+  let create () =
+    create ~name:"var" (fun _ -> Sexp.atom_or_quoted_string "var")
 end
 
 let with_error_handler f ~on_error ctx k =

src/stdune/univ_map.ml

@@ -13,19 +13,23 @@ module Key = struct
     type t
     type 'a Witness.t += T : t Witness.t
     val id : int
+    val name : string
+    val sexp_of_t : t -> Usexp.t
   end
 
   type 'a t = (module T with type t = 'a)
 
   let next = ref 0
 
-  let create (type a) () =
+  let create (type a) ~name sexp_of_t =
     let n = !next in
     next := n + 1;
     let module M = struct
       type t = a
       type 'a Witness.t += T : t Witness.t
       let id = n
+      let sexp_of_t = sexp_of_t
+      let name = name
     end in
     (module M : T with type t = a)
 
@@ -74,3 +78,14 @@ let find_exn t key =
 let singleton key v = Int.Map.singleton (Key.id key) (Binding.T (key, v))
 
 let superpose = Int.Map.superpose
+
+let sexp_of_t (t : t) =
+  let open Usexp in
+  List (
+    Int.Map.to_list t
+    |> List.map ~f:(fun (_, (Binding.T (key, v))) ->
+      let (module K) = key in
+      List
+        [ atom_or_quoted_string K.name
+        ; K.sexp_of_t v
+        ]))

src/stdune/univ_map.mli

@@ -7,7 +7,7 @@ type t
 
 module Key : sig
   type 'a t
-  val create : unit -> 'a t
+  val create : name:string -> ('a -> Usexp.t) -> 'a t
 end
 
 val empty    : t
@@ -22,3 +22,5 @@ val singleton : 'a Key.t -> 'a -> t
 (** [superpose a b] is [b] augmented with bindings of [a] that are not
     in [b]. *)
 val superpose : t -> t -> t
+
+val sexp_of_t : t -> Usexp.t

src/syntax.ml

@@ -59,7 +59,7 @@ type t =
 let create ~name ~desc supported_versions =
   { name
   ; desc
-  ; key = Univ_map.Key.create ()
+  ; key = Univ_map.Key.create ~name Version.sexp_of_t
   ; supported_versions = Supported_versions.make supported_versions
   }