host context resolution: topological sort to ensure no duplication an…

…d error on bad configurations.

and tests.

Signed-off-by: Lucas Pluvinage <lucas.pluvinage@gmail.com>

CHANGES.md

@@ -43,6 +43,10 @@ unreleased
 - Install the `future_syntax` preprocessor as `ocaml-syntax-shims.exe` (#2125,
   @rgrinberg)
 
+- 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 and @aalekseyev)
+
 1.9.2 (02/05/2019)
 ------------------
 

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

@@ -506,11 +506,11 @@ let create ~(kind : Kind.t) ~path ~env ~env_nodes ~name ~merlin ~targets ~host_c
         set t.ocamlmklib;
       end;
     end;
-    Fiber.return (host_context, t)
+    Fiber.return t
   in
   let implicit = not (List.mem ~set:targets Workspace.Context.Target.Native) in
-  let* (nat_host, native) =
-    create_one ~host:None ~findlib_toolchain:host_toolchain
+  let* native =
+    create_one ~host:host_context ~findlib_toolchain:host_toolchain
       ~implicit ~name ~merlin
   in
   let+ others =
@@ -522,7 +522,7 @@ let create ~(kind : Kind.t) ~path ~env ~env_nodes ~name ~merlin ~targets ~host_c
           ~findlib_toolchain:(Some findlib_toolchain)
         >>| Option.some)
   in
-  (nat_host, native) :: List.filter_opt others
+  native :: List.filter_opt others
 
 let opam_config_var t var =
   opam_config_var ~env:t.env ~cache:t.opam_var_cache var
@@ -600,49 +600,118 @@ let create_for_opam ~root ~env ~env_nodes ~targets ~profile
   create ~kind:(Opam { root; switch }) ~profile ~targets ~path ~env ~env_nodes
     ~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 bad_configuration_check map =
+  let get_host_context = function
+    | Workspace.Context.Default { host_context; _ }
+    | Workspace.Context.Opam { base={host_context; _}; _} -> host_context
+  in
+  let get_loc = function
+    | Workspace.Context.Default { loc; _ }
+    | Workspace.Context.Opam { base={loc; _}; _} -> loc
+  in
+  let check elt = match get_host_context elt with
+    | None -> ()
+    | Some host ->
+      (let host_elt = String.Map.find_exn map host in
+       match get_host_context host_elt with
+       | None -> ()
+       | Some host_of_host ->
+         Errors.fail
+           (get_loc host_elt)
+           "Context '%s' is both a host (for '%s') and a target (for '%s')."
+           host
+           (Workspace.Context.name elt)
+           host_of_host
+      )
+  in
+  String.Map.iter
+    map
+    ~f:check
+
+let top_sort contexts =
+  let key = Workspace.Context.name
+  in
+  let map =
+    String.Map.of_list_map_exn
+      contexts
+      ~f:(fun x -> key x, x)
+  in
+  let deps def =
+    let open Workspace.Context in
+    match def with
+    | Default { host_context=(Some ctx); loc; name; _}
+    | Opam { base={host_context=(Some ctx); loc; name; _}; _} ->
+      (match String.Map.find map ctx with
+       | None ->
+         Errors.fail
+           loc
+           "Undefined host context '%s' for '%s'."
+           ctx
+           name
+       | Some host_ctx -> [host_ctx])
+    | _ -> []
+  in
+  bad_configuration_check map;
+  match Top_closure.String.top_closure ~key ~deps contexts with
+  | Ok top_contexts -> top_contexts
+  | Error _ -> assert false
 
 let create ~env (workspace : Workspace.t) =
+  let open Workspace.Context in
   let env_nodes context =
     { Env_nodes.
       context
     ; workspace = workspace.env
     }
   in
-  Fiber.parallel_map workspace.contexts ~f:(fun def ->
-    match def with
-    | Default { targets; name; host_context; 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
+  let contexts = top_sort workspace.contexts
+  in
+  List.fold_left
+    contexts
+    ~f:(fun acc def ->
+      acc >>= fun (ctx_map, contexts) ->
+      (match def with
+       | Default { targets; name; host_context; profile; env = env_node ;
+                   toolchain ; _ } ->
+         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
+         let host_context =
+           Option.map
+             host_context
+             ~f:(fun ctx -> String.Map.find_exn ctx_map ctx)
+         in
+         default ~env ~env_nodes:(env_nodes env_node) ~profile ~targets ~name
+           ~merlin ~host_context ~host_toolchain
+       | Opam { base = { targets; name; host_context; profile; env = env_node;
+                         toolchain; _ }
+              ; switch; root; merlin } ->
+         let host_context =
+           Option.map
+             host_context
+             ~f:(fun ctx -> String.Map.find_exn ctx_map ctx)
+         in
+         create_for_opam ~root ~env_nodes:(env_nodes env_node) ~env ~profile
+           ~switch ~name ~merlin ~targets ~host_context
+           ~host_toolchain:toolchain)
+      >>| fun new_contexts ->
+      let updated_map =
+        List.fold_left
+          new_contexts
+          ~f:(fun map elem -> String.Map.add map elem.name elem)
+          ~init:ctx_map
       in
-      (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
+      (updated_map, new_contexts @ contexts)
+    )
+    ~init:(Fiber.return (String.Map.empty, []))
+  >>| fun (_, contexts) -> contexts
+
+
 
 let which t s = which ~cache:t.which_cache ~path:t.path s
 

test/blackbox-tests/dune.inc

@@ -127,6 +127,14 @@
    test-cases/custom-build-dir
    (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected)))))
 
