markdown: parse fenced_code_attributes extension

lib/block.ml

@@ -66,11 +66,23 @@ module Raw = struct
         contents : string list;
         label_cmt : string option;
         legacy_labels : string;
+        attributes : string option;
         errors : Output.t list;
       }
 
-  let make ~loc ~section ~header ~contents ~label_cmt ~legacy_labels ~errors =
-    Any { loc; section; header; contents; label_cmt; legacy_labels; errors }
+  let make ~loc ~section ~header ~contents ~label_cmt ~legacy_labels ~attributes
+      ~errors =
+    Any
+      {
+        loc;
+        section;
+        header;
+        contents;
+        label_cmt;
+        legacy_labels;
+        attributes;
+        errors;
+      }
 
   let make_include ~loc ~section ~labels = Include { loc; section; labels }
 end
@@ -114,6 +126,7 @@ type t = {
   os_type_enabled : bool;
   set_variables : (string * string) list;
   unset_variables : string list;
+  attributes : string list;
   delim : string option;
   value : value;
 }
@@ -263,15 +276,18 @@ let pp_header ?syntax ppf t =
         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 ->
+  | Some Syntax.Markdown | None -> (
       if t.legacy_labels then
         Fmt.pf ppf "```%a%a"
           Fmt.(option Header.pp)
           (header t) pp_legacy_labels t.labels
       else
         Fmt.pf ppf "%a```%a" (pp_labels ?syntax) t.labels
           Fmt.(option Header.pp)
-          (header t)
+          (header t);
+      match t.attributes with
+      | [] | [ "" ] -> ()
+      | attrs -> Fmt.pf ppf " {%a}" Fmt.(string |> list ~sep:(any " ")) attrs)
 
 let pp ?syntax ppf b =
   pp_header ?syntax ppf b;
@@ -459,7 +475,8 @@ 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 ~delim ~contents ~errors =
+let mk ~loc ~section ~labels ~legacy_labels ~header ~delim ~contents ~attributes
+    ~errors =
   let block_kind =
     get_label (function Block_kind x -> Some x | _ -> None) labels
   in
@@ -486,6 +503,7 @@ let mk ~loc ~section ~labels ~legacy_labels ~header ~delim ~contents ~errors =
     os_type_enabled;
     set_variables = config.set_variables;
     unset_variables = config.unset_variables;
+    attributes;
     delim;
     value;
   }
@@ -495,7 +513,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:[] ~delim:None
+        ~errors:[] ~delim:None ~attributes:[]
   | None -> label_required ~loc ~label:"file" ~kind:"include"
 
 let parse_labels ~label_cmt ~legacy_labels =
@@ -513,15 +531,37 @@ let from_raw raw =
   | Raw.Include { loc; section; labels } ->
       let* labels = locate_errors ~loc (Label.of_string labels) in
       Util.Result.to_error_list @@ mk_include ~loc ~section ~labels
-  | Raw.Any { loc; section; header; contents; label_cmt; legacy_labels; errors }
-    ->
-      let header = Header.of_string header in
+  | Raw.Any
+      {
+        loc;
+        section;
+        header;
+        contents;
+        label_cmt;
+        legacy_labels;
+        attributes;
+        errors;
+      } ->
+      let attributes =
+        String.split_on_char ' ' (Option.value ~default:"" attributes)
+      in
+      let attr_classes =
+        attributes |> List.filter @@ String.starts_with ~prefix:"."
+      in
+      let header, attributes =
+        match (Header.of_string header, attr_classes) with
+        | None, lang :: _ ->
+            ( lang |> Astring.String.with_range ~first:1 |> Header.of_string,
+              List.filter (fun a -> a <> lang) attributes )
+        | (Some _ as some), _ -> (some, attributes)
+        | None, [] -> (None, attributes)
+      in
       let* labels, legacy_labels =
         locate_errors ~loc (parse_labels ~label_cmt ~legacy_labels)
       in
       Util.Result.to_error_list
-      @@ mk ~loc ~section ~header ~contents ~labels ~legacy_labels ~errors
-           ~delim:None
+      @@ mk ~loc ~section ~header ~contents ~labels ~legacy_labels ~attributes
+           ~errors ~delim:None
 
 let is_active ?section:s t =
   let active =

lib/block.mli

@@ -84,6 +84,7 @@ module Raw : sig
     contents:string list ->
     label_cmt:string option ->
     legacy_labels:string ->
+    attributes:string option ->
     errors:Output.t list ->
     t
 
