Make the (interface) field of a (dialect) optional

Signed-off-by: Guillaume Petiot <guillaume@tarides.com>

src/dune_rules/dialect.ml

@@ -45,7 +45,7 @@ end
 
 type t =
   { name : string
-  ; file_kinds : File_kind.t Ml_kind.Dict.t
+  ; file_kinds : File_kind.t Ml_kind.Dialect.t
   }
 
 let name t = t.name
@@ -54,15 +54,16 @@ let to_dyn { name; file_kinds } =
   let open Dyn in
   record
     [ ("name", string name)
-    ; ("file_kinds", Ml_kind.Dict.to_dyn File_kind.to_dyn file_kinds)
+    ; ("file_kinds", Ml_kind.Dialect.to_dyn File_kind.to_dyn file_kinds)
     ]
 
 let encode { name; file_kinds } =
   let open Dune_lang.Encoder in
   let file_kind_stanzas =
     let open Ml_kind in
     List.map ~f:File_kind.encode
-      [ Dict.get file_kinds Intf; Dict.get file_kinds Impl ]
+    @@ List.filter_opt
+    @@ [ Dialect.get file_kinds Intf; Dialect.get file_kinds Impl ]
   in
   let fields = record_fields [ field "name" string name ] @ file_kind_stanzas in
   list sexp (string "dialect" :: fields)
@@ -88,17 +89,23 @@ let decode =
   fields
     (let+ name = field "name" string
      and+ impl = field "implementation" (fields (kind Ml_kind.Impl))
-     and+ intf = field "interface" (fields (kind Ml_kind.Intf)) in
-     { name; file_kinds = Ml_kind.Dict.make ~intf ~impl })
+     and+ intf = field_o "interface" (fields (kind Ml_kind.Intf)) in
+     { name; file_kinds = Ml_kind.Dialect.make ~intf ~impl })
 
 let extension { file_kinds; _ } ml_kind =
-  (Ml_kind.Dict.get file_kinds ml_kind).extension
+  let open Option.O in
+  let+ x = Ml_kind.Dialect.get file_kinds ml_kind in
+  x.extension
 
 let preprocess { file_kinds; _ } ml_kind =
-  (Ml_kind.Dict.get file_kinds ml_kind).preprocess
+  let open Option.O in
+  let* x = Ml_kind.Dialect.get file_kinds ml_kind in
+  x.preprocess
 
 let format { file_kinds; _ } ml_kind =
-  (Ml_kind.Dict.get file_kinds ml_kind).format
+  let open Option.O in
+  let* x = Ml_kind.Dialect.get file_kinds ml_kind in
+  x.format
 
 let ocaml =
   let format kind =
@@ -126,9 +133,9 @@ let ocaml =
           , [ ".ocamlformat"; ".ocamlformat-ignore"; ".ocamlformat-enable" ] )
     }
   in
-  let intf = file_kind Ml_kind.Intf ".mli" in
+  let intf = Option.some @@ file_kind Ml_kind.Intf ".mli" in
   let impl = file_kind Ml_kind.Impl ".ml" in
-  { name = "ocaml"; file_kinds = Ml_kind.Dict.make ~intf ~impl }
+  { name = "ocaml"; file_kinds = Ml_kind.Dialect.make ~intf ~impl }
 
 let reason =
   let file_kind kind extension =
@@ -152,9 +159,9 @@ let reason =
     ; format = Some (Loc.none, format, [])
     }
   in
-  let intf = file_kind Ml_kind.Intf ".rei" in
+  let intf = Option.some @@ file_kind Ml_kind.Intf ".rei" in
   let impl = file_kind Ml_kind.Impl ".re" in
-  { name = "reason"; file_kinds = Ml_kind.Dict.make ~intf ~impl }
+  { name = "reason"; file_kinds = Ml_kind.Dialect.make ~intf ~impl }
 
 let rescript =
   let file_kind kind extension =
@@ -179,22 +186,23 @@ let rescript =
     ; format = Some (Loc.none, format, [])
     }
   in
-  let intf = file_kind Ml_kind.Intf ".resi" in
+  let intf = Option.some @@ file_kind Ml_kind.Intf ".resi" in
   let impl = file_kind Ml_kind.Impl ".res" in
-  { name = "rescript"; file_kinds = Ml_kind.Dict.make ~intf ~impl }
+  { name = "rescript"; file_kinds = Ml_kind.Dialect.make ~intf ~impl }
 
