From da1d9ad1c49f31fc9031fd1bc6661dad3600e40c Mon Sep 17 00:00:00 2001
From: Sébastien Dailly <sebastien@chimrod.com>
Date: Fri, 4 Jun 2021 22:56:27 +0200
Subject: Added markdown output

---
 editor/actions/to_markdown.ml | 294 ++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 294 insertions(+)
 create mode 100755 editor/actions/to_markdown.ml

(limited to 'editor/actions/to_markdown.ml')

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 ))
-- 
cgit v1.2.3