@@ -105,6 +106,7 @@ type t = {
       (** Whether the current os type complies with the block's version. *)
   set_variables : (string * string) list;
   unset_variables : string list;
+  attributes : string list;
   delim : string option;
   value : value;
 }
@@ -118,6 +120,7 @@ val mk :
   header:Header.t option ->
   delim:string option ->
   contents:string list ->
+  attributes:string list ->
   errors:Output.t list ->
   (t, [ `Msg of string ]) result
 

lib/lexer_mdx.mll

@@ -19,7 +19,9 @@ rule text section = parse
         newline lexbuf;
         `Section section :: text (Some section) lexbuf }
   | ( "<!--" ws* "$MDX" ws* ([^' ' '\n']* as label_cmt) ws* "-->" ws* eol? )?
-      "```" ([^' ' '\n']* as header) ws* ([^'\n']* as legacy_labels) eol
+      "```" ([^' ' '=' '{' '\n']* as header) ws* ([^'{' '\n']* as legacy_labels) ws*
+      ('{' ([^'\n']* as attributes) '}')? ws*
+      eol
       { let start = Lexing.lexeme_start_p lexbuf in
         newline lexbuf;
         (match label_cmt with
@@ -42,7 +44,7 @@ rule text section = parse
         let loc = loc ~start ~end_ in
         let block =
           Block.Raw.make ~loc ~section ~header ~contents ~label_cmt
-            ~legacy_labels ~errors
+            ~legacy_labels ~attributes ~errors
         in
         `Block block :: text section lexbuf }
   | "<!--" ws* "$MDX" ws* ([^' ' '\n']* as labels) ws* "-->" ws* eol
@@ -85,7 +87,7 @@ and cram_text section = parse
         let loc = loc ~start ~end_ in
         let block =
             Block.Raw.make ~loc ~section ~header ~contents ~label_cmt
-              ~legacy_labels ~errors:[]
+              ~legacy_labels ~errors:[] ~attributes:None
         in
         `Block block
         :: (if requires_empty_line then `Text "\n" :: rest else rest) }
@@ -101,7 +103,7 @@ and cram_text section = parse
         let rest = cram_text section lexbuf in
         let block =
             Block.Raw.make ~loc ~section ~header ~contents ~label_cmt
-              ~legacy_labels ~errors:[]
+              ~legacy_labels ~errors:[] ~attributes:None
         in
         `Block block
         :: (if requires_empty_line then `Text "\n" :: rest else rest) }

lib/mli_parser.ml

@@ -151,7 +151,7 @@ let make_block code_block file_contents =
       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:[] ~delim
+        ~contents ~legacy_labels:false ~errors:[] ~delim ~attributes:[]
 
 (* 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

test/bin/mdx-test/expect/attributes/test-case.md

@@ -0,0 +1,33 @@
+https://pandoc.org/MANUAL.html#extension-fenced_code_attributes are parsed and left untouched.
+Also make sure we actually parse all of these by having the wrong output to trigger a correction.
+
+```{.sh}
+$ echo foo
+foo
+```
+
+``` {.ocaml}
+# let x = 3;;
+val x : int = 4
+```
+
+```{#identifier .ocaml}
+# let x = 3;;
+val x : int = 4
+```
+
+```{#identifier .ocaml attrib="attrval"}
+# let x = 3;;
+val x : int = 4
+```
+
+```{#identifier .ocaml attrib="attrval with spaces"}
+# let x = 3;;
+val x : int = 4
+```
+
+```{#id1 #id2 .ocaml attrib="attrval" attr2="attrval2}"}
+# let x = 3;;
+val x : int = 4
+```
+

test/bin/mdx-test/expect/attributes/test-case.md.expected

@@ -0,0 +1,33 @@
+https://pandoc.org/MANUAL.html#extension-fenced_code_attributes are parsed and left untouched.
+Also make sure we actually parse all of these by having the wrong output to trigger a correction.
+
+```sh
+$ echo foo
+foo
+```
+
+```ocaml
+# let x = 3;;
+val x : int = 3
+```
+
+```ocaml {#identifier}
+# let x = 3;;
+val x : int = 3
+```
+
+```ocaml {#identifier attrib="attrval"}
+# let x = 3;;
+val x : int = 3
+```
+
+```ocaml {#identifier attrib="attrval with spaces"}
+# let x = 3;;
+val x : int = 3
+```
+
+```ocaml {#id1 #id2 attrib="attrval" attr2="attrval2}"}
+# let x = 3;;
+val x : int = 3
+```
+

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

@@ -1,4 +1,16 @@
 
+(rule
+ (target attributes.actual)
+ (deps (package mdx) (source_tree attributes))
+ (action
+  (with-stdout-to %{target}
+   (chdir attributes
+    (run ocaml-mdx test --output - test-case.md)))))
+
+(rule
+ (alias runtest)
+ (action (diff attributes/test-case.md.expected attributes.actual)))
+
 (rule
  (target bash-fence.actual)
  (deps (package mdx) (source_tree bash-fence))

test/lib/test_block.ml

@@ -24,6 +24,7 @@ let test_mk =
       let actual =
         Mdx.Block.mk ~loc:Location.none ~section:None ~labels
           ~legacy_labels:false ~header ~contents ~errors:[] ~delim:None
+          ~attributes:[]
       in
       let expected =
         Result.map_error

test/lib/test_dep.ml

@@ -27,6 +27,7 @@ let test_of_block =
         match
           Mdx.Block.mk ~loc:Location.none ~section:None ~labels ~header:None
             ~contents:[] ~legacy_labels:false ~errors:[] ~delim:None
+            ~attributes:[]
         with
         | Ok block -> block
         | Error _ -> assert false)