From 562404e256aef48d832ceea565c726683316730f Mon Sep 17 00:00:00 2001 From: Lucas Pluvinage Date: Sat, 13 Apr 2019 16:04:44 +0200 Subject: [PATCH] Add the ability to choose the host context. Also allows to use (default) with different names Signed-off-by: Lucas Pluvinage --- bin/installed_libraries.ml | 2 ++ src/context.ml | 47 ++++++++++++++++++++++++++------------ src/workspace.ml | 37 ++++++++++++++++++------------ src/workspace.mli | 13 ++++++----- 4 files changed, 64 insertions(+), 35 deletions(-) diff --git a/bin/installed_libraries.ml b/bin/installed_libraries.ml index 2d28e48d4989..c9acec65e91f 100644 --- a/bin/installed_libraries.ml +++ b/bin/installed_libraries.ml @@ -22,6 +22,8 @@ let term = { merlin_context = Some "default" ; contexts = [Default { loc = Loc.of_pos __POS__ ; targets = [Native] + ; name = "default" + ; host_context = None ; profile = Config.default_build_profile ; env = None ; toolchain = None diff --git a/src/context.ml b/src/context.ml index 562dccc62f62..d9736b4cf940 100644 --- a/src/context.ml +++ b/src/context.ml @@ -208,7 +208,7 @@ let ocamlfind_printconf_path ~env ~ocamlfind ~toolchain = let+ l = Process.run_capture_lines ~env Strict ocamlfind args in List.map l ~f:Path.of_filename_relative_to_initial_cwd -let create ~(kind : Kind.t) ~path ~env ~env_nodes ~name ~merlin ~targets +let create ~(kind : Kind.t) ~path ~env ~env_nodes ~name ~merlin ~targets ~host_context ~host_toolchain ~profile = let opam_var_cache = Hashtbl.create 128 in (match kind with @@ -506,11 +506,10 @@ let create ~(kind : Kind.t) ~path ~env ~env_nodes ~name ~merlin ~targets set t.ocamlmklib; end; end; - Fiber.return t + Fiber.return (host_context, t) in - let implicit = not (List.mem ~set:targets Workspace.Context.Target.Native) in - let* native = + let* (nat_host, native) = create_one ~host:None ~findlib_toolchain:host_toolchain ~implicit ~name ~merlin in @@ -523,14 +522,14 @@ let create ~(kind : Kind.t) ~path ~env ~env_nodes ~name ~merlin ~targets ~findlib_toolchain:(Some findlib_toolchain) >>| Option.some) in - native :: List.filter_opt others + (nat_host, native) :: List.filter_opt others let opam_config_var t var = opam_config_var ~env:t.env ~cache:t.opam_var_cache var let default ~merlin ~env_nodes ~env ~targets = let path = Env.path Env.initial in - create ~kind:Default ~path ~env ~env_nodes ~name:"default" + create ~kind:Default ~path ~env ~env_nodes ~merlin ~targets let opam_version = @@ -555,7 +554,7 @@ let opam_version = Fiber.Future.wait future let create_for_opam ~root ~env ~env_nodes ~targets ~profile - ~switch ~name ~merlin ~host_toolchain = + ~switch ~name ~merlin ~host_context ~host_toolchain = let opam = match Lazy.force opam with | None -> Utils.program_not_found "opam" ~loc:None @@ -599,7 +598,22 @@ let create_for_opam ~root ~env ~env_nodes ~targets ~profile in let env = Env.extend env ~vars in create ~kind:(Opam { root; switch }) ~profile ~targets ~path ~env ~env_nodes - ~name ~merlin ~host_toolchain + ~name ~merlin ~host_context ~host_toolchain + +let resolve_host_contexts contexts = + let empty = String.Map.empty in + let map = List.fold_left + ~f:(fun map (_,(_,elem)) -> String.Map.add map elem.name elem) + ~init:empty + contexts in + List.map ~f:(fun (loc, (host, elem)) -> match host with + | None -> elem + | Some host -> ( + match String.Map.find map host with + | None -> Errors.fail loc "Undefined host context '%s' for '%s'." host elem.name + | Some ctx -> {elem with for_host=(Some ctx)} + )) + contexts let create ~env (workspace : Workspace.t) = let env_nodes context = @@ -610,7 +624,7 @@ let create ~env (workspace : Workspace.t) = in Fiber.parallel_map workspace.contexts ~f:(fun def -> match def with - | Default { targets; profile; env = env_node ; toolchain ; loc = _ } -> + | Default { targets; name; host_context; profile; env = env_node ; toolchain ; loc } -> let merlin = workspace.merlin_context = Some (Workspace.Context.name def) in @@ -619,13 +633,16 @@ let create ~env (workspace : Workspace.t) = | Some t, _ -> Some t | None, default -> default in - default ~env ~env_nodes:(env_nodes env_node) ~profile ~targets ~merlin - ~host_toolchain - | Opam { base = { targets; profile; env = env_node; toolchain; loc = _ } - ; name; switch; root; merlin } -> - create_for_opam ~root ~env_nodes:(env_nodes env_node) ~env ~profile - ~switch ~name ~merlin ~targets ~host_toolchain:toolchain) + (default ~env ~env_nodes:(env_nodes env_node) ~profile ~targets ~name ~merlin + ~host_context ~host_toolchain + >>| fun x -> List.map ~f:(fun x -> (loc,x)) x) + | Opam { base = { targets; name; host_context; profile; env = env_node; toolchain; loc } + ; switch; root; merlin } -> + (create_for_opam ~root ~env_nodes:(env_nodes env_node) ~env ~profile + ~switch ~name ~merlin ~targets ~host_context ~host_toolchain:toolchain) + >>| fun x -> List.map ~f:(fun x -> (loc,x)) x) >>| List.concat + >>| resolve_host_contexts let which t s = which ~cache:t.which_cache ~path:t.path s diff --git a/src/workspace.ml b/src/workspace.ml index 61286f8ea87e..739ff005e710 100644 --- a/src/workspace.ml +++ b/src/workspace.ml @@ -47,17 +47,21 @@ module Context = struct module Common = struct type t = - { loc : Loc.t - ; profile : string - ; targets : Target.t list - ; env : Dune_env.Stanza.t option - ; toolchain : string option + { loc : Loc.t + ; profile : string + ; targets : Target.t list + ; env : Dune_env.Stanza.t option + ; toolchain : string option + ; name : string + ; host_context : string option } let t ~profile = let+ env = env_field and+ targets = field "targets" (list Target.t) ~default:[Target.Native] and+ profile = field "profile" string ~default:profile + and+ host_context = + field_o "host" (Syntax.since syntax (1, 10) >>= fun () -> string) and+ toolchain = field_o "toolchain" (Syntax.since syntax (1, 5) >>> string) and+ loc = loc @@ -66,6 +70,8 @@ module Context = struct ; profile ; loc ; env + ; name = "default" + ; host_context ; toolchain } end @@ -73,24 +79,22 @@ module Context = struct module Opam = struct type t = { base : Common.t - ; name : string ; switch : string ; root : string option ; merlin : bool } let t ~profile ~x = - let+ base = Common.t ~profile - and+ switch = field "switch" string + let+ switch = field "switch" string and+ name = field_o "name" Name.t and+ root = field_o "root" string and+ merlin = field_b "merlin" + and+ base = Common.t ~profile in let name = Option.value ~default:switch name in - let base = { base with targets = Target.add base.targets x } in + let base = { base with targets = Target.add base.targets x; name } in { base ; switch - ; name ; root ; merlin } @@ -100,8 +104,11 @@ module Context = struct type t = Common.t let t ~profile ~x = - Common.t ~profile >>| fun t -> - { t with targets = Target.add t.targets x } + let+ common = Common.t ~profile + and+ name = field_o "name" (Syntax.since syntax (1, 10) >>= fun () -> Name.t) + in + let name = Option.value ~default:common.name name in + { common with targets = Target.add common.targets x; name } end type t = Default of Default.t | Opam of Opam.t @@ -131,8 +138,8 @@ module Context = struct ~dune:(t ~profile ~x) let name = function - | Default _ -> "default" - | Opam o -> o.name + | Default d -> d.name + | Opam o -> o.base.name let targets = function | Default x -> x.targets @@ -150,6 +157,8 @@ module Context = struct ; targets = [Option.value x ~default:Target.Native] ; profile = Option.value profile ~default:Config.default_build_profile + ; name = "default" + ; host_context = None ; env = None ; toolchain = None } diff --git a/src/workspace.mli b/src/workspace.mli index aabd6b6b0560..d0c3f7777c79 100644 --- a/src/workspace.mli +++ b/src/workspace.mli @@ -11,17 +11,18 @@ module Context : sig end module Common : sig type t = - { loc : Loc.t - ; profile : string - ; targets : Target.t list - ; env : Dune_env.Stanza.t option - ; toolchain : string option + { loc : Loc.t + ; profile : string + ; targets : Target.t list + ; env : Dune_env.Stanza.t option + ; toolchain : string option + ; name : string + ; host_context : string option } end module Opam : sig type t = { base : Common.t - ; name : string ; switch : string ; root : string option ; merlin : bool