Resurect UTop_main.interact

This commit is contained in:
Jeremie Dimino 2017-05-26 15:26:27 +01:00
parent a1d147022a
commit 202917d9d3
7 changed files with 69 additions and 75 deletions

View File

@ -13,6 +13,7 @@
* Drop support for camlp4/camlp5
* Drop support for OCaml <= 4.01
* Switch the build system to jbuilder
* Resurect `UTop_main.interact`
1.19.3 (2016-08-15)
-------------------

View File

@ -28,7 +28,7 @@ test:
.PHONY: all-supported-ocaml-versions
all-supported-ocaml-versions:
jbuilder runtest --workspace jbuild-workspace.dev
jbuilder build --workspace jbuild-workspace.dev
.PHONY: cinaps
cinaps:

View File

@ -4,8 +4,7 @@ let some_value = [A 42; B "Hello, world"]
let () =
print_endline "Starting utop now!";
UTop_main.interact
~search_path:["_build"]
UTop_main.interact ()
~unit:__MODULE__
~loc:__POS__
~values:[V ("some_value", some_value)]

7
jbuild-workspace.dev Normal file
View File

@ -0,0 +1,7 @@
;; This file is used by `make all-supported-ocaml-versions`
(context ((switch 4.02.3)))
(context ((switch 4.03.0)))
(context ((switch 4.04.1)))
(context ((switch 4.05.0+trunk)))
;; 4.06 support is broken for now
;; (context ((switch 4.06.0+trunk)))

View File

@ -1365,81 +1365,71 @@ let main () = main_internal ~initial_env:None
type value = V : string * _ -> value
#if not defined ENABLE_INTERACT
let interact ~search_path ~unit ~loc:(fname, lnum, cnum, _) ~values =
failwith "\
UTop_main.interact wasn't enabled at compile time.
If you installed utop through opam, just do this to enable this feature:
$ opam install ppx_tools"
#else
exception Found of Env.t
let interact ~search_path ~unit ~loc:(fname, lnum, cnum, _) ~values =
#if OCAML_VERSION >= (4, 03, 0)
let get_required_label name args =
match List.find (fun (lab, _) -> lab = Asttypes.Labelled name) args with
| _, x -> x
| exception Not_found -> None
#else
let get_required_label name args =
match List.find (fun (lab, _, k) -> lab = "loc" && k = Typedtree.Required) args with
| _, x, _ -> x
| _ -> None
| exception Not_found -> None
#endif
let walk dir ~init ~f =
let rec loop dir acc =
let acc = f dir acc in
ArrayLabels.fold_left (Sys.readdir dir) ~init:acc ~f:(fun acc fn ->
let fn = Filename.concat dir fn in
match Unix.lstat fn with
| { st_kind = S_DIR; _ } -> loop fn acc
| _ -> acc)
in
match Unix.lstat dir with
| exception Unix.Unix_error(ENOENT, _, _) -> init
| _ -> loop dir init
let interact ?(search_path=[]) ?(build_dir="_build") ~unit ~loc:(fname, lnum, cnum, _)
~values =
let search_path = walk build_dir ~init:search_path ~f:(fun dir acc -> dir :: acc) 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
Printf.ksprintf failwith "%s.cmt not found in search path!" unit
in
let cmt_infos = Cmt_format.read_cmt cmt_fname in
let search = object(self)
inherit [unit] UTop_cmt_lifter.lifter as super
let module Search =
TypedtreeIter.MakeIterator(struct
include TypedtreeIter.DefaultIteratorArgument
method! lift_Typedtree_expression e =
super#lift_Typedtree_expression e;
match e.exp_desc with
| Texp_apply (_, args) -> begin
try
match
#if OCAML_VERSION >= (4, 03, 0)
List.find (fun (lab, _) -> lab = Asttypes.Labelled "loc" ) args,
List.find (fun (lab, _) -> lab = Asttypes.Labelled "values") args
#else
List.find (fun (lab, _, _) -> lab = "loc" ) args,
List.find (fun (lab, _, _) -> lab = "values") args
#endif
with
#if OCAML_VERSION >= (4, 03, 0)
| (Asttypes.Labelled _, Some l), (Asttypes.Labelled _, Some v) ->
#else
| (_, Some l, Required), (_, Some v, Required) ->
#endif
let pos = l.exp_loc.loc_start in
if pos.pos_fname = fname &&
pos.pos_lnum = lnum &&
pos.pos_cnum - pos.pos_bol = cnum then
raise (Found v.exp_env)
| _ -> ()
with Not_found -> ()
end
| _ -> ()
method! lift_Types_label_description _ = ()
method! lift_Types_type_declaration _ = ()
method tuple _ = ()
method string _ = ()
method record _ _ = ()
method nativeint _ = ()
method list _ = ()
method lift_Types_Vars_t _ _ = ()
method lift_Types_Variance_t _ = ()
method lift_Types_Meths_t _ _ = ()
method lift_Types_Concr_t _ = ()
method lift_Env_t _ = ()
method int64 _ = ()
method int32 _ = ()
method int _ = ()
method constr _ _ = ()
method char _ = ()
method array _ = ()
end in
let enter_expression (e : Typedtree.expression) =
match e.exp_desc with
| Texp_apply (_, args) -> begin
try
match get_required_label "loc" args,
get_required_label "values" args
with
| Some l, Some v ->
let pos = l.exp_loc.loc_start in
if pos.pos_fname = fname &&
pos.pos_lnum = lnum &&
pos.pos_cnum - pos.pos_bol = cnum then
raise (Found v.exp_env)
| _ -> ()
with Not_found -> ()
end
| _ -> ()
end) in
try
search#lift_Cmt_format_cmt_infos cmt_infos;
begin match cmt_infos.cmt_annots with
| Implementation st -> Search.iter_structure st
| _ -> ()
end;
failwith "Couldn't find location in cmt file"
with Found env ->
try
@ -1458,5 +1448,3 @@ let () =
Some (Location.error_of_printer_file Envaux.report_error err)
| _ -> None
)
#endif

View File

@ -19,8 +19,10 @@ exception Term of int
type value = V : string * _ -> value
val interact
: search_path:string list
: ?search_path:string list
-> ?build_dir:string
-> unit:string
-> loc:(string * int * int * int)
-> values:value list
-> unit
-> unit

View File

@ -20,7 +20,4 @@ depends: [
"findlib.top" {>= "1.7.2"}
"jbuilder" {build & >= "1.0+beta9"}
]
depopts: [
"ppx_tools"
]
available: [ ocaml-version >= "4.02.3" ]
available: [ ocaml-version >= "4.02.3" & ocaml-version < "4.06.0"]