Fix comments links using an ugly tactic. lol

bin/widgets/comments/mastodon.ml

@@ -151,7 +151,11 @@ module Context = struct
     ignore_extra_fields prism
 end
 
-type content_fragment = Text of string | Mention of string | Tag of string
+type content_fragment =
+  | Text of string
+  | Mention of string
+  | Tag of string
+  | Link of (string * string)
 
 let fragmentize str =
   let len = String.length str in

bin/widgets/comments/mastodon.mli

@@ -52,6 +52,10 @@ module Context : sig
   val encoding : t Data_encoding.t
 end
 
-type content_fragment = Text of string | Mention of string | Tag of string
+type content_fragment =
+  | Text of string
+  | Mention of string
+  | Tag of string
+  | Link of (string * string)
 
 val fragmentize : string -> content_fragment list

bin/widgets/comments/util.ml

@@ -4,3 +4,48 @@ let cheat_with_string_document str =
   let tpl = Dom_html.document##createElement (Js.string "div") in
   let () = tpl##.innerHTML := Js.string str in
   tpl##.innerText |> Js.to_string
+
+type node_content =
+  | Link of string * string
+  | Text of string
+  | Paragraph of node_content list
+
+let parse_mastodon_response str =
+  let tpl = Dom_html.document##createElement (Js.string "div") in
+  let () = tpl##.innerHTML := Js.string str in
+  let open Nightmare_js.Nullable in
+  let rec aux acc = function
+    | [] -> acc
+    | node :: xs -> (
+        let element =
+          node |> Dom.CoerceTo.element >|= Dom_html.element |> to_option
+        in
+        match element with
+        | None -> (
+            match node |> Dom.CoerceTo.text |> to_option with
+            | None -> aux acc xs
+            | Some txt ->
+                let str = txt##.data |> Js.to_string in
+                let e = Text str in
+                aux (e :: acc) xs)
+        | Some elt -> (
+            match elt |> Dom_html.CoerceTo.a |> to_option with
+            | Some a ->
+                let href = a##.href |> Js.to_string
+                and value = a##.innerText |> Js.to_string in
+                let e = Link (href, value) in
+                aux (e :: acc) xs
+            | None -> (
+                match elt |> Dom_html.CoerceTo.p |> to_option with
+                | Some p ->
+                    let children = p##.childNodes |> Dom.list_of_nodeList in
+                    let result = aux [] children in
+                    let e = Paragraph (List.rev result) in
+                    aux (e :: acc) xs
+                | None ->
+                    let children = elt##.childNodes |> Dom.list_of_nodeList in
+                    let result = aux acc children in
+                    aux result xs)))
+  in
+  let children = tpl##.childNodes |> Dom.list_of_nodeList in
+  aux [] children |> List.rev

bin/widgets/comments/util.mli

@@ -1 +1,7 @@
+type node_content =
+  | Link of string * string
+  | Text of string
+  | Paragraph of node_content list
+
 val cheat_with_string_document : string -> string
+val parse_mastodon_response : string -> node_content list

bin/widgets/comments/view.ml

@@ -1,48 +1,25 @@
-let render_mention mentions username =
-  let open Nightmare_js_vdom in
-  match
-    List.find_opt
-      (fun x -> String.equal x.Mastodon.Mention.username username)
-      mentions
-  with
-  | Some s ->
-      a
-        ~a:[ a_href s.url; a_class [ "comment-content-mention" ] ]
-        [ txt @@ "@" ^ username ]
-  | None ->
-      span
-        ~a:
-          [
-            a_class
-              [ "comment-content-mention"; "comment-content-mention-unreach" ]
-          ]
-        [ txt @@ "#" ^ username ]
+let truncate_link str =
+  let len = String.length str in
+  if len >= 32 then
+    let s = String.sub str 0 32 in
+    s ^ "..."
+  else str
 
-let render_tag tags username =
+let rec render_comment_content content =
   let open Nightmare_js_vdom in
-  match
-    List.find_opt (fun x -> String.equal x.Mastodon.Tag.name username) tags
-  with
-  | Some s ->
-      a
-        ~a:[ a_href s.url; a_class [ "comment-content-tag" ] ]
-        [ txt @@ "#" ^ username ]
-  | None ->
-      span
-        ~a:[ a_class [ "comment-content-tag"; "comment-content-tag-unreach" ] ]
-        [ txt @@ "#" ^ username ]
+  List.map
+    (function
+      | Util.Text v -> span [ txt v ]
+      | Util.Link (h, v) ->
+          a
+            ~a:[ a_href h; a_class [ "comment-content-link" ] ]
+            [ txt @@ truncate_link v ]
+      | Util.Paragraph xs ->
+          div ~a:[ a_class [ "paragraph" ] ] (render_comment_content xs))
+    content
 
-let compute_content tags mentions content =
-  let open Nightmare_js_vdom in
-  content
-  |> Util.cheat_with_string_document
-  |> Mastodon.fragmentize
-  |> List.filter_map (function
-       | Mastodon.Tag x -> Some (render_tag tags x)
-       | Mention x -> Some (render_mention mentions x)
-       | Text "" -> None
-       | Text x ->
-           Some (span ~a:[ a_class [ "comment-content-regular" ] ] [ txt x ]))
+let compute_content content =
+  content |> Util.parse_mastodon_response |> render_comment_content
 
 let render_comments main_id comments =
   let open Mastodon in
@@ -57,9 +34,7 @@ let render_comments main_id comments =
            if String.(equal empty author.display_name) then author.username
            else author.display_name
          in
-         let txt_content =
-           compute_content comment.tags comment.mentions content
-         in
+         let txt_content = compute_content content in
          let replies_txt =
            let msg =
              if comment.replies_count > 1 then "reponses" else "reponse"

css/default.css

@@ -44,6 +44,7 @@ body {
   font-family: var(--sans-serif-font);
 }
 
+.comment-content-link,
 .comment-content-tag,
 .comment-content-mention,
 .address-meta a,
@@ -670,6 +671,10 @@ code {
   padding-bottom: 32px;
 }
 
+#comments-thread .comments-list .a_comment .comment-content .paragraph {
+  margin-bottom: 12px;
+}
+
 #comments-thread .comments-list .a_comment .comment-date {
   grid-area: date;
   font-family: var(--mono-font);