summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rwxr-xr-xeditor/actions/add_page.ml53
-rwxr-xr-xeditor/actions/delete_page.ml37
-rwxr-xr-xeditor/actions/editor_actions.ml359
-rwxr-xr-xeditor/actions/editor_actions.mli9
-rwxr-xr-xeditor/actions/export.ml50
-rwxr-xr-xeditor/actions/import.ml56
-rwxr-xr-xeditor/actions/load_page.ml9
-rwxr-xr-xeditor/actions/of_markdown.ml297
-rwxr-xr-xeditor/actions/to_markdown.ml404
-rwxr-xr-xeditor/editor.ml325
-rwxr-xr-xeditor/plugins/link_editor.ml216
-rwxr-xr-xeditor/plugins/plugins.ml209
-rwxr-xr-xeditor/prosemirror/bindings.ml1054
-rwxr-xr-xeditor/prosemirror/prosemirror.ml580
-rwxr-xr-xeditor/state/state.ml164
-rwxr-xr-xeditor/state/state.mli32
16 files changed, 1769 insertions, 2085 deletions
diff --git a/editor/actions/add_page.ml b/editor/actions/add_page.ml
index dff2c2f..58e991b 100755
--- a/editor/actions/add_page.ml
+++ b/editor/actions/add_page.ml
@@ -2,42 +2,31 @@ module Js = Js_of_ocaml.Js
module App = Editor_app
module M = struct
-
type t = Forms.Add_page.t
- let key_of_title
- : Jstr.t -> Jstr.t
- = fun title ->
- title
+ let key_of_title : Jstr.t -> Jstr.t = fun title -> title
- let process
- : t -> State.t -> State.t
- = fun {title} state ->
- let page_id = key_of_title title in
- State.new_page ~title (Some page_id) state
+ let process : t -> State.t -> State.t =
+ fun { title } state ->
+ let page_id = key_of_title title in
+ State.new_page ~title (Some page_id) state
end
-
(** Create a new element *)
-let create
- : unit -> App.event Note.event
- = fun () ->
- let title = Jstr.v "Nouvelle page" in
- let form = Forms.Add_page.create () in
+let create : unit -> App.event Note.event =
+ fun () ->
+ let title = Jstr.v "Nouvelle page" in
+ let form = Forms.Add_page.create () in
- let valid_on = Note.S.map
- (fun Forms.Add_page.{title} -> not @@ Jstr.equal Jstr.empty title)
- (fst form)
- in
- let ev = Elements.Popup.create
- ~title
- ~form
- ~valid_on
- ()
- in
- Note.E.map
- (fun v -> App.dispatch (module M) v)
- (* Option.on_some trigger the event only when the pop up is validated.
- Closing the popup doesn't do anything.
- *)
- (Note.E.Option.on_some ev)
+ let valid_on =
+ Note.S.map
+ (fun Forms.Add_page.{ title } -> not @@ Jstr.equal Jstr.empty title)
+ (fst form)
+ in
+ let ev = Elements.Popup.create ~title ~form ~valid_on () in
+ Note.E.map
+ (fun v -> App.dispatch (module M) v)
+ (* Option.on_some trigger the event only when the pop up is validated.
+ Closing the popup doesn't do anything.
+ *)
+ (Note.E.Option.on_some ev)
diff --git a/editor/actions/delete_page.ml b/editor/actions/delete_page.ml
index 2b75b2e..4730eee 100755
--- a/editor/actions/delete_page.ml
+++ b/editor/actions/delete_page.ml
@@ -1,31 +1,22 @@
module App = Editor_app
-module M = struct
+module M = struct
type t = unit
- let process
- : t -> State.t -> State.t
- = fun () state ->
- match state.page_id with
- | None -> state
- | Some page_id ->
+ let process : t -> State.t -> State.t =
+ fun () state ->
+ match state.page_id with
+ | None -> state
+ | Some page_id ->
State.Storage.delete (fun () -> Some page_id);
State.load_page None state
-
end
-let create
- : unit -> App.event Note.event
- = fun () ->
- let title = Jstr.v "Confirmation"
- and message =
- Jstr.v "La page sera définitivement supprimée"
- in
- let ev = Elements.Popup.create
- ~title
- ~form:(Forms.Validation.create message)
- ()
- in
- Note.E.map
- (fun v -> App.dispatch (module M) v)
- (Note.E.Option.on_some ev)
+let create : unit -> App.event Note.event =
+ fun () ->
+ let title = Jstr.v "Confirmation"
+ and message = Jstr.v "La page sera définitivement supprimée" in
+ let ev =
+ Elements.Popup.create ~title ~form:(Forms.Validation.create message) ()
+ in
+ Note.E.map (fun v -> App.dispatch (module M) v) (Note.E.Option.on_some ev)
diff --git a/editor/actions/editor_actions.ml b/editor/actions/editor_actions.ml
index eadf1e7..68ce766 100755
--- a/editor/actions/editor_actions.ml
+++ b/editor/actions/editor_actions.ml
@@ -2,7 +2,6 @@ open StdLabels
open Brr
open Brr_note
module App = Editor_app
-
module Js = Js_of_ocaml.Js
(** This is the attribute attached to each link and containing the node id
@@ -17,190 +16,188 @@ type t =
; delete_button : El.t
}
-let build
- : Prosemirror.t -> t
- = fun pm ->
-
- let delete_button = El.button
- ~at:At.[ class' (Jstr.v "action-button") ]
- [ El.i []
- ~at:At.[ class' (Jstr.v "fa")
- ; class' (Jstr.v "fa-2x")
- ; class' (Jstr.v "fa-trash") ] ]
-
- and home_button = El.button
- ~at:At.[ class' (Jstr.v "action-button") ]
- [ El.i []
- ~at:At.[ class' (Jstr.v "fa")
- ; class' (Jstr.v "fa-2x")
- ; class' (Jstr.v "fa-home") ] ]
-
- and add_button = El.button
- ~at:At.[ class' (Jstr.v "action-button") ]
- [ El.i []
- ~at:At.[ class' (Jstr.v "fa")
- ; class' (Jstr.v "fa-2x")
- ; class' (Jstr.v "fa-plus") ] ]
-
- and export_button = El.button
- ~at:At.[class' (Jstr.v "action-button")]
- [ El.i
- []
- ~at:At.[ class' (Jstr.v "fa")
- ; class' (Jstr.v "fa-2x")
- ; class' (Jstr.v "fa-download") ] ]
-
- and load_button = El.button
- ~at:At.[class' (Jstr.v "action-button")]
- [ El.i
- []
- ~at:At.[ class' (Jstr.v "fa")
- ; class' (Jstr.v "fa-2x")
- ; class' (Jstr.v "fa-upload") ] ]
-
- and cog_button = El.button
- ~at:At.[class' (Jstr.v "action-button")]
- [ El.i
- []
- ~at:At.[ class' (Jstr.v "fa")
- ; class' (Jstr.v "fa-2x")
- ; class' (Jstr.v "fa-cog") ]
- ]
-
- in
-
- (* We are waiting for event inside another event ( form validation inside
- popup creation.
-
- Note.E.join is used here in order to get only te popup validation. *)
- let delete_event =
- Note.E.join (
- Evr.on_el
- Ev.click
- (fun _ -> Delete_page.create ())
- delete_button)
-
- (* Event on popup creation *)
- and add_event =
- Note.E.join (
- Evr.on_el
+let build : Prosemirror.t -> t =
+ fun pm ->
+ let delete_button =
+ El.button
+ ~at:At.[ class' (Jstr.v "action-button") ]
+ [ El.i
+ []
+ ~at:
+ At.
+ [ class' (Jstr.v "fa")
+ ; class' (Jstr.v "fa-2x")
+ ; class' (Jstr.v "fa-trash")
+ ]
+ ]
+ and home_button =
+ El.button
+ ~at:At.[ class' (Jstr.v "action-button") ]
+ [ El.i
+ []
+ ~at:
+ At.
+ [ class' (Jstr.v "fa")
+ ; class' (Jstr.v "fa-2x")
+ ; class' (Jstr.v "fa-home")
+ ]
+ ]
+ and add_button =
+ El.button
+ ~at:At.[ class' (Jstr.v "action-button") ]
+ [ El.i
+ []
+ ~at:
+ At.
+ [ class' (Jstr.v "fa")
+ ; class' (Jstr.v "fa-2x")
+ ; class' (Jstr.v "fa-plus")
+ ]
+ ]
+ and export_button =
+ El.button
+ ~at:At.[ class' (Jstr.v "action-button") ]
+ [ El.i
+ []
+ ~at:
+ At.
+ [ class' (Jstr.v "fa")
+ ; class' (Jstr.v "fa-2x")
+ ; class' (Jstr.v "fa-download")
+ ]
+ ]
+ and load_button =
+ El.button
+ ~at:At.[ class' (Jstr.v "action-button") ]
+ [ El.i
+ []
+ ~at:
+ At.
+ [ class' (Jstr.v "fa")
+ ; class' (Jstr.v "fa-2x")
+ ; class' (Jstr.v "fa-upload")
+ ]
+ ]
+ and cog_button =
+ El.button
+ ~at:At.[ class' (Jstr.v "action-button") ]
+ [ El.i
+ []
+ ~at:
+ At.
+ [ class' (Jstr.v "fa")
+ ; class' (Jstr.v "fa-2x")
+ ; class' (Jstr.v "fa-cog")
+ ]
+ ]
+ in
+
+ (* We are waiting for event inside another event ( form validation inside
+ popup creation.
+
+ Note.E.join is used here in order to get only te popup validation. *)
+ let delete_event =
+ Note.E.join
+ (Evr.on_el Ev.click (fun _ -> Delete_page.create ()) delete_button)
+ (* Event on popup creation *)
+ and add_event =
+ Note.E.join (Evr.on_el Ev.click (fun _ -> Add_page.create ()) add_button)
+ and export_event =
+ Evr.on_el Ev.click (fun _ -> Export.create ()) export_button
+ and import_event =
+ Note.E.join (Evr.on_el Ev.click (fun _ -> Import.create ()) load_button)
+ and cog_event =
+ Evr.on_el Ev.click (fun _ -> To_markdown.create pm) cog_button
+ in
+
+ let ul = El.ul [] in
+
+ (* Wait for a click on an existing page in order to sent the associated
+ event.
+
+ We compose the resulting event with both :
+ - the home button
+ - the list for all the pages presents in the sidebar
+
+ We use the bubble property in order to listen only the [ul] element and
+ not the each entry in the list. This way, there is no recursive loop
+ between the redirect_handler and the dynamic generation of elements
+ inside the [ul] node. *)
+ let redirect_event =
+ Note.E.select
+ [ Evr.on_el
Ev.click
- (fun _ -> Add_page.create ())
- add_button)
-
- and export_event =
- Evr.on_el
- Ev.click
- (fun _ -> Export.create ())
- export_button
-
- and import_event =
- Note.E.join (
- Evr.on_el
+ (fun _ -> App.dispatch (module Load_page.M) None)
+ home_button
+ ; Evr.on_el
Ev.click
- (fun _ -> Import.create ())
- load_button)
- and cog_event =
- Evr.on_el
- Ev.click
- (fun _ -> To_markdown.create pm)
- cog_button
- in
-
-
- let ul = El.ul [] in
-
- (* Wait for a click on an existing page in order to sent the associated
- event.
-
- We compose the resulting event with both :
- - the home button
- - the list for all the pages presents in the sidebar
-
- We use the bubble property in order to listen only the [ul] element and
- not the each entry in the list. This way, there is no recursive loop
- between the redirect_handler and the dynamic generation of elements
- inside the [ul] node. *)
- let redirect_event =
- Note.E.select
- [ Evr.on_el
- Ev.click
- (fun _ -> App.dispatch (module Load_page.M) None)
- home_button
- ; Evr.on_el
- Ev.click
- (fun ev ->
- let el = Jv.Id.of_jv @@ Jv.Id.to_jv @@ Ev.target ev in
- let name = El.at note_id_attribute el in
- App.dispatch (module Load_page.M) name)
- ul ] in
-
- let childs =
- [ home_button
- ; add_button
- ; export_button
- ; load_button
- ; delete_button
- ; cog_button
- ; El.hr ()
- ; ul ] in
-
- let result_event =
- Note.E.select
- [ delete_event
- ; redirect_event
- ; add_event
- ; export_event
- ; import_event
- ; cog_event ] in
-
- { ev = result_event
- ; childs
- ; ul
+ (fun ev ->
+ let el = Jv.Id.of_jv @@ Jv.Id.to_jv @@ Ev.target ev in
+ let name = El.at note_id_attribute el in
+ App.dispatch (module Load_page.M) name )
+ ul
+ ]
+ in
+
+ let childs =
+ [ home_button
+ ; add_button
+ ; export_button
+ ; load_button
; delete_button
- ; completed = false }
+ ; cog_button
+ ; El.hr ()
+ ; ul
+ ]
+ in
+
+ let result_event =
+ Note.E.select
+ [ delete_event
+ ; redirect_event
+ ; add_event
+ ; export_event
+ ; import_event
+ ; cog_event
+ ]
+ in
+
+ { ev = result_event; childs; ul; delete_button; completed = false }
+
-let get_event
- : t -> App.event Note.event
- = fun {ev; _} -> ev
+let get_event : t -> App.event Note.event = fun { ev; _ } -> ev
(** Collect all the notes in the cache and return them into links. *)
let get_notes _ =
- List.map
- (State.Storage.get_ids ())
- ~f:(fun id ->
- let name_opt = (State.Storage.load (Some id))##.title in
- let name = Js.Opt.get name_opt (fun () -> id) in
- El.li
- [ El.a
- ~at:[ At.href (Jstr.v "#")
- ; At.v note_id_attribute id
- ]
- [ El.txt name ] ])
-
-let complete
- : t -> State.t Note.signal -> El.t list
- = fun t change ->
-
- (* As we register some events, we have to prevent many execution of this
- function *)
- let () =
- if t.completed then
- raise (Failure "The action panel is already registered") in
- t.completed <- true;
-
- Elr.def_children
- t.ul
- (Note.S.map get_notes change);
-
- Elr.def_at
- (Jstr.v "disabled")
- (Note.S.map
- (fun state ->
- match state.State.page_id with
- | None -> Some Jstr.empty
- | Some _ -> None)
- change)
- t.delete_button;
-
- t.childs
+ List.map (State.Storage.get_ids ()) ~f:(fun id ->
+ let name_opt = (State.Storage.load (Some id))##.title in
+ let name = Js.Opt.get name_opt (fun () -> id) in
+ El.li
+ [ El.a
+ ~at:[ At.href (Jstr.v "#"); At.v note_id_attribute id ]
+ [ El.txt name ]
+ ] )
+
+
+let complete : t -> State.t Note.signal -> El.t list =
+ fun t change ->
+ (* As we register some events, we have to prevent many execution of this
+ function *)
+ let () =
+ if t.completed then raise (Failure "The action panel is already registered")
+ in
+ t.completed <- true;
+
+ Elr.def_children t.ul (Note.S.map get_notes change);
+
+ Elr.def_at
+ (Jstr.v "disabled")
+ (Note.S.map
+ (fun state ->
+ match state.State.page_id with
+ | None -> Some Jstr.empty
+ | Some _ -> None )
+ change )
+ t.delete_button;
+
+ t.childs
diff --git a/editor/actions/editor_actions.mli b/editor/actions/editor_actions.mli
index b1ac054..6f3421a 100755
--- a/editor/actions/editor_actions.mli
+++ b/editor/actions/editor_actions.mli
@@ -1,16 +1,13 @@
type t
+val build : Prosemirror.t -> t
(** Create the elements to be declared inside the panel *)
-val build
- : Prosemirror.t -> t
+val get_event : t -> Editor_app.event Note.event
(** Get the events triggered by the actions buttons *)
-val get_event
- : t -> Editor_app.event Note.event
+val complete : t -> State.t Note.signal -> Brr.El.t list
(** Finalize the creation, register the handler to state update, and return the
dom elements.
Raise an error if already completed. *)
-val complete
- : t -> State.t Note.signal -> Brr.El.t list
diff --git a/editor/actions/export.ml b/editor/actions/export.ml
index 27c6a26..3c70bd3 100755
--- a/editor/actions/export.ml
+++ b/editor/actions/export.ml
@@ -2,35 +2,31 @@ module Js = Js_of_ocaml.Js
module App = Editor_app
module M = struct
-
type t = unit
- let process
- : t -> State.t -> State.t
- = fun _ state ->
-
- (* Save this as a json element. The text may contains UTF-16 characters,
- which will raise an error in the btoa function.
-
- As an easy solution, we convert them into UTF-8 through the native
- OCaml representation of string.
- *)
- let json = State.Storage.to_json ()
- |> Jstr.to_string (* Encode into UTF-8 *)
- |> Obj.magic (* Then type the element again as a string. *)
- in
- Elements.Transfert.send
- ~mime_type:(Jstr.v "application/json")
- ~filename:(Jstr.v "export.json")
- json;
-
- (* The function does not actually update the state, and return it
- unchanged *)
- state
-
+ let process : t -> State.t -> State.t =
+ fun _ state ->
+ (* Save this as a json element. The text may contains UTF-16 characters,
+ which will raise an error in the btoa function.
+
+ As an easy solution, we convert them into UTF-8 through the native
+ OCaml representation of string.
+ *)
+ let json =
+ State.Storage.to_json ()
+ |> Jstr.to_string (* Encode into UTF-8 *)
+ |> Obj.magic
+ (* Then type the element again as a string. *)
+ in
+ Elements.Transfert.send
+ ~mime_type:(Jstr.v "application/json")
+ ~filename:(Jstr.v "export.json")
+ json;
+
+ (* The function does not actually update the state, and return it
+ unchanged *)
+ state
end
(** Create a new element *)
-let create
- : unit -> App.event
- = fun () -> App.dispatch (module M) ()
+let create : unit -> App.event = fun () -> App.dispatch (module M) ()
diff --git a/editor/actions/import.ml b/editor/actions/import.ml
index b87960b..9539bd3 100755
--- a/editor/actions/import.ml
+++ b/editor/actions/import.ml
@@ -1,58 +1,52 @@
module Js = Js_of_ocaml.Js
module App = Editor_app
-let uncheck_import =
- fun ~previous ~update ->
+let uncheck_import ~previous ~update =
let _ = previous
and _ = update in
true
-let check_import =
- fun ~previous ~update ->
- Js.Opt.case previous##.date
+
+let check_import ~previous ~update =
+ Js.Opt.case
+ previous##.date
(fun () -> true)
(fun previous_date ->
- Js.Opt.case update##.date
- (fun () -> true)
- (fun update_date ->
- update_date >= previous_date ))
+ Js.Opt.case
+ update##.date
+ (fun () -> true)
+ (fun update_date -> update_date >= previous_date) )
-module M = struct
+module M = struct
type t = Forms.Selector.t
- let process
- : t -> State.t -> State.t
- = fun t state ->
- match t.Forms.Selector.file with
- | None -> state
- | Some file ->
+ let process : t -> State.t -> State.t =
+ fun t state ->
+ match t.Forms.Selector.file with
+ | None -> state
+ | Some file ->
let content = file.Elements.Input.content in
let check =
- if t.Forms.Selector.preserve_newest then
- check_import
- else
- uncheck_import
+ if t.Forms.Selector.preserve_newest
+ then check_import
+ else uncheck_import
in
- match
- State.Storage.of_json
- ~check
- content with
+ ( match State.Storage.of_json ~check content with
| Error _ -> state
- | Ok _obj ->
- State.load_page state.State.page_id state
+ | Ok _obj -> State.load_page state.State.page_id state )
end
let create () =
let title = Jstr.v "Importer des notes" in
let form = Forms.Selector.create () in
- let ev = Elements.Popup.create
+ let ev =
+ Elements.Popup.create
~title
~form
- ~valid_on:(Note.S.map (fun form -> form.Forms.Selector.file != None) (fst form))
+ ~valid_on:
+ (Note.S.map (fun form -> form.Forms.Selector.file != None) (fst form))
()
in
- Note.E.map
- (fun v -> App.dispatch (module M) v)
- (Note.E.Option.on_some ev)
+ Note.E.map (fun v -> App.dispatch (module M) v) (Note.E.Option.on_some ev)
diff --git a/editor/actions/load_page.ml b/editor/actions/load_page.ml
index e85f8b5..0d02f71 100755
--- a/editor/actions/load_page.ml
+++ b/editor/actions/load_page.ml
@@ -1,10 +1,7 @@
+(** Load the page with the given ID in the editor *)
module M = struct
-
type t = Jstr.t option
- let process
- : t -> State.t -> State.t
- = fun page_id state ->
- State.load_page page_id state
-
+ let process : t -> State.t -> State.t =
+ fun page_id state -> State.load_page page_id state
end
diff --git a/editor/actions/of_markdown.ml b/editor/actions/of_markdown.ml
index 951feed..ec18ce1 100755
--- a/editor/actions/of_markdown.ml
+++ b/editor/actions/of_markdown.ml
@@ -5,68 +5,67 @@ module PM = Prosemirror
type node_t = PM.Model.node Js.t
module FromMarkdown = struct
-
type t = PM.t * Omd.doc
(** Add the given mark in the mark list.
The attributes, if any, are added to the mark properties. *)
- let add_attribute
- : string -> PM.Model.schema Js.t -> PM.Model.mark Js.t list -> Jv.prop PM.O.t Js.opt -> PM.Model.mark Js.t list
- = fun name schema marks attributes ->
- match PM.O.get schema##.marks name with
- | None -> marks
- | Some mark_type ->
+ let add_attribute :
+ string
+ -> PM.Model.schema Js.t
+ -> PM.Model.mark Js.t list
+ -> Jv.prop PM.O.t Js.opt
+ -> PM.Model.mark Js.t list =
+ fun name schema marks attributes ->
+ match PM.O.get schema##.marks name with
+ | None -> marks
+ | Some mark_type ->
let m = schema##mark_fromType mark_type attributes in
- m::marks
+ m :: marks
+
(** The function [parse_inline] will tranform all the inline markup to a
Prosemirror node.
This apply to element like bold, links and so one. *)
- let rec parse_inline_content
- : Prosemirror.View.editor_view Js.t
+ let rec parse_inline_content :
+ Prosemirror.View.editor_view Js.t
-> PM.t
-> PM.Model.mark Js.t list
-> Omd.attributes Omd.inline
- -> node_t Js.js_array Js.t
- = fun view pm marks -> function
- | Omd.Concat (attrs, els) ->
+ -> node_t Js.js_array Js.t =
+ fun view pm marks -> function
+ | Omd.Concat (attrs, els) ->
ignore attrs;
let nodes =
List.to_seq els
|> Seq.map (fun e -> parse_inline_content view pm marks e)
|> Array.of_seq
- |> Js.array in
+ |> Js.array
+ in
(* Flatten each array returned *)
nodes##reduce_init
- (Js.wrap_callback
- @@ fun (init: node_t Js.js_array Js.t) (elems: node_t Js.js_array Js.t) _ _ ->
- init##concat elems)
+ ( Js.wrap_callback
+ @@ fun (init : node_t Js.js_array Js.t)
+ (elems : node_t Js.js_array Js.t)
+ _
+ _ ->
+ init##concat elems )
(new%js Js.array_empty)
-
- | Omd.Strong (attrs, content) ->
+ | Omd.Strong (attrs, content) ->
(* Strong (or Emph) elements just add the coresponding mark and
process the content further *)
ignore attrs;
- let marks = add_attribute
- "strong"
- view##.state##.schema
- marks
- Js.null in
+ let marks =
+ add_attribute "strong" view##.state##.schema marks Js.null
+ in
parse_inline_content view pm marks content
-
- | Omd.Emph (attrs, content) ->
+ | Omd.Emph (attrs, content) ->
ignore attrs;
- let marks = add_attribute
- "em"
- view##.state##.schema
- marks
- Js.null in
+ let marks = add_attribute "em" view##.state##.schema marks Js.null in
parse_inline_content view pm marks content
-
- | Omd.Text (attrs, text) ->
+ | Omd.Text (attrs, text) ->
ignore attrs;
(* Convert the marks as js array *)
let js_marks = Js.array @@ Array.of_list marks in
@@ -75,81 +74,80 @@ module FromMarkdown = struct
(Jstr.of_string text)
(Js.some js_marks)
|]
-
- | Omd.Code (attrs, content) ->
+ | Omd.Code (attrs, content) ->
ignore attrs;
- let marks = add_attribute
- "code"
- view##.state##.schema
- marks
- Js.null in
+ let marks = add_attribute "code" view##.state##.schema marks Js.null in
let js_marks = Js.array @@ Array.of_list marks in
Js.array
[| view##.state##.schema##text
(Jstr.of_string content)
(Js.some js_marks)
|]
-
- | Omd.Link (attrs, link_attrs) ->
+ | Omd.Link (attrs, link_attrs) ->
ignore attrs;
- let attrs' = PM.O.init
- [| "href", link_attrs.destination
- (* TODO Handle title *)
- |] in
- let marks = add_attribute
- "link"
- view##.state##.schema
- marks
- (Js.some attrs') in
+ let attrs' =
+ PM.O.init
+ [| ("href", link_attrs.destination) (* TODO Handle title *) |]
+ in
+ let marks =
+ add_attribute "link" view##.state##.schema marks (Js.some attrs')
+ in
parse_inline_content view pm marks link_attrs.label
-
- | Hard_break (_)
- | Soft_break (_)
- (* TODO Handle Break *)
- | Image (_, _)
- | Html (_, _) ->
- Brr.Console.(log [Jstr.v "Other"]);
+ | Hard_break _ | Soft_break _ (* TODO Handle Break *)
+ |Image (_, _)
+ |Html (_, _) ->
+ Brr.Console.(log [ Jstr.v "Other" ]);
new%js Js.array_empty
- let rec parse_block
- : Prosemirror.View.editor_view Js.t -> PM.t -> Omd.attributes Omd.block -> node_t option
- = fun view pm -> function
- | Omd.Paragraph (attrs, elements) ->
+ let rec parse_block :
+ Prosemirror.View.editor_view Js.t
+ -> PM.t
+ -> Omd.attributes Omd.block
+ -> node_t option =
+ fun view pm -> function
+ | Omd.Paragraph (attrs, elements) ->
ignore attrs;
let marks = [] in
(* Transform each node inside the markdown document and add them into the
paragraph node *)
let nodes = parse_inline_content view pm marks elements in
let fragment = PM.Model.Fragment.from_array pm nodes in
- let node = view##.state##.schema##node
+ let node =
+ view##.state##.schema##node
(Jstr.v "paragraph")
- (Js.null)
+ Js.null
(Js.some fragment)
- (Js.null) in
+ Js.null
+ in
Some node
-
- | Omd.Heading (attrs, level, elements) ->
+ | Omd.Heading (attrs, level, elements) ->
ignore attrs;
let marks = [] in
(* Heading is like a paragraph, but with an attribute (the level) *)
- let attributes = object%js val level = level end
+ let attributes =
+ object%js
+ val level = level
+ end
and nodes = parse_inline_content view pm marks elements in
let fragment = PM.Model.Fragment.from_array pm nodes in
- let node = view##.state##.schema##node
+ let node =
+ view##.state##.schema##node
(Jstr.v "heading")
(Js.some attributes)
(Js.some fragment)
- (Js.null) in
+ Js.null
+ in
Some node
-
- | Omd.List (attrs, type_, spacing, elements) ->
+ | Omd.List (attrs, type_, spacing, elements) ->
ignore attrs;
ignore spacing;
- let type_list = match type_ with
+ let type_list =
+ match type_ with
| Omd.Ordered _ -> "ordered_list"
- | Omd.Bullet _ -> "bullet_list" in
+ | Omd.Bullet _ -> "bullet_list"
+ in
(* The whole list node is declared as ordered or bullet depending of
the type given by the markdown.
@@ -157,56 +155,58 @@ module FromMarkdown = struct
Each element inside the list is transformed as a list_item.
The list_item node can itself contains other blocks (recursively) *)
- let nodes = List.map elements
- ~f:(fun list_entry ->
- let nodes = (List.filter_map list_entry
- ~f:(fun e -> parse_block view pm e))
- |> Array.of_list
- |> Js.array in
- let fragment = PM.Model.Fragment.from_array pm nodes in
- view##.state##.schema##node
- (Jstr.v "list_item")
- (Js.null)
- (Js.some fragment)
- (Js.null)
- ) in
- let nodes_array= nodes
- |> Array.of_list
- |> Js.array in
+ let nodes =
+ List.map elements ~f:(fun list_entry ->
+ let nodes =
+ List.filter_map list_entry ~f:(fun e -> parse_block view pm e)
+ |> Array.of_list
+ |> Js.array
+ in
+ let fragment = PM.Model.Fragment.from_array pm nodes in
+ view##.state##.schema##node
+ (Jstr.v "list_item")
+ Js.null
+ (Js.some fragment)
+ Js.null )
+ in
+ let nodes_array = nodes |> Array.of_list |> Js.array in
let fragment = PM.Model.Fragment.from_array pm nodes_array in
- let node = view##.state##.schema##node
+ let node =
+ view##.state##.schema##node
(Jstr.v type_list)
- (Js.null)
+ Js.null
(Js.some fragment)
- (Js.null) in
+ Js.null
+ in
Some node
-
- | Omd.Thematic_break attrs ->
+ | Omd.Thematic_break attrs ->
ignore attrs;
- let node = view##.state##.schema##node
+ let node =
+ view##.state##.schema##node
(Jstr.v "horizontal_rule")
- (Js.null)
- (Js.null)
- (Js.null) in
+ Js.null
+ Js.null
+ Js.null
+ in
Some node
-
- | Omd.Blockquote(attrs, elements) ->
+ | Omd.Blockquote (attrs, elements) ->
ignore attrs;
let nodes =
- List.filter_map elements
- ~f:(fun e -> parse_block view pm e)
+ List.filter_map elements ~f:(fun e -> parse_block view pm e)
|> Array.of_list
- |> Js.array in
+ |> Js.array
+ in
let fragment = PM.Model.Fragment.from_array pm nodes in
- let node = view##.state##.schema##node
+ let node =
+ view##.state##.schema##node
(Jstr.v "blockquote")
- (Js.null)
+ Js.null
(Js.some fragment)
- (Js.null) in
+ Js.null
+ in
Some node
-
- | Code_block(attrs, content, format) ->
+ | Code_block (attrs, content, format) ->
ignore attrs;
(* The language format is ignored (I do not provide syntaxic
@@ -214,48 +214,53 @@ module FromMarkdown = struct
ignore format;
(* TODO Check if this work *)
- let nodes = Js.array
- [| view##.state##.schema##text
- (Jstr.of_string content)
- (Js.null)
- |] in
+ let nodes =
+ Js.array
+ [| view##.state##.schema##text (Jstr.of_string content) Js.null |]
+ in
let fragment = PM.Model.Fragment.from_array pm nodes in
- let node = view##.state##.schema##node
+ let node =
+ view##.state##.schema##node
(Jstr.v "code_block")
- (Js.null)
+ Js.null
(Js.some fragment)
- (Js.null) in
+ Js.null
+ in
Some node
- | Html_block(_, _)
- | Definition_list(_, _)
- ->
- Brr.Console.(log [Jstr.v "Other block"]);
+ | Html_block (_, _) | Definition_list (_, _) ->
+ Brr.Console.(log [ Jstr.v "Other block" ]);
None
- let parse
- : Prosemirror.View.editor_view Js.t -> PM.t -> Omd.doc -> Prosemirror.Model.node Js.t
- = fun view pm doc ->
- Brr.Console.( log [ doc ]);
- (* Transform each node inside the markdown document and add them into the
- root node *)
- let nodes =
- doc
- |> List.filter_map ~f:(fun b -> parse_block view pm b)
- |> Array.of_list
- |> Js.array
- in
- let fragment = PM.Model.Fragment.from_array pm nodes in
- let document = view##.state##.schema##node
- (Jstr.v "doc")
- (Js.null)
- (Js.some fragment)
- (Js.null) in
- Brr.Console.(log [ document ]);
- document
- let update
- : t -> State.t -> State.t
- = fun (pm, doc) state ->
- let _ = parse state.State.view pm doc in
- state
+ let parse :
+ Prosemirror.View.editor_view Js.t
+ -> PM.t
+ -> Omd.doc
+ -> Prosemirror.Model.node Js.t =
+ fun view pm doc ->
+ Brr.Console.(log [ doc ]);
+ (* Transform each node inside the markdown document and add them into the
+ root node *)
+ let nodes =
+ doc
+ |> List.filter_map ~f:(fun b -> parse_block view pm b)
+ |> Array.of_list
+ |> Js.array
+ in
+ let fragment = PM.Model.Fragment.from_array pm nodes in
+ let document =
+ view##.state##.schema##node
+ (Jstr.v "doc")
+ Js.null
+ (Js.some fragment)
+ Js.null
+ in
+ Brr.Console.(log [ document ]);
+ document
+
+
+ let update : t -> State.t -> State.t =
+ fun (pm, doc) state ->
+ let _ = parse state.State.view pm doc in
+ state
end
diff --git a/editor/actions/to_markdown.ml b/editor/actions/to_markdown.ml
index 1920219..3f0934a 100755
--- a/editor/actions/to_markdown.ml
+++ b/editor/actions/to_markdown.ml
@@ -2,14 +2,13 @@ module Js = Js_of_ocaml.Js
module PM = Prosemirror
module App = Editor_app
-
type buffer = Jstr.t Js.js_array Js.t
-type f = (buffer -> PM.Model.node Js.t -> unit)
-let render_mark_type = object%js
+type f = buffer -> PM.Model.node Js.t -> unit
- method code
- = fun (mark:PM.Model.mark Js.t) (buffer: buffer) ->
+let render_mark_type =
+ object%js
+ method code (mark : PM.Model.mark Js.t) (buffer : buffer) =
ignore mark;
(* There may be a bug here, if the code itself contains `` .
@@ -18,82 +17,68 @@ let render_mark_type = object%js
https://spec.commonmark.org/0.29/#code-span *)
ignore @@ buffer##push (Jstr.v "``");
- fun (buffer:buffer) ->
- ignore @@ buffer##push (Jstr.v "``")
+ fun (buffer : buffer) -> ignore @@ buffer##push (Jstr.v "``")
- method strong
- = fun (mark:PM.Model.mark Js.t) (buffer: buffer) ->
+ method strong (mark : PM.Model.mark Js.t) (buffer : buffer) =
ignore mark;
ignore @@ buffer##push (Jstr.v "**");
- fun (buffer:buffer) ->
- ignore @@ buffer##push (Jstr.v "**")
+ fun (buffer : buffer) -> ignore @@ buffer##push (Jstr.v "**")
- method em
- = fun (mark:PM.Model.mark Js.t) (buffer: buffer) ->
+ method em (mark : PM.Model.mark Js.t) (buffer : buffer) =
ignore mark;
ignore @@ buffer##push (Jstr.v "*");
- fun (buffer:buffer) ->
- ignore @@ buffer##push (Jstr.v "*")
+ fun (buffer : buffer) -> ignore @@ buffer##push (Jstr.v "*")
- (**
+ (**
https://spec.commonmark.org/0.29/#links
*)
- method link
- = fun (mark:PM.Model.mark Js.t) (buffer: buffer) ->
+ method link (mark : PM.Model.mark Js.t) (buffer : buffer) =
ignore @@ buffer##push (Jstr.v "[");
- fun (buffer:buffer) ->
+ fun (buffer : buffer) ->
ignore @@ buffer##push (Jstr.v "](");
- let href_opt = PM.O.get (mark##.attrs) "href" in
- Option.iter
- (fun href -> ignore @@ buffer##push (href))
- href_opt;
- ignore @@ buffer##push (Jstr.v ")");
+ let href_opt = PM.O.get mark##.attrs "href" in
+ Option.iter (fun href -> ignore @@ buffer##push href) href_opt;
+ ignore @@ buffer##push (Jstr.v ")")
+ end
-end
type render_state =
{ level : int
- ; apply_indent : bool }
+ ; apply_indent : bool
+ }
(* Check if a property exists in the object with the name of
node type, and if so, call the appropriate method.
*)
-let process_node obj (state:render_state) buffer node =
+let process_node obj (state : render_state) buffer node =
let name = node##._type##.name in
match Jv.find' (Jv.Id.to_jv obj) name with
- | None ->
- Brr.Console.(log
- [ Jstr.v "Unknow type"
- ; name
- ; node ])
+ | None -> Brr.Console.(log [ Jstr.v "Unknow type"; name; node ])
| Some _ ->
-
- Jv.call'
- (Jv.Id.to_jv obj)
- name
- [| Jv.Id.to_jv state
- ; Jv.Id.to_jv buffer
- ; Jv.Id.to_jv node
- |]
-
-let render_node_type = object%js (_this)
-
- (* https://spec.commonmark.org/0.29/#thematic-breaks *)
- method horizontal_rule_
- = fun (state:render_state) (buffer: buffer) (node:PM.Model.node Js.t) ->
+ Jv.call'
+ (Jv.Id.to_jv obj)
+ name
+ [| Jv.Id.to_jv state; Jv.Id.to_jv buffer; Jv.Id.to_jv node |]
+
+
+(** Create a js object with a function for each node type. Each function may
+ call [process_node] recursively for each nested nodes *)
+let render_node_type =
+ object%js (_this)
+ (* https://spec.commonmark.org/0.29/#thematic-breaks *)
+ method horizontal_rule_
+ (state : render_state) (buffer : buffer) (node : PM.Model.node Js.t) =
ignore state;
ignore node;
- if state.level <> 0 then (
+ if state.level <> 0
+ then (
ignore @@ buffer##push (Jstr.v "\n");
- ignore @@ buffer##push (Jstr.(repeat state.level (v " ") ));
- ignore @@ buffer##push (Jstr.v "---\n");
- ) else (
- ignore @@ buffer##push (Jstr.v "\n---\n")
- )
-
- method text
- = fun (state:render_state) (buffer: buffer) (node:PM.Model.node Js.t) ->
+ ignore @@ buffer##push Jstr.(repeat state.level (v " "));
+ ignore @@ buffer##push (Jstr.v "---\n") )
+ else ignore @@ buffer##push (Jstr.v "\n---\n")
+ method text
+ (state : render_state) (buffer : buffer) (node : PM.Model.node Js.t) =
ignore state;
(* Execute each mark as an environment like
\begin{environement}
@@ -101,194 +86,171 @@ let render_node_type = object%js (_this)
\end{environment}
this way, nested marks are working correctly
-
*)
- let post_render = node##.marks##reduce_init
- (Js.wrap_callback @@ fun (acc:(buffer -> unit) Js.js_array Js.t) (mark: PM.Model.mark Js.t) (_:int) _ ->
- let name = mark##._type##.name in
- match Jv.find' (Jv.Id.to_jv render_mark_type) name with
- | None ->
- Brr.Console.(
- log [ Jstr.v "Unknown mark type"
- ; name]);
- acc
- | Some _ ->
- (* Add the element as first (lifo) *)
- ignore @@ acc##unshift
- (Jv.call'
- (Jv.Id.to_jv render_mark_type)
- name
- [| Jv.Id.to_jv mark
- ; Jv.Id.to_jv buffer
- |]);
- acc)
+ let post_render =
+ node##.marks##reduce_init
+ ( Js.wrap_callback
+ @@ fun (acc : (buffer -> unit) Js.js_array Js.t)
+ (mark : PM.Model.mark Js.t)
+ (_ : int)
+ _ ->
+ let name = mark##._type##.name in
+ match Jv.find' (Jv.Id.to_jv render_mark_type) name with
+ | None ->
+ Brr.Console.(log [ Jstr.v "Unknown mark type"; name ]);
+ acc
+ | Some _ ->
+ (* Add the element as first (lifo) *)
+ ignore
+ @@ acc##unshift
+ (Jv.call'
+ (Jv.Id.to_jv render_mark_type)
+ name
+ [| Jv.Id.to_jv mark; Jv.Id.to_jv buffer |] );
+ acc )
(new%js Js.array_empty)
in
let () =
- if node##.isText == Js._true then
- Js.Opt.iter
- node##.text
- (fun content -> ignore @@ buffer##push content) in
+ if node##.isText == Js._true
+ then
+ Js.Opt.iter node##.text (fun content ->
+ ignore @@ buffer##push content )
+ in
post_render##forEach
- (Js.wrap_callback @@ fun (call:(buffer -> unit)) (_:int) _ -> call buffer)
-
- method heading
- = fun (state:render_state) (buffer: buffer) (node:PM.Model.node Js.t) ->
+ ( Js.wrap_callback
+ @@ fun (call : buffer -> unit) (_ : int) _ -> call buffer )
- let h_level:int = node##.attrs##.level in
- ignore @@ buffer##push (Jstr.(repeat h_level (v "#") ));
+ method heading
+ (state : render_state) (buffer : buffer) (node : PM.Model.node Js.t) =
+ let h_level : int = node##.attrs##.level in
+ ignore @@ buffer##push Jstr.(repeat h_level (v "#"));
ignore @@ buffer##push (Jstr.v " ");
node##.content##forEach
- ( Js.wrap_meth_callback @@ fun _ node ~offset ~index ->
- let _ = offset
- and _ = index in
- process_node _this state buffer node);
- ignore @@ buffer##push (Jstr.(v "\n\n" ))
-
- method paragraph
- = fun (state:render_state) (buffer: buffer) (node:PM.Model.node Js.t) ->
+ ( Js.wrap_meth_callback
+ @@ fun _ node ~offset ~index ->
+ let _ = offset
+ and _ = index in
+ process_node _this state buffer node );
+ ignore @@ buffer##push Jstr.(v "\n\n")
+
+ method paragraph
+ (state : render_state) (buffer : buffer) (node : PM.Model.node Js.t) =
node##.content##forEach
- ( Js.wrap_meth_callback @@ fun _ node ~offset ~index ->
- ignore offset;
- ignore index;
- if state.apply_indent then (
- ignore @@ buffer##push (Jstr.(repeat state.level (v " ") ))
- );
- process_node _this state buffer node);
- ignore @@ buffer##push (Jstr.(v "\n" ))
-
- method list_item_
- = fun (state:render_state) (buffer: buffer) (node:PM.Model.node Js.t) ->
-
+ ( Js.wrap_meth_callback
+ @@ fun _ node ~offset ~index ->
+ ignore offset;
+ ignore index;
+ if state.apply_indent
+ then ignore @@ buffer##push Jstr.(repeat state.level (v " "));
+ process_node _this state buffer node );
+ ignore @@ buffer##push Jstr.(v "\n")
+
+ method list_item_
+ (state : render_state) (buffer : buffer) (node : PM.Model.node Js.t) =
node##.content##forEach
- ( Js.wrap_meth_callback @@ fun _ node ~offset ~index ->
- ignore offset;
- (* The first element in the list should be correctly indented, but if
- there is many elements inside the list (paragraph) we have to
- apply the indentation again.
- *)
- let new_state = { state with apply_indent = index <> 0 } in
- process_node _this new_state buffer node);
-
- method bullet_list_
- = fun (state:render_state) (buffer: buffer) (node:PM.Model.node Js.t) ->
+ ( Js.wrap_meth_callback
+ @@ fun _ node ~offset ~index ->
+ ignore offset;
+ (* The first element in the list should be correctly indented, but if
+ there is many elements inside the list (paragraph) we have to
+ apply the indentation again.
+ *)
+ let new_state = { state with apply_indent = index <> 0 } in
+ process_node _this new_state buffer node )
+
+ method bullet_list_
+ (state : render_state) (buffer : buffer) (node : PM.Model.node Js.t) =
node##.content##forEach
- ( Js.wrap_meth_callback @@ fun _ node ~offset ~index ->
- ignore offset;
- if state.level <> 0 && (index <> 0 || state.apply_indent) then (
- ignore @@ buffer##push (Jstr.(repeat state.level (v " ") ))
- );
- ignore @@ buffer##push (Jstr.v "- ");
- let new_state =
- { level = state.level + 2
- ; apply_indent = false
- } in
- process_node _this new_state buffer node);
- if (state.level == 0) then
- ignore @@ buffer##push (Jstr.(v "\n" ))
-
- method ordered_list_
- = fun (state:render_state) (buffer: buffer) (node:PM.Model.node Js.t) ->
+ ( Js.wrap_meth_callback
+ @@ fun _ node ~offset ~index ->
+ ignore offset;
+ if state.level <> 0 && (index <> 0 || state.apply_indent)
+ then ignore @@ buffer##push Jstr.(repeat state.level (v " "));
+ ignore @@ buffer##push (Jstr.v "- ");
+ let new_state = { level = state.level + 2; apply_indent = false } in
+ process_node _this new_state buffer node );
+ if state.level == 0 then ignore @@ buffer##push Jstr.(v "\n")
+
+ method ordered_list_
+ (state : render_state) (buffer : buffer) (node : PM.Model.node Js.t) =
node##.content##forEach
- ( Js.wrap_meth_callback @@ fun _ node ~offset ~index ->
- ignore offset;
- if state.level <> 0 && (index <> 0 || state.apply_indent) then (
- ignore @@ buffer##push (Jstr.(repeat state.level (v " ") ))
- );
- let num = Jstr.of_int (1 + index) in
- let prefix = Jstr.( num + (v ". ")) in
- ignore @@ buffer##push prefix;
- let new_state =
- { level = state.level + (Jstr.length prefix)
- ; apply_indent = false
- } in
- process_node _this new_state buffer node);
- if (state.level == 0) then
- ignore @@ buffer##push (Jstr.(v "\n" ))
-
- (* https://spec.commonmark.org/0.29/#fenced-code-blocks *)
- method code_block_
- = fun (state:render_state) (buffer: buffer) (node:PM.Model.node Js.t) ->
+ ( Js.wrap_meth_callback
+ @@ fun _ node ~offset ~index ->
+ ignore offset;
+ if state.level <> 0 && (index <> 0 || state.apply_indent)
+ then ignore @@ buffer##push Jstr.(repeat state.level (v " "));
+ let num = Jstr.of_int (1 + index) in
+ let prefix = Jstr.(num + v ". ") in
+ ignore @@ buffer##push prefix;
+ let new_state =
+ { level = state.level + Jstr.length prefix; apply_indent = false }
+ in
+ process_node _this new_state buffer node );
+ if state.level == 0 then ignore @@ buffer##push Jstr.(v "\n")
+
+ (* https://spec.commonmark.org/0.29/#fenced-code-blocks *)
+ method code_block_
+ (state : render_state) (buffer : buffer) (node : PM.Model.node Js.t) =
ignore @@ buffer##push (Jstr.v "```\n");
node##.content##forEach
- ( Js.wrap_meth_callback @@ fun _ node ~offset ~index ->
- ignore index;
- ignore offset;
- let new_state =
- { state with
- apply_indent = true
- } in
- process_node _this new_state buffer node);
- if state.apply_indent then (
- ignore @@ buffer##push (Jstr.(repeat state.level (v " ") ))
- );
+ ( Js.wrap_meth_callback
+ @@ fun _ node ~offset ~index ->
+ ignore index;
+ ignore offset;
+ let new_state = { state with apply_indent = true } in
+ process_node _this new_state buffer node );
+ if state.apply_indent
+ then ignore @@ buffer##push Jstr.(repeat state.level (v " "));
ignore @@ buffer##push (Jstr.v "\n```\n")
- (** https://spec.commonmark.org/0.29/#block-quotes *)
- method blockquote
- = fun (state:render_state) (buffer: buffer) (node:PM.Model.node Js.t) ->
+ (** https://spec.commonmark.org/0.29/#block-quotes *)
+ method blockquote
+ (state : render_state) (buffer : buffer) (node : PM.Model.node Js.t) =
node##.content##forEach
- ( Js.wrap_meth_callback @@ fun _ node ~offset ~index ->
- ignore index;
- ignore offset;
- ignore @@ buffer##push (Jstr.v "> ");
- let new_state =
- { level = state.level + 2
- ; apply_indent = false
- } in
- process_node _this new_state buffer node);
- ignore @@ buffer##push (Jstr.v "\n");
-end
-
+ ( Js.wrap_meth_callback
+ @@ fun _ node ~offset ~index ->
+ ignore index;
+ ignore offset;
+ ignore @@ buffer##push (Jstr.v "> ");
+ let new_state = { level = state.level + 2; apply_indent = false } in
+ process_node _this new_state buffer node );
+ ignore @@ buffer##push (Jstr.v "\n")
+ end
module ToMarkdown = struct
-
type t = PM.t
- let process
- : t -> State.t -> State.t
- = fun pm state ->
-
- let view = state.State.view in
- let root_node = view##.state##.doc in
- let buffer = new%js Js.array_empty in
-
- Brr.Console.(log [Obj.magic root_node]);
-
- let () = root_node##forEach
- (Js.wrap_meth_callback @@ fun _ node ~offset ~index ->
- let _ = offset
- and _ = index in
-
- let init =
- { level = 0
- ; apply_indent = false } in
-
-
- process_node render_node_type init buffer node
- ) in
-
- (* Concatenate the array into a single string *)
- let js_markdown = buffer##join (Js.string "") in
- let markdown = Js.to_string js_markdown in
- Brr.Console.(log [js_markdown]);
- let doc = Omd.of_string markdown in
- let new_doc = Of_markdown.FromMarkdown.parse view pm doc in
-
- Brr.Console.(log
- [ Jstr.v "Are the same ?"
- ; (Obj.magic @@ Js_of_ocaml.Js.bool (root_node = new_doc))
- ]);
-
- (* The function does not actually update the state, and return it
- unchanged *)
- state
-
+ let process : t -> State.t -> State.t =
+ fun pm state ->
+ let view = state.State.view in
+ let root_node = view##.state##.doc in
+ let buffer = new%js Js.array_empty in
+ Brr.Console.(log [ Obj.magic root_node ]);
+ let () =
+ root_node##forEach
+ ( Js.wrap_meth_callback
+ @@ fun _ node ~offset ~index ->
+ let _ = offset
+ and _ = index in
+ let init = { level = 0; apply_indent = false } in
+ process_node render_node_type init buffer node )
+ in
+ (* Concatenate the array into a single string *)
+ let js_markdown = buffer##join (Js.string "") in
+ let markdown = Js.to_string js_markdown in
+ Brr.Console.(log [ js_markdown ]);
+ let doc = Omd.of_string markdown in
+ let new_doc = Of_markdown.FromMarkdown.parse view pm doc in
+ Brr.Console.(
+ log
+ [ Jstr.v "Are the same ?"
+ ; Obj.magic @@ Js_of_ocaml.Js.bool (root_node = new_doc)
+ ]);
+ (* The function does not actually update the state, and return it
+ unchanged *)
+ state
end
(** Create a new element *)
-let create
- : PM.t -> App.event
- = fun pm ->
- App.dispatch (module ToMarkdown) pm
+let create : PM.t -> App.event = fun pm -> App.dispatch (module ToMarkdown) pm
diff --git a/editor/editor.ml b/editor/editor.ml
index 575e164..d558a7a 100755
--- a/editor/editor.ml
+++ b/editor/editor.ml
@@ -1,174 +1,217 @@
open Brr
module PM = Prosemirror
module Js = Js_of_ocaml.Js
-
module Actions = Editor_actions
+let _ =
+ Js.Unsafe.global ##. PM :=
+ object%js
+ val commands = Js.Unsafe.js_expr {|require("prosemirror-commands")|}
+
+ val dropcursor = Js.Unsafe.js_expr {|require("prosemirror-dropcursor")|}
+
+ val example_setup_ =
+ Js.Unsafe.js_expr {|require("prosemirror-example-setup")|}
+
+ val gapcursor = Js.Unsafe.js_expr {|require("prosemirror-gapcursor")|}
+
+ val history = Js.Unsafe.js_expr {|require("prosemirror-history")|}
+
+ val inputrules = Js.Unsafe.js_expr {|require("prosemirror-inputrules")|}
+
+ val keymap = Js.Unsafe.js_expr {|require("prosemirror-keymap")|}
+
+ val menu = Js.Unsafe.js_expr {|require("prosemirror-menu")|}
+
+ val model = Js.Unsafe.js_expr {|require("prosemirror-model")|}
+
+ val schema_basic_ =
+ Js.Unsafe.js_expr {|require("prosemirror-schema-basic")|}
+
+ val schema_list_ =
+ Js.Unsafe.js_expr {|require("prosemirror-schema-list")|}
+
+ val state = Js.Unsafe.js_expr {|require("prosemirror-state")|}
+
+ val transform = Js.Unsafe.js_expr {|require("prosemirror-transform")|}
+
+ val view = Js.Unsafe.js_expr {|require("prosemirror-view")|}
+ end
+
+
+(** Load the js-zip library, with browserify *)
+let zip = Js.Unsafe.js_expr {|require("jszip")|}
+
(** Create a new editor view
[build_view element state] will create the editor and attach it to [element].
*)
-let build_view
- : PM.t -> Jstr.t option -> El.t -> PM.View.editor_view Js.t * float
- = fun pm page_id editor ->
-
- (* Remove all the elements if any *)
- El.set_children editor [];
-
- (* TODO
- This could be improved, instead of creating a new schema, just fetch
- the node and marks from the plungin *)
- let custom_schema =
- Plugins.Footnotes.footnote_schema
- pm
- (PM.SchemaBasic.schema pm) in
-
- (* Recreate the full schema by adding all the nodes and marks from the
- plugings *)
- let specs = PM.Model.schema_spec
- (PM.SchemaList.add_list_nodes
- pm
- (custom_schema##.spec##.nodes)
- (Jstr.v "paragraph block*")
- (Some (Jstr.v "block")))
- (Some custom_schema##.spec##.marks)
- None in
- let full_schema = PM.Model.schema pm specs in
- let stored_content = State.Storage.load page_id in
-
- (* This variable contains the last update time, either because it is
- stored, or because it is the date where we create the first page. *)
- let last_backup = Js.Opt.get
- stored_content##.date
- (fun () -> (new%js Js.date_now)##getTime) in
-
- let props = PM.View.direct_editor_props () in
- props##.state := State.state_of_storage pm stored_content full_schema;
-
- (* Add the custom nodes *)
- props##.nodeViews := PM.O.init
- [| ( "footnote", (Plugins.Footnotes.footnote_view pm))
- |];
-
- let view = PM.View.editor_view
- pm
- editor
- props in
- view, last_backup
+let build_view :
+ PM.t -> Jstr.t option -> El.t -> PM.View.editor_view Js.t * float =
+ fun pm page_id editor ->
+ (* Remove all the elements if any *)
+ El.set_children editor [];
+
+ (* TODO
+ This could be improved, instead of creating a new schema, just fetch
+ the node and marks from the plungin *)
+ let custom_schema =
+ Plugins.Footnotes.footnote_schema pm (PM.SchemaBasic.schema pm)
+ in
+
+ (* Recreate the full schema by adding all the nodes and marks from the
+ plugings *)
+ let specs =
+ PM.Model.schema_spec
+ (PM.SchemaList.add_list_nodes
+ pm
+ custom_schema##.spec##.nodes
+ (Jstr.v "paragraph block*")
+ (Some (Jstr.v "block")) )
+ (Some custom_schema##.spec##.marks)
+ None
+ in
+ let full_schema = PM.Model.schema pm specs in
+ let stored_content = State.Storage.load page_id in
+
+ (* This variable contains the last update time, either because it is
+ stored, or because it is the date where we create the page. *)
+ let last_backup =
+ Js.Opt.get stored_content##.date (fun () -> (new%js Js.date_now)##getTime)
+ in
+
+ let props = PM.View.direct_editor_props () in
+ props##.state := State.state_of_storage pm stored_content full_schema;
+
+ (* Add the custom nodes *)
+ props##.nodeViews :=
+ PM.O.init [| ("footnote", Plugins.Footnotes.footnote_view pm) |];
+
+ let view = PM.View.editor_view pm editor props in
+ (view, last_backup)
+
module Store = struct
type t = El.t
- let process
- : t -> State.t -> State.t
- = fun title_element state ->
- let title = El.prop (El.Prop.value) title_element in
+ let process : t -> State.t -> State.t =
+ fun title_element state ->
+ let title = El.prop El.Prop.value title_element in
- let new_date = (new%js Js.date_now)##getTime in
- let content_obj = object%js
+ let new_date = (new%js Js.date_now)##getTime in
+ let content_obj =
+ object%js
val content = Js.some @@ Jv.Id.to_jv (state.view##.state##toJSON ())
+
val title = Js.some title
+
val date = Js.some new_date
- end in
- let save = State.Storage.save
- content_obj
- state.page_id
- (* There three date here :
- - The actual date at the time we save the note
- - The date associated with the note when we loaded it first time
- - The date associated with the note at the time we want to update it
-
- The two last may differ if the note has been updated in another one tab. *)
- ~check:(fun ~previous ~update ->
- let _ = update in
- Js.Opt.case previous##.date
- (fun () -> true)
- (fun date ->
- (* I do not figure how the previous date could be older
- than the last backup. It could be either :
-
- - equal (if we are the only one to update it)
- - more recent (if the content has been updated elsewhere)
-
- but older shoud be a bug. *)
- let is_ok = date <= state.last_backup in
- if (not is_ok) then (
- let open Console in
- log
- [ Jstr.v "Last backup date is "
- ; new%js Js.date_fromTimeValue state.last_backup
- ; Jstr.v " but date is "
- ; new%js Js.date_fromTimeValue date] );
- is_ok)) in
- begin match save with
- | Ok true -> { state with last_backup = new_date }
- | Ok false ->
- Console.(log [Jstr.v "Didn't save"]);
- state
- | Error other ->
- (* TODO In case of error, notify the user *)
- Console.(log [Jstr.v "Couldn't save" ; other]);
- state
end
+ in
+ let save =
+ State.Storage.save
+ content_obj
+ state.page_id
+ (* There three date here :
+ - The actual date at the time we save the note
+ - The date associated with the note when we loaded it first time
+ - The date associated with the note at the time we want to update it
+
+ The two last may differ if the note has been updated in another one
+ tab. *)
+ ~check:(fun ~previous ~update ->
+ let _ = update in
+ Js.Opt.case
+ previous##.date
+ (fun () -> true)
+ (fun date ->
+ (* I do not figure how the previous date could be older
+ than the last backup. It could be either :
+
+ - equal (if we are the only one to update it)
+ - more recent (if the content has been updated elsewhere)
+
+ but older shoud be a bug. *)
+ let is_ok = date <= state.last_backup in
+ ( if not is_ok
+ then
+ let open Console in
+ log
+ [ Jstr.v "Last backup date is "
+ ; new%js Js.date_fromTimeValue state.last_backup
+ ; Jstr.v " but date is "
+ ; new%js Js.date_fromTimeValue date
+ ] );
+ is_ok ) )
+ in
+ match save with
+ | Ok true -> { state with last_backup = new_date }
+ | Ok false ->
+ Console.(log [ Jstr.v "Didn't save" ]);
+ state
+ | Error other ->
+ (* TODO In case of error, notify the user *)
+ Console.(log [ Jstr.v "Couldn't save"; other ]);
+ state
end
module App = Editor_app
let app id content =
-
let title_element = Document.find_el_by_id G.document (Jstr.v "title") in
(* Check the pre-requisite *)
- match title_element, (Jv.is_none id), (Jv.is_none content), Blog.Sidebar.get () with
+ match
+ (title_element, Jv.is_none id, Jv.is_none content, Blog.Sidebar.get ())
+ with
| Some title, false, false, Some sidebar ->
-
- let () = Blog.Sidebar.clean sidebar in
-
- let pm = PM.v () in
- let editor:El.t = Jv.Id.of_jv id in
- (* Load the cache for the given page *)
- let page_id = State.Storage.page_id () in
- let view, last_backup = build_view pm page_id editor in
-
- let init_state = State.init pm view last_backup page_id in
-
- (* Initialize the buttons actions and get the associated events.
- At this point, the HTML element is not yet created, and cannot be
- inserted in the document.
- *)
- let side_elements = Editor_actions.build pm in
- let btn_events = Editor_actions.get_event side_elements in
-
- (* Create the main event loop with all the collected events *)
- let app_state = App.run
- ~eq:State.eq
- init_state
- (Note.E.select
- [ Brr_note.Evr.on_els Ev.focusout
- (fun _ _ -> App.dispatch (module Store) title)
- [ editor ; title ]
- ; btn_events
- ]) in
-
- (* Get the html element associated with the buttons, and add it in the
- page.
-
- The state event is already created, and can be given in the html
- creation in order to update the elements when the state change.
- *)
- let childs = Editor_actions.complete side_elements app_state in
- let () = El.append_children sidebar childs in
- let _ = Note.(Logr.hold (S.log app_state (fun _ -> ()))) in
- ()
-
+ let () = Blog.Sidebar.clean sidebar in
+
+ let pm = PM.v () in
+ let editor : El.t = Jv.Id.of_jv id in
+ (* Load the cache for the given page *)
+ let page_id = State.Storage.page_id () in
+ let view, last_backup = build_view pm page_id editor in
+
+ let init_state = State.init pm view last_backup page_id in
+
+ (* Initialize the buttons actions and get the associated events.
+ At this point, the HTML element is not yet created, and cannot be
+ inserted in the document.
+ *)
+ let side_elements = Editor_actions.build pm in
+ let btn_events = Editor_actions.get_event side_elements in
+
+ (* Create the main event loop with all the collected events *)
+ let app_state =
+ App.run
+ ~eq:State.eq
+ init_state
+ (Note.E.select
+ [ Brr_note.Evr.on_els
+ Ev.focusout
+ (fun _ _ -> App.dispatch (module Store) title)
+ [ editor; title ]
+ ; btn_events
+ ] )
+ in
+
+ (* Get the html element associated with the buttons, and add it in the
+ page.
+
+ The state event is already created, and can be given in the html
+ creation in order to update the elements when the state change.
+ *)
+ let childs = Editor_actions.complete side_elements app_state in
+ let () = El.append_children sidebar childs in
+ let _ = Note.(Logr.hold (S.log app_state (fun _ -> ()))) in
+ ()
| _ ->
- Console.(error [str "No element with id '%s' '%s' found"; id ; content])
+ Console.(error [ str "No element with id '%s' '%s' found"; id; content ])
-let () =
+let () =
let open Jv in
- let editor = obj
- [| "attach_prosemirror", (repr app)
- |] in
+ let editor = obj [| ("attach_prosemirror", repr app) |] in
set global "editor" editor
diff --git a/editor/plugins/link_editor.ml b/editor/plugins/link_editor.ml
index 9bfdfd4..9fcfc51 100755
--- a/editor/plugins/link_editor.ml
+++ b/editor/plugins/link_editor.ml
@@ -1,127 +1,103 @@
open Brr
-
module Js = Js_of_ocaml.Js
module PM = Prosemirror
-let link_edit
- : PM.View.editor_view Js.t -> < .. > Js.t
- = fun view ->
-
- let popin = El.div []
- ~at:At.([class' (Jstr.v "popin")]) in
-
- El.set_inline_style El.Style.display (Jstr.v "none") popin;
-
- let parent = Jv.(Id.of_jv @@ get (Jv.Id.to_jv view##.dom) "parentNode") in
- let () = El.append_children parent [popin] in
-
- let hide
- : unit -> unit
- = fun () ->
- El.set_inline_style El.Style.display (Jstr.v "none") popin
- in
-
- let update
- : PM.View.editor_view Js.t -> PM.State.editor_state Js. t Js.opt -> unit
- = fun view _state_opt ->
-
- let state = view##.state in
- Js.Opt.case (state##.doc##nodeAt (view##.state##.selection##._to))
- (fun () -> hide ())
- (fun node ->
- (* Check if we are editing a link *)
- match PM.O.get state##.schema##.marks "link" with
- | None -> ()
- | Some link_type ->
- let is_present = link_type##isInSet node##.marks in
- Js.Opt.case
- is_present
- (fun () -> hide ())
- (fun mark ->
- (* Get the node's bounding position and display the popin *)
- let position = state##.doc##resolve
- (view##.state##.selection##._to) in
- let start = position##start Js.null
- and end' = position##_end Js.null in
-
- Popin.set_position
- ~start
- ~end'
- view popin;
-
- (* Extract the value from the attribute *)
- let attrs = mark##.attrs in
- let href_opt = PM.O.get attrs "href" in
- let href_value = Option.value
- ~default:Jstr.empty
- href_opt
- in
-
- (* Create the popin content *)
- let a = El.a
- ~at:At.[ href href_value ]
- [ El.txt href_value ] in
-
- let entry = Popin.build_field a
- (fun new_value ->
- (* The function is called when the user validate
- the change in the popi. We create a new
- transaction in the document by replacing the
- mark with the new one. *)
- if not (Jstr.equal new_value href_value) then (
-
- (* Create a new attribute object for the mark in
- order to keep history safe *)
- let attrs' = PM.O.init
- [| "href", new_value |] in
-
- Option.iter
- (fun v -> PM.O.set attrs' "title" v)
- (PM.O.get attrs "title");
-
- let mark' = state##.schema##mark_fromType
- link_type
- (Js.some attrs') in
- (* Create a transaction which update the
- mark with the new value *)
- view##dispatch
- state
- ##.tr
- ##(removeMark
- ~from:start
- ~to_:end'
- mark)
- ##(addMark
- ~from:start
- ~to_:end'
- mark')
- );
- true
-
- ) in
-
-
- El.set_children popin
- [ entry.field
- ; entry.button ];
-
- ))
-
- and destroy () = El.remove popin in
-
+let link_edit : PM.View.editor_view Js.t -> < .. > Js.t =
+ fun view ->
+ let popin = El.div [] ~at:At.[ class' (Jstr.v "popin") ] in
+
+ El.set_inline_style El.Style.display (Jstr.v "none") popin;
+
+ let parent = Jv.(Id.of_jv @@ get (Jv.Id.to_jv view##.dom) "parentNode") in
+ let () = El.append_children parent [ popin ] in
+
+ let hide : unit -> unit =
+ fun () -> El.set_inline_style El.Style.display (Jstr.v "none") popin
+ in
+
+ let update :
+ PM.View.editor_view Js.t -> PM.State.editor_state Js.t Js.opt -> unit =
+ fun view _state_opt ->
+ let state = view##.state in
+ Js.Opt.case
+ (state##.doc##nodeAt view##.state##.selection##._to)
+ (fun () -> hide ())
+ (fun node ->
+ (* Check if we are editing a link *)
+ match PM.O.get state##.schema##.marks "link" with
+ | None -> ()
+ | Some link_type ->
+ let is_present = link_type##isInSet node##.marks in
+ Js.Opt.case
+ is_present
+ (fun () -> hide ())
+ (fun mark ->
+ (* Get the node's bounding position and display the popin *)
+ let position =
+ state##.doc##resolve view##.state##.selection##._to
+ in
+ let start = position##start Js.null
+ and end' = position##_end Js.null in
+
+ Popin.set_position ~start ~end' view popin;
+
+ (* Extract the value from the attribute *)
+ let attrs = mark##.attrs in
+ let href_opt = PM.O.get attrs "href" in
+ let href_value = Option.value ~default:Jstr.empty href_opt in
+
+ (* Create the popin content *)
+ let a = El.a ~at:At.[ href href_value ] [ El.txt href_value ] in
+
+ let entry =
+ Popin.build_field a (fun new_value ->
+ (* The function is called when the user validate
+ the change in the popi. We create a new
+ transaction in the document by replacing the
+ mark with the new one. *)
+ if not (Jstr.equal new_value href_value)
+ then (
+ (* Create a new attribute object for the mark in
+ order to keep history safe *)
+ let attrs' = PM.O.init [| ("href", new_value) |] in
+
+ Option.iter
+ (fun v -> PM.O.set attrs' "title" v)
+ (PM.O.get attrs "title");
+
+ let mark' =
+ state##.schema##mark_fromType
+ link_type
+ (Js.some attrs')
+ in
+ (* Create a transaction which update the
+ mark with the new value *)
+ view##dispatch
+ state
+ ##. tr
+ ## (removeMark ~from:start ~to_:end' mark)
+ ## (addMark ~from:start ~to_:end' mark') );
+ true )
+ in
+
+ El.set_children popin [ entry.field; entry.button ] ) )
+ and destroy () = El.remove popin in
+
+ object%js
+ val update = Js.wrap_callback update
+
+ val destroy = Js.wrap_callback destroy
+ end
+
+
+let plugin : PM.t -> PM.State.plugin Js.t =
+ fun t ->
+ let state = Jv.get (Jv.Id.to_jv t) "state" in
+
+ let params =
object%js
- val update = Js.wrap_callback update
- val destroy= Js.wrap_callback destroy
+ val view = fun view -> link_edit view
end
+ in
-let plugin
- : PM.t -> PM.State.plugin Js.t
- = fun t ->
- let state = Jv.get (Jv.Id.to_jv t) "state" in
-
- let params = object%js
- val view = (fun view -> link_edit view)
- end in
-
- Jv.new' (Jv.get state "Plugin") [| Jv.Id.to_jv params |]
- |> Jv.Id.of_jv
+ Jv.new' (Jv.get state "Plugin") [| Jv.Id.to_jv params |] |> Jv.Id.of_jv
diff --git a/editor/plugins/plugins.ml b/editor/plugins/plugins.ml
index 3a92df8..51b761c 100755
--- a/editor/plugins/plugins.ml
+++ b/editor/plugins/plugins.ml
@@ -1,131 +1,137 @@
module Js = Js_of_ocaml.Js
module PM = Prosemirror
-
module Footnotes = Footnotes
(** Commands *)
-let change_level
- : PM.t -> PM.Model.resolved_pos Js.t -> int -> (int -> bool) -> PM.Commands.t
- = fun pm res incr pred state dispatch ->
- let parent = res##.parent in
- let attributes = parent##.attrs in
-
- let current_level = if Jv.is_none attributes##.level then
- 0
- else
- attributes##.level in
- let t, props = match pred current_level with
- | false ->
+let change_level :
+ PM.t -> PM.Model.resolved_pos Js.t -> int -> (int -> bool) -> PM.Commands.t
+ =
+ fun pm res incr pred state dispatch ->
+ let parent = res##.parent in
+ let attributes = parent##.attrs in
+
+ 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"
- , Js.some (object%js
- val level = current_level + incr
- end))
- | true ->
- ( PM.O.get state##.schema##.nodes "paragraph"
- , Js.null) in
- match t with
- | None -> Js._false
- | Some t ->
+ , Js.some
+ (object%js
+ val level = current_level + incr
+ end ) )
+ | true ->
+ (PM.O.get state##.schema##.nodes "paragraph", Js.null)
+ in
+ match t with
+ | None ->
+ Js._false
+ | Some t ->
PM.Commands.set_block_type pm t props state dispatch
+
(** Increase the title level by one when pressing # at the begining of a line *)
let handle_sharp pm state dispatch =
-
- let res = PM.State.selection_to (state##.selection) in
+ let res = PM.State.selection_to state##.selection in
match Js.Opt.to_option res##.nodeBefore with
- | Some _ -> Js._false
- | None -> (* Line start *)
- begin match Jstr.to_string res##.parent##._type##.name with
- | "heading" ->
+ | Some _ ->
+ Js._false
+ | None ->
+ (* Line start *)
+ ( match Jstr.to_string res##.parent##._type##.name with
+ | "heading" ->
change_level pm res 1 (fun x -> x > 5) state dispatch
- | "paragraph" ->
- begin match PM.O.get state##.schema##.nodes "heading" with
- | None -> Js._false
- | Some t ->
- let props = Js.some (object%js
- val level = 1
- end) in
- PM.Commands.set_block_type pm t props state dispatch
- end
- | _ -> Js._false
- end
+ | "paragraph" ->
+ ( match PM.O.get state##.schema##.nodes "heading" with
+ | None ->
+ Js._false
+ | Some t ->
+ let props =
+ Js.some
+ (object%js
+ val level = 1
+ end )
+ in
+ PM.Commands.set_block_type pm t props state dispatch )
+ | _ ->
+ Js._false )
-let handle_backspace pm state dispatch =
- let res = PM.State.selection_to (state##.selection) in
+let handle_backspace pm state dispatch =
+ let res = PM.State.selection_to state##.selection in
match Js.Opt.to_option res##.nodeBefore with
- | Some _ -> Js._false
- | None -> (* Line start *)
- 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 toggle_mark
- : Js.regExp Js.t -> PM.t -> string -> PM.InputRule.input_rule Js.t
- = fun regExp pm mark_type_name ->
- PM.InputRule.create pm
- regExp
- ~fn:(Js.wrap_callback @@ fun (state:PM.State.editor_state Js.t) _ ~from ~to_ ->
- match PM.O.get state##.schema##.marks mark_type_name with
- | None -> Js.null
- | Some mark_type ->
-
- let m = state##.schema##mark_fromType mark_type Js.null in
-
- (* Delete the markup code *)
- let tr = (state##.tr)##delete ~from ~to_ in
-
- (* Check if the mark is active at the position *)
- let present = Js.Opt.bind
- (PM.State.cursor (tr##.selection))
- (fun resolved ->
- Js.Opt.map
- (mark_type##isInSet (resolved##marks ()))
- (fun _ -> resolved)
- ) in
- Js.Opt.case present
- (fun () ->
- let tr = tr##addStoredMark m in
- Js.some @@ tr)
- (fun _resolved ->
- let tr = tr##removeStoredMark_mark m in
- Js.some tr))
+ | Some _ ->
+ Js._false
+ | None ->
+ (* Line start *)
+ ( match Jstr.to_string res##.parent##._type##.name with
+ | "heading" ->
+ change_level pm res (-1) (fun x -> x <= 1) state dispatch
+ | _ ->
+ Js._false )
+
+
+let toggle_mark :
+ Js.regExp Js.t -> PM.t -> string -> PM.InputRule.input_rule Js.t =
+ fun regExp pm mark_type_name ->
+ PM.InputRule.create
+ pm
+ regExp
+ ~fn:
+ ( Js.wrap_callback
+ @@ fun (state : PM.State.editor_state Js.t) _ ~from ~to_ ->
+ match PM.O.get state##.schema##.marks mark_type_name with
+ | None ->
+ Js.null
+ | Some mark_type ->
+ let m = state##.schema##mark_fromType mark_type Js.null in
+
+ (* Delete the markup code *)
+ let tr = state##.tr##delete ~from ~to_ in
+
+ (* Check if the mark is active at the position *)
+ let present =
+ Js.Opt.bind
+ (PM.State.cursor tr##.selection)
+ (fun resolved ->
+ Js.Opt.map
+ (mark_type##isInSet (resolved##marks ()))
+ (fun _ -> resolved) )
+ in
+ Js.Opt.case
+ present
+ (fun () ->
+ let tr = tr##addStoredMark m in
+ Js.some @@ tr )
+ (fun _resolved ->
+ let tr = tr##removeStoredMark_mark m in
+ Js.some tr ) )
+
let input_rule pm =
+ let bold = toggle_mark (new%js Js.regExp (Js.string "\\*\\*$")) pm "strong"
+ and em = toggle_mark (new%js Js.regExp (Js.string "//$")) pm "em" in
- let bold =
- toggle_mark
- (new%js Js.regExp (Js.string "\\*\\*$"))
- pm
- "strong"
- and em =
- toggle_mark
- (new%js Js.regExp (Js.string "//$"))
- pm
- "em" in
+ PM.InputRule.to_plugin pm (Js.array [| bold; em |])
- PM.InputRule.to_plugin pm
- (Js.array [| bold; em |])
let default pm schema =
-
- (** Load the history plugin *)
- let _ = PM.History.(history pm (history_prop ()) ) in
+ (* Load the history plugin *)
+ let _ = PM.History.(history pm (history_prop ())) in
let props = PM.Example.options schema in
- props##.menuBar := Js.some Js._true;
- props##.floatingMenu := Js.some Js._true;
- props##.menuContent := (Footnotes.build_menu pm schema)##.fullMenu;
+ props##.menuBar := Js.some Js._true ;
+ props##.floatingMenu := Js.some Js._true ;
+ props##.menuContent := (Footnotes.build_menu pm schema)##.fullMenu ;
let setup = PM.Example.example_setup pm props in
let keymaps =
- PM.Keymap.keymap pm
- [| "Backspace", (handle_backspace pm)
- ; "#", (handle_sharp pm)
- |] in
+ PM.Keymap.keymap
+ pm
+ [| ("Backspace", handle_backspace pm); ("#", handle_sharp pm) |]
+ in
(* Add the custom keymaps in the list *)
let _ = setup##unshift keymaps in
@@ -133,5 +139,4 @@ let default pm schema =
let _ = setup##push (Tooltip.bold_plugin pm) in
let _ = setup##push (Link_editor.plugin pm) in
-
Js.some setup
diff --git a/editor/prosemirror/bindings.ml b/editor/prosemirror/bindings.ml
index 7f6d82f..a6a09dc 100755
--- a/editor/prosemirror/bindings.ml
+++ b/editor/prosemirror/bindings.ml
@@ -1,750 +1,573 @@
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 get : 'a t -> Jv.prop -> 'a option
- val set
- : 'a t -> Jv.prop -> 'a -> unit
+ val get' : 'a t -> Jv.prop' -> 'a option
- val set'
- : 'a t -> Jv.prop' -> 'a -> unit
+ val set : 'a t -> Jv.prop -> 'a -> unit
- val create
- : unit -> 'a t
+ val set' : 'a t -> Jv.prop' -> 'a -> unit
- val init
- : (Jv.prop * 'a) array -> 'a t
+ val create : unit -> 'a t
+ val init : (Jv.prop * 'a) array -> 'a t
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 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 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 create
- : unit -> 'a t
- = fun () -> Jv.obj [||]
+ let set : 'a t -> Jv.prop -> 'a -> unit =
+ fun o prop v -> Jv.set o prop (Jv.Id.to_jv v)
- let init
- : (Jv.prop * 'a) array -> 'a t
- = fun param -> Jv.obj (Obj.magic param)
-end
+ let set' : 'a t -> Jv.prop' -> 'a -> unit =
+ fun o prop v -> Jv.set' o prop (Jv.Id.to_jv v)
+
-class type ['a] ordered_map = object ('this)
+ let create : unit -> 'a t = fun () -> Jv.obj [||]
- method get:
- Jstr.t -> 'a t opt meth
+ let init : (Jv.prop * 'a) array -> 'a t =
+ fun param -> Jv.obj (Obj.magic param)
+end
- method update:
- Jstr.t -> 'a t -> Jstr.t opt -> 'this meth
+class type ['a] ordered_map =
+ object ('this)
+ method get : Jstr.t -> 'a t opt meth
- method remove:
- Jstr.t -> 'this meth
+ method update : Jstr.t -> 'a t -> Jstr.t opt -> 'this meth
- method addToStart:
- Jstr.t -> 'a t -> 'this t meth
+ method remove : Jstr.t -> 'this meth
- method addToEnd:
- Jstr.t -> 'a t -> 'this t meth
+ method addToStart : Jstr.t -> 'a t -> 'this t meth
-end
+ method addToEnd : Jstr.t -> 'a t -> 'this t meth
+ end
module Classes = struct
-
type 'a meta_data
type domOutputSpec
+
type parse_rule
type content_match
type slice
- class type _node_props = object ('this)
+ class type _node_props =
+ object ('this)
+ method inlineContent : bool t readonly_prop
+ (** True if this node type has inline content. *)
- method inlineContent:
- bool t readonly_prop
- (** True if this node type has inline content. *)
+ method isBlock : bool t readonly_prop
- method isBlock:
- bool t readonly_prop
+ method isText : bool t readonly_prop
- method isText:
- bool t readonly_prop
+ method isInline : bool t readonly_prop
- method isInline:
- bool t readonly_prop
+ method isTextblock : bool t readonly_prop
- method isTextblock:
- bool t readonly_prop
+ method isLeaf : bool t readonly_prop
- method isLeaf:
- bool t readonly_prop
-
- method isAtom:
- bool t readonly_prop
-
- end
+ method isAtom : bool t readonly_prop
+ end
type depth = int opt
- class type mark = object ('this)
-
- method _type
- : mark_type t readonly_prop
-
- method attrs
- : 'a TypedObject.t prop
-
- method isInSet
- : mark t js_array t -> bool t meth
-
- method eq
- : 'this t -> bool t meth
-
- end
-
- and node_spec = object ('this)
-
- method content
- : Jstr.t opt prop
-
- method marks
- : Jstr.t opt prop
-
- method group
- : Jstr.t opt prop
-
- method inline
- : bool t opt prop
+ class type mark =
+ object ('this)
+ method _type : mark_type t readonly_prop
- method atom
- : bool t opt prop
+ method attrs : 'a TypedObject.t prop
- method attrs
- : 'a TypedObject.t prop
+ method isInSet : mark t js_array t -> bool t meth
- method selectable
- : bool t opt prop
+ method eq : 'this t -> bool t meth
+ end
- method draggable
- : bool t opt prop
+ and node_spec =
+ object ('this)
+ method content : Jstr.t opt prop
- method code
- : bool t opt prop
+ method marks : Jstr.t opt prop
- method defining
- : bool t opt prop
+ method group : Jstr.t opt prop
- method isolating
- : bool t opt prop
+ method inline : bool t opt prop
- method toDOM
- : (node t -> domOutputSpec t) callback prop
+ method atom : bool t opt prop
- method parseDom
- : parse_rule t js_array t opt prop
+ method attrs : 'a TypedObject.t prop
- end
+ method selectable : bool t opt prop
- and resolved_pos = object ('this)
+ method draggable : bool t opt prop
- method pos
- : int readonly_prop
+ method code : bool t opt prop
- method depth
- : int readonly_prop
+ method defining : bool t opt prop
- method parentOffset
- : int readonly_prop
+ method isolating : bool t opt prop
- method parent
- : node t readonly_prop
+ method toDOM : (node t -> domOutputSpec t) callback prop
- method doc
- : node t readonly_prop
+ method parseDom : parse_rule t js_array t opt prop
+ end
- method node
- : depth -> node t meth
+ and resolved_pos =
+ object ('this)
+ method pos : int readonly_prop
- method index
- : depth -> int meth
+ method depth : int readonly_prop
- method start
- : depth -> int meth
+ method parentOffset : int readonly_prop
- method _end
- : depth -> int meth
+ method parent : node t readonly_prop
- method after
- : depth -> int meth
+ method doc : node t readonly_prop
- method nodeAfter
- : node t opt readonly_prop
+ method node : depth -> node t meth
- method nodeBefore
- : node t opt readonly_prop
+ method index : depth -> int meth
- method marks
- : unit -> mark t js_array t meth
+ method start : depth -> int meth
- method sameParent
- : 'this t -> bool t meth
+ method _end : depth -> int meth
- method max
- : 'this t -> 'this t meth
+ method after : depth -> int meth
- method min
- : 'this t -> 'this t meth
- end
+ method nodeAfter : node t opt readonly_prop
- and mark_spec = object ('this)
+ method nodeBefore : node t opt readonly_prop
- method toDOM:
- (node t -> domOutputSpec t) callback prop
+ method marks : unit -> mark t js_array t meth
- method inclusive:
- bool t prop
+ method sameParent : 'this t -> bool t meth
- method spanning:
- bool t prop
+ method max : 'this t -> 'this t meth
- end
+ method min : 'this t -> 'this t meth
+ end
- and schema_spec = object ('this)
+ and mark_spec =
+ object ('this)
+ method toDOM : (node t -> domOutputSpec t) callback prop
- method nodes:
- node_spec ordered_map t readonly_prop
+ method inclusive : bool t prop
- method marks:
- mark_spec ordered_map t readonly_prop
+ method spanning : bool t prop
+ end
- method topNode:
- Jstr.t opt readonly_prop
+ and schema_spec =
+ object ('this)
+ method nodes : node_spec ordered_map t readonly_prop
- end
+ method marks : mark_spec ordered_map t readonly_prop
- and schema = object ('this)
+ method topNode : Jstr.t opt readonly_prop
+ end
- method spec:
- schema_spec t prop
+ and schema =
+ object ('this)
+ method spec : schema_spec t prop
- method nodes:
- node_type t TypedObject.t readonly_prop
+ method nodes : node_type t TypedObject.t readonly_prop
- method marks:
- mark_type t TypedObject.t readonly_prop
+ method marks : mark_type t TypedObject.t readonly_prop
- method topNodeType:
- node_type t readonly_prop
+ method topNodeType : node_type t readonly_prop
- method text:
- Jstr.t -> mark t js_array t opt -> node t meth
+ method text : Jstr.t -> mark t js_array t opt -> node t meth
- (** [node t attrs fragment ] Will create a node with the type [t] and
+ method node :
+ Jstr.t
+ -> < .. > t opt
+ -> fragment t opt
+ -> mark t js_array t opt
+ -> node t meth
+ (** [node t attrs fragment ] Will create a node with the type [t] and
attributes [attrs]. The content will always be a fragment.
You can create a fragment from an array on node with the function
[Model.Fragment.from_array]
*)
- method node:
- Jstr.t -> < .. > t opt -> fragment t opt -> mark t js_array t opt -> node t meth
- method mark_fromType:
- mark_type t -> 'a TypedObject.t opt -> mark t meth
+ method mark_fromType : mark_type t -> 'a TypedObject.t opt -> mark t meth
+ end
- end
+ and node_type =
+ object ('this)
+ inherit _node_props
- and node_type = object ('this)
+ method name : Jstr.t readonly_prop
- inherit _node_props
+ method schema : schema t readonly_prop
- method name:
- Jstr.t readonly_prop
+ method spec : node_spec t readonly_prop
- method schema:
- schema t readonly_prop
+ method contentMatch : content_match t readonly_prop
- method spec:
- node_spec t readonly_prop
+ method hasRequiredAttrs : unit -> bool t meth
- method contentMatch:
- content_match t readonly_prop
-
- method hasRequiredAttrs:
- unit -> bool t meth
-
- method create_withFragmentContent:
- < .. > t opt -> fragment t opt -> mark t opt -> node t meth
-
- end
+ method create_withFragmentContent :
+ < .. > t opt -> fragment t opt -> mark t opt -> node t meth
+ end
(** Signature for MarkType class
https://prosemirror.net/docs/ref/#model.MarkType
*)
- and mark_type = object ('this)
-
- method name:
- Jstr.t readonly_prop
+ and mark_type =
+ object ('this)
+ method name : Jstr.t readonly_prop
- method schema:
- schema t readonly_prop
+ method schema : schema t readonly_prop
- method spec:
- mark_spec t readonly_prop
+ method spec : mark_spec t readonly_prop
- method isInSet:
- mark t js_array t -> mark t opt meth
-
- end
+ method isInSet : mark t js_array t -> mark t opt meth
+ end
(** Common signature between fragment and node *)
- and _element = object ('this)
+ and _element =
+ object ('this)
+ method childCount : int readonly_prop
+ (** The number of children that the node has. *)
- method childCount:
- int readonly_prop
- (** The number of children that the node has. *)
-
- method child:
- int -> node t meth
- (** Get the child node at the given index. Raise an error when the index
+ method child : int -> node t meth
+ (** Get the child node at the given index. Raise an error when the index
is out of range. *)
- method maybeChild:
- int -> node t opt meth
- (** Get the child node at the given index, if it exists. *)
+ method maybeChild : int -> node t opt meth
+ (** Get the child node at the given index, if it exists. *)
- method eq:
- 'this t -> bool t meth
- (** Compare this element to another one. *)
+ method eq : 'this t -> bool t meth
+ (** Compare this element to another one. *)
- method cut:
- int -> int opt -> 'this t meth
- (** Cut out the element between the two given positions. *)
+ method cut : int -> int opt -> 'this t meth
+ (** Cut out the element between the two given positions. *)
- method toString:
- unit -> Jstr.t meth
- (** Return a debugging string that describes this element. *)
+ method toString : unit -> Jstr.t meth
+ (** Return a debugging string that describes this element. *)
- method descendants
- : (node t -> pos:int -> node t -> bool t) callback -> unit meth
+ method descendants :
+ (node t -> pos:int -> node t -> bool t) callback -> unit meth
- method forEach
- : (node t -> offset:int -> index:int -> unit) callback -> unit meth
+ method forEach :
+ (node t -> offset:int -> index:int -> unit) callback -> unit meth
(** Call [f] for every child node, passing the node, its offset into
this parent node, and its index. *)
+ end
- end
+ and fragment =
+ object ('this)
+ inherit _element
- and fragment = object ('this)
-
- inherit _element
-
- method size
- : int readonly_prop
- (** The size of the fragment, which is the total of the size of its
+ method size : int readonly_prop
+ (** The size of the fragment, which is the total of the size of its
content nodes. *)
- method append
- : 'this t -> 'this t meth
+ method append : 'this t -> 'this t meth
- method lastChild
- : node t opt readonly_prop
+ method lastChild : node t opt readonly_prop
- method firstChild
- : node t opt readonly_prop
+ method firstChild : node t opt readonly_prop
- method findDiffStart
- : 'this t -> int opt meth
+ method findDiffStart : 'this t -> int opt meth
- method findDiffEnd
- : 'this t -> < a: int prop; b: int prop> t opt meth
-
- end
+ method findDiffEnd : 'this t -> < a : int prop ; b : int prop > t opt meth
+ end
(** https://prosemirror.net/docs/ref/#model.Node *)
- and node = object ('this)
-
- inherit _element
+ and node =
+ object ('this)
+ inherit _element
- inherit _node_props
+ inherit _node_props
- method _type
- : node_type t readonly_prop
+ method _type : node_type t readonly_prop
- method attrs
- : < .. > t prop
+ method attrs : < .. > t prop
- method content
- : fragment t prop
+ method content : fragment t prop
- method copy
- : fragment t -> 'this t meth
+ method copy : fragment t -> 'this t meth
- method slice
- : from:int -> to_:int opt -> slice t meth
+ method slice : from:int -> to_:int opt -> slice t meth
- method resolve
- : int -> resolved_pos t meth
+ method resolve : int -> resolved_pos t meth
- method nodeAt
- : int -> 'this t opt meth
+ method nodeAt : int -> 'this t opt meth
- method marks
- : mark t js_array t readonly_prop
+ method marks : mark t js_array t readonly_prop
- method sameMarkup
- : node t -> bool t meth
+ method sameMarkup : node t -> bool t meth
- method text
- : Jstr.t opt prop
-
- end
+ method text : Jstr.t opt prop
+ end
(** View *)
- and editor_props = object ('this)
+ and editor_props =
+ object ('this)
+ method editable : (editor_state t -> bool t) callback prop
- method editable
- : (editor_state t -> bool t) callback prop
+ method handleDOMEvents :
+ (editor_view t -> Jv.t -> bool t) callback TypedObject.t prop
- method handleDOMEvents
- : (editor_view t -> Jv.t -> bool t) callback TypedObject.t prop
+ method handleClickOn :
+ ( editor_view t
+ -> int t
+ -> node t
+ -> int
+ -> Brr.Ev.Mouse.t Brr.Ev.type'
+ -> bool t
+ -> bool t )
+ callback
+ prop
- method handleClickOn
- : (editor_view t -> int t -> node t -> int -> Brr.Ev.Mouse.t Brr.Ev.type' -> bool t -> bool t) callback prop
+ method nodeViews :
+ (node t -> editor_view t -> (unit -> int) -> < .. > t) TypedObject.t
+ prop
+ end
- method nodeViews
- : (node t -> editor_view t -> (unit -> int) -> < .. > t) TypedObject.t prop
+ and direct_editor_props =
+ object ('this)
+ inherit editor_props
- end
+ method state : editor_state t writeonly_prop
- and direct_editor_props = object ('this)
+ method dispatchTransaction :
+ (editor_view t, transaction t -> unit) meth_callback writeonly_prop
+ (** The call back is called with this = instance of editor_view *)
+ end
- inherit editor_props
+ and editor_view =
+ object ('this)
+ method state : editor_state t readonly_prop
- method state:
- editor_state t writeonly_prop
+ method dom : Brr.El.t readonly_prop prop
- (** The call back is called with this = instance of editor_view *)
- method dispatchTransaction:
- (editor_view t, transaction t -> unit) meth_callback writeonly_prop
-
- end
+ method editable : bool t readonly_prop
- and editor_view = object ('this)
+ method props : direct_editor_props t readonly_prop
- method state:
- editor_state t readonly_prop
+ method update : direct_editor_props t -> unit meth
- method dom:
- Brr.El.t readonly_prop prop
+ method setProps : direct_editor_props t -> unit meth
- method editable:
- bool t readonly_prop
+ method updateState : editor_state t -> unit meth
- method props:
- direct_editor_props t readonly_prop
+ method hasFocus : unit -> bool t meth
- method update:
- direct_editor_props t -> unit meth
+ method focus : unit -> unit meth
- method setProps:
- direct_editor_props t -> unit meth
+ method posAtCoords :
+ < left : float prop ; top : float prop > t
+ -> < pos : int prop ; inside : int prop > t meth
- method updateState:
- editor_state t -> unit meth
+ method coordsAtPos :
+ int
+ -> int opt
+ -> < left : float prop
+ ; right : float prop
+ ; top : float prop
+ ; bottom : float prop >
+ t
+ meth
- method hasFocus:
- unit -> bool t meth
+ method domAtPos :
+ pos:int
+ -> side:int opt
+ -> < node : Brr.El.t t prop ; offset : int prop > t meth
- method focus:
- unit -> unit meth
+ method destroy : unit meth
- method posAtCoords:
- < left: float prop ; top: float prop > t -> < pos: int prop; inside: int prop> t meth
-
- method coordsAtPos:
- int -> int opt -> < left: float prop; right: float prop; top: float prop; bottom: float prop > t meth
-
- method domAtPos:
- pos:int -> side:int opt -> < node: Brr.El.t t prop; offset: int prop > t meth
-
- method destroy
- : unit meth
-
- method dispatch:
- transaction t -> unit meth
-
- end
+ method dispatch : transaction t -> unit meth
+ end
(** State *)
- and plugin = object ('this)
-
- method props : editor_props t opt prop
+ and plugin =
+ object ('this)
+ method props : editor_props t opt prop
- method view:
- (editor_view t -> < .. > t) callback opt prop
+ method view : (editor_view t -> < .. > t) callback opt prop
- method filterTransaction:
- (transaction t -> editor_state t -> bool t) opt prop
+ method filterTransaction :
+ (transaction t -> editor_state t -> bool t) opt prop
+ end
- end
+ and selection =
+ object ('this)
+ method from : int readonly_prop
- and selection = object ('this)
+ method _to : int readonly_prop
- method from:
- int readonly_prop
+ method empty : bool t readonly_prop
- method _to:
- int readonly_prop
+ method eq : 'this t -> bool t meth
- method empty:
- bool t readonly_prop
+ method content : unit -> slice t meth
- method eq:
- 'this t -> bool t meth
+ method replace : transaction t -> slice t -> unit meth
- method content:
- unit -> slice t meth
+ method replaceWith : transaction t -> node t -> unit meth
+ end
- method replace:
- transaction t -> slice t -> unit meth
+ and text_selection =
+ object ('this)
+ inherit selection
+ end
- method replaceWith:
- transaction t -> node t -> unit meth
-
- end
-
- and text_selection = object ('this)
-
- inherit selection
-
- end
-
- and node_selection = object ('this)
-
- inherit selection
-
- end
+ and node_selection =
+ object ('this)
+ inherit selection
+ end
(* Transform *)
+ and mappable = object ('this) end
- and mappable = object ('this)
-
- end
-
- and step_map = object ('this)
-
- inherit mappable
-
- end
-
- and step = object ('this)
-
- method map
- : mappable t -> 'this t meth
-
- end
-
- and transform = object ('this)
-
- method doc
- : node t readonly_prop
-
- method steps
- : step t js_array t readonly_prop
-
- method docs
- : node t js_array t readonly_prop
+ and step_map =
+ object ('this)
+ inherit mappable
+ end
- method step
- : step t -> 'this t meth
+ and step =
+ object ('this)
+ method map : mappable t -> 'this t meth
+ end
- method docChanged
- : bool t prop
+ and transform =
+ object ('this)
+ method doc : node t readonly_prop
- method addMark
- : from:int -> to_:int -> mark t -> 'this t meth
+ method steps : step t js_array t readonly_prop
- method removeMark
- : from:int -> to_:int -> mark t -> 'this t meth
+ method docs : node t js_array t readonly_prop
- method replace
- : from:int -> to_:int -> slice t opt -> 'this t meth
+ method step : step t -> 'this t meth
- method delete
- : from:int -> to_:int -> 'this t meth
+ method docChanged : bool t prop
- method insert
- : pos:int -> node t -> 'this t meth
+ method addMark : from:int -> to_:int -> mark t -> 'this t meth
- method replaceRangeWith
- : from:int -> to_:int -> node t -> 'this t meth
+ method removeMark : from:int -> to_:int -> mark t -> 'this t meth
- method setBlockType
- : from:int -> to_:int -> node_type t -> < .. > t -> 'this t meth
+ method replace : from:int -> to_:int -> slice t opt -> 'this t meth
- end
+ method delete : from:int -> to_:int -> 'this t meth
- and transaction = object ('this)
+ method insert : pos:int -> node t -> 'this t meth
- inherit transform
+ method replaceRangeWith : from:int -> to_:int -> node t -> 'this t meth
- method time:
- int readonly_prop
+ method setBlockType :
+ from:int -> to_:int -> node_type t -> < .. > t -> 'this t meth
+ end
- method setTime
- : int -> 'this t meth
+ and transaction =
+ object ('this)
+ inherit transform
- method storedMarks
- : mark t js_array t opt readonly_prop
+ method time : int readonly_prop
- method setStoredMarks
- : mark t js_array t opt -> 'this t meth
+ method setTime : int -> 'this t meth
- method addStoredMark
- : mark t -> 'this t meth
+ method storedMarks : mark t js_array t opt readonly_prop
- method removeStoredMark_mark
- : mark t -> 'this t meth
+ method setStoredMarks : mark t js_array t opt -> 'this t meth
- method removeStoredMark_marktype
- : mark_type t -> 'this t meth
+ method addStoredMark : mark t -> 'this t meth
- method ensureMarks
- : mark t js_array t -> 'this t meth
+ method removeStoredMark_mark : mark t -> 'this t meth
- method storedMarksSet
- : bool readonly_prop
+ method removeStoredMark_marktype : mark_type t -> 'this t meth
- method selection
- : selection t readonly_prop
+ method ensureMarks : mark t js_array t -> 'this t meth
- method setSelection
- : selection t -> 'this t meth
+ method storedMarksSet : bool readonly_prop
- method deleteSelection
- : 'this t meth
+ method selection : selection t readonly_prop
- method replaceSelection
- : slice t -> 'this t meth
+ method setSelection : selection t -> 'this t meth
- method replaceSelectionWith
- : node t -> bool t opt -> 'this t meth
+ method deleteSelection : 'this t meth
- method selectionSet
- : bool readonly_prop
+ method replaceSelection : slice t -> 'this t meth
- method before
- : node t readonly_prop
+ method replaceSelectionWith : node t -> bool t opt -> 'this t meth
- method insertText
- : Jstr.t -> from:int opt -> to_:int opt -> 'this t meth
+ method selectionSet : bool readonly_prop
- method setMeta
- : 'a meta_data t -> 'a -> 'this t meth
+ method before : node t readonly_prop
- method getMeta
- : 'a meta_data t -> 'a optdef meth
+ method insertText : Jstr.t -> from:int opt -> to_:int opt -> 'this t meth
- method scrollIntoView
- : unit -> 'this t meth
+ method setMeta : 'a meta_data t -> 'a -> 'this t meth
- end
+ method getMeta : 'a meta_data t -> 'a optdef meth
- and configuration_prop = object ('this)
+ method scrollIntoView : unit -> 'this t meth
+ end
- method schema:
- schema t opt prop
+ and configuration_prop =
+ object ('this)
+ method schema : schema t opt prop
- method plugins:
- plugin t js_array t opt prop
+ method plugins : plugin t js_array t opt prop
+ end
- end
+ and creation_prop =
+ object ('this)
+ inherit configuration_prop
- and creation_prop = object ('this)
+ method doc : node t opt prop
- inherit configuration_prop
+ method selection : selection t opt prop
- method doc:
- node t opt prop
+ method storedMarks : mark t js_array t opt prop
+ end
- method selection:
- selection t opt prop
+ and editor_state =
+ object ('this)
+ method doc : node t readonly_prop
- method storedMarks:
- mark t js_array t opt prop
-
- end
+ method selection : selection t readonly_prop
- and editor_state = object ('this)
+ method storedMarks : mark t js_array t opt readonly_prop
- method doc :
- node t readonly_prop
+ method schema : schema t readonly_prop
- method selection:
- selection t readonly_prop
+ method plugins : plugin t js_array t readonly_prop
- method storedMarks:
- mark t js_array t opt readonly_prop
+ method apply : transaction t -> 'this t meth
- method schema:
- schema t readonly_prop
+ method applyTransaction :
+ transaction t
+ -> < state : 'this t prop
+ ; transactions : transaction t js_array t prop >
+ t
+ meth
- method plugins:
- plugin t js_array t readonly_prop
+ method tr : transaction t readonly_prop
- method apply:
- transaction t -> 'this t meth
-
- method applyTransaction
- : transaction t ->
- < state: 'this t prop; transactions : transaction t js_array t prop> t meth
-
- method tr:
- transaction t readonly_prop
-
- method reconfigure:
- configuration_prop t meth
-
- method toJSON:
- unit -> Brr.Json.t meth
-
- end
+ method reconfigure : configuration_prop t meth
+ method toJSON : unit -> Brr.Json.t meth
+ end
end
module Model = struct
-
type parse_rule = Classes.parse_rule
type domOutputSpec = Classes.domOutputSpec
@@ -770,189 +593,160 @@ module Model = struct
class type mark_type = Classes.mark_type
class type node = Classes.node
-
end
module Transform = struct
-
type step_result
class type step_map = Classes.step_map
class type step = Classes.step
- class type replace_step = object ('this)
+ class type replace_step =
+ object ('this)
+ inherit step
+ end
- inherit step
+ class type replace_around_step =
+ object ('this)
+ inherit step
+ end
- end
-
- class type replace_around_step = object ('this)
-
- inherit step
-
- end
-
- class type add_mark_step = object ('this)
-
- inherit step
-
- end
+ class type add_mark_step =
+ object ('this)
+ inherit step
+ end
class type transform = Classes.transform
-
-
end
module State = struct
-
type 'a meta_data = 'a Classes.meta_data
+
class type plugin = Classes.plugin
+
class type selection = Classes.selection
+
class type text_selection = Classes.text_selection
+
class type node_selection = Classes.node_selection
+
class type transaction = Classes.transaction
+
class type configuration_prop = Classes.configuration_prop
+
class type creation_prop = Classes.creation_prop
+
class type editor_state = Classes.editor_state
- type dispatch = (Classes.transaction t -> unit)
+ type dispatch = Classes.transaction t -> unit
end
module View = struct
-
class type editor_props = Classes.editor_props
class type direct_editor_props = Classes.direct_editor_props
class type editor_view = Classes.editor_view
-
end
module History = struct
+ class type history_prop =
+ object ('this)
+ method depth : int opt prop
- class type history_prop = object ('this)
-
- method depth: int opt prop
-
- method newGroupDelay: int opt prop
-
- end
-
+ method newGroupDelay : int opt prop
+ end
end
module SchemaBasic = struct
+ class type nodes =
+ object ('this)
+ method doc : Model.node_spec t prop
- class type nodes = object ('this)
+ method paragraph : Model.node_spec t prop
- method doc:
- Model.node_spec t prop
+ method blockquote : Model.node_spec t prop
- method paragraph:
- Model.node_spec t prop
+ method horizontal_rule : Model.node_spec t prop
- method blockquote:
- Model.node_spec t prop
+ method heading : Model.node_spec t prop
- method horizontal_rule:
- Model.node_spec t prop
+ method code_block : Model.node_spec t prop
- method heading:
- Model.node_spec t prop
+ method text : Model.node_spec t prop
- method code_block:
- Model.node_spec t prop
+ method image : Model.node_spec t prop
- method text:
- Model.node_spec t prop
+ method hard_break : Model.node_spec t prop
+ end
- method image:
- Model.node_spec t prop
+ class type marks =
+ object ('this)
+ method link : Model.mark_spec t prop
- method hard_break:
- Model.node_spec t prop
-
- end
+ method em : Model.mark_spec t prop
- class type marks = object ('this)
-
- method link:
- Model.mark_spec t prop
-
- method em:
- Model.mark_spec t prop
-
- method strong:
- Model.mark_spec t prop
-
- method code:
- Model.mark_spec t prop
-
- end
+ method strong : Model.mark_spec t prop
+ method code : Model.mark_spec t prop
+ end
end
module Menu = struct
-
- class type menuElement = object ('this)
- end
-
- class type menuItemSpec = object ('this)
- method title
- : Jstr.t opt prop
-
- method label
- : Jstr.t opt prop
-
- method select
- : (menuItem t, State.editor_state t -> bool t) meth_callback prop
-
- method run
- : (menuItem t, State.editor_state t -> (State.transaction t -> unit) -> View.editor_view t -> 'a Brr.Ev.t -> unit) meth_callback prop
- end
-
- and menuItem = object ('this)
- inherit menuElement
- end
-
- class type dropdown = object ('this)
-
- inherit menuElement
-
- method content
- : menuItem t js_array t prop
- end
+ class type menuElement = object ('this) end
+
+ class type menuItemSpec =
+ object ('this)
+ method title : Jstr.t opt prop
+
+ method label : Jstr.t opt prop
+
+ method select :
+ (menuItem t, State.editor_state t -> bool t) meth_callback prop
+
+ method run :
+ ( menuItem t
+ , State.editor_state t
+ -> (State.transaction t -> unit)
+ -> View.editor_view t
+ -> 'a Brr.Ev.t
+ -> unit )
+ meth_callback
+ prop
+ end
+
+ and menuItem =
+ object ('this)
+ inherit menuElement
+ end
+
+ class type dropdown =
+ object ('this)
+ inherit menuElement
+
+ method content : menuItem t js_array t prop
+ end
end
module Example = struct
+ class type menuItems =
+ object ('this)
+ method insertMenu : Menu.dropdown t prop
- class type menuItems = object ('this)
-
- method insertMenu
- : Menu.dropdown t prop
-
- method fullMenu
- : Menu.menuElement t js_array t prop
-
- end
+ method fullMenu : Menu.menuElement t js_array t prop
+ end
- class type options = object ('this)
+ class type options =
+ object ('this)
+ method schema : Model.schema t prop
- method schema
- : Model.schema t prop
+ method menuBar : bool t opt prop
- method menuBar
- : bool t opt prop
+ method floatingMenu : bool t opt prop
- method floatingMenu
- : bool t opt prop
-
- method history
- : bool t opt prop
-
- method menuContent
- : Menu.menuElement t js_array t prop
-
- end
+ method history : bool t opt prop
+ method menuContent : Menu.menuElement t js_array t prop
+ end
end
diff --git a/editor/prosemirror/prosemirror.ml b/editor/prosemirror/prosemirror.ml
index c44d090..4d75f4c 100755
--- a/editor/prosemirror/prosemirror.ml
+++ b/editor/prosemirror/prosemirror.ml
@@ -5,435 +5,385 @@ type t = Jv.t
type t' = t
-let v
- : unit -> t
- = fun () ->
- Jv.get Jv.global "PM"
+let v : unit -> t = fun () -> Jv.get Jv.global "PM"
module O = Bindings.TypedObject
module Model = struct
-
include Bindings.Model
module Fragment = struct
-
(** https://prosemirror.net/docs/ref/#model.Fragment^fromArray *)
- let from_array
- : t -> node Js.t Js.js_array Js.t -> fragment Js.t
- = fun t elements ->
- let model = Jv.get t "model" in
- let class_ = Jv.get model "Fragment" in
- Jv.call (Jv.Id.to_jv class_ ) "fromArray" [|Jv.Id.to_jv elements |]
- |> Jv.Id.of_jv
-
+ let from_array : t -> node Js.t Js.js_array Js.t -> fragment Js.t =
+ fun t elements ->
+ let model = Jv.get t "model" in
+ let class_ = Jv.get model "Fragment" in
+ Jv.call (Jv.Id.to_jv class_) "fromArray" [| Jv.Id.to_jv elements |]
+ |> Jv.Id.of_jv
end
module Mark = struct
+ let _set_from : t -> 'a Js.t -> mark Js.t =
+ fun t element ->
+ let model = Jv.get t "model" in
+ let class_ = Jv.get model "Mark" in
+ Jv.call (Jv.Id.to_jv class_) "setFrom" [| Jv.Id.to_jv element |]
+ |> Jv.Id.of_jv
+
- let _set_from
- : t -> 'a Js.t -> mark Js.t
- = fun t element ->
- let model = Jv.get t "model" in
- let class_ = Jv.get model "Mark" in
- Jv.call (Jv.Id.to_jv class_ ) "setFrom" [|Jv.Id.to_jv element |]
- |> Jv.Id.of_jv
+ let set_from_mark : t -> mark Js.t -> mark Js.t = _set_from
+ end
+ module DOMParser = struct
+ type parser = Jv.t
- let set_from_mark
- : t -> mark Js.t -> mark Js.t
- = _set_from
+ let from_schema : t -> schema Js.t -> parser =
+ fun t schema ->
+ let model = Jv.get t "model" in
+ let parser = Jv.get model "DOMParser" in
+ Jv.call (Jv.Id.to_jv parser) "fromSchema" [| Jv.Id.to_jv schema |]
+ let parse : parser -> El.t -> node Js.t =
+ fun dom_parser el ->
+ Jv.call dom_parser "parse" [| Jv.Id.to_jv el |] |> Jv.Id.of_jv
end
- module DOMParser = struct
+ let schema_spec :
+ node_spec Bindings.ordered_map Js.t
+ -> mark_spec Bindings.ordered_map Js.t option
+ -> string option
+ -> schema_spec Js.t =
+ fun nodes marks_opt topNode_opt ->
+ let marks = Jv.of_option ~none:Jv.null Jv.Id.to_jv marks_opt
+ and topNode = Jv.of_option ~none:Jv.null Jv.of_string topNode_opt in
+ Jv.obj
+ [| ("nodes", Jv.Id.to_jv nodes); ("marks", marks); ("topNode", topNode) |]
+ |> Jv.Id.of_jv
- type parser = Jv.t
+ let schema : t -> schema_spec Js.t -> schema Js.t =
+ fun t spec ->
+ let model = Jv.get t "model" in
+ Jv.new' (Jv.get model "Schema") [| Jv.Id.to_jv spec |] |> Jv.Id.of_jv
- let from_schema
- : t -> schema Js.t -> parser
- = fun t schema ->
- let model = Jv.get t "model" in
- let parser = Jv.get model "DOMParser" in
- Jv.call (Jv.Id.to_jv parser) "fromSchema" [|Jv.Id.to_jv schema|]
- let parse
- : parser -> El.t -> node Js.t
- = fun dom_parser el ->
- Jv.call dom_parser "parse" [|Jv.Id.to_jv el|]
- |> Jv.Id.of_jv
+ let empty_fragment : t -> fragment Js.t =
+ fun t ->
+ let model = Jv.get t "model" in
+ let fragment = Jv.get model "Fragment" in
+ Jv.get fragment "empty" |> Jv.Id.of_jv
- end
- let schema_spec:
- node_spec Bindings.ordered_map Js.t
- -> mark_spec Bindings.ordered_map Js.t option
- -> string option
- -> schema_spec Js.t
- = fun nodes marks_opt topNode_opt ->
- let marks = Jv.of_option ~none:Jv.null Jv.Id.to_jv marks_opt
- and topNode = Jv.of_option ~none:Jv.null Jv.of_string topNode_opt in
- Jv.obj
- [| "nodes", (Jv.Id.to_jv nodes)
- ; "marks", marks
- ; "topNode", topNode
- |]
- |> 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 schema
- : t -> schema_spec Js.t -> schema Js.t
- = fun t spec ->
- let model = Jv.get t "model" in
- Jv.new' (Jv.get model "Schema") [| Jv.Id.to_jv spec |]
- |> Jv.Id.of_jv
+ let hole : domOutputSpec Js.t = 0 |> Jv.Id.to_jv |> Jv.Id.of_jv
- let empty_fragment
- : t -> fragment Js.t
- = fun t ->
- let model = Jv.get t "model" in
- let fragment = Jv.get model "Fragment" in
- Jv.get fragment "empty"
- |> Jv.Id.of_jv
+ let of_ : 'a -> domOutputSpec Js.t =
+ fun elem -> elem |> Jv.Id.to_jv |> 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
+ let of_el : Brr.El.t -> domOutputSpec Js.t = of_
- module ParseRule = struct
+ let of_jstr : Jstr.t -> domOutputSpec Js.t = of_
- let tag
- : Jstr.t -> parse_rule Js.t
- = fun name ->
- Jv.obj [| "tag", Jv.of_jstr name |]
- |> Jv.Id.of_jv
+ 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
+ module ParseRule = struct
+ let tag : Jstr.t -> parse_rule Js.t =
+ fun name -> Jv.obj [| ("tag", Jv.of_jstr name) |] |> Jv.Id.of_jv
end
end
module State = struct
-
include Bindings.State
- let configuration_prop
- : unit -> configuration_prop Js.t
- = fun () -> Js.Unsafe.obj [||]
+ let configuration_prop : unit -> configuration_prop Js.t =
+ fun () -> Js.Unsafe.obj [||]
- let creation_prop
- : unit -> creation_prop Js.t
- = fun () -> Js.Unsafe.obj [||]
- let create
- : t -> creation_prop Js.t -> editor_state Js.t
- = fun t props ->
- let state = Jv.get t "state" in
- let editor_state = Jv.get state "EditorState" in
- Jv.call editor_state "create" [|Jv.Id.to_jv props|]
- |> Jv.Id.of_jv
+ let creation_prop : unit -> creation_prop Js.t = fun () -> Js.Unsafe.obj [||]
- let fromJSON
- : t -> configuration_prop Js.t -> Brr.Json.t -> editor_state Js.t
- = fun t config json ->
- let state = Jv.get t "state" in
- let editor_state = Jv.get state "EditorState" in
- Jv.call editor_state "fromJSON" [|Jv.Id.to_jv config ; json |]
- |> Jv.Id.of_jv
+ let create : t -> creation_prop Js.t -> editor_state Js.t =
+ fun t props ->
+ let state = Jv.get t "state" in
+ let editor_state = Jv.get state "EditorState" in
+ Jv.call editor_state "create" [| Jv.Id.to_jv props |] |> Jv.Id.of_jv
- let selection_from
- : selection Js.t -> Model.resolved_pos Js.t
- = fun selection ->
- Jv.Id.(of_jv @@ Jv.get (to_jv selection) "$from")
-
- 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 fromJSON : t -> configuration_prop Js.t -> Brr.Json.t -> editor_state Js.t
+ =
+ fun t config json ->
+ let state = Jv.get t "state" in
+ 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_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 selection_from : selection Js.t -> Model.resolved_pos Js.t =
+ fun selection -> Jv.Id.(of_jv @@ Jv.get (to_jv selection) "$from")
- 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
+ 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
+
+
+ let cursor : selection Js.t -> Model.resolved_pos Js.t Js.opt =
+ fun selection -> Jv.Id.(of_jv @@ Jv.get (to_jv selection) "$cursor")
- let cursor
- : selection Js.t -> Model.resolved_pos Js.t Js.opt
- = fun selection ->
- Jv.Id.(of_jv @@ Jv.get (to_jv selection) "$cursor")
- let create_str_meta_data
- : Jstr.t -> 'a meta_data Js.t
- = Obj.magic
+ let create_str_meta_data : Jstr.t -> 'a meta_data Js.t = Obj.magic
end
(* Editor view *)
module View = struct
-
module EditorProps = struct
type t = Jv.t
end
include Bindings.View
- let direct_editor_props
- : unit -> direct_editor_props Js.t
- = fun () -> Js.Unsafe.obj [||]
-
- let editor_view
- : t -> El.t -> direct_editor_props Js.t -> editor_view Js.t
- = fun t node props ->
- Jv.new' (Jv.get (Jv.get t "view") "EditorView") [|Jv.Id.to_jv node ; Jv.Id.to_jv props|]
- |> Jv.Id.of_jv
+ let direct_editor_props : unit -> direct_editor_props Js.t =
+ fun () -> Js.Unsafe.obj [||]
+
+
+ let editor_view : t -> El.t -> direct_editor_props Js.t -> editor_view Js.t =
+ fun t node props ->
+ Jv.new'
+ (Jv.get (Jv.get t "view") "EditorView")
+ [| Jv.Id.to_jv node; Jv.Id.to_jv props |]
+ |> Jv.Id.of_jv
end
module Transform = struct
-
include Bindings.Transform
- let offset
- : t -> int -> step_map Js.t
- = fun t n ->
- let stepmap = Jv.get (Jv.get t "transform") "StepMap" in
- Jv.call stepmap "offset" [|Jv.Id.to_jv n|]
- |> Jv.Id.of_jv
-
- let insertPoint
- : t -> Model.node Js.t -> pos:int -> Model.node_type Js.t -> int Js.opt
- = fun t node ~pos node_t ->
- let transform = Jv.get t "transform" in
- Jv.call transform "insertPoint" Jv.Id.[|to_jv node ; to_jv pos; to_jv node_t|]
- |> Jv.Id.of_jv
-
+ let offset : t -> int -> step_map Js.t =
+ fun t n ->
+ let stepmap = Jv.get (Jv.get t "transform") "StepMap" in
+ Jv.call stepmap "offset" [| Jv.Id.to_jv n |] |> Jv.Id.of_jv
+
+
+ let insertPoint :
+ t -> Model.node Js.t -> pos:int -> Model.node_type Js.t -> int Js.opt =
+ fun t node ~pos node_t ->
+ let transform = Jv.get t "transform" in
+ Jv.call
+ transform
+ "insertPoint"
+ Jv.Id.[| to_jv node; to_jv pos; to_jv node_t |]
+ |> Jv.Id.of_jv
end
module Commands = struct
-
type t = State.editor_state Js.t -> State.dispatch Js.opt -> bool Js.t
- let baseKeymap
- : t' -> (string * t) array
- = fun t ->
- Jv.get (Jv.get t "commands") "baseKeymap"
- |> Jv.Id.of_jv
+ let baseKeymap : t' -> (string * t) 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 Js.opt -> t
- = fun t node props ->
- Jv.call (Jv.get t "commands") "setBlockType" Jv.Id.[| to_jv node ; to_jv props |]
- |> Jv.Id.of_jv
- let toggle_mark
- : t' -> Model.mark_type Js.t -> < .. > Js.t Js.opt -> t
- = fun t mark props ->
- Jv.call (Jv.get t "commands") "toggleMark" Jv.Id.[| to_jv mark ; to_jv props |]
- |> Jv.Id.of_jv
+ let set_block_type : t' -> Model.node_type Js.t -> < .. > Js.t Js.opt -> t =
+ fun t node props ->
+ Jv.call
+ (Jv.get t "commands")
+ "setBlockType"
+ Jv.Id.[| to_jv node; to_jv props |]
+ |> Jv.Id.of_jv
+ let toggle_mark : t' -> Model.mark_type Js.t -> < .. > Js.t Js.opt -> t =
+ fun t mark props ->
+ Jv.call
+ (Jv.get t "commands")
+ "toggleMark"
+ Jv.Id.[| to_jv mark; to_jv props |]
+ |> Jv.Id.of_jv
end
-
module History = struct
-
include Bindings.History
- let history_prop
- : unit -> history_prop Js.t
- = fun () -> Js.Unsafe.obj [||]
+ let history_prop : unit -> history_prop Js.t = fun () -> Js.Unsafe.obj [||]
- let history
- : t -> history_prop Js.t -> State.plugin Js.t
- = fun t props ->
- Jv.call (Jv.get t "history") "history" [|Jv.Id.to_jv props|]
- |> Jv.Id.of_jv
+ let history : t -> history_prop Js.t -> State.plugin Js.t =
+ fun t props ->
+ Jv.call (Jv.get t "history") "history" [| Jv.Id.to_jv props |]
+ |> Jv.Id.of_jv
- let undo
- : t -> Commands.t
- = 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 -> Commands.t
- = fun t state fn ->
- Jv.call (Jv.get t "history") "redo" [|Jv.Id.to_jv state; Jv.repr fn|]
- |> Jv.Id.of_jv
-end
+ let undo : t -> Commands.t =
+ fun t state fn ->
+ Jv.call (Jv.get t "history") "undo" [| Jv.Id.to_jv state; Jv.repr fn |]
+ |> Jv.Id.of_jv
-module Keymap = struct
- let keymap
- : t -> (string * Commands.t) 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|]
- |> Jv.Id.of_jv
+ let redo : t -> Commands.t =
+ fun t state fn ->
+ Jv.call (Jv.get t "history") "redo" [| Jv.Id.to_jv state; Jv.repr fn |]
+ |> Jv.Id.of_jv
+end
+module Keymap = struct
+ let keymap : t -> (string * Commands.t) 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 |] |> Jv.Id.of_jv
end
module InputRule = struct
-
type input_rule
- let create
- : t -> Js.regExp Js.t -> fn:(State.editor_state Js.t -> Jstr.t Js.js_array Js.t -> from:int -> to_:int -> State.transaction Js.t Js.opt) Js.callback -> input_rule Js.t
- = fun t match' ~fn ->
- Jv.new' (Jv.get (Jv.get t "inputrules") "InputRule") [|Jv.Id.to_jv match' ; Jv.Id.to_jv fn|]
- |> Jv.Id.of_jv
-
- let to_plugin
- : t -> input_rule Js.t Js.js_array Js.t -> State.plugin Js.t
- = fun t rules ->
- let obj = Jv.obj [|("rules", Jv.Id.to_jv rules)|] in
- Jv.call (Jv.get t "inputrules") "inputRules" [| obj |]
- |> Jv.Id.of_jv
-
+ (** Create a new inputRule.
+
+ The callback is called with the following elements :
+ - the editor state
+ - the elements matched by the regex
+ - starting position
+ - ending position
+
+ and shall return a transaction if any modifications are applied. *)
+ let create :
+ t
+ -> Js.regExp Js.t
+ -> fn:
+ ( State.editor_state Js.t
+ -> Jstr.t Js.js_array Js.t
+ -> from:int
+ -> to_:int
+ -> State.transaction Js.t Js.opt )
+ Js.callback
+ -> input_rule Js.t =
+ fun t match' ~fn ->
+ Jv.new'
+ (Jv.get (Jv.get t "inputrules") "InputRule")
+ [| Jv.Id.to_jv match'; Jv.Id.to_jv fn |]
+ |> Jv.Id.of_jv
+
+
+ let to_plugin : t -> input_rule Js.t Js.js_array Js.t -> State.plugin Js.t =
+ fun t rules ->
+ let obj = Jv.obj [| ("rules", Jv.Id.to_jv rules) |] in
+ Jv.call (Jv.get t "inputrules") "inputRules" [| obj |] |> Jv.Id.of_jv
end
module SchemaBasic = struct
-
include Bindings.SchemaBasic
- let schema
- : t -> Model.schema Js.t
- = fun t ->
- Jv.get (Jv.get t "schema_basic") "schema"
- |> Jv.Id.of_jv
+ let schema : t -> Model.schema Js.t =
+ fun t -> 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
+ let nodes : t -> nodes Js.t =
+ fun t -> Jv.get (Jv.get t "schema_basic") "nodes" |> Jv.Id.of_jv
end
module SchemaList = struct
-
- let add_list_nodes
- : t -> Model.node_spec Bindings.ordered_map Js.t -> Jstr.t -> Jstr.t option -> Model.node_spec Bindings.ordered_map Js.t
- = fun t nodes item_content list_group_opt ->
- let schema_list = Jv.get t "schema_list" in
-
- let list_group = Jv.of_option ~none:Jv.null Jv.of_jstr list_group_opt in
-
- Jv.call schema_list "addListNodes"
- [|Jv.Id.to_jv nodes
- ; Jv.of_jstr item_content
- ; list_group |]
- |> Jv.Id.of_jv
-
+ let add_list_nodes :
+ t
+ -> Model.node_spec Bindings.ordered_map Js.t
+ -> Jstr.t
+ -> Jstr.t option
+ -> Model.node_spec Bindings.ordered_map Js.t =
+ fun t nodes item_content list_group_opt ->
+ let schema_list = Jv.get t "schema_list" in
+
+ let list_group = Jv.of_option ~none:Jv.null Jv.of_jstr list_group_opt in
+
+ Jv.call
+ schema_list
+ "addListNodes"
+ [| Jv.Id.to_jv nodes; Jv.of_jstr item_content; list_group |]
+ |> Jv.Id.of_jv
end
module Menu = struct
-
include Bindings.Menu
- let menuItemSpec
- : unit -> menuItemSpec Js.t
- = fun () -> Js.Unsafe.obj [||]
-
- let menu_item
- : t -> menuItemSpec Js.t -> menuItem Js.t
- = fun t spec ->
- let menu = Jv.get t "menu" in
- Jv.new' (Jv.get menu "MenuItem") [| Jv.Id.to_jv spec |]
- |> Jv.Id.of_jv
+ let menuItemSpec : unit -> menuItemSpec Js.t = fun () -> Js.Unsafe.obj [||]
+ let menu_item : t -> menuItemSpec Js.t -> menuItem Js.t =
+ fun t spec ->
+ let menu = Jv.get t "menu" in
+ Jv.new' (Jv.get menu "MenuItem") [| Jv.Id.to_jv spec |] |> Jv.Id.of_jv
end
(* Example Setup *)
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 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
- let buildMenuItems
- : t -> Model.schema Js.t -> menuItems Js.t
- = fun t schema ->
- let setup = Jv.get t "example_setup" in
- Jv.call setup "buildMenuItems" [|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
+
+
+ let buildMenuItems : t -> Model.schema Js.t -> menuItems Js.t =
+ fun t schema ->
+ let setup = Jv.get t "example_setup" in
+ Jv.call setup "buildMenuItems" [| Jv.Id.to_jv schema |] |> Jv.Id.of_jv
end
diff --git a/editor/state/state.ml b/editor/state/state.ml
index 33b796f..49a1e23 100755
--- a/editor/state/state.ml
+++ b/editor/state/state.ml
@@ -1,16 +1,14 @@
open Brr
module PM = Prosemirror
module Js = Js_of_ocaml.Js
-
module Storage = Storage
(** This is the state for the application *)
type t =
{ editable : bool
; view : PM.View.editor_view Js.t
- ; last_backup: float
- ; page_id: Jstr.t option
-
+ ; last_backup : float
+ ; page_id : Jstr.t option
; window : Brr.El.t list
; pm : PM.t
}
@@ -19,91 +17,79 @@ type t =
The prosemirror elemens are ignored *)
let eq s1 s2 =
- Stdlib.(==)
- ( s1.editable
- , s1.last_backup
- , s1.page_id
- , s1.window )
-
- ( s2.editable
- , s2.last_backup
- , s2.page_id
- , s2.window )
-
-let set_title
- : Storage.content Js.t -> unit
- = fun content ->
- let title =
- Js.Opt.get
- content##.title
- (fun () -> Jstr.empty) in
- let title_element = Document.find_el_by_id G.document (Jstr.v "title") in
- Option.iter
- (fun el -> El.set_prop (El.Prop.value) title el)
- title_element
-
-let state_of_storage
- : PM.t -> Storage.content Js.t -> PM.Model.schema Js.t -> PM.State.editor_state Js.t
- = fun pm content schema ->
- Js.Opt.case
- content##.content
- (fun () ->
- let obj = PM.State.creation_prop () in
- obj##.plugins := Plugins.default pm schema;
- obj##.schema := Js.some schema;
- PM.State.create pm obj)
- (fun page_content ->
- let obj = PM.State.configuration_prop () in
- obj##.plugins := Plugins.default pm schema;
- obj##.schema := Js.some schema;
- PM.State.fromJSON pm obj page_content)
-
-let load_page
- : Jstr.t option -> t -> t
- = fun page_id state ->
- let json = Storage.load page_id in
- let editor_state = state_of_storage state.pm json state.view##.state##.schema in
- let () = state.view##updateState editor_state
- and () = set_title json in
-
- let last_backup =
- Js.Opt.case json##.date
- (fun () -> state.last_backup )
- (fun v -> v) in
-
- { state with page_id
- ; last_backup }
-
-let new_page
- : Jstr.t option -> title:Jstr.t -> t -> t
- = fun page_id ~title state ->
- let new_date = (new%js Js.date_now)##getTime in
- let content_obj = object%js
+ Stdlib.( == )
+ (s1.editable, s1.last_backup, s1.page_id, s1.window)
+ (s2.editable, s2.last_backup, s2.page_id, s2.window)
+
+
+let set_title : Storage.content Js.t -> unit =
+ fun content ->
+ let title = Js.Opt.get content##.title (fun () -> Jstr.empty) in
+ let title_element = Document.find_el_by_id G.document (Jstr.v "title") in
+ Option.iter (fun el -> El.set_prop El.Prop.value title el) title_element
+
+
+let state_of_storage :
+ PM.t
+ -> Storage.content Js.t
+ -> PM.Model.schema Js.t
+ -> PM.State.editor_state Js.t =
+ fun pm content schema ->
+ Js.Opt.case
+ content##.content
+ (fun () ->
+ let obj = PM.State.creation_prop () in
+ obj##.plugins := Plugins.default pm schema;
+ obj##.schema := Js.some schema;
+ PM.State.create pm obj )
+ (fun page_content ->
+ let obj = PM.State.configuration_prop () in
+ obj##.plugins := Plugins.default pm schema;
+ obj##.schema := Js.some schema;
+ PM.State.fromJSON pm obj page_content )
+
+
+let load_page : Jstr.t option -> t -> t =
+ fun page_id state ->
+ let json = Storage.load page_id in
+ let editor_state =
+ state_of_storage state.pm json state.view##.state##.schema
+ in
+ let () = state.view##updateState editor_state
+ and () = set_title json in
+
+ let last_backup =
+ Js.Opt.case json##.date (fun () -> state.last_backup) (fun v -> v)
+ in
+
+ { state with page_id; last_backup }
+
+
+let new_page : Jstr.t option -> title:Jstr.t -> t -> t =
+ fun page_id ~title state ->
+ let new_date = (new%js Js.date_now)##getTime in
+ let content_obj =
+ object%js
val content = Js.null
+
val title = Js.some title
+
val date = Js.some new_date
- end in
- let editor_state = state_of_storage state.pm content_obj state.view##.state##.schema in
- let () = state.view##updateState editor_state
- and () = set_title content_obj in
-
- let last_backup =
- Js.Opt.case content_obj##.date
- (fun () -> state.last_backup )
- (fun v -> v) in
-
- { state with page_id
- ; last_backup }
-
-
-let init
- : PM.t -> PM.View.editor_view Js.t -> float -> Jstr.t option -> t
- = fun pm view last_backup page_id ->
- { editable = true
- ; view
- ; last_backup
- ; page_id
-
- ; window = []
- ; pm
- }
+ end
+ in
+ let editor_state =
+ state_of_storage state.pm content_obj state.view##.state##.schema
+ in
+ let () = state.view##updateState editor_state
+ and () = set_title content_obj in
+
+ let last_backup =
+ Js.Opt.case content_obj##.date (fun () -> state.last_backup) (fun v -> v)
+ in
+
+ { state with page_id; last_backup }
+
+
+let init : PM.t -> PM.View.editor_view Js.t -> float -> Jstr.t option -> t =
+ fun pm view last_backup page_id ->
+ { editable = true; view; last_backup; page_id; window = []; pm }
diff --git a/editor/state/state.mli b/editor/state/state.mli
index 57b45fa..c98a8ab 100755
--- a/editor/state/state.mli
+++ b/editor/state/state.mli
@@ -4,30 +4,32 @@ module Storage = Storage
type t =
{ editable : bool
; view : Prosemirror.View.editor_view Js.t
- ; last_backup: float
- ; page_id: Jstr.t option
-
+ ; last_backup : float
+ ; page_id : Jstr.t option
; window : Brr.El.t list
; pm : Prosemirror.t
}
+val eq : t -> t -> bool
-val eq: t -> t -> bool
-
+val set_title : Storage.content Js.t -> unit
(** Update the title element according to the page. *)
-val set_title
- : Storage.content Js.t -> unit
-val state_of_storage
- : Prosemirror.t -> Storage.content Js.t -> Prosemirror.Model.schema Js.t -> Prosemirror.State.editor_state Js.t
+val state_of_storage :
+ Prosemirror.t
+ -> Storage.content Js.t
+ -> Prosemirror.Model.schema Js.t
+ -> Prosemirror.State.editor_state Js.t
-val load_page
- : Jstr.t option -> t -> t
+val load_page : Jstr.t option -> t -> t
+val new_page : Jstr.t option -> title:Jstr.t -> t -> t
(** Create a new empty page, and load it *)
-val new_page
- : Jstr.t option -> title:Jstr.t -> t -> t
+val init :
+ Prosemirror.t
+ -> Prosemirror.View.editor_view Js.t
+ -> float
+ -> Jstr.t option
+ -> t
(** Initialise a new state *)
-val init
- : Prosemirror.t -> Prosemirror.View.editor_view Js.t -> float -> Jstr.t option -> t