From 3f5e3dd53755dd67c24721afc62e32d2187e3583 Mon Sep 17 00:00:00 2001
From: Sébastien Dailly <sebastien@chimrod.com>
Date: Wed, 24 Feb 2021 20:51:43 +0100
Subject: Update editor code

---
 editor/tooltip.ml | 149 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 149 insertions(+)
 create mode 100755 editor/tooltip.ml

(limited to 'editor/tooltip.ml')

diff --git a/editor/tooltip.ml b/editor/tooltip.ml
new file mode 100755
index 0000000..06426d1
--- /dev/null
+++ b/editor/tooltip.ml
@@ -0,0 +1,149 @@
+open StdLabels
+open Js_of_ocaml
+open Brr
+
+
+module PM = Prosemirror
+
+(** https://prosemirror.net/examples/tooltip/ *)
+
+(** Set the element position just above the selection  *)
+let set_position
+  : PM.View.editor_view Js.t -> El.t -> unit
+  = fun view el ->
+    El.set_inline_style El.Style.display (Jstr.v "") el;
+    let start = view##coordsAtPos (view##.state##.selection##.from) Js.null
+    and end' = view##coordsAtPos (view##.state##.selection##._to) Js.null in
+    let offsetParent = Jv.(Id.of_jv @@ get (Jv.Id.to_jv el) "offsetParent") in
+
+    let box = Jv.(Id.of_jv @@ call (Jv.Id.to_jv offsetParent) "getBoundingClientRect" [||]) in
+    let box_left = Jv.(Id.of_jv @@ get (Jv.Id.to_jv box) "left") in
+    let box_bottom = Jv.(Id.of_jv @@ get (Jv.Id.to_jv box) "bottom") in
+
+    let left = Float.max
+        ((start##.left +. end'##.left) /. 2.)
+        (start##.left +. 3.) in
+
+    El.set_inline_style (Jstr.v "left")
+      Jstr.( (of_float ( left -. box_left )) + (v "px") )
+      el;
+    El.set_inline_style (Jstr.v "bottom")
+      Jstr.( (of_float ( box_bottom -. start##.top )) + (v "px") )
+      el
+
+let tooltip
+  : PM.View.editor_view Js.t -> < .. > Js.t
+  = fun view ->
+
+    (* Create the element which will be displayed over the editor *)
+    let tooltip = El.div []
+        ~at:At.([class' (Jstr.v "tooltip")]) in
+    El.set_inline_style El.Style.display (Jstr.v "none") tooltip;
+
+    let parent = Jv.(Id.of_jv @@ get (Jv.Id.to_jv view##.dom) "parentNode") in
+    let () = El.append_children parent [tooltip] in
+
+    let update
+      : PM.View.editor_view Js.t -> PM.State.editor_state Js. t Js.opt -> unit
+      = fun view state_opt ->
+
+        Js.Opt.case state_opt
+          (fun () -> ())
+          (fun previous_state ->
+             if ((view##.state##.doc##eq previous_state##.doc) = Js._true)
+             && ((previous_state##.selection##eq view##.state##.selection) = Js._true)
+             then
+               ()
+             else (
+               if (view##.state##.selection##.empty) = Js._true then
+                 (* Hide the tooltip if the selection is empty *)
+                 El.set_inline_style El.Style.display (Jstr.v "none") tooltip
+               else (
+                 (* otherwise, reposition it and update its content *)
+                 set_position view tooltip;
+                 El.set_prop
+                   (El.Prop.jstr (Jstr.v "textContent"))
+                   (Jstr.of_int
+                      (view##.state##.selection##._to -  view##.state##.selection##.from))
+                   tooltip)))
+    and destroy () = El.remove tooltip in
+
+    object%js
+      val update = Js.wrap_callback update
+      val destroy= Js.wrap_callback destroy
+    end
+
+let tooltip_plugin
+  : PM.t -> PM.State.plugin Js.t
+  = fun t ->
+    let state = Jv.get (Jv.Id.to_jv t) "state" in
+
+    let params = object%js
+      val view = (fun view -> tooltip view)
+    end in
+
+    Jv.new' (Jv.get state "Plugin") [| Jv.Id.to_jv params |]
+    |> Jv.Id.of_jv
+
+
+let boldtip
+  : PM.View.editor_view Js.t -> < .. > Js.t
+  = fun view ->
+    (* Create the element which will be displayed over the editor *)
+    let tooltip = El.div []
+        ~at:At.([class' (Jstr.v "tooltip")]) in
+    El.set_inline_style El.Style.display (Jstr.v "none") tooltip;
+
+    let parent = Jv.(Id.of_jv @@ get (Jv.Id.to_jv view##.dom) "parentNode") in
+    let () = El.append_children parent [tooltip] in
+
+    let update
+      : PM.View.editor_view Js.t -> PM.State.editor_state Js. t Js.opt -> unit
+      = fun view _state_opt ->
+        let state = view##.state in
+        let is_bold = match PM.O.get state##.schema##.marks "strong" with
+          | None -> None
+          | Some mark_type ->
+            let is_strong = Js.Opt.bind state##.storedMarks (fun t -> mark_type##isInSet t) in
+            Js.Opt.case is_strong
+              (fun () -> None)
+              (fun _ -> Some (Jstr.v "gras")) in
+        let is_em = match PM.O.get state##.schema##.marks "em" with
+          | None -> None
+          | Some mark_type ->
+            let is_strong = Js.Opt.bind state##.storedMarks (fun t -> mark_type##isInSet t) in
+            Js.Opt.case is_strong
+              (fun () -> None)
+              (fun _ -> Some (Jstr.(v "emphase"))) in
+
+        let marks = List.filter_map [is_bold ; is_em]
+            ~f:(fun x -> x) in
+
+        match marks with
+        | [] -> El.set_inline_style El.Style.display (Jstr.v "none") tooltip
+        | _ ->
+          (* The mark is present, add in the content *)
+          set_position view tooltip;
+          El.set_prop
+            (El.Prop.jstr (Jstr.v "textContent"))
+            (Jstr.concat marks ~sep:(Jstr.v ", "))
+            tooltip
+
+    and destroy () = El.remove tooltip in
+
+    object%js
+      val update = Js.wrap_callback update
+      val destroy= Js.wrap_callback destroy
+    end
+
+let bold_plugin
+  : PM.t -> PM.State.plugin Js.t
+  = fun t ->
+    let state = Jv.get (Jv.Id.to_jv t) "state" in
+
+    let params = object%js
+      val view = (fun view -> boldtip view)
+    end in
+
+    Jv.new' (Jv.get state "Plugin") [| Jv.Id.to_jv params |]
+    |> Jv.Id.of_jv
-- 
cgit v1.2.3