From 563cc6059c6e8a8d729f56e420fd6deda31253dd Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Fri, 10 Mar 2017 11:22:01 +0000 Subject: [PATCH] Add Context.sexp_of_t --- src/context.ml | 77 +++++++++++++++++++++++++++++++++++++------------ src/context.mli | 5 ++++ src/findlib.ml | 2 ++ src/findlib.mli | 2 ++ src/main.ml | 3 +- src/sexp.ml | 12 ++++++++ src/sexp.mli | 1 + 7 files changed, 83 insertions(+), 19 deletions(-) diff --git a/src/context.ml b/src/context.ml index 0ba91798..001f9b82 100644 --- a/src/context.ml +++ b/src/context.ml @@ -9,6 +9,13 @@ module Kind = struct } end type t = Default | Opam of Opam.t + + let sexp_of_t : t -> Sexp.t = function + | Default -> Atom "default" + | Opam o -> + Sexp.To_sexp.(record [ "root" , string o.root + ; "switch", string o.switch + ]) end type t = @@ -28,6 +35,7 @@ type t = ; ocamlyacc : Path.t ; ocamlmklib : Path.t ; env : string array + ; env_extra : string String_map.t ; findlib : Findlib.t ; arch_sixtyfour : bool ; opam_var_cache : (string, string) Hashtbl.t @@ -67,6 +75,33 @@ type t = ; which_cache : (string, Path.t option) Hashtbl.t } +let sexp_of_t t = + let open Sexp.To_sexp in + let path = Path.sexp_of_t in + record + [ "name", string t.name + ; "kind", Kind.sexp_of_t t.kind + ; "merlin", bool t.merlin + ; "for_host", option string (Option.map t.for_host ~f:(fun t -> t.name)) + ; "build_dir", path t.build_dir + ; "toplevel_path", option path t.toplevel_path + ; "ocaml_bin", path t.ocaml_bin + ; "ocaml", path t.ocaml + ; "ocamlc", path t.ocamlc + ; "ocamlopt", option path t.ocamlopt + ; "ocamldep", path t.ocamldep + ; "ocamllex", path t.ocamllex + ; "ocamlyacc", path t.ocamlyacc + ; "ocamlmklib", path t.ocamlmklib + ; "env", string_map string t.env_extra + ; "findlib_path", list path (Findlib.path t.findlib) + ; "arch_sixtyfour", bool t.arch_sixtyfour + ; "natdynlink_supported", bool t.natdynlink_supported + ; "opam_vars", string_hashtbl string t.opam_var_cache + ; "ocamlc_config", list (pair string string) t.ocamlc_config + ; "which", string_hashtbl (option path) t.which_cache + ] + let compare a b = compare a.name b.name let get_arch_sixtyfour stdlib_dir = @@ -107,7 +142,26 @@ let get_env env var = let which ~cache ~path x = Hashtbl.find_or_add cache x ~f:(Bin.which ~path) -let create ~(kind : Kind.t) ~path ~env ~name ~merlin = +let extend_env ~vars ~env = + if String_map.is_empty vars then + env + else + let imported = + Array.to_list env + |> List.filter ~f:(fun s -> + match String.index s '=' with + | None -> true + | Some i -> + let key = String.sub s ~pos:0 ~len:i in + not (String_map.mem key vars)) + in + List.rev_append + (List.map (String_map.bindings vars) ~f:(fun (k, v) -> sprintf "%s=%s" k v)) + imported + |> Array.of_list + +let create ~(kind : Kind.t) ~path ~base_env ~env_extra ~name ~merlin = + let env = extend_env ~env:base_env ~vars:env_extra in let opam_var_cache = Hashtbl.create 128 in (match kind with | Opam { root; _ } -> @@ -218,6 +272,7 @@ let create ~(kind : Kind.t) ~path ~env ~name ~merlin = ; ocamlmklib = get_prog "ocamlmklib" ; env + ; env_extra ; findlib = Findlib.create ~stdlib_dir ~path:findlib_path ; arch_sixtyfour = get_arch_sixtyfour stdlib_dir @@ -279,22 +334,8 @@ let default ?(merlin=true) () = | _ -> find_path (i + 1) in let path = find_path 0 in - create ~kind:Default ~path ~env ~name:"default" ~merlin - -let extend_env ~vars ~env = - let imported = - Array.to_list env - |> List.filter ~f:(fun s -> - match String.index s '=' with - | None -> true - | Some i -> - let key = String.sub s ~pos:0 ~len:i in - not (String_map.mem key vars)) - in - List.rev_append - (List.map (String_map.bindings vars) ~f:(fun (k, v) -> sprintf "%s=%s" k v)) - imported - |> Array.of_list + create ~kind:Default ~path ~base_env:env ~env_extra:String_map.empty + ~name:"default" ~merlin let create_for_opam ?root ~switch ~name ?(merlin=false) () = match Bin.opam with @@ -318,7 +359,7 @@ let create_for_opam ?root ~switch ~name ?(merlin=false) () = | Some s -> Bin.parse_path s in let env = Lazy.force initial_env in - create ~kind:(Opam { root; switch }) ~path ~env:(extend_env ~vars ~env) + create ~kind:(Opam { root; switch }) ~path ~base_env:env ~env_extra:vars ~name ~merlin let which t s = which ~cache:t.which_cache ~path:t.path s diff --git a/src/context.mli b/src/context.mli index c4469b9c..6a3d7582 100644 --- a/src/context.mli +++ b/src/context.mli @@ -63,6 +63,9 @@ type t = ; (** Environment variables *) env : string array + ; (** Diff between the base environment and [env] *) + env_extra : string String_map.t + ; findlib : Findlib.t ; (** Misc *) @@ -110,6 +113,8 @@ type t = ; which_cache : (string, Path.t option) Hashtbl.t } +val sexp_of_t : t -> Sexp.t + (** Compare the context names *) val compare : t -> t -> int diff --git a/src/findlib.ml b/src/findlib.ml index 58c8dbe5..98bae41b 100644 --- a/src/findlib.ml +++ b/src/findlib.ml @@ -141,6 +141,8 @@ type t = ; has_headers : (Path.t, bool ) Hashtbl.t } +let path t = t.path + let create ~stdlib_dir ~path = { stdlib_dir ; path diff --git a/src/findlib.mli b/src/findlib.mli index c5f9300f..7b7aade1 100644 --- a/src/findlib.mli +++ b/src/findlib.mli @@ -10,6 +10,8 @@ val create -> path:Path.t list -> t +val path : t -> Path.t list + type package = { name : string ; dir : Path.t diff --git a/src/main.ml b/src/main.ml index 154a3e73..853c9944 100644 --- a/src/main.ml +++ b/src/main.ml @@ -88,7 +88,8 @@ let report_error ?(map_fname=fun x->x) ppf exn ~backtrace = pkg | Code_error msg -> let bt = Printexc.raw_backtrace_to_string backtrace in - Format.fprintf ppf "@{Internal error, please report upstream (include the contents of _build/log.@}\n\ + Format.fprintf ppf "@{Internal error, please report upstream \ + including the contents of _build/log.@}\n\ Description: %s\n\ Backtrace:\n\ %s" msg bt diff --git a/src/sexp.ml b/src/sexp.ml index 644b4548..65a096ae 100644 --- a/src/sexp.ml +++ b/src/sexp.ml @@ -64,6 +64,7 @@ module type Combinators = sig val option : 'a t -> 'a option t val string_set : String_set.t t val string_map : 'a t -> 'a String_map.t t + val string_hashtbl : 'a t -> (string, 'a) Hashtbl.t t end module To_sexp = struct @@ -82,6 +83,10 @@ module To_sexp = struct let string_map f map = list (pair string f) (String_map.bindings map) let record l = List (List.map l ~f:(fun (n, v) -> List [Atom n; v])) + let string_hashtbl f h = + string_map f + (Hashtbl.fold h ~init:String_map.empty ~f:(fun ~key ~data acc -> + String_map.add acc ~key ~data)) end module Of_sexp = struct @@ -137,6 +142,13 @@ module Of_sexp = struct | Error (key, _v1, _v2) -> of_sexp_error sexp (sprintf "key %S present multiple times" key) + let string_hashtbl f sexp = + let map = string_map f sexp in + let tbl = Hashtbl.create (String_map.cardinal map + 32) in + String_map.iter map ~f:(fun ~key ~data -> + Hashtbl.add tbl ~key ~data); + tbl + type unparsed_field = { value : Ast.t option ; entry : Ast.t diff --git a/src/sexp.mli b/src/sexp.mli index 973e379d..20b37f0f 100644 --- a/src/sexp.mli +++ b/src/sexp.mli @@ -34,6 +34,7 @@ module type Combinators = sig val option : 'a t -> 'a option t val string_set : String_set.t t val string_map : 'a t -> 'a String_map.t t + val string_hashtbl : 'a t -> (string, 'a) Hashtbl.t t end module To_sexp : sig