From e612a344629b999e90089710646e7a0bc68597d2 Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Sun, 14 Feb 2021 19:32:36 +0100 Subject: Update prosemirror --- editor/editor.css | 36 +++++ editor/editor.ml | 102 +++++++++++++-- editor/prosemirror/bindings.ml | 262 ++++++++++++++++++++++++++++++++----- editor/prosemirror/prosemirror.ml | 116 ++++++++++++++-- editor/prosemirror/prosemirror.mli | 56 +++++++- 5 files changed, 519 insertions(+), 53 deletions(-) diff --git a/editor/editor.css b/editor/editor.css index 8f29bde..fb58773 100644 --- a/editor/editor.css +++ b/editor/editor.css @@ -324,3 +324,39 @@ li.ProseMirror-selectednode:after { } .ProseMirror p { margin-bottom: 1em } + +.editor em::before, .editor em::after { + content: "//" +} + +.editor blockquote p::before { + content: "> " +} + +.editor strong::before, .editor strong::after { + content: "**" +} + +.editor h1::before { + content: "# " +} + +.editor h2::before { + content: "## " +} + +.editor h3::before { + content: "### " +} + +.editor h4::before { + content: "#### " +} + +.editor h5::before { + content: "##### " +} + +.editor h6::before { + content: "###### " +} diff --git a/editor/editor.ml b/editor/editor.ml index c32a5ba..64fb723 100755 --- a/editor/editor.ml +++ b/editor/editor.ml @@ -1,5 +1,96 @@ open Js_of_ocaml open Brr +module PM = Prosemirror + +let change_level + : PM.t -> PM.Model.resolved_pos Js.t -> PM.State.editor_state Js.t -> int -> (PM.State.transaction Js.t -> unit) -> (int -> bool) -> bool + = fun pm res state incr dispatch pred -> + let parent = res##.parent in + let attributes = parent##.attrs in + + (* There are some problems to update the view when the content is empty. + It looks like the comparaison does not comprae the level argument. + In order to prevent any error, juste return in such situation. + *) + let empty_content = parent##.content##eq (PM.Model.empty_fragment pm) + and level = attributes##.level in + if (pred level || empty_content) then false + else + (* Look the position for the previous element *) + let resolved = (res##.doc)##resolve (res##.pos -1) in + let selection = PM.State.node_selection pm resolved in + + let props = object%js + val level = level + incr + end in + + let element = parent##copy (PM.Model.empty_fragment pm) in + element##.attrs := props; + element##.content := parent##.content; + + (* Create a new transaction for replacing the selection *) + let tr = state##.tr in + let tr = tr##replaceRangeWith + selection##.from + selection##._to + element in + + (* Return at the initial position *) + let position = PM.State.create_text_selection + pm + tr##.doc + res##.pos in + let tr = tr##setSelection position in + dispatch (tr##scrollIntoView ()); + true + +let handle_backspace pm state dispatch = + + (* Get the currrent node *) + let res = PM.State.selection_to (state##.selection) in + + match Js.Opt.to_option res##.nodeBefore with + | Some _ -> false + | None -> (* Line start *) + let parent = res##.parent in + begin match Jstr.to_string parent##._type##.name with + | "heading" -> change_level pm res state (-1) dispatch (fun x -> x <= 1) + | _ -> false + end + + +(** Increase the title level by one when pressing # at the begining of a line *) +let handle_sharp pm state dispatch = + (* Get the currrent node *) + let res = PM.State.selection_to (state##.selection) in + + match Js.Opt.to_option res##.nodeBefore with + | Some _ -> false + | None -> (* Line start *) + let parent = res##.parent in + begin match Jstr.to_string parent##._type##.name with + | "heading" -> change_level pm res state (+1) dispatch (fun x -> x > 5) + | _ -> false + end + + +let default_plugins pm schema = + + let props = PM.Example.options schema in + props##.menuBar := Js.some false; + props##.floatingMenu := Js.some false; + 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 + + Js.some setup let create_new_state pm mySchema content = let module PM = Prosemirror in @@ -11,7 +102,7 @@ let create_new_state pm mySchema content = let props = PM.State.creation_prop () in props##.doc := Js.some doc; - props##.plugins := Js.some (PM.example_setup pm mySchema); + props##.plugins := default_plugins pm mySchema; PM.State.create pm @@ -50,23 +141,16 @@ let prosemirror id content = Console.(log [Jstr.v "Loading json"]); let history = PM.History.(history pm (history_prop ()) ) in - Console.(log [history]); let _ = history in let obj = PM.State.configuration_prop () in - obj##.plugins := Js.some (PM.example_setup pm mySchema); + obj##.plugins := default_plugins pm mySchema; obj##.schema := Js.some mySchema; PM.State.fromJSON pm obj json end in let props = PM.View.direct_editor_props () in - props##.dispatchTransaction := (Js.wrap_meth_callback (fun view transaction -> - Console.(log [ Jstr.v "Document size went from" - ; transaction##.before##.content##.size ]); - let state = view##.state##apply transaction in - view##updateState state - )); props##.state := state; diff --git a/editor/prosemirror/bindings.ml b/editor/prosemirror/bindings.ml index 08db819..f6d4223 100755 --- a/editor/prosemirror/bindings.ml +++ b/editor/prosemirror/bindings.ml @@ -1,5 +1,47 @@ open Js_of_ocaml.Js +module TypedObject : sig + + type 'a t + + val get + : 'a t -> Jv.prop -> 'a option + + val get' + : 'a t -> Jv.prop' -> 'a option + + val set + : 'a t -> Jv.prop -> 'a -> unit + + val set' + : 'a t -> Jv.prop' -> 'a -> unit + +end = struct + + type 'a t = Jv.t + + let get + : 'a t -> Jv.prop -> 'a + = fun t prop -> + Jv.to_option Jv.Id.of_jv (Jv.get t prop) + + let get' + : 'a t -> Jv.prop' -> 'a + = fun t prop -> + Jv.to_option Jv.Id.of_jv (Jv.get' t prop) + + let set + : 'a t -> Jv.prop -> 'a -> unit + = fun o prop v -> + Jv.set o prop (Jv.Id.to_jv v) + + let set' + : 'a t -> Jv.prop' -> 'a -> unit + = fun o prop v -> + Jv.set' o prop (Jv.Id.to_jv v) + +end + class type ['a] ordered_map = object ('this) method get: @@ -21,63 +63,131 @@ end module Model = struct + type domOutputSpec + + class type _node_props = object ('this) + + method inlineContent: + bool readonly_prop + (** True if this node type has inline content. *) + + method isBlock: + bool readonly_prop + + method isText: + bool readonly_prop + + method isInline: + bool readonly_prop + + method isTextblock: + bool readonly_prop + + method isLeaf: + bool readonly_prop + + method isAtom: + bool readonly_prop + + end + + type mark type node_spec - type mark_spec + type content_match - class type schema_spec = object ('this) + type slice - method nodes: - node_spec ordered_map t readonly_prop + class type resolved_pos = object ('this) + + method pos: + int readonly_prop + + method depth: + int readonly_prop + + method parent: + node t readonly_prop + + method doc: + node t readonly_prop + + method node: + int -> node t meth + + method index: + int -> int meth + + method nodeAfter: + node t opt readonly_prop + + method nodeBefore: + node t opt readonly_prop method marks: - mark_spec ordered_map t readonly_prop + unit -> mark t js_array t meth - method topNode: - Jstr.t opt readonly_prop + method sameParent: + 'this -> bool t meth + method max: + 'this -> 'this t meth + + method min: + 'this -> 'this t meth end - class type schema = object ('this) + and mark_spec = object ('this) - method spec: - schema_spec t prop + method toDOM: + (node t -> domOutputSpec t) callback writeonly_prop + + method inclusive: + bool t prop + + method spanning: + bool t prop end - type content_match + and schema_spec = object ('this) - type slice + method nodes: + node_spec ordered_map t readonly_prop - class type _node_props = object ('this) + method marks: + mark_spec ordered_map t readonly_prop - method inlineContent: - bool readonly_prop - (** True if this node type has inline content. *) + method topNode: + Jstr.t opt readonly_prop - method isBlock: - bool readonly_prop + end - method isText: - bool readonly_prop + and schema = object ('this) - method isInline: - bool readonly_prop + method spec: + schema_spec t prop - method isTextblock: - bool readonly_prop + method nodes: + node_type t TypedObject.t readonly_prop - method isLeaf: - bool readonly_prop + method marks: + mark_type t TypedObject.t readonly_prop - method isAtom: - bool readonly_prop + method typoNodeType: + node_type t readonly_prop + + method text: + Jstr.t -> node t meth + + method node: + Jstr.t -> < .. > t opt -> fragment t opt -> mark t js_array t opt -> node t meth end - class type node_type = object ('this) + and node_type = object ('this) inherit _node_props @@ -96,13 +206,30 @@ module Model = struct method hasRequiredAttrs: unit -> bool meth + method create_withFragment: + < .. > t -> fragment t opt -> mark t opt -> node t meth + end - class type mark_type = object ('this) + (** Signature for MarkType class + + https://prosemirror.net/docs/ref/#model.MarkType + *) + and mark_type = object ('this) + + method name: + Jstr.t readonly_prop + + method schema: + schema t readonly_prop + + method spec: + mark_spec t readonly_prop + end (** Common signature between fragment and node *) - class type _element = object ('this) + and _element = object ('this) method childCount: int readonly_prop @@ -164,16 +291,29 @@ module Model = struct node_type t readonly_prop method attrs: - < .. > t readonly_prop + < .. > t prop method content: - fragment t readonly_prop + 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 meth + + method text: + Jstr.t opt prop + end end @@ -219,6 +359,12 @@ module Transform = struct method step: step t -> 'this t meth + method insert: + int -> Model.node t -> 'this t meth + + method replaceRangeWith: + int -> int -> Model.node t -> 'this t meth + end end @@ -244,12 +390,33 @@ module State = struct class type selection = object ('this) + method from: + int readonly_prop + + method _to: + int readonly_prop + method content: unit -> Model.slice t meth method replace: transaction t -> Model.slice t -> unit meth + method replaceWith: + transaction t -> Model.node t -> unit meth + + end + + and text_selection = object ('this) + + inherit selection + + end + + and node_selection = object ('this) + + inherit selection + end and transaction = object ('this) @@ -295,12 +462,19 @@ module State = struct method replaceSelection: Model.slice t -> 'this t meth + method replaceSelectionWith: + Model.node t -> bool t -> 'this t meth + method selectionSet: bool readonly_prop method before: Model.node t readonly_prop + method scrollIntoView : + unit -> 'this t meth + + end class type configuration_prop = object ('this) @@ -398,6 +572,9 @@ module View = struct method updateState: State.editor_state t -> unit meth + method dispatch: + State.transaction t -> unit meth + end end @@ -464,3 +641,22 @@ module History = struct end end + +module Example = struct + + class type options = object ('this) + + method schema: + Model.schema t prop + + method menuBar: + bool opt prop + + method floatingMenu: + bool opt prop + + method history: + bool opt prop + + end +end diff --git a/editor/prosemirror/prosemirror.ml b/editor/prosemirror/prosemirror.ml index c19abe0..e97fa9b 100755 --- a/editor/prosemirror/prosemirror.ml +++ b/editor/prosemirror/prosemirror.ml @@ -8,12 +8,15 @@ let v = fun () -> Jv.get Jv.global "PM" +module O = Bindings.TypedObject + module Model = struct include Bindings.Model module DOMParser = struct + type parser = Jv.t let from_schema @@ -63,6 +66,46 @@ module Model = struct Jv.get fragment "empty" |> Jv.Id.of_jv + module Dom_output_spec = struct + + let v + : ?attrs:< .. > -> string -> domOutputSpec Js.t list -> domOutputSpec Js.t + = fun ?attrs name elems -> + + let elems = match attrs with + | None -> elems + | Some v -> Jv.Id.(of_jv @@ to_jv @@ v)::elems in + + let elems = (Jv.Id.of_jv @@ Jv.of_string name)::elems in + (Jv.of_list Jv.Id.to_jv elems) + |> Jv.Id.to_jv + |> Jv.Id.of_jv + + let hole + : domOutputSpec Js.t + = 0 + |> Jv.Id.to_jv + |> Jv.Id.of_jv + + let of_ + : 'a -> domOutputSpec Js.t + = fun elem -> + elem + |> Jv.Id.to_jv + |> Jv.Id.of_jv + + let of_el + : Brr.El.t -> domOutputSpec Js.t + = of_ + + let of_jstr + : Jstr.t -> domOutputSpec Js.t + = of_ + + let of_obj + : < dom: node Js.t Js.readonly_prop ; contentDOM : node Js.t Js.opt Js.readonly_prop > Js.t -> domOutputSpec Js.t + = of_ + end end module State = struct @@ -92,6 +135,47 @@ module State = struct 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_to + : selection Js.t -> Model.resolved_pos Js.t + = fun selection -> + Jv.Id.(of_jv @@ Jv.get (to_jv selection) "$to") + + let node_selection + : t -> Model.resolved_pos Js.t -> node_selection Js.t + = fun t pos -> + let state = Jv.get t "state" in + Jv.new' (Jv.get state "NodeSelection") [| Jv.Id.to_jv pos |] + |> Jv.Id.of_jv + + let is_selectable + : t -> Model.node Js.t -> bool Js.t + = fun t node -> + let selection = Jv.get (Jv.get t "state") "NodeSelection" in + Jv.call selection "isSelectable" [|Jv.Id.to_jv node|] + |> Jv.Id.of_jv + + let selection_at_start + : t-> Model.node Js.t -> selection Js.t + = fun t node -> + let selection = Jv.get (Jv.get t "state") "NodeSelection" in + Jv.call selection "atStart" [|Jv.Id.to_jv node|] + |> Jv.Id.of_jv + + + let create_node_selection + : t -> Model.node Js.t -> int -> node_selection Js.t + = fun t doc number -> + let state = Jv.get t "state" in + Jv.call (Jv.get state "NodeSelection") "create" Jv.Id.[|to_jv doc; Jv.of_int number|] + |> Jv.Id.of_jv + + let create_text_selection + : t -> Model.node Js.t -> int -> node_selection Js.t + = fun t doc number -> + let state = Jv.get t "state" in + Jv.call (Jv.get state "TextSelection") "create" Jv.Id.[|to_jv doc; Jv.of_int number|] + |> Jv.Id.of_jv end (* Editor view *) @@ -142,6 +226,12 @@ module SchemaBasic = struct Jv.get (Jv.get t "schema_basic") "schema" |> Jv.Id.of_jv + let nodes + : t -> nodes Js.t + = fun t -> + Jv.get (Jv.get t "schema_basic") "nodes" + |> Jv.Id.of_jv + end module History = struct @@ -174,7 +264,7 @@ end module Keymap = struct let keymap - : t -> (string * (State.editor_state Js.t -> (State.transaction -> unit) -> bool)) array -> State.plugin Js.t + : t -> (string * (State.editor_state Js.t -> (State.transaction Js.t -> unit) -> bool)) array -> State.plugin Js.t = fun t props -> let props = Jv.obj @@ Array.map (fun (id, f) -> (id, Jv.repr f)) props in Jv.call (Jv.get t "keymap") "keymap" [|props|] @@ -194,10 +284,20 @@ end (* Example Setup *) -let example_setup - : t -> Model.schema Js.t -> State.plugin Js.t Js.js_array Js.t - = fun t schema -> - let setup = Jv.get t "example_setup" in - let props = Jv.obj [|("schema", Jv.Id.to_jv schema)|] in - Jv.call setup "exampleSetup" [|props|] - |> Jv.Id.of_jv +module Example = struct + + include Bindings.Example + + let options + : Model.schema Js.t -> options Js.t + = fun schema -> + Jv.obj [|("schema", Jv.Id.to_jv schema)|] + |> Jv.Id.of_jv + + let example_setup + : t -> options Js.t -> State.plugin Js.t Js.js_array Js.t + = fun t options -> + let setup = Jv.get t "example_setup" in + Jv.call setup "exampleSetup" [|Jv.Id.to_jv options|] + |> Jv.Id.of_jv +end diff --git a/editor/prosemirror/prosemirror.mli b/editor/prosemirror/prosemirror.mli index aa27bf4..a4c5d35 100755 --- a/editor/prosemirror/prosemirror.mli +++ b/editor/prosemirror/prosemirror.mli @@ -6,6 +6,8 @@ type t val v : unit -> t +module O = Bindings.TypedObject + module rec Model : sig include module type of Bindings.Model @@ -34,6 +36,24 @@ module rec Model : sig 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 @@ -62,6 +82,24 @@ and State : sig val fromJSON : t -> configuration_prop Js.t -> Brr.Json.t -> editor_state Js.t + val selection_to + : selection Js.t -> Model.resolved_pos Js.t + + val selection_at_start + : t-> Model.node Js.t -> selection Js.t + + val is_selectable + : t -> Model.node Js.t -> bool Js.t + + val node_selection + : t -> Model.resolved_pos Js.t -> node_selection Js.t + + val create_node_selection + : t -> Model.node Js.t -> int -> node_selection Js.t + + val create_text_selection + : t -> Model.node Js.t -> int -> text_selection Js.t + end (* Editor view *) @@ -91,6 +129,10 @@ module SchemaBasic : sig val schema : t -> Model.schema Js.t + val nodes + : t -> nodes Js.t + + end module History : sig @@ -113,7 +155,7 @@ end module Keymap : sig val keymap - : t -> (string * (State.editor_state Js.t -> (State.transaction -> unit) -> bool)) array -> State.plugin Js.t + : t -> (string * (State.editor_state Js.t -> (State.transaction Js.t -> unit) -> bool)) array -> State.plugin Js.t end @@ -126,5 +168,13 @@ end (* Example Setup *) -val example_setup - : t -> Model.schema Js.t -> State.plugin Js.t Js.js_array Js.t +module Example : sig + + include module type of Bindings.Example + + val options + : Model.schema Js.t -> options Js.t + + val example_setup + : t -> options Js.t -> State.plugin Js.t Js.js_array Js.t +end -- cgit v1.2.3