Add shell completion

This provides a shell completion mechanism for dune. This relies on the
bash completion API, which can be used with zsh as well.

The architecture is:

- `dune complete script` outputs a script to be sourced in the user's
  shell. It is comprised of a `_dune` function and the `complete -F
  _dune dune` command to register it. The `_dune` function can be used
  in cram tests to write natural-looking tests for this feature.
- this script calls `dune complete command` with the partial
  command-line. This internal command parses it to determine what the
  word being completed refers to: a command name, an argument name, or
  an argument value. The first two ones are part of the metadata
  `cmdliner` knows about; the last one is provided through a completion
  function that can be passed in one the `Arg` functions.
- the interface between `bash` and `dune complete command` is simple:
  it passes the command line and a position to complete at (this is
  necessary to encode the difference between `dune bui<tab>` and `dune
  build <tab>` for example), and reads an array from the output of the
  command.

The things I'm happy with:

- it is small!
- coverage is pretty good: command names, arguments (positional and
  optional, including optional arguments with optional names), and the
  `--` construct are supported. So, this is likely to improve the user
  experience already.
- it is easy to test through cram or unit tests (I chose the former).

Now, for the ugly bits...

- this effectively is a partial reimplementation of cmdliner inside
  `complete.ml`. If the exact parsing rules are different, it means that
  we can complete to something with different or wrong semantics.
- the vendored copy of cmdliner is patched to expose so that it is
  possible to use the private APIs. these two points need to be resolved
  before we can think about how to upstream this.
- some bits of the cmdliner API need to be modified to provide
  completion automatically. For example for things like `enum` it's easy
  to provide a completion function automatically.
- it is difficult to define the right API for the completion functions.
  `unit -> string list` is a first approximation but with some
  limitations. For example, getting a list of buildable targets needs to
  run under `Fiber`, but we can't pollute the API with it. Interestingly
  enough, algebraic effects seem like they would be an interesting
  solution for this.
- at the moment, we're not relying on the shell's completion helpers to
  complete things like filenames. To support this we would either need
  to implement that in OCaml, or extend the bash/dune interface so that
  the completion function could call `compgen -f` based on the dune
  output.
- as a way to tie the two previous points: if we wanted to complete
  `dune build dir/file<tab>`, it would be a lot more efficient to pass
  the prefix to the build system and let it compute just the targets
  that match this, rather than compute everything and filter it
  afterwards. So that prefix would need to appear in the completion API.

Signed-off-by: Etienne Millon <me@emillon.org>

bin/common.ml

@@ -424,8 +424,10 @@ module Options_implied_by_dash_p = struct
         "Promote the generated <package>.install files to the source tree"
       in
       Arg.(
-        last
-        & opt_all ~vopt:true bool [ false ]
+        last (* XXX do something about this *)
+        & opt_all
+            ~complete:(fun () -> [ "true"; "false" ])
+            ~vopt:true bool [ false ]
         & info [ "promote-install-files" ] ~docs ~doc)
     and+ require_dune_project_file =
       let doc = "Fail if a dune-project file is missing." in
@@ -573,8 +575,8 @@ let shared_with_config_file =
         ~f:(fun s -> (Dune_engine.Sandbox_mode.to_string s, s))
     in
     Arg.(
-      value
-      & opt (some (enum all)) None
+      value (* XXX: enum helper *)
+      & opt ~complete:(fun () -> List.map ~f:fst all) (some (enum all)) None
       & info [ "sandbox" ]
           ~env:
             (Cmd.Env.info

bin/complete.ml

@@ -0,0 +1,167 @@
+open Import
+open Stdune
+
+let all = Fdecl.create Dyn.opaque
+
+module Script = struct
+  let script =
+    {|
+_dune () {
+    local p=$(IFS=, ; echo "${COMP_WORDS[*]}")
+    COMPREPLY=( $(dune complete command --command-line $p --position $COMP_CWORD) )
+}
+
+complete -F _dune dune
+|}
+
+  let term =
+    let+ () = Term.const () in
+    print_endline script
+
+  let info = Cmd.info ~doc:"Output a bash completion script for dune." "script"
+
+  let command = Cmd.v info term
+end
+
+module Command = struct
+  (** The kind of thing we're providing completions for *)
+  type kind =
+    | Command of unit Cmd.t list  (** Commands (nested as a tree) *)
+    | Argument of unit Cmd.t
+        (** All arguments for a command: options and positional ones *)
+    | Argument_pos of unit Cmd.t
+        (** Only positional arguments for a command (after [--]) *)
+    | Arg_value of
+        { cmd : unit Cmd.t
+        ; arg : Cmdliner_info.Arg.t
+        ; optional : bool
+        }
+        (** Argument values: what appears after [--opt]. [optional] is [true] if
+            the next item in the command line can be interpreted as a value for
+            this argument. *)
+
+  let split_at n l =
+    let rec go n l acc =
+      match l with
+      | h :: t when n > 0 -> go (n - 1) t (h :: acc)
+      | _ -> (acc, l)
+    in
+    let rev_head, tail = go n l [] in
+    (List.rev rev_head, tail)
+
+  let compute_prefix cword cmdline =
+    let first, next = split_at cword cmdline in
+    (first, List.hd_opt next)
+
+  let match_prefix word_at_completion_point w =
+    match word_at_completion_point with
+    | None -> true
+    | Some prefix -> String.is_prefix ~prefix w
+
+  let cmd_args cmd =
+    cmd |> Cmdliner_cmd.get_info |> Cmdliner_info.Cmd.args
+    |> Cmdliner_info.Arg.Set.elements
+
+  let complete_args cmd ~word_at_completion_point ~pos_only =
+    let opt_args, pos_args =
+      cmd_args cmd |> List.partition ~f:Cmdliner_info.Arg.is_opt
+    in
+    let include_opts =
+      if pos_only then false
+      else
+        match word_at_completion_point with
+        | None -> false
+        | Some s -> String.is_prefix ~prefix:"-" s
+    in
+    (if include_opts then
+     List.concat_map ~f:Cmdliner_info.Arg.opt_names opt_args
+    else [])
+    @ List.concat_map ~f:Cmdliner_info.Arg.complete pos_args
+
+  let completions_at cmds position cmdline =
+    let args, word_at_completion_point = compute_prefix position cmdline in
+
+    let rec go cmdline state =
+      match (state, cmdline) with
+      | Command cmds, [] -> List.map cmds ~f:Cmd.name
+      | Command cmds, first :: other_args -> (
+        match
+          List.find_opt cmds ~f:(fun cmd -> String.equal first (Cmd.name cmd))
+        with
+        | None -> []
+        | Some cmd -> (
+          match cmd with
+          | Cmd _ -> go other_args (Argument cmd)
+          | Group (_, (_, cmds)) -> go other_args (Command cmds)))
+      | Argument cmd, [] ->
+        complete_args cmd ~word_at_completion_point ~pos_only:false
+      | Argument cmd, "--" :: other_args -> go other_args (Argument_pos cmd)
+      | Argument cmd, first_arg :: other_args -> (
+        let arg_opt =
+          cmd_args cmd
+          |> List.find_map ~f:(fun arg ->
+                 if Cmdliner_info.Arg.is_opt arg then
+                   let names = Cmdliner_info.Arg.opt_names arg in
+                   Option.some_if
+                     (List.mem names first_arg ~equal:String.equal)
+                     arg
+                 else None)
+        in
+        match arg_opt with
+        | None -> complete_args cmd ~word_at_completion_point ~pos_only:false
+        | Some arg -> (
+          match Cmdliner_info.Arg.opt_kind arg with
+          | Flag -> go other_args (Argument cmd)
+          | Opt -> go other_args (Arg_value { cmd; arg; optional = false })
+          | Opt_vopt _ ->
+            go other_args (Arg_value { cmd; arg; optional = true })))
+      | Arg_value { cmd; arg; optional }, [] ->
+        let args = Cmdliner_info.Arg.complete arg in
+        if optional then
+          args @ complete_args cmd ~word_at_completion_point ~pos_only:false
+        else args
+      | Arg_value { cmd; _ }, _ :: other_args -> go other_args (Argument cmd)
+      | Argument_pos cmd, [] ->
+        complete_args cmd ~word_at_completion_point ~pos_only:true
+      | Argument_pos cmd, _first_arg :: other_args ->
+        go other_args (Argument_pos cmd)
+    in
+
+    go (List.tl args) (Command cmds)
+    |> List.filter ~f:(match_prefix word_at_completion_point)
+
+  let term =
+    let+ cmdline =
+      let open Arg in
+      required
+      & opt (some & list string) None
+      & info
+          ~doc:
+            "A comma-separated list representing the command line to complete"
+          [ "command-line" ]
+    and+ position =
+      let open Arg in
+      required
+      & opt (some int) None
+      & info
+          ~doc:
+            "The 0-indexed position at which to complete the command-line. For \
+             example, when typing $(b,dune bui<tab>), the position is 1 and \
+             when typing $(b,dune build <tab>) it is 2."
+          [ "position" ]
+    in
+    let cmds = Fdecl.get all in
+    completions_at cmds position cmdline
+    |> String.Set.of_list
+    |> String.Set.iter ~f:print_endline
+
+  let info =
+    Cmd.info ~doc:"Output possible completions of a partial dune command line."
+      "command"
+
+  let command = Cmd.v info term
+end
+
+let info = Cmd.info "complete"
+
+let command = Cmd.group info [ Script.command; Command.command ]

bin/complete.mli

@@ -0,0 +1,5 @@
+open Import
+
+val all : unit Cmd.t list Stdune.Fdecl.t
+
+val command : unit Cmd.t

bin/describe.ml

@@ -867,6 +867,8 @@ module What = struct
       , return External_lib_deps )
     ]
 
+  let parsers = List.map parsers_with_docs ~f:(fun (n, _, _, _) -> n)
+
   (* The list of documentation strings (one for each command) *)
   let docs =
     List.map parsers_with_docs ~f:(fun (stag, args, doc, _parser) ->
@@ -1033,7 +1035,8 @@ let term : unit Term.t =
   let+ common = Common.term
   and+ what =
     Arg.(
-      value & pos_all string []
+      value
+      & pos_all ~complete:(fun () -> What.parsers) string []
       & info [] ~docv:"STRING"
           ~doc:
             ("What to describe. The syntax of this description is tied to the \

bin/main.ml

@@ -27,6 +27,7 @@ let all : _ Cmdliner.Cmd.t list =
     ; Ocaml_merlin.command
     ; Shutdown.command
     ; Diagnostics.command
+    ; Complete.command
     ]
   in
   let groups =
@@ -85,7 +86,9 @@ let info =
           ]
       ]
 
-let cmd = Cmd.group info all
+let cmd =
+  Fdecl.set Complete.all all;
+  Cmd.group info all
 
 let exit_and_flush code =
   Console.finish ();

doc/dune.inc

@@ -44,6 +44,15 @@
  (package dune)
  (files   dune-clean.1))
 
+(rule
+ (with-stdout-to dune-complete.1
+  (run dune complete --help=groff)))
+
+(install
+ (section man)
+ (package dune)
+ (files   dune-complete.1))
+
 (rule
  (with-stdout-to dune-coq.1
   (run dune coq --help=groff)))