From 210a4d94836d07bb71cad46b3e670c1977cfe833 Mon Sep 17 00:00:00 2001
From: Sébastien Dailly <sebastien@chimrod.com>
Date: Sun, 21 Mar 2021 20:24:15 +0100
Subject: Updated PM examples

---
 editor/dune                        |   1 +
 editor/editor.css                  |  40 +++
 editor/editor.ml                   |  47 +--
 editor/footnotes.ml                | 257 +++++++++++++++++
 editor/plugins.ml                  |   1 +
 editor/prosemirror/bindings.ml     | 577 +++++++++++++++++++++++++------------
 editor/prosemirror/prosemirror.ml  |  74 ++++-
 editor/prosemirror/prosemirror.mli | 140 +++++----
 editor/tooltip.ml                  | 123 +++-----
 9 files changed, 900 insertions(+), 360 deletions(-)
 create mode 100755 editor/footnotes.ml

(limited to 'editor')

diff --git a/editor/dune b/editor/dune
index b16e85f..767d35e 100755
--- a/editor/dune
+++ b/editor/dune
@@ -4,6 +4,7 @@
    brr
    brr.note
    elements
+   js_lib
    prosemirror
    blog
    )
diff --git a/editor/editor.css b/editor/editor.css
index c8c2aeb..75d9495 100644
--- a/editor/editor.css
+++ b/editor/editor.css
@@ -392,3 +392,43 @@ li.ProseMirror-selectednode:after {
   left: 0;
   top: 24px;
 }
+
+
+  .ProseMirror {
+    counter-reset: prosemirror-footnote;
+  }
+  footnote {
+    display: inline-block;
+    position: relative;
+    cursor: pointer;
+  }
+  footnote::after {
+    content: counter(prosemirror-footnote);
+    vertical-align: super;
+    font-size: 75%;
+    counter-increment: prosemirror-footnote;
+  }
+  .ProseMirror-hideselection .footnote-tooltip *::selection { background-color: transparent; }
+  .ProseMirror-hideselection .footnote-tooltip *::-moz-selection { background-color: transparent; }
+  .footnote-tooltip {
+    cursor: auto;
+    position: absolute;
+    left: -30px;
+    top: calc(100% + 10px);
+    background: silver;
+    padding: 3px;
+    border-radius: 2px;
+    width: 500px;
+  }
+  .footnote-tooltip::before {
+    border: 5px solid silver;
+    border-top-width: 0px;
+    border-left-color: transparent;
+    border-right-color: transparent;
+    position: absolute;
+    top: -5px;
+    left: 27px;
+    content: " ";
+    height: 0;
+    width: 0;
+  }
diff --git a/editor/editor.ml b/editor/editor.ml
index 5aecef0..19480e2 100755
--- a/editor/editor.ml
+++ b/editor/editor.ml
@@ -58,13 +58,18 @@ let prosemirror id content =
       let module PM = Prosemirror in
       let pm = PM.v () in
 
