Merge pull request #439 from gpetiot/odoc.2.3.0

Upgrade mdx to use last version of odoc-parser
realworldocaml · Oct 30, 2023 · 3226c6e · 3226c6e
2 parents 526248a + abf4a61
commit 3226c6e
Show file tree

Hide file tree

Showing 20 changed files with 1,044 additions and 125 deletions.
diff --git a/CHANGES.md b/CHANGES.md
@@ -1,3 +1,9 @@
+### unreleased
+
+#### Added
+
+- Handle the error-blocks syntax (#439, @jonludlam, @gpetiot)
+
 ### 2.3.1
 
 #### Added

diff --git a/lib/block.ml b/lib/block.ml
@@ -114,6 +114,7 @@ type t = {
   os_type_enabled : bool;
   set_variables : (string * string) list;
   unset_variables : string list;
+  delim : string option;
   value : value;
 }
 
@@ -160,19 +161,61 @@ let rec error_padding = function
       let xs = error_padding xs in
       x :: xs
 
-let pp_errors ppf t =
+let compute_delimiter ~base_delim outputs =
+  let s =
+    Format.asprintf "%a" (Format.pp_print_list (Output.pp ~pad:0)) outputs
+  in
+  let is_inadequate delim =
+    Astring.String.is_infix ~affix:("]" ^ delim ^ "}") s
+  in
+  let rec loop n =
+    let delim =
+      match n with 0 -> base_delim | n -> Format.sprintf "%s_%d" base_delim n
+    in
+    if is_inadequate delim then loop (n + 1) else delim
+  in
+  loop 0
+
+let pp_error ?syntax ?delim ppf outputs =
+  match syntax with
+  | Some Syntax.Markdown ->
+      Fmt.pf ppf "```\n```mdx-error\n%a\n"
+        Fmt.(list ~sep:(any "\n") Output.pp)
+        outputs
+  | Some Syntax.Mli | Some Syntax.Mld ->
+      let err_delim = compute_delimiter ~base_delim:"err" outputs in
+      Fmt.pf ppf "]%a[\n{%s@mdx-error[\n%a\n]%s}"
+        Fmt.(option string)
+        delim err_delim
+        Fmt.(list ~sep:(any "\n") Output.pp)
+        outputs err_delim
+  | _ -> ()
+
+let has_output t =
+  match t.value with
+  | OCaml { errors = []; _ } -> false
+  | OCaml { errors = _; _ } -> true
+  | _ -> false
+
+let pp_value ?syntax ppf t =
+  let delim = t.delim in
   match t.value with
   | OCaml { errors = []; _ } -> ()
   | OCaml { errors; _ } ->
       let errors = error_padding errors in
-      Fmt.pf ppf "```mdx-error\n%a\n```\n"
-        Fmt.(list ~sep:(any "\n") Output.pp)
-        errors
+      pp_error ?syntax ?delim ppf errors
   | _ -> ()
 
-let pp_footer ?syntax ppf _ =
+let pp_footer ?syntax ppf t =
+  let delim =
+    if has_output t then (
+      pp_value ?syntax ppf t;
+      None)
+    else t.delim
+  in
   match syntax with
-  | Some Syntax.Mli | Some Syntax.Mld -> Fmt.string ppf "]}"
+  | Some Syntax.Mli | Some Syntax.Mld ->
+      Fmt.pf ppf "]%a}" Fmt.(option string) delim
   | Some Syntax.Cram -> Fmt.string ppf "\n"
   | Some Syntax.Markdown | None -> Fmt.string ppf "```\n"
 
@@ -216,7 +259,9 @@ let pp_header ?syntax ppf t =
         | [] -> ()
         | labels -> Fmt.pf ppf " %a" (pp_labels ?syntax) labels
       in
-      Fmt.pf ppf "{%a%a[" pp_lang_header lang_headers pp_labels other_labels
+      Fmt.pf ppf "{%a%a%a["
+        Fmt.(option string)
+        t.delim pp_lang_header lang_headers pp_labels other_labels
   | Some Syntax.Cram -> pp_labels ?syntax ppf t.labels
   | Some Syntax.Markdown | None ->
       if t.legacy_labels then
@@ -231,8 +276,7 @@ let pp_header ?syntax ppf t =
 let pp ?syntax ppf b =
   pp_header ?syntax ppf b;
   pp_contents ?syntax ppf b;
-  pp_footer ?syntax ppf b;
-  pp_errors ppf b
+  pp_footer ?syntax ppf b
 
 let directory t = t.dir
 let file t = match t.value with Include t -> Some t.file_included | _ -> None
@@ -415,7 +459,7 @@ let infer_block ~loc ~config ~header ~contents ~errors =
           let+ () = check_no_errors ~loc errors in
           Raw { header })
 
-let mk ~loc ~section ~labels ~legacy_labels ~header ~contents ~errors =
+let mk ~loc ~section ~labels ~legacy_labels ~header ~delim ~contents ~errors =
   let block_kind =
     get_label (function Block_kind x -> Some x | _ -> None) labels
   in
