diff --git a/src/lib/uTop_main.ml b/src/lib/uTop_main.ml index 6af15274..87387f9e 100644 --- a/src/lib/uTop_main.ml +++ b/src/lib/uTop_main.ml @@ -756,7 +756,52 @@ let print_error term msg = LTerm.set_style term LTerm_style.none >>= fun () -> LTerm.flush term -let rec loop term = +module Ops = struct + type t = + | Term of LTerm.t + | Test of Stdlib.in_channel + + let read_phrase = function + | Term t -> read_phrase t + | Test ic -> + let rec loop () = + let r = + match Stdlib.input_line ic with + | exception End_of_file -> `Eof + | s -> + let n = String.length s in + begin + if n >= 1 && s.[0] = '#' then + `Input (String.sub s 1 (n - 1)) + else + `Output + end + in + match r with + | `Eof -> exit 0 + | `Input s -> s + | `Output -> loop () + in + let input = loop () in + Printf.printf "#%s\n%!" input; + let r = parse_and_check input false in + Stdlib.flush Stdlib.stderr; + Lwt.return r + + let print_error ops e = match ops with + | Term t -> print_error t e + | Test _ -> Printf.printf "%s%!" e; Lwt.return_unit + + let flush = function + | Term t -> LTerm.flush t + | Test _ -> Lwt.return_unit + + let render_out_phrase ops s = match ops with + | Term t -> render_out_phrase t s + | Test _ -> Printf.printf "%s%!" s;Lwt.return_unit +end + +let rec loop ops = (* Reset completion. *) UTop_complete.reset (); @@ -771,16 +816,16 @@ let rec loop term = Lwt_main.run ( Lwt.finalize (fun () -> - read_phrase term >>= fun (result, warnings) -> + Ops.read_phrase ops >>= fun (result, warnings) -> (* Print warnings before errors. *) Lwt_io.print warnings >>= fun () -> match result with | UTop.Value phrase -> return (Some phrase) | UTop.Error (locs, msg) -> - print_error term msg >>= fun () -> + Ops.print_error ops msg >>= fun () -> return None) - (fun () -> LTerm.flush term) + (fun () -> Ops.flush ops) ) in match phrase_opt with @@ -819,10 +864,10 @@ let rec loop term = match phrase with | Parsetree.Ptop_def _ -> (* The string is an output phrase, colorize it. *) - Lwt_main.run (render_out_phrase term string) + Lwt_main.run (Ops.render_out_phrase ops string) | Parsetree.Ptop_dir _ -> (* The string is an error message. *) - Lwt_main.run (print_error term string) + Lwt_main.run (Ops.print_error ops string) with exn -> (* The only possible errors are directive errors. *) let msg = UTop.get_message Errors.report_error exn in @@ -834,10 +879,10 @@ let rec loop term = with Not_found -> msg in - Lwt_main.run (print_error term msg)); - loop term + Lwt_main.run (Ops.print_error ops msg)); + loop ops | None -> - loop term + loop ops (* +-----------------------------------------------------------------+ | Welcome message | @@ -1345,9 +1390,47 @@ let print_version_num () = Printf.printf "%s\n" UTop.version; exit 0 +module Test = struct + let map_loc f {Location.loc;txt} = {Location.loc; txt= f txt} + + let shorten_warning_name s = + Scanf.sscanf s "%d" string_of_int + + let shorten_kind = function + | Location.Report_warning s -> Location.Report_warning (shorten_warning_name s) + | k -> k + + let short_warning_reporter loc warn = + Option.map + (fun report -> + { report with + Location.kind = shorten_kind report.Location.kind } + ) + (Location.default_warning_reporter loc warn) + + let short_report_printer () = + let def = Location.batch_mode_printer in + let pp self ppf report = + Format.fprintf ppf "%a\n" (self.Location.pp_report_kind self report) report.kind; + in + { def with pp } + + let setup () = + Location.warning_reporter := short_warning_reporter; + Location.report_printer := short_report_printer + + let run path = + let ic = Stdlib.open_in_bin path in + Fun.protect + (fun () -> loop (Test ic)) + ~finally:(fun () -> Stdlib.close_in_noerr ic) +end + (* Config from command line *) let autoload = ref true +let test_file = ref None + let args = Arg.align [ "-absname", Arg.Set Clflags.absname, " Show absolute filenames in error message"; "-I", Arg.String (fun dir -> Clflags.include_dirs := dir :: !Clflags.include_dirs), " Add to the list of include directories"; @@ -1402,6 +1485,7 @@ let args = Arg.align [ " Load this package"; "-dparsetree", Arg.Set Clflags.dump_parsetree, " Dump OCaml AST after rewriting"; "-dsource", Arg.Set Clflags.dump_source, " Dump OCaml source after rewriting"; + "-test", Arg.String (fun s -> test_file := Some s), " Test mode (internal)"; ] let () = Clflags.real_paths := false @@ -1499,6 +1583,14 @@ let main_aux ~initial_env = Topcommon.load_topdirs_signature (); #endif if not (prepare ()) then exit 2; + match !test_file with + | Some f -> begin + common_init ~initial_env; + Test.setup (); + Test.run f + end + | None -> + begin if !emacs_mode then begin Printf.printf "protocol-version:%d\n%!" protocol_version; UTop_private.set_ui UTop_private.Emacs; @@ -1523,7 +1615,7 @@ let main_aux ~initial_env = flush stdout; (* Main loop. *) try - loop term + loop (Ops.Term term) with LTerm_read_line.Interrupt -> () end else begin @@ -1535,6 +1627,7 @@ let main_aux ~initial_env = end; (* Don't let the standard toplevel run... *) exit 0 + end let main_internal ~initial_env = try diff --git a/test/demo.txt b/test/demo.txt new file mode 100644 index 00000000..5c0e2e24 --- /dev/null +++ b/test/demo.txt @@ -0,0 +1,5 @@ +# type t = () of unit;; +Warning 65 +type t = () of unit +# 0;; +- : int = 0 diff --git a/test/dune b/test/dune new file mode 100644 index 00000000..e8d8ecc2 --- /dev/null +++ b/test/dune @@ -0,0 +1,8 @@ +(rule + (with-outputs-to + demo.txt.corrected + (run %{bin:utop} -test demo.txt))) + +(alias + (name runtest) + (action (diff demo.txt demo.txt.corrected)))