Port warning reporting to the "catch" pattern

Conflicts:
	chunk.ml
	error_report.mli

chunk.ml

@@ -3,12 +3,15 @@ type item_desc =
   | Module_opening of Location.t * string Location.loc * Parsetree.module_expr
   | Module_closing of Parsetree.structure_item Location.loc * History.offset
 
-type item = Outline.sync * (item_desc, exn) Misc.sum
+type item = Outline.sync * (exn list * item_desc option)
 type sync = item History.sync
 type t = item History.t
 
 exception Malformed_module of Location.t
 exception Invalid_chunk
+exception Warning of Location.t * string
+
+let wrap_warnings = List.rev_map (fun (l,s) -> Warning (l,s))
 
 let eof_lexer _ = Chunk_parser.EOF
 let fail_lexer _ = failwith "lexer ended"
@@ -19,11 +22,11 @@ let line x = (x.Location.loc.Location.loc_start.Lexing.pos_lnum)
 let dump_chunk t =
   List.map
   begin function
-  | _, Misc.Inl (Definitions []) -> assert false
-  | _, Misc.Inl (Definitions (d :: _)) -> ("definition", line d)
-  | _, Misc.Inl (Module_opening (l,s,_)) -> ("opening " ^ s.Location.txt, line s)
-  | _, Misc.Inl (Module_closing (d,offset)) -> ("closing after " ^ string_of_int offset, line d)
-  | _, Misc.Inr exn -> ("exception", -1)
+  | _, (_, Some (Definitions [])) -> assert false
+  | _, (_, Some (Definitions (d :: _))) -> ("definition", line d)
+  | _, (_, Some (Module_opening (l,s,_))) -> ("opening " ^ s.Location.txt, line s)
+  | _, (_, Some (Module_closing (d,offset))) -> ("closing after " ^ string_of_int offset, line d)
+  | _, (_, None) -> ("error", -1)
   end (List.rev (History.prevs t) @ History.nexts t)
 
 let fake_tokens tokens f =
@@ -69,13 +72,12 @@ let sync_step outline tokens t =
         (* reconstitute module from t *)
         let rec rewind_defs defs t =
           match History.backward t with
