Markdown -> Ocamldoc conversion

src/compat.ml

@@ -0,0 +1,32 @@
+module Uchar = struct
+  include Uchar
+  let rep: Uchar.t = Obj.magic(0xFFFD)
+end
+
+module List = struct
+  include List
+  let rec find_opt p = function
+  | [] -> None
+  | x :: l -> if p x then Some x else find_opt p l
+end
+
+module Buffer = struct
+  include Buffer
+  let add_utf_8_uchar b u = match Uchar.to_int u with
+  | u when u < 0 -> assert false
+  | u when u <= 0x007F ->
+      Buffer.add_char b (Char.unsafe_chr u)
+  | u when u <= 0x07FF ->
+      Buffer.add_char b (Char.unsafe_chr (0xC0 lor (u lsr 6)));
+      Buffer.add_char b (Char.unsafe_chr (0x80 lor (u land 0x3F)))
+  | u when u <= 0xFFFF ->
+      Buffer.add_char b (Char.unsafe_chr (0xE0 lor (u lsr 12)));
+      Buffer.add_char b (Char.unsafe_chr (0x80 lor ((u lsr 6) land 0x3F)));
+      Buffer.add_char b (Char.unsafe_chr (0x80 lor (u land 0x3F)))
+  | u when u <= 0x10FFFF ->
+      Buffer.add_char b (Char.unsafe_chr (0xF0 lor (u lsr 18)));
+      Buffer.add_char b (Char.unsafe_chr (0x80 lor ((u lsr 12) land 0x3F)));
+      Buffer.add_char b (Char.unsafe_chr (0x80 lor ((u lsr 6) land 0x3F)));
+      Buffer.add_char b (Char.unsafe_chr (0x80 lor (u land 0x3F)))
+    | _ -> assert false
+end

src/dune

@@ -1,10 +1,12 @@
 (library
  (name omd)
+ (libraries str)
  (public_name omd)
  (flags :standard -w -30))
 
-
 (rule
  (with-stdout-to
   entities.ml
-  (chdir ../tools (run ./gen_entities.exe %{dep:../tools/entities.json}))))
+  (chdir
+   ../tools
+   (run ./gen_entities.exe %{dep:../tools/entities.json}))))

src/ocamldoc.ml

