Merge pull request #357 from Leonidas-from-XIV/mli-metadata-labels

Recognize metadata labels in `mli` files

Author: Leonidas-from-XIV

CHANGES.md

@@ -2,6 +2,9 @@
 
 #### Added
 
+- Add support for adding language tags and metadata labels in `mli` files.
+  (#339, #357, @julow, @Leonidas-from-XIV)
+
 #### Changed
 
 #### Deprecated

README.md

@@ -13,13 +13,6 @@ and to practice "literate programming" using markdown and OCaml.
 The test mode allows to ensure that shell scripts and OCaml fragments
 in the documentation always stays up-to-date.
 
-The blocks in markdown files can be parameterized by `mdx`-specific labels, that
-will change the way `mdx` interprets the block.
-The syntax is: `<!-- $MDX labels -->`, where `labels` is a list of valid labels
-separated by a comma. This line has to immediately precede the block it is
-attached to. Examples are given in the following sections.
-This syntax is the recommended way to define labels since `mdx` 1.7.0, to use the previous syntax please refer to the [mdx 1.6.0 README](https://github.com/realworldocaml/mdx/blob/1.6.0/README.md).
-
 `mdx` is released as a single binary (called `ocaml-mdx`) and
 can be installed using opam:
 
@@ -32,6 +25,33 @@ If you want to contribute or hack on the project, please see the
 
 ### Supported Extensions
 
+#### Labels
+
+The blocks in markdown files can be parameterized by `mdx`-specific labels, that
+will change the way `mdx` interprets the block.
+
+The syntax is: `<!-- $MDX LABELS -->`, where `LABELS` is a list of valid labels
+separated by a comma. This line has to immediately precede the block it is
+attached to.
+
+    <!-- $MDX LABELS -->
+    ```ocaml
+    ```
+
+This syntax is the recommended way to define labels since `mdx` 1.7.0, to use
+the previous syntax please refer to the
+[mdx 1.6.0 README](https://github.com/realworldocaml/mdx/blob/1.6.0/README.md).
+
+It is also possible to use labels in OCaml interface files (`mli`), the syntax
+for this is is slightly different to match the conventions of OCaml
+documentation comments:
+
+    (** This is an documentation comment with an ocaml block
+        {@ocaml LABELS [
+        ]}
+    *)
+
+
 #### Shell Scripts
 
 `ocaml-mdx` interprets shell scripts inside `sh` code blocks as cram-like tests. The

dune-project

@@ -35,6 +35,6 @@
   result
   (ocaml-version
    (>= 2.3.0))
-  (odoc-parser (>= 0.9.0))
+  (odoc-parser (>= 1.0.0))
   (lwt :with-test)
   (alcotest :with-test)))

lib/block.ml

@@ -131,9 +131,9 @@ let lstrip string =
 
 let pp_contents ?syntax ppf t =
   match (syntax, t.contents) with
-  | Some Syntax.Mli, [ _ ] -> Fmt.pf ppf "%s" (String.concat "\n" t.contents)
-  | Some Syntax.Mli, _ ->
-      Fmt.pf ppf "\n%a" (pp_lines syntax t) (List.map lstrip t.contents)
+  | Some Syntax.Mli, [ line ] -> Fmt.pf ppf "%s" line
+  | Some Syntax.Mli, lines ->
+      Fmt.pf ppf "@\n%a@\n" (pp_lines syntax t) (List.map lstrip lines)
   | (Some Cram | Some Normal | None), [] -> ()
   | (Some Cram | Some Normal | None), _ ->
       Fmt.pf ppf "%a\n" (pp_lines syntax t) t.contents
@@ -146,10 +146,9 @@ let pp_errors ppf t =
       Fmt.string ppf "```\n"
   | _ -> ()
 
-let pp_footer ?syntax ppf t =
+let pp_footer ?syntax ppf _ =
   match syntax with
-  | Some Syntax.Mli ->
-      if List.length t.contents = 1 then Fmt.pf ppf "" else Fmt.pf ppf "\n"
+  | Some Syntax.Mli -> ()
   | Some Syntax.Cram -> ()
   | _ -> Fmt.string ppf "```\n"
 

lib/cram.ml

@@ -20,7 +20,12 @@ module Log = (val Logs.src_log src : Logs.LOG)
 open Astring
 open Misc
 
-type t = { command : string list; output : Output.t list; exit_code : int }
+type t = {
+  command : string list;
+  output : Output.t list;
+  exit_code : int;
+  vpad : int;
+}
 
 let dump_line ppf = function
   | #Output.t as o -> Output.dump ppf o
@@ -37,10 +42,20 @@ let dump ppf (t : t) =
     Fmt.(Dump.list Output.dump)
     t.output t.exit_code
 
+let pp_vpad ppf t =
+  let rec loop = function
+    | 0 -> ()
+    | n ->
+        Fmt.pf ppf "\n";
+        loop (Int.pred n)
+  in
+  loop t.vpad
+
 let pp_command ?(pad = 0) ppf (t : t) =
   match t.command with
   | [] -> ()
   | l ->
+      pp_vpad ppf t;
       let sep ppf () = Fmt.pf ppf "\\\n%a> " pp_pad pad in
       Fmt.pf ppf "%a$ %a\n" pp_pad pad Fmt.(list ~sep string) l
 
@@ -52,7 +67,7 @@ let pp ?pad ppf (t : t) =
   pp_lines (Output.pp ?pad) ppf t.output;
   pp_exit_code ?pad ppf t.exit_code
 
-let pad_of_lines = function
+let hpad_of_lines = function
   | [] -> 0
   | h :: _ ->
       let i = ref 0 in
@@ -61,22 +76,29 @@ let pad_of_lines = function
       done;
       !i
 
-let of_lines t =
-  let pad = pad_of_lines t in
+let of_lines ~syntax ~(loc : Location.t) t =
+  let pos = loc.loc_start in
+  let hpad =
+    match syntax with Syntax.Mli -> pos.pos_cnum + 2 | _ -> hpad_of_lines t
+  in
   let unpad line =
-    if String.is_empty line then line
-    else if String.length line < pad then
-      Fmt.failwith "invalid padding: %S" line
-    else String.with_index_range line ~first:pad
+    match syntax with
+    | Syntax.Mli -> String.trim line
+    | _ ->
+        if String.is_empty line then line
+        else if String.length line < hpad then
+          Fmt.failwith "invalid padding: %S" line
+        else String.with_index_range line ~first:hpad
   in
   let lines = List.map unpad t in
   let lines =
     Lexer_cram.token (Lexing.from_string (String.concat ~sep:"\n" lines))
   in
+  let vpad = match syntax with Syntax.Mli -> 1 | _ -> 0 in
   Log.debug (fun l ->
-      l "Cram.of_lines (pad=%d) %a" pad Fmt.(Dump.list dump_line) lines);
+      l "Cram.of_lines (pad=%d) %a" hpad Fmt.(Dump.list dump_line) lines);
   let mk command output exit_code =
