Improve logic to return several warnings for ill placed doc comments.doc2attr

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/doc2attr@15939 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

4 files changed, 73 insertions, 47 deletions

diff --git a/driver/pparse.ml b/driver/pparse.ml
index 4c086cc880..81ce69b84a 100644
--- a/driver/pparse.ml
+++ b/driver/pparse.ml
@@ -148,53 +148,80 @@ let file ppf ~tool_name inputfile parse_fun ast_magic =
         Location.input_name := input_value ic;
         input_value ic
       end else begin
-        seek_in ic 0;
         Location.input_name := inputfile;
-        try
+
+        let parse () =
+          seek_in ic 0;
           let lexbuf = Lexing.from_channel ic in
           Location.init lexbuf inputfile;
           parse_fun lexbuf
-        with Syntaxerr.Error _ when !Clflags.strict_doc ->
-          (* We try to parse the file again in legacy mode (non strict-doc).
-             If this succeeds, the error can only be caused by a bogus
-             documentation comment.  In that case, we report a warning
-             on the last doc token. This means that at most one
-             warning can be reported in a single unit. (We could also
-             restart parsing by informing the lexer to ignore only
-             this last doc token, but this becomes messy.)
-
-             It would also be possible to add logic to drop a doc
-             token that causes directly a parse error (and show a
-             warning) and continue parsing.  This can be done by
-             extending the Parsing module with a new exception which
-             can be raise by a custom parse_error function.  When this
-             exception is raised, Parsing reads the next token (as in
-             the Read_token case) and loop.  We would only do that
-             when the last token was a doc comment (info collected by the
-             "token" function in lexer.mll).
-
-             Unfortunately, this approach doesn't work for cases where
-             the parse error is only detected after the doc token, as
-             in:
-
-                 let x = 1 (** *) + 2
-
-             We could do a best-effort and combine the two techniques.
-          *)
-
-          let last_doc = !Location.last_doc_token_loc in
-          try
-            Clflags.strict_doc := false;
-            seek_in ic 0;
-            let lexbuf = Lexing.from_channel ic in
-            Location.init lexbuf inputfile;
-            let ast = parse_fun lexbuf in
-            Location.prerr_warning last_doc Warnings.Bad_location_for_doc;
-            ast
-          with exn ->
-            Clflags.strict_doc := false;
-            raise exn
+        in
+
+        let last_doc_token = ref None in
+        Location.keep_doc_token :=
+          (fun loc -> last_doc_token := Some loc; true);
+
+        let handle_bad_doc_comments () =
+          (* Special logic to turn badly located documentation
+             comments (which result in parsing errors) into
+             warnings. *)
+
+          (* First, we try to parse again by ignoring all
+             documentation comments (this could be achieved also by
+             unsetting strict_doc). *)
+
+          Location.keep_doc_token := (fun _ -> false);
+          ignore (parse ());
+
+          (* If the line above raise an exception, this is because the
+             file contains a "real" parsing error (not caused by doc
+             comments).  If this is the case, we do nothing special,
+             i.e. we do not try to report badly located doc
+             comments. *)
+
+
+          (* Otherwise, we know the original error is caused by one of
+             the doc comments.  We parse again by ignoring the last
+             doc comments (from the original parsing) which is likely
+             to be the cause for the parse error.  We iterate by
+             ignoring more and more doc comment, until we reach again
+             a state where the file is parsed without errors (we know
+             there is such a state; the number of iteration is bounded
+             by the total number of doc comments). *)
+
+          let ignored_doc_tokens = Hashtbl.create 16 in
+          Location.keep_doc_token :=
+            (fun loc ->
+               if Hashtbl.mem ignored_doc_tokens loc then false
+               else begin
+                 last_doc_token := Some loc;
+                 true
+               end
+            );
+
+          let rec loop () =
+            begin match !last_doc_token with
+            | Some x ->
+                Location.prerr_warning x Warnings.Bad_location_for_doc;
+                Hashtbl.add ignored_doc_tokens x ()
+            | None -> assert false;
+            end;
+            last_doc_token := None;
+            try parse ()
+            with _exn -> loop ()
+          in
+          loop ()
+        in
 
+        Misc.try_finally
+          (fun () ->
+             try
+               parse ()
+             with Syntaxerr.Error _
+               when !Clflags.strict_doc && !last_doc_token <> None ->
+                 handle_bad_doc_comments ()
+          )
+          (fun () -> Location.keep_doc_token := (fun _ -> true))
       end
     with x -> close_in ic; raise x
   in
diff --git a/parsing/lexer.mll b/parsing/lexer.mll
index a081d7c34c..b1179ed920 100644
--- a/parsing/lexer.mll
+++ b/parsing/lexer.mll
@@ -670,8 +670,8 @@ and skip_sharp_bang = parse
           last_comments := (s, comment_loc) :: !last_comments;
           token lexbuf
       | DOC(_, loc) | FLOATING_DOC(_, loc) as tok ->
-          Location.last_doc_token_loc := loc;
-          tok
+          if !Location.keep_doc_token loc then tok
+          else token lexbuf
       | tok ->
           tok
   let comments () = List.rev !last_comments
diff --git a/parsing/location.ml b/parsing/location.ml
index eb7f1f32b7..df71cf57d1 100644
--- a/parsing/location.ml
+++ b/parsing/location.ml
@@ -386,4 +386,4 @@ let () =
 let raise_errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") =
   Printf.ksprintf (fun msg -> raise (Error ({loc; msg; sub; if_highlight})))
 
-let last_doc_token_loc = ref none
+let keep_doc_token = ref (fun _ -> true)
diff --git a/parsing/location.mli b/parsing/location.mli
index 354488226e..892c73c949 100644
--- a/parsing/location.mli
+++ b/parsing/location.mli
@@ -118,5 +118,4 @@ val report_error: formatter -> error -> unit
 val report_exception: formatter -> exn -> unit
   (* Reraise the exception if it is unknown. *)
 
-val last_doc_token_loc: t ref
-  (* Remember the location of the last doc token. *)
+val keep_doc_token: (t -> bool) ref