Markdown to ocamldoc conversion for documentation comments

src/reason-parser/dune

@@ -5,13 +5,15 @@
 
 (rule
  (targets ocaml_util.ml)
- (deps ../generate/select.exe ocaml_util.ml-4.10 ocaml_util.ml-4.09 ocaml_util.ml-4.08
-   ocaml_util.ml-4.07 ocaml_util.ml-4.06 ocaml_util.ml-default)
+ (deps ../generate/select.exe ocaml_util.ml-4.10 ocaml_util.ml-4.09
+   ocaml_util.ml-4.08 ocaml_util.ml-4.07 ocaml_util.ml-4.06
+   ocaml_util.ml-default)
  (action
   (with-stdout-to
    %{targets}
-   (run ../generate/select.exe ocaml_util.ml-4.10 ocaml_util.ml-4.09 ocaml_util.ml-4.08
-     ocaml_util.ml-4.07 ocaml_util.ml-4.06 ocaml_util.ml-default))))
+   (run ../generate/select.exe ocaml_util.ml-4.10 ocaml_util.ml-4.09
+     ocaml_util.ml-4.08 ocaml_util.ml-4.07 ocaml_util.ml-4.06
+     ocaml_util.ml-default))))
 
 (rule
  (targets reason_string.ml)
@@ -95,4 +97,4 @@
    reason_recover_parser reason_declarative_lexer reason_lexer reason_oprint
    reason_parser_explain_raw reason_parser_explain reason_parser_recover
    reason_string)
- (libraries ocaml-migrate-parsetree menhirLib reason.easy_format))
+ (libraries ocaml-migrate-parsetree menhirLib reason.easy_format reason.omd))

src/reason-parser/reason_attributes.ml

@@ -33,7 +33,7 @@ let rec partitionAttributes ?(partDoc=false) ?(allowUncurry=true) attrs : attrib
   | ({ attr_name = {txt="ocaml.text"}; _} as doc)::atTl when partDoc = true ->
     let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
     {partition with docAttrs=doc::partition.docAttrs}
-  | ({ attr_name = {txt="ocaml.doc"}; _} as doc)::atTl when partDoc = true ->
+  | ({ attr_name = {txt="ocaml.doc" | "ocaml.text"}; _} as doc)::atTl when partDoc = true ->
     let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
     {partition with docAttrs=doc::partition.docAttrs}
   | ({ attr_name = {txt="reason.raw_literal"}; _} as attr) :: atTl ->

src/reason-parser/reason_parser.mly

@@ -140,6 +140,11 @@ module Clflags = Reason_syntax_util.Clflags
 
 *)
 
+let make_floating_doc = function
+  | {attr_name = {txt = "ocaml.doc"; _} as attr_name; _} as attr ->
+      {attr with attr_name = {attr_name with txt = "ocaml.text"}}
+  | attr -> attr
+
 let uncurry_payload ?(name="bs") loc =
   { attr_name = {loc; txt = name};
     attr_payload = PStr [];
@@ -986,7 +991,7 @@ let mkBsObjTypeSugar ~loc ~closed rows =
 
 let doc_loc loc = {txt = "ocaml.doc"; loc = loc}
 
-let doc_attr text loc =
+let doc_attr_item text loc =
   let open Parsetree in
   let exp =
     { pexp_desc = Pexp_constant (Pconst_string(text, None));
@@ -995,12 +1000,16 @@ let doc_attr text loc =
       pexp_loc_stack = [];
     }
   in
-  let item =
-    { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc }
-  in
+  { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc }
+
+let doc_attr text loc =
+  let open Parsetree in
+  let markdown_text = (Omd.to_ocamldoc (Omd.of_string text)) in
+  let ocamldoc_item = doc_attr_item text loc in
+  let markdown_item = doc_attr_item markdown_text loc in
   {
     attr_name = doc_loc loc;
-    attr_payload = PStr [item];
+    attr_payload = PStr [ocamldoc_item; markdown_item];
     attr_loc = loc
   }
 
@@ -1728,8 +1737,12 @@ structure_item:
     | let_bindings
       { val_of_let_bindings $1 }
     ) { [$1] }
- | located_attributes
-   { List.map (fun x -> mkstr ~loc:x.loc (Pstr_attribute x.txt)) $1 }
+   | located_attributes
+     {
+       List.map
+        (fun x -> mkstr ~loc:x.loc (Pstr_attribute (make_floating_doc x.txt)))
+        $1
+     }
 ;
 
 module_binding_body:
@@ -1949,7 +1962,9 @@ signature_item:
 signature_items:
   | as_loc(signature_item) { [mksig ~loc:$1.loc $1.txt] }
   | located_attributes
-    { List.map (fun x -> mksig ~loc:x.loc (Psig_attribute x.txt)) $1 }
+    { List.map
+      (fun x -> mksig ~loc:x.loc (Psig_attribute (make_floating_doc x.txt)))
+      $1 }
 ;
 
 open_declaration:
@@ -2109,7 +2124,9 @@ class_field:
       { mkcf_attrs (Pcf_extension $2) $1 }
     ) { [$1] }
   | located_attributes
-    { List.map (fun x -> mkcf ~loc:x.loc (Pcf_attribute x.txt)) $1 }
+    { List.map
+      (fun x -> mkcf ~loc:x.loc (Pcf_attribute (make_floating_doc x.txt)))
+      $1 }
 ;
 
 value:
@@ -2373,7 +2390,9 @@ class_sig_field:
       { mkctf_attrs (Pctf_extension $2) $1 }
     ) { [$1] }
   | located_attributes
-    { List.map (fun x -> mkctf ~loc:x.loc (Pctf_attribute x.txt)) $1 }
+    { List.map
+      (fun x -> mkctf ~loc:x.loc (Pctf_attribute (make_floating_doc x.txt)))
+      $1 }
 ;
 
 value_type:
