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 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 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