make UTop_main.interact work and add an example
This commit is contained in:
parent
fa05edcc93
commit
05a0816d95
|
@ -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
|
|
@ -0,0 +1 @@
|
||||||
|
true: thread, linkall, predicate(create_toploop), warn(-40), bin_annot
|
|
@ -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)]
|
||||||
|
;;
|
|
@ -0,0 +1 @@
|
||||||
|
(* empty *)
|
|
@ -1368,8 +1368,13 @@ type value = V : string * _ -> value
|
||||||
exception Found of Env.t
|
exception Found of Env.t
|
||||||
|
|
||||||
let interact ~search_path ~unit ~loc:(fname, lnum, cnum, _) ~values =
|
let interact ~search_path ~unit ~loc:(fname, lnum, cnum, _) ~values =
|
||||||
let fname = Misc.find_in_path_uncap search_path (unit ^ ".cmt") in
|
let cmt_fname =
|
||||||
let cmt_infos = Cmt_format.read_cmt fname in
|
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)
|
let search = object(self)
|
||||||
inherit [unit] UTop_cmt_lifter.lifter as super
|
inherit [unit] UTop_cmt_lifter.lifter as super
|
||||||
|
|
||||||
|
@ -1383,6 +1388,11 @@ let interact ~search_path ~unit ~loc:(fname, lnum, cnum, _) ~values =
|
||||||
with
|
with
|
||||||
| (_, Some l, Required), (_, Some v, Required) ->
|
| (_, Some l, Required), (_, Some v, Required) ->
|
||||||
let pos = l.exp_loc.loc_start in
|
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 &&
|
if pos.pos_fname = fname &&
|
||||||
pos.pos_lnum = lnum &&
|
pos.pos_lnum = lnum &&
|
||||||
pos.pos_cnum - pos.pos_bol = cnum then
|
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
|
match search#lift_Cmt_format_cmt_infos cmt_infos with
|
||||||
| () -> failwith "Couldn't find location in cmt file"
|
| () -> failwith "Couldn't find location in cmt file"
|
||||||
| exception (Found env) ->
|
| 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;
|
List.iter (fun (V (name, v)) -> Toploop.setvalue name (Obj.repr v)) values;
|
||||||
main_internal ~initial_env:(Some env)
|
main_internal ~initial_env:(Some env)
|
||||||
;;
|
;;
|
||||||
|
|
Loading…
Reference in New Issue