Experimental command to format code blocks embedded in docstrings

CHANGELOG.md

@@ -12,6 +12,10 @@
 
 # 12.0.0-beta.1 (Unreleased)
 
+#### :rocket: New Feature
+
+- Add experimental command to `rescript-tools` for formatting all ReScript code blocks in markdown. Either in a markdown file directly, or inside of docstrings in ReScript code. https://github.com/rescript-lang/rescript/pull/7598
+
 # 12.0.0-alpha.15
 
 #### :boom: Breaking Change

analysis/src/Commands.ml

@@ -282,17 +282,13 @@ let format ~path =
         ~filename:path
     in
     if List.length diagnostics > 0 then ""
-    else
-      Res_printer.print_implementation
-        ~width:Res_multi_printer.default_print_width ~comments structure
+    else Res_printer.print_implementation ~comments structure
   else if Filename.check_suffix path ".resi" then
     let {Res_driver.parsetree = signature; comments; diagnostics} =
       Res_driver.parsing_engine.parse_interface ~for_printer:true ~filename:path
     in
     if List.length diagnostics > 0 then ""
-    else
-      Res_printer.print_interface ~width:Res_multi_printer.default_print_width
-        ~comments signature
+    else Res_printer.print_interface ~comments signature
   else ""
 
 let diagnosticSyntax ~path =

analysis/src/CreateInterface.ml

@@ -102,7 +102,7 @@ let printSignature ~extractor ~signature =
   Printtyp.reset_names ();
   let sigItemToString (item : Outcometree.out_sig_item) =
     item |> Res_outcome_printer.print_out_sig_item_doc
-    |> Res_doc.to_string ~width:Res_multi_printer.default_print_width
+    |> Res_doc.to_string ~width:Res_printer.default_print_width
   in
 
   let genSigStrForInlineAttr lines attributes id vd =

analysis/src/Xform.ml

@@ -855,7 +855,6 @@ let parseImplementation ~filename =
     let structure = [Ast_helper.Str.eval ~loc:expr.pexp_loc expr] in
     structure
     |> Res_printer.print_implementation
-         ~width:Res_multi_printer.default_print_width
          ~comments:(comments |> filterComments ~loc:expr.pexp_loc)
     |> Utils.indent range.start.character
   in
@@ -864,14 +863,12 @@ let parseImplementation ~filename =
     let structure = [item] in
     structure
     |> Res_printer.print_implementation
-         ~width:Res_multi_printer.default_print_width
          ~comments:(comments |> filterComments ~loc:item.pstr_loc)
     |> Utils.indent range.start.character
   in
   let printStandaloneStructure ~(loc : Location.t) structure =
     structure
     |> Res_printer.print_implementation
-         ~width:Res_multi_printer.default_print_width
          ~comments:(comments |> filterComments ~loc)
   in
   (structure, printExpr, printStructureItem, printStandaloneStructure)
@@ -891,7 +888,7 @@ let parseInterface ~filename =
       (item : Parsetree.signature_item) =
     let signature_item = [item] in
     signature_item
-    |> Res_printer.print_interface ~width:Res_multi_printer.default_print_width
+    |> Res_printer.print_interface
          ~comments:(comments |> filterComments ~loc:item.psig_loc)
     |> Utils.indent range.start.character
   in

compiler/ml/location.ml

