Add location of invalid docstring in warning messages

CHANGES.md

@@ -7,6 +7,8 @@
   + Preserve the syntax of infix set/get operators (#1528, @gpetiot)
     `String.get` and similar calls used to be automatically rewritten to their corresponding infix form `.()`, that was incorrect when using the `-unsafe` compilation flag. Now the concrete syntax of these calls is preserved.
 
+  + Add location of invalid docstring in warning messages, checks are made when parsing the file (#1529, @gpetiot)
+
 ### 0.16.0 (2020-11-16)
 
 #### Removed

lib/Docstring.ml

@@ -0,0 +1,27 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                              OCamlFormat                               *)
+(*                                                                        *)
+(*            Copyright (c) Facebook, Inc. and its affiliates.            *)
+(*                                                                        *)
+(*      This source code is licensed under the MIT license found in       *)
+(*      the LICENSE file in the root directory of this source tree.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+let parse ~loc text =
+  let location = loc.Location.loc_start in
+  let location =
+    { location with
+      pos_cnum= location.pos_cnum + 3 (* Length of comment opening *) }
+  in
+  match Odoc_parser.parse_comment_raw ~location ~text with
+  | exception _ ->
+      let span = Migrate_ast.Location.to_span loc in
+      Error [Odoc_model.Error.make "comment could not be parsed" span]
+  | {value; warnings= []} -> Ok value
+  | {warnings; _} -> Error warnings
+
+let warn fmt warning =
+  Format.fprintf fmt "Warning: Invalid documentation comment:@,%s\n%!"
+    (Odoc_model.Error.to_string warning)

lib/Docstring.mli

@@ -0,0 +1,17 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                              OCamlFormat                               *)
+(*                                                                        *)
+(*            Copyright (c) Facebook, Inc. and its affiliates.            *)
+(*                                                                        *)
+(*      This source code is licensed under the MIT license found in       *)
+(*      the LICENSE file in the root directory of this source tree.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+val parse :
+     loc:Warnings.loc
+  -> string
+  -> (Odoc_parser.Ast.docs, Odoc_model.Error.t list) Result.t
+
+val warn : Format.formatter -> Odoc_model.Error.t -> unit

lib/Fmt_ast.ml

@@ -335,17 +335,6 @@ let fmt_direction_flag = function
 let fmt_virtual_flag f =
   match f with Virtual -> fmt "@ virtual" | Concrete -> noop
 
-let parse_docstring ~loc text =
-  let location = loc.Location.loc_start in
-  let location =
-    { location with
-      pos_cnum= location.pos_cnum + 3 (* Length of comment opening *) }
-  in
-  match Odoc_parser.parse_comment_raw ~location ~text with
-  | exception _ -> Error ["comment could not be parsed"]
-  | {value; warnings= []} -> Ok value
-  | {warnings; _} -> Error (List.map warnings ~f:Odoc_model.Error.to_string)
-
 let fmt_parsed_docstring c ~loc ?pro ~epi str_cmt parsed =
   assert (not (String.is_empty str_cmt)) ;
   let fmt_parsed parsed =
@@ -362,13 +351,7 @@ let fmt_parsed_docstring c ~loc ?pro ~epi str_cmt parsed =
     match parsed with
     | _ when not c.conf.parse_docstrings -> fmt_raw str_cmt
     | Ok parsed -> fmt_parsed parsed
-    | Error msgs ->
-        if not c.conf.quiet then
-          List.iter msgs
-            ~f:
-              (Caml.Format.eprintf
-                 "Warning: Invalid documentation comment:@,%s\n%!" ) ;
-        fmt_raw str_cmt
+    | Error _ -> fmt_raw str_cmt
   in
   Cmts.fmt c loc
   @@ vbox_if (Option.is_none pro) 0 (fmt_opt pro $ wrap "(**" "*)" doc $ epi)
@@ -384,7 +367,7 @@ let fmt_docstring c ?(standalone = false) ?pro ?epi doc =
   list_pn (Option.value ~default:[] doc)
     (fun ~prev:_ ({txt; loc}, floating) ~next ->
       let epi = docstring_epi ~standalone ~next ~epi ~floating in
-      fmt_parsed_docstring c ~loc ?pro ~epi txt (parse_docstring ~loc txt) )
+      fmt_parsed_docstring c ~loc ?pro ~epi txt (Docstring.parse ~loc txt) )
 
 let fmt_docstring_around_item' ?(is_val = false) ?(force_before = false)
     ?(fit = false) c doc1 doc2 =
@@ -408,7 +391,7 @@ let fmt_docstring_around_item' ?(is_val = false) ?(force_before = false)
       let floating_doc, doc =
         doc
         |> List.map ~f:(fun (({txt; loc}, _) as doc) ->
-               (parse_docstring ~loc txt, doc) )
+               (Docstring.parse ~loc txt, doc) )
         |> List.partition_tf ~f:(fun (_, (_, floating)) -> floating)
       in
       let placement =