-let ml_suffix { file_kinds = { Ml_kind.Dict.intf; impl }; _ } ml_kind =
-  match (ml_kind, intf.preprocess, impl.preprocess) with
-  | Ml_kind.Intf, None, _ | Impl, _, None -> None
-  | _ -> Some (extension ocaml ml_kind)
+let ml_suffix { file_kinds = { Ml_kind.Dialect.intf; impl }; _ } ml_kind =
+  match (ml_kind, intf, impl.preprocess) with
+  | Ml_kind.Intf, (None | Some { preprocess = None; _ }), _ | Impl, _, None ->
+    None
+  | _ -> extension ocaml ml_kind
 
 module DB = struct
   type dialect = t
 
   type t =
     { by_name : dialect String.Map.t
     ; by_extension : dialect String.Map.t
-    ; mutable extensions_for_merlin : string Ml_kind.Dict.t list option
+    ; mutable extensions_for_merlin : string Ml_kind.Dialect.t list option
     }
 
   let fold { by_name; _ } = String.Map.fold by_name
@@ -208,18 +216,18 @@ module DB = struct
   let set_extensions_for_merlin t =
     let v =
       fold t ~init:[] ~f:(fun d s ->
-          let impl = extension d Ml_kind.Impl in
+          let impl = Option.value_exn @@ extension d Ml_kind.Impl in
           let intf = extension d Ml_kind.Intf in
           if
             (* Only include dialects with no preprocessing and skip default file
                extensions *)
             preprocess d Ml_kind.Impl <> None
             || preprocess d Ml_kind.Intf <> None
-            || impl = extension ocaml Ml_kind.Impl
+            || impl = Option.value_exn @@ extension ocaml Ml_kind.Impl
                && intf = extension ocaml Ml_kind.Intf
           then s
-          else { Ml_kind.Dict.impl; intf } :: s)
-      |> List.sort ~compare:(Ml_kind.Dict.compare String.compare)
+          else { Ml_kind.Dialect.impl; intf } :: s)
+      |> List.sort ~compare:(Ml_kind.Dialect.compare String.compare)
     in
     t.extensions_for_merlin <- Some v;
     v
@@ -247,9 +255,12 @@ module DB = struct
           ]
     in
     let by_extension =
-      add_ext
-        (add_ext by_extension dialect.file_kinds.intf.extension)
-        dialect.file_kinds.impl.extension
+      let by_extension =
+        Option.value ~default:by_extension
+        @@ Option.map dialect.file_kinds.intf ~f:(fun intf ->
+               add_ext by_extension intf.extension)
+      in
+      add_ext by_extension dialect.file_kinds.impl.extension
     in
     { by_name; by_extension; extensions_for_merlin = None }
 
@@ -262,8 +273,9 @@ module DB = struct
     Option.map
       ~f:(fun dialect ->
         let kind =
-          if dialect.file_kinds.intf.extension = extension then Ml_kind.Intf
-          else Ml_kind.Impl
+          match dialect.file_kinds.intf with
+          | Some intf when intf.extension = extension -> Ml_kind.Intf
+          | _ -> Ml_kind.Impl
         in
         (dialect, kind))
       (String.Map.find by_extension extension)

src/dune_rules/dialect.mli

@@ -29,7 +29,7 @@ val encode : t Dune_lang.Encoder.t
 
 val decode : t Dune_lang.Decoder.t
 
-val extension : t -> Ml_kind.t -> string
+val extension : t -> Ml_kind.t -> string option
 
 val preprocess : t -> Ml_kind.t -> (Loc.t * Dune_lang.Action.t) option
 
@@ -58,7 +58,7 @@ module DB : sig
 
   val fold : t -> init:'a -> f:(dialect -> 'a -> 'a) -> 'a
 
-  val extensions_for_merlin : t -> string Ml_kind.Dict.t list
+  val extensions_for_merlin : t -> string Ml_kind.Dialect.t list
 
   val to_dyn : t -> Dyn.t
 

src/dune_rules/merlin/merlin.ml

@@ -47,7 +47,7 @@ module Processed = struct
     ; obj_dirs : Path.Set.t
     ; src_dirs : Path.Set.t
     ; flags : string list
-    ; extensions : string Ml_kind.Dict.t list
+    ; extensions : string Ml_kind.Dialect.t list
     ; melc_flags : string list
     }
 
@@ -59,7 +59,7 @@ module Processed = struct
       ; ("obj_dirs", Path.Set.to_dyn obj_dirs)
       ; ("src_dirs", Path.Set.to_dyn src_dirs)
       ; ("flags", list string flags)
-      ; ("extensions", list (Ml_kind.Dict.to_dyn string) extensions)
+      ; ("extensions", list (Ml_kind.Dialect.to_dyn string) extensions)
       ; ("melc_flags", list string melc_flags)
       ]
 
@@ -171,8 +171,10 @@ module Processed = struct
         :: flags
     in
     let suffixes =
