Merge pull request #66 from whitequark/master
Run ppx preprocessors before typing and report their errors gracefully
This commit is contained in:
commit
45f35219e4
|
@ -302,6 +302,31 @@ let list_directories dir =
|
||||||
String_set.empty
|
String_set.empty
|
||||||
(try Sys.readdir (if dir = "" then Filename.current_dir_name else dir) with Sys_error _ -> [||]))
|
(try Sys.readdir (if dir = "" then Filename.current_dir_name else dir) with Sys_error _ -> [||]))
|
||||||
|
|
||||||
|
#if ocaml_version >= (4, 02, 0)
|
||||||
|
let path () =
|
||||||
|
let path_separator =
|
||||||
|
match Sys.os_type with
|
||||||
|
| "Unix" | "Cygwin" -> ':'
|
||||||
|
| "Win32" -> ';'
|
||||||
|
| _ -> assert false in
|
||||||
|
let split str sep =
|
||||||
|
let rec split_rec pos =
|
||||||
|
if pos >= String.length str then [] else begin
|
||||||
|
match try Some (String.index_from str pos sep)
|
||||||
|
with Not_found -> None with
|
||||||
|
| Some newpos ->
|
||||||
|
String.sub str pos (newpos - pos) ::
|
||||||
|
split_rec (newpos + 1)
|
||||||
|
| None ->
|
||||||
|
[String.sub str pos (String.length str - pos)]
|
||||||
|
end in
|
||||||
|
split_rec 0
|
||||||
|
in
|
||||||
|
try
|
||||||
|
split (Sys.getenv "PATH") path_separator
|
||||||
|
with Not_found -> []
|
||||||
|
#endif
|
||||||
|
|
||||||
(* +-----------------------------------------------------------------+
|
(* +-----------------------------------------------------------------+
|
||||||
| Names listing |
|
| Names listing |
|
||||||
+-----------------------------------------------------------------+ *)
|
+-----------------------------------------------------------------+ *)
|
||||||
|
@ -902,6 +927,37 @@ let complete ~syntax ~phrase_terminator ~input =
|
||||||
(loc.idx2 - Zed_utf8.length name,
|
(loc.idx2 - Zed_utf8.length name,
|
||||||
List.map (function (w, Directory) -> (w, "") | (w, File) -> (w, "\"" ^ phrase_terminator)) result)
|
List.map (function (w, Directory) -> (w, "") | (w, File) -> (w, "\"" ^ phrase_terminator)) result)
|
||||||
|
|
||||||
|
#if ocaml_version >= (4, 02, 0)
|
||||||
|
(* Completion on #ppx. *)
|
||||||
|
| [(Symbol "#", _); (Lident ("ppx"), _); (String false, loc)] ->
|
||||||
|
let file = String.sub input (loc.ofs1 + 1) (String.length input - loc.ofs1 - 1) in
|
||||||
|
let filter ~dir_ok name =
|
||||||
|
try
|
||||||
|
Unix.access name [Unix.X_OK];
|
||||||
|
let kind = (Unix.stat name).Unix.st_kind in
|
||||||
|
let basename = Filename.basename name in
|
||||||
|
(kind = Unix.S_REG && String.length basename >= 4 &&
|
||||||
|
String.sub basename 0 4 = "ppx_") ||
|
||||||
|
(dir_ok && kind = Unix.S_DIR)
|
||||||
|
with Unix.Unix_error _ -> false
|
||||||
|
in
|
||||||
|
let map =
|
||||||
|
if Filename.dirname file = "." && not (Filename.is_implicit file) then
|
||||||
|
let dir = Filename.dirname file in
|
||||||
|
add_files (filter ~dir_ok:true) String_map.empty dir
|
||||||
|
else
|
||||||
|
List.fold_left
|
||||||
|
(fun acc dir -> add_files (fun name ->
|
||||||
|
filter ~dir_ok:false (Filename.concat dir name)) acc dir)
|
||||||
|
String_map.empty (path ())
|
||||||
|
in
|
||||||
|
let list = String_map.bindings map in
|
||||||
|
let name = basename file in
|
||||||
|
let result = lookup_assoc name list in
|
||||||
|
(loc.idx2 - Zed_utf8.length name,
|
||||||
|
List.map (function (w, Directory) -> (w, "") | (w, File) -> (w, "\"" ^ phrase_terminator)) result)
|
||||||
|
#endif
|
||||||
|
|
||||||
(* Completion on #use. *)
|
(* Completion on #use. *)
|
||||||
| [(Symbol "#", _); (Lident "use", _); (String false, loc)] ->
|
| [(Symbol "#", _); (Lident "use", _); (String false, loc)] ->
|
||||||
let file = String.sub input (loc.ofs1 + 1) (String.length input - loc.ofs1 - 1) in
|
let file = String.sub input (loc.ofs1 + 1) (String.length input - loc.ofs1 - 1) in
|
||||||
|
|
|
@ -85,12 +85,33 @@ let parse_input_multi input =
|
||||||
in
|
in
|
||||||
(result, Buffer.contents buf)
|
(result, Buffer.contents buf)
|
||||||
|
|
||||||
|
#if ocaml_version = (4, 02, 0)
|
||||||
|
(* #ppx missed the 4.02 merge window. :/ *)
|
||||||
|
let () =
|
||||||
|
Hashtbl.add Toploop.directive_table "ppx"
|
||||||
|
(Toploop.Directive_string(fun s -> Clflags.all_ppx := s :: !Clflags.all_ppx))
|
||||||
|
#endif
|
||||||
|
|
||||||
let parse_and_check input eos_is_error =
|
let parse_and_check input eos_is_error =
|
||||||
let buf = Buffer.create 32 in
|
let buf = Buffer.create 32 in
|
||||||
|
let preprocess input =
|
||||||
|
match input with
|
||||||
|
#if ocaml_version >= (4, 02, 0)
|
||||||
|
| UTop.Value (Parsetree.Ptop_def pstr) ->
|
||||||
|
begin try
|
||||||
|
let pstr = Pparse.apply_rewriters Config.ast_impl_magic_number pstr in
|
||||||
|
UTop.Value (Parsetree.Ptop_def pstr)
|
||||||
|
with Pparse.Error error ->
|
||||||
|
Pparse.report_error Format.str_formatter error;
|
||||||
|
UTop.Error ([], Format.flush_str_formatter ())
|
||||||
|
end
|
||||||
|
#endif
|
||||||
|
| _ -> input
|
||||||
|
in
|
||||||
let result =
|
let result =
|
||||||
UTop.collect_formatters buf [Format.err_formatter]
|
UTop.collect_formatters buf [Format.err_formatter]
|
||||||
(fun () ->
|
(fun () ->
|
||||||
match !UTop.parse_toplevel_phrase input eos_is_error with
|
match preprocess (!UTop.parse_toplevel_phrase input eos_is_error) with
|
||||||
| UTop.Error (locs, msg) ->
|
| UTop.Error (locs, msg) ->
|
||||||
UTop.Error (convert_locs input locs, "Error: " ^ msg ^ "\n")
|
UTop.Error (convert_locs input locs, "Error: " ^ msg ^ "\n")
|
||||||
| UTop.Value phrase ->
|
| UTop.Value phrase ->
|
||||||
|
@ -520,9 +541,6 @@ let rewrite_str_item pstr_item tstr_item =
|
||||||
let rewrite phrase =
|
let rewrite phrase =
|
||||||
match phrase with
|
match phrase with
|
||||||
| Parsetree.Ptop_def pstr ->
|
| Parsetree.Ptop_def pstr ->
|
||||||
#if ocaml_version >= (4, 02, 0)
|
|
||||||
let pstr = Pparse.apply_rewriters Config.ast_impl_magic_number pstr in
|
|
||||||
#endif
|
|
||||||
if (UTop.get_auto_run_lwt () || UTop.get_auto_run_async ()) && List.exists is_eval pstr then
|
if (UTop.get_auto_run_lwt () || UTop.get_auto_run_async ()) && List.exists is_eval pstr then
|
||||||
let tstr, _, _ = Typemod.type_structure !Toploop.toplevel_env pstr Location.none in
|
let tstr, _, _ = Typemod.type_structure !Toploop.toplevel_env pstr Location.none in
|
||||||
let tstr = str_items_of_typed_structure tstr in
|
let tstr = str_items_of_typed_structure tstr in
|
||||||
|
|
Loading…
Reference in New Issue