Merge pull request #66 from whitequark/master

Run ppx preprocessors before typing and report their errors gracefully

src/lib/uTop_complete.ml

@@ -302,6 +302,31 @@ let list_directories dir =
        String_set.empty
        (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                                                   |
    +-----------------------------------------------------------------+ *)
@@ -902,6 +927,37 @@ let complete ~syntax ~phrase_terminator ~input =
         (loc.idx2 - Zed_utf8.length name,
          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. *)
     | [(Symbol "#", _); (Lident "use", _); (String false, loc)] ->
         let file = String.sub input (loc.ofs1 + 1) (String.length input - loc.ofs1 - 1) in

src/lib/uTop_main.ml

@@ -85,12 +85,33 @@ let parse_input_multi input =
   in
   (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 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 =
     UTop.collect_formatters buf [Format.err_formatter]
       (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 (convert_locs input locs, "Error: " ^ msg ^ "\n")
            | UTop.Value phrase ->
@@ -520,9 +541,6 @@ let rewrite_str_item pstr_item tstr_item =
 let rewrite phrase =
   match phrase with
     | 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
         let tstr, _, _ = Typemod.type_structure !Toploop.toplevel_env pstr Location.none in
         let tstr = str_items_of_typed_structure tstr in