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

@@ -40,6 +40,10 @@ unreleased
 
 - Fix `.install` files not being generated (#2124, fixes #2123, @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

@@ -600,20 +600,79 @@ 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
 
+(* Enforces that a context cannot be both a host and a target context.*)
+let look_for_bad_configurations contexts =
+  let map =
+    String.Map.of_list_map_exn
+      contexts
+      ~f:(fun ((_, (_, c)) as elt) -> (c.name, elt))
+  in
+  let check (_, (host, elt)) =
+    match host with
+    | None -> ()
+    | Some host ->
+      (match String.Map.find_exn map host with
+       | _,(None, _) -> ()
+       | loc, ((Some host_of_host),_) ->
+         Errors.fail
+           loc
+           "Context '%s' is both a host (for '%s') and a target (for '%s')."
+           host
+           elt.name
+           host_of_host
+      )
+  in
+  List.iter
+    contexts
+    ~f:check
+
+(* Resolve the host field of contexts
+ * (assuming contexts are topologically sorted)
+*)
+let rec resolve_host_top_contexts acc map contexts =
+  match contexts with
+  | [] -> acc
+  | (_,(None, ctx))::next ->
+    resolve_host_top_contexts
+      (ctx::acc)
+      (String.Map.add map ctx.name ctx)
+      next
+  | (_,((Some host), ctx))::next ->
+    let ctx_resolved = {ctx with for_host=Some (String.Map.find_exn map host)}
+    in
+    resolve_host_top_contexts
+      (ctx_resolved::acc)
+      (String.Map.add map ctx.name ctx_resolved)
+      next
+
+(* Resolve the host field of contexts *)
 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 map =
+    String.Map.of_list_map_exn
+      contexts
+      ~f:(fun ((_, (_, c)) as elt) -> c.name, elt)
+  in
+  let key (_,(_, ctx)) = ctx.name in
+  let deps (loc, (host, elem)) =
+    match host with
+    | Some host ->
+      (match String.Map.find map host with
+       | None ->
+         Errors.fail
+           loc
+           "Undefined host context '%s' for '%s'."
+           host
+           elem.name
+       | Some host_ctx -> [host_ctx])
+    | None -> []
+  in
+  match Top_closure.String.top_closure ~key ~deps contexts with
+  | Ok top_contexts ->
+    look_for_bad_configurations top_contexts;
+    resolve_host_top_contexts [] String.Map.empty top_contexts
+  | Error failed_contexts ->
+    look_for_bad_configurations (List.tl failed_contexts);
+    assert false (* Should fail beforehand. *)
 
 let create ~env (workspace : Workspace.t) =
   let env_nodes context =
@@ -624,7 +683,8 @@ let create ~env (workspace : Workspace.t) =
   in
   Fiber.parallel_map workspace.contexts ~f:(fun def ->
     match def with
-    | Default { targets; name; host_context; 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
@@ -633,13 +693,15 @@ let create ~env (workspace : Workspace.t) =
         | Some t, _ -> Some t
         | None, default -> default
       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 }
+      (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)
+         ~switch ~name ~merlin ~targets ~host_context
+         ~host_toolchain:toolchain)
       >>| fun x -> List.map ~f:(fun x -> (loc,x)) x)
   >>| List.concat
   >>| resolve_host_contexts

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))
@@ -1460,6 +1468,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)
@@ -1636,6 +1645,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') context.
+  [1]
+
+  $ dune build --root ./topological-loop --display short file @install
+  Entering directory 'topological-loop'
+  File "dune-workspace", line 3, characters 9-53:
+  3 | (context (default
+  4 |   (name cross-1)
+  5 |   (host cross-3)
+  6 | ))
+  Error: Context 'cross-1' is both a host (for 'cross-2') and a target (for 'cross-3') context.
+  [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