Add Context.sexp_of_t

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

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
 

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

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

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 "@{<error>Internal error, please report upstream (include the contents of _build/log.@}\n\
+    Format.fprintf ppf "@{<error>Internal error, please report upstream \
+                        including the contents of _build/log.@}\n\
                         Description: %s\n\
                         Backtrace:\n\
                         %s" msg bt

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

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