Markdown backend: complete initial impl. Verified: frames and optiona…

…lly foldable trees

Currently, multiline preformatted content as separate inline code markers. Will consider using code blocks...

dune-project

@@ -35,3 +35,14 @@ Printbox allows to print nested boxes, lists, arrays, tables in several formats"
            (odoc :with-test)
            (tyxml (>= 4.3))
            (mdx (and (>= 1.4) :with-test))))
+
+(package
+  (name printbox-md)
+(synopsis "Printbox Markdown rendering")
+(description "
+Adds Markdown output handling to the printbox package, with fallback to text and simplified HTML.
+Printbox allows to print nested boxes, lists, arrays, tables in several formats")
+  (depends (printbox (= :version))
+           (printbox-text (and (= :version) :with-test))
+           (odoc :with-test)
+           (mdx (and (>= 1.4) :with-test))))

printbox-md.opam

@@ -0,0 +1,36 @@
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+version: "0.8"
+synopsis: "Printbox Markdown rendering"
+description: """
+
+Adds Markdown output handling to the printbox package, with fallback to text and simplified HTML.
+Printbox allows to print nested boxes, lists, arrays, tables in several formats"""
+maintainer: ["c-cube"]
+authors: ["Simon Cruanes" "Guillaume Bury"]
+license: "BSD-2-Clause"
+homepage: "https://github.com/c-cube/printbox"
+bug-reports: "https://github.com/c-cube/printbox/issues"
+depends: [
+  "dune" {>= "3.0"}
+  "printbox" {= version}
+  "printbox-text" {= version & with-test}
+  "odoc" {with-test}
+  "mdx" {>= "1.4" & with-test}
+  "odoc" {with-doc}
+]
+build: [
+  ["dune" "subst"] {dev}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "@install"
+    "@runtest" {with-test}
+    "@doc" {with-doc}
+  ]
+]
+dev-repo: "git+https://github.com/c-cube/printbox.git"

src/printbox-html/PrintBox_html.ml

@@ -170,6 +170,12 @@ let to_html ?(config=Config.default) b = H.div [to_html_rec ~config b]
 let to_string ?config b =
   Format.asprintf "@[%a@]@." (H.pp_elt ()) (to_html ?config b)
 
+let to_string_indent ?config b =
+  Format.asprintf "@[%a@]@." (H.pp_elt ~indent:true ()) (to_html ?config b)
+
+let pp ?config ?indent () pp b =
+    Format.fprintf pp "@[%a@]@." (H.pp_elt ?indent ()) (to_html ?config b)
+
 let to_string_doc ?config b =
   let meta_str = "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\">" in
   let footer_str =

src/printbox-html/PrintBox_html.mli