@@ -0,0 +1,151 @@
+open Ast
+
+type t =
+  | TripleSurround of string * t * string * t * string
+  | Surround of string * t * string
+  | BlockSurround of string * t * string
+  | GeneralBlock of t
+  | Text of string
+  | Raw of string
+  | Null
+  | Concat of t * t
+
+let nl = Raw "\n"
+
+let escape_uri s =
+  let b = Buffer.create (String.length s) in
+  String.iter (function
+      | '!' | '*' | '\'' | '(' | ')' | ';' | ':'
+      | '@' | '=' | '+' | '$' | ',' | '/' | '?' | '%'
+      | '#' | 'A'..'Z' | 'a'..'z' | '0'..'9' | '-' | '_' | '.' | '~' as c ->
+          Buffer.add_char b c
+      | '&' ->
+          Buffer.add_string b "&"
+      | _ as c ->
+          Printf.bprintf b "%%%2X" (Char.code c)
+    ) s;
+  Buffer.contents b
+
+let to_plain_text t =
+  let buf = Buffer.create 1024 in
+  let rec go = function
+    | Text t -> Buffer.add_string buf t
+    | Concat (t1, t2) -> go t1; go t2
+    | _ -> ()
+  in
+  go t;
+  Buffer.contents buf
+
+let rec add_to_buffer buf = function
+  | TripleSurround (s1, t1, s2, t2, s3) ->
+    Printf.bprintf buf "%s%a%s%a%s" s1 add_to_buffer t1 s2 add_to_buffer t2 s3
+  | Surround (s1, t1, s2) -> Printf.bprintf buf "%s%a%s" s1 add_to_buffer t1 s2
+  | BlockSurround (s1, t1, s2) -> Printf.bprintf buf "\n\b%s%a%s\n" s1 add_to_buffer t1 s2
+  | GeneralBlock (t) -> Printf.bprintf buf "\n%a\n" add_to_buffer t
+  | Text s -> Buffer.add_string buf s
+  | Raw s -> Buffer.add_string buf s
+  | Null -> ()
+  | Concat (t1, t2) ->
+    add_to_buffer buf t1;
+    add_to_buffer buf t2
+
+let text s = Text s
+let raw s = Raw s
+let concat s1 s2 = match (s1, s2) with
+  | Null, s
+  | s, Null -> s
+  | s1, s2 -> Concat(s1, s2)
+
+let concat_map f l =
+  List.fold_left (fun accu x -> concat accu (f x)) Null l
+
+let cross_reference_words = [
+  "module";
+  "modtype";
+  "class";
+  "classtype";
+  "val";
+  "type";
+  "exception";
+  "attribute";
+  "method";
+  "section";
+  "const";
+  "recfield";
+]
+
+let is_cross_reference_regexps = cross_reference_words |> List.map(fun w -> (Str.regexp_string (w ^ ":")))
+let inferred_cross_reference = Str.regexp_string("ref:")
+
+let rec inline {il_desc; il_attributes = _} =
+  match il_desc with
+  | Concat l -> concat_map inline l
+  | Text s -> text s
+  | Emph il -> Surround ("{e ", inline il, "}")
+  | Strong il -> Surround ("{b ", inline il, "}")
+  | Code s -> Surround ("[", text s, "]")
+  | Hard_break -> text "\n\n"
+  | Soft_break -> text "\n"
+  | Html body -> Surround ("{%html: ", (text body), "%}")
+  | Link {label; destination; title = _} ->
+    let cross_reference = match label with
+      | {il_desc = Text s; _} when s == destination ->
+        if (Str.string_match inferred_cross_reference destination 0) then
+          Some(Str.string_after destination 4)
+        else
+          if List.exists (fun r -> Str.string_match r destination 0) is_cross_reference_regexps then Some(destination) else None
+      | _ ->
+        None in
+    (
+      match cross_reference with
+      | Some(cross_reference) ->
+        Surround("{!", (text cross_reference), "}")
+      | None ->
+        TripleSurround("{{: ", (text destination), "} ", inline label, "}")
+    )
+  | Image {label; destination; title} ->
+      let img = "<img src=\"" ^ escape_uri(destination) ^ "\" alt=\"" ^ (to_plain_text (inline label)) ^ "\"" ^ (match title with
+      | None -> ""
+      | Some title -> " title=\"" ^ title ^ "\"") ^ "/>" in
+      Surround ("{%html: ", text img, "%}")
+
+
+let rec block {bl_desc; bl_attributes = _attr} =
+  match bl_desc with
+  | Blockquote q -> BlockSurround("{v ", (concat_map block q), "v}")
+  | Paragraph md -> GeneralBlock(inline md)
+  | List (ty, sp, bl) ->
+      let sign = match ty with Ordered _ -> "+ " | Bullet _ -> "- " in
+      let li t =
+        let block' t =
+          match t.bl_desc, sp with
+          | Paragraph t, Tight -> concat (inline t) nl
+          | _ -> block t
+        in
+        let nl = if sp = Tight then Null else nl in
+        Surround (sign, concat nl (concat_map block' t), "") in
+      concat nl (concat_map li bl)
+  | Code_block (_label, code) ->
+    BlockSurround("{[\n", text code, "]}")
+  | Thematic_break -> GeneralBlock(text "***")
+  | Html_block body -> raw body
+  | Heading(level, text) ->
+    BlockSurround("{" ^ (
+      match level with
+        | 1 -> "0"
+        | 2 -> "1"
+        | 3 -> "2"
+        | 4 -> "3"
+        | 5 -> "4"
+        | _ -> "5"
+      ) ^ " ", inline text, "}")
+  | Definition_list _ -> Null
+  | Link_def _ -> Null
+
+let of_doc doc =
+  concat_map block doc
+
+let to_string t =
+  let buf = Buffer.create 1024 in
+  add_to_buffer buf t;
+  Buffer.contents buf;

src/ocamldoc.mli

@@ -0,0 +1,15 @@
+open Ast
+
+type t =
+  | TripleSurround of string * t * string * t * string
+  | Surround of string * t * string
+  | BlockSurround of string * t * string
+  | GeneralBlock of t
+  | Text of string
+  | Raw of string
+  | Null
+  | Concat of t * t
+
+val of_doc: block list -> t
+
+val to_string : t -> string

src/omd.ml

@@ -27,3 +27,6 @@ let to_html doc =
 
 let to_sexp ast =
   Format.asprintf "@[%a@]@." Sexp.print (Sexp.create ast)
+
+let to_ocamldoc doc =
+  Ocamldoc.to_string (Ocamldoc.of_doc doc)

src/omd.mli

@@ -69,3 +69,5 @@ val of_string: string -> doc
 val to_html: doc -> string
 
 val to_sexp: doc -> string
+
+val to_ocamldoc: doc -> string

src/parser.ml

@@ -1,4 +1,5 @@
 open Ast
+open Compat
 
 module Sub : sig
   type t

tests/dune

@@ -4,7 +4,9 @@
  (modules extract_tests))
 
 (rule
- (with-stdout-to dune.inc.new (run ./extract_tests.exe -write-dune-file)))
+ (with-stdout-to
+  dune.inc.new
+  (run ./extract_tests.exe -write-dune-file)))
 
 (include dune.inc)
 
@@ -13,6 +15,12 @@
  (libraries str omd)
  (modules omd))
 
+(executable
+ (name omd_ocamldoc)
+ (libraries str omd)
+ (modules omd_ocamldoc))
+
 (rule
  (alias gen)
- (action (diff dune.inc dune.inc.new)))
+ (action
+  (diff dune.inc dune.inc.new)))

tests/extract_tests.ml

@@ -26,13 +26,17 @@ let disabled =
 
 let with_open_in fn f =
   let ic = open_in fn in
-  Fun.protect ~finally:(fun () -> close_in_noerr ic)
-    (fun () -> f ic)
+  let result = f ic in
+  close_in_noerr ic;
+  result
+
+
 
 let with_open_out fn f =
   let oc = open_out fn in
-  Fun.protect ~finally:(fun () -> close_out_noerr oc)
-    (fun () -> f oc)
+  let result = f oc in
+  close_out oc;
+  result
 
 let begins_with s s' =
   String.length s >= String.length s' &&

tests/omd.ml

@@ -7,8 +7,9 @@ let normalize_html s =
 
 let with_open_in fn f =
   let ic = open_in fn in
-  Fun.protect ~finally:(fun () -> close_in_noerr ic)
-    (fun () -> f ic)
+  let result = f ic in
+  close_in_noerr ic;
+  result
 
 let () =
   with_open_in Sys.argv.(1) @@ fun ic ->

tests/omd_ocamldoc.ml

@@ -0,0 +1,9 @@
+let with_open_in fn f =
+  let ic = open_in fn in
+  let result = f ic in
+  close_in_noerr ic;
+  result
+
+let () =
+  with_open_in Sys.argv.(1) @@ fun ic ->
+  print_string (Omd.to_ocamldoc (Omd.of_channel ic))