Merge pull request #423 from jonludlam/add-mld-support-v2

Add mld support v2

Author: Leonidas-from-XIV

CHANGES.md

@@ -6,6 +6,8 @@
 
 #### Added
 
+- Added support for `mld` files (#423, @jonludlam)
+
 #### Changed
 
 #### Deprecated

README.md

@@ -2,7 +2,7 @@
 
 ## MDX
 
-MDX allows to execute code blocks inside markdown and mli documentation
+MDX allows to execute code blocks inside markdown and mli/mld documentation
 to help keeping them up to date.
 
 Use the
@@ -20,7 +20,7 @@ If you want to contribute to the project, please see the
 
 ### Basic Usage
 
-You can use MDX with your Markdown or `.mli` documentation, which ensures
+You can use MDX with your Markdown or `.ml{i,d}` documentation, which ensures
 code in multi-line or verbatim code blocks is correct.
 
 To enable MDX on specific files you must first enable it for your project by
@@ -113,7 +113,7 @@ dune promote
 Now the documentation is up-to-date and running `dune runtest` again should be
 successful!
 
-Note that to use the `dune runtest/promote` workflow with `mli` files,
+Note that to use the `dune runtest/promote` workflow with `mli` or `mld` files,
 you will need to adjust the `mdx` stanza in the `dune` file, as by
 [default](https://dune.readthedocs.io/en/latest/dune-files.html#mdx-since-2-4),
 Dune only checks markdown files with `mdx`.  E.g.,
@@ -138,7 +138,7 @@ block it is attached to.
     ```ocaml
     ```
 
-The `.mli` syntax for this is is slightly different to match the conventions of
+The `.mli` and `.mld` syntax for this is is slightly different to match the conventions of
 OCaml documentation comments:
 
     (** This is an documentation comment with an ocaml block

lib/block.ml

@@ -171,7 +171,7 @@ let pp_errors ppf t =
 
 let pp_footer ?syntax ppf _ =
   match syntax with
-  | Some Syntax.Mli -> Fmt.string ppf "]}"
+  | Some Syntax.Mli | Some Syntax.Mld -> Fmt.string ppf "]}"
   | Some Syntax.Cram -> Fmt.string ppf "\n"
   | Some Syntax.Markdown | None -> Fmt.string ppf "```\n"
 
@@ -181,7 +181,8 @@ let pp_legacy_labels ppf = function
 
 let pp_labels ?syntax ppf labels =
   match syntax with
-  | Some Syntax.Mli -> Fmt.(list ~sep:(any ",") Label.pp) ppf labels
+  | Some Syntax.Mli | Some Syntax.Mld ->
+      Fmt.(list ~sep:(any ",") Label.pp) ppf labels
   | Some Syntax.Cram -> (
       match labels with
       | [] -> ()
@@ -199,7 +200,7 @@ let pp_labels ?syntax ppf labels =
 
 let pp_header ?syntax ppf t =
   match syntax with
-  | Some Syntax.Mli ->
+  | Some Syntax.Mli | Some Syntax.Mld ->
       let lang_headers, other_labels =
         List.partition
           (function Label.Language_tag _ -> true | _ -> false)

lib/mdx.ml

@@ -71,6 +71,7 @@ let parse l =
 let parse_lexbuf syntax Misc.{ string; lexbuf } =
   match syntax with
   | Syntax.Mli -> Mli_parser.parse_mli string
+  | Syntax.Mld -> Mli_parser.parse_mld string
   | Markdown ->
       Util.Result.to_error_list @@ Lexer_mdx.markdown_token lexbuf >>= parse
   | Cram -> Util.Result.to_error_list @@ Lexer_mdx.cram_token lexbuf >>= parse
@@ -80,6 +81,7 @@ let parse_file syntax f = Misc.load_file ~filename:f |> parse_lexbuf syntax
 let of_string syntax s =
   match syntax with
   | Syntax.Mli -> Mli_parser.parse_mli s
+  | Syntax.Mld -> Mli_parser.parse_mld s
   | Syntax.Markdown | Syntax.Cram ->
       Misc.{ lexbuf = Lexing.from_string s; string = s } |> parse_lexbuf syntax
 

lib/mli_parser.ml

@@ -150,11 +150,10 @@ let make_block code_block file_contents =
       Block.mk ~loc:code_block.code_block ~section:None ~labels ~header
         ~contents ~legacy_labels:false ~errors:[]
 
-let parse_mli file_contents =
-  (* Find the locations of the code blocks within [file_contents], then slice it up into
-     [Text] and [Block] parts by using the starts and ends of those blocks as
-     boundaries. *)
-  let code_blocks = docstring_code_blocks file_contents in
+(* Given the locations of the code blocks within [file_contents], then slice it up into
+   [Text] and [Block] parts by using the starts and ends of those blocks as
+   boundaries. *)
+let extract_blocks code_blocks file_contents =
   let cursor, tokens =
     List.fold_left
       (fun (cursor, code_blocks) (code_block : Code_block.t) ->
@@ -183,5 +182,16 @@ let parse_mli file_contents =
   else tokens
 
 let parse_mli file_contents =
-  try Ok (parse_mli file_contents)
+  try
+    let code_blocks = docstring_code_blocks file_contents in
+    Ok (extract_blocks code_blocks file_contents)
   with exn -> Error [ `Msg (Printexc.to_string exn) ]
+
+let parse_mld ?(filename = "_none_") file_contents =
+  let location =
+    Lexing.{ pos_bol = 0; pos_lnum = 1; pos_cnum = 0; pos_fname = filename }
+  in
+  let code_blocks =
+    extract_code_block_info [] ~location ~docstring:file_contents |> List.rev
+  in
+  Ok (extract_blocks code_blocks file_contents)

lib/mli_parser.mli

@@ -1,2 +1,8 @@
 val parse_mli : string -> (Document.line list, [ `Msg of string ] list) result
 (** Slice an mli file into its [Text] and [Block] parts. *)
+
+val parse_mld :
+  ?filename:string ->
+  string ->
+  (Document.line list, [ `Msg of string ] list) result
+(** Slice an mld file into its [Text] and [Block] parts. *)

lib/syntax.ml

@@ -1,9 +1,10 @@
-type t = Markdown | Cram | Mli
+type t = Markdown | Cram | Mli | Mld
 
 let pp fs = function
   | Markdown -> Fmt.string fs "markdown"
   | Cram -> Fmt.string fs "cram"
   | Mli -> Fmt.string fs "mli"
+  | Mld -> Fmt.string fs "mld"
 
 let equal x y = x = y
 
@@ -12,10 +13,12 @@ let infer ~file =
   | ".t" -> Some Cram
   | ".md" -> Some Markdown
   | ".mli" -> Some Mli
+  | ".mld" -> Some Mld
   | _ -> None
 
 let of_string = function
   | "markdown" | "normal" -> Some Markdown
   | "cram" -> Some Cram
   | "mli" -> Some Mli
+  | "mld" -> Some Mld
   | _ -> None

lib/syntax.mli

@@ -1,4 +1,4 @@
-type t = Markdown | Cram | Mli
+type t = Markdown | Cram | Mli | Mld
 
 val pp : Format.formatter -> t -> unit
 val equal : t -> t -> bool

test/bin/gen_rule_helpers/gen_rule_helpers.ml

@@ -37,9 +37,10 @@ let get_files dir =
   read_dir dir |> List.filter is_file
 
 let cwd_options_file = "test-case.opts"
-let cwd_test_file_md = "test-case.md"
-let cwd_test_file_t = "test-case.t"
-let cwd_test_file_mli = "test-case.mli"
+
+let cwd_test_files =
+  [ "test-case.md"; "test-case.t"; "test-case.mli"; "test-case.mld" ]
+
 let cwd_enabled_if_file = "test-case.enabled-if"
 
 type dir = {
@@ -52,20 +53,14 @@ type dir = {
 }
 
 let test_file ~dir_name files =
-  let is_test_file f =
-    f = cwd_test_file_md || f = cwd_test_file_t || f = cwd_test_file_mli
-  in
+  let is_test_file f = List.mem f cwd_test_files in
   match List.filter is_test_file files with
   | [ test_file ] -> test_file
-  | [] ->
-      Printf.eprintf "No test file for %s\n" dir_name;
-      Printf.eprintf "There should be one of %s, %s, or %s\n" cwd_test_file_md
-        cwd_test_file_t cwd_test_file_mli;
-      exit 1
-  | _ ->
-      Printf.eprintf "More than one test file for %s\n" dir_name;
-      Printf.eprintf "There should be only one of %s, %s, or %s\n"
-        cwd_test_file_md cwd_test_file_t cwd_test_file_mli;
+  | found_files ->
+      Format.eprintf "Invalid number of test file for %s (found %a)\n" dir_name
+        pp_string_list found_files;
+      Format.eprintf "There should be exactly one of [%a]\n" pp_string_list
+        cwd_test_files;
       exit 1
 
 let expected_file ~dir_name ~test_file files =

test/bin/mdx-test/expect/dune.inc

@@ -467,6 +467,18 @@
  (alias runtest)
  (action (diff shell-file-inc/test-case.md.expected shell-file-inc.actual)))
 
+(rule
+ (target simple-mld.actual)
+ (deps (package mdx) (source_tree simple-mld))
+ (action
+  (with-stdout-to %{target}
+   (chdir simple-mld
+    (run ocaml-mdx test --output - --syntax=mld test-case.mld)))))
+
+(rule
+ (alias runtest)
+ (action (diff simple-mld/test-case.mld simple-mld.actual)))
+
 (rule
  (target simple-mli.actual)
  (deps (package mdx) (source_tree simple-mli))