From 467cecfccc1d0fe167f12be242cb6a5cdf8ae74e Mon Sep 17 00:00:00 2001
From: Rudi Grinberg <rudi.grinberg@gmail.com>
Date: Thu, 21 Jun 2018 23:06:39 +0630
Subject: [PATCH] Add sexp conversion to univeral maps

Very useful for debugging

Signed-off-by: Rudi Grinberg <rudi.grinberg@gmail.com>
---
 src/dune_project.ml     | 26 +++++++++++++++++++++++++-
 src/fiber/fiber.ml      |  3 +++
 src/stdune/univ_map.ml  | 17 ++++++++++++++++-
 src/stdune/univ_map.mli |  4 +++-
 src/syntax.ml           |  2 +-
 5 files changed, 48 insertions(+), 4 deletions(-)

diff --git a/src/dune_project.ml b/src/dune_project.ml
index d4900e46..cfabeb1a 100644
--- a/src/dune_project.ml
+++ b/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
diff --git a/src/fiber/fiber.ml b/src/fiber/fiber.ml
index f89955d1..e8793d81 100644
--- a/src/fiber/fiber.ml
+++ b/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 =
diff --git a/src/stdune/univ_map.ml b/src/stdune/univ_map.ml
index a17795be..fc545b7a 100644
--- a/src/stdune/univ_map.ml
+++ b/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
+        ]))
diff --git a/src/stdune/univ_map.mli b/src/stdune/univ_map.mli
index 03d20724..3e764dbb 100644
--- a/src/stdune/univ_map.mli
+++ b/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
diff --git a/src/syntax.ml b/src/syntax.ml
index 3c3eed61..b4c7c6c5 100644
--- a/src/syntax.ml
+++ b/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
   }