@@ -231,24 +231,29 @@ let error_of_exn exn =
 
 (* taken from https://github.com/rescript-lang/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/parsing/location.ml#L380 *)
 (* This is the error report entry point. We'll replace the default reporter with this one. *)
-let rec default_error_reporter ?(src = None) ppf {loc; msg; sub} =
+let rec default_error_reporter ?(custom_intro = None) ?(src = None) ppf
+    {loc; msg; sub} =
   setup_colors ();
   (* open a vertical box. Everything in our message is indented 2 spaces *)
   (* If src is given, it will display a syntax error after parsing. *)
   let intro =
-    match src with
-    | Some _ -> "Syntax error!"
-    | None -> "We've found a bug for you!"
+    match (custom_intro, src) with
+    | Some intro, _ -> intro
+    | None, Some _ -> "Syntax error!"
+    | None, None -> "We've found a bug for you!"
   in
   Format.fprintf ppf "@[<v>@,  %a@,  %s@,@]"
     (print ~src ~message_kind:`error intro)
     loc msg;
-  List.iter (Format.fprintf ppf "@,@[%a@]" (default_error_reporter ~src)) sub
+  List.iter
+    (Format.fprintf ppf "@,@[%a@]" (default_error_reporter ~custom_intro ~src))
+    sub
 (* no need to flush here; location's report_exception (which uses this ultimately) flushes *)
 
 let error_reporter = ref default_error_reporter
 
-let report_error ?(src = None) ppf err = !error_reporter ~src ppf err
+let report_error ?(custom_intro = None) ?(src = None) ppf err =
+  !error_reporter ~custom_intro ~src ppf err
 
 let error_of_printer loc print x = errorf ~loc "%a@?" print x
 
@@ -276,7 +281,8 @@ let rec report_exception_rec n ppf exn =
     match error_of_exn exn with
     | None -> reraise exn
     | Some `Already_displayed -> ()
-    | Some (`Ok err) -> fprintf ppf "@[%a@]@." (report_error ~src:None) err
+    | Some (`Ok err) ->
+      fprintf ppf "@[%a@]@." (report_error ~custom_intro:None ~src:None) err
   with exn when n > 0 -> report_exception_rec (n - 1) ppf exn
 
 let report_exception ppf exn = report_exception_rec 5 ppf exn

compiler/ml/location.mli

@@ -103,12 +103,28 @@ val register_error_of_exn : (exn -> error option) -> unit
     a location, a message, and optionally sub-messages (each of them
     being located as well). *)
 
-val report_error : ?src:string option -> formatter -> error -> unit
-
-val error_reporter : (?src:string option -> formatter -> error -> unit) ref
+val report_error :
+  ?custom_intro:string option ->
+  ?src:string option ->
+  formatter ->
+  error ->
+  unit
+
+val error_reporter :
+  (?custom_intro:string option ->
+  ?src:string option ->
+  formatter ->
+  error ->
+  unit)
+  ref
 (** Hook for intercepting error reports. *)
 
-val default_error_reporter : ?src:string option -> formatter -> error -> unit
+val default_error_reporter :
+  ?custom_intro:string option ->
+  ?src:string option ->
+  formatter ->
+  error ->
+  unit
 (** Original error reporter for use in hooks. *)
 
 val report_exception : formatter -> exn -> unit

compiler/syntax/src/res_diagnostics.ml

@@ -131,12 +131,13 @@ let explain t =
 
 let make ~start_pos ~end_pos category = {start_pos; end_pos; category}
 
-let print_report diagnostics src =
+let print_report ?(custom_intro = None) ?(formatter = Format.err_formatter)
+    diagnostics src =
   let rec print diagnostics src =
     match diagnostics with
     | [] -> ()
     | d :: rest ->
-      Location.report_error ~src:(Some src) Format.err_formatter
+      Location.report_error ~custom_intro ~src:(Some src) formatter
         Location.
           {
             loc =
@@ -147,12 +148,12 @@ let print_report diagnostics src =
           };
       (match rest with
       | [] -> ()
-      | _ -> Format.fprintf Format.err_formatter "@.");
+      | _ -> Format.fprintf formatter "@.");
       print rest src
   in
-  Format.fprintf Format.err_formatter "@[<v>";
+  Format.fprintf formatter "@[<v>";
   print (List.rev diagnostics) src;
-  Format.fprintf Format.err_formatter "@]@."
+  Format.fprintf formatter "@]@."
 
 let unexpected token context = Unexpected {token; context}
 

compiler/syntax/src/res_diagnostics.mli

@@ -22,4 +22,9 @@ val message : string -> category
 
 val make : start_pos:Lexing.position -> end_pos:Lexing.position -> category -> t
 
-val print_report : t list -> string -> unit
+val print_report :
+  ?custom_intro:string option ->
+  ?formatter:Format.formatter ->
+  t list ->
+  string ->
+  unit

compiler/syntax/src/res_multi_printer.ml

@@ -1,5 +1,3 @@
-let default_print_width = 100
-
 (* print res files to res syntax *)
 let print_res ~ignore_parse_errors ~is_interface ~filename =
   if is_interface then (
@@ -9,7 +7,7 @@ let print_res ~ignore_parse_errors ~is_interface ~filename =
     if parse_result.invalid then (
       Res_diagnostics.print_report parse_result.diagnostics parse_result.source;
       if not ignore_parse_errors then exit 1);
-    Res_printer.print_interface ~width:default_print_width
+    Res_printer.print_interface ~width:Res_printer.default_print_width
       ~comments:parse_result.comments parse_result.parsetree)
   else
     let parse_result =
@@ -18,7 +16,7 @@ let print_res ~ignore_parse_errors ~is_interface ~filename =
     if parse_result.invalid then (
       Res_diagnostics.print_report parse_result.diagnostics parse_result.source;
       if not ignore_parse_errors then exit 1);
-    Res_printer.print_implementation ~width:default_print_width
+    Res_printer.print_implementation ~width:Res_printer.default_print_width
       ~comments:parse_result.comments parse_result.parsetree
 [@@raises exit]
 

compiler/syntax/src/res_multi_printer.mli

@@ -1,5 +1,3 @@
-val default_print_width : int [@@live]
-
 (* Interface to print source code to res.
  * Takes a filename called "input" and returns the corresponding formatted res syntax *)
 val print : ?ignore_parse_errors:bool -> string -> string [@@dead "+print"]

compiler/syntax/src/res_printer.ml

@@ -5,6 +5,8 @@ module Token = Res_token
 module Parens = Res_parens
 module ParsetreeViewer = Res_parsetree_viewer
 
+let default_print_width = 100
+
 type callback_style =
   (* regular arrow function, example: `let f = x => x + 1` *)
   | NoCallback
@@ -6055,15 +6057,17 @@ let print_typ_expr t = print_typ_expr ~state:(State.init ()) t
 let print_expression e = print_expression ~state:(State.init ()) e
 let print_pattern p = print_pattern ~state:(State.init ()) p
 
-let print_implementation ~width (s : Parsetree.structure) ~comments =
+let print_implementation ?(width = default_print_width)
+    (s : Parsetree.structure) ~comments =
   let cmt_tbl = CommentTable.make () in
   CommentTable.walk_structure s cmt_tbl comments;
   (* CommentTable.log cmt_tbl; *)
   let doc = print_structure ~state:(State.init ()) s cmt_tbl in
   (* Doc.debug doc; *)
   Doc.to_string ~width doc ^ "\n"
 
-let print_interface ~width (s : Parsetree.signature) ~comments =
+let print_interface ?(width = default_print_width) (s : Parsetree.signature)
+    ~comments =
   let cmt_tbl = CommentTable.make () in
   CommentTable.walk_signature s cmt_tbl comments;
   Doc.to_string ~width (print_signature ~state:(State.init ()) s cmt_tbl) ^ "\n"

compiler/syntax/src/res_printer.mli

@@ -1,3 +1,5 @@
+val default_print_width : int
+
 val print_type_params :
   (Parsetree.core_type * Asttypes.variance) list ->
   Res_comments_table.t ->
@@ -18,9 +20,9 @@ val print_structure : Parsetree.structure -> Res_comments_table.t -> Res_doc.t
 [@@live]
 
 val print_implementation :
-  width:int -> Parsetree.structure -> comments:Res_comment.t list -> string
+  ?width:int -> Parsetree.structure -> comments:Res_comment.t list -> string
 val print_interface :
-  width:int -> Parsetree.signature -> comments:Res_comment.t list -> string
+  ?width:int -> Parsetree.signature -> comments:Res_comment.t list -> string
 
 val print_ident_like :
   ?allow_uident:bool -> ?allow_hyphen:bool -> string -> Res_doc.t

dune-project

@@ -34,6 +34,8 @@
  (depends
   (ocaml
    (>= 4.14))
+  (cmarkit
+   (>= 0.3.0))
   (cppo
    (= 1.8.0))
   analysis

runtime/Stdlib_Result.resi

@@ -83,10 +83,10 @@ let getOrThrow: result<'a, 'b> => 'a
 
 ```rescript
 let ok = Ok(42)
-Result.mapOr(ok, 0, (x) => x / 2) == 21
+Result.mapOr(ok, 0, x => x / 2) == 21
 
 let error = Error("Invalid data")
-Result.mapOr(error, 0, (x) => x / 2) == 0
+Result.mapOr(error, 0, x => x / 2) == 0
 ```
 */
 let mapOr: (result<'a, 'c>, 'b, 'a => 'b) => 'b
@@ -102,7 +102,7 @@ ordinary value.
 ## Examples
 
 ```rescript
-let f = (x) => sqrt(Int.toFloat(x))
+let f = x => sqrt(Int.toFloat(x))
 
 Result.map(Ok(64), f) == Ok(8.0)
 
@@ -119,8 +119,8 @@ unchanged. Function `f` takes a value of the same type as `n` and returns a
 ## Examples
 
 ```rescript
-let recip = (x) =>
-  if (x !== 0.0) {
+let recip = x =>
+  if x !== 0.0 {
     Ok(1.0 /. x)
   } else {
     Error("Divide by zero")
@@ -219,11 +219,11 @@ let mod10cmp = (a, b) => Int.compare(mod(a, 10), mod(b, 10))
 
 Result.compare(Ok(39), Ok(57), mod10cmp) == 1.
 
-Result.compare(Ok(57), Ok(39), mod10cmp) == (-1.)
+Result.compare(Ok(57), Ok(39), mod10cmp) == -1.
 
 Result.compare(Ok(39), Error("y"), mod10cmp) == 1.
 
-Result.compare(Error("x"), Ok(57), mod10cmp) == (-1.)
+Result.compare(Error("x"), Ok(57), mod10cmp) == -1.
 
 Result.compare(Error("x"), Error("y"), mod10cmp) == 0.
 ```

tests/tools_tests/src/docstrings-format/FormatDocstringsTest1.res

@@ -0,0 +1,49 @@
+/**
+This is the first docstring with unformatted ReScript code.
+
+```res example
+let badly_formatted=(x,y)=>{
+let result=x+y
+if result>0{Console.log("positive")}else{Console.log("negative")}
+result
+}
+```
+
+And another code block in the same docstring:
+
+```rescript
+type user={name:string,age:int,active:bool}
+let createUser=(name,age)=>{name:name,age:age,active:true}
+```
+*/
+let testFunction1 = () => "test1"
+
+module Nested = {
+  /**
+  This is a second docstring with different formatting issues.
+
+  But if I add another line here it should be fine.
+
+  ```res info
+  module UserService={
+    let validate=user => user.age>=18 && user.name !== ""
+    let getName = user=>user.name
+  }
+  ```  
+  */
+  let testFunction2 = () => "test2"
+}
+
+/**
+Third docstring with array and option types.
+
+```rescript
+let processUsers=(users:array<user>)=>{
+users
+->Array.map(user=>{...user,active:false})->Array.filter(u=>u.age>21)
+}
+
+type status=|Loading|Success(string)|Error(option<string>)
+```
+*/
+let testFunction3 = () => "test3"