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 | Hard_break _ | Soft_break _ (* TODO Handle Break *) |Image (_, _) |Html (_, _) -> Brr.Console.(log [ Jstr.v "Other" ]); new%js Js.array_empty let rec parse_block : Prosemirror.View.editor_view Js.t -> PM.t -> Omd.attributes Omd.block -> node_t option = fun view pm -> function | Omd.Paragraph (attrs, elements) -> 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 inside the list is transformed as a list_item. The list_item node can itself contains other blocks (recursively) *) let nodes = List.map elements ~f:(fun list_entry -> let nodes = List.filter_map list_entry ~f:(fun e -> parse_block view pm e) |> Array.of_list |> Js.array in let fragment = PM.Model.Fragment.from_array pm nodes in view##.state##.schema##node (Jstr.v "list_item") Js.null (Js.some fragment) Js.null ) in let nodes_array = nodes |> Array.of_list |> Js.array in let 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 | Code_block (attrs, content, format) -> ignore attrs; (* The language format is ignored (I do not provide syntaxic coloration) *) ignore format; (* TODO Check if this work *) let nodes = Js.array [| view##.state##.schema##text (Jstr.of_string content) Js.null |] in let fragment = PM.Model.Fragment.from_array pm nodes in let node = view##.state##.schema##node (Jstr.v "code_block") Js.null (Js.some fragment) Js.null in Some node | Html_block (_, _) | Definition_list (_, _) -> Brr.Console.(log [ Jstr.v "Other block" ]); None let parse : Prosemirror.View.editor_view Js.t -> PM.t -> Omd.doc -> Prosemirror.Model.node Js.t = fun view pm doc -> Brr.Console.(log [ doc ]); (* Transform each node inside the markdown document and add them into the root node *) let nodes = doc |> List.filter_map ~f:(fun b -> parse_block view pm b) |> Array.of_list |> Js.array in let fragment = PM.Model.Fragment.from_array pm nodes in let document = view##.state##.schema##node (Jstr.v "doc") Js.null (Js.some fragment) Js.null in Brr.Console.(log [ document ]); document let update : t -> State.t -> State.t = fun (pm, doc) state -> let _ = parse state.State.view pm doc in state end