Working key handler

4 files changed, 64 insertions, 68 deletions

diff --git a/editor/editor.ml b/editor/editor.ml
index 64fb723..d32288c 100755
--- a/editor/editor.ml
+++ b/editor/editor.ml
@@ -3,82 +3,58 @@ 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 ->
+  : PM.t -> PM.Model.resolved_pos Js.t -> int -> (int -> bool) -> PM.State.command
+  = fun pm res incr pred state dispatch ->
     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 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"
+        , (object%js
+          val level = current_level + incr
+        end :> < > Js.t ))
+      | true ->
+        ( PM.O.get state##.schema##.nodes "paragraph"
+        , object%js end) in
+    match t with
+    | None -> Js._false
+    | Some t ->
+      PM.Commands.set_block_type pm t props state dispatch
 
-let handle_backspace pm state dispatch =
+(** 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
+  | Some _ -> Js._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
+    begin match Jstr.to_string res##.parent##._type##.name with
+      | "heading"   -> change_level pm res 1 (fun x -> x > 5) state dispatch
+      | "paragraph" -> change_level pm res 1 (fun _ -> false) state dispatch
+      | _ -> Js._false
     end
 
+let handle_backspace pm state dispatch =
 
-(** 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
+  | Some _ -> Js._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
+    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 default_plugins pm schema =
 
   let props = PM.Example.options schema in
-  props##.menuBar := Js.some false;
-  props##.floatingMenu := Js.some false;
+  props##.menuBar := Js.some Js._true;
+  props##.floatingMenu := Js.some Js._true;
   let setup = PM.Example.example_setup pm props in
 
   let keymaps =
diff --git a/editor/prosemirror/bindings.ml b/editor/prosemirror/bindings.ml
index f6d4223..cb5a47c 100755
--- a/editor/prosemirror/bindings.ml
+++ b/editor/prosemirror/bindings.ml
@@ -365,6 +365,9 @@ module Transform = struct
     method replaceRangeWith:
       int -> int -> Model.node t -> 'this t meth
 
+    method setBlockType:
+      int -> int -> Model.node_type t -> < .. > t -> 'this t meth
+
   end
 
 end
@@ -650,13 +653,13 @@ module Example = struct
       Model.schema t prop
 
     method menuBar:
-      bool opt prop
+      bool t opt prop
 
     method floatingMenu:
-      bool opt prop
+      bool t opt prop
 
     method history:
-      bool opt prop
+      bool t opt prop
 
   end
 end
diff --git a/editor/prosemirror/prosemirror.ml b/editor/prosemirror/prosemirror.ml
index e97fa9b..e2758c7 100755
--- a/editor/prosemirror/prosemirror.ml
+++ b/editor/prosemirror/prosemirror.ml
@@ -112,6 +112,10 @@ module State = struct
 
   include Bindings.State
 
+  type dispatch = (transaction Js.t -> unit)
+
+  type command = editor_state Js.t -> dispatch Js.opt -> bool Js.t
+
   let configuration_prop
     : unit -> configuration_prop Js_of_ocaml.Js.t
     = fun () -> Js_of_ocaml.Js.Unsafe.obj [||]
@@ -176,6 +180,7 @@ module State = struct
       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 *)
@@ -249,13 +254,13 @@ module History = struct
       |> Jv.Id.of_jv
 
   let undo
-    : t -> State.editor_state Js.t -> (State.transaction -> unit) -> bool
+    : t -> State.command
     = fun t state fn ->
       Jv.call (Jv.get t "history") "undo" [|Jv.Id.to_jv state; Jv.repr fn|]
       |> Jv.Id.of_jv
 
   let redo
-    : t -> State.editor_state Js.t -> (State.transaction -> unit) -> bool
+    : t -> State.command
     = fun t state fn ->
       Jv.call (Jv.get t "history") "redo" [|Jv.Id.to_jv state; Jv.repr fn|]
       |> Jv.Id.of_jv
@@ -264,7 +269,7 @@ end
 module Keymap = struct
 
   let keymap
-    : t -> (string * (State.editor_state Js.t -> (State.transaction Js.t -> unit) -> bool)) array -> State.plugin Js.t
+    : t -> (string * State.command) 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|]
@@ -275,11 +280,16 @@ end
 module Commands = struct
 
   let baseKeymap
-    : t -> (string * (State.editor_state Js.t -> (State.transaction -> unit) -> bool)) array
+    : t -> (string * State.command) array
     = fun t ->
       Jv.get (Jv.get t "commands") "baseKeymap"
       |> Jv.Id.of_jv
 
+  let set_block_type
+    : t -> Model.node_type Js.t -> < .. > Js.t -> State.command
+    = fun t node props ->
+      Jv.call (Jv.get t "commands") "setBlockType" Jv.Id.[| to_jv node ; to_jv props |]
+      |> Jv.Id.of_jv
 end
 
 (* Example Setup *)
diff --git a/editor/prosemirror/prosemirror.mli b/editor/prosemirror/prosemirror.mli
index a4c5d35..7a723d3 100755
--- a/editor/prosemirror/prosemirror.mli
+++ b/editor/prosemirror/prosemirror.mli
@@ -100,6 +100,10 @@ and State : sig
   val create_text_selection 
     : t -> Model.node Js.t -> int -> text_selection Js.t
 
+  type dispatch = (transaction Js.t -> unit)
+
+  type command = editor_state Js.t -> dispatch Js.opt -> bool Js.t
+
 end
 
 (* Editor view *)
@@ -146,23 +150,26 @@ module History : sig
     : t -> history_prop Js.t -> State.plugin Js.t
 
   val undo 
-    : t -> State.editor_state Js.t -> (State.transaction -> unit) -> bool
+    : t -> State.command
 
   val redo
-    : t -> State.editor_state Js.t -> (State.transaction -> unit) -> bool
+    : t -> State.command
 end
 
 module Keymap : sig
 
   val keymap
-    : t -> (string * (State.editor_state Js.t -> (State.transaction Js.t -> unit) -> bool)) array -> State.plugin Js.t
+    : t -> (string * State.command) array -> State.plugin Js.t
 
 end
 
 module Commands : sig
 
   val baseKeymap 
-    : t -> (string * (State.editor_state Js.t -> (State.transaction -> unit) -> bool)) array
+    : t -> (string * State.command) array
+
+  val set_block_type 
+    : t -> Model.node_type Js.t -> < .. > Js.t -> State.command
 
 end