Merge pull request #3104 from ocaml/relocation

Sites, locations, relocation

CHANGES.md

@@ -1,8 +1,11 @@
 Unreleased
 ----------
 
-- Ignore special files (BLK, CHR, FIFO, SOCKET) , fixes #3124, #3546
-  (#3570, @ejgallego)
+- Ignore special files (BLK, CHR, FIFO, SOCKET), (#3570, fixes #3124, #3546,
+  @ejgallego)
+
+- Experimental: Introduce specific installation sites. Allow to define plugins
+  to be installed in these sites. (#3104, fixes #1185, @bobot)
 
 2.7.1 (2/09/2020)
 -----------------

bin/exec.ml

@@ -45,7 +45,8 @@ let term =
   and+ args = Arg.(value & pos_right 0 string [] (Arg.info [] ~docv:"ARGS")) in
   Common.set_common common ~targets:[ Arg.Dep.file prog ];
   let setup = Scheduler.go ~common (fun () -> Import.Main.setup common) in
-  let context = Import.Main.find_context_exn setup.workspace ~name:context in
+  let sctx = Import.Main.find_scontext_exn setup ~name:context in
+  let context = Dune_rules.Super_context.context sctx in
   let path_relative_to_build_root p =
     Common.prefix_target common p
     |> Path.Build.relative context.build_dir
@@ -131,6 +132,7 @@ let term =
   | Some real_prog, _ ->
     let real_prog = Path.to_string real_prog in
     let argv = prog :: args in
-    restore_cwd_and_execve common real_prog argv context.env
+    restore_cwd_and_execve common real_prog argv
+      (Super_context.context_env sctx)
 
 let command = (term, info)

bin/import.ml

@@ -17,7 +17,8 @@ module Action = Dune_engine.Action
 module Dep = Dune_engine.Dep
 module Action_to_sh = Dune_rules.Action_to_sh
 module Dpath = Dune_engine.Dpath
-module Install = Dune_rules.Install
+module Install = Dune_engine.Install
+module Section = Dune_engine.Section
 module Watermarks = Dune_rules.Watermarks
 module Promotion = Dune_engine.Promotion
 module Colors = Dune_rules.Colors

bin/install_uninstall.ml

@@ -68,6 +68,7 @@ module type File_operations = sig
     -> executable:bool
     -> special_file:Special_file.t option
     -> package:Package.Name.t
+    -> conf:Dune_engine.Artifact_substitution.conf
     -> unit Fiber.t
 
   val mkdir_p : Path.t -> unit
@@ -82,7 +83,7 @@ module type Workspace = sig
 end
 
 module File_ops_dry_run : File_operations = struct
-  let copy_file ~src ~dst ~executable ~special_file:_ ~package:_ =
+  let copy_file ~src ~dst ~executable ~special_file:_ ~package:_ ~conf:_ =
     Format.printf "Copying %s to %s (executable: %b)\n"
       (Path.to_string_maybe_quoted src)
       (Path.to_string_maybe_quoted dst)
@@ -119,7 +120,10 @@ module File_ops_real (W : Workspace) : File_operations = struct
     match f ic with
     | exception _ ->
       User_warning.emit ~loc:(Loc.in_file src)
-        [ Pp.text "Failed to parse file, not adding version information." ];
+        [ Pp.text
+            "Failed to parse file, not adding version and locations \
+             information."
+        ];
       plain_copy ()
     | No_version_needed -> plain_copy ()
     | Need_version print -> (
@@ -161,12 +165,42 @@ module File_ops_real (W : Workspace) : File_operations = struct
           in
           Pp.render_ignore_tags ppf (Dune_rules.Meta.pp meta.entries))
 
-  let process_dune_package ic =
+  let replace_sites
+      ~(get_location : Dune_engine.Section.t -> Package.Name.t -> Stdune.Path.t)
+      dp =
+    match
+      List.find_map dp ~f:(function
+        | Dune_lang.List [ Atom (A "name"); Atom (A name) ] -> Some name
+        | _ -> None)
+    with
+    | None -> dp
+    | Some name ->
+      List.map dp ~f:(function
+        | Dune_lang.List ((Atom (A "sites") as sexp_sites) :: sites) ->
+          let sites =
+            List.map sites ~f:(function
+              | Dune_lang.List [ (Atom (A section) as section_sexp); _ ] ->
+                let path =
+                  get_location
+                    (Option.value_exn (Section.of_string section))
+                    (Package.Name.of_string name)
+                in
+                let open Dune_lang.Encoder in
+                pair sexp string (section_sexp, Path.to_absolute_filename path)
+              | _ -> assert false)
+          in
+          Dune_lang.List (sexp_sites :: sites)
+        | x -> x)
+
+  let process_dune_package ~get_location ic =
     let lb = Lexing.from_channel ic in
     let dp =
       Dune_lang.Parser.parse ~mode:Many lb
       |> List.map ~f:Dune_lang.Ast.remove_locs
     in
+    (* replace sites with external path in the file *)
+    let dp = replace_sites ~get_location dp in
+    (* replace version if needed in the file *)
     if
       List.exists dp ~f:(function
         | Dune_lang.List (Atom (A "version") :: _)
@@ -197,7 +231,8 @@ module File_ops_real (W : Workspace) : File_operations = struct
               Format.pp_print_cut ppf ());
           Format.pp_close_box ppf ())
 
-  let copy_file ~src ~dst ~executable ~special_file ~package =
+  let copy_file ~src ~dst ~executable ~special_file ~package
+      ~(conf : Dune_engine.Artifact_substitution.conf) =
     let chmod =
       if executable then
         fun _ ->
@@ -215,9 +250,10 @@ module File_ops_real (W : Workspace) : File_operations = struct
         match (special_file : Special_file.t option) with
         | Some META -> copy_special_file ~src ~package ~ic ~oc ~f:process_meta
         | Some Dune_package ->
-          copy_special_file ~src ~package ~ic ~oc ~f:process_dune_package
+          copy_special_file ~src ~package ~ic ~oc
+            ~f:(process_dune_package ~get_location:conf.get_location)
         | None ->
-          Dune_engine.Artifact_substitution.copy ~get_vcs ~input_file:src
+          Dune_engine.Artifact_substitution.copy ~conf ~input_file:src
             ~input:(input ic) ~output:(output oc))
 
   let remove_if_exists dst =
