Update prosemirror

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