lib/Migrate_ast.ml

@@ -136,6 +136,8 @@ module Position = struct
   include (val Comparator.make ~compare ~sexp_of_t)
 
   let distance p1 p2 = p2.pos_cnum - p1.pos_cnum
+
+  let to_point x = Odoc_model.Location_.{line= x.pos_lnum; column= column x}
 end
 
 module Location = struct
@@ -195,6 +197,12 @@ module Location = struct
   let smallest loc stack =
     let min a b = if width a < width b then a else b in
     List.reduce_exn (loc :: stack) ~f:min
+
+  let to_span loc =
+    let open Odoc_model.Location_ in
+    { file= loc.loc_start.pos_fname
+    ; start= Position.to_point loc.loc_start
+    ; end_= Position.to_point loc.loc_end }
 end
 
 module Longident = struct

lib/Migrate_ast.mli

@@ -84,6 +84,8 @@ module Location : sig
   val width : t -> int
 
   val is_single_line : t -> int -> bool
+
+  val to_span : t -> Odoc_model.Location_.span
 end
 
 module Traverse : sig

lib/Parse_with_comments.ml

@@ -41,6 +41,33 @@ let tokens lexbuf =
   in
   loop []
 
+let check_docstrings (conf : Conf.t) =
+  object
+    inherit Ppxlib.Ast_traverse.iter as super
+
+    method! attribute x =
+      match x with
+      | { attr_name= {txt= "ocaml.doc" | "ocaml.text"; _}
+        ; attr_payload=
+            PStr
+              [ { pstr_desc=
+                    Pstr_eval
+                      ( { pexp_desc=
+                            Pexp_constant (Pconst_string (doc, _, None))
+                        ; pexp_loc= loc
+                        ; pexp_attributes= []
+                        ; _ }
+                      , [] )
+                ; _ } ]
+        ; _ } -> (
+        match Docstring.parse ~loc doc with
+        | Ok _ -> ()
+        | Error warnings ->
+            if not conf.quiet then
+              List.iter warnings ~f:(Docstring.warn Format.err_formatter) )
+      | _ -> () ; super#attribute x
+  end
+
 let fresh_lexbuf source =
   let lexbuf = Lexing.from_string source in
   Location.init lexbuf !Location.input_name ;
@@ -68,6 +95,8 @@ let parse fragment (conf : Conf.t) ~source =
         else not conf.quiet )
       ~f:(fun () ->
         let ast = Migrate_ast.Parse.fragment fragment lexbuf in
+        if conf.parse_docstrings then
+          Migrate_ast.Traverse.iter fragment (check_docstrings conf) ast ;
         Warnings.check_fatal () ;
         let comments =
           List.map

lib/Parse_with_comments.mli

@@ -31,3 +31,4 @@ val parse :
   -> Conf.t
   -> source:string
   -> 'a with_comments
+(** @raise [Warning50] on misplaced documentation comments. *)

test/passing/format_invalid_files_with_locations.ml.ref

@@ -1,9 +1,9 @@
-Warning: format_invalid_files_with_locations.ml is invalid, recovering.
 Warning: Invalid documentation comment:
 File "format_invalid_files_with_locations.ml", line 10, characters 22-22:
 End of text is not allowed in '[...]' (code).
 Warning: format_invalid_files_with_locations.ml is invalid, recovering.
 Warning: format_invalid_files_with_locations.ml is invalid, recovering.
+Warning: format_invalid_files_with_locations.ml is invalid, recovering.
 let x = 1 + (;;
 
 (* asd *)

test/passing/invalid_docstring.ml.ref

@@ -1,3 +1,4 @@
 Warning: Invalid documentation comment:
+File "invalid_docstring.ml", line 1, characters 0-7:
 comment could not be parsed
 (**{v*)