Resurect UTop_main.interact
This commit is contained in:
parent
a1d147022a
commit
202917d9d3
|
@ -13,6 +13,7 @@
|
||||||
* Drop support for camlp4/camlp5
|
* Drop support for camlp4/camlp5
|
||||||
* Drop support for OCaml <= 4.01
|
* Drop support for OCaml <= 4.01
|
||||||
* Switch the build system to jbuilder
|
* Switch the build system to jbuilder
|
||||||
|
* Resurect `UTop_main.interact`
|
||||||
|
|
||||||
1.19.3 (2016-08-15)
|
1.19.3 (2016-08-15)
|
||||||
-------------------
|
-------------------
|
||||||
|
|
2
Makefile
2
Makefile
|
@ -28,7 +28,7 @@ test:
|
||||||
|
|
||||||
.PHONY: all-supported-ocaml-versions
|
.PHONY: all-supported-ocaml-versions
|
||||||
all-supported-ocaml-versions:
|
all-supported-ocaml-versions:
|
||||||
jbuilder runtest --workspace jbuild-workspace.dev
|
jbuilder build --workspace jbuild-workspace.dev
|
||||||
|
|
||||||
.PHONY: cinaps
|
.PHONY: cinaps
|
||||||
cinaps:
|
cinaps:
|
||||||
|
|
|
@ -4,8 +4,7 @@ let some_value = [A 42; B "Hello, world"]
|
||||||
|
|
||||||
let () =
|
let () =
|
||||||
print_endline "Starting utop now!";
|
print_endline "Starting utop now!";
|
||||||
UTop_main.interact
|
UTop_main.interact ()
|
||||||
~search_path:["_build"]
|
|
||||||
~unit:__MODULE__
|
~unit:__MODULE__
|
||||||
~loc:__POS__
|
~loc:__POS__
|
||||||
~values:[V ("some_value", some_value)]
|
~values:[V ("some_value", some_value)]
|
||||||
|
|
|
@ -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)))
|
|
@ -1365,81 +1365,71 @@ let main () = main_internal ~initial_env:None
|
||||||
|
|
||||||
type value = V : string * _ -> value
|
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
|
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 =
|
let cmt_fname =
|
||||||
try
|
try
|
||||||
Misc.find_in_path_uncap search_path (unit ^ ".cmt")
|
Misc.find_in_path_uncap search_path (unit ^ ".cmt")
|
||||||
with Not_found ->
|
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
|
in
|
||||||
let cmt_infos = Cmt_format.read_cmt cmt_fname in
|
let cmt_infos = Cmt_format.read_cmt cmt_fname in
|
||||||
let search = object(self)
|
let module Search =
|
||||||
inherit [unit] UTop_cmt_lifter.lifter as super
|
TypedtreeIter.MakeIterator(struct
|
||||||
|
include TypedtreeIter.DefaultIteratorArgument
|
||||||
|
|
||||||
method! lift_Typedtree_expression e =
|
let enter_expression (e : Typedtree.expression) =
|
||||||
super#lift_Typedtree_expression e;
|
match e.exp_desc with
|
||||||
match e.exp_desc with
|
| Texp_apply (_, args) -> begin
|
||||||
| Texp_apply (_, args) -> begin
|
try
|
||||||
try
|
match get_required_label "loc" args,
|
||||||
match
|
get_required_label "values" args
|
||||||
#if OCAML_VERSION >= (4, 03, 0)
|
with
|
||||||
List.find (fun (lab, _) -> lab = Asttypes.Labelled "loc" ) args,
|
| Some l, Some v ->
|
||||||
List.find (fun (lab, _) -> lab = Asttypes.Labelled "values") args
|
let pos = l.exp_loc.loc_start in
|
||||||
#else
|
if pos.pos_fname = fname &&
|
||||||
List.find (fun (lab, _, _) -> lab = "loc" ) args,
|
pos.pos_lnum = lnum &&
|
||||||
List.find (fun (lab, _, _) -> lab = "values") args
|
pos.pos_cnum - pos.pos_bol = cnum then
|
||||||
#endif
|
raise (Found v.exp_env)
|
||||||
with
|
| _ -> ()
|
||||||
#if OCAML_VERSION >= (4, 03, 0)
|
with Not_found -> ()
|
||||||
| (Asttypes.Labelled _, Some l), (Asttypes.Labelled _, Some v) ->
|
end
|
||||||
#else
|
| _ -> ()
|
||||||
| (_, Some l, Required), (_, Some v, Required) ->
|
end) in
|
||||||
#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
|
|
||||||
try
|
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"
|
failwith "Couldn't find location in cmt file"
|
||||||
with Found env ->
|
with Found env ->
|
||||||
try
|
try
|
||||||
|
@ -1458,5 +1448,3 @@ let () =
|
||||||
Some (Location.error_of_printer_file Envaux.report_error err)
|
Some (Location.error_of_printer_file Envaux.report_error err)
|
||||||
| _ -> None
|
| _ -> None
|
||||||
)
|
)
|
||||||
|
|
||||||
#endif
|
|
||||||
|
|
|
@ -19,8 +19,10 @@ exception Term of int
|
||||||
type value = V : string * _ -> value
|
type value = V : string * _ -> value
|
||||||
|
|
||||||
val interact
|
val interact
|
||||||
: search_path:string list
|
: ?search_path:string list
|
||||||
|
-> ?build_dir:string
|
||||||
-> unit:string
|
-> unit:string
|
||||||
-> loc:(string * int * int * int)
|
-> loc:(string * int * int * int)
|
||||||
-> values:value list
|
-> values:value list
|
||||||
-> unit
|
-> unit
|
||||||
|
-> unit
|
||||||
|
|
|
@ -20,7 +20,4 @@ depends: [
|
||||||
"findlib.top" {>= "1.7.2"}
|
"findlib.top" {>= "1.7.2"}
|
||||||
"jbuilder" {build & >= "1.0+beta9"}
|
"jbuilder" {build & >= "1.0+beta9"}
|
||||||
]
|
]
|
||||||
depopts: [
|
available: [ ocaml-version >= "4.02.3" & ocaml-version < "4.06.0"]
|
||||||
"ppx_tools"
|
|
||||||
]
|
|
||||||
available: [ ocaml-version >= "4.02.3" ]
|
|
||||||
|
|
Loading…
Reference in New Issue