@@ -37,7 +37,11 @@ end
 val to_html : ?config:Config.t -> PrintBox.t -> [`Div] html
 (** HTML for one box *)
 
+val pp : ?config:Config.t -> ?indent:bool -> unit -> Format.formatter -> PrintBox.t -> unit
+
 val to_string : ?config:Config.t -> PrintBox.t -> string
 
+val to_string_indent : ?config:Config.t -> PrintBox.t -> string
+
 val to_string_doc : ?config:Config.t -> PrintBox.t -> string
 (** Same as {!to_string}, but adds the prelude and some footer *)

src/printbox-md/PrintBox_md.ml

@@ -0,0 +1,179 @@
+(* This file is free software. See file "license" for more details. *)
+
+module B = PrintBox
+
+(* This is a bare-bones implementation that will hopefully evolve over time. *)
+(* 
+let to_md_rec ~tables ~trees (b: B.t) =
+  let text_to_md ?(border=false) ~l ~style () =
+    let a, bold = attrs_of_style style in
+    let l = List.map H.txt l in
+    let l = if bold then List.map (fun x->H.b [x]) l else l in
+    let a_border = if border then [H.a_style  "border:thin solid"] else [] in
+    H.span ~a:(H.a_class config.cls_text :: a_border @ (a @ config.a_text)) l in
+  let loop :
+    'tags. (B.t -> ([< Html_types.flow5 > `Pre `Span `Div `Ul `Table `P] as 'tags) html) -> B.t -> 'tags html =
+    fun fix b ->
+      match B.view b with
+      | B.Empty -> (H.div [] :> [< Html_types.flow5 > `Pre `Span `Div `P `Table `Ul ] html)
+      | B.Text {l; style} when style.B.Style.preformatted -> H.pre [text_to_md ~l ~style ()]
+      | B.Text {l; style} -> text_to_md ~l ~style ()
+      | B.Pad (_, b) -> fix b
+      | B.Frame b ->
+         H.div ~a:[H.a_style "border:thin solid"] [ fix b ]
+      | B.Align {h=`Right;inner=b;v=_} ->
+        H.div ~a:[H.a_class ["align-right"]] [ fix b ]
+      | B.Align {h=`Center;inner=b;v=_} ->
+        H.div ~a:[H.a_class ["center"]] [ fix b ]
+      | B.Align {inner=b;_} -> fix b
+      | B.Grid (bars, a) ->
+        let class_ = match bars with
+          | `Bars -> "framed"
+          | `None -> "non-framed"
+        in
+        let to_row a =
+          Array.to_list a
+          |> List.map
+            (fun b -> H.td ~a:(H.a_class config.cls_col :: config.a_col) [fix b])
+          |> (fun x -> H.tr ~a:(H.a_class config.cls_row :: config.a_row) x)
+        in
+        let rows =
+          Array.to_list a |> List.map to_row
+        in
+        H.table ~a:(H.a_class (class_ :: config.cls_table)::config.a_table) rows
+      | B.Tree (_, b, l) ->
+        let l = Array.to_list l in
+        H.div
+          [ fix b
+          ; H.ul (List.map (fun x -> H.li [fix x]) l)
+          ]
+      | B.Link _ -> assert false
+  in
+  let rec to_md_rec b =
+    match B.view b with
+    | B.Tree (_, b, l) when config.tree_summary ->
+      let l = Array.to_list l in
+      (match B.view b with
+      | B.Text {l=tl; style} ->
+        H.details (H.summary [text_to_md ~l:tl ~style ()])
+        [ H.ul (List.map (fun x -> H.li [to_md_rec x]) l) ]
+      | B.Frame b ->
+        (match B.view b with
+        | (B.Text {l=tl; style}) ->
+          H.details (H.summary [text_to_md ~border:true ~l:tl ~style ()])
+            [ H.ul (List.map (fun x -> H.li [to_md_rec x]) l) ]
+        | _ ->
+          H.div
+            [ to_md_rec b
+            ; H.ul (List.map (fun x -> H.li [to_md_rec x]) l)
+            ])
+      | _ ->
+        H.div
+          [ to_md_rec b
+          ; H.ul (List.map (fun x -> H.li [to_md_rec x]) l)
+          ])
+    | B.Link {uri; inner} ->
+      H.div [H.a ~a:[H.a_href uri] [to_md_nondet_rec inner]]
+    | _ -> loop to_md_rec b
+  and to_md_nondet_rec b =
+    match B.view b with
+    | B.Link {uri; inner} ->
+      H.div [H.a ~a:[H.a_href uri] [to_md_nondet_rec inner]]
+    | _ -> loop to_md_nondet_rec b
+  in
+  to_md_rec b
+ *)
+
+ let style_format (s:B.Style.t) =
+  let open B.Style in
+  let {bold = _; bg_color; fg_color; preformatted = _} = s in
+  let encode_color = function
+    | Red -> "red"
+    | Blue -> "blue"
+    | Green -> "green"
+    | Yellow -> "yellow"
+    | Cyan -> "cyan"
+    | Black -> "black"
+    | Magenta -> "magenta"
+    | White -> "white"
+  in
+  let s =
+    (match bg_color with None -> [] | Some c -> ["background-color", encode_color c]) @
+    (match fg_color with None -> [] | Some c -> ["color", encode_color c])
+  in
+  match s with
+    | [] -> "", ""
+    | s ->
+      {|<span style="|} ^ String.concat ";" (List.map (fun (k,v) -> k ^ ": " ^ v) s) ^ {|">|}, "</span>"
+
+let pp ~tables ~foldable_trees out b =
+  let open Format in
+  (* We cannot use Format for indentation, because we need to insert ">" at the right places. *)
+  let rec loop ~inline ~prefix b =
+    match B.view b with
+    | B.Empty -> ()
+    | B.Text {l; style} ->
+      let sty_pre, sty_post = style_format style in
+      pp_print_string out sty_pre;
+      (* use html for gb_color, fg_color and md for bold, preformatted. *)
+      pp_print_list
+        ~pp_sep:(fun out () ->
+           pp_print_string out "<br>"; pp_print_cut out (); pp_print_string out prefix)
+        (fun out s ->
+          let s = if style.B.Style.preformatted then String.concat "" ["`"; s; "`"] else s in
+          let s = if style.B.Style.bold then String.concat "" ["**"; s; "**"] else s in
+          pp_print_string out s
+        ) out l;
+        pp_print_string out sty_post
+    | B.Frame b ->
+      if inline then
+        fprintf out {|<span style="border:thin solid">%a</span>|}
+          (fun _out -> loop ~inline ~prefix) b
+      else fprintf out "> %a" (fun _out -> loop ~inline ~prefix:(prefix ^ "> ")) b
+    | B.Pad (_, b) -> 
+      (* NOT IMPLEMENTED YET *)
+      loop ~inline ~prefix b
+    | B.Align {h = _; v=_; inner} ->
+      (* NOT IMPLEMENTED YET *)
+      loop ~inline ~prefix inner
+    | B.Grid (_, _) when tables = `Html && String.length prefix = 0 ->
+      PrintBox_html.pp ~indent:(not inline) () out b
+    | B.Grid (_, _) ->
+      let table =
+        if tables = `Text then PrintBox_text.to_string b
+        else PrintBox_html.(if inline then to_string else to_string_indent) b in
+      let lines = String.split_on_char '\n' table in
+      let lines =
+         List.map (fun s ->
+           if s.[String.length s - 1] = '\r'
+           then String.sub s 0 (String.length s - 1) else s) lines in
+      pp_print_list
+        ~pp_sep:(fun out () ->
+           pp_print_string out "<br>"; 
+           if not inline then fprintf out "@,%s" prefix)
+        pp_print_string out lines
+    | B.Tree (_extra_indent, header, [||]) ->
+      loop ~inline ~prefix header
+    | B.Tree (extra_indent, header, body) ->
+      if foldable_trees
+      then
+        fprintf out "<details><summary>%a</summary>@,%s@,%s- "
+          (fun _out -> loop ~inline:true ~prefix) header prefix prefix
+      else (loop ~inline ~prefix header; fprintf out "@,%s- " prefix);
+      let pp_sep out () = fprintf out "@,%s- " prefix in
+      let subprefix = prefix ^ String.make (2 + extra_indent) ' ' in
+      pp_print_list
+        ~pp_sep
+        (fun _out sub -> loop ~inline ~prefix:subprefix sub)
+        out @@ Array.to_list body;
+      if foldable_trees then fprintf out "@,%s</details>" prefix
+    | B.Link {uri; inner} ->
+      pp_print_string out "[";
+      loop ~inline:true ~prefix:(prefix ^ " ") inner;
+      fprintf out "](%s)" uri in
+  pp_open_vbox out 0;
+  loop ~inline:false ~prefix:"" b;
+  pp_close_box out ()
+
+let to_string ~tables ~foldable_trees b =
+  Format.asprintf "%a@." (pp ~tables ~foldable_trees) b

src/printbox-md/PrintBox_md.mli

@@ -0,0 +1,6 @@
+val pp :
+  tables:[`Text | `Html] -> foldable_trees:bool -> Format.formatter ->
+    PrintBox.t -> unit
+
+val to_string :
+  tables:[`Text | `Html] -> foldable_trees:bool -> PrintBox.t -> string

src/printbox-md/dune

@@ -0,0 +1,6 @@
+(library
+ (name printbox_md)
+ (public_name printbox-md)
+ (wrapped false)
+ (flags :standard -w +a-3-4-44-29 -safe-string)
+ (libraries printbox printbox-text printbox-html))

src/printbox-md/playground.md

@@ -0,0 +1,74 @@
+
+
+
+|             |       |          |
+|-------------|-------|----------|
+|             | min   | -89.2 °C |
+| Temperature |       |          |
+| 1961-1990   | mean  | 14 °C    |
+|             | min   | 56.7 °C  |
+
+
+> trying
+> > nested
+> > > quoatation
+
+**`bold code`**<br>
+`code`
+
+> List 1:
+> - Element 1
+>   second line of element 1
+> - Element 2
+>   - Subelement 3
+>   - Subelement 4
+>     > Some<br>
+>     > more
+>     > <details><summary>Header 5</summary>
+>     >
+>     > - Subelem 6
+>     > - Subelem 7
+>     > </details>
+
+Framed fold:
+
+> <details><summary>List 2:</summary>
+>
+> - Element 1<br>
+>   second line of element 1
+> - Element 2
+>   - Subelement 3
+>   - Subelement 4
+>     > Some<br>
+>     > more
+>     > <details><summary>Header 5</summary>
+>     > 
+>     > - Subelem 6
+>     > - Subelem 7
+>     > </details>
+> </details>
+
+
+> <details><summary>List 3:</summary>
+>
+> - Element 1
+>   second line of element 1
+> - Element 2<ul>
+>   <li>Subelement 3</li>
+>   <li>Subelement 4
+>     >
+>     > Some<br>
+>     > more
+>     > <details><summary>Header 5</summary>
+>     >
+>     > - Subelem 6
+>     > - Subelem 7
+>     > </details></li>
+>   </ul>
+> </details>
+
+
+<details>
+> <summary> List 4: </summary>
+
+</details>

test/dune

@@ -26,3 +26,9 @@
  (modules test_html)
  (package printbox-html)
  (libraries printbox printbox-html))
+
+(test
+ (name test_md)
+ (modules test_md)
+ (package printbox-md)
+ (libraries printbox printbox-md))