make UTop_main.interact work and add an example

This commit is contained in:
Jeremie Dimino 2016-02-23 11:27:22 +00:00
parent fa05edcc93
commit 05a0816d95
5 changed files with 35 additions and 2 deletions

View File

@ -0,0 +1,7 @@
OC := ocamlbuild -classic-display -no-links -use-ocamlfind
build:
$(OC) -pkg threads,compiler-libs.toplevel,utop test_program.byte
clean:
$(OC) -clean

1
examples/interact/_tags Normal file
View File

@ -0,0 +1 @@
true: thread, linkall, predicate(create_toploop), warn(-40), bin_annot

View File

@ -0,0 +1,12 @@
type t = A of int | B of string
let some_value = [A 42; B "Hello, world"]
let () =
print_endline "Starting utop now!";
UTop_main.interact
~search_path:["_build"]
~unit:__MODULE__
~loc:__POS__
~values:[V ("some_value", some_value)]
;;

View File

@ -0,0 +1 @@
(* empty *)

View File

@ -1368,8 +1368,13 @@ type value = V : string * _ -> value
exception Found of Env.t
let interact ~search_path ~unit ~loc:(fname, lnum, cnum, _) ~values =
let fname = Misc.find_in_path_uncap search_path (unit ^ ".cmt") in
let cmt_infos = Cmt_format.read_cmt fname in
let cmt_fname =
try
Misc.find_in_path_uncap search_path (unit ^ ".cmt")
with Not_found ->
Printf.ksprintf failwith "%s.cmt not found in search path!" fname
in
let cmt_infos = Cmt_format.read_cmt cmt_fname in
let search = object(self)
inherit [unit] UTop_cmt_lifter.lifter as super
@ -1383,6 +1388,11 @@ let interact ~search_path ~unit ~loc:(fname, lnum, cnum, _) ~values =
with
| (_, Some l, Required), (_, Some v, Required) ->
let pos = l.exp_loc.loc_start in
Printf.eprintf "%s:%d:%d %s:%d:%d\n%!"
fname lnum cnum
pos.pos_fname
pos.pos_lnum
(pos.pos_cnum - pos.pos_bol);
if pos.pos_fname = fname &&
pos.pos_lnum = lnum &&
pos.pos_cnum - pos.pos_bol = cnum then
@ -1412,6 +1422,8 @@ let interact ~search_path ~unit ~loc:(fname, lnum, cnum, _) ~values =
match search#lift_Cmt_format_cmt_infos cmt_infos with
| () -> failwith "Couldn't find location in cmt file"
| exception (Found env) ->
Clflags.include_dirs := cmt_infos.cmt_loadpath @ !Clflags.include_dirs;
let env = Env.env_of_only_summary Envaux.env_from_summary env in
List.iter (fun (V (name, v)) -> Toploop.setvalue name (Obj.repr v)) values;
main_internal ~initial_env:(Some env)
;;