From bf94695abeda0d7bb296ae4cd0f9a53782587d4a Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Mon, 7 Feb 2022 16:14:09 +0100 Subject: Update editor organisation --- editor/actions.ml | 23 ++-- editor/app.ml | 118 ++++++++++++++++++++ editor/dune | 2 + editor/editor.ml | 197 +++++---------------------------- editor/footnotes.ml | 248 ------------------------------------------ editor/forms/add_page.ml | 22 +++- editor/forms/add_page.mli | 6 +- editor/forms/delete_page.ml | 10 +- editor/forms/dune | 1 + editor/forms/events.ml | 17 ++- editor/link_editor.ml | 127 --------------------- editor/plugins.ml | 135 ----------------------- editor/plugins/dune | 9 ++ editor/plugins/footnotes.ml | 248 ++++++++++++++++++++++++++++++++++++++++++ editor/plugins/link_editor.ml | 127 +++++++++++++++++++++ editor/plugins/plugins.ml | 137 +++++++++++++++++++++++ editor/plugins/popin.ml | 83 ++++++++++++++ editor/plugins/tooltip.ml | 89 +++++++++++++++ editor/popin.ml | 83 -------------- editor/state/dune | 9 ++ editor/state/state.ml | 70 ++++++++++++ editor/state/state.mli | 24 ++++ editor/state/storage.ml | 137 +++++++++++++++++++++++ editor/state/storage.mli | 36 ++++++ editor/storage.ml | 137 ----------------------- editor/storage.mli | 36 ------ editor/tooltip.ml | 89 --------------- 27 files changed, 1176 insertions(+), 1044 deletions(-) create mode 100755 editor/app.ml delete mode 100755 editor/footnotes.ml delete mode 100755 editor/link_editor.ml delete mode 100755 editor/plugins.ml create mode 100755 editor/plugins/dune create mode 100755 editor/plugins/footnotes.ml create mode 100755 editor/plugins/link_editor.ml create mode 100755 editor/plugins/plugins.ml create mode 100755 editor/plugins/popin.ml create mode 100755 editor/plugins/tooltip.ml delete mode 100755 editor/popin.ml create mode 100755 editor/state/dune create mode 100755 editor/state/state.ml create mode 100755 editor/state/state.mli create mode 100755 editor/state/storage.ml create mode 100755 editor/state/storage.mli delete mode 100755 editor/storage.ml delete mode 100755 editor/storage.mli delete mode 100755 editor/tooltip.ml (limited to 'editor') diff --git a/editor/actions.ml b/editor/actions.ml index f7633e1..0f107f9 100755 --- a/editor/actions.ml +++ b/editor/actions.ml @@ -17,30 +17,24 @@ let populate_menu () = let delete_button = El.button ~at:At.[ class' (Jstr.v "action-button") ] - [ El.i - [] + [ El.i [] ~at:At.[ class' (Jstr.v "fa") ; class' (Jstr.v "fa-2x") - ; class' (Jstr.v "fa-trash") - ] ] + ; class' (Jstr.v "fa-trash") ] ] and home_button = El.button ~at:At.[ class' (Jstr.v "action-button") ] - [ El.i - [] + [ El.i [] ~at:At.[ class' (Jstr.v "fa") ; class' (Jstr.v "fa-2x") - ; class' (Jstr.v "fa-home") - ] ] + ; class' (Jstr.v "fa-home") ] ] and add_button = El.button ~at:At.[ class' (Jstr.v "action-button") ] - [ El.i - [] + [ El.i [] ~at:At.[ class' (Jstr.v "fa") ; class' (Jstr.v "fa-2x") - ; class' (Jstr.v "fa-plus") - ] ] + ; class' (Jstr.v "fa-plus") ] ] in @@ -49,19 +43,20 @@ let populate_menu () = Ev.click Evr.unit delete_button + and add_event = Evr.on_el Ev.click Evr.unit add_button in - let stored_pages = Storage.get_ids () in + let stored_pages = State.Storage.get_ids () in let pages = List.map stored_pages ~f:(fun id -> - let name_opt = (Storage.load (Some id))##.title in + let name_opt = (State.Storage.load (Some id))##.title in let name = Js.Opt.get name_opt (fun () -> id) in diff --git a/editor/app.ml b/editor/app.ml new file mode 100755 index 0000000..aee396a --- /dev/null +++ b/editor/app.ml @@ -0,0 +1,118 @@ +open Brr +module PM = Prosemirror +module Js = Js_of_ocaml.Js + +type events = + | DeleteEvent + | StoreEvent + | LoadEvent of Jstr.t option + | AddEvent + | CloseEvent of Forms.Events.kind option + | GEvent of Forms.Events.event + +let key_of_title + : Jstr.t -> Jstr.t + = fun title -> + title + +(** [update] is the event loop. + + The function take a new event, and apply it to the current state. *) + +let update + : 'a option Note.E.send -> (events, State.t) Application.t + = fun close_sender event state -> + match event with + + | GEvent (Event (t, (module Handler))) -> + Handler.on_close t state + + | AddEvent -> + let title = Jstr.v "Nouvelle page" in + let popup = Ui.popup + ~title + ~form:(Some (Forms.Add_page.create ())) + close_sender in + { state with window = popup::state.window} + + | DeleteEvent -> + begin match state.page_id with + | None -> state + | Some page_id -> + let title = Jstr.v "Confirmation" in + let popup = Ui.popup + ~title + ~form:(Some (Forms.Delete_page.create page_id)) + close_sender in + { state with window = popup::state.window} + end + + | CloseEvent res -> + + let state = match state.window with + | [] -> { state with window = [] } + | el::tl -> El.remove el + ; { state with window = tl } in + + (* The actions is confirmed by the user. Handle the form result *) + begin match res with + (* Delete the current page, then load the home page *) + | Some (Forms.Delete_page.DeletePage id) -> + State.Storage.delete (fun () -> Some id); + let json = State.Storage.load None in + State.load_page None state json + (* Add a new page *) + | Some (Forms.Add_page.AddPage {title}) -> + let page_id = key_of_title title in + 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 + State.load_page (Some page_id) state content_obj + + | _ -> state + end + + | StoreEvent -> + + let title_element = Document.find_el_by_id G.document (Jstr.v "title") in + let content = Option.map + (fun el -> El.prop (El.Prop.value) el) + title_element in + + 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.Opt.option content + val date = Js.some new_date + end in + let save = State.Storage.save + content_obj + state.page_id + ~check:(fun previous_state -> + Js.Opt.case previous_state##.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. *) + date <= state.last_backup)) in + begin match save with + | Ok true -> { state with last_backup = new_date } + | other -> + (* TODO In case of error, notify the user *) + Console.(log [other]); + state + end + + | LoadEvent page_id -> + let json = State.Storage.load page_id in + State.load_page page_id state json + + diff --git a/editor/dune b/editor/dune index c8dfe3c..295c39f 100755 --- a/editor/dune +++ b/editor/dune @@ -8,6 +8,8 @@ prosemirror blog application + state + plugins forms ) (modes js) diff --git a/editor/editor.ml b/editor/editor.ml index d3a9624..1a34dfc 100755 --- a/editor/editor.ml +++ b/editor/editor.ml @@ -2,56 +2,6 @@ open Brr module PM = Prosemirror module Js = Js_of_ocaml.Js -(** This is the state for the application *) -type state = - { editable : bool - ; view : PM.View.editor_view Js.t - ; last_backup: float - ; page_id: Jstr.t option - - ; window : El.t list - } - -type events = - | DeleteEvent - | StoreEvent - | LoadEvent of Jstr.t option - | AddEvent - | CloseEvent of Forms.Events.kind option - -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 key_of_title - : Jstr.t -> Jstr.t - = fun title -> - title - -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) - (** Create a new editor view [build_view element state] will create the editor and attach it to [element]. @@ -68,7 +18,7 @@ let build_view This could be improved, instead of creating a new schema, just fetch the node and marks from the plungin *) let custom_schema = - Footnotes.footnote_schema + Plugins.Footnotes.footnote_schema pm (PM.SchemaBasic.schema pm) in @@ -83,7 +33,7 @@ let build_view (Some custom_schema##.spec##.marks) None in let full_schema = PM.Model.schema pm specs in - let stored_content = Storage.load page_id 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. *) @@ -92,11 +42,11 @@ let build_view (fun () -> (new%js Js.date_now)##getTime) in let props = PM.View.direct_editor_props () in - props##.state := state_of_storage pm stored_content full_schema; + props##.state := State.state_of_storage pm stored_content full_schema; (* Add the custom nodes *) props##.nodeViews := PM.O.init - [| ( "footnote", (Footnotes.footnote_view pm)) + [| ( "footnote", (Plugins.Footnotes.footnote_view pm)) |]; let view = PM.View.editor_view @@ -105,114 +55,21 @@ let build_view props in view, last_backup -let load_page - : PM.t -> Jstr.t option -> state -> Storage.content Js.t -> state - = fun pm page_id state json -> - let editor_state = state_of_storage pm json state.view##.state##.schema in - let () = state.view##updateState editor_state - and () = set_title json in - { state with page_id } (** [update] is the event loop. The function take a new event, and apply it to the current state. *) let update - : PM.t -> 'a option Note.E.send -> (events, state) Application.t - = fun pm close_sender event state -> - match event with - - | AddEvent -> - let title = Jstr.v "Nouvelle page" in - let popup = Ui.popup - ~title - ~form:(Some (Forms.Add_page.create ())) - close_sender in - { state with window = popup::state.window} - - | DeleteEvent -> - begin match state.page_id with - | None -> state - | Some page_id -> - let title = Jstr.v "Confirmation" in - let popup = Ui.popup - ~title - ~form:(Some (Forms.Delete_page.create page_id)) - close_sender in - { state with window = popup::state.window} - end - - | CloseEvent res -> - - let state = match state.window with - | [] -> { state with window = [] } - | el::tl -> El.remove el - ; { state with window = tl } in - - (* The actions is confirmed by the user. Handle the form result *) - begin match res with - (* Delete the current page, then load the home page *) - | Some (Forms.Delete_page.DeletePage id) -> - Storage.delete (fun () -> Some id); - let json = Storage.load None in - load_page pm None state json - (* Add a new page *) - | Some (Forms.Add_page.AddPage {title}) -> - let page_id = key_of_title title in - Console.(log [title]); - 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 - load_page pm (Some page_id) state content_obj - - | _ -> state - end - - | StoreEvent -> - - let title_element = Document.find_el_by_id G.document (Jstr.v "title") in - let content = Option.map - (fun el -> El.prop (El.Prop.value) el) - title_element in - - 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.Opt.option content - val date = Js.some new_date - end in - let save = Storage.save - content_obj - state.page_id - ~check:(fun previous_state -> - Js.Opt.case previous_state##.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. *) - date <= state.last_backup)) in - begin match save with - | Ok true -> { state with last_backup = new_date } - | _ -> - (* TODO In case of error, notify the user *) - state - end - - | LoadEvent page_id -> - let json = Storage.load page_id in - load_page pm page_id state json - + : 'a option Note.E.send -> (App.events, State.t) Application.t + = App.update let app id content = + (* This event is used in the pop process. The sender is given to the + subroutine in order to track the window closing *) + let event, sender = Note.E.create () in + (* Check the pre-requisite *) let events_opt = Actions.populate_menu () in match (Jv.is_none id), (Jv.is_none content), events_opt with @@ -221,34 +78,32 @@ let app id content = 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 = Storage.page_id () in + let page_id = State.Storage.page_id () in let view, last_backup = build_view pm page_id editor in - (* This event is used in the pop process. The sender is given to the - subroutine in order to track the window closing *) - let event, sender = Note.E.create () in - let _ = sender in let init_state = - { editable = true - ; view - ; last_backup - ; page_id - - ; window = [] - } + State.{ editable = true + ; view + ; last_backup + ; page_id + + ; window = [] + ; pm + } in let app_state = Application.run - (update pm sender) + ~eq:State.eq + (App.update sender) init_state (Note.E.select - [ Note.E.map (fun () -> DeleteEvent) btn_events.Actions.delete - ; Brr_note.Evr.on_el Ev.focusout (fun _ -> StoreEvent) editor - ; Note.E.map (fun v -> LoadEvent v) btn_events.Actions.redirect - ; Note.E.map (fun () -> AddEvent) btn_events.Actions.add - ; Note.E.map (fun v -> CloseEvent v) event + [ Brr_note.Evr.on_el Ev.focusout (fun _ -> App.StoreEvent) editor + ; Note.E.map (fun () -> App.DeleteEvent) btn_events.Actions.delete + ; Note.E.map (fun () -> App.AddEvent) btn_events.Actions.add + ; Note.E.map (fun v -> App.LoadEvent v) btn_events.Actions.redirect + ; Note.E.map (fun v -> App.CloseEvent v) event ]) in let () = diff --git a/editor/footnotes.ml b/editor/footnotes.ml deleted file mode 100755 index 794171f..0000000 --- a/editor/footnotes.ml +++ /dev/null @@ -1,248 +0,0 @@ -open Brr -open Js_of_ocaml -module PM = Prosemirror - -let footNoteSpec = object%js - - val mutable group = Jstr.v "inline" - val mutable content = Jstr.v "inline*" (* The star is very important ! *) - val mutable inline = Js._true - val mutable draggable = Js._true - (* This makes the view treat the node as a leaf, even though it - technically has content *) - val mutable atom = Js._true - - val toDOM - : (PM.Model.node Js.t -> PM.Model.domOutputSpec Js.t) Js.callback - = Js.wrap_callback (fun _ -> - let open PM.Model.Dom_output_spec in - v "footnote" - [ hole ]) - - val parseDOM - : PM.Model.parse_rule Js.t Js.js_array Js.t Js.opt - = Js.some @@ Js.array - [|PM.Model.ParseRule.tag (Jstr.v "footnote")|] - -end - -let footnote_schema pm defaultSchema = - - let nodes = defaultSchema##.spec##.nodes - and marks = defaultSchema##.spec##.marks in - - let specs = PM.Model.schema_spec - (nodes##addToEnd (Jstr.v "footnote") (Js.Unsafe.coerce footNoteSpec)) - (Some marks) - None in - - PM.Model.schema pm - specs - -let build_menu pm schema = - let menu = PM.Example.buildMenuItems pm schema in - - let itemSpec = PM.Menu.menuItemSpec () in - itemSpec##.title := Js.some @@ Jstr.v "Insert footnote"; - itemSpec##.label := Js.some @@ Jstr.v "Footnote"; - itemSpec##.select := Js.wrap_meth_callback (fun _ (state:PM.State.editor_state Js.t) -> - match PM.O.get schema##.nodes "footnote" with - | None -> Js._false - | Some footnote_node -> - let res = Js.Opt.test @@ PM.Transform.insertPoint - pm - state##.doc - ~pos:state##.selection##.from - footnote_node - in - Js.bool res); - - itemSpec##.run := - Js.wrap_meth_callback (fun _this state dispatch _ _ -> - match PM.O.get schema##.nodes "footnote" with - | None -> () - | Some footnote_node -> - - let from' = PM.State.selection_from state##.selection - and to' = PM.State.selection_to state##.selection in - - let content = - if state##.selection##.empty != Js._true - && from'##sameParent to' = Js._true - && from'##.parent##.inlineContent = Js._true then ( - from'##.parent##.content##cut - (from'##.parentOffset) - (Js.some @@ to'##.parentOffset) - ) else ( - PM.Model.empty_fragment pm - ) in - let new_node = footnote_node##create_withFragmentContent - Js.null - (Js.some content) - Js.null - in - dispatch @@ - state##.tr##replaceSelectionWith - new_node - Js.null - ); - - let item = PM.Menu.menu_item pm itemSpec in - let _ = menu##.insertMenu##.content##push item in - menu - -let fromOutside - : bool PM.State.meta_data Js.t - = PM.State.create_str_meta_data (Jstr.v "fromOutside") - -let footnote_view - : PM.t -> PM.Model.node Js.t -> PM.View.editor_view Js.t -> (unit -> int) -> < .. > Js.t - = fun pm init_node outerView get_pos -> - - (* These are used when the footnote is selected *) - let innerView - : PM.View.editor_view Js.t Js.opt ref - = ref Js.null in - - let dispatchInner - : PM.View.editor_view Js.t -> PM.State.transaction Js.t -> unit - = fun view tr -> - let res = view##.state##applyTransaction tr in - view##updateState res##.state; - - let meta = Js.Optdef.get (tr##getMeta fromOutside) (fun () -> false) in - if (not meta) then ( - let outerTr = outerView##.state##.tr - and offsetMap = PM.Transform.offset pm ((get_pos()) + 1) in - res##.transactions##forEach - (Js.wrap_callback @@ - fun (elem:PM.State.transaction Js.t) _ _ -> - elem##.steps##forEach - (Js.wrap_callback @@ fun (step:PM.Transform.step Js.t) _ _ -> - let _ = outerTr##step (step##map offsetMap) in - () - )); - if (outerTr##.docChanged = Js._true) then ( - outerView##dispatch outerTr) - ); - in - object%js (_self) - - val mutable node: PM.Model.node Js.t = init_node - - (* The node's representation in the editor (empty, for now) *) - val dom = El.v (Jstr.v "footnote") [] - - method _open = - (* Append a tooltip to the outer node *) - let tooltip = El.div [] - ~at:At.([class' (Jstr.v "popin")]) in - El.append_children _self##.dom - [ tooltip ]; - - let dispatch_fn - : PM.State.transaction Js.t -> unit - = fun tr -> outerView##dispatch tr in - - let state_properties = Js.Unsafe.coerce (object%js - val doc = Js.some _self##.node; - val plugins = Js.some @@ Js.array @@ [| - PM.Keymap.keymap pm - [| ( "Mod-z" - , (fun _ _ -> PM.History.undo pm outerView##.state (Js.some dispatch_fn))) - ; ( "Mod-y" - , (fun _ _ -> PM.History.redo pm outerView##.state (Js.some dispatch_fn))) - |] - |]; - end) in - - let view_properties = PM.View.direct_editor_props () in - view_properties##.state := PM.State.create pm state_properties; - (* This is the magic part *) - view_properties##.dispatchTransaction := - (Js.wrap_meth_callback dispatchInner); - view_properties##.handleDOMEvents := PM.O.init - [| ( "mousedown" - , Js.wrap_callback (fun _ _ -> - (* Kludge to prevent issues due to the fact that the - whole footnote is node-selected (and thus DOM-selected) - when the parent editor is focused. *) - if (outerView##hasFocus () = Js._true) then ( - Js.Opt.iter !innerView (fun view -> view##focus ()) - ); - Js._false ))|]; - - innerView := Js.some - (PM.View.editor_view pm - tooltip - view_properties); - - method close = - Js.Opt.iter (!innerView) - (fun view -> - view##destroy; - innerView := Js.null; - El.set_prop - (El.Prop.jstr (Jstr.v "textContent")) - (Jstr.empty) - _self##.dom - ) - - method update - : PM.Model.node Js.t -> bool Js.t - = fun node -> - if (node##sameMarkup _self##.node = Js._false) then ( - Js._false - ) else ( - _self##.node := node; - Js.Opt.iter !innerView (fun view -> - let state = view##.state in - Js.Opt.iter (node##.content##findDiffStart state##.doc##.content) (fun start -> - let res_opt = (node##.content##findDiffEnd state##.doc##.content) in - Js.Opt.iter res_opt (fun end_diff -> - let overlap = start - (min end_diff##.a end_diff##.b) in - let endA, endB = - if overlap > 0 then - ( end_diff##.a + overlap - , end_diff##.b + overlap ) - else - ( end_diff##.a - , end_diff##.b ) - in - let tr = - state##.tr - ##(replace - ~from:start - ~to_:endB - (Js.some @@ node##slice ~from:start ~to_:(Js.some endA))) - ##(setMeta fromOutside true) in - view##dispatch tr))); - Js._true - ) - - method destroy = - Js.Opt.iter !innerView (fun _ -> _self##close) - - method stopEvent e = - Js.Opt.case !innerView - (fun () -> Js._false) - (fun view -> - let dom = view##.dom in - Jv.call (Jv.Id.to_jv dom) "contains" [| e##.target|] - |> Jv.Id.of_jv) - - method ignoreMutation = - Js._true - - method selectNode = - El.set_class (Jstr.v "ProseMirror-selectednode") true _self##.dom; - if not (Js.Opt.test !innerView) then ( - _self##_open - ) - - method deselectNode = - El.set_class (Jstr.v "ProseMirror-selectednode") false _self##.dom; - if (Js.Opt.test !innerView) then - _self##close - - end diff --git a/editor/forms/add_page.ml b/editor/forms/add_page.ml index 597e9d3..ac45824 100755 --- a/editor/forms/add_page.ml +++ b/editor/forms/add_page.ml @@ -1,9 +1,12 @@ open Brr open Brr_note open Note +module Js = Js_of_ocaml.Js + +type t = { title : Jstr.t } type Events.kind += - | AddPage of { title : Jstr.t } + | AddPage of t [@@unboxed] let create : unit -> Events.t @@ -34,3 +37,20 @@ let create [ input ] ] ] ) + +let key_of_title + : Jstr.t -> Jstr.t + = fun title -> + title + +let on_close + : t -> State.t -> State.t + = fun {title} state -> + let page_id = key_of_title title in + 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 + State.load_page (Some page_id) state content_obj diff --git a/editor/forms/add_page.mli b/editor/forms/add_page.mli index 97b1d6c..6be1611 100755 --- a/editor/forms/add_page.mli +++ b/editor/forms/add_page.mli @@ -1,5 +1,9 @@ +type t = { title : Jstr.t } type Events.kind += - | AddPage of { title : Jstr.t } + | AddPage of t [@@unboxed] val create : unit -> Events.t + +val on_close + : t -> State.t -> State.t diff --git a/editor/forms/delete_page.ml b/editor/forms/delete_page.ml index 701162c..3328dd7 100755 --- a/editor/forms/delete_page.ml +++ b/editor/forms/delete_page.ml @@ -1,8 +1,10 @@ open Brr open Note +type t = Jstr.t + type Events.kind += - | DeletePage of Jstr.t [@@unboxed] + | DeletePage of t [@@unboxed] let create : Jstr.t -> Events.t @@ -23,3 +25,9 @@ let create , El.txt message ) +let on_close + : t -> State.t -> State.t + = fun id state -> + State.Storage.delete (fun () -> Some id); + let json = State.Storage.load None in + State.load_page None state json diff --git a/editor/forms/dune b/editor/forms/dune index 9876654..124ce01 100755 --- a/editor/forms/dune +++ b/editor/forms/dune @@ -7,6 +7,7 @@ js_lib blog application + state ) (preprocess (pps js_of_ocaml-ppx)) ) diff --git a/editor/forms/events.ml b/editor/forms/events.ml index 339e15d..f7f5711 100755 --- a/editor/forms/events.ml +++ b/editor/forms/events.ml @@ -1,5 +1,20 @@ -(** This type is designed to be extended for each form *) +(** This type is designed to be extended for each form. + + Each of them hold the values inside the form. + +*) type kind = .. +(** The signal has to be log in order to be completely working *) type t = kind Note.signal * Brr.El.t +module type Handler = sig + + type t + + val on_close: t -> State.t -> State.t + +end + +type event = Event : 'a * (module Handler with type t = 'a) -> event + diff --git a/editor/link_editor.ml b/editor/link_editor.ml deleted file mode 100755 index 9bfdfd4..0000000 --- a/editor/link_editor.ml +++ /dev/null @@ -1,127 +0,0 @@ -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 - - 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 view = (fun view -> link_edit view) - end in - - Jv.new' (Jv.get state "Plugin") [| Jv.Id.to_jv params |] - |> Jv.Id.of_jv diff --git a/editor/plugins.ml b/editor/plugins.ml deleted file mode 100755 index 91dedeb..0000000 --- a/editor/plugins.ml +++ /dev/null @@ -1,135 +0,0 @@ -module Js = Js_of_ocaml.Js -module PM = Prosemirror - -(** 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 -> - ( 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 -> - 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 - 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 > 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 - -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)) - -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 - - 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 - - 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; - let setup = PM.Example.example_setup pm props in - - let keymaps = - PM.Keymap.keymap pm - [| "Backspace", (handle_backspace pm) - ; "#", (handle_sharp pm) - |] in - - (* Add the custom keymaps in the list *) - let _ = setup##unshift keymaps in - let _ = setup##push (input_rule pm) in - let _ = setup##push (Tooltip.bold_plugin pm) in - let _ = setup##push (Link_editor.plugin pm) in - - - Js.some setup diff --git a/editor/plugins/dune b/editor/plugins/dune new file mode 100755 index 0000000..046dc5a --- /dev/null +++ b/editor/plugins/dune @@ -0,0 +1,9 @@ +(library + (name plugins) + (libraries + brr + prosemirror + js_lib + ) + (preprocess (pps js_of_ocaml-ppx)) + ) diff --git a/editor/plugins/footnotes.ml b/editor/plugins/footnotes.ml new file mode 100755 index 0000000..794171f --- /dev/null +++ b/editor/plugins/footnotes.ml @@ -0,0 +1,248 @@ +open Brr +open Js_of_ocaml +module PM = Prosemirror + +let footNoteSpec = object%js + + val mutable group = Jstr.v "inline" + val mutable content = Jstr.v "inline*" (* The star is very important ! *) + val mutable inline = Js._true + val mutable draggable = Js._true + (* This makes the view treat the node as a leaf, even though it + technically has content *) + val mutable atom = Js._true + + val toDOM + : (PM.Model.node Js.t -> PM.Model.domOutputSpec Js.t) Js.callback + = Js.wrap_callback (fun _ -> + let open PM.Model.Dom_output_spec in + v "footnote" + [ hole ]) + + val parseDOM + : PM.Model.parse_rule Js.t Js.js_array Js.t Js.opt + = Js.some @@ Js.array + [|PM.Model.ParseRule.tag (Jstr.v "footnote")|] + +end + +let footnote_schema pm defaultSchema = + + let nodes = defaultSchema##.spec##.nodes + and marks = defaultSchema##.spec##.marks in + + let specs = PM.Model.schema_spec + (nodes##addToEnd (Jstr.v "footnote") (Js.Unsafe.coerce footNoteSpec)) + (Some marks) + None in + + PM.Model.schema pm + specs + +let build_menu pm schema = + let menu = PM.Example.buildMenuItems pm schema in + + let itemSpec = PM.Menu.menuItemSpec () in + itemSpec##.title := Js.some @@ Jstr.v "Insert footnote"; + itemSpec##.label := Js.some @@ Jstr.v "Footnote"; + itemSpec##.select := Js.wrap_meth_callback (fun _ (state:PM.State.editor_state Js.t) -> + match PM.O.get schema##.nodes "footnote" with + | None -> Js._false + | Some footnote_node -> + let res = Js.Opt.test @@ PM.Transform.insertPoint + pm + state##.doc + ~pos:state##.selection##.from + footnote_node + in + Js.bool res); + + itemSpec##.run := + Js.wrap_meth_callback (fun _this state dispatch _ _ -> + match PM.O.get schema##.nodes "footnote" with + | None -> () + | Some footnote_node -> + + let from' = PM.State.selection_from state##.selection + and to' = PM.State.selection_to state##.selection in + + let content = + if state##.selection##.empty != Js._true + && from'##sameParent to' = Js._true + && from'##.parent##.inlineContent = Js._true then ( + from'##.parent##.content##cut + (from'##.parentOffset) + (Js.some @@ to'##.parentOffset) + ) else ( + PM.Model.empty_fragment pm + ) in + let new_node = footnote_node##create_withFragmentContent + Js.null + (Js.some content) + Js.null + in + dispatch @@ + state##.tr##replaceSelectionWith + new_node + Js.null + ); + + let item = PM.Menu.menu_item pm itemSpec in + let _ = menu##.insertMenu##.content##push item in + menu + +let fromOutside + : bool PM.State.meta_data Js.t + = PM.State.create_str_meta_data (Jstr.v "fromOutside") + +let footnote_view + : PM.t -> PM.Model.node Js.t -> PM.View.editor_view Js.t -> (unit -> int) -> < .. > Js.t + = fun pm init_node outerView get_pos -> + + (* These are used when the footnote is selected *) + let innerView + : PM.View.editor_view Js.t Js.opt ref + = ref Js.null in + + let dispatchInner + : PM.View.editor_view Js.t -> PM.State.transaction Js.t -> unit + = fun view tr -> + let res = view##.state##applyTransaction tr in + view##updateState res##.state; + + let meta = Js.Optdef.get (tr##getMeta fromOutside) (fun () -> false) in + if (not meta) then ( + let outerTr = outerView##.state##.tr + and offsetMap = PM.Transform.offset pm ((get_pos()) + 1) in + res##.transactions##forEach + (Js.wrap_callback @@ + fun (elem:PM.State.transaction Js.t) _ _ -> + elem##.steps##forEach + (Js.wrap_callback @@ fun (step:PM.Transform.step Js.t) _ _ -> + let _ = outerTr##step (step##map offsetMap) in + () + )); + if (outerTr##.docChanged = Js._true) then ( + outerView##dispatch outerTr) + ); + in + object%js (_self) + + val mutable node: PM.Model.node Js.t = init_node + + (* The node's representation in the editor (empty, for now) *) + val dom = El.v (Jstr.v "footnote") [] + + method _open = + (* Append a tooltip to the outer node *) + let tooltip = El.div [] + ~at:At.([class' (Jstr.v "popin")]) in + El.append_children _self##.dom + [ tooltip ]; + + let dispatch_fn + : PM.State.transaction Js.t -> unit + = fun tr -> outerView##dispatch tr in + + let state_properties = Js.Unsafe.coerce (object%js + val doc = Js.some _self##.node; + val plugins = Js.some @@ Js.array @@ [| + PM.Keymap.keymap pm + [| ( "Mod-z" + , (fun _ _ -> PM.History.undo pm outerView##.state (Js.some dispatch_fn))) + ; ( "Mod-y" + , (fun _ _ -> PM.History.redo pm outerView##.state (Js.some dispatch_fn))) + |] + |]; + end) in + + let view_properties = PM.View.direct_editor_props () in + view_properties##.state := PM.State.create pm state_properties; + (* This is the magic part *) + view_properties##.dispatchTransaction := + (Js.wrap_meth_callback dispatchInner); + view_properties##.handleDOMEvents := PM.O.init + [| ( "mousedown" + , Js.wrap_callback (fun _ _ -> + (* Kludge to prevent issues due to the fact that the + whole footnote is node-selected (and thus DOM-selected) + when the parent editor is focused. *) + if (outerView##hasFocus () = Js._true) then ( + Js.Opt.iter !innerView (fun view -> view##focus ()) + ); + Js._false ))|]; + + innerView := Js.some + (PM.View.editor_view pm + tooltip + view_properties); + + method close = + Js.Opt.iter (!innerView) + (fun view -> + view##destroy; + innerView := Js.null; + El.set_prop + (El.Prop.jstr (Jstr.v "textContent")) + (Jstr.empty) + _self##.dom + ) + + method update + : PM.Model.node Js.t -> bool Js.t + = fun node -> + if (node##sameMarkup _self##.node = Js._false) then ( + Js._false + ) else ( + _self##.node := node; + Js.Opt.iter !innerView (fun view -> + let state = view##.state in + Js.Opt.iter (node##.content##findDiffStart state##.doc##.content) (fun start -> + let res_opt = (node##.content##findDiffEnd state##.doc##.content) in + Js.Opt.iter res_opt (fun end_diff -> + let overlap = start - (min end_diff##.a end_diff##.b) in + let endA, endB = + if overlap > 0 then + ( end_diff##.a + overlap + , end_diff##.b + overlap ) + else + ( end_diff##.a + , end_diff##.b ) + in + let tr = + state##.tr + ##(replace + ~from:start + ~to_:endB + (Js.some @@ node##slice ~from:start ~to_:(Js.some endA))) + ##(setMeta fromOutside true) in + view##dispatch tr))); + Js._true + ) + + method destroy = + Js.Opt.iter !innerView (fun _ -> _self##close) + + method stopEvent e = + Js.Opt.case !innerView + (fun () -> Js._false) + (fun view -> + let dom = view##.dom in + Jv.call (Jv.Id.to_jv dom) "contains" [| e##.target|] + |> Jv.Id.of_jv) + + method ignoreMutation = + Js._true + + method selectNode = + El.set_class (Jstr.v "ProseMirror-selectednode") true _self##.dom; + if not (Js.Opt.test !innerView) then ( + _self##_open + ) + + method deselectNode = + El.set_class (Jstr.v "ProseMirror-selectednode") false _self##.dom; + if (Js.Opt.test !innerView) then + _self##close + + end diff --git a/editor/plugins/link_editor.ml b/editor/plugins/link_editor.ml new file mode 100755 index 0000000..9bfdfd4 --- /dev/null +++ b/editor/plugins/link_editor.ml @@ -0,0 +1,127 @@ +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 + + 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 view = (fun view -> link_edit view) + end in + + 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 new file mode 100755 index 0000000..3a92df8 --- /dev/null +++ b/editor/plugins/plugins.ml @@ -0,0 +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 -> + ( 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 -> + 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 + 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 > 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 + +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)) + +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 + + 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 + + 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; + let setup = PM.Example.example_setup pm props in + + let keymaps = + PM.Keymap.keymap pm + [| "Backspace", (handle_backspace pm) + ; "#", (handle_sharp pm) + |] in + + (* Add the custom keymaps in the list *) + let _ = setup##unshift keymaps in + let _ = setup##push (input_rule pm) in + let _ = setup##push (Tooltip.bold_plugin pm) in + let _ = setup##push (Link_editor.plugin pm) in + + + Js.some setup diff --git a/editor/plugins/popin.ml b/editor/plugins/popin.ml new file mode 100755 index 0000000..63dcad1 --- /dev/null +++ b/editor/plugins/popin.ml @@ -0,0 +1,83 @@ +open Brr +module Js = Js_of_ocaml.Js +module PM = Prosemirror + +type binded_field = + { field: El.t + ; button: El.t + } + +(** Set the element position just above the selection *) +let set_position + : start:int -> end':int -> PM.View.editor_view Js.t -> El.t -> unit + = fun ~start ~end' view el -> + El.set_inline_style El.Style.display (Jstr.v "") el; + + (* These are in screen coordinates *) + let start = view##coordsAtPos start Js.null + and end' = view##coordsAtPos end' Js.null in + let offsetParent = Jv.(Id.of_jv @@ get (Jv.Id.to_jv el) "offsetParent") in + + (* The box in which the tooltip is positioned, to use as base *) + let box = Jv.(Id.of_jv @@ call (Jv.Id.to_jv offsetParent) "getBoundingClientRect" [||]) in + let box_left = Jv.(Id.of_jv @@ get (Jv.Id.to_jv box) "left") in + let box_bottom = Jv.(Id.of_jv @@ get (Jv.Id.to_jv box) "bottom") in + + (* Find a center-ish x position from the selection endpoints (when + crossing lines, end may be more to the left) *) + let left = (start##.left +. end'##.left) /. 2. in + + El.set_inline_style (Jstr.v "left") + Jstr.( (of_float ( left -. box_left )) + (v "px") ) + el; + El.set_inline_style (Jstr.v "bottom") + Jstr.( (of_float ( box_bottom -. start##.top )) + (v "px") ) + el + +(** Build a button which allow to activate or desactivate the given Element. + + The function f is called when the user validate the input. + +*) +let build_field + : El.t -> (Jstr.t -> bool) -> binded_field + = fun field f -> + + let button_content = + [ El.i [] + ~at:At.[ class' (Jstr.v "fas") + ; class' (Jstr.v "fa-pen") ] + ] in + + let button = El.button + button_content + in + + Ev.listen Ev.click + (fun _ -> + match El.at (Jstr.v "contenteditable") field with + | Some value when (Jstr.equal value (Jstr.v "true")) -> + let new_value = El.prop + (El.Prop.jstr (Jstr.v "textContent")) + field in + begin match f new_value with + | true -> + El.set_at (Jstr.v "contenteditable") None field; + El.set_children button button_content + | false -> () + end + | _ -> + El.set_at (Jstr.v "contenteditable") + (Some (Jstr.v "true")) field; + El.set_children button + [ El.i + ~at:At.[ class' (Jstr.v "fas") + ; class' (Jstr.v "fa-check") ] + [] + ] + ) + (El.as_target button); + + { field + ; button = button + } diff --git a/editor/plugins/tooltip.ml b/editor/plugins/tooltip.ml new file mode 100755 index 0000000..05d56d4 --- /dev/null +++ b/editor/plugins/tooltip.ml @@ -0,0 +1,89 @@ +open StdLabels +open Brr + +module Js = Js_of_ocaml.Js +module PM = Prosemirror + +(** https://prosemirror.net/examples/tooltip/ *) + + +let boldtip + : PM.View.editor_view Js.t -> < .. > Js.t + = fun view -> + (* Create the element which will be displayed over the editor *) + let tooltip = El.div [] + ~at:At.([ class' (Jstr.v "popin") + ]) in + El.set_inline_style El.Style.display (Jstr.v "none") tooltip; + + let parent = Jv.(Id.of_jv @@ get (Jv.Id.to_jv view##.dom) "parentNode") in + let () = El.append_children parent [tooltip] in + + let update + : PM.View.editor_view Js.t -> PM.State.editor_state Js. t Js.opt -> unit + = fun view state_opt -> + + (* Compare the previous and actual state. If the stored marks are the + same, just return *) + let state = view##.state in + let previous_stored_marks = + Js.Opt.bind state_opt (fun state -> state##.storedMarks) + |> Js.Opt.to_option + and current_stored_marks = state##.storedMarks in + + let same = match previous_stored_marks, Js.Opt.to_option current_stored_marks with + | Some arr1, Some arr2 -> + Js_lib.Array.compare arr1 arr2 ~f:(fun v1 v2 -> v1##eq v2) + | None, None -> Js._true + | _, _ -> Js._false in + + if same <> Js._true then + + let is_bold = Option.bind (PM.O.get state##.schema##.marks "strong") + (fun mark_type -> + let is_strong = + Js.Opt.bind current_stored_marks + (fun t -> mark_type##isInSet t) in + Js.Opt.case is_strong + (fun () -> None) + (fun _ -> Some (Jstr.v "gras"))) in + let is_em = Option.bind (PM.O.get state##.schema##.marks "em") + (fun mark_type -> + let is_em = + Js.Opt.bind current_stored_marks + (fun t -> mark_type##isInSet t) in + Js.Opt.case is_em + (fun () -> None) + (fun _ -> Some (Jstr.(v "emphase")))) in + + let marks = List.filter_map [is_bold; is_em] ~f:(fun x -> x) in + match marks with + | [] -> El.set_inline_style El.Style.display (Jstr.v "none") tooltip + | _ -> + (* The mark is present, add in the content *) + let start = view##.state##.selection##.from + and end' = view##.state##.selection##._to in + Popin.set_position ~start ~end' view tooltip; + El.set_prop + (El.Prop.jstr (Jstr.v "textContent")) + (Jstr.concat marks ~sep:(Jstr.v ", ")) + tooltip + + and destroy () = El.remove tooltip in + + object%js + val update = Js.wrap_callback update + val destroy= Js.wrap_callback destroy + end + +let bold_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 -> boldtip view) + end in + + Jv.new' (Jv.get state "Plugin") [| Jv.Id.to_jv params |] + |> Jv.Id.of_jv diff --git a/editor/popin.ml b/editor/popin.ml deleted file mode 100755 index 63dcad1..0000000 --- a/editor/popin.ml +++ /dev/null @@ -1,83 +0,0 @@ -open Brr -module Js = Js_of_ocaml.Js -module PM = Prosemirror - -type binded_field = - { field: El.t - ; button: El.t - } - -(** Set the element position just above the selection *) -let set_position - : start:int -> end':int -> PM.View.editor_view Js.t -> El.t -> unit - = fun ~start ~end' view el -> - El.set_inline_style El.Style.display (Jstr.v "") el; - - (* These are in screen coordinates *) - let start = view##coordsAtPos start Js.null - and end' = view##coordsAtPos end' Js.null in - let offsetParent = Jv.(Id.of_jv @@ get (Jv.Id.to_jv el) "offsetParent") in - - (* The box in which the tooltip is positioned, to use as base *) - let box = Jv.(Id.of_jv @@ call (Jv.Id.to_jv offsetParent) "getBoundingClientRect" [||]) in - let box_left = Jv.(Id.of_jv @@ get (Jv.Id.to_jv box) "left") in - let box_bottom = Jv.(Id.of_jv @@ get (Jv.Id.to_jv box) "bottom") in - - (* Find a center-ish x position from the selection endpoints (when - crossing lines, end may be more to the left) *) - let left = (start##.left +. end'##.left) /. 2. in - - El.set_inline_style (Jstr.v "left") - Jstr.( (of_float ( left -. box_left )) + (v "px") ) - el; - El.set_inline_style (Jstr.v "bottom") - Jstr.( (of_float ( box_bottom -. start##.top )) + (v "px") ) - el - -(** Build a button which allow to activate or desactivate the given Element. - - The function f is called when the user validate the input. - -*) -let build_field - : El.t -> (Jstr.t -> bool) -> binded_field - = fun field f -> - - let button_content = - [ El.i [] - ~at:At.[ class' (Jstr.v "fas") - ; class' (Jstr.v "fa-pen") ] - ] in - - let button = El.button - button_content - in - - Ev.listen Ev.click - (fun _ -> - match El.at (Jstr.v "contenteditable") field with - | Some value when (Jstr.equal value (Jstr.v "true")) -> - let new_value = El.prop - (El.Prop.jstr (Jstr.v "textContent")) - field in - begin match f new_value with - | true -> - El.set_at (Jstr.v "contenteditable") None field; - El.set_children button button_content - | false -> () - end - | _ -> - El.set_at (Jstr.v "contenteditable") - (Some (Jstr.v "true")) field; - El.set_children button - [ El.i - ~at:At.[ class' (Jstr.v "fas") - ; class' (Jstr.v "fa-check") ] - [] - ] - ) - (El.as_target button); - - { field - ; button = button - } diff --git a/editor/state/dune b/editor/state/dune new file mode 100755 index 0000000..dd405a1 --- /dev/null +++ b/editor/state/dune @@ -0,0 +1,9 @@ +(library + (name state) + (libraries + brr + prosemirror + plugins + ) + (preprocess (pps js_of_ocaml-ppx)) + ) diff --git a/editor/state/state.ml b/editor/state/state.ml new file mode 100755 index 0000000..48b4d58 --- /dev/null +++ b/editor/state/state.ml @@ -0,0 +1,70 @@ +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 + + ; window : Brr.El.t list + ; pm : PM.t + } + +(** Compare two states together. + + 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 -> Storage.content Js.t -> t + = fun page_id state json -> + 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 + { state with page_id } + diff --git a/editor/state/state.mli b/editor/state/state.mli new file mode 100755 index 0000000..e370015 --- /dev/null +++ b/editor/state/state.mli @@ -0,0 +1,24 @@ +module Js = Js_of_ocaml.Js + +module Storage = Storage + +type t = + { editable : bool + ; view : Prosemirror.View.editor_view Js.t + ; last_backup: float + ; page_id: Jstr.t option + + ; window : Brr.El.t list + ; pm : Prosemirror.t + } + +val eq: t -> t -> bool + +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 load_page + : Jstr.t option -> t -> Storage.content Js.t -> t diff --git a/editor/state/storage.ml b/editor/state/storage.ml new file mode 100755 index 0000000..f893c2d --- /dev/null +++ b/editor/state/storage.ml @@ -0,0 +1,137 @@ +open Brr +module Js = Js_of_ocaml.Js + +let storage_key = (Jstr.v "editor") + +let storage = Brr_io.Storage.local G.window + +class type content = object + + method title + : Jstr.t Js.opt Js.readonly_prop + + method content + : Jv.t Js.opt Js.readonly_prop + + method date + : float Js.opt Js.readonly_prop + +end + +let page_id + : unit -> Jstr.t option + = fun () -> + let uri = Brr.Window.location Brr.G.window in + let query = Brr.Uri.query uri in + let params = Brr.Uri.Params.of_jstr query in + Brr.Uri.Params.find (Jstr.v "page") params + +(** [load' pm schema content key] will load the content stored in the local + storage for the [key]. +*) +let load' + : Jstr.t -> content Js.t + = fun key -> + + let opt_data = Brr_io.Storage.get_item storage key in + match opt_data with + | None -> + object%js + val title = Js.null + val content = Js.null + val date = Js.null + end + | Some contents -> + + (* Try to load from the storage *) + match Json.decode contents with + | Error _ -> + object%js + val title = Js.null + val content = Js.null + val date = Js.null + end + + | Ok json -> + Jv.Id.of_jv json + +(** Save the view *) +let save' + : check:(content Js.t -> bool) -> content Js.t -> Jstr.t -> (bool, Jv.Error.t) result + = fun ~check object_content key -> + + (* First load the content from the storage *) + match check (load' key) with + | false -> Ok false + | true -> + let storage = Brr_io.Storage.local G.window in + let operation = Brr_io.Storage.set_item + storage + key + (Json.encode @@ Jv.Id.to_jv @@ object_content) in + Result.map (fun () -> true) operation + + +(** [load pm schema content f] will try load the content stored in the local + storage. The right key is given by the result of the function [f] +*) +let load + : Jstr.t option -> content Js.t + = fun key -> + match key with + | None -> load' storage_key + | Some value -> + let key = Jstr.concat + ~sep:(Jstr.v "_") + [storage_key ; value] in + load' key + +let save + : check:(content Js.t -> bool) -> content Js.t -> Jstr.t option -> (bool, Jv.Error.t) result + = fun ~check object_content key -> + match key with + | None -> + save' ~check object_content storage_key + | Some value -> + let key = Jstr.concat + ~sep:(Jstr.v "_") + [storage_key ; value] in + save' ~check object_content key + +let delete + : (unit -> Jstr.t option) -> unit + = fun f -> + match f () with + | None -> () + | Some value -> + let key = Jstr.concat + ~sep:(Jstr.v "_") + [storage_key ; value] in + let storage = Brr_io.Storage.local G.window in + Brr_io.Storage.remove_item storage key + +let get_ids + : unit -> Jstr.t list + = fun () -> + let open Brr_io in + let storage = Storage.local G.window in + let items = Storage.length storage in + + let sub = Jstr.( storage_key + (v "_") ) in + let start = Jstr.length sub in + + let rec add_element acc = function + | -1 -> acc + | nb -> + begin match Storage.key storage nb with + | Some key when (Jstr.starts_with ~sub key) -> + + let key_name = Jstr.sub key + ~start in + add_element (key_name::acc) (nb -1) + | _ -> + add_element acc (nb -1) + end + + in + add_element [] items diff --git a/editor/state/storage.mli b/editor/state/storage.mli new file mode 100755 index 0000000..5b7e0a0 --- /dev/null +++ b/editor/state/storage.mli @@ -0,0 +1,36 @@ +module Js = Js_of_ocaml.Js + +(** Provide a function for extracting the page id from the URL *) +val page_id + : unit -> Jstr.t option + +class type content = object + + method title + : Jstr.t Js.opt Js.readonly_prop + + method content + : Jv.t Js.opt Js.readonly_prop + + method date + : float Js.opt Js.readonly_prop + +end + +(** load f] will try to load the content associated with the given key. + + The function [f] is called to identified which is the appropriate page id. +*) +val load + : Jstr.t option -> content Js.t + +val save + : check:(content Js.t -> bool) -> content Js.t -> Jstr.t option -> (bool, Jv.Error.t) result + +(** Remove the page from the storage. *) +val delete + : (unit -> Jstr.t option) -> unit + +(** Collect all the keys to the existing pages *) +val get_ids + : unit -> Jstr.t list diff --git a/editor/storage.ml b/editor/storage.ml deleted file mode 100755 index f893c2d..0000000 --- a/editor/storage.ml +++ /dev/null @@ -1,137 +0,0 @@ -open Brr -module Js = Js_of_ocaml.Js - -let storage_key = (Jstr.v "editor") - -let storage = Brr_io.Storage.local G.window - -class type content = object - - method title - : Jstr.t Js.opt Js.readonly_prop - - method content - : Jv.t Js.opt Js.readonly_prop - - method date - : float Js.opt Js.readonly_prop - -end - -let page_id - : unit -> Jstr.t option - = fun () -> - let uri = Brr.Window.location Brr.G.window in - let query = Brr.Uri.query uri in - let params = Brr.Uri.Params.of_jstr query in - Brr.Uri.Params.find (Jstr.v "page") params - -(** [load' pm schema content key] will load the content stored in the local - storage for the [key]. -*) -let load' - : Jstr.t -> content Js.t - = fun key -> - - let opt_data = Brr_io.Storage.get_item storage key in - match opt_data with - | None -> - object%js - val title = Js.null - val content = Js.null - val date = Js.null - end - | Some contents -> - - (* Try to load from the storage *) - match Json.decode contents with - | Error _ -> - object%js - val title = Js.null - val content = Js.null - val date = Js.null - end - - | Ok json -> - Jv.Id.of_jv json - -(** Save the view *) -let save' - : check:(content Js.t -> bool) -> content Js.t -> Jstr.t -> (bool, Jv.Error.t) result - = fun ~check object_content key -> - - (* First load the content from the storage *) - match check (load' key) with - | false -> Ok false - | true -> - let storage = Brr_io.Storage.local G.window in - let operation = Brr_io.Storage.set_item - storage - key - (Json.encode @@ Jv.Id.to_jv @@ object_content) in - Result.map (fun () -> true) operation - - -(** [load pm schema content f] will try load the content stored in the local - storage. The right key is given by the result of the function [f] -*) -let load - : Jstr.t option -> content Js.t - = fun key -> - match key with - | None -> load' storage_key - | Some value -> - let key = Jstr.concat - ~sep:(Jstr.v "_") - [storage_key ; value] in - load' key - -let save - : check:(content Js.t -> bool) -> content Js.t -> Jstr.t option -> (bool, Jv.Error.t) result - = fun ~check object_content key -> - match key with - | None -> - save' ~check object_content storage_key - | Some value -> - let key = Jstr.concat - ~sep:(Jstr.v "_") - [storage_key ; value] in - save' ~check object_content key - -let delete - : (unit -> Jstr.t option) -> unit - = fun f -> - match f () with - | None -> () - | Some value -> - let key = Jstr.concat - ~sep:(Jstr.v "_") - [storage_key ; value] in - let storage = Brr_io.Storage.local G.window in - Brr_io.Storage.remove_item storage key - -let get_ids - : unit -> Jstr.t list - = fun () -> - let open Brr_io in - let storage = Storage.local G.window in - let items = Storage.length storage in - - let sub = Jstr.( storage_key + (v "_") ) in - let start = Jstr.length sub in - - let rec add_element acc = function - | -1 -> acc - | nb -> - begin match Storage.key storage nb with - | Some key when (Jstr.starts_with ~sub key) -> - - let key_name = Jstr.sub key - ~start in - add_element (key_name::acc) (nb -1) - | _ -> - add_element acc (nb -1) - end - - in - add_element [] items diff --git a/editor/storage.mli b/editor/storage.mli deleted file mode 100755 index 5b7e0a0..0000000 --- a/editor/storage.mli +++ /dev/null @@ -1,36 +0,0 @@ -module Js = Js_of_ocaml.Js - -(** Provide a function for extracting the page id from the URL *) -val page_id - : unit -> Jstr.t option - -class type content = object - - method title - : Jstr.t Js.opt Js.readonly_prop - - method content - : Jv.t Js.opt Js.readonly_prop - - method date - : float Js.opt Js.readonly_prop - -end - -(** load f] will try to load the content associated with the given key. - - The function [f] is called to identified which is the appropriate page id. -*) -val load - : Jstr.t option -> content Js.t - -val save - : check:(content Js.t -> bool) -> content Js.t -> Jstr.t option -> (bool, Jv.Error.t) result - -(** Remove the page from the storage. *) -val delete - : (unit -> Jstr.t option) -> unit - -(** Collect all the keys to the existing pages *) -val get_ids - : unit -> Jstr.t list diff --git a/editor/tooltip.ml b/editor/tooltip.ml deleted file mode 100755 index 05d56d4..0000000 --- a/editor/tooltip.ml +++ /dev/null @@ -1,89 +0,0 @@ -open StdLabels -open Brr - -module Js = Js_of_ocaml.Js -module PM = Prosemirror - -(** https://prosemirror.net/examples/tooltip/ *) - - -let boldtip - : PM.View.editor_view Js.t -> < .. > Js.t - = fun view -> - (* Create the element which will be displayed over the editor *) - let tooltip = El.div [] - ~at:At.([ class' (Jstr.v "popin") - ]) in - El.set_inline_style El.Style.display (Jstr.v "none") tooltip; - - let parent = Jv.(Id.of_jv @@ get (Jv.Id.to_jv view##.dom) "parentNode") in - let () = El.append_children parent [tooltip] in - - let update - : PM.View.editor_view Js.t -> PM.State.editor_state Js. t Js.opt -> unit - = fun view state_opt -> - - (* Compare the previous and actual state. If the stored marks are the - same, just return *) - let state = view##.state in - let previous_stored_marks = - Js.Opt.bind state_opt (fun state -> state##.storedMarks) - |> Js.Opt.to_option - and current_stored_marks = state##.storedMarks in - - let same = match previous_stored_marks, Js.Opt.to_option current_stored_marks with - | Some arr1, Some arr2 -> - Js_lib.Array.compare arr1 arr2 ~f:(fun v1 v2 -> v1##eq v2) - | None, None -> Js._true - | _, _ -> Js._false in - - if same <> Js._true then - - let is_bold = Option.bind (PM.O.get state##.schema##.marks "strong") - (fun mark_type -> - let is_strong = - Js.Opt.bind current_stored_marks - (fun t -> mark_type##isInSet t) in - Js.Opt.case is_strong - (fun () -> None) - (fun _ -> Some (Jstr.v "gras"))) in - let is_em = Option.bind (PM.O.get state##.schema##.marks "em") - (fun mark_type -> - let is_em = - Js.Opt.bind current_stored_marks - (fun t -> mark_type##isInSet t) in - Js.Opt.case is_em - (fun () -> None) - (fun _ -> Some (Jstr.(v "emphase")))) in - - let marks = List.filter_map [is_bold; is_em] ~f:(fun x -> x) in - match marks with - | [] -> El.set_inline_style El.Style.display (Jstr.v "none") tooltip - | _ -> - (* The mark is present, add in the content *) - let start = view##.state##.selection##.from - and end' = view##.state##.selection##._to in - Popin.set_position ~start ~end' view tooltip; - El.set_prop - (El.Prop.jstr (Jstr.v "textContent")) - (Jstr.concat marks ~sep:(Jstr.v ", ")) - tooltip - - and destroy () = El.remove tooltip in - - object%js - val update = Js.wrap_callback update - val destroy= Js.wrap_callback destroy - end - -let bold_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 -> boldtip view) - end in - - Jv.new' (Jv.get state "Plugin") [| Jv.Id.to_jv params |] - |> Jv.Id.of_jv -- cgit v1.2.3