Add sexp conversion to univeral maps
Very useful for debugging Signed-off-by: Rudi Grinberg <rudi.grinberg@gmail.com>
This commit is contained in:
parent
f35d068836
commit
467cecfccc
|
@ -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
|
||||
|
|
|
@ -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 =
|
||||
|
|
|
@ -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
|
||||
]))
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
}
|
||||
|
||||
|
|
Loading…
Reference in New Issue