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