@@ -442,6 +486,7 @@ let mk ~loc ~section ~labels ~legacy_labels ~header ~contents ~errors =
     os_type_enabled;
     set_variables = config.set_variables;
     unset_variables = config.unset_variables;
+    delim;
     value;
   }
 
@@ -450,7 +495,7 @@ let mk_include ~loc ~section ~labels =
   | Some file_inc ->
       let header = Header.infer_from_file file_inc in
       mk ~loc ~section ~labels ~legacy_labels:false ~header ~contents:[]
-        ~errors:[]
+        ~errors:[] ~delim:None
   | None -> label_required ~loc ~label:"file" ~kind:"include"
 
 let parse_labels ~label_cmt ~legacy_labels =
@@ -476,6 +521,7 @@ let from_raw raw =
       in
       Util.Result.to_error_list
       @@ mk ~loc ~section ~header ~contents ~labels ~legacy_labels ~errors
+           ~delim:None
 
 let is_active ?section:s t =
   let active =

diff --git a/lib/block.mli b/lib/block.mli
@@ -105,6 +105,7 @@ type t = {
       (** Whether the current os type complies with the block's version. *)
   set_variables : (string * string) list;
   unset_variables : string list;
+  delim : string option;
   value : value;
 }
 (** The type for supported code blocks. *)
@@ -115,6 +116,7 @@ val mk :
   labels:Label.t list ->
   legacy_labels:bool ->
   header:Header.t option ->
+  delim:string option ->
   contents:string list ->
   errors:Output.t list ->
   (t, [ `Msg of string ]) result

diff --git a/lib/mli_parser.ml b/lib/mli_parser.ml
@@ -3,6 +3,7 @@ module Code_block = struct
 
   type t = {
     metadata : metadata option;
+    delimiter : string option;
     content : Location.t; (* Location of the content *)
     code_block : Location.t; (* Location of the enclosing code block *)
   }
@@ -44,18 +45,19 @@ let extract_code_block_info acc ~(location : Lexing.position) ~docstring =
           loc_ghost = false;
         }
     in
-    fun location (metadata, { O.Loc.location = span; _ }) ->
+    fun location
+        { O.Ast.meta; delimiter; content = { O.Loc.location = span; _ }; _ } ->
       let metadata =
         Option.map
-          (fun (lang, labels) ->
-            let language_tag = O.Loc.value lang in
-            let labels = Option.map O.Loc.value labels in
+          (fun { O.Ast.language; tags } ->
+            let language_tag = O.Loc.value language in
+            let labels = Option.map O.Loc.value tags in
             Code_block.{ language_tag; labels })
-          metadata
+          meta
       in
       let content = convert_loc span in
       let code_block = convert_loc location in
-      { metadata; content; code_block }
+      { metadata; delimiter; content; code_block }
   in
 
   (* Fold over the results from odoc-parser, recurse where necessary
@@ -146,9 +148,10 @@ let make_block code_block file_contents =
         let len = loc.loc_end.pos_cnum - start in
         String.sub file_contents start len
       in
+      let delim = code_block.delimiter in
       let contents = slice code_block.content |> String.split_on_char '\n' in
       Block.mk ~loc:code_block.code_block ~section:None ~labels ~header
-        ~contents ~legacy_labels:false ~errors:[]
+        ~contents ~legacy_labels:false ~errors:[] ~delim
 
 (* 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

diff --git a/test/bin/mdx-test/expect/simple-mld/test-case.mld b/test/bin/mdx-test/expect/simple-mld/test-case.mld
@@ -59,4 +59,11 @@ Indentation test:
   val x : int = 1
 ]}
 
-
+{delim@ocaml[
+  let f = 1 + "2"
+]delim[
+{err@mdx-error[
+Line 1, characters 15-18:
+Error: This expression has type string but an expression was expected of type
+         int
+]err}]}
diff --git a/test/bin/mdx-test/expect/simple-mli/test-case.mli b/test/bin/mdx-test/expect/simple-mli/test-case.mli
@@ -49,3 +49,14 @@ val bar : string
 
 (** {@ocaml skip[1 + 1 = 3]} *)
 val baz : string
+
+(**
+{[
+  let f = 1 + "2"
+][
+{err@mdx-error[
+Line 1, characters 15-18:
+Error: This expression has type string but an expression was expected of type
+         int
+]err}]}
+*)
diff --git a/test/lib/test_block.ml b/test/lib/test_block.ml
@@ -23,7 +23,7 @@ let test_mk =
     let test_fun () =
       let actual =
         Mdx.Block.mk ~loc:Location.none ~section:None ~labels
-          ~legacy_labels:false ~header ~contents ~errors:[]
+          ~legacy_labels:false ~header ~contents ~errors:[] ~delim:None
       in
       let expected =
         Result.map_error

diff --git a/test/lib/test_dep.ml b/test/lib/test_dep.ml
@@ -26,7 +26,7 @@ let test_of_block =
     | Ok labels -> (
         match
           Mdx.Block.mk ~loc:Location.none ~section:None ~labels ~header:None
-            ~contents:[] ~legacy_labels:false ~errors:[]
+            ~contents:[] ~legacy_labels:false ~errors:[] ~delim:None
         with
         | Ok block -> block
         | Error _ -> assert false)