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

…d error on bad configurations.

and tests.

Signed-off-by: Lucas Pluvinage <[email protected]>

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,141 @@ 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 get_host_context = function
+  | Workspace.Context.Default { host_context; _ }
+  | Workspace.Context.Opam { base={host_context; _}; _} -> host_context
+
+let bad_configuration_check map =
+  let find_or_error loc name host =
+    (match String.Map.find map host with
+     | None ->
+       Errors.fail
+         loc
+         "Undefined host context '%s' for '%s'."
+         host
+         name
+     | Some host_ctx -> host_ctx)
+  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 name = Workspace.Context.name elt in
+      let loc = get_loc elt in
+      (let host_elt = find_or_error loc name 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
+           name
+           host_of_host
+      )
+  in
+  String.Map.iter
+    map
+    ~f:check
 
-let create ~env (workspace : Workspace.t) =
+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); _}
+    | Opam { base={host_context=(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 separate_independant_contexts topo_contexts =
+  let f (acc, cur) elem = match get_host_context elem with
+    | None when cur == [] -> (acc, [elem])
+    | None -> ((List.rev cur)::acc, [elem])
+    | Some _ -> (acc, elem::cur)
+  in
+  match List.fold_left ~f ~init:([],[]) topo_contexts with
+  | (acc, []) -> acc
+  | (acc, cur) -> (List.rev cur)::acc
+
+let instanciate_context env (workspace : Workspace.t) def ctx_map =
+  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)
+  (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)
+
+let instanciate_context_group ~env (workspace : Workspace.t) contexts =
+  List.fold_left
+    contexts
+    ~f:(fun acc def ->
+      acc >>= fun (ctx_map, contexts) ->
+      instanciate_context env workspace def ctx_map
+      >>| 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
-      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 ~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)
+      (updated_map, new_contexts @ contexts)
+    )
+    ~init:(Fiber.return (String.Map.empty, []))
+  >>| fun (_, contexts) -> contexts
+
+let create ~env (workspace : Workspace.t) =
+  let contexts = top_sort workspace.contexts in
+  let independant_contexts = separate_independant_contexts contexts
+  in
+  Fiber.parallel_map
+    independant_contexts
+    ~f:(instanciate_context_group ~env workspace)
   >>| List.concat
-  >>| resolve_host_contexts
 
 let which t s = which ~cache:t.which_cache ~path:t.path s
 

src/workspace.ml

@@ -61,11 +61,17 @@ module Context = struct
       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)
+        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

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/context-not-found/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/context-not-found/dune-project

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

test/blackbox-tests/test-cases/custom-cross-compilation/context-not-found/dune-workspace

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

test/blackbox-tests/test-cases/custom-cross-compilation/context-not-found/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,57 @@
+  $ 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]
+
+  $ env OCAMLFIND_CONF=$PWD/target-and-host/etc/findlib.conf dune build --root ./target-and-host --display short file @install
+  Entering directory 'target-and-host'
+  File "dune-workspace", line 3, characters 9-69:
+  3 | (context (default
+  4 |   (name cross-1)
+  5 |   (targets foo)
+  6 |   (host default)
+  7 | ))
+  Error: `targets` and `host` options cannot be used in the same context.
+  [1]
+
+
+  $ dune build --root ./context-not-found --display short file @install
+  Entering directory 'context-not-found'
+  File "dune-workspace", line 3, characters 9-50:
+  3 | (context (default
+  4 |   (name cross-1)
+  5 |   (host oups)
+  6 | ))
+  Error: Undefined host context 'oups' for 'cross-1'.
+  [1]

test/blackbox-tests/test-cases/custom-cross-compilation/target-and-host/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/target-and-host/dune-project

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