From e612a344629b999e90089710646e7a0bc68597d2 Mon Sep 17 00:00:00 2001
From: Sébastien Dailly <sebastien@chimrod.com>
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(-)
(limited to 'editor')
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