From 8d23a029c57be92a7aed0f18d9fcf1c931c1038e Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Mon, 7 Feb 2022 16:40:45 +0100 Subject: Reformat --- editor/actions/add_page.ml | 53 +- editor/actions/delete_page.ml | 37 +- editor/actions/editor_actions.ml | 359 +++++++------ editor/actions/editor_actions.mli | 9 +- editor/actions/export.ml | 50 +- editor/actions/import.ml | 56 +- editor/actions/load_page.ml | 9 +- editor/actions/of_markdown.ml | 297 ++++++----- editor/actions/to_markdown.ml | 404 +++++++------- editor/editor.ml | 325 +++++++----- editor/plugins/link_editor.ml | 216 ++++---- editor/plugins/plugins.ml | 209 ++++---- editor/prosemirror/bindings.ml | 1054 +++++++++++++++---------------------- editor/prosemirror/prosemirror.ml | 580 ++++++++++---------- editor/state/state.ml | 164 +++--- editor/state/state.mli | 32 +- 16 files changed, 1769 insertions(+), 2085 deletions(-) (limited to 'editor') 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 -- cgit v1.2.3