-          | Some ((_,Misc.Inl (Definitions [])), _) -> assert false
-          | Some ((_,Misc.Inl (Definitions lst)), t') ->
-            rewind_defs (List.map (fun d -> d.Location.txt) lst @ defs) t'
-          | Some ((_,Misc.Inl (Module_closing (d,offset))), t') ->
+          | Some ((_,(_,Some (Definitions []))), _) -> assert false
+          | Some ((_,(_,Some (Definitions (d::_)))), t') -> rewind_defs (d.Location.txt :: defs) t'
+          | Some ((_,(_,Some (Module_closing (d,offset)))), t') ->
               rewind_defs (d.Location.txt :: defs) (History.seek_offset offset t')
-          | Some ((_,Misc.Inl (Module_opening (loc,s,m))), t') -> loc,s,m,defs,t'
-          | Some ((_,Misc.Inr _), t') -> rewind_defs defs t'
+          | Some ((_,(_,Some (Module_opening (loc,s,m)))), t') -> loc,s,m,defs,t'
+          | Some ((_,(_,None)), t') -> rewind_defs defs t'
           | None ->
               let p = (match tokens with (_,loc_start,loc_end) :: _ -> Location.({loc_start;loc_end;loc_ghost = false}) | _ -> Location.none) in
               raise (Malformed_module p)
@@ -126,16 +128,12 @@ let sync outlines chunks =
     match History.forward outlines with
       | None -> chunks
       | Some ({ Outline.kind ; Outline.tokens },outlines') ->
-          match
-            try
-              match sync_step kind tokens chunks with
-                | Some chunk -> Some (History.insert (History.Sync.at outlines', Misc.Inl chunk) chunks)
-                | None -> None
-            with
-              | exn -> Some (History.insert (History.Sync.at outlines', Misc.Inr exn) chunks)
-          with
-            | Some chunks -> aux outlines' chunks
-            | None -> aux outlines' chunks
+          let chunk =
+            match Location.catch_warnings (fun () -> sync_step kind tokens chunks) with
+              | warnings, Misc.Inr item -> wrap_warnings warnings, item
+              | warnings, Misc.Inl exn -> exn :: wrap_warnings warnings, None
+          in
+          let chunks' = History.(insert (Sync.at outlines', chunk) chunks) in
+          aux outlines' chunks'
   in
   aux outlines chunks
-

chunk.mli

@@ -8,12 +8,13 @@ type item_desc =
    *)
   | Module_closing of Parsetree.structure_item Location.loc * History.offset
 
-and item = Outline.sync * (item_desc, exn) Misc.sum
+and item = Outline.sync * (exn list * item_desc option)
 and sync = item History.sync
 and t = item History.t
 
 exception Malformed_module of Location.t
 exception Invalid_chunk
+exception Warning of Location.t * string
 
 val sync_step : Outline_utils.kind -> Outline.token list -> t -> item_desc option
 val sync : Outline.t -> t -> t

command.ml

@@ -82,7 +82,6 @@ let command_tell = {
   handler = begin fun (i,o) state -> function
   | [`String "struct" ; `String source] ->
       Env.reset_missing_cmis ();
-      ignore (Error_report.reset_warnings ());
       let eod = ref false and eot = ref false in
       let lexbuf = Misc.lex_strings source
         begin fun () ->
@@ -115,8 +114,6 @@ let command_tell = {
         let types = Typer.sync chunks types in
         let tokens = History.nexts tokens in
         let pos = !bufpos in
-        let w = Error_report.reset_warnings () in
-        let outlines = Outline.append_exns w outlines in
         let state' = { tokens ; outlines ; chunks ; types ; pos } in
           (if state.tokens = state'.tokens then List.iter (fun (i,_,_) -> prerr_endline (Chunk_parser_utils.token_to_string i)) state.tokens );
         if !eod || (!eot && state.tokens = state'.tokens)

error_report.ml

@@ -1,10 +1,3 @@
-exception Warning of Location.t * string
-
-let reset_warnings () =
-  let result = List.map (fun (l,s) -> Warning (l,s)) !Location.warnings in
-  Location.warnings := [];
-  result
-
 let format ~valid ~where ?loc msg =
   let content = ["valid", `Bool valid; "message", `String msg] in
   let content =
@@ -55,7 +48,7 @@ let strict_to_json = function
       Some (format ~valid:true ~where:"parser" ~loc (to_string ()))
   | Outline.Parse_error loc ->
       Some (format ~valid:true ~where:"parser" ~loc "Parse error")
-  | Warning (loc, msg) ->
+  | Chunk.Warning (loc, msg) ->
       Some (format ~valid:true ~where:"warning" ~loc msg)
   | Chunk.Malformed_module loc ->
       Some (format ~valid:true ~where:"warning" ~loc "Malformed module")

error_report.mli

@@ -1,6 +1,4 @@
 (** {0 Exception formatting for error reporting} *)
-exception Warning of Location.t * string
-val reset_warnings : unit -> exn list
 
 (** The format of reports for known exceptions is:
   *   {message: string, type: string, valid:true,

parsing/location.ml

@@ -270,13 +270,28 @@ let print_warning loc ppf w =
   end
 ;;
 
-let warnings = ref []
+let warnings : (t * string) list ref option ref = ref None
+
 let prerr_warning loc w =
-  let ppf, to_string = Misc.ppf_to_string () in
-  print_warning loc ppf w;
-  match to_string () with
-    | "" -> ()
-    | s ->  warnings := (loc,s) :: !warnings
+  match !warnings with
+  | None -> print_warning loc err_formatter w
+  | Some l ->
+    let ppf, to_string = Misc.ppf_to_string () in
+    print_warning loc ppf w;
+    match to_string () with
+      | "" -> ()
+      | s ->  l := (loc,s) :: !l
+
+let catch_warnings f =
+  let caught = ref [] in
+  let previous = !warnings in
+  warnings := Some caught;
+  let result =
+    try Misc.Inr (f())
+    with e -> Misc.Inl e
+  in
+  warnings := previous;
+  !caught, result
 ;;
 
 let echo_eof () =

parsing/location.mli

@@ -56,7 +56,7 @@ val print_error_cur_file: formatter -> unit
 val print_warning: t -> formatter -> Warnings.t -> unit
 
 val prerr_warning : t -> Warnings.t -> unit
-val warnings : (t * string) list ref
+val catch_warnings : (unit -> 'a) -> (t * string) list * (exn, 'a) Misc.sum
 
 val echo_eof: unit -> unit
 val reset: unit -> unit

typer.ml

@@ -30,7 +30,7 @@ let exns  t = let _,_,v = value t in v
 let append_step chunks chunk_item t =
   let env, trees, exns = value t in
   match chunk_item with
-    | Misc.Inl (Chunk.Module_opening (_,_,pmod)) ->
+    | Chunk.Module_opening (_,_,pmod) ->
         begin try
           let open Typedtree in
           let open Parsetree in
@@ -64,11 +64,10 @@ let append_step chunks chunk_item t =
           match find_structure tymod with
             | None -> None
             | Some md -> Some (md.mod_env, trees, exns)
-        with exn ->
-          Some (env, trees, exn :: exns)
+        with exn -> Some (env, trees, exn :: exns)
         end
 
-    | Misc.Inl (Chunk.Definitions ds) ->
+    | Chunk.Definitions ds ->
         let (env,trees,exns) =
           List.fold_left
           begin fun (env,trees,exns) d ->
@@ -80,19 +79,15 @@ let append_step chunks chunk_item t =
         in
         Some (env, trees, exns)
 
-    | Misc.Inl (Chunk.Module_closing (d,offset)) ->
+    | Chunk.Module_closing (d,offset) ->
         begin try
           let _, t = History.Sync.rewind fst (History.seek_offset offset chunks) t in
           let env, trees, exns = value t in
           let tstr,tsg,env = Typemod.type_structure env [d.Location.txt] d.Location.loc in
           Some (env, (tstr,tsg) :: trees, exns)
-        with exn ->
-          Some (env, trees, exn :: exns)
+        with exn -> Some (env, trees, exn :: exns)
         end
 
-    | Misc.Inr exn ->
-          Some (env, trees, exn :: exns)
-
 let sync chunks t =
   (* Find last synchronisation point *)
   let chunks, t = History.Sync.rewind fst chunks t in
@@ -102,9 +97,17 @@ let sync chunks t =
   let rec aux chunks t =
     match History.forward chunks with
       | None -> t
-      | Some ((_,chunk_item),chunks') ->
-          match append_step chunks chunk_item t with
-            | Some item -> aux chunks' (History.insert (History.Sync.at chunks', item) t)
-            | None -> aux chunks' t
+      | Some ((_,(exns,chunk)),chunks') ->
+          let env, trees, exns' =
+            match
+              begin match chunk with
+                | Some c -> append_step chunks c t
+                | None -> None
+              end
+            with
+              | Some result -> result
+              | None -> value t
+          in
+          History.(insert (Sync.at chunks', (env, trees, exns @ exns'))) t
   in
   aux chunks t