Skip to content

Commit

Permalink
Add the ability to choose the host context and create duplicates of t…
Browse files Browse the repository at this point in the history 
…he default context with different settings (#2098)

Add the ability to choose the host context and create duplicates of the default context with different settings

Co-authored-by: Jérémie Dimino <jeremie@dimino.org>
Co-authored-by: Rudi Grinberg <rudi.grinberg@gmail.com>
  • Loading branch information
@rgrinberg @jeremiedimino
rgrinberg and jeremiedimino committed May 8, 2019
2 parents 30d2400 + 5dc27f9 commit da6108f
Show file tree
Hide file tree
Showing 35 changed files with 307 additions and 61 deletions.
4 changes: 4 additions & 0 deletions CHANGES.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -49,6 +49,10 @@ unreleased
`--always-show-command-line` option to disable this behavior and always show
the full command.

- In `dune-workspace` files, add the ability to choose the host context and to
create duplicates of the default context with different settings. (#2098,
@TheLortex, review by @diml, @rgrinberg and @aalekseyev)

1.9.2 (02/05/2019)
------------------

Expand Down
13 changes: 1 addition & 12 deletions bin/installed_libraries.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -17,18 +17,7 @@ let term =
let env = Import.Main.setup_env ~capture_outputs:common.capture_outputs in
Scheduler.go ~log:(Log.create common) ~common (fun () ->
let open Fiber.O in
let* ctxs =
Context.create ~env
{ merlin_context = Some "default"
; contexts = [Default { loc = Loc.of_pos __POS__
; targets = [Native]
; profile = Config.default_build_profile
; env = None
; toolchain = None
}]
; env = None
}
in
let* ctxs = Context.create ~env (Workspace.default ()) in
let ctx = List.hd ctxs in
let findlib = ctx.findlib in
if na then begin
Expand Down
3 changes: 3 additions & 0 deletions doc/usage.rst
View file
Original file line number Diff line number Diff line change
Expand Up @@ -528,6 +528,9 @@ context or can be the description of an opam switch, as follows:

- ``(toolchain <findlib_coolchain>)`` set findlib toolchain for the context.

- ``(host <host_context>)`` choose a different context to build binaries that
are meant to be executed on the host machine, such as preprocessors.

Both ``(default ...)`` and ``(opam ...)`` accept a ``targets`` field in order to
setup cross compilation. See :ref:`advanced-cross-compilation` for more
information.
Expand Down
82 changes: 55 additions & 27 deletions src/context.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -209,7 +209,7 @@ let ocamlfind_printconf_path ~env ~ocamlfind ~toolchain =
List.map l ~f:Path.of_filename_relative_to_initial_cwd

let create ~(kind : Kind.t) ~path ~env ~env_nodes ~name ~merlin ~targets
~host_toolchain ~profile =
~host_context ~host_toolchain ~profile =
let opam_var_cache = Hashtbl.create 128 in
(match kind with
| Opam { root = Some root; _ } ->
Expand Down Expand Up @@ -508,10 +508,9 @@ let create ~(kind : Kind.t) ~path ~env ~env_nodes ~name ~merlin ~targets
end;
Fiber.return t
in

let implicit = not (List.mem ~set:targets Workspace.Context.Target.Native) in
let* native =
create_one ~host:None ~findlib_toolchain:host_toolchain
create_one ~host:host_context ~findlib_toolchain:host_toolchain
~implicit ~name ~merlin
in
let+ others =
Expand All @@ -530,8 +529,7 @@ let opam_config_var t var =

let default ~merlin ~env_nodes ~env ~targets =
let path = Env.path Env.initial in
create ~kind:Default ~path ~env ~env_nodes ~name:"default"
~merlin ~targets
create ~kind:Default ~path ~env ~env_nodes ~merlin ~targets

let opam_version =
let res = ref None in
Expand All @@ -555,7 +553,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
Expand Down Expand Up @@ -599,33 +597,63 @@ 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 create ~env (workspace : Workspace.t) =
let env_nodes context =
let instantiate_context env (workspace : Workspace.t)
~(context : Workspace.Context.t) ~host_context =
let env_nodes =
let context = Workspace.Context.env context in
{ Env_nodes.
context
; workspace = workspace.env
}
in
Fiber.parallel_map workspace.contexts ~f:(fun def ->
match def with
| Default { targets; profile; env = env_node ; toolchain ; loc = _ } ->
let merlin =
workspace.merlin_context = Some (Workspace.Context.name def)
in
let host_toolchain =
match toolchain, Env.get env "OCAMLFIND_TOOLCHAIN" with
| 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)
>>| List.concat
match context with
| Default { targets; name; host_context = _; profile; env = _
; toolchain ; loc = _ } ->
let merlin =
workspace.merlin_context = Some (Workspace.Context.name context)
in
let host_toolchain =
match toolchain with
| Some _ -> toolchain
| None -> Env.get env "OCAMLFIND_TOOLCHAIN"
in
default ~env ~env_nodes ~profile ~targets ~name ~merlin ~host_context
~host_toolchain
| Opam { base = { targets; name; host_context = _; profile; env = _
; toolchain; loc = _ }
; switch; root; merlin } ->
create_for_opam ~root ~env_nodes ~env ~profile ~switch ~name ~merlin
~targets ~host_context ~host_toolchain:toolchain

let create ~env (workspace : Workspace.t) =
let rec contexts : t list Fiber.Once.t String.Map.t Lazy.t = lazy (
List.map workspace.contexts ~f:(fun context ->
let contexts = Fiber.Once.create (fun () ->
let* host_context =
match Workspace.Context.host_context context with
| None -> Fiber.return None
| Some context ->
let+ contexts =
String.Map.find_exn (Lazy.force contexts) context
|> Fiber.Once.get
in
match contexts with
| [x] -> Some x
| [] -> assert false (* checked by workspace *)
| _ :: _ -> assert false (* target cannot be host *)
in
instantiate_context env workspace ~context ~host_context
) in
let name = Workspace.Context.name context in
(name, contexts))
|> String.Map.of_list_exn
) in
Lazy.force contexts
|> String.Map.values
|> Fiber.parallel_map ~f:Fiber.Once.get
|> Fiber.map ~f:List.concat

let which t s = which ~cache:t.which_cache ~path:t.path s

Expand Down
95 changes: 80 additions & 15 deletions src/workspace.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -47,50 +47,60 @@ 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) >>> string)
and+ toolchain =
field_o "toolchain" (Syntax.since syntax (1, 5) >>> string)
and+ loc = loc
in
Option.iter
host_context
~f:(fun _ -> match targets with
| [Target.Native] -> ()
| _ -> (Errors.fail loc "`targets` and `host` options cannot be used in the same context.")
);
{ targets
; profile
; loc
; env
; name = "default"
; host_context
; toolchain
}
end

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
}
Expand All @@ -100,8 +110,12 @@ 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
Expand All @@ -110,6 +124,10 @@ module Context = struct
| Default x -> x.loc
| Opam x -> x.base.loc

