Permalink
Browse files

Port warning reporting to the "catch" pattern

Conflicts:
	chunk.ml
	error_report.mli
  • Loading branch information...
1 parent 0985b15 commit 45b044b5abd35b7981cfd617a27075001dbef17d @let-def let-def committed Feb 10, 2013
Showing with 63 additions and 58 deletions.
  1. +21 −23 chunk.ml
  2. +2 −1 chunk.mli
  3. +0 −3 command.ml
  4. +1 −8 error_report.ml
  5. +0 −2 error_report.mli
  6. +21 −6 parsing/location.ml
  7. +1 −1 parsing/location.mli
  8. +17 −14 typer.ml
View
44 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
-
View
3 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
View
3 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)
View
9 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")
View
2 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,
View
27 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 () =
View
2 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
View
31 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

0 comments on commit 45b044b

Please sign in to comment.