From da1d9ad1c49f31fc9031fd1bc6661dad3600e40c Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Fri, 4 Jun 2021 22:56:27 +0200 Subject: Added markdown output --- editor/actions/dune | 1 + editor/actions/editor_actions.ml | 31 ++-- editor/actions/editor_actions.mli | 2 +- editor/actions/of_markdown.ml | 236 +++++++++++++++++++++++++++++ editor/actions/to_markdown.ml | 294 +++++++++++++++++++++++++++++++++++++ editor/editor.css | 0 editor/editor.ml | 2 +- editor/prosemirror/bindings.ml | 19 ++- editor/prosemirror/prosemirror.ml | 12 ++ editor/prosemirror/prosemirror.mli | 7 + 10 files changed, 587 insertions(+), 17 deletions(-) create mode 100755 editor/actions/of_markdown.ml create mode 100755 editor/actions/to_markdown.ml mode change 100644 => 100755 editor/editor.css (limited to 'editor') diff --git a/editor/actions/dune b/editor/actions/dune index 4044b52..10279dd 100755 --- a/editor/actions/dune +++ b/editor/actions/dune @@ -3,6 +3,7 @@ (libraries brr brr.note + omd elements blog forms diff --git a/editor/actions/editor_actions.ml b/editor/actions/editor_actions.ml index 91d2a24..518e0c7 100755 --- a/editor/actions/editor_actions.ml +++ b/editor/actions/editor_actions.ml @@ -17,8 +17,8 @@ type t = } let build - : unit -> t - = fun () -> + : Prosemirror.t -> t + = fun pm -> let delete_button = El.button ~at:At.[ class' (Jstr.v "action-button") ] @@ -56,6 +56,16 @@ let build ~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 @@ -89,6 +99,11 @@ let build Ev.click (fun _ -> Import.create ()) load_button) + and cog_event = + Evr.on_el + Ev.click + (fun _ -> To_markdown.create pm) + cog_button in @@ -128,14 +143,7 @@ let build ; export_button ; load_button ; 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-cog") ] - ] + ; cog_button ; El.hr () ; ul ] in @@ -145,7 +153,8 @@ let build ; redirect_event ; add_event ; export_event - ; import_event ] in + ; import_event + ; cog_event ] in { ev = result_event ; childs diff --git a/editor/actions/editor_actions.mli b/editor/actions/editor_actions.mli index 0e9997b..a0a3c3b 100755 --- a/editor/actions/editor_actions.mli +++ b/editor/actions/editor_actions.mli @@ -2,7 +2,7 @@ type t (** Create the elements to be declared inside the panel *) val build - : unit -> t + : Prosemirror.t -> t (** Get the events triggered by the actions buttons *) val get_event diff --git a/editor/actions/of_markdown.ml b/editor/actions/of_markdown.ml new file mode 100755 index 0000000..580c6c4 --- /dev/null +++ b/editor/actions/of_markdown.ml @@ -0,0 +1,236 @@ +open StdLabels +module Js = Js_of_ocaml.Js +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 m = schema##mark_fromType mark_type attributes in + 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 + -> 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) -> + 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 + + (* 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) + (new%js Js.array_empty) + + | 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 + parse_inline_content view pm marks content + + | Omd.Emph (attrs, content) -> + ignore attrs; + let marks = add_attribute + "em" + view##.state##.schema + marks + Js.null in + parse_inline_content view pm marks content + + | Omd.Text (attrs, text) -> + ignore attrs; + (* Convert the marks as js array *) + let js_marks = Js.array @@ Array.of_list marks in + Js.array + [| view##.state##.schema##text + (Jstr.of_string text) + (Js.some js_marks) + |] + + | Omd.Code (attrs, content) -> + ignore attrs; + 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) -> + 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 + parse_inline_content view pm marks link_attrs.label + + | _ -> + (* TODO Handle Break *) + 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) -> + 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 + (Jstr.v "paragraph") + (Js.null) + (Js.some fragment) + (Js.null) in + Some node + + | 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 + 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 + (Jstr.v "heading") + (Js.some attributes) + (Js.some fragment) + (Js.null) in + Some node + + | Omd.List (attrs, type_, spacing, elements) -> + ignore attrs; + ignore spacing; + + let type_list = match type_ with + | Omd.Ordered _ -> "ordered_list" + | Omd.Bullet _ -> "bullet_list" in + + (* The whole list node is declared as ordered or bullet depending of + the type given by the markdown. + + Each element insiide 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 fragment = PM.Model.Fragment.from_array pm nodes_array in + let node = view##.state##.schema##node + (Jstr.v type_list) + (Js.null) + (Js.some fragment) + (Js.null) in + Some node + + | Omd.Thematic_break attrs -> + ignore attrs; + let node = view##.state##.schema##node + (Jstr.v "horizontal_rule") + (Js.null) + (Js.null) + (Js.null) in + Some node + + | Omd.Blockquote(attrs, elements) -> + ignore attrs; + let nodes = + List.filter_map elements + ~f:(fun e -> parse_block view pm e) + |> Array.of_list + |> Js.array in + let fragment = PM.Model.Fragment.from_array pm nodes in + let node = view##.state##.schema##node + (Jstr.v "blockquote") + (Js.null) + (Js.some fragment) + (Js.null) in + Some node + + | _ -> + Brr.Console.(log [Jstr.v "Other block"]); + None + + let parse + : Prosemirror.View.editor_view Js.t -> PM.t -> Omd.doc -> unit + = 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 ]) + + 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 new file mode 100755 index 0000000..c1ac774 --- /dev/null +++ b/editor/actions/to_markdown.ml @@ -0,0 +1,294 @@ +module Js = Js_of_ocaml.Js +module PM = Prosemirror + +type buffer = Jstr.t Js.js_array Js.t +type f = (buffer -> PM.Model.node Js.t -> unit) + +let render_mark_type = object%js + + method code + = fun (mark:PM.Model.mark Js.t) (buffer: buffer) -> + ignore mark; + (* There may be a bug here, if the code itself contains `` . + + The encoder should search inside the node if the patern is present, + and adjust the number of backticks accordingly + + https://spec.commonmark.org/0.29/#code-span *) + ignore @@ buffer##push (Jstr.v "``"); + fun (buffer:buffer) -> + ignore @@ buffer##push (Jstr.v "``") + + method strong + = fun (mark:PM.Model.mark Js.t) (buffer: buffer) -> + ignore mark; + ignore @@ buffer##push (Jstr.v "**"); + fun (buffer:buffer) -> + ignore @@ buffer##push (Jstr.v "**") + + method em + = fun (mark:PM.Model.mark Js.t) (buffer: buffer) -> + ignore mark; + 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) -> + ignore @@ buffer##push (Jstr.v "["); + 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 ")"); + +end + +type render_state = + { level : int + ; 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 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 ]) + | 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) -> + ignore state; + ignore node; + 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 state; + (* Execute each mark as an environment like + \begin{environement} + … + \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) + (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 + 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) -> + + 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) -> + 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) -> + + 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) -> + 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) -> + 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) -> + 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 " ") )) + ); + 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) -> + 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 + + + +module ToMarkdown = struct + + type t = PM.t + + let update + : 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 -> State.event + = fun pm -> + State.E + ( pm + , (module ToMarkdown : State.Event with type t = ToMarkdown.t )) diff --git a/editor/editor.css b/editor/editor.css old mode 100644 new mode 100755 diff --git a/editor/editor.ml b/editor/editor.ml index 8dc13e8..5883ec8 100755 --- a/editor/editor.ml +++ b/editor/editor.ml @@ -131,7 +131,7 @@ let app id content = let init_state = State.init pm view last_backup page_id in - let side_elements = Editor_actions.build () in + let side_elements = Editor_actions.build pm in let btn_events = Editor_actions.get_event side_elements in let app_state = State.run ~eq:State.eq diff --git a/editor/prosemirror/bindings.ml b/editor/prosemirror/bindings.ml index 49c0904..7f6d82f 100755 --- a/editor/prosemirror/bindings.ml +++ b/editor/prosemirror/bindings.ml @@ -116,6 +116,9 @@ module Classes = struct class type mark = object ('this) + method _type + : mark_type t readonly_prop + method attrs : 'a TypedObject.t prop @@ -127,7 +130,7 @@ module Classes = struct end - class type node_spec = object ('this) + and node_spec = object ('this) method content : Jstr.t opt prop @@ -258,12 +261,18 @@ module Classes = struct method marks: mark_type t TypedObject.t readonly_prop - method typoNodeType: + method topNodeType: node_type t readonly_prop method text: - Jstr.t -> node t meth + Jstr.t -> 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 @@ -348,7 +357,9 @@ module Classes = struct : (node t -> pos:int -> node t -> bool t) callback -> unit meth method forEach - : (node t -> offset:int -> index:int -> unit) callback -> unit meth + : (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 diff --git a/editor/prosemirror/prosemirror.ml b/editor/prosemirror/prosemirror.ml index 48dbfd0..e413084 100755 --- a/editor/prosemirror/prosemirror.ml +++ b/editor/prosemirror/prosemirror.ml @@ -16,6 +16,18 @@ module Model = struct include Bindings.Model + module Fragment = struct + + 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 diff --git a/editor/prosemirror/prosemirror.mli b/editor/prosemirror/prosemirror.mli index 506ab89..dd8d5de 100755 --- a/editor/prosemirror/prosemirror.mli +++ b/editor/prosemirror/prosemirror.mli @@ -90,6 +90,13 @@ and Model : sig val schema : t -> schema_spec Js.t -> schema Js.t + module Fragment : sig + + val from_array + : t -> node Js.t Js.js_array Js.t -> fragment Js.t + + end + module Mark : sig val set_from_mark -- cgit v1.2.3