-      List.map extensions ~f:(fun { Ml_kind.Dict.impl; intf } ->
-          make_directive "SUFFIX" (Sexp.Atom (Printf.sprintf "%s %s" impl intf)))
+      List.map extensions ~f:(fun { Ml_kind.Dialect.impl; intf } ->
+          make_directive "SUFFIX"
+            (Sexp.Atom
+               (Printf.sprintf "%s %s" impl (Option.value intf ~default:""))))
     in
     Sexp.List
       (List.concat
@@ -198,8 +200,9 @@ module Processed = struct
         printf "STDLIB %s\n" (serialize_path stdlib_dir));
     Path.Set.iter obj_dirs ~f:(fun p -> printf "B %s\n" (serialize_path p));
     Path.Set.iter src_dirs ~f:(fun p -> printf "S %s\n" (serialize_path p));
-    List.iter extensions ~f:(fun { Ml_kind.Dict.impl; intf } ->
-        printf "SUFFIX %s" (Printf.sprintf "%s %s" impl intf));
+    List.iter extensions ~f:(fun { Ml_kind.Dialect.impl; intf } ->
+        printf "SUFFIX %s"
+          (Printf.sprintf "%s %s" impl (Option.value intf ~default:"")));
     (* We print all FLG directives as comments *)
     List.iter pp_configs
       ~f:
@@ -322,7 +325,7 @@ module Unprocessed = struct
     ; libname : Lib_name.Local.t option
     ; source_dirs : Path.Source.Set.t
     ; objs_dirs : Path.Set.t
-    ; extensions : string Ml_kind.Dict.t list
+    ; extensions : string Ml_kind.Dialect.t list
     ; mode : Lib_mode.t
     }
 

src/dune_rules/module.ml

@@ -377,7 +377,10 @@ let decode_old ~src_dir =
        if exists then
          let module_basename n ~(ml_kind : Ml_kind.t) ~(dialect : Dialect.t) =
            let n = Module_name.to_string n in
-           String.lowercase n ^ Dialect.extension dialect ml_kind
+           let ext =
+             Option.value (Dialect.extension dialect ml_kind) ~default:""
+           in
+           String.lowercase n ^ ext
          in
          let basename = module_basename name ~ml_kind ~dialect:Dialect.ocaml in
          Some (File.make Dialect.ocaml (Path.relative src_dir basename))

src/ocaml/ml_kind.ml

@@ -54,3 +54,30 @@ module Dict = struct
     let open Dyn in
     record [ ("impl", f impl); ("intf", f intf) ]
 end
+
+module Dialect = struct
+  type 'a t =
+    { impl : 'a
+    ; intf : 'a option
+    }
+
+  let get t = function
+    | Impl -> Some t.impl
+    | Intf -> t.intf
+
+  let make ~impl ~intf = { impl; intf }
+
+  let to_dyn f { impl; intf } =
+    let open Dyn in
+    let fields =
+      match intf with
+      | Some intf -> [ ("impl", f impl); ("intf", f intf) ]
+      | None -> [ ("impl", f impl) ]
+    in
+    record fields
+
+  let compare f { impl; intf } t =
+    let open Ordering.O in
+    let= () = f impl t.impl in
+    Option.compare f intf t.intf
+end

src/ocaml/ml_kind.mli

@@ -43,3 +43,20 @@ module Dict : sig
 
   val map : 'a t -> f:('a -> 'b) -> 'b t
 end
+
+module Dialect : sig
+  type kind := t
+
+  type 'a t =
+    { impl : 'a
+    ; intf : 'a option
+    }
+
+  val get : 'a t -> kind -> 'a option
+
+  val make : impl:'a -> intf:'a option -> 'a t
+
+  val to_dyn : ('a -> Dyn.t) -> 'a t -> Dyn.t
+
+  val compare : ('a -> 'a -> Ordering.t) -> 'a t -> 'a t -> Ordering.t
+end

test/blackbox-tests/test-cases/dialects/no_intf.t/dune

@@ -0,0 +1,9 @@
+(executable
+ (name main)
+ (public_name main)
+ (modules main))
+
+(executable
+ (name fmt)
+ (public_name fmt)
+ (modules fmt))

test/blackbox-tests/test-cases/dialects/no_intf.t/dune-project

@@ -0,0 +1,8 @@
+(lang dune 1.11)
+(using fmt 1.2 (enabled_for mlfi))
+
+(dialect
+ (name mlfi)
+ (implementation
+  (extension mf)
+  (format (run fmt %{input-file}))))

test/blackbox-tests/test-cases/dialects/no_intf.t/fmt.ml

@@ -0,0 +1 @@
+prerr_endline ("Formatting " ^ Sys.argv.(1))

test/blackbox-tests/test-cases/dialects/no_intf.t/run.t

@@ -0,0 +1,6 @@
+Test the (dialect ...) stanza inside the dune-project file.
+
+  $ dune exec ./main.exe
+
+  $ dune build @fmt
+  Formatting main.mf