+(alias
+ (name custom-cross-compilation)
+ (deps (package dune) (source_tree test-cases/custom-cross-compilation))
+ (action
+  (chdir
+   test-cases/custom-cross-compilation
+   (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected)))))
+
 (alias
  (name cxx-extension)
  (deps (package dune) (source_tree test-cases/cxx-extension))
@@ -1468,6 +1476,7 @@
   (alias copy_files)
   (alias cross-compilation)
   (alias custom-build-dir)
+  (alias custom-cross-compilation)
   (alias cxx-extension)
   (alias default-targets)
   (alias dep-on-dir-that-does-not-exist)
@@ -1645,6 +1654,7 @@
   (alias copy-files-non-sub-dir-error)
   (alias copy_files)
   (alias custom-build-dir)
+  (alias custom-cross-compilation)
   (alias cxx-extension)
   (alias default-targets)
   (alias dep-on-dir-that-does-not-exist)

test/blackbox-tests/test-cases/custom-cross-compilation/bad-configuration/dune

@@ -0,0 +1,6 @@
+(executable
+ (name p)
+ (public_name p)
+)
+
+(rule (with-stdout-to file (run ./p.exe)))

test/blackbox-tests/test-cases/custom-cross-compilation/bad-configuration/dune-project

@@ -0,0 +1 @@
+(lang dune 1.10)

test/blackbox-tests/test-cases/custom-cross-compilation/bad-configuration/dune-workspace

@@ -0,0 +1,10 @@
+(lang dune 1.10)
+(context (default))
+(context (default
+  (name cross-1)
+  (host default)
+))
+(context (default
+  (name cross-2)
+  (host cross-1)
+))

test/blackbox-tests/test-cases/custom-cross-compilation/bad-configuration/p.ml

@@ -0,0 +1 @@
+let () = Printf.printf "%d\n" 137

test/blackbox-tests/test-cases/custom-cross-compilation/normal/dune

@@ -0,0 +1,6 @@
+(executable
+ (name p)
+ (public_name p)
+)
+
+(rule (with-stdout-to file (run ./p.exe)))

test/blackbox-tests/test-cases/custom-cross-compilation/normal/dune-project

@@ -0,0 +1 @@
+(lang dune 1.10)

test/blackbox-tests/test-cases/custom-cross-compilation/normal/dune-workspace

@@ -0,0 +1,6 @@
+(lang dune 1.10)
+(context (default))
+(context (default
+  (name cross)
+  (host default)
+))

test/blackbox-tests/test-cases/custom-cross-compilation/normal/p.ml

@@ -0,0 +1 @@
+let () = Printf.printf "%d\n" 137

test/blackbox-tests/test-cases/custom-cross-compilation/run.t

@@ -0,0 +1,35 @@
+  $ dune build --root ./normal --display short file @install
+  Entering directory 'normal'
+      ocamldep .p.eobjs/p.ml.d [cross]
+        ocamlc .p.eobjs/byte/p.{cmi,cmo,cmt} [cross]
+      ocamlopt .p.eobjs/native/p.{cmx,o} [cross]
+      ocamlopt p.exe [cross]
+      ocamldep .p.eobjs/p.ml.d
+        ocamlc .p.eobjs/byte/p.{cmi,cmo,cmt}
+      ocamlopt .p.eobjs/native/p.{cmx,o}
+      ocamlopt p.exe
+             p file [cross]
+             p file
+
+  $ cat normal/_build/cross/file
+  137
+
+  $ dune build --root ./bad-configuration --display short file @install
+  Entering directory 'bad-configuration'
+  File "dune-workspace", line 3, characters 9-53:
+  3 | (context (default
+  4 |   (name cross-1)
+  5 |   (host default)
+  6 | ))
+  Error: Context 'cross-1' is both a host (for 'cross-2') and a target (for 'default').
+  [1]
+
+  $ dune build --root ./topological-loop --display short file @install
+  Entering directory 'topological-loop'
+  File "dune-workspace", line 11, characters 9-53:
+  11 | (context (default
+  12 |   (name cross-3)
+  13 |   (host cross-2)
+  14 | ))
+  Error: Context 'cross-3' is both a host (for 'cross-1') and a target (for 'cross-2').
+  [1]

test/blackbox-tests/test-cases/custom-cross-compilation/topological-loop/dune

@@ -0,0 +1,6 @@
+(executable
+ (name p)
+ (public_name p)
+)
+
+(rule (with-stdout-to file (run ./p.exe)))

test/blackbox-tests/test-cases/custom-cross-compilation/topological-loop/dune-project

@@ -0,0 +1 @@
+(lang dune 1.10)

test/blackbox-tests/test-cases/custom-cross-compilation/topological-loop/dune-workspace

@@ -0,0 +1,14 @@
+(lang dune 1.10)
+(context (default))
+(context (default
+  (name cross-1)
+  (host cross-3)
+))
+(context (default
+  (name cross-2)
+  (host cross-1)
+))
+(context (default
+  (name cross-3)
+  (host cross-2)
+))

test/blackbox-tests/test-cases/custom-cross-compilation/topological-loop/p.ml

@@ -0,0 +1 @@
+let () = Printf.printf "%d\n" 137