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

CHANGES.md

@@ -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)
 ------------------
 

bin/installed_libraries.ml

@@ -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

doc/usage.rst

@@ -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.

src/context.ml

@@ -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; _ } ->
@@ -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 =
@@ -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
@@ -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
@@ -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
 

src/workspace.ml

@@ -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
       }
@@ -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
@@ -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",
@@ -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
@@ -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
       }
@@ -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
@@ -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
   }
 

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
@@ -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