@@ -243,13 +279,12 @@ end
 module Sections = struct
   type t =
     | All
-    | Only of Install.Section.Set.t
+    | Only of Section.Set.t
 
-  let sections_conv : Install.Section.t list Cmdliner.Arg.converter =
+  let sections_conv : Section.t list Cmdliner.Arg.converter =
     let all =
-      Install.Section.all |> Install.Section.Set.to_list
-      |> List.map ~f:(fun section ->
-             (Install.Section.to_string section, section))
+      Section.all |> Section.Set.to_list
+      |> List.map ~f:(fun section -> (Section.to_string section, section))
     in
     Arg.list ~sep:',' (Arg.enum all)
 
@@ -261,12 +296,12 @@ module Sections = struct
     in
     match sections with
     | None -> All
-    | Some sections -> Only (Install.Section.Set.of_list sections)
+    | Some sections -> Only (Section.Set.of_list sections)
 
   let should_install t section =
     match t with
     | All -> true
-    | Only set -> Install.Section.Set.mem set section
+    | Only set -> Section.Set.mem set section
 end
 
 let file_operations ~dry_run ~workspace : (module File_operations) =
@@ -328,6 +363,13 @@ let install_uninstall ~what =
         value & flag
         & info [ "dry-run" ]
             ~doc:"Only display the file operations that would be performed.")
