Integration with auto formatters

This adds a "fmt" extension in dune-project files. When used, it will
setup a `@fmt` alias that will call `ocamlformat` on ocaml source code,
and `refmt` on reason source code. The tools are not configured by dune.

Closes #1201

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

src/dune_file.ml

@@ -650,6 +650,62 @@ end
 
 let modules_field name = Ordered_set_lang.field name
 
+module Auto_format = struct
+  let syntax =
+    Syntax.create ~name:"fmt"
+      ~desc:"integration with automatic formatters"
+      [ (1, 0) ]
+
+  type language =
+    | Ocaml
+    | Reason
+
+  let language_to_sexp = function
+    | Ocaml -> Sexp.Atom "ocaml"
+    | Reason -> Sexp.Atom "reason"
+
+  let language =
+    sum
+      [ ("ocaml", return Ocaml)
+      ; ("reason", return Reason)
+      ]
+
+  type enabled_for =
+    | Default
+    | Only of language list
+
+  let enabled_for_field =
+    let%map r = field_o "enabled_for" (repeat language) in
+    match r with
+    | Some l -> Only l
+    | None -> Default
+
+  let enabled_for_to_sexp =
+    function
+      | Default -> Sexp.Atom "default"
+      | Only l -> List [Atom "only"; List (List.map ~f:language_to_sexp l)]
+
+  type t =
+    { loc : Loc.t
+    ; enabled_for : enabled_for
+    }
+
+  let to_sexp {loc; enabled_for} =
+    Sexp.List
+      [ List [Atom "loc"; Loc.to_sexp loc]
+      ; List [Atom "enabled_for"; enabled_for_to_sexp enabled_for]
+      ]
+
+  let dparse =
+    let%map loc = loc
+    and enabled_for = record enabled_for_field
+    in
+    ({loc; enabled_for}, [])
+
+  let key =
+    Dune_project.Extension.register syntax dparse to_sexp
+end
+
 module Buildable = struct
   type t =
     { loc                      : Loc.t
@@ -845,7 +901,8 @@ module Library = struct
           ~desc:"the experimental variants feature"
           [ (0, 1) ]
       in
-      Dune_project.Extension.register ~experimental:true
+      Dune_project.Extension.register_no_args
+        ~experimental:true
         syntax (Dsexp.Of_sexp.return []);
       syntax
   end
@@ -888,8 +945,10 @@ module Library = struct
           ~desc:"experimental feature for building the compiler with dune"
           [ (0, 1) ]
       in
-      Dune_project.Extension.register ~experimental:true
-        syntax (Dsexp.Of_sexp.return []);
+      Dune_project.Extension.register_no_args
+        ~experimental:true
+        syntax
+        (Dsexp.Of_sexp.return []);
       syntax
 
     let glob =
@@ -1705,7 +1764,8 @@ module Menhir = struct
   type Stanza.t += T of t
 
   let () =
-    Dune_project.Extension.register syntax
+    Dune_project.Extension.register_no_args
+      syntax
       (return [ "menhir", dparse >>| fun x -> [T x] ])
 
   (* Syntax for jbuild files *)

src/dune_file.mli

@@ -127,6 +127,25 @@ module Dep_conf : sig
   val to_sexp : t Sexp.To_sexp.t
 end
 
+module Auto_format : sig
+  type language =
+    | Ocaml
+    | Reason
+
+  type enabled_for =
+    | Default
+    | Only of language list
+
+  type t =
+    { loc : Loc.t
+    ; enabled_for : enabled_for
+    }
+
+  val syntax : Syntax.t
+
+  val key : t Dune_project.Extension.key
+end
+
 module Buildable : sig
   type t =
     { loc                      : Loc.t

src/dune_project.ml

@@ -148,6 +148,7 @@ type t =
   ; packages      : Package.t Package.Name.Map.t
   ; stanza_parser : Stanza.t list Dsexp.Of_sexp.t
   ; project_file  : Project_file.t
+  ; extension_args : Univ_map.t
   }
 
 let packages t = t.packages
@@ -156,6 +157,9 @@ let name t = t.name
 let root t = t.root
 let stanza_parser t = t.stanza_parser
 
+let find_extension_args t key =
+  Univ_map.find t.extension_args key
+
 include Versioned_file.Make(struct
     type t = Stanza.Parser.t list
   end)
@@ -201,12 +205,20 @@ let append_to_project_file t str =
   Project_file_edit.append t.project_file str
 
 module Extension = struct
-  type t =
+  type 'a key = 'a Univ_map.Key.t
+
+  type 'a p =
     { syntax       : Syntax.t
-    ; stanzas      : Stanza.Parser.t list Dsexp.Of_sexp.t
+    ; stanzas      : ('a * Stanza.Parser.t list) Dsexp.Of_sexp.t
     ; experimental : bool
+    ; key          : 'a key
     }
 
+  type t = Extension : 'a p -> t
+
+  let syntax (Extension e) = e.syntax
+  let is_experimental (Extension e) = e.experimental
+
   type instance =
     { extension  : t
     ; version    : Syntax.Version.t
@@ -216,20 +228,34 @@ module Extension = struct
 
   let extensions = Hashtbl.create 32
 
-  let register ?(experimental=false) syntax stanzas =
+  let register ?(experimental=false) syntax stanzas arg_to_sexp =
     let name = Syntax.name syntax in
     if Hashtbl.mem extensions name then
       Exn.code_error "Dune_project.Extension.register: already registered"
         [ "name", Sexp.To_sexp.string name ];
-    Hashtbl.add extensions name { syntax; stanzas ; experimental }
+    let key = Univ_map.Key.create ~name arg_to_sexp in
+    let ext = { syntax; stanzas; experimental; key } in
+    Hashtbl.add extensions name (Extension ext);
+    key
+
+  let register_no_args ?experimental syntax stanzas =
+    let unit_stanzas =
+      let%map r = stanzas in
+      ((), r)
+    in
+    let unit_to_sexp () = Sexp.List [] in
+    let _ : unit key =
+      register ?experimental syntax unit_stanzas unit_to_sexp
+    in
+    ()
 
   let instantiate ~loc ~parse_args (name_loc, name) (ver_loc, ver) =
     match Hashtbl.find extensions name with
     | None ->
       Errors.fail name_loc "Unknown extension %S.%s" name
         (hint name (Hashtbl.keys extensions))
     | Some t ->
-      Syntax.check_supported t.syntax (ver_loc, ver);
+      Syntax.check_supported (syntax t) (ver_loc, ver);
       { extension = t
       ; version = ver
       ; loc
@@ -240,13 +266,13 @@ module Extension = struct
      automatically available at their latest version.  When used, dune
      will automatically edit the dune-project file. *)
   let automatic ~project_file ~f =
-    Hashtbl.foldi extensions ~init:[] ~f:(fun name ext acc ->
+    Hashtbl.foldi extensions ~init:[] ~f:(fun name extension acc ->
       if f name then
         let version =
-          if ext.experimental then
+          if is_experimental extension then
             (0, 0)
           else
-            Syntax.greatest_supported_version ext.syntax
+            Syntax.greatest_supported_version (syntax extension)
         in
         let parse_args p =
           let open Dsexp.Of_sexp in
@@ -266,7 +292,7 @@ module Extension = struct
              end;
              p))
         in
-        { extension = ext
+        { extension
         ; version
         ; loc = Loc.none
         ; parse_args
@@ -279,12 +305,12 @@ let make_parsing_context ~(lang : Lang.Instance.t) ~extensions =
   let acc = Univ_map.singleton (Syntax.key lang.syntax) lang.version in
   List.fold_left extensions ~init:acc
     ~f:(fun acc (ext : Extension.instance) ->
-      Univ_map.add acc (Syntax.key ext.extension.syntax) ext.version)
+      Univ_map.add acc (Syntax.key (Extension.syntax ext.extension)) ext.version)
 
 let key =
   Univ_map.Key.create ~name:"dune-project"
     (fun { name; root; version; project_file; kind
-         ; stanza_parser = _; packages = _ } ->
+         ; stanza_parser = _; packages = _ ; extension_args = _ } ->
       Sexp.To_sexp.record
         [ "name", Name.to_sexp name
         ; "root", Path.Local.to_sexp root
@@ -319,6 +345,7 @@ let anonymous = lazy (
   ; stanza_parser =
       Dsexp.Of_sexp.(set_many parsing_context (sum lang.data))
   ; project_file  = { file = Path.relative Path.root filename; exists = false }
+  ; extension_args = Univ_map.empty
   })
 
 let default_name ~dir ~packages =
@@ -351,7 +378,7 @@ let parse ~dir ~lang ~packages ~file =
   fields
     (let%map name = name_field ~dir ~packages
      and version = field_o "version" string
-     and extensions =
+     and explicit_extensions =
        multi_field "using"
          (let%map loc = loc
           and name = located string
@@ -364,33 +391,45 @@ let parse ~dir ~lang ~packages ~file =
      in
      match
        String.Map.of_list
-         (List.map extensions ~f:(fun (e : Extension.instance) ->
-            (Syntax.name e.extension.syntax, e.loc)))
+         (List.map explicit_extensions ~f:(fun (e : Extension.instance) ->
+            (Syntax.name (Extension.syntax e.extension), e.loc)))
      with
      | Error (name, _, loc) ->
        Errors.fail loc "Extension %S specified for the second time." name
      | Ok map ->
        let project_file : Project_file.t = { file; exists = true } in
        let extensions =
-         extensions @
+         explicit_extensions @
          Extension.automatic ~project_file
            ~f:(fun name -> not (String.Map.mem map name))
        in
        let parsing_context = make_parsing_context ~lang ~extensions in
-       let stanzas =
-         List.concat
-           (lang.data ::
-            List.map extensions ~f:(fun (ext : Extension.instance) ->
-              ext.parse_args
-                (Dsexp.Of_sexp.set_many parsing_context ext.extension.stanzas)))
+       let extension_args = ref Univ_map.empty in
+       let is_explicit e =
+         String.Map.mem map @@ Syntax.name @@ Extension.syntax e
+       in
+       let extension_stanzas =
+         List.map extensions ~f:(fun (ext : Extension.instance) ->
+           let extension = ext.extension in
+           let Extension.Extension e = extension in
+           let args =
+             let%map (arg, stanzas) = Dsexp.Of_sexp.set_many parsing_context e.stanzas
+             in
+             if is_explicit extension then
+               extension_args := Univ_map.add !extension_args e.key arg;
+             stanzas
+           in
+           ext.parse_args args)
        in
+       let stanzas = List.concat (lang.data :: extension_stanzas) in
        { kind = Dune
        ; name
        ; root = get_local_path dir
        ; version
        ; packages
        ; stanza_parser = Dsexp.Of_sexp.(set_many parsing_context (sum stanzas))
        ; project_file
+       ; extension_args = !extension_args
        })
 
 let load_dune_project ~dir packages =
@@ -408,6 +447,7 @@ let make_jbuilder_project ~dir packages =
   ; stanza_parser =
       Dsexp.Of_sexp.(set_many parsing_context (sum lang.data))
   ; project_file = { file = Path.relative dir filename; exists = false }
+  ; extension_args = Univ_map.empty
   }
 
 let read_name file =

src/dune_project.mli

@@ -56,6 +56,8 @@ module Lang : sig
 end
 
 module Extension : sig
+  type 'a key
+
   (** [register id parser] registers a new extension. Users will
       enable this extension by writing:
 
@@ -64,6 +66,13 @@ module Extension : sig
       in their [dune-project] file. [parser] is used to describe
       what [<args>] might be. *)
   val register
+    :  ?experimental:bool
+    -> Syntax.t
+    -> ('a * Stanza.Parser.t list) Dsexp.Of_sexp.t
+    -> ('a -> Sexp.t)
+    -> 'a key
+
+  val register_no_args
     :  ?experimental:bool
     -> Syntax.t
     -> Stanza.Parser.t list Dsexp.Of_sexp.t
@@ -93,3 +102,6 @@ val append_to_project_file : t -> string -> unit
 (** Set the project we are currently parsing dune files for *)
 val set : t -> ('a, 'k) Dsexp.Of_sexp.parser -> ('a, 'k) Dsexp.Of_sexp.parser
 val get_exn : unit -> (t, 'k) Dsexp.Of_sexp.parser
+
+(** Find arguments passed to (using) *)
+val find_extension_args : t -> 'a Extension.key -> 'a option