Rewrite InternalLink.t into a record

Allows to add more fields.

Author: Julow

src/document/comment.ml

@@ -69,8 +69,9 @@ module Reference = struct
         | None ->
             let s = source_of_code s in
             [ inline @@ Inline.Source s ]
-        | Some s ->
-            [ inline @@ Inline.InternalLink (InternalLink.Unresolved s) ])
+        | Some content ->
+            let link = { InternalLink.target = Unresolved; content } in
+            [ inline @@ Inline.InternalLink link ])
     | `Dot (parent, s) -> unresolved ?text (parent :> t) s
     | `Module (parent, s) ->
         unresolved ?text (parent :> t) (ModuleName.to_string s)
@@ -100,25 +101,28 @@ module Reference = struct
     | `Resolved r -> (
         (* IDENTIFIER MUST BE RENAMED TO DEFINITION. *)
         let id = Reference.Resolved.identifier r in
-        let txt =
+        let content =
           match text with
           | None ->
               [ inline @@ Inline.Source (source_of_code (render_resolved r)) ]
           | Some s -> s
         in
         match Url.from_identifier ~stop_before id with
         | Ok url ->
-            [ inline @@ Inline.InternalLink (InternalLink.Resolved (url, txt)) ]
-        | Error (Not_linkable _) -> txt
+            let target = InternalLink.Resolved url in
+            [ inline @@ Inline.InternalLink { InternalLink.target; content } ]
+        | Error (Not_linkable _) -> content
         | Error exn ->
             (* FIXME: better error message *)
             Printf.eprintf "Id.href failed: %S\n%!" (Url.Error.to_string exn);
-            txt)
+            content)
 
   and unresolved : ?text:Inline.t -> Reference.t -> string -> Inline.t =
    fun ?text parent field ->
     match text with
-    | Some s -> [ inline @@ InternalLink (InternalLink.Unresolved s) ]
+    | Some content ->
+        let link = { InternalLink.target = Unresolved; content } in
+        [ inline @@ InternalLink link ]
     | None ->
         let tail = [ inline @@ Text ("." ^ field) ] in
         let content = to_ir ~stop_before:true parent in

src/document/doctree.ml

@@ -377,16 +377,12 @@ end = struct
       match x.desc with
       | Styled (_, x) -> inline x
       | Link (_, x) -> inline x
-      | InternalLink x -> internallink x
+      | InternalLink x -> inline x.content
       | Math _ -> true
       | Text _ | Entity _ | Linebreak | Source _ | Raw_markup _ -> false
     in
     List.exists inline_ x
 
-  and internallink : InternalLink.t -> bool = function
-    | Resolved (_, x) -> inline x
-    | Unresolved x -> inline x
-
   and description : Description.t -> bool =
    fun x ->
     let description_ : Description.one -> bool =

src/document/generator.ml

@@ -32,15 +32,15 @@ let type_var tv = tag "type-var" (O.txt tv)
 
 let enclose ~l ~r x = O.span (O.txt l ++ x ++ O.txt r)
 
-let path p txt =
-  O.elt
-    [ inline @@ InternalLink (InternalLink.Resolved (Url.from_path p, txt)) ]
+let resolved p content =
+  let link = { InternalLink.target = Resolved p; content } in
+  O.elt [ inline @@ InternalLink link ]
 
-let resolved p txt =
-  O.elt [ inline @@ InternalLink (InternalLink.Resolved (p, txt)) ]
+let path p content = resolved (Url.from_path p) content
 
-let unresolved txt =
-  O.elt [ inline @@ InternalLink (InternalLink.Unresolved txt) ]
+let unresolved content =
+  let link = { InternalLink.target = Unresolved; content } in
+  O.elt [ inline @@ InternalLink link ]
 
 let path_to_id path =
   match Url.Anchor.from_identifier (path :> Paths.Identifier.t) with
@@ -1814,8 +1814,8 @@ module Make (Syntax : SYNTAX) = struct
         in
         let li ?(attr = []) name url =
           let link url desc =
-            Inline.InternalLink
-              InternalLink.(Resolved (url, [ Inline.{ attr = []; desc } ]))
+            let content = [ Inline.{ attr = []; desc } ] in
+            Inline.InternalLink { InternalLink.target = Resolved url; content }
           in
           [ block ~attr @@ Block.Inline (inline @@ link url (Text name)) ]
         in

src/document/types.ml

@@ -6,11 +6,9 @@ end =
   Class
 
 and InternalLink : sig
-  type resolved = Url.t * Inline.t
+  type target = Resolved of Url.t | Unresolved
 
-  type unresolved = Inline.t
-
-  type t = Resolved of resolved | Unresolved of Inline.t
+  type t = { target : target; content : Inline.t }
 end =
   InternalLink
 

src/document/utils.ml

@@ -33,10 +33,7 @@ and compute_length_inline (t : Types.Inline.t) : int =
     | Text s -> acc + String.length s
     | Entity _e -> acc + 1
     | Linebreak -> 0 (* TODO *)
-    | Styled (_, t)
-    | Link (_, t)
-    | InternalLink (Resolved (_, t))
-    | InternalLink (Unresolved t) ->
+    | Styled (_, t) | Link (_, t) | InternalLink { content = t; _ } ->
         acc + compute_length_inline t
     | Source s -> acc + compute_length_source s
     | Math _ -> assert false

src/html/generator.ml

@@ -94,24 +94,21 @@ and styled style ~emph_level =
 
 let rec internallink ~config ~emph_level ~resolve ?(a = []) (t : InternalLink.t)
     =
-  match t with
-  | Resolved (uri, content) ->
-      let href = Link.href ~config ~resolve uri in
-      let a = (a :> Html_types.a_attrib Html.attrib list) in
-      let elt =
-        Html.a ~a:(Html.a_href href :: a) (inline_nolink ~emph_level content)
-      in
-      let elt = (elt :> phrasing Html.elt) in
-      [ elt ]
-  | Unresolved content ->
-      (* let title =
-       *   Html.a_title (Printf.sprintf "unresolved reference to %S"
-       *       (ref_to_string ref)
-       * in *)
-      let a = Html.a_class [ "xref-unresolved" ] :: a in
-      let elt = Html.span ~a (inline ~config ~emph_level ~resolve content) in
-      let elt = (elt :> phrasing Html.elt) in
-      [ elt ]
+  let elt =
+    match t.target with
+    | Resolved uri ->
+        let href = Link.href ~config ~resolve uri in
+        let a = (a :> Html_types.a_attrib Html.attrib list) in
+        Html.a ~a:(Html.a_href href :: a) (inline_nolink ~emph_level t.content)
+    | Unresolved ->
+        (* let title =
+         *   Html.a_title (Printf.sprintf "unresolved reference to %S"
+         *       (ref_to_string ref)
+         * in *)
+        let a = Html.a_class [ "xref-unresolved" ] :: a in
+        Html.span ~a (inline ~config ~emph_level ~resolve t.content)
+  in
+  [ (elt :> phrasing Html.elt) ]
 
 and inline ~config ?(emph_level = 0) ~resolve (l : Inline.t) :
     phrasing Html.elt list =

src/latex/generator.ml

@@ -231,17 +231,14 @@ let source k (t : Source.t) =
   tokens t
 
 let rec internalref ~verbatim ~in_source (t : InternalLink.t) =
-  match t with
-  | Resolved (uri, content) ->
-      let target = Link.label uri in
-      let text = Some (inline ~verbatim ~in_source content) in
-      let short = in_source in
-      Internal_ref { short; text; target }
-  | Unresolved content ->
-      let target = "xref-unresolved" in
-      let text = Some (inline ~verbatim ~in_source content) in
-      let short = in_source in
-      Internal_ref { short; target; text }
+  let target =
+    match t.target with
+    | InternalLink.Resolved uri -> Link.label uri
+    | Unresolved -> "xref-unresolved"
+  in
+  let text = Some (inline ~verbatim ~in_source t.content) in
+  let short = in_source in
+  Internal_ref { short; target; text }
 
 and inline ~in_source ~verbatim (l : Inline.t) =
   let one (t : Inline.one) =

src/manpage/generator.ml

@@ -238,9 +238,7 @@ let strip l =
               { h with desc = Styled (sty, List.rev @@ loop [] content) }
             in
             loop (h :: acc) t
-        | Link (_, content)
-        | InternalLink (Resolved (_, content))
-        | InternalLink (Unresolved content) ->
+        | Link (_, content) | InternalLink { content; _ } ->
             let acc = loop acc content in
             loop acc t
         | Source code ->
@@ -298,7 +296,7 @@ and inline (l : Inline.t) =
       | Styled (sty, content) -> style sty (inline content) ++ inline rest
       | Link (href, content) ->
           env "UR" "UE" href (inline @@ strip content) ++ inline rest
-      | InternalLink (Resolved (_, content) | Unresolved content) ->
+      | InternalLink { content; _ } ->
           font "CI" (inline @@ strip content) ++ inline rest
       | Source content -> source_code content ++ inline rest
       | Math s -> math s ++ inline rest