haskal
/
utop
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

compatible with 4.08

This commit is contained in:
ZAN DoYe 2019-05-23 13:42:47 +08:00
parent 01c5361a17
commit ad510daa99
4 changed files with 151 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
src/lib/uTop.ml
View File

@ -248,7 +248,14 @@ let parse_default parse str eos_is_error =
(* If the string is empty, do not report an error. *) (* If the string is empty, do not report an error. *)
raise Need_more raise Need_more
| Lexer.Error (error, loc) -> | Lexer.Error (error, loc) ->
#if OCAML_VERSION >= (4, 08, 0)
(match Location.error_of_exn (Lexer.Error (error, loc)) with
| Some (`Ok error)->
Error ([mkloc loc], get_message Location.print_report error)
| _-> raise Need_more)
#else
Error ([mkloc loc], get_message Lexer.report_error error) Error ([mkloc loc], get_message Lexer.report_error error)
#endif
| Syntaxerr.Error error -> begin | Syntaxerr.Error error -> begin
match error with match error with
| Syntaxerr.Unclosed (opening_loc, opening, closing_loc, closing) -> | Syntaxerr.Unclosed (opening_loc, opening, closing_loc, closing) ->
@ -796,19 +803,13 @@ let () =
let () = let () =
(* "utop" is an internal library so it is not passed as "-package" (* "utop" is an internal library so it is not passed as "-package"
to "ocamlfind ocamlmktop". *) to "ocamlfind ocamlmktop". *)
Topfind.don't_load_deeply ["utop"]; try Topfind.don't_load_deeply ["utop"]; with Fl_package_base.No_such_package _-> ();
Topfind.add_predicates ["byte"; "toploop"]; Topfind.add_predicates ["byte"; "toploop"];
(* Add findlib path so Topfind is available and it won't be (* Add findlib path so Topfind is available and it won't be
initialized twice if the user does [#use "topfind"]. *) initialized twice if the user does [#use "topfind"]. *)
Topdirs.dir_directory (Findlib.package_directory "findlib"); Topdirs.dir_directory (Findlib.package_directory "findlib");
(* Make UTop accessible. *) (* Make UTop accessible. *)
Topdirs.dir_directory (Findlib.package_directory "utop") try Topdirs.dir_directory (Findlib.package_directory "utop") with Fl_package_base.No_such_package _-> ()
(* +-----------------------------------------------------------------+
| Compiler-libs re-exports |
+-----------------------------------------------------------------+ *)
let load_path = Config.load_path
(* +-----------------------------------------------------------------+ (* +-----------------------------------------------------------------+
| Deprecated | | Deprecated |

7
src/lib/uTop.mli
View File

@ -356,13 +356,6 @@ val discard_formatters : Format.formatter list -> (unit -> 'a) -> 'a
val split_words : string -> string list val split_words : string -> string list
(** {6 compiler-libs reexports} *)
val load_path : string list ref
(** [load_path] is an alias of [Config.load_path], normally hidden in toplevel.
It contains the list of directories added by findlib-required packages
and [#directory] directives. *)
(**/**) (**/**)
(* These variables are not used and deprecated: *) (* These variables are not used and deprecated: *)

98
src/lib/uTop_complete.ml
View File

@ -392,7 +392,12 @@ let visible_modules () =
(Sys.readdir (if dir = "" then Filename.current_dir_name else dir)) (Sys.readdir (if dir = "" then Filename.current_dir_name else dir))
with Sys_error _ -> with Sys_error _ ->
acc) acc)
String_set.empty !Config.load_path) #if OCAML_VERSION >= (4, 08, 0)
String_set.empty @@ Load_path.get_paths ()
#else
String_set.empty !Config.load_path
#endif
)
let field_name { ld_id = id } = Ident.name id let field_name { ld_id = id } = Ident.name id
let constructor_name { cd_id = id } = Ident.name id let constructor_name { cd_id = id } = Ident.name id
@ -419,6 +424,11 @@ let add_names_of_type decl acc =
| Type_open -> | Type_open ->
acc acc
#if OCAML_VERSION >= (4, 08, 0)
let path_of_mty_alias = function
| Mty_alias path -> path
| _ -> assert false
#else
#if OCAML_VERSION >= (4, 04, 0) #if OCAML_VERSION >= (4, 04, 0)
let path_of_mty_alias = function let path_of_mty_alias = function
| Mty_alias (_, path) -> path | Mty_alias (_, path) -> path
@ -428,19 +438,33 @@ let path_of_mty_alias = function
| Mty_alias path -> path | Mty_alias path -> path
| _ -> assert false | _ -> assert false
#endif #endif
#endif
let rec names_of_module_type = function let rec names_of_module_type = function
| Mty_signature decls -> | Mty_signature decls ->
List.fold_left List.fold_left
(fun acc decl -> match decl with (fun acc decl -> match decl with
#if OCAML_VERSION >= (4, 08, 0)
| Sig_value (id, _, _)
| Sig_typext (id, _, _, _)
| Sig_module (id, _, _, _, _)
| Sig_modtype (id, _, _)
| Sig_class (id, _, _, _)
| Sig_class_type (id, _, _, _) ->
#else
| Sig_value (id, _) | Sig_value (id, _)
| Sig_typext (id, _, _) | Sig_typext (id, _, _)
| Sig_module (id, _, _) | Sig_module (id, _, _)
| Sig_modtype (id, _) | Sig_modtype (id, _)
| Sig_class (id, _, _) | Sig_class (id, _, _)
| Sig_class_type (id, _, _) -> | Sig_class_type (id, _, _) ->
#endif
add (Ident.name id) acc add (Ident.name id) acc
#if OCAML_VERSION >= (4, 08, 0)
| Sig_type (id, decl, _, _) ->
#else
| Sig_type (id, decl, _) -> | Sig_type (id, decl, _) ->
#endif
add_names_of_type decl (add (Ident.name id) acc)) add_names_of_type decl (add (Ident.name id) acc))
String_set.empty decls String_set.empty decls
| Mty_ident path -> begin | Mty_ident path -> begin
@ -462,14 +486,18 @@ let rec fields_of_module_type = function
| Mty_signature decls -> | Mty_signature decls ->
List.fold_left List.fold_left
(fun acc decl -> match decl with (fun acc decl -> match decl with
| Sig_value (id, _) | Sig_value _
| Sig_typext (id, _, _) | Sig_typext _
| Sig_module (id, _, _) | Sig_module _
| Sig_modtype (id, _) | Sig_modtype _
| Sig_class (id, _, _) | Sig_class _
| Sig_class_type (id, _, _) -> | Sig_class_type _ ->
acc acc
| Sig_type (id, decl, _) -> #if OCAML_VERSION >= (4, 08, 0)
| Sig_type (_, decl, _, _) ->
#else
| Sig_type (_, decl, _) ->
#endif
add_fields_of_type decl acc) add_fields_of_type decl acc)
String_set.empty decls String_set.empty decls
| Mty_ident path -> begin | Mty_ident path -> begin
@ -529,7 +557,11 @@ let list_global_names () =
loop (add_names_of_type decl (add (Ident.name id) acc)) summary loop (add_names_of_type decl (add (Ident.name id) acc)) summary
| Env.Env_extension(summary, id, _) -> | Env.Env_extension(summary, id, _) ->
loop (add (Ident.name id) acc) summary loop (add (Ident.name id) acc) summary
#if OCAML_VERSION >= (4, 08, 0)
| Env.Env_module(summary, id, _, _) ->
#else
| Env.Env_module(summary, id, _) -> | Env.Env_module(summary, id, _) ->
#endif
loop (add (Ident.name id) acc) summary loop (add (Ident.name id) acc) summary
| Env.Env_modtype(summary, id, _) -> | Env.Env_modtype(summary, id, _) ->
loop (add (Ident.name id) acc) summary loop (add (Ident.name id) acc) summary
@ -539,18 +571,31 @@ let list_global_names () =
loop (add (Ident.name id) acc) summary loop (add (Ident.name id) acc) summary
| Env.Env_functor_arg(summary, id) -> | Env.Env_functor_arg(summary, id) ->
loop (add (Ident.name id) acc) summary loop (add (Ident.name id) acc) summary
#if OCAML_VERSION >= (4, 08, 0)
| Env.Env_persistent (summary, id) ->
loop (add (Ident.name id) acc) summary
#endif
#if OCAML_VERSION >= (4, 04, 0) #if OCAML_VERSION >= (4, 04, 0)
| Env.Env_constraints (summary, _) -> | Env.Env_constraints (summary, _) ->
loop acc summary loop acc summary
#endif #endif
#if OCAML_VERSION >= (4, 08, 0)
| Env.Env_copy_types (summary, _) ->
loop acc summary
#else
#if OCAML_VERSION >= (4, 06, 0) #if OCAML_VERSION >= (4, 06, 0)
| Env.Env_copy_types (summary, _) -> | Env.Env_copy_types (summary, _) ->
loop acc summary loop acc summary
#endif #endif
#if OCAML_VERSION >= (4, 07, 0) #endif
| Env.Env_open(summary, _, path) -> #if OCAML_VERSION >= (4, 08, 0)
| Env.Env_open(summary, path) ->
#else #else
| Env.Env_open(summary, path) -> #if OCAML_VERSION >= (4, 07, 0)
| Env.Env_open(summary, _, path) ->
#else
| Env.Env_open(summary, path) ->
#endif
#endif #endif
match try Some (Path_map.find path !local_names_by_path) with Not_found -> None with match try Some (Path_map.find path !local_names_by_path) with Not_found -> None with
| Some names -> | Some names ->
@ -600,7 +645,11 @@ let list_global_fields () =
loop (add_fields_of_type decl (add (Ident.name id) acc)) summary loop (add_fields_of_type decl (add (Ident.name id) acc)) summary
| Env.Env_extension(summary, id, _) -> | Env.Env_extension(summary, id, _) ->
loop (add (Ident.name id) acc) summary loop (add (Ident.name id) acc) summary
#if OCAML_VERSION >= (4, 08, 0)
| Env.Env_module(summary, id, _, _) ->
#else
| Env.Env_module(summary, id, _) -> | Env.Env_module(summary, id, _) ->
#endif
loop (add (Ident.name id) acc) summary loop (add (Ident.name id) acc) summary
| Env.Env_functor_arg(summary, id) -> | Env.Env_functor_arg(summary, id) ->
loop (add (Ident.name id) acc) summary loop (add (Ident.name id) acc) summary
@ -610,6 +659,10 @@ let list_global_fields () =
loop (add (Ident.name id) acc) summary loop (add (Ident.name id) acc) summary
| Env.Env_cltype(summary, id, _) -> | Env.Env_cltype(summary, id, _) ->
loop (add (Ident.name id) acc) summary loop (add (Ident.name id) acc) summary
#if OCAML_VERSION >= (4, 08, 0)
| Env.Env_persistent (summary, id) ->
loop (add (Ident.name id) acc) summary
#endif
#if OCAML_VERSION >= (4, 04, 0) #if OCAML_VERSION >= (4, 04, 0)
| Env.Env_constraints (summary, _) -> | Env.Env_constraints (summary, _) ->
loop acc summary loop acc summary
@ -619,7 +672,11 @@ let list_global_fields () =
loop acc summary loop acc summary
#endif #endif
#if OCAML_VERSION >= (4, 07, 0) #if OCAML_VERSION >= (4, 07, 0)
| Env.Env_open(summary, _, path) -> #if OCAML_VERSION >= (4, 08, 0)
| Env.Env_open(summary, path) ->
#else
| Env.Env_open(summary, _, path) ->
#endif
#else #else
| Env.Env_open(summary, path) -> | Env.Env_open(summary, path) ->
#endif #endif
@ -876,7 +933,14 @@ let complete ~syntax ~phrase_terminator ~input =
List.fold_left List.fold_left
(fun acc d -> add_files filter acc (Filename.concat d dir)) (fun acc d -> add_files filter acc (Filename.concat d dir))
String_map.empty String_map.empty
(Filename.current_dir_name :: !Config.load_path) (Filename.current_dir_name ::
#if OCAML_VERSION >= (4, 08, 0)
(Load_path.get_paths ())
#else
!Config.load_path
#endif
)
else else
add_files filter String_map.empty (Filename.dirname file) add_files filter String_map.empty (Filename.dirname file)
in in
@ -933,7 +997,13 @@ let complete ~syntax ~phrase_terminator ~input =
List.fold_left List.fold_left
(fun acc d -> add_files filter acc (Filename.concat d dir)) (fun acc d -> add_files filter acc (Filename.concat d dir))
String_map.empty String_map.empty
(Filename.current_dir_name :: !Config.load_path) (Filename.current_dir_name ::
#if OCAML_VERSION >= (4, 08, 0)
(Load_path.get_paths ())
#else
!Config.load_path
#endif
)
else else
add_files filter String_map.empty (Filename.dirname file) add_files filter String_map.empty (Filename.dirname file)
in in

58
src/lib/uTop_main.ml
View File

@ -518,7 +518,11 @@ let rule_path rule =
(* Returns whether the given path is persistent. *) (* Returns whether the given path is persistent. *)
let rec is_persistent_path = function let rec is_persistent_path = function
| Path.Pident id -> Ident.persistent id | Path.Pident id -> Ident.persistent id
#if OCAML_VERSION >= (4, 08, 0)
| Path.Pdot (p, _) -> is_persistent_path p
#else
| Path.Pdot (p, _, _) -> is_persistent_path p | Path.Pdot (p, _, _) -> is_persistent_path p
#endif
| Path.Papply (_, p) -> is_persistent_path p | Path.Papply (_, p) -> is_persistent_path p
(* Check that the given long identifier is present in the environment (* Check that the given long identifier is present in the environment
@ -572,7 +576,11 @@ let rewrite phrase =
match phrase with match phrase with
| Parsetree.Ptop_def pstr -> | Parsetree.Ptop_def pstr ->
if (UTop.get_auto_run_lwt () || UTop.get_auto_run_async ()) && List.exists is_eval pstr then if (UTop.get_auto_run_lwt () || UTop.get_auto_run_async ()) && List.exists is_eval pstr then
#if OCAML_VERSION >= (4, 08, 0)
let tstr, _, _, _ = Typemod.type_structure !Toploop.toplevel_env pstr Location.none in
#else
let tstr, _, _ = Typemod.type_structure !Toploop.toplevel_env pstr Location.none in let tstr, _, _ = Typemod.type_structure !Toploop.toplevel_env pstr Location.none in
#endif
Parsetree.Ptop_def (List.map2 rewrite_str_item pstr tstr.Typedtree.str_items) Parsetree.Ptop_def (List.map2 rewrite_str_item pstr tstr.Typedtree.str_items)
else else
phrase phrase
@ -589,6 +597,9 @@ let add_let binding_name def =
{ {
pvb_pat = { pvb_pat = {
ppat_desc = Ppat_var { txt = binding_name; loc = pstr_loc; }; ppat_desc = Ppat_var { txt = binding_name; loc = pstr_loc; };
#if OCAML_VERSION >= (4, 08, 0)
ppat_loc_stack= [];
#endif
ppat_loc = pstr_loc; ppat_loc = pstr_loc;
ppat_attributes = []; ppat_attributes = [];
}; };
@ -626,12 +637,27 @@ let execute_phrase =
let rec collect_printers path signature acc = let rec collect_printers path signature acc =
List.fold_left (fun acc item -> List.fold_left (fun acc item ->
match (item : Types.signature_item) with match (item : Types.signature_item) with
#if OCAML_VERSION >= (4, 08, 0)
| Sig_module (id, _, {md_type = Mty_signature s; _}, _, _) ->
#else
| Sig_module (id, {md_type = Mty_signature s; _}, _) -> | Sig_module (id, {md_type = Mty_signature s; _}, _) ->
#endif
collect_printers (Longident.Ldot (path, Ident.name id)) s acc collect_printers (Longident.Ldot (path, Ident.name id)) s acc
#if OCAML_VERSION >= (4, 08, 0)
| Sig_value (id, vd, _) ->
#else
| Sig_value (id, vd) -> | Sig_value (id, vd) ->
#endif
#if OCAML_VERSION >= (4, 08, 0)
if List.exists (fun attr->
let open Parsetree in
match attr.attr_name with
| {Asttypes.txt = "toplevel_printer" | "ocaml.toplevel_printer"; _} ->
#else
if List.exists (function if List.exists (function
| {Asttypes.txt = "toplevel_printer" | "ocaml.toplevel_printer"; _}, | {Asttypes.txt = "toplevel_printer" | "ocaml.toplevel_printer"; _},
_ -> _ ->
#endif
true true
| _ -> false) | _ -> false)
vd.val_attributes vd.val_attributes
@ -1149,29 +1175,49 @@ let typeof sid =
let out_sig_item = let out_sig_item =
try try
let (path, ty_decl) = lookup_type id env in let (path, ty_decl) = lookup_type id env in
#if OCAML_VERSION >= (4, 08, 0)
let id = Ident.create_local (Path.name path) in
#else
let id = Ident.create (Path.name path) in let id = Ident.create (Path.name path) in
#endif
Some (Printtyp.tree_of_type_declaration id ty_decl Types.Trec_not) Some (Printtyp.tree_of_type_declaration id ty_decl Types.Trec_not)
with Not_found -> with Not_found ->
try try
let (path, val_descr) = Env.lookup_value id env in let (path, val_descr) = Env.lookup_value id env in
#if OCAML_VERSION >= (4, 08, 0)
let id = Ident.create_local (Path.name path) in
#else
let id = Ident.create (Path.name path) in let id = Ident.create (Path.name path) in
#endif
Some (Printtyp.tree_of_value_description id val_descr) Some (Printtyp.tree_of_value_description id val_descr)
with Not_found -> with Not_found ->
try try
let lbl_desc = Env.lookup_label id env in let lbl_desc = Env.lookup_label id env in
let (path, ty_decl) = from_type_desc lbl_desc.Types.lbl_res.Types.desc in let (path, ty_decl) = from_type_desc lbl_desc.Types.lbl_res.Types.desc in
#if OCAML_VERSION >= (4, 08, 0)
let id = Ident.create_local (Path.name path) in
#else
let id = Ident.create (Path.name path) in let id = Ident.create (Path.name path) in
#endif
Some (Printtyp.tree_of_type_declaration id ty_decl Types.Trec_not) Some (Printtyp.tree_of_type_declaration id ty_decl Types.Trec_not)
with Not_found -> with Not_found ->
try try
let path = Env.lookup_module id env ~load:true in let path = Env.lookup_module id env ~load:true in
let mod_typ = (Env.find_module path env).Types.md_type in let mod_typ = (Env.find_module path env).Types.md_type in
#if OCAML_VERSION >= (4, 08, 0)
let id = Ident.create_local (Path.name path) in
#else
let id = Ident.create (Path.name path) in let id = Ident.create (Path.name path) in
#endif
Some (Printtyp.tree_of_module id mod_typ Types.Trec_not) Some (Printtyp.tree_of_module id mod_typ Types.Trec_not)
with Not_found -> with Not_found ->
try try
let (path, mty_decl) = Env.lookup_modtype id env in let (path, mty_decl) = Env.lookup_modtype id env in
#if OCAML_VERSION >= (4, 08, 0)
let id = Ident.create_local (Path.name path) in
#else
let id = Ident.create (Path.name path) in let id = Ident.create (Path.name path) in
#endif
Some (Printtyp.tree_of_modtype_declaration id mty_decl) Some (Printtyp.tree_of_modtype_declaration id mty_decl)
with Not_found -> with Not_found ->
try try
@ -1179,7 +1225,11 @@ let typeof sid =
match cstr_desc.Types.cstr_tag with match cstr_desc.Types.cstr_tag with
| _ -> | _ ->
let (path, ty_decl) = from_type_desc cstr_desc.Types.cstr_res.Types.desc in let (path, ty_decl) = from_type_desc cstr_desc.Types.cstr_res.Types.desc in
#if OCAML_VERSION >= (4, 08, 0)
let id = Ident.create_local (Path.name path) in
#else
let id = Ident.create (Path.name path) in let id = Ident.create (Path.name path) in
#endif
Some (Printtyp.tree_of_type_declaration id ty_decl Types.Trec_not) Some (Printtyp.tree_of_type_declaration id ty_decl Types.Trec_not)
with Not_found -> with Not_found ->
None None
@ -1260,7 +1310,11 @@ let print_version_num () =
let autoload = ref true let autoload = ref true
let args = Arg.align [ let args = Arg.align [
#if OCAML_VERSION >= (4, 08, 0)
"-absname", Arg.Set Clflags.absname, " Show absolute filenames in error message";
#else
"-absname", Arg.Set Location.absname, " Show absolute filenames in error message"; "-absname", Arg.Set Location.absname, " Show absolute filenames in error message";
#endif
"-I", Arg.String (fun dir -> Clflags.include_dirs := dir :: !Clflags.include_dirs), "<dir> Add <dir> to the list of include directories"; "-I", Arg.String (fun dir -> Clflags.include_dirs := dir :: !Clflags.include_dirs), "<dir> Add <dir> to the list of include directories";
"-init", Arg.String (fun s -> Clflags.init_file := Some s), "<file> Load <file> instead of default init file"; "-init", Arg.String (fun s -> Clflags.init_file := Some s), "<file> Load <file> instead of default init file";
"-labels", Arg.Clear Clflags.classic, " Use commuting label mode"; "-labels", Arg.Clear Clflags.classic, " Use commuting label mode";
@ -1276,7 +1330,11 @@ let args = Arg.align [
"-rectypes", Arg.Set Clflags.recursive_types, " Allow arbitrary recursive types"; "-rectypes", Arg.Set Clflags.recursive_types, " Allow arbitrary recursive types";
"-stdin", Arg.Unit (fun () -> run_script ""), " Read script from standard input"; "-stdin", Arg.Unit (fun () -> run_script ""), " Read script from standard input";
"-strict-sequence", Arg.Set Clflags.strict_sequence, " Left-hand part of a sequence must have type unit"; "-strict-sequence", Arg.Set Clflags.strict_sequence, " Left-hand part of a sequence must have type unit";
#if OCAML_VERSION >= (4, 08, 0)
"-unsafe", Arg.Set Clflags.unsafe, " Do not compile bounds checking on array and string access";
#else
"-unsafe", Arg.Set Clflags.fast, " Do not compile bounds checking on array and string access"; "-unsafe", Arg.Set Clflags.fast, " Do not compile bounds checking on array and string access";
#endif
"-version", Arg.Unit print_version, " Print version and exit"; "-version", Arg.Unit print_version, " Print version and exit";
"-vnum", Arg.Unit print_version_num, " Print version number and exit"; "-vnum", Arg.Unit print_version_num, " Print version number and exit";
"-w", Arg.String (Warnings.parse_options false), "-w", Arg.String (Warnings.parse_options false),