-    { command; output = List.rev output; exit_code }
+    { command; output = List.rev output; exit_code; vpad }
   in
   let rec command_cont acc = function
     | `Command_cont c :: t -> command_cont (c :: acc) t
@@ -101,8 +123,8 @@ let of_lines t =
   match lines with
   | `Command_first cmd :: t ->
       let cmd, t = command_cont [ cmd ] t in
-      (pad, aux cmd [] [] t)
-  | `Command cmd :: t -> (pad, aux [ cmd ] [] [] t)
+      (hpad, aux cmd [] [] t)
+  | `Command cmd :: t -> (hpad, aux [ cmd ] [] [] t)
   | [] -> (0, [])
   | `Output line :: _ ->
       if String.length line > 0 && line.[0] = '$' then

lib/cram.mli

@@ -16,7 +16,12 @@
 
 (** Cram tests *)
 
-type t = { command : string list; output : Output.t list; exit_code : int }
+type t = {
+  command : string list;
+  output : Output.t list;
+  exit_code : int;
+  vpad : int;
+}
 (** The type for cram tests. *)
 
 (** {2 Accessors} *)
@@ -34,7 +39,7 @@ val command_line : t -> string
 
 (** {2 Parser} *)
 
-val of_lines : string list -> int * t list
+val of_lines : syntax:Syntax.t -> loc:Location.t -> string list -> int * t list
 (** [of_lines l] parses the commands [l]. It returns the optional
    whitespace padding. *)
 

lib/mli_parser.ml

@@ -1,7 +1,14 @@
-open! Compat
-
 module Code_block = struct
-  type t = { location : Odoc_parser.Loc.span; contents : string }
+  type metadata = {
+    language_tag : string Odoc_parser.Loc.with_location;
+    labels : string Odoc_parser.Loc.with_location option;
+  }
+
+  type t = {
+    location : Odoc_parser.Loc.span;
+    metadata : metadata option;
+    contents : string;
+  }
 end
 
 let drop_last lst =
@@ -51,8 +58,14 @@ let extract_code_blocks ~(location : Lexing.position) ~docstring =
     List.map
       (fun block ->
         match Odoc_parser.Loc.value block with
-        | `Code_block (_metadata, { Odoc_parser.Loc.value = contents; _ }) ->
-            [ { Code_block.location = block.location; contents } ]
+        | `Code_block (metadata, { Odoc_parser.Loc.value = contents; _ }) ->
+            let metadata =
+              Option.map
+                (fun (language_tag, labels) ->
+                  Code_block.{ language_tag; labels })
+                metadata
+            in
+            [ { Code_block.location = block.location; metadata; contents } ]
         | `List (_, _, lists) -> List.map acc lists |> List.concat
         | _ -> [])
       blocks
@@ -118,6 +131,53 @@ let docstring_code_blocks str =
     (docstrings (Lexing.from_string str))
   |> List.concat
 
