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
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