+    and+ relocatable =
+      Arg.(
+        value & flag
+        & info [ "relocatable" ]
+            ~doc:
+              "Make the binaries relocatable (the installation directory can \
+               be moved).")
     and+ pkgs = Arg.(value & pos_all package_name [] name_)
     and+ context =
       Arg.(
@@ -437,6 +479,11 @@ let install_uninstall ~what =
                 get_dirs context ~prefix_from_command_line
                   ~libdir_from_command_line
               in
+              let conf =
+                Dune_engine.Artifact_substitution.conf_for_install ~relocatable
+                  ~default_ocamlpath:context.default_ocamlpath
+                  ~stdlib_dir:context.stdlib_dir ~prefix ~libdir ~mandir
+              in
               Fiber.sequential_iter entries_per_package
                 ~f:(fun (package, entries) ->
                   let paths =
@@ -456,11 +503,10 @@ let install_uninstall ~what =
                           (Path.to_string_maybe_quoted dst);
                         Ops.mkdir_p dir;
                         let executable =
-                          Install.Section.should_set_executable_bit
-                            entry.section
+                          Section.should_set_executable_bit entry.section
                         in
                         Ops.copy_file ~src:entry.src ~dst ~executable
-                          ~special_file ~package
+                          ~special_file ~package ~conf
                       ) else (
                         Ops.remove_if_exists dst;
                         files_deleted_in := Path.Set.add !files_deleted_in dir;

bin/utop.ml

@@ -26,13 +26,14 @@ let term =
       [ Pp.textf "cannot find directory: %s" (String.maybe_quoted dir) ];
   let utop_target = Arg.Dep.file (Filename.concat dir Utop.utop_exe) in
   Common.set_common_other common ~targets:[ utop_target ];
-  let context, utop_path =
+  let sctx, utop_path =
     Scheduler.go ~common (fun () ->
         let open Fiber.O in
         let* setup = Import.Main.setup common in
         let context =
           Import.Main.find_context_exn setup.workspace ~name:ctx_name
         in
+        let sctx = Import.Main.find_scontext_exn setup ~name:ctx_name in
         let setup =
           { setup with
             workspace = { setup.workspace with contexts = [ context ] }
@@ -48,9 +49,10 @@ let term =
           | Ok _ -> assert false
         in
         let+ () = do_build [ File target ] in
-        (context, Path.to_string target))
+        (sctx, Path.to_string target))
   in
   Hooks.End_of_build.run ();
-  restore_cwd_and_execve common utop_path (utop_path :: args) context.env
+  restore_cwd_and_execve common utop_path (utop_path :: args)
+    (Super_context.context_env sctx)
 
 let command = (term, info)

boot/libs.ml

@@ -21,6 +21,8 @@ let local_libraries =
   ; ("src/catapult", Some "Catapult", false, None)
   ; ("src/jbuild_support", Some "Jbuild_support", false, None)
   ; ("otherlibs/action-plugin/src", Some "Dune_action_plugin", false, None)
+  ; ("src/meta_parser", Some "Dune_meta_parser", false, None)
+  ; ("src/section", Some "Dune_section", false, None)
   ; ("vendor/build_path_prefix_map/src", Some "Build_path_prefix_map", false,
     None)
   ; ("src/dune_engine", Some "Dune_engine", false, None)

doc/advanced-topics.rst

@@ -57,8 +57,96 @@ set of predicates:
   it is linked as part of a driver or meant to add a ``-ppx`` argument
   to the compiler, choose the former behavior
 
-Dynamic loading of packages
-===========================
+.. _plugins:
+
+Plugins and dynamic loading of packages
+========================================
+
+Dune allows to define and load plugins without having to deal with specific
+compilation, installation directories, dependencies or the module `Dynlink`.
+Here we show an example of an executable which can be extended using plugins,
+and the definition of one plugin in another package.
+
+Example
+-------
+
+Main executable (C)
+^^^^^^^^^^^^^^^^^^^^^
+
+- ``dune-project`` file:
+
+.. code:: scheme
+
+   (lang dune 2.8)
+   (name c)
+   (package (name c) (sites (lib plugins)))
+
+
+- ``dune`` file:
+
+.. code:: scheme
+
+   (executable
+    (public_name c)
+    (modules sites c)
+    (libraries c.register dune-site dune-site.plugins))
+
+   (library
+    (public_name c.register)
+    (name c_register)
+    (modules c_register))
+
+   (generate_module (module sites)  (plugins (c plugins)))
+
+- The module ``c_register.ml`` of the library ``c.register``:
+
+.. code:: ocaml
+
+   let todo = Queue.create ()
+
+- The code of the exectuable ``c.ml``:
+
+.. code:: ocaml
+
+   (* load all the available plugins *)
+   let () = Sites.Plugins.Plugins.load_all ()
+   (* Execute the code registered by the plugins *)
+   let () = Queue.iter (fun f -> f ()) !C_register.todo
+
+One plugin (B)
+^^^^^^^^^^^^^^
+
+- ``dune-project`` file:
+
+.. code:: scheme
+
+   (lang dune 2.8)
+   (name b)
+
+- ``dune`` file:
+
+.. code:: scheme
+
+  (library
+   (public_name b)
+   (libraries c.register))
+
+  (plugin
+   (name b)
+   (libraries b)
+   (site (c plugins)))
+
+- The code of the plugin ``b.ml``:
+
+.. code:: ocaml
+
+   let () = Queue.add (fun () -> print_endline "B is doing something") C_register.todo
+
+
+Dynamic loading of packages with findlib
+========================================
+
+The prefered way for new developement is to use :ref:`plugins`.
 
 Dune supports the ``findlib.dynload`` package from `findlib
 <http://projects.camlcity.org/projects/findlib.html>`_ that enables

doc/concepts.rst

@@ -1048,6 +1048,19 @@ the installation directory is either guessed or can be manually
 specified by the user.  This is described more in detail in the last
 section of this page.
 
+.. _sites:
+
+Sites of a package
+------------------
+
+When packages need additional resources outside their binary, their location
+could be hard to find. Moreover some packages could add resources to another
+package, for example in the case of plugins. These location are called sites in
+dune. One package can define them. During execution one site corresponds to a
+list of directories. They are like layers, the first directories have an higher
+priority.
+
+
 Libraries
 ^^^^^^^^^
 
@@ -1062,9 +1075,9 @@ For instance:
 
 .. code:: scheme
 
-          (library
-           (name mylib)
-           (public_name mypackage.mylib))
+   (library
+    (name mylib)
+    (public_name mypackage.mylib))
 
 After you have added a public name to a library, Dune will know to
 install it as part of the package it is attached to.  Dune installs