diff --git a/src/dune_rules/dialect.ml b/src/dune_rules/dialect.ml index cbe815918dbb..eedd1dbc1781 100644 --- a/src/dune_rules/dialect.ml +++ b/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,7 +54,7 @@ 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 } = @@ -62,7 +62,8 @@ let encode { name; file_kinds } = 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,14 +186,15 @@ 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 @@ -194,7 +202,7 @@ module DB = struct 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) diff --git a/src/dune_rules/dialect.mli b/src/dune_rules/dialect.mli index ee68798cad34..94f7f03e2176 100644 --- a/src/dune_rules/dialect.mli +++ b/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 diff --git a/src/dune_rules/merlin/merlin.ml b/src/dune_rules/merlin/merlin.ml index 4f7771ac7bf1..ad4db5e2355f 100644 --- a/src/dune_rules/merlin/merlin.ml +++ b/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 } diff --git a/src/dune_rules/module.ml b/src/dune_rules/module.ml index cbf1d7f6c0b1..53b680f6e72c 100644 --- a/src/dune_rules/module.ml +++ b/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)) diff --git a/src/ocaml/ml_kind.ml b/src/ocaml/ml_kind.ml index 147fa474c8d7..6a365c674a38 100644 --- a/src/ocaml/ml_kind.ml +++ b/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 diff --git a/src/ocaml/ml_kind.mli b/src/ocaml/ml_kind.mli index 7b60a8bc6796..b4f1245e9b5e 100644 --- a/src/ocaml/ml_kind.mli +++ b/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 diff --git a/test/blackbox-tests/test-cases/dialects/no_intf.t/.ocamlformat b/test/blackbox-tests/test-cases/dialects/no_intf.t/.ocamlformat new file mode 100644 index 000000000000..e69de29bb2d1 diff --git a/test/blackbox-tests/test-cases/dialects/no_intf.t/dune b/test/blackbox-tests/test-cases/dialects/no_intf.t/dune new file mode 100644 index 000000000000..bd4d0d55a2b7 --- /dev/null +++ b/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)) diff --git a/test/blackbox-tests/test-cases/dialects/no_intf.t/dune-project b/test/blackbox-tests/test-cases/dialects/no_intf.t/dune-project new file mode 100644 index 000000000000..199e973b9c8b --- /dev/null +++ b/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})))) diff --git a/test/blackbox-tests/test-cases/dialects/no_intf.t/fmt.ml b/test/blackbox-tests/test-cases/dialects/no_intf.t/fmt.ml new file mode 100644 index 000000000000..7ff80db14f4c --- /dev/null +++ b/test/blackbox-tests/test-cases/dialects/no_intf.t/fmt.ml @@ -0,0 +1 @@ +prerr_endline ("Formatting " ^ Sys.argv.(1)) diff --git a/test/blackbox-tests/test-cases/dialects/no_intf.t/main.mf b/test/blackbox-tests/test-cases/dialects/no_intf.t/main.mf new file mode 100644 index 000000000000..e69de29bb2d1 diff --git a/test/blackbox-tests/test-cases/dialects/no_intf.t/main.opam b/test/blackbox-tests/test-cases/dialects/no_intf.t/main.opam new file mode 100644 index 000000000000..e69de29bb2d1 diff --git a/test/blackbox-tests/test-cases/dialects/no_intf.t/run.t b/test/blackbox-tests/test-cases/dialects/no_intf.t/run.t new file mode 100644 index 000000000000..7ca3ddc88e87 --- /dev/null +++ b/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