Allow to specify which context for merlin

bin/main.ml

@@ -60,7 +60,7 @@ let installed_libraries =
   let go common =
     set_common common;
     Future.Scheduler.go ~log:(create_log ())
-      (Lazy.force Context.default >>= fun ctx ->
+      (Context.default () >>= fun ctx ->
        let findlib = Findlib.create ctx in
        let pkgs = Findlib.all_packages findlib in
        let max_len = List.longest_map pkgs ~f:(fun p -> p.name) in

src/context.ml

@@ -8,6 +8,7 @@ end
 type t =
   { name                    : string
   ; kind                    : Kind.t
+  ; merlin                  : bool
   ; for_host                : t option
   ; build_dir               : Path.t
   ; path                    : Path.t list
@@ -82,7 +83,7 @@ let opam_config_var ~env ~cache var =
       Hashtbl.add cache ~key:var ~data:s;
       Some s
 
-let create ~(kind : Kind.t) ~path ~env ~name =
+let create ~(kind : Kind.t) ~path ~env ~name ~merlin =
   let opam_var_cache = Hashtbl.create 128 in
   (match kind with
    | Opam { root; _ } ->
@@ -168,6 +169,7 @@ let create ~(kind : Kind.t) ~path ~env ~name =
   let t =
     { name
     ; kind
+    ; merlin
     ; for_host = None
     ; build_dir
     ; path
@@ -232,7 +234,7 @@ let initial_env = lazy (
   Lazy.force Ansi_color.setup_env_for_ocaml_colors;
   Unix.environment ())
 
-let default = lazy (
+let default ?(merlin=true) () =
   let env = Lazy.force initial_env in
   let rec find_path i =
     if i = Array.length env then
@@ -244,7 +246,7 @@ let default = lazy (
       | _ -> find_path (i + 1)
   in
   let path = find_path 0 in
-  create ~kind:Default ~path ~env ~name:"default")
+  create ~kind:Default ~path ~env ~name:"default" ~merlin
 
 let extend_env ~vars ~env =
   let imported =
@@ -261,7 +263,7 @@ let extend_env ~vars ~env =
     imported
   |> Array.of_list
 
-let create_for_opam ?root ~switch ~name () =
+let create_for_opam ?root ~switch ~name ?(merlin=false) () =
   match Bin.opam with
   | None -> die "Program opam not found in PATH"
   | Some fn ->
@@ -284,7 +286,7 @@ let create_for_opam ?root ~switch ~name () =
     in
     let env = Lazy.force initial_env in
     create ~kind:(Opam { root; switch }) ~path ~env:(extend_env ~vars ~env)
-      ~name
+      ~name ~merlin
 
 let which t s = Bin.which ~path:t.path s
 

src/context.mli

@@ -28,6 +28,9 @@ type t =
   { name : string
   ; kind : Kind.t
 
+  ; (** [true] if this context is used for the .merlin files *)
+    merlin : bool
+
   ; (** If this context is a cross-compilation context, you need another context for
         building tools used for the compilation that run on the host. *)
     for_host : t option
@@ -101,10 +104,11 @@ val create_for_opam
   :  ?root:string
   -> switch:string
   -> name:string
+  -> ?merlin:bool
   -> unit
   -> t Future.t
 
-val default : t Future.t Lazy.t
+val default : ?merlin:bool -> unit -> t Future.t
 
 (** All contexts in use, by name *)
 val all : unit -> t String_map.t

src/gen_rules.ml

@@ -626,7 +626,7 @@ module Gen(P : Params) = struct
         )
     )
 
-  let requires ~dir ~dep_kind ~item ~libraries ~preprocess ~virtual_deps =
+  let real_requires ~dir ~dep_kind ~item ~libraries ~preprocess ~virtual_deps =
     let all_pps =
       Preprocess_map.pps preprocess
       |> Pp_set.elements
@@ -647,65 +647,65 @@ module Gen(P : Params) = struct
        Build.store_vfile vrequires);
     Build.vpath vrequires
 
+  let requires ~dir ~dep_kind ~item ~libraries ~preprocess ~virtual_deps =
+    let real_requires =
+      real_requires ~dir ~dep_kind ~item ~libraries ~preprocess ~virtual_deps
+    in
+    let requires =
+      if ctx.merlin then
+        match Path.extract_build_context dir with
+        | Some (_, remaindir) ->
+          Build.path (Path.relative remaindir ".merlin") >>> real_requires
+        | _ -> real_requires
+      else
+        real_requires
+    in
+    (requires, real_requires)
+
   let dot_merlin ~dir ~requires ~alias_modules =
-    (* Only generate .merlin file in default context *)
+    if ctx.merlin then
-    match Path.extract_build_context dir with
+      match Path.extract_build_context dir with
-    | Some ("default", remaindir) ->
+      | Some (_, remaindir) ->
         let path = Path.relative remaindir ".merlin" in
         add_rule (
           requires
-          >>^ (fun libs_list ->
+          >>^ (fun libs ->
-            List.concat libs_list
+              let internals, externals =
-            |> List.partition_map ~f:(function
+                List.partition_map libs ~f:(function
-                | Lib.Internal (path, _) ->
+                  | Lib.Internal (path, _) ->
                     let path = Path.reach path ~from:remaindir in
                     Inl ("B " ^ path)
-                | Lib.External pkg ->
+                  | Lib.External pkg ->
-                    Inr ("PKG " ^ pkg.name)))
+                    Inr ("PKG " ^ pkg.name))
-          >>^ (fun (internals, externals) ->
+              in
-            let dot_merlin =
+              let dot_merlin =
-              [ "S ." ; "B " ^ (Path.reach dir ~from:remaindir) ]
+                [ "S ." ; "B " ^ (Path.reach dir ~from:remaindir) ]
-              @ internals
+                @ internals
-              @ externals
+                @ externals
-              @ (List.filter_map alias_modules ~f:(fun x ->
+                @ List.map alias_modules ~f:(fun (m : Module.t) ->
-                  Option.map x ~f:(fun (m : Module.t) ->
+                    "FLG -open " ^ m.name)
-                    "FLG -open " ^ m.name)))
+              in
-            in
-            let dot_merlin =
               dot_merlin
               |> String_set.of_list
               |> String_set.elements
-              |> List.sort ~cmp:String.compare
+              |> List.map ~f:(Printf.sprintf "%s\n")
-            in
+              |> String.concat ~sep:"")
-            String.concat ~sep:"\n" dot_merlin ^ "\n")
           >>>
           Build.echo path
         )
-    | _ ->
+      | _ ->
-      ()
+        ()
 
   let merge_dot_merlin merlin_deps ~dir =
-    merlin_deps
+    if ctx.merlin && merlin_deps <> [] then
-    |> List.fold_left ~init:None ~f:(fun acc (requires, alias_module) ->
+      let requires, alias_modules = List.split merlin_deps in
-        match acc with
+      let alias_modules = List.filter_map alias_modules ~f:(fun x -> x) in
-        | None -> let requires = requires >>^ (fun x -> [x]) in
+      let requires =
-          Some (requires, [alias_module])
+        Build.all requires
-        | Some (acc_requires, acc_alias_modules) ->
+        >>^ fun requires ->
-          let new_acc_requires =
+        Lib.remove_dups_preserve_order (List.concat requires)
-            let together = acc_requires &&& requires in
+      in
-            together
+      dot_merlin ~dir ~requires ~alias_modules
-            >>^ (fun (acc_requires, requires) ->
-            requires :: acc_requires)
-          in
-          let new_acc_alias_modules =
-            alias_module :: acc_alias_modules
-          in
-          Some (new_acc_requires, new_acc_alias_modules))
-    |> function
-      | Some (requires, alias_modules) ->
-        dot_merlin ~dir ~requires ~alias_modules
-      | None ->
-        ()
 
   let setup_runtime_deps ~dir ~dep_kind ~item ~libraries ~ppx_runtime_libraries =
     let vruntime_deps = Lib_db.vruntime_deps ~dir ~item in
@@ -1049,20 +1049,13 @@ module Gen(P : Params) = struct
             |> String.concat ~sep:"")
          >>> Build.echo (Path.relative dir m.ml_fname)));
 
-    let real_requires =
+    let requires, real_requires =
       requires ~dir ~dep_kind ~item:lib.name
         ~libraries:lib.buildable.libraries
         ~preprocess:lib.buildable.preprocess
         ~virtual_deps:lib.virtual_deps
     in
 
-    let requires = 
-      match Path.extract_build_context dir with
-      | Some ("default", remaindir) ->
-        Build.path (Path.relative remaindir ".merlin") >>> real_requires
-      | _ -> real_requires
-    in
-
     setup_runtime_deps ~dir ~dep_kind ~item:lib.name
       ~libraries:lib.buildable.libraries
       ~ppx_runtime_libraries:lib.ppx_runtime_libraries;
@@ -1217,21 +1210,13 @@ module Gen(P : Params) = struct
     let item = List.hd exes.names in
     let dep_graph = ocamldep_rules ~dir ~item ~modules ~alias_module:None in
 
-    let real_requires =
+    let requires, real_requires =
       requires ~dir ~dep_kind ~item
         ~libraries:exes.buildable.libraries
         ~preprocess:exes.buildable.preprocess
         ~virtual_deps:[]
     in
 
-    let requires =
-      match Path.extract_build_context dir with
-      | Some ("default", remaindir) ->
-        Build.path (Path.relative remaindir ".merlin") >>> real_requires
-      | _ ->
-        real_requires
-    in
-
     List.iter (Lib_db.select_rules ~dir exes.buildable.libraries) ~f:add_rule;
 
     build_modules ~flags ~dir ~dep_graph ~modules ~requires ~alias_module:None;

src/main.ml

@@ -22,13 +22,14 @@ let setup ?filter_out_optional_stanzas_with_missing_deps ?workspace () =
       if Sys.file_exists "jbuild-workspace" then
         Workspace.load "jbuild-workspace"
       else
-        [Default]
+        { merlin_context = Some "default"; contexts = [Default] }
   in
   Future.all
-    (List.map workspace ~f:(function
+    (List.map workspace.contexts ~f:(function
-     | Workspace.Context.Default -> Lazy.force Context.default
+     | Workspace.Context.Default ->
-     | Opam { name; switch; root } ->
+       Context.default ~merlin:(workspace.merlin_context = Some "default") ()
-       Context.create_for_opam ~name ~switch ?root ()))
+     | Opam { name; switch; root; merlin } ->
+       Context.create_for_opam ~name ~switch ?root ~merlin ()))
   >>= fun contexts ->
   Gen_rules.gen conf ~contexts
     ?filter_out_optional_stanzas_with_missing_deps
@@ -124,7 +125,8 @@ let bootstrap () =
       ]
       anon "Usage: boot.exe [-j JOBS] [--dev]\nOptions are:";
     Future.Scheduler.go ~log:(create_log ())
