Medias: make them nestable blocks

Signed-off-by: Paul-Elliot <[email protected]>
ocaml · Jan 9, 2024 · eb67d4e · eb67d4e
1 parent 1dbbda9
commit eb67d4e
Show file tree

Hide file tree

Showing 9 changed files with 160 additions and 257 deletions.
diff --git a/src/document/comment.ml b/src/document/comment.ml
@@ -264,6 +264,38 @@ let rec nestable_block_element :
            and raise warnings *)
       in
       [ block @@ Table { data; align } ]
+  | `Media (href, media, content) ->
+      let content =
+        match (content, href) with
+        | [], `Reference path ->
+            let s = Reference.render_unresolved (path :> Comment.Reference.t) in
+            [ inline @@ Inline.Source (source_of_code s) ]
+        | [], `Link href -> [ inline @@ Inline.Source (source_of_code href) ]
+        | _ -> inline_element_list content
+      in
+      let url =
+        match href with
+        | `Reference (`Resolved r) -> (
+            let id =
+              Odoc_model.Paths.Reference.Resolved.(identifier (r :> t))
+            in
+            match Url.from_identifier ~stop_before:false id with
+            | Ok url -> Target.Internal (Resolved url)
+            | Error exn ->
+                (* FIXME: better error message *)
+                Printf.eprintf "Id.href failed: %S\n%!"
+                  (Url.Error.to_string exn);
+                Internal Unresolved)
+        | `Reference _ -> Internal Unresolved
+        | `Link href -> External href
+      in
+      let i =
+        match media with
+        | `Audio -> Block.Audio (url, content)
+        | `Video -> Video (url, content)
+        | `Image -> Image (url, content)
+      in
+      [ block i ]
 
 and paragraph : Comment.paragraph -> Block.one = function
   | [ { value = `Raw_markup (target, s); _ } ] ->
@@ -338,38 +370,6 @@ let attached_block_element : Comment.attached_block_element -> Block.t =
   function
   | #Comment.nestable_block_element as e -> nestable_block_element e
   | `Tag t -> [ block ~attr:[ "at-tags" ] @@ Description [ tag t ] ]
-  | `Media (href, media, content) ->
-      let content =
-        match (content, href) with
-        | [], `Reference path ->
-            let s = Reference.render_unresolved (path :> Comment.Reference.t) in
-            [ inline @@ Inline.Source (source_of_code s) ]
-        | [], `Link href -> [ inline @@ Inline.Source (source_of_code href) ]
-        | _ -> inline_element_list content
-      in
-      let url =
-        match href with
-        | `Reference (`Resolved r) -> (
-            let id =
-              Odoc_model.Paths.Reference.Resolved.(identifier (r :> t))
-            in
-            match Url.from_identifier ~stop_before:false id with
-            | Ok url -> Target.Internal (Resolved url)
-            | Error exn ->
-                (* FIXME: better error message *)
-                Printf.eprintf "Id.href failed: %S\n%!"
-                  (Url.Error.to_string exn);
-                Internal Unresolved)
-        | `Reference _ -> Internal Unresolved
-        | `Link href -> External href
-      in
-      let i =
-        match media with
-        | `Audio -> Block.Audio (url, content)
-        | `Video -> Video (url, content)
-        | `Image -> Image (url, content)
-      in
-      [ block i ]
 
 (* TODO collaesce tags *)
 

diff --git a/src/model/comment.ml b/src/model/comment.ml
@@ -54,6 +54,10 @@ type 'a abstract_table = {
   align : alignment option list option;
 }
 
+type media_href = [ `Link of string | `Reference of Reference.Asset.t ]
+
+type media_element = [ `Media of media_href * media * paragraph ]
+
 type nestable_block_element =
   [ `Paragraph of paragraph
   | `Code_block of
@@ -66,7 +70,7 @@ type nestable_block_element =
   | `Table of nestable_block_element abstract_table
   | `List of
     [ `Unordered | `Ordered ] * nestable_block_element with_location list list
-  ]
+  | media_element ]
 
 type tag =
   [ `Author of string
@@ -93,12 +97,7 @@ type heading_level =
   | `Paragraph
   | `Subparagraph ]
 
-type media_href = [ `Link of string | `Reference of Reference.Asset.t ]
-
-type media_element = [ `Media of media_href * media * paragraph ]
-
-type attached_block_element =
-  [ nestable_block_element | media_element | `Tag of tag ]
+type attached_block_element = [ nestable_block_element | `Tag of tag ]
 
 type heading_attrs = {
   heading_level : heading_level;
@@ -110,8 +109,7 @@ type block_element =
   [ nestable_block_element
   | `Heading of
     heading_attrs * Identifier.Label.t * inline_element with_location list
-  | `Tag of tag
-  | media_element ]
+  | `Tag of tag ]
 
 type docs = block_element with_location list
 

diff --git a/src/model/semantics.ml b/src/model/semantics.ml
@@ -276,6 +276,39 @@ let rec nestable_block_element :
           grid
       in
       `Table { Comment.data; align } |> Location.at location
+  | { value = `Media (_, { value = `Link href; _ }, content, m); location } ->
+      let text = inline_elements status content in
+      `Media (`Link href, m, text) |> Location.at location
+  | {
+   value =
+     `Media
+       (kind, { value = `Reference href; location = href_location }, content, m);
+   location;
+  } -> (
+      match Error.raise_warnings (Reference.parse href_location href) with
+      | Result.Ok target ->
+          let text = inline_elements status content in
+          let target =
+            match target with
+            | `Asset _ as a -> a
+            | `Root (_, `TAsset) as a -> a
+            | `Root (s, `TUnknown) -> `Root (s, `TAsset)
+            | `Root _ -> failwith "a"
+            | `Dot (_, s) -> failwith s
+            | `Resolved _ -> failwith "todo2"
+            | _ -> failwith "todo"
+          in
+          `Media (`Reference target, m, text) |> Location.at location
+      | Result.Error error ->
+          Error.raise_warning error;
+          let placeholder =
+            match kind with
+            | `Simple -> `Code_span href
+            | `With_text -> `Styled (`Emphasis, content)
+          in
+          `Paragraph
+            (inline_elements status [ placeholder |> Location.at location ])
+          |> Location.at location)
 
 and nestable_block_elements status elements =
   List.map (nestable_block_element status) elements
@@ -483,62 +516,7 @@ let top_level_block_elements status ast_elements =
             in
             traverse ~top_heading_level
               (element :: comment_elements_acc)
-              ast_elements
-        | {
-         value = `Media (_, { value = `Link href; _ }, content, m);
-         location;
-        } ->
-            let text = inline_elements status content in
-            let element =
-              `Media (`Link href, m, text) |> Location.at location
-            in
-            traverse ~top_heading_level
-              (element :: comment_elements_acc)
-              ast_elements
-        | {
-         value =
-           `Media
-             ( kind,
-               { value = `Reference href; location = href_location },
-               content,
-               m );
-         location;
-        } -> (
-            match Error.raise_warnings (Reference.parse href_location href) with
-            | Result.Ok target ->
-                let text = inline_elements status content in
-                let target =
-                  match target with
-                  | `Asset _ as a -> a
-                  | `Root (_, `TAsset) as a -> a
-                  | `Root (s, `TUnknown) -> `Root (s, `TAsset)
-                  | `Root _ -> failwith "a"
-                  | `Dot (_, s) -> failwith s
-                  | `Resolved _ -> failwith "todo2"
-                  | _ -> failwith "todo"
-                in
-                let element =
-                  `Media (`Reference target, m, text) |> Location.at location
-                in
-                traverse ~top_heading_level
-                  (element :: comment_elements_acc)
-                  ast_elements
-            | Result.Error error ->
-                Error.raise_warning error;
-                let placeholder =
-                  match kind with
-                  | `Simple -> `Code_span href
-                  | `With_text -> `Styled (`Emphasis, content)
-                in
-                let placeholder =
-                  `Paragraph
-                    (inline_elements status
-                       [ placeholder |> Location.at location ])
-                  |> Location.at location
-                in
-                traverse ~top_heading_level
-                  (placeholder :: comment_elements_acc)
-                  ast_elements))
+              ast_elements)
   in
   let top_heading_level =
     (* Non-page documents have a generated title. *)

diff --git a/src/parser/ast.ml b/src/parser/ast.ml
@@ -40,6 +40,9 @@ type code_block_meta = {
   tags : string with_location option;
 }
 
+type media = Token.media
+type media_href = Token.media_href
+
 type code_block = {
   meta : code_block_meta option;
   delimiter : string option;
@@ -57,7 +60,12 @@ and nestable_block_element =
     * [ `Light | `Heavy ]
     * nestable_block_element with_location list list
   | `Table of table
-  | `Math_block of string  (** @since 2.0.0 *) ]
+  | `Math_block of string  (** @since 2.0.0 *)
+  | `Media of
+    reference_kind
+    * media_href with_location
+    * inline_element with_location list
+    * media (** @since 2.3.0 *)]
 (** Some block elements may be nested within lists or tags, but not all.
     The [`List] constructor has a parameter of type [\[`Light | `Heavy\]].
     This corresponds to the syntactic constructor used (see the
@@ -89,17 +97,9 @@ type ocamldoc_tag =
 type tag = [ ocamldoc_tag | internal_tag ]
 type heading = int * string option * inline_element with_location list
 
-type media = Token.media
-type media_href = Token.media_href
-
 type block_element =
   [ nestable_block_element
   | `Heading of heading
-  | `Tag of tag
-  | `Media of
-    reference_kind
-    * media_href with_location
-    * inline_element with_location list
-    * media ]
+  | `Tag of tag ]
 
 type t = block_element with_location list