From 304d7becbc08fd0b90ef09a449eb755a77970538 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9mie=20Dimino?= Date: Sun, 26 Feb 2017 20:53:32 +0000 Subject: [PATCH] Allow to specify which context for merlin --- bin/main.ml | 2 +- src/context.ml | 12 ++--- src/context.mli | 6 ++- src/gen_rules.ml | 111 ++++++++++++++++++++-------------------------- src/main.ml | 14 +++--- src/workspace.ml | 61 +++++++++++++++++-------- src/workspace.mli | 6 ++- 7 files changed, 117 insertions(+), 95 deletions(-) diff --git a/bin/main.ml b/bin/main.ml index 94802386..09b55ca5 100644 --- a/bin/main.ml +++ b/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 diff --git a/src/context.ml b/src/context.ml index 9e4a59fe..6836bb64 100644 --- a/src/context.ml +++ b/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 diff --git a/src/context.mli b/src/context.mli index 96d3b349..3dcc3ffd 100644 --- a/src/context.mli +++ b/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 diff --git a/src/gen_rules.ml b/src/gen_rules.ml index 4ad02f7c..77e9e5a8 100644 --- a/src/gen_rules.ml +++ b/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 *) - match Path.extract_build_context dir with - | Some ("default", remaindir) -> + if ctx.merlin then + match Path.extract_build_context dir with + | Some (_, remaindir) -> let path = Path.relative remaindir ".merlin" in add_rule ( requires - >>^ (fun libs_list -> - List.concat libs_list - |> List.partition_map ~f:(function - | Lib.Internal (path, _) -> + >>^ (fun libs -> + let internals, externals = + List.partition_map libs ~f:(function + | Lib.Internal (path, _) -> let path = Path.reach path ~from:remaindir in Inl ("B " ^ path) - | Lib.External pkg -> - Inr ("PKG " ^ pkg.name))) - >>^ (fun (internals, externals) -> - let dot_merlin = - [ "S ." ; "B " ^ (Path.reach dir ~from:remaindir) ] - @ internals - @ externals - @ (List.filter_map alias_modules ~f:(fun x -> - Option.map x ~f:(fun (m : Module.t) -> - "FLG -open " ^ m.name))) - in - let dot_merlin = + | Lib.External pkg -> + Inr ("PKG " ^ pkg.name)) + in + let dot_merlin = + [ "S ." ; "B " ^ (Path.reach dir ~from:remaindir) ] + @ internals + @ externals + @ List.map alias_modules ~f:(fun (m : Module.t) -> + "FLG -open " ^ m.name) + in dot_merlin |> String_set.of_list |> String_set.elements - |> List.sort ~cmp:String.compare - in - String.concat ~sep:"\n" dot_merlin ^ "\n") + |> List.map ~f:(Printf.sprintf "%s\n") + |> String.concat ~sep:"") >>> Build.echo path ) - | _ -> - () + | _ -> + () let merge_dot_merlin merlin_deps ~dir = - merlin_deps - |> List.fold_left ~init:None ~f:(fun acc (requires, alias_module) -> - match acc with - | None -> let requires = requires >>^ (fun x -> [x]) in - Some (requires, [alias_module]) - | Some (acc_requires, acc_alias_modules) -> - let new_acc_requires = - let together = acc_requires &&& requires in - together - >>^ (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 -> - () + if ctx.merlin && merlin_deps <> [] then + let requires, alias_modules = List.split merlin_deps in + let alias_modules = List.filter_map alias_modules ~f:(fun x -> x) in + let requires = + Build.all requires + >>^ fun requires -> + Lib.remove_dups_preserve_order (List.concat requires) + in + dot_merlin ~dir ~requires ~alias_modules 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; diff --git a/src/main.ml b/src/main.ml index cb6eacb0..fa273b0a 100644 --- a/src/main.ml +++ b/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 - | Workspace.Context.Default -> Lazy.force Context.default - | Opam { name; switch; root } -> - Context.create_for_opam ~name ~switch ?root ())) + (List.map workspace.contexts ~f:(function + | Workspace.Context.Default -> + Context.default ~merlin:(workspace.merlin_context = Some "default") () + | 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 diff --git a/src/workspace.ml b/src/workspace.ml index 5703fb19..0fd8bac1 100644 --- a/src/workspace.ml +++ b/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 ctx = - sum - [ cstr "context" [Context.t] (fun x -> x) ] - sexp - in - let name = Context.name ctx in - if name = "" || - String.is_prefix name ~prefix:"." || - name = "log" || - String.contains name '/' || - String.contains name '\\' then - of_sexp_errorf sexp "%S is not allowed as a build context name" name; - if List.exists acc ~f:(fun c -> Context.name c = name) then - of_sexp_errorf sexp "second definition of build context %S" name; - ctx :: acc) - |> List.rev + let merlin_ctx, contexts = + List.fold_left sexps ~init:(None, []) ~f:(fun (merlin_ctx, ctxs) sexp -> + let ctx = + sum + [ cstr "context" [Context.t] (fun x -> x) ] + sexp + in + let name = Context.name ctx in + if name = "" || + String.is_prefix name ~prefix:"." || + name = "log" || + String.contains name '/' || + String.contains name '\\' then + of_sexp_errorf sexp "%S is not allowed as a build context name" name; + if List.exists ctxs ~f:(fun c -> Context.name c = name) then + of_sexp_errorf sexp "second definition of build context %S" name; + 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) diff --git a/src/workspace.mli b/src/workspace.mli index 316b68f3..750a8952 100644 --- a/src/workspace.mli +++ b/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