Update prosemirror

3 files changed, 390 insertions, 44 deletions

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