@@ -4916,7 +4935,14 @@ attribute:
         attr_loc = mklocation $symbolstartpos $endpos
       }
     }
-  | DOCSTRING { doc_attr $1 (mklocation $symbolstartpos $endpos) }
+  | DOCSTRING {
+    (* Here is where we will make another copy of doc_attr but with
+     * reason.doc/text instead of ocaml.doc/text and _that_ is the one that the
+     * printer should pay attention to, completely ignoring the ocaml.doc/text
+     * ones.  The ocaml.doc/text ones would only be received by odoc. *)
+     (* doc_attr (Omd.to_ocamldoc Omd.of_string ($1)) (mklocation $symbolstartpos $endpos) :: *)
+      doc_attr $1 (mklocation $symbolstartpos $endpos)
+    }
 ;
 
 (* Inlined to avoid having to deal with buggy $symbolstartpos *)

src/reason-parser/reason_pprint_ast.ml

@@ -6536,6 +6536,15 @@ let printer = object(self:'self)
 
   (* [@ ...] Simple attributes *)
   method attribute = function
+    (*
+      In case there are two entries in the AST, use the second one because that
+      is the markdown text, and ignore the converted ocamldoc text.
+    *)
+    | { attr_name = { Location. txt = ("ocaml.doc" | "ocaml.text") }
+      ; attr_payload =
+          PStr [_;{ pstr_desc = Pstr_eval ({ pexp_desc = Pexp_constant (Pconst_string(text, None)) } , _);
+                  pstr_loc }]
+      ; _ }
     | { attr_name = { Location. txt = ("ocaml.doc" | "ocaml.text") }
       ; attr_payload =
           PStr [{ pstr_desc = Pstr_eval ({ pexp_desc = Pexp_constant (Pconst_string(text, None)) } , _);

src/reason-parser/vendor/omd/.gitignore

@@ -0,0 +1,3 @@
+_build/
+.merlin
+*.install

src/reason-parser/vendor/omd/VERSION

@@ -0,0 +1,2 @@
+@jfrolich/omd
+f11da5aedf56b25dde528cfe0be54f99e6f58921

src/reason-parser/vendor/omd/src/ast.ml

@@ -0,0 +1,119 @@
+type attributes =
+  (string * string) list
+
+type 'a link_def =
+  {
+    label: 'a;
+    destination: string;
+    title: string option;
+  }
+
+type list_type =
+  | Ordered of int * char
+  | Bullet of char
+
+type list_spacing =
+  | Loose
+  | Tight
+
+let same_block_list_kind k1 k2 =
+  match k1, k2 with
+  | Ordered (_, c1), Ordered (_, c2)
+  | Bullet c1, Bullet c2 -> c1 = c2
+  | _ -> false
+
+module type T = sig
+  type t
+end
+
+module MakeBlock (I : T) = struct
+  type def_elt =
+    {
+      term: I.t;
+      defs: I.t list;
+    }
+
+  and block =
+    {
+      bl_desc: block_desc;
+      bl_attributes: attributes;
+    }
+
+  and block_desc =
+    | Paragraph of I.t
+    | List of list_type * list_spacing * block list list
+    | Blockquote of block list
+    | Thematic_break
+    | Heading of int * I.t
+    | Code_block of string * string
+    | Html_block of string
+    | Link_def of string link_def
+    | Definition_list of def_elt list
+
+  let defs ast =
+    let rec loop acc {bl_desc; bl_attributes} =
+      match bl_desc with
+      | List (_, _, bls) -> List.fold_left (List.fold_left loop) acc bls
+      | Blockquote l -> List.fold_left loop acc l
+      | Paragraph _ | Thematic_break | Heading _
+      | Definition_list _ | Code_block _ | Html_block _ -> acc
+      | Link_def def -> (def, bl_attributes) :: acc
+    in
+    List.rev (List.fold_left loop [] ast)
+end
+
+type inline =
+  {
+    il_desc: inline_desc;
+    il_attributes: attributes;
+  }
+
+and inline_desc =
+  | Concat of inline list
+  | Text of string
+  | Emph of inline
+  | Strong of inline
+  | Code of string
+  | Hard_break
+  | Soft_break
+  | Link of inline link_def
+  | Image of inline link_def
+  | Html of string
+
+module Raw = MakeBlock (String)
+
+module Inline = struct type t = inline end
+
+include MakeBlock (Inline)
+
+module MakeMapper (Src : T) (Dst : T) = struct
+  module SrcBlock = MakeBlock(Src)
+  module DstBlock = MakeBlock(Dst)
+
+  let rec map (f : Src.t -> Dst.t) : SrcBlock.block -> DstBlock.block =
+    fun {bl_desc; bl_attributes} ->
+    let bl_desc =
+      match bl_desc with
+      | SrcBlock.Paragraph x -> DstBlock.Paragraph (f x)
+      | List (ty, sp, bl) ->
+          List (ty, sp, List.map (List.map (map f)) bl)
+      | Blockquote xs ->
+          Blockquote (List.map (map f) xs)
+      | Thematic_break ->
+          Thematic_break
+      | Heading (level, text) ->
+          Heading (level, f text)
+      | Definition_list l ->
+          let f {SrcBlock.term; defs} = {DstBlock.term = f term; defs = List.map f defs} in
+          Definition_list (List.map f l)
+      | Code_block (label, code) ->
+          Code_block (label, code)
+      | Html_block x ->
+          Html_block x
+      | Link_def x ->
+          Link_def x
+    in
+    {bl_desc; bl_attributes}
+end
+
+module Mapper = MakeMapper (String) (Inline)