let host_context = function
| Default { host_context; _ }
| Opam { base = { host_context ; _}; _} -> host_context

let t ~profile ~x =
sum
[ "default",
Expand All @@ -130,9 +148,13 @@ module Context = struct
| _ -> t ~profile ~x)
~dune:(t ~profile ~x)

let env = function
| Default d -> d.env
| Opam o -> o.base.env

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
Expand All @@ -150,6 +172,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
}
Expand All @@ -164,6 +188,47 @@ type t =
include Versioned_file.Make(struct type t = unit end)
let () = Lang.register syntax ()

let bad_configuration_check map =
let find_exn loc name host =
match String.Map.find map host with
| Some host_ctx -> host_ctx
| None ->
Errors.fail
loc
"Undefined host context '%s' for '%s'."
host
name
in
let check elt =
Context.host_context elt
|> Option.iter ~f:(fun host ->
let name = Context.name elt in
let loc = Context.loc elt in
let host_elt = find_exn loc name host in
Context.host_context host_elt
|> Option.iter ~f:(fun host_of_host ->
Errors.fail
(Context.loc host_elt)
"Context '%s' is both a host (for '%s') and a target (for '%s')."
host
name
host_of_host))
in
String.Map.iter map ~f:check

let top_sort contexts =
let key = Context.name in
let map = String.Map.of_list_map_exn contexts ~f:(fun x -> key x, x) in
let deps def =
match Context.host_context def with
| None -> []
| Some ctx -> [String.Map.find_exn map ctx]
in
bad_configuration_check map;
match Top_closure.String.top_closure ~key ~deps contexts with
| Ok topo_contexts -> topo_contexts
| Error _ -> assert false

let t ?x ?profile:cmdline_profile () =
let* () = Versioned_file.no_more_lang in
let* env = env_field in
Expand Down Expand Up @@ -205,7 +270,7 @@ let t ?x ?profile:cmdline_profile () =
None
in
{ merlin_context
; contexts = List.rev contexts
; contexts = top_sort (List.rev contexts)
; env
}

Expand Down
24 changes: 17 additions & 7 deletions src/workspace.mli
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -34,10 +35,19 @@ module Context : sig

type t = Default of Default.t | Opam of Opam.t

val loc : t -> Loc.t

val name : t -> string

val env : t -> Dune_env.Stanza.t option

val host_context : t -> string option
end

type t =
(** Representation of a workspace. The list of context is
topologically sorted, i.e. a context always comes before the
contexts where it is used as host context. *)
type t = private
{ merlin_context : string option
; contexts : Context.t list
; env : Dune_env.Stanza.t option
Expand Down
Loading

0 comments on commit da6108f

Please sign in to comment.