+      let schema = (PM.SchemaBasic.schema pm) in
+      let schema = Footnotes.footnote_schema pm schema in
+
+      Console.(log [ schema ]);
+
       let specs = PM.Model.schema_spec
           (PM.SchemaList.add_list_nodes
              pm
-             ((PM.SchemaBasic.schema pm)##.spec##.nodes)
+             (schema##.spec##.nodes)
              (Jstr.v "paragraph block*")
              (Some (Jstr.v "block")))
-          (Some (PM.SchemaBasic.schema pm)##.spec##.marks)
+          (Some schema##.spec##.marks)
           None in
       let mySchema = PM.Model.schema pm specs in
 
@@ -80,46 +85,26 @@ let prosemirror id content =
           view##updateState state
         );
 
+      let view' = (Footnotes.footnote_view pm) in
+
+      let nodes = PM.O.init
+          [| ("footnote", view')  |] in
+      props##.nodeViews := nodes;
+
       let view = PM.View.editor_view
           pm
           (Jv.Id.of_jv id)
           props in
-      view##setProps props;
+      Console.(log [Jstr.v "main view"; view]);
       (* Attach an event on focus out *)
       let _ = Brr_note.Evr.on_el
           (Ev.focusout)
-          (fun _ ->
-(*
-             let props = view##.props in
-             props##.editable := Js.wrap_callback (fun  _ -> Js._false);
-             view##update props;
-*)
-             save_storage view
-          )
+          (fun _ -> save_storage view)
           (Jv.Id.of_jv id) in
 
-
-(*
-      let default_editable = view##.props##.editable in
-      let _ = Brr_note.Evr.on_el
-          (Ev.dblclick)
-          (fun e ->
-             let target = Ev.target e in
-             let (el:El.t) = Jv.Id.(of_jv @@ to_jv target) in
-             if (view##.editable == Js._false && (El.tag_name el <> Jstr.v "a")) then (
-               let props = view##.props in
-               props##.editable := default_editable;
-               view##update props;
-               Console.(log [el]);
-               El.set_has_focus true (Jv.Id.of_jv id);
-             )
-
-          )
-          (Jv.Id.of_jv id) in
-*)
       ()
 
-    | _, _-> Console.(error [str "No element with id '%s' '%s' found"; id ; content])
+    | _, _ -> Console.(error [str "No element with id '%s' '%s' found"; id ; content])
 
   end
 
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
diff --git a/editor/plugins.ml b/editor/plugins.ml
index 8dd960a..69319c4 100755
--- a/editor/plugins.ml
+++ b/editor/plugins.ml
@@ -116,6 +116,7 @@ let default pm schema =
   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 =
diff --git a/editor/prosemirror/bindings.ml b/editor/prosemirror/bindings.ml
index 4b95b73..1711829 100755
--- a/editor/prosemirror/bindings.ml
+++ b/editor/prosemirror/bindings.ml
@@ -16,6 +16,12 @@ module TypedObject : sig
   val set'
     : 'a t -> Jv.prop' -> 'a -> unit
 
+  val create
+    : unit -> 'a t
+
+  val init
+    : (Jv.prop * 'a) array -> 'a t
+
 end = struct
 
   type 'a t = Jv.t
@@ -40,6 +46,14 @@ end = struct
     = fun o prop v ->
       Jv.set' o prop (Jv.Id.to_jv v)
 
+  let create
+    : unit -> 'a t
+    = fun () -> Jv.obj [||]
+
+  let init
+    : (Jv.prop * 'a) array -> 'a t
+    = fun param -> Jv.obj (Obj.magic param)
+
 end
 
 class type ['a] ordered_map = object ('this)
@@ -54,102 +68,148 @@ class type ['a] ordered_map = object ('this)
     Jstr.t -> 'this meth
 
   method addToStart:
-    Jstr.t -> 'a t -> 'this meth
+    Jstr.t -> 'a t -> 'this t meth
 
   method addToEnd:
-    Jstr.t -> 'a t -> 'this meth
+    Jstr.t -> 'a t -> 'this t meth
 
 end
 
-module Model = struct
+module Classes = struct
+
+  type 'a meta_data
 
   type domOutputSpec
+  type parse_rule
+
+  type content_match
+
+  type slice
 
   class type _node_props = object ('this)
 
     method inlineContent:
-      bool readonly_prop
+      bool t readonly_prop
     (** True if this node type has inline content. *)
 
     method isBlock:
-      bool readonly_prop
+      bool t readonly_prop
 
     method isText:
-      bool readonly_prop
+      bool t readonly_prop
 
     method isInline:
-      bool readonly_prop
+      bool t readonly_prop
 
     method isTextblock:
-      bool readonly_prop
+      bool t readonly_prop
 
     method isLeaf:
-      bool readonly_prop
+      bool t readonly_prop
 
     method isAtom:
-      bool readonly_prop
+      bool t readonly_prop
 
   end
 
+  type depth = int opt
 
   class type mark = object ('this)
 
-    method eq:
-      'this t -> bool t meth
+    method eq
+      : 'this t -> bool t meth
 
-    method isInSet:
-      mark t js_array t -> mark t opt meth
+    method isInSet
+      : mark t js_array t -> mark t opt meth
 
   end
 
-  type node_spec
+  class type node_spec = object ('this)
 
-  type content_match
+    method content
+      : Jstr.t opt prop
 
-  type slice
+    method marks
+      : Jstr.t opt prop
 
-  type depth = int opt
+    method group
+      : Jstr.t opt prop
 
-  class type resolved_pos = object ('this)
+    method inline
+      : bool t opt prop
 
-    method pos:
-      int readonly_prop
+    method atom
+      : bool t opt prop
 
-    method depth:
-      int readonly_prop
+    method attrs
+      : < .. > t opt prop
 
-    method parent:
-      node t readonly_prop
+    method selectable
+      : bool t opt prop
 
-    method doc:
-      node t readonly_prop
+    method draggable
+      : bool t opt prop
 
-    method node:
-      depth -> node t meth
+    method code
+      : bool t opt prop
 
-    method index:
-      depth -> int meth
+    method defining
+      : bool t opt prop
 
-    method after:
-      depth -> int meth
+    method isolating
+      : bool t opt prop
 
-    method nodeAfter:
-      node t opt readonly_prop
+    method toDOM
+      : (node t -> domOutputSpec t) callback prop
 
-    method nodeBefore:
-      node t opt readonly_prop
+    method parseDom
+      : parse_rule t js_array t opt prop
 
-    method marks:
-      unit -> mark t js_array t meth
+  end
+
+  and resolved_pos = object ('this)
+
+    method pos
+      : int readonly_prop
+
+    method depth
+      : int readonly_prop
+
+    method parentOffset
+      : int readonly_prop
+
+    method parent
+      : node t readonly_prop
 
-    method sameParent:
-      'this -> bool t meth
+    method doc
+      : node t readonly_prop
 
-    method max:
-      'this -> 'this t meth
+    method node
+      : depth -> node t meth
 
-    method min:
-      'this -> 'this t meth
+    method index
+      : depth -> int meth
+
+    method after
+      : depth -> int meth
+
+    method nodeAfter
+      : node t opt readonly_prop
+
+    method nodeBefore
+      : node t opt readonly_prop
+
+    method marks
+      : unit -> mark t js_array t meth
+
+    method sameParent
+      : 'this t -> bool t meth
+
+    method max
+      : 'this t -> 'this t meth
+
+    method min
+      : 'this t -> 'this t meth
   end
 
   and mark_spec = object ('this)
@@ -222,8 +282,8 @@ module Model = struct
     method hasRequiredAttrs:
       unit -> bool t meth
 
-    method create_withFragment:
-      < .. > t -> fragment t opt -> mark t opt -> node t meth
+    method create_withFragmentContent:
+      < .. > t opt -> fragment t opt -> mark t opt -> node t meth
 
   end
 
@@ -268,7 +328,7 @@ module Model = struct
     (** Compare this element to another one. *)
 
     method cut:
-      int -> int opt -> 'this meth
+      int -> int opt -> 'this t meth
     (** Cut out the element between the two given positions. *)
 
     method toString:
@@ -284,128 +344,80 @@ module Model = struct
 
     inherit _element
 
-    method size:
-      int readonly_prop
+    method size
+      : int readonly_prop
     (** The size of the fragment, which is the total of the size of its
         content nodes. *)
 
-    method append:
-      'this t -> 'this t meth
+    method append
+      : 'this t -> 'this t meth
+
+    method lastChild
+      : node t opt readonly_prop
 
-    method lastChild:
-      node t opt readonly_prop
+    method firstChild
+      : node t opt readonly_prop
 
-    method firstChild:
-      node t opt readonly_prop
+    method findDiffStart
+      : 'this t -> int opt meth
+
+    method findDiffEnd
+      : 'this t -> < a: int prop; b: int prop> t opt meth
 
   end
 
+  (** https://prosemirror.net/docs/ref/#model.Node *)
   and node = object ('this)
 
     inherit _element
 
     inherit _node_props
 
-    method _type:
-      node_type t readonly_prop
-
-    method attrs:
-      < .. > t prop
+    method _type
+      : node_type t readonly_prop
 
-    method content:
-      fragment t prop
-
-    method copy:
-      fragment t -> 'this t meth
-
-    method resolve:
-      int -> resolved_pos t meth
-
-    method nodeAt:
-      int -> 'this t opt meth
-
-    method marks:
-      mark t js_array t readonly_prop
-
-    method sameMarkupd:
-      node t -> bool t meth
-
-    method text:
-      Jstr.t opt prop
-
-  end
-
-end
+    method attrs
+      : < .. > t prop
 
-module Transform = struct
+    method content
+      : fragment t prop
 
-  type step_result
+    method copy
+      : fragment t -> 'this t meth
 
-  class type step = object ('this)
+    method slice
+      : from:int -> to_:int opt -> slice t meth
 
-  end
+    method resolve
+      : int -> resolved_pos t meth
 
-  class type replace_step = object ('this)
+    method nodeAt
+      : int -> 'this t opt meth
 
-    inherit step
+    method marks
+      : mark t js_array t readonly_prop
 
-  end
+    method sameMarkup
+      : node t -> bool t meth
 
-  class type replace_around_step = object ('this)
-
-    inherit step
+    method text
+      : Jstr.t opt prop
 
   end
 
-  class type add_mark_step = object ('this)
-
-    inherit step
-
-  end
-
-
-  class type transform = object ('this)
-
-    method doc:
-      Model.node t readonly_prop
-
-    method steps:
-      step t js_array t readonly_prop
-
-    method docs:
-      Model.node t js_array t readonly_prop
-
-    method step:
-      step t -> 'this t meth
-
-    method addMark:
-      from:int -> to_:int -> Model.mark t -> 'this t meth
-
-    method delete:
-      from:int -> to_:int -> 'this t meth
-
-    method insert:
-      pos:int -> Model.node t -> 'this t meth
-
-    method replaceRangeWith:
-      from:int -> to_:int -> Model.node t -> 'this t meth
-
-    method setBlockType:
-      from:int -> to_:int -> Model.node_type t -> < .. > t -> 'this t meth
-
-  end
-
-end
+  (** View *)
 
+  and editor_props = object ('this)
 
-module Classes = struct
+    method editable
+      : (editor_state t -> bool t) callback prop
 
+    method handleDOMEvents
+      : (editor_view t ->  Jv.t -> bool t) callback TypedObject.t prop
 
-  (** View *)
-  class type editor_props = object ('this)
+    method nodeViews
+      : (node t -> editor_view t -> (unit -> int) -> < .. > t) TypedObject.t prop
 
-    method editable:
-      (editor_state t -> bool t) callback prop
   end
 
   and direct_editor_props = object ('this)
@@ -418,6 +430,7 @@ module Classes = struct
     (** The call back is called with this = instance of editor_view *)
     method dispatchTransaction:
       (editor_view t, transaction t -> unit) meth_callback writeonly_prop
+
   end
 
   and editor_view = object ('this)
@@ -443,12 +456,21 @@ module Classes = struct
     method updateState:
       editor_state t -> unit meth
 
+    method hasFocus:
+      unit -> bool t meth
+
+    method focus:
+      unit -> unit meth
+
     method posAtCoords:
       < left: float prop ; top: float prop > t -> < pos: int prop; inside: int prop> t meth
 
     method coordsAtPos:
       int -> int opt -> < left: float prop; right: float prop; top: float prop; bottom: float prop > t meth
 
+    method destroy
+      : unit meth
+
     method dispatch:
       transaction t -> unit meth
 
@@ -483,13 +505,13 @@ module Classes = struct
       'this t -> bool t meth
 
     method content:
-      unit -> Model.slice t meth
+      unit -> slice t meth
 
     method replace:
-      transaction t -> Model.slice t -> unit meth
+      transaction t -> slice t -> unit meth
 
     method replaceWith:
-      transaction t -> Model.node t -> unit meth
+      transaction t -> node t -> unit meth
 
   end
 
@@ -505,70 +527,132 @@ module Classes = struct
 
   end
 
+  (* Transform *)
+
+  and mappable = object ('this)
+
+  end
+
+  and step_map = object ('this)
+
+    inherit mappable
+
+  end
+
+  and step = object ('this)
+
+    method map
+      : mappable t -> 'this t meth
+
+  end
+
+  and transform = object ('this)
+
+    method doc
+      : node t readonly_prop
+
+    method steps
+      : step t js_array t readonly_prop
+
+    method docs
+      : node t js_array t readonly_prop
+
+    method step
+      : step t -> 'this t meth
+
+    method docChanged
+      : bool t prop
+
+    method addMark
+      : from:int -> to_:int -> mark t -> 'this t meth
+
+    method replace
+      : from:int -> to_:int -> slice t opt -> 'this t meth
+
+    method delete
+      : from:int -> to_:int -> 'this t meth
+
+    method insert
+      : pos:int -> node t -> 'this t meth
+
+    method replaceRangeWith
+      : from:int -> to_:int -> node t -> 'this t meth
+
+    method setBlockType
+      : from:int -> to_:int -> node_type t -> < .. > t -> 'this t meth
+
+  end
+
   and transaction = object ('this)
 
-    inherit Transform.transform
+    inherit transform
 
     method time:
       int readonly_prop
 
-    method setTime:
-      int -> 'this t meth
+    method setTime
+      : int -> 'this t meth
 
-    method storedMarks:
-      Model.mark t js_array t opt readonly_prop
+    method storedMarks
+      : mark t js_array t opt readonly_prop
 
-    method setStoredMarks:
-      Model.mark t js_array t opt -> 'this t meth
+    method setStoredMarks
+      : mark t js_array t opt -> 'this t meth
 
-    method addStoredMark:
-      Model.mark t -> 'this t meth
+    method addStoredMark
+      : mark t -> 'this t meth
 
-    method removeStoredMark_mark:
-      Model.mark t -> 'this t meth
+    method removeStoredMark_mark
+      : mark t -> 'this t meth
 
-    method removeStoredMark_marktype:
-      Model.mark_type t -> 'this t meth
+    method removeStoredMark_marktype
+      : mark_type t -> 'this t meth
 
-    method ensureMarks:
-      Model.mark t js_array t -> 'this t meth
+    method ensureMarks
+      : mark t js_array t -> 'this t meth
 
-    method storedMarksSet:
-      bool readonly_prop
+    method storedMarksSet
+      : bool readonly_prop
 
-    method selection:
-      selection t readonly_prop
+    method selection
+      : selection t readonly_prop
 
-    method setSelection:
-      selection t -> 'this t meth
+    method setSelection
+      : selection t -> 'this t meth
 
-    method deleteSelection:
-      'this t meth
+    method deleteSelection
+      : 'this t meth
 
-    method replaceSelection:
-      Model.slice t -> 'this t meth
+    method replaceSelection
+      : slice t -> 'this t meth
 
-    method replaceSelectionWith:
-      Model.node t -> bool t -> 'this t meth
+    method replaceSelectionWith
+      : node t -> bool t opt -> 'this t meth
 
-    method selectionSet:
-      bool readonly_prop
+    method selectionSet
+      : bool readonly_prop
 
-    method before:
-      Model.node t readonly_prop
+    method before
+      : node t readonly_prop
 
-    method insertText:
-      Jstr.t -> from:int opt -> to_:int opt -> 'this t meth
+    method insertText
+      : Jstr.t -> from:int opt -> to_:int opt -> 'this t meth
 
-    method scrollIntoView :
-      unit -> 'this t meth
+    method setMeta
+      : 'a meta_data t -> 'a -> 'this t meth
+
+    method getMeta
+      : 'a meta_data t -> 'a optdef meth
+
+    method scrollIntoView
+      : unit -> 'this t meth
 
   end
 
   and configuration_prop = object ('this)
 
     method schema:
-      Model.schema t opt prop
+      schema t opt prop
 
     method plugins:
       plugin t js_array t opt prop
@@ -580,29 +664,29 @@ module Classes = struct
     inherit configuration_prop
 
     method doc:
-      Model.node t opt prop
+      node t opt prop
 
     method selection:
       selection t opt prop
 
     method storedMarks:
-      Model.mark t js_array t opt prop
+      mark t js_array t opt prop
 
   end
 
   and editor_state = object ('this)
 
     method doc :
-      Model.node t readonly_prop
+      node t readonly_prop
 
     method selection:
       selection t readonly_prop
 
     method storedMarks:
-      Model.mark t js_array t opt readonly_prop
+      mark t js_array t opt readonly_prop
 
     method schema:
-      Model.schema t readonly_prop
+      schema t readonly_prop
 
     method plugins:
       plugin t js_array t readonly_prop
@@ -610,6 +694,10 @@ module Classes = struct
     method apply:
       transaction t -> 'this t meth
 
+    method applyTransaction
+      : transaction t ->
+        < state: 'this t prop; transactions : transaction t js_array t prop> t meth
+
     method tr:
       transaction t readonly_prop
 
@@ -623,8 +711,70 @@ module Classes = struct
 
 end
 
+module Model = struct
+
+  type parse_rule = Classes.parse_rule
+
+  type domOutputSpec = Classes.domOutputSpec
+
+  type depth = Classes.depth
+
+  class type mark = Classes.mark
+
+  class type fragment = Classes.fragment
+
+  class type node_spec = Classes.node_spec
+
+  class type resolved_pos = Classes.resolved_pos
+
+  class type mark_spec = Classes.mark_spec
+
+  class type schema_spec = Classes.schema_spec
+
+  class type schema = Classes.schema
+
+  class type node_type = Classes.node_type
+
+  class type mark_type = Classes.mark_type
+
+  class type node = Classes.node
+
+end
+
+module Transform = struct
+
+  type step_result
+
+  class type step_map = Classes.step_map
+
+  class type step = Classes.step
+
+  class type replace_step = object ('this)
+
+    inherit step
+
+  end
+
+  class type replace_around_step = object ('this)
+
+    inherit step
+
+  end
+
+  class type add_mark_step = object ('this)
+
+    inherit step
+
+  end
+
+  class type transform = Classes.transform
+
+
+end
+
 module State = struct
 
+  type 'a meta_data = 'a Classes.meta_data
   class type plugin = Classes.plugin
   class type selection = Classes.selection
   class type text_selection = Classes.text_selection
@@ -710,21 +860,66 @@ module SchemaBasic = struct
 
 end
 
+module Menu = struct
+
+  class type menuElement = object ('this)
+  end
+
+  class type menuItemSpec = object ('this)
+    method title
+      : Jstr.t opt prop
+
+    method label
+      : Jstr.t opt prop
+
+    method select
+      : (menuItem t, State.editor_state t -> bool t) meth_callback prop
+
+    method run
+      : (menuItem t, State.editor_state t -> (State.transaction t -> unit) -> View.editor_view t -> 'a Brr.Ev.t -> unit) meth_callback prop
+  end
+
+  and menuItem = object ('this)
+    inherit menuElement
+  end
+
+  class type dropdown = object ('this)
+
+    inherit menuElement
+
+    method content
+      : menuItem t js_array t prop
+  end
+end
+
 module Example = struct
 
+  class type menuItems = object ('this)
+
+    method insertMenu
+      : Menu.dropdown t prop
+
+    method fullMenu
+      : Menu.menuElement t js_array t prop
+
+  end
+
   class type options = object ('this)
 
-    method schema:
-      Model.schema t prop
+    method schema
+      : Model.schema t prop
+
+    method menuBar
+      : bool t opt prop
 
-    method menuBar:
-      bool t opt prop
+    method floatingMenu
+      : bool t opt prop
 
-    method floatingMenu:
-      bool t opt prop
+    method history
+      : bool t opt prop
 
-    method history:
-      bool t opt prop
+    method menuContent
+      : Menu.menuElement t js_array t prop
 
   end
 
diff --git a/editor/prosemirror/prosemirror.ml b/editor/prosemirror/prosemirror.ml
index e37cc3b..8c436a3 100755
--- a/editor/prosemirror/prosemirror.ml
+++ b/editor/prosemirror/prosemirror.ml
@@ -108,6 +108,16 @@ module Model = struct
       : < dom: node Js.t Js.readonly_prop ; contentDOM : node Js.t Js.opt Js.readonly_prop > Js.t -> domOutputSpec Js.t
       = of_
   end
+
+  module ParseRule = struct
+
+    let tag
+      : Jstr.t -> parse_rule Js.t
+      = fun name ->
+        Jv.obj [| "tag", Jv.of_jstr name |]
+        |> Jv.Id.of_jv
+
+  end
 end
 
 module State = struct
@@ -115,12 +125,12 @@ module State = struct
   include Bindings.State
 
   let configuration_prop
-    : unit -> configuration_prop Js_of_ocaml.Js.t
-    = fun () -> Js_of_ocaml.Js.Unsafe.obj [||]
+    : unit -> configuration_prop Js.t
+    = fun () -> Js.Unsafe.obj [||]
 
   let creation_prop
     : unit -> creation_prop Js.t
-    = fun () -> Js_of_ocaml.Js.Unsafe.obj [||]
+    = fun () -> Js.Unsafe.obj [||]
 
   let create
     : t -> creation_prop Js.t -> editor_state Js.t
@@ -131,13 +141,18 @@ module State = struct
       |> Jv.Id.of_jv
 
   let fromJSON
-    : t -> configuration_prop Js_of_ocaml.Js.t -> Brr.Json.t -> editor_state Js.t
+    : t -> configuration_prop Js.t -> Brr.Json.t -> editor_state Js.t
     = fun t config json ->
       let state = Jv.get t "state" in
       let editor_state = Jv.get state "EditorState" in
       Jv.call editor_state "fromJSON" [|Jv.Id.to_jv config ; json |]
       |> Jv.Id.of_jv
 
+  let selection_from
+    : selection Js.t -> Model.resolved_pos Js.t
+    = fun selection ->
+      Jv.Id.(of_jv @@ Jv.get (to_jv selection) "$from")
+
   let selection_to
     : selection Js.t -> Model.resolved_pos Js.t
     = fun selection ->
@@ -183,6 +198,10 @@ module State = struct
     : selection Js.t -> Model.resolved_pos Js.t Js.opt
     = fun selection ->
       Jv.Id.(of_jv @@ Jv.get (to_jv selection) "$cursor")
+
+  let create_str_meta_data
+    : Jstr.t -> 'a meta_data Js.t
+    = Obj.magic
 end
 
 (* Editor view *)
@@ -196,7 +215,7 @@ module View = struct
   include Bindings.View
   let direct_editor_props
     : unit -> direct_editor_props Js.t
-    = fun () -> Js_of_ocaml.Js.Unsafe.obj [||]
+    = fun () -> Js.Unsafe.obj [||]
 
   let editor_view
     : t -> El.t -> direct_editor_props Js.t -> editor_view Js.t
@@ -206,6 +225,26 @@ module View = struct
 
 end
 
+module Transform = struct
+
+  include Bindings.Transform
+
+  let offset
+    : t -> int -> step_map Js.t
+    = fun t n ->
+      let stepmap = Jv.get (Jv.get t "transform") "StepMap" in
+      Jv.call stepmap "offset" [|Jv.Id.to_jv n|]
+      |> Jv.Id.of_jv
+
+  let insertPoint
+    : t -> Model.node Js.t -> pos:int -> Model.node_type Js.t -> int Js.opt
+    = fun t node ~pos node_t ->
+      let transform = Jv.get t "transform" in
+      Jv.call transform "insertPoint" Jv.Id.[|to_jv node ; to_jv pos; to_jv node_t|]
+      |> Jv.Id.of_jv
+
+end
+
 module Commands = struct
 
   type t = State.editor_state Js.t -> State.dispatch Js.opt -> bool Js.t
@@ -238,7 +277,7 @@ module History = struct
 
   let history_prop
     : unit -> history_prop Js.t
-    = fun () -> Js_of_ocaml.Js.Unsafe.obj [||]
+    = fun () -> Js.Unsafe.obj [||]
 
   let history
     : t -> history_prop Js.t -> State.plugin Js.t
@@ -324,6 +363,22 @@ module SchemaList = struct
 
 end
 
+module Menu = struct
+
+  include Bindings.Menu
+
+  let menuItemSpec
+    : unit -> menuItemSpec Js.t
+    = fun () -> Js.Unsafe.obj [||]
+
+  let menu_item
+    : t -> menuItemSpec Js.t -> menuItem Js.t
+    = fun t spec ->
+      let menu = Jv.get t "menu" in
+      Jv.new' (Jv.get menu "MenuItem") [| Jv.Id.to_jv spec |]
+      |> Jv.Id.of_jv
+
+end
 
 (* Example Setup *)
 
@@ -343,4 +398,11 @@ module Example = struct
       let setup = Jv.get t "example_setup" in
       Jv.call setup "exampleSetup" [|Jv.Id.to_jv options|]
       |> Jv.Id.of_jv
+
+  let buildMenuItems
+    : t -> Model.schema Js.t -> menuItems Js.t
+    = fun t schema ->
+      let setup = Jv.get t "example_setup" in
+      Jv.call setup "buildMenuItems" [|Jv.Id.to_jv schema|]
+      |> Jv.Id.of_jv
 end
diff --git a/editor/prosemirror/prosemirror.mli b/editor/prosemirror/prosemirror.mli
index eac895a..76545d2 100755
--- a/editor/prosemirror/prosemirror.mli
+++ b/editor/prosemirror/prosemirror.mli
@@ -10,58 +10,9 @@ val v
 
 module O = Bindings.TypedObject
 
-module rec Model : sig
-
-  include module type of Bindings.Model
-
-  val schema_spec: 
-    node_spec Bindings.ordered_map Js.t
-    -> mark_spec Bindings.ordered_map Js.t option 
-    -> string option 
-    -> schema_spec Js.t
-
-  val schema 
-    : t -> schema_spec Js.t -> schema Js.t 
-
-  module DOMParser : sig
-
-    type parser
-
-    val from_schema
-      : t -> schema Js.t -> parser
-
-    val parse
-      : parser -> El.t -> node Js.t
-
-  end
-
-  val empty_fragment 
-    : t -> fragment Js.t
-
-  module Dom_output_spec : sig
-
-    val v
-      : ?attrs:< .. > -> string -> domOutputSpec Js.t list -> domOutputSpec Js.t
-
-    (** Hole element inside an output_spec element *)
-    val hole
-      : domOutputSpec Js.t
-
-    val of_el
-      : Brr.El.t -> domOutputSpec Js.t
-
-    val of_jstr
-      : Jstr.t -> domOutputSpec Js.t
-
-    val of_obj
-      : < dom: node Js.t Js.readonly_prop ; contentDOM : node Js.t Js.opt Js.readonly_prop > Js.t -> domOutputSpec Js.t
-  end
-
-end
-
 (* State *)
 
-and State : sig
+module rec State : sig
 
   include module type of Bindings.State
 
@@ -77,6 +28,9 @@ and State : sig
   val fromJSON 
     : t -> configuration_prop Js.t -> Brr.Json.t -> editor_state Js.t
 
+  val selection_from
+    : selection Js.t -> Model.resolved_pos Js.t 
+
   val selection_to 
     : selection Js.t -> Model.resolved_pos Js.t 
 
@@ -98,6 +52,9 @@ and State : sig
   val cursor 
     : selection Js.t -> Model.resolved_pos Js.t Js.opt
 
+  val create_str_meta_data 
+    : Jstr.t -> 'a meta_data Js.t
+
 end
 
 (* Editor view *)
@@ -120,6 +77,73 @@ and View : sig
 
 end
 
+and  Model : sig
+
+  include module type of Bindings.Model
+
+  val schema_spec: 
+    node_spec Bindings.ordered_map Js.t
+    -> mark_spec Bindings.ordered_map Js.t option 
+    -> string option 
+    -> schema_spec Js.t
+
+  val schema 
+    : t -> schema_spec Js.t -> schema Js.t 
+
+  module DOMParser : sig
+
+    type parser
+
+    val from_schema
+      : t -> schema Js.t -> parser
+
+    val parse
+      : parser -> El.t -> node Js.t
+
+  end
+
+  val empty_fragment 
+    : t -> fragment Js.t
+
+  module Dom_output_spec : sig
+
+    val v
+      : ?attrs:< .. > -> string -> domOutputSpec Js.t list -> domOutputSpec Js.t
+
+    (** Hole element inside an output_spec element *)
+    val hole
+      : domOutputSpec Js.t
+
+    val of_el
+      : Brr.El.t -> domOutputSpec Js.t
+
+    val of_jstr
+      : Jstr.t -> domOutputSpec Js.t
+
+    val of_obj
+      : < dom: node Js.t Js.readonly_prop ; contentDOM : node Js.t Js.opt Js.readonly_prop > Js.t -> domOutputSpec Js.t
+  end
+
+  module ParseRule : sig 
+
+    val tag: Jstr.t -> parse_rule Js.t
+
+  end
+
+end
+
+and Transform : sig 
+
+  include module type of Bindings.Transform
+
+  val offset
+    : t -> int -> step_map Js.t
+
+  val insertPoint 
+    : t -> Model.node Js.t -> pos:int -> Model.node_type Js.t -> int Js.opt
+
+end
+
 module Commands : sig
 
   type t = State.editor_state Js.t -> State.dispatch Js.opt -> bool Js.t
@@ -190,6 +214,17 @@ module SchemaList : sig
 
 end
 
+module Menu : sig
+
+  include module type of Bindings.Menu
+
+  val menuItemSpec
+    : unit -> menuItemSpec Js.t
+
+  val menu_item
+    : t -> menuItemSpec Js.t -> menuItem Js.t
+end
+
 (* Example Setup *)
 
 module Example : sig
@@ -201,4 +236,7 @@ module Example : sig
 
   val example_setup
     : t -> options Js.t -> State.plugin Js.t Js.js_array Js.t
-end
+
+  val buildMenuItems 
+    : t -> Model.schema Js.t -> menuItems Js.t
+end 
diff --git a/editor/tooltip.ml b/editor/tooltip.ml
index 693d68d..43c345f 100755
--- a/editor/tooltip.ml
+++ b/editor/tooltip.ml
@@ -29,10 +29,9 @@ let set_position
       Jstr.( (of_float ( box_bottom -. start##.top )) + (v "px") )
       el
 
-let 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 "tooltip")]) in
@@ -45,86 +44,48 @@ let tooltip
       : PM.View.editor_view Js.t -> PM.State.editor_state Js. t Js.opt -> unit
       = fun view state_opt ->
 
-        Js.Opt.iter state_opt
-          (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 ->
+        (* Compare the previous and actual state. If the stored marks are the
+           same, just return *)
         let state = view##.state in
-        let is_bold = Option.bind (PM.O.get state##.schema##.marks "strong")
-            (fun 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 = Option.bind (PM.O.get state##.schema##.marks "em")
-            (fun 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
+        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_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 "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
 
-- 
cgit v1.2.3