Update editor organisation

6 files changed, 693 insertions, 0 deletions

diff --git a/editor/plugins/dune b/editor/plugins/dune
new file mode 100755
index 0000000..046dc5a
--- /dev/null
+++ b/editor/plugins/dune
@@ -0,0 +1,9 @@
+(library
+ (name plugins)
+ (libraries 
+   brr
+   prosemirror
+   js_lib
+   )
+ (preprocess (pps js_of_ocaml-ppx))
+ )
diff --git a/editor/plugins/footnotes.ml b/editor/plugins/footnotes.ml
new file mode 100755
index 0000000..794171f
--- /dev/null
+++ b/editor/plugins/footnotes.ml
@@ -0,0 +1,248 @@
+open Brr
+open Js_of_ocaml
+module PM = Prosemirror
+
+let footNoteSpec = object%js
+
+  val mutable group = Jstr.v "inline"
+  val mutable content = Jstr.v "inline*" (* The star is very important ! *)
+  val mutable inline = Js._true
+  val mutable draggable = Js._true
+  (*  This makes the view treat the node as a leaf, even though it
+      technically has content *)
+  val mutable atom = Js._true
+
+  val toDOM
+    : (PM.Model.node Js.t -> PM.Model.domOutputSpec Js.t) Js.callback
+    = Js.wrap_callback (fun _ ->
+        let open PM.Model.Dom_output_spec in
+        v "footnote"
+          [ hole ])
+
+  val parseDOM
+    : PM.Model.parse_rule Js.t Js.js_array Js.t Js.opt
+    = Js.some @@ Js.array
+      [|PM.Model.ParseRule.tag (Jstr.v "footnote")|]
+
+end
+
+let footnote_schema pm defaultSchema =
+
+  let nodes = defaultSchema##.spec##.nodes
+  and marks = defaultSchema##.spec##.marks in
+
+  let specs = PM.Model.schema_spec
+      (nodes##addToEnd (Jstr.v "footnote") (Js.Unsafe.coerce footNoteSpec))
+      (Some marks)
+      None in
+
+  PM.Model.schema pm
+    specs
+
+let build_menu pm schema =
+  let menu = PM.Example.buildMenuItems pm schema in
+
+  let itemSpec = PM.Menu.menuItemSpec () in
+  itemSpec##.title := Js.some @@ Jstr.v "Insert footnote";
+  itemSpec##.label := Js.some @@ Jstr.v "Footnote";
+  itemSpec##.select := Js.wrap_meth_callback (fun _ (state:PM.State.editor_state Js.t) ->
+      match PM.O.get schema##.nodes "footnote" with
+      | None ->  Js._false
+      | Some footnote_node ->
+        let res = Js.Opt.test @@ PM.Transform.insertPoint
+            pm
+            state##.doc
+            ~pos:state##.selection##.from
+            footnote_node
+        in
+        Js.bool res);
+
+  itemSpec##.run :=
+    Js.wrap_meth_callback (fun _this state dispatch _ _ ->
+        match PM.O.get schema##.nodes "footnote" with
+        | None -> ()
+        | Some footnote_node ->
+
+          let from' = PM.State.selection_from state##.selection
+          and to' = PM.State.selection_to state##.selection in
+
+          let content =
+            if state##.selection##.empty != Js._true
+            && from'##sameParent to' = Js._true
+            && from'##.parent##.inlineContent = Js._true then (
+              from'##.parent##.content##cut
+                (from'##.parentOffset)
+                (Js.some @@ to'##.parentOffset)
+            ) else (
+              PM.Model.empty_fragment pm
+            ) in
+          let new_node = footnote_node##create_withFragmentContent
+              Js.null
+              (Js.some content)
+              Js.null
+          in
+          dispatch @@
+          state##.tr##replaceSelectionWith
+            new_node
+            Js.null
+      );
+
+  let item = PM.Menu.menu_item pm itemSpec in
+  let _ = menu##.insertMenu##.content##push item in
+  menu
+
+let fromOutside
+  : bool PM.State.meta_data Js.t
+  = PM.State.create_str_meta_data (Jstr.v "fromOutside")
+
+let footnote_view
+  : PM.t -> PM.Model.node Js.t -> PM.View.editor_view Js.t -> (unit -> int) -> < .. > Js.t
+  = fun pm init_node outerView get_pos ->
+
+    (* These are used when the footnote is selected *)
+    let innerView
+      : PM.View.editor_view Js.t Js.opt ref
+      = ref Js.null in
+
+    let dispatchInner
+      : PM.View.editor_view Js.t -> PM.State.transaction Js.t -> unit
+      = fun view tr ->
+        let res = view##.state##applyTransaction tr in
+        view##updateState res##.state;
+
+        let meta = Js.Optdef.get (tr##getMeta fromOutside) (fun () -> false) in
+        if (not meta) then (
+          let outerTr = outerView##.state##.tr
+          and offsetMap = PM.Transform.offset pm ((get_pos()) + 1) in
+          res##.transactions##forEach
+            (Js.wrap_callback @@
+             fun (elem:PM.State.transaction Js.t) _ _ ->
+             elem##.steps##forEach
+               (Js.wrap_callback @@ fun (step:PM.Transform.step Js.t) _ _ ->
+                let _ = outerTr##step (step##map offsetMap) in
+                ()
+               ));
+          if (outerTr##.docChanged = Js._true) then (
+            outerView##dispatch outerTr)
+        );
+    in
+    object%js (_self)
+
+      val mutable node: PM.Model.node Js.t = init_node
+
+      (* The node's representation in the editor (empty, for now) *)
+      val dom = El.v (Jstr.v "footnote") []
+
+      method _open =
+        (* Append a tooltip to the outer node *)
+        let tooltip = El.div []
+            ~at:At.([class' (Jstr.v "popin")]) in
+        El.append_children _self##.dom
+          [ tooltip ];
+
+        let dispatch_fn
+          : PM.State.transaction Js.t -> unit
+          = fun tr -> outerView##dispatch tr in
+
+        let state_properties = Js.Unsafe.coerce (object%js
+            val doc = Js.some _self##.node;
+            val plugins = Js.some @@ Js.array @@ [|
+                PM.Keymap.keymap pm
+                  [| ( "Mod-z"
+                     , (fun _ _ -> PM.History.undo pm outerView##.state (Js.some dispatch_fn)))
+                   ; ( "Mod-y"
+                     , (fun _ _ -> PM.History.redo pm outerView##.state (Js.some dispatch_fn)))
+                  |]
+              |];
+          end) in
+
+        let view_properties = PM.View.direct_editor_props () in
+        view_properties##.state := PM.State.create pm state_properties;
+        (* This is the magic part *)
+        view_properties##.dispatchTransaction :=
+          (Js.wrap_meth_callback dispatchInner);
+        view_properties##.handleDOMEvents := PM.O.init
+            [| ( "mousedown"
+               , Js.wrap_callback (fun _ _ ->
+                     (* Kludge to prevent issues due to the fact that the
+                        whole footnote is node-selected (and thus DOM-selected)
+                        when the parent editor is focused. *)
+                     if (outerView##hasFocus () = Js._true) then (
+                       Js.Opt.iter !innerView (fun view -> view##focus ())
+                     );
+                     Js._false ))|];
+
+        innerView := Js.some
+            (PM.View.editor_view pm
+               tooltip
+               view_properties);
+
+      method close =
+        Js.Opt.iter (!innerView)
+          (fun view ->
+             view##destroy;
+             innerView := Js.null;
+             El.set_prop
+               (El.Prop.jstr (Jstr.v "textContent"))
+               (Jstr.empty)
+               _self##.dom
+          )
+
+      method update
+        : PM.Model.node Js.t -> bool Js.t
+        = fun node ->
+          if (node##sameMarkup _self##.node = Js._false) then (
+            Js._false
+          ) else (
+            _self##.node := node;
+            Js.Opt.iter !innerView (fun view ->
+                let state = view##.state in
+                Js.Opt.iter (node##.content##findDiffStart state##.doc##.content) (fun start ->
+                    let res_opt = (node##.content##findDiffEnd state##.doc##.content) in
+                    Js.Opt.iter res_opt (fun end_diff ->
+                        let overlap = start - (min end_diff##.a end_diff##.b) in
+                        let endA, endB =
+                          if overlap > 0 then
+                            ( end_diff##.a + overlap
+                            , end_diff##.b + overlap )
+                          else
+                            ( end_diff##.a
+                            , end_diff##.b )
+                        in
+                        let tr =
+                          state##.tr
+                          ##(replace
+                               ~from:start
+                               ~to_:endB
+                               (Js.some @@ node##slice ~from:start ~to_:(Js.some endA)))
+                          ##(setMeta fromOutside true) in
+                        view##dispatch tr)));
+            Js._true
+          )
+
+      method destroy =
+        Js.Opt.iter !innerView (fun _ -> _self##close)
+
+      method stopEvent e =
+        Js.Opt.case !innerView
+          (fun () -> Js._false)
+          (fun view ->
+             let dom = view##.dom in
+             Jv.call (Jv.Id.to_jv dom) "contains" [| e##.target|]
+             |> Jv.Id.of_jv)
+
+      method ignoreMutation =
+        Js._true
+
+      method selectNode =
+        El.set_class (Jstr.v "ProseMirror-selectednode") true _self##.dom;
+        if not (Js.Opt.test !innerView) then (
+          _self##_open
+        )
+
+      method deselectNode =
+        El.set_class (Jstr.v "ProseMirror-selectednode") false _self##.dom;
+        if (Js.Opt.test !innerView) then
+          _self##close
+
+    end
diff --git a/editor/plugins/link_editor.ml b/editor/plugins/link_editor.ml
new file mode 100755
index 0000000..9bfdfd4
--- /dev/null
+++ b/editor/plugins/link_editor.ml
@@ -0,0 +1,127 @@
+open Brr
+
+module Js = Js_of_ocaml.Js
+module PM = Prosemirror
+
+let link_edit
+  : PM.View.editor_view Js.t -> < .. > Js.t
+  = fun view ->
+
+    let popin = El.div []
+        ~at:At.([class' (Jstr.v "popin")]) in
+
+    El.set_inline_style El.Style.display (Jstr.v "none") popin;
+
+    let parent = Jv.(Id.of_jv @@ get (Jv.Id.to_jv view##.dom) "parentNode") in
+    let () = El.append_children parent [popin] in
+
+    let hide
+      : unit -> unit
+      = fun () ->
+        El.set_inline_style El.Style.display (Jstr.v "none") popin
+    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
+        Js.Opt.case (state##.doc##nodeAt (view##.state##.selection##._to))
+          (fun () -> hide ())
+          (fun node ->
+             (* Check if we are editing a link *)
+             match PM.O.get state##.schema##.marks "link" with
+             | None -> ()
+             | Some link_type ->
+               let is_present = link_type##isInSet node##.marks in
+               Js.Opt.case
+                 is_present
+                 (fun () -> hide ())
+                 (fun mark ->
+                    (* Get the node's bounding position and display the popin *)
+                    let position = state##.doc##resolve
+                        (view##.state##.selection##._to) in
+                    let start = position##start Js.null
+                    and end' = position##_end Js.null in
+
+                    Popin.set_position
+                      ~start
+                      ~end'
+                      view popin;
+
+                    (* Extract the value from the attribute *)
+                    let attrs = mark##.attrs in
+                    let href_opt = PM.O.get attrs "href" in
+                    let href_value = Option.value
+                        ~default:Jstr.empty
+                        href_opt
+                    in
+
+                    (* Create the popin content *)
+                    let a = El.a
+                        ~at:At.[ href href_value ]
+                        [ El.txt href_value ] in
+
+                    let entry = Popin.build_field a
+                        (fun new_value ->
+                           (* The function is called when the user validate
+                              the change in the popi. We create a new
+                              transaction in the document by replacing the
+                              mark with the new one. *)
+                           if not (Jstr.equal new_value href_value) then (
+
+                             (* Create a new attribute object for the mark in
+                                order to keep history safe *)
+                             let attrs' = PM.O.init
+                                 [| "href", new_value |] in
+
+                             Option.iter
+                               (fun v -> PM.O.set attrs' "title" v)
+                               (PM.O.get attrs "title");
+
+                             let mark' = state##.schema##mark_fromType
+                                 link_type
+                                 (Js.some attrs') in
+                             (* Create a transaction which update the
+                                mark with the new value *)
+                             view##dispatch
+                               state
+                               ##.tr
+                               ##(removeMark
+                                    ~from:start
+                                    ~to_:end'
+                                    mark)
+                               ##(addMark
+                                    ~from:start
+                                    ~to_:end'
+                                    mark')
+                           );
+                           true
+
+                        ) in
+
+
+                    El.set_children popin
+                      [ entry.field
+                      ; entry.button ];
+
+                 ))
+
+    and destroy () = El.remove popin in
+
+    object%js
+      val update = Js.wrap_callback update
+      val destroy= Js.wrap_callback destroy
+    end
+
+let 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 -> link_edit view)
+    end in
+
+    Jv.new' (Jv.get state "Plugin") [| Jv.Id.to_jv params |]
+    |> Jv.Id.of_jv
diff --git a/editor/plugins/plugins.ml b/editor/plugins/plugins.ml
new file mode 100755
index 0000000..3a92df8
--- /dev/null
+++ b/editor/plugins/plugins.ml
@@ -0,0 +1,137 @@
+module Js = Js_of_ocaml.Js
+module PM = Prosemirror
+
+module Footnotes = Footnotes
+
+(** Commands *)
+
+let change_level
+  : PM.t -> PM.Model.resolved_pos Js.t -> int -> (int -> bool) -> PM.Commands.t
+  = fun pm res incr pred state dispatch ->
+    let parent = res##.parent in
+    let attributes = parent##.attrs in
+
+    let current_level = if Jv.is_none attributes##.level then
+        0
+      else
+        attributes##.level in
+    let t, props = match pred current_level with
+      | false ->
+        ( PM.O.get state##.schema##.nodes "heading"
+        , Js.some (object%js
+            val level = current_level + incr
+          end))
+      | true ->
+        ( PM.O.get state##.schema##.nodes "paragraph"
+        , Js.null) in
+    match t with
+    | None -> Js._false
+    | Some t ->
+      PM.Commands.set_block_type pm t props state dispatch
+
+(** Increase the title level by one when pressing # at the begining of a line *)
+let handle_sharp pm state dispatch =
+
+  let res = PM.State.selection_to (state##.selection) in
+  match Js.Opt.to_option res##.nodeBefore with
+  | Some _ -> Js._false
+  | None -> (* Line start *)
+    begin match Jstr.to_string res##.parent##._type##.name with
+      | "heading" ->
+        change_level pm res 1 (fun x -> x > 5) state dispatch
+      | "paragraph" ->
+        begin match PM.O.get state##.schema##.nodes "heading" with
+          | None -> Js._false
+          | Some t ->
+            let props = Js.some (object%js
+                val level = 1
+              end) in
+            PM.Commands.set_block_type pm t props state dispatch
+        end
+      | _ -> Js._false
+    end
+
+let handle_backspace pm state dispatch =
+
+  let res = PM.State.selection_to (state##.selection) in
+  match Js.Opt.to_option res##.nodeBefore with
+  | Some _ -> Js._false
+  | None -> (* Line start *)
+    begin match Jstr.to_string res##.parent##._type##.name with
+      | "heading" -> change_level pm res (-1) (fun x -> x <= 1) state dispatch
+      | _ -> Js._false
+    end
+
+
+let toggle_mark
+  : Js.regExp Js.t -> PM.t -> string -> PM.InputRule.input_rule Js.t
+  = fun regExp pm mark_type_name ->
+    PM.InputRule.create pm
+      regExp
+      ~fn:(Js.wrap_callback @@ fun (state:PM.State.editor_state Js.t) _ ~from ~to_ ->
+           match PM.O.get state##.schema##.marks mark_type_name with
+           | None -> Js.null
+           | Some mark_type ->
+
+             let m = state##.schema##mark_fromType mark_type Js.null in
+
+             (* Delete the markup code *)
+             let tr = (state##.tr)##delete ~from ~to_ in
+
+             (* Check if the mark is active at the position *)
+             let present = Js.Opt.bind
+                 (PM.State.cursor (tr##.selection))
+                 (fun resolved ->
+                    Js.Opt.map
+                      (mark_type##isInSet (resolved##marks ()))
+                      (fun _ -> resolved)
+                 ) in
+             Js.Opt.case present
+               (fun () ->
+                  let tr = tr##addStoredMark m in
+                  Js.some @@ tr)
+               (fun _resolved ->
+                  let tr = tr##removeStoredMark_mark m in
+                  Js.some tr))
+
+let input_rule pm =
+
+  let bold =
+    toggle_mark
+      (new%js Js.regExp (Js.string "\\*\\*$"))
+      pm
+      "strong"
+  and em =
+    toggle_mark
+      (new%js Js.regExp (Js.string "//$"))
+      pm
+      "em" in
+
+  PM.InputRule.to_plugin pm
+    (Js.array [| bold; em |])
+
+let default pm schema =
+
+  (** Load the history plugin *)
+  let _ = PM.History.(history pm (history_prop ()) ) in
+
+  let props = PM.Example.options schema in
+  props##.menuBar := Js.some Js._true;
+  props##.floatingMenu := Js.some Js._true;
+  props##.menuContent := (Footnotes.build_menu pm schema)##.fullMenu;
+  let setup = PM.Example.example_setup pm props in
+
+  let keymaps =
+    PM.Keymap.keymap pm
+      [| "Backspace", (handle_backspace pm)
+       ; "#", (handle_sharp pm)
+      |] in
+
+  (* Add the custom keymaps in the list *)
+  let _ = setup##unshift keymaps in
+  let _ = setup##push (input_rule pm) in
+  let _ = setup##push (Tooltip.bold_plugin pm) in
+  let _ = setup##push (Link_editor.plugin pm) in
+
+
+  Js.some setup
diff --git a/editor/plugins/popin.ml b/editor/plugins/popin.ml
new file mode 100755
index 0000000..63dcad1
--- /dev/null
+++ b/editor/plugins/popin.ml
@@ -0,0 +1,83 @@
+open Brr
+module Js = Js_of_ocaml.Js
+module PM = Prosemirror
+
+type binded_field =
+  { field: El.t
+  ; button: El.t
+  }
+
+(** Set the element position just above the selection  *)
+let set_position
+  : start:int -> end':int -> PM.View.editor_view Js.t -> El.t -> unit
+  = fun ~start ~end' view el ->
+    El.set_inline_style El.Style.display (Jstr.v "") el;
+
+    (* These are in screen coordinates *)
+    let start = view##coordsAtPos start Js.null
+    and end' = view##coordsAtPos end' Js.null in
+    let offsetParent = Jv.(Id.of_jv @@ get (Jv.Id.to_jv el) "offsetParent") in
+
+    (* The box in which the tooltip is positioned, to use as base *)
+    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
+
+    (* Find a center-ish x position from the selection endpoints (when
+       crossing lines, end may be more to the left) *)
+    let left = (start##.left +. end'##.left) /. 2. 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
+
+(** Build a button which allow to activate or desactivate the given Element.
+
+    The function f is called when the user validate the input.
+
+*)
+let build_field
+  : El.t -> (Jstr.t -> bool) -> binded_field
+  = fun field f ->
+
+    let button_content =
+      [ El.i []
+          ~at:At.[ class' (Jstr.v "fas")
+                 ; class' (Jstr.v "fa-pen") ]
+      ] in
+
+    let button = El.button
+        button_content
+    in
+
+    Ev.listen Ev.click
+      (fun _ ->
+         match El.at (Jstr.v "contenteditable") field with
+         | Some value when (Jstr.equal value (Jstr.v "true")) ->
+           let new_value = El.prop
+               (El.Prop.jstr (Jstr.v "textContent"))
+               field in
+           begin match f new_value with
+             | true ->
+               El.set_at (Jstr.v "contenteditable") None field;
+               El.set_children button button_content
+             | false -> ()
+           end
+         | _ ->
+           El.set_at (Jstr.v "contenteditable")
+             (Some (Jstr.v "true")) field;
+           El.set_children button
+             [ El.i
+                 ~at:At.[ class' (Jstr.v "fas")
+                        ; class' (Jstr.v "fa-check") ]
+                 []
+             ]
+      )
+      (El.as_target button);
+
+    { field
+    ; button = button
+    }
diff --git a/editor/plugins/tooltip.ml b/editor/plugins/tooltip.ml
new file mode 100755
index 0000000..05d56d4
--- /dev/null
+++ b/editor/plugins/tooltip.ml
@@ -0,0 +1,89 @@
+open StdLabels
+open Brr
+
+module Js = Js_of_ocaml.Js
+module PM = Prosemirror
+
+(** https://prosemirror.net/examples/tooltip/ *)
+
+
+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 "popin")
+                ]) 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 ->
+
+        (* Compare the previous and actual state. If the stored marks are the
+           same, just return *)
+        let state = view##.state in
+        let previous_stored_marks =
+          Js.Opt.bind state_opt (fun state -> state##.storedMarks)
+          |> Js.Opt.to_option
+        and current_stored_marks = state##.storedMarks in
+
+        let same = match previous_stored_marks, Js.Opt.to_option current_stored_marks with
+          | Some arr1, Some arr2 ->
+            Js_lib.Array.compare arr1 arr2 ~f:(fun v1 v2 -> v1##eq v2)
+          | None, None -> Js._true
+          | _, _ -> Js._false in
+
+        if same <> Js._true then
+
+          let is_bold = Option.bind (PM.O.get state##.schema##.marks "strong")
+              (fun mark_type ->
+                 let is_strong =
+                   Js.Opt.bind current_stored_marks
+                     (fun t -> mark_type##isInSet t) in
+                 Js.Opt.case is_strong
+                   (fun () -> None)
+                   (fun _ -> Some (Jstr.v "gras"))) in
+          let is_em = Option.bind (PM.O.get state##.schema##.marks "em")
+              (fun mark_type ->
+                 let is_em =
+                   Js.Opt.bind current_stored_marks
+                     (fun t -> mark_type##isInSet t) in
+                 Js.Opt.case is_em
+                   (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 *)
+            let start = view##.state##.selection##.from
+            and end' = view##.state##.selection##._to in
+            Popin.set_position ~start ~end' 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