-      (setup ~workspace:[Default] () >>= fun { build_system = bs; _ } ->
+      (setup ~workspace:{ merlin_context = Some "default"; contexts = [Default] } ()
+       >>= fun { build_system = bs; _ } ->
        Build_system.do_build_exn bs [Path.(relative root) (pkg ^ ".install")])
   in
   try

src/workspace.ml

@@ -7,6 +7,7 @@ module Context = struct
       { name   : string
       ; switch : string
       ; root   : string option
+      ; merlin : bool
       }
 
     let t =
@@ -14,9 +15,11 @@ module Context = struct
         (field   "switch" string                 >>= fun switch ->
          field   "name"   string ~default:switch >>= fun name ->
          field_o "root"   string                 >>= fun root ->
+         field_b "merlin"                        >>= fun merlin ->
          return { switch
                 ; name
                 ; root
+                ; merlin
                 })
   end
 
@@ -31,25 +34,47 @@ module Context = struct
     | Opam o  -> o.name
 end
 
-type t = Context.t list
+type t =
+  { merlin_context : string option
+  ; contexts       : Context.t list
+  }
 
 let t sexps =
-  List.fold_left sexps ~init:[] ~f:(fun acc sexp ->
+  let merlin_ctx, contexts =
-    let ctx =
+    List.fold_left sexps ~init:(None, []) ~f:(fun (merlin_ctx, ctxs) sexp ->
-      sum
+      let ctx =
-        [ cstr "context" [Context.t] (fun x -> x) ]
+        sum
-        sexp
+          [ cstr "context" [Context.t] (fun x -> x) ]
-    in
+          sexp
-    let name = Context.name ctx in
+      in
-    if name = "" ||
+      let name = Context.name ctx in
-       String.is_prefix name ~prefix:"." ||
+      if name = "" ||
-       name = "log" ||
+         String.is_prefix name ~prefix:"." ||
-       String.contains name '/' ||
+         name = "log" ||
-       String.contains name '\\' then
+         String.contains name '/' ||
-      of_sexp_errorf sexp "%S is not allowed as a build context name" name;
+         String.contains name '\\' then
-    if List.exists acc ~f:(fun c -> Context.name c = name) then
+        of_sexp_errorf sexp "%S is not allowed as a build context name" name;
-      of_sexp_errorf sexp "second definition of build context %S" name;
+      if List.exists ctxs ~f:(fun c -> Context.name c = name) then
-    ctx :: acc)
+        of_sexp_errorf sexp "second definition of build context %S" name;
-  |> List.rev
+      match ctx, merlin_ctx with
+      | Opam { merlin = true; _ }, Some _ ->
+        of_sexp_errorf sexp "you can only have one context for merlin"
+      | Opam { merlin = true; _ }, None ->
+        (Some name, ctx :: ctxs)
+      | _ ->
+        (merlin_ctx, ctx :: ctxs))
+  in
+  let merlin_ctx =
+    match merlin_ctx with
+    | Some _ -> merlin_ctx
+    | None ->
+      if List.mem Context.Default ~set:contexts then
+        Some "default"
+      else
+        None
+  in
+  { merlin_context = merlin_ctx
+  ; contexts       = List.rev contexts
+  }
 
 let load fn = t (Sexp_load.many fn)

src/workspace.mli

@@ -8,12 +8,16 @@ module Context : sig
       { name   : string
       ; switch : string
       ; root   : string option
+      ; merlin : bool
       }
   end
 
   type t = Default | Opam of Opam.t
 end
 
-type t = Context.t list
+type t =
+  { merlin_context : string option
+  ; contexts       : Context.t list
+  }
 
 val load : string -> t