Handle language tag on code blocks

odoc.opam

@@ -25,7 +25,7 @@ delimited with `(** ... *)`, and outputs HTML.
 """
 
 depends: [
-  "odoc-parser" {>= "0.9.0"}
+  "odoc-parser" {>= "1.0.0"}
   "astring"
   "cmdliner" {>= "1.0.0"}
   "cppo" {build & >= "1.1.0"}

src/document/codefmt.ml

@@ -222,7 +222,7 @@ let code ?attr f = [ inline ?attr @@ Inline.Source (render f) ]
 
 let documentedSrc f = [ DocumentedSrc.Code (render f) ]
 
-let codeblock ?attr f = [ block ?attr @@ Block.Source (render f) ]
+let codeblock ?attr f = [ block ?attr @@ Block.Source (None, render f) ]
 
 let keyword keyword ppf = pf ppf "@{<keyword>%s@}" keyword
 

src/document/comment.ml

@@ -196,8 +196,9 @@ let rec nestable_block_element : Comment.nestable_block_element -> Block.one =
  fun content ->
   match content with
   | `Paragraph p -> paragraph p
-  | `Code_block code ->
-      block @@ Source (source_of_code (Odoc_model.Location_.value code))
+  | `Code_block (lang_tag, code) ->
+      block
+      @@ Source (lang_tag, source_of_code (Odoc_model.Location_.value code))
   | `Verbatim s -> block @@ Verbatim s
   | `Modules ms -> module_references ms
   | `List (kind, items) ->

src/document/types.ml

@@ -64,6 +64,8 @@ end =
   Heading
 
 and Block : sig
+  type lang_tag = string option
+
   type t = one list
 
   and one = { attr : Class.t; desc : desc }
@@ -73,7 +75,7 @@ and Block : sig
     | Paragraph of Inline.t
     | List of list_type * t list
     | Description of Description.t
-    | Source of Source.t
+    | Source of lang_tag * Source.t
     | Verbatim of string
     | Raw_markup of Raw_markup.t
 

src/html/generator.ml

@@ -165,32 +165,37 @@ let heading ~resolve (h : Heading.t) =
 let rec block ~resolve (l : Block.t) : flow Html.elt list =
   let as_flow x = (x : phrasing Html.elt list :> flow Html.elt list) in
   let one (t : Block.one) =
-    let a = class_ t.attr in
+    let mk_block ?(extra_class = []) mk content =
+      let a = Some (class_ (extra_class @ t.attr)) in
+      [ mk ?a content ]
+    in
     match t.desc with
     | Inline i ->
-        if a = [] then as_flow @@ inline ~resolve i
-        else [ Html.span ~a (inline ~resolve i) ]
-    | Paragraph i -> [ Html.p ~a (inline ~resolve i) ]
+        if t.attr = [] then as_flow @@ inline ~resolve i
+        else mk_block Html.span (inline ~resolve i)
+    | Paragraph i -> mk_block Html.p (inline ~resolve i)
     | List (typ, l) ->
         let mk = match typ with Ordered -> Html.ol | Unordered -> Html.ul in
-        [ mk ~a (List.map (fun x -> Html.li (block ~resolve x)) l) ]
+        mk_block mk (List.map (fun x -> Html.li (block ~resolve x)) l)
     | Description l ->
-        [
-          (let item i =
-             let a = class_ i.Description.attr in
-             let term =
-               (inline ~resolve i.Description.key
-                 : phrasing Html.elt list
-                 :> flow Html.elt list)
-             in
-             let def = block ~resolve i.Description.definition in
-             Html.li ~a (term @ (Html.txt " " :: def))
-           in
-           Html.ul ~a (List.map item l));
-        ]
+        let item i =
+          let a = class_ i.Description.attr in
+          let term =
+            (inline ~resolve i.Description.key
+              : phrasing Html.elt list
+              :> flow Html.elt list)
+          in
+          let def = block ~resolve i.Description.definition in
+          Html.li ~a (term @ (Html.txt " " :: def))
+        in
+        mk_block Html.ul (List.map item l)
     | Raw_markup r -> raw_markup r
-    | Verbatim s -> [ Html.pre ~a [ Html.txt s ] ]
-    | Source c -> [ Html.pre ~a (source (inline ~resolve) c) ]
+    | Verbatim s -> mk_block Html.pre [ Html.txt s ]
+    | Source (lang_tag, c) ->
+        let extra_class =
+          match lang_tag with None -> [] | Some lang -> [ "language-" ^ lang ]
+        in
+        mk_block ~extra_class Html.pre (source (inline ~resolve) c)
   in
   Utils.list_concat_map l ~f:one
 

src/latex/generator.ml

@@ -308,7 +308,7 @@ let rec block ~in_source (l : Block.t) =
         ]
     | Raw_markup r -> raw_markup r
     | Verbatim s -> [ Verbatim s ]
-    | Source c -> non_empty_block_code c
+    | Source (_, c) -> non_empty_block_code c
   in
   list_concat_map l ~f:one
 

src/manpage/generator.ml

@@ -331,7 +331,7 @@ let rec block (l : Block.t) =
             indent 2 (str "@" ++ key ++ str ":" ++ sp ++ def)
           in
           list ~sep:break (List.map f descrs) ++ continue rest
-      | Source content ->
+      | Source (_, content) ->
           env "EX" "EE" "" (source_code content) ++ continue rest
       | Verbatim content -> env "EX" "EE" "" (str "%s" content) ++ continue rest
       | Raw_markup t -> raw_markup t ++ continue rest)

src/model/comment.ml

@@ -40,7 +40,7 @@ type module_reference = {
 
 type nestable_block_element =
   [ `Paragraph of paragraph
-  | `Code_block of string with_location
+  | `Code_block of string option * string with_location
   | `Verbatim of string
   | `Modules of module_reference list
   | `List of

src/model/semantics.ml

@@ -227,8 +227,13 @@ let rec nestable_block_element :
   match element with
   | { value = `Paragraph content; location } ->
       Location.at location (`Paragraph (inline_elements status content))
-  | { value = `Code_block (_, code); _ } ->
-      Location.same element (`Code_block code)
+  | { value = `Code_block (metadata, code); location } ->
+      let lang_tag =
+        match metadata with
+        | Some ({ Location.value; _ }, _) -> Some value
+        | None -> None
+      in
+      Location.at location (`Code_block (lang_tag, code))
   | { value = `Verbatim _; _ } as element -> element
   | { value = `Modules modules; location } ->
       let modules =

src/model_desc/comment_desc.ml

@@ -18,7 +18,7 @@ and general_link_content = general_inline_element with_location list
 
 type general_block_element =
   [ `Paragraph of general_link_content
-  | `Code_block of string with_location
+  | `Code_block of string option * string with_location
   | `Verbatim of string
   | `Modules of Comment.module_reference list
   | `List of
@@ -100,7 +100,8 @@ let rec block_element : general_block_element t =
   Variant
     (function
     | `Paragraph x -> C ("`Paragraph", x, link_content)
-    | `Code_block x -> C ("`Code_block", ignore_loc x, string)
+    | `Code_block (x1, x2) ->
+        C ("`Code_block", (x1, ignore_loc x2), Pair (Option string, string))
     | `Verbatim x -> C ("`Verbatim", x, string)
     | `Modules x -> C ("`Modules", x, List module_reference)
     | `List (x1, x2) ->

test/model/semantics/test.ml

@@ -1989,7 +1989,10 @@ let%expect_test _ =
       [%expect
         {|
         {
-          "value": [ { "`Tag": { "`Author": "Foo" } }, { "`Code_block": "bar" } ],
+          "value": [
+            { "`Tag": { "`Author": "Foo" } },
+            { "`Code_block": [ "None", "bar" ] }
+          ],
           "warnings": [
             "File \"f.ml\", line 2, characters 0-7:\n'{[...]}' (code block) is not allowed in the tags section.\nSuggestion: move '{[...]}' (code block) before any tags."
           ]
@@ -2376,7 +2379,7 @@ let%expect_test _ =
       test "{[@author Foo]}";
       [%expect
         {|
-          { "value": [ { "`Code_block": "@author Foo" } ], "warnings": [] } |}]
+          { "value": [ { "`Code_block": [ "None", "@author Foo" ] } ], "warnings": [] } |}]
 
     let in_verbatim =
       test "{v @author Foo v}";
@@ -2389,7 +2392,10 @@ let%expect_test _ =
       [%expect
         {|
         {
-          "value": [ { "`Code_block": "foo" }, { "`Tag": { "`Author": "Bar" } } ],
+          "value": [
+            { "`Code_block": [ "None", "foo" ] },
+            { "`Tag": { "`Author": "Bar" } }
+          ],
           "warnings": [
             "File \"f.ml\", line 1, characters 8-19:\n'@author' should begin on its own line."
           ]