1 files changed, 257 insertions, 0 deletions
diff --git a/editor/footnotes.ml b/editor/footnotes.ml
new file mode 100755
index 0000000..a2bc9c6
--- /dev/null
+++ b/editor/footnotes.ml
@@ -0,0 +1,257 @@
+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*"
+  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
+
+
+    let obj =
+      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 "footnote-tooltip")]) 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
+            )
+
+        (*  TODO
+            https://prosemirror.net/docs/ref/#view.NodeView.update *)
+        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
+    in
+    obj