diff options
Diffstat (limited to 'editor')
| -rwxr-xr-x | editor/dune | 1 | ||||
| -rw-r--r-- | editor/editor.css | 40 | ||||
| -rwxr-xr-x | editor/editor.ml | 47 | ||||
| -rwxr-xr-x | editor/footnotes.ml | 257 | ||||
| -rwxr-xr-x | editor/plugins.ml | 1 | ||||
| -rwxr-xr-x | editor/prosemirror/bindings.ml | 577 | ||||
| -rwxr-xr-x | editor/prosemirror/prosemirror.ml | 74 | ||||
| -rwxr-xr-x | editor/prosemirror/prosemirror.mli | 140 | ||||
| -rwxr-xr-x | editor/tooltip.ml | 123 |
9 files changed, 900 insertions, 360 deletions
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 |