Initial implementation of dune fmt

This is a first draft with three main limitations:

- it is language agnostic, so it does not know about field names
- it is not able to parse comments
- it does not break long lines

The formatting rules are pretty simple:

- lists composed only of atoms, quoted strings, templates, and
  singletons are displayed on a single line
- other lists are displayed with a line break after each element
- an empty line is inserted between toplevel stanzas

The CLI is pretty light: it can either read a file or standard input,
and fix a file in place. In addition, the command is named
`unstable-fmt` for now, until some guarantees are given.

Closes #940

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

CHANGES.md

@@ -11,6 +11,9 @@ next
 
 - Display actual stanza when package is ambiguous (#1126, fix #1123, @emillon)
 
+- Add `dune unstable-fmt` to format `dune` files. The interface and syntax are
+  still subject to change, so use with caution. (#1130, fix #940, @emillon)
+
 1.1.1 (08/08/2018)
 ------------------
 

bin/main.ml

@@ -1480,6 +1480,43 @@ let printenv =
   in
   (term, Term.info "printenv" ~doc ~man )
 
+let fmt =
+  let doc = "Format dune files" in
+  let man =
+    [ `S "DESCRIPTION"
+    ; `P {|$(b,dune unstable-fmt) reads a dune file and outputs a formatted
+           version. This feature is unstable, and its interface or behaviour
+           might change.
+         |}
+    ] in
+  let term =
+    let%map path_opt =
+      let docv = "FILE" in
+      let doc = "Path to the dune file to parse." in
+      Arg.(value & pos 0 (some path) None & info [] ~docv ~doc)
+    and inplace =
+      let doc = "Modify the file in place" in
+      Arg.(value & flag & info ["inplace"] ~doc)
+    in
+    if true then
+      let (input, output) =
+        match path_opt, inplace with
+        | None, false ->
+          (None, None)
+        | Some path, true ->
+          let path = Arg.Path.path path in
+          (Some path, Some path)
+        | Some path, false ->
+          (Some (Arg.Path.path path), None)
+        | None, true ->
+          die "--inplace requires a file name"
+      in
+      Dune_fmt.format_file ~input ~output
+    else
+      die "This command is unstable. Please pass --unstable to use it nonetheless."
+  in
+  (term, Term.info "unstable-fmt" ~doc ~man )
+
 module Help = struct
   let config =
     ("dune-config", 5, "", "Dune", "Dune manual"),
@@ -1600,6 +1637,7 @@ let all =
   ; promote
   ; printenv
   ; Help.help
+  ; fmt
   ]
 
 let default =

doc/dune.inc

@@ -116,6 +116,15 @@
  (package dune)
  (files   dune-uninstall.1))
 
+(rule
+ (with-stdout-to dune-unstable-fmt.1
+  (run dune unstable-fmt --help=groff)))
+
+(install
+ (section man)
+ (package dune)
+ (files   dune-unstable-fmt.1))
+
 (rule
  (with-stdout-to dune-utop.1
   (run dune utop --help=groff)))

src/dune_fmt.ml

@@ -0,0 +1,121 @@
+open! Import
+
+let parse_file path_opt =
+  let fname, contents =
+    match path_opt with
+    | Some path ->
+      Io.with_file_in path ~f:(fun ic ->
+        let contents = Io.read_all ic in
+        (Path.to_string path, contents)
+      )
+    | None ->
+      let lines = Io.input_lines stdin in
+      let contents = String.concat ~sep:"\n" lines in
+      ("<stdin>", contents)
+  in
+  Sexp.parse_string
+    ~fname
+    ~mode:Usexp.Parser.Mode.Many
+    contents
+
+let can_be_displayed_inline =
+  List.for_all ~f:(function
+    | Usexp.Atom _
+    | Usexp.Quoted_string _
+    | Usexp.Template _
+    | Usexp.List [_]
+      ->
+      true
+    | Usexp.List _
+      ->
+      false
+  )
+
+let pp_indent fmt indent =
+  Format.pp_print_string fmt @@ String.make indent ' '
+
+let print_inline_list fmt indent sexps =
+  Format.fprintf fmt "%a(" pp_indent indent;
+  let first = ref true in
+  List.iter sexps ~f:(fun sexp ->
+    if !first then
+      first := false
+    else
+      Format.pp_print_string fmt " ";
+    Usexp.pp Usexp.Dune fmt sexp
+  );
+  Format.pp_print_string fmt ")"
+
+let rec pp_sexp indent fmt =
+  function
+    ( Usexp.Atom _
+    | Usexp.Quoted_string _
+    | Usexp.Template _
+    ) as sexp
+    ->
+    Format.fprintf fmt "%a%a"
+      pp_indent indent
+      (Usexp.pp Usexp.Dune) sexp
+  | Usexp.List sexps
+    ->
+    if can_be_displayed_inline sexps then
+      print_inline_list fmt indent sexps
+    else
+      pp_sexp_list indent fmt sexps
+
+and pp_sexp_list indent fmt sexps =
+    begin
+      Format.fprintf fmt "%a(" pp_indent indent;
+      let first = ref true in
+      List.iter sexps ~f:(fun sexp ->
+        let indent =
+          if !first then
+            begin
+              first := false;
+              0
+            end
+          else
+            indent + 1
+        in
+        pp_sexp
+          indent
+          fmt
+          sexp;
+        Format.pp_print_string fmt "\n";
+      );
+      Format.fprintf fmt "%a)" pp_indent indent;
+    end
+
+let pp_top_sexp fmt sexp =
+  Format.fprintf fmt "%a\n" (pp_sexp 0) sexp
+
+let pp_top_sexps fmt sexps =
+  let first = ref true in
+  List.iter sexps ~f:(fun sexp ->
+    if !first then
+      first := false
+    else
+      Format.pp_print_string fmt "\n";
+    pp_top_sexp fmt (Sexp.Ast.remove_locs sexp);
+  )
+
+let with_output path_opt k =
+  match path_opt with
+  | None ->
+    k Format.std_formatter
+  | Some path ->
+    Io.with_file_out ~binary:true path ~f:(fun oc ->
+      k @@ Format.formatter_of_out_channel oc
+    )
+
+let format_file ~input ~output =
+  match parse_file input with
+  | exception Usexp.Parse_error e ->
+    Printf.printf
+      "Parse error: %s\n"
+      (Usexp.Parse_error.message e)
+  | sexps ->
+    with_output output (fun fmt ->
+      pp_top_sexps fmt sexps;
+      Format.pp_print_flush fmt ()
+    )

src/dune_fmt.mli

@@ -0,0 +1,7 @@
+open Import
+
+(** Reformat a dune file. [None] corresponds to stdin/stdout. *)
+val format_file :
+  input:Path.t option ->
+  output:Path.t option ->
+  unit

src/stdune/io.mli

@@ -11,6 +11,7 @@ val with_file_out : ?binary:bool (* default true *) -> Path.t -> f:(out_channel
 
 val with_lexbuf_from_file : Path.t -> f:(Lexing.lexbuf -> 'a) -> 'a
 
+val input_lines : in_channel -> string list
 val lines_of_file : Path.t -> string list
 
 val read_file : ?binary:bool -> Path.t -> string

test/blackbox-tests/dune.inc

@@ -207,6 +207,14 @@
    test-cases/findlib-error
    (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected)))))
 
+(alias
+ (name fmt)
+ (deps (package dune) (source_tree test-cases/fmt))
+ (action
+  (chdir
+   test-cases/fmt
+   (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected)))))
+
 (alias
  (name force-test)
  (deps (package dune) (source_tree test-cases/force-test))
@@ -816,6 +824,7 @@
   (alias fallback-dune)
   (alias findlib)
   (alias findlib-error)
+  (alias fmt)
   (alias force-test)
   (alias gen-opam-install-file)
   (alias github1019)
@@ -914,6 +923,7 @@
   (alias fallback-dune)
   (alias findlib)
   (alias findlib-error)
+  (alias fmt)
   (alias force-test)
   (alias github1019)
   (alias github1099)

test/blackbox-tests/test-cases/fmt/dune

@@ -0,0 +1,2 @@
+(a
+b)

test/blackbox-tests/test-cases/fmt/run.t

@@ -0,0 +1,62 @@
+The empty list and atoms are printed as is:
+
+  $ echo '()' | dune unstable-fmt
+  ()
+
+  $ echo 'a' | dune unstable-fmt
+  a
+
+Lists containing only atoms, quoted strings, templates, and singleton lists are
+printed inline:
+
+  $ echo '(atom "string" %{template} (singleton))' | dune unstable-fmt
+  (atom "string" %{template} (singleton))
+
+Other lists are displayed one element per line:
+
+  $ echo '(a (b c d) e)' | dune unstable-fmt
+  (a
+   (b c d)
+   e
+  )
+
+When there are several s-expressions, they are printed with an empty line
+between them:
+
+  $ echo '(a b) (c d)' | dune unstable-fmt
+  (a b)
+
+  (c d)
+
+It is possible to pass a file name:
+
+  $ dune unstable-fmt dune
+  (a b)
+
+A file can be fixed in place:
+
+  $ echo '(a (b c))' > dune_temp
+  $ dune unstable-fmt --inplace dune_temp
+  $ cat dune_temp
+  (a
+   (b c)
+  )
+
+The --inplace flag requires a file name:
+
+  $ dune unstable-fmt --inplace
+  --inplace requires a file name
+  [1]
+
+Parse errors are displayed:
+
+  $ echo '(' | dune unstable-fmt
+  Parse error: unclosed parenthesis at end of input
+
+and files are not removed when there is an error:
+
+  $ echo '(a' > dune_temp
+  $ dune unstable-fmt --inplace dune_temp
+  Parse error: unclosed parenthesis at end of input
+  $ cat dune_temp
+  (a