+let make_block ~loc code_block =
+  let handle_header = function
+    | Some Code_block.{ language_tag; labels } -> (
+        let header =
+          Block.Header.of_string (Odoc_parser.Loc.value language_tag)
+        in
+        match labels with
+        | None -> Ok (header, [])
+        | Some labels -> (
+            let labels = Odoc_parser.Loc.value labels |> String.trim in
+            match Label.of_string labels with
+            | Ok labels -> Ok (header, labels)
+            | Error msgs -> Error (List.hd msgs)
+            (* TODO: Report precise location *)))
+    | None ->
+        (* If not specified, blocks are run as ocaml blocks *)
+        Ok (Some OCaml, [])
+  in
+  match handle_header code_block.Code_block.metadata with
+  | Error _ as e -> e
+  | Ok (header, labels) ->
+      let contents = String.split_on_char '\n' code_block.contents in
+      Block.mk ~loc ~section:None ~labels ~header ~contents ~legacy_labels:false
+        ~errors:[]
+
+let code_block_markup code_block =
+  let open Document in
+  let opening =
+    match code_block.Code_block.metadata with
+    | Some { language_tag; labels } ->
+        let labels =
+          match labels with
+          | Some s -> [ Text " "; Text (Odoc_parser.Loc.value s) ]
+          | None -> []
+        in
+        [ Text "{@"; Text (Odoc_parser.Loc.value language_tag) ]
+        @ labels @ [ Text "[" ]
+    | None -> [ Text "{[" ]
+  in
+  let hpad =
+    let has_several_lines = String.contains code_block.contents '\n' in
+    let column = code_block.location.start.column in
+    if not has_several_lines then ""
+    else Astring.String.v ~len:column (fun _ -> ' ')
+  in
+  (opening, [ Text (hpad ^ "]}") ])
+
 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
@@ -132,22 +192,15 @@ let parse_mli file_contents =
           Document.Text
             (slice lines ~start:!cursor ~end_:code_block.location.start)
         in
-        let column = code_block.location.start.column in
-        let contents = String.split_on_char '\n' code_block.contents in
         let block =
-          match
-            Block.mk ~loc ~section:None ~labels:[] ~header:(Some OCaml)
-              ~contents ~legacy_labels:false ~errors:[]
-          with
+          match make_block ~loc code_block with
           | Ok block -> Document.Block block
-          | Error _ -> failwith "Error creating block"
-        in
-        let hpad =
-          if List.length contents = 1 then ""
-          else Astring.String.v ~len:column (fun _ -> ' ')
+          | Error (`Msg msg) ->
+              failwith (Fmt.str "Error creating block: %s" msg)
         in
+        let opening, closing = code_block_markup code_block in
         cursor := code_block.location.end_;
-        [ pre_text; Text "{["; block; Text (hpad ^ "]}") ])
+        [ pre_text ] @ opening @ [ block ] @ closing)
       code_blocks
     |> List.concat
   in

lib/test/mdx_test.ml

@@ -197,7 +197,7 @@ let run_toplevel_tests ?syntax ?root c ppf tests t =
               Output.pp ~pad ppf (`Output line))
         output)
     tests;
-  match syntax with Some Syntax.Mli -> () | _ -> Block.pp_footer ?syntax ppf t
+  Block.pp_footer ?syntax ppf t
 
 type file = { first : Mdx.Part.file; current : Mdx.Part.file }
 
@@ -305,7 +305,11 @@ let run_exn ~non_deterministic ~silent_eval ~record_backtrace ~syntax ~silent
           with_non_det non_deterministic non_det ~command:print_block
             ~output:det ~det
       | Cram { language = _; non_det } ->
-          let pad, tests = Cram.of_lines t.contents in
+          let pad, tests =
+            Cram.of_lines
+              ~syntax:(Option.value ~default:Normal syntax)
+              ~loc:t.loc t.contents
+          in
           with_non_det non_deterministic non_det ~command:print_block
             ~output:(fun () ->
               print_block ();

mdx.opam

@@ -30,7 +30,7 @@ depends: [
   "re" {>= "1.7.2"}
   "result"
   "ocaml-version" {>= "2.3.0"}
-  "odoc-parser" {>= "0.9.0"}
+  "odoc-parser" {>= "1.0.0"}
   "lwt" {with-test}
   "alcotest" {with-test}
   "odoc" {with-doc}

test/bin/mdx-test/expect/simple-mli/test-case.mli

@@ -19,14 +19,33 @@
       print_endline (String.concat " " [the; last; phrase])
     ]}
 
-    {[
+    With the optional header:
+
+    {@ocaml[
       # List.map (fun x -> x * x) [(1 + 9); 2; 3];;
       - : int list = [100; 4; 9]
       # List.map (fun x -> x * x) [1; 2; 3];;
       - : int list = [1; 4; 9]
     ]}
+
+    A shell block:
+
+    {@sh set-FOO=Hello,set-BAR=Bash[
+      $ echo $FOO $BAR
+      Hello Bash
+    ]}
+
+    A block that doesn't run:
+
+    {@text[
+      # 1
+      = 2 ?
+    ]}
 *)
 val foo : string
 
-(** {[1 + 1 = 3]} *)
+(** {@ocaml[1 + 1 = 3]} *)
 val bar : string
+
+(** {@ocaml skip[1 + 1 = 3]} *)
+val baz : string