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

adjustments for ocaml 4 

Ignore-this: 8dcb773296b6ac7a6e83bb0b00f6697f

darcs-hash:20120615142321-c41ad-563f6c26dba5a942182e86a369167547ffbff121
This commit is contained in:
Jeremie Dimino 2012-06-15 16:23:21 +02:00
parent fbfd13b78e
commit 51f7caafb5
3 changed files with 97 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
src/lib/uTop.ml
View File

@ -253,6 +253,15 @@ let rec last head tail =
| head :: tail ->
last head tail
#if ocaml_version >= (4, 0, 0)
let with_loc loc str = {
Location.txt = str;
Location.loc = loc;
}
#else
let with_loc loc str = str
#endif
(* Check that the given phrase can be evaluated without typing/compile
errors. *)
let check_phrase phrase =
@ -283,11 +292,11 @@ let check_phrase phrase =
} in
let funct = {
Parsetree.pmod_loc = loc;
Parsetree.pmod_desc = Parsetree.Pmod_functor ("_", empty_sig, wrapped_items);
Parsetree.pmod_desc = Parsetree.Pmod_functor (with_loc loc "_", empty_sig, wrapped_items);
} in
let top_def = {
Parsetree.pstr_loc = loc;
Parsetree.pstr_desc = Parsetree.Pstr_module ("_", funct);
Parsetree.pstr_desc = Parsetree.Pstr_module (with_loc loc "_", funct);
} in
let check_phrase = Parsetree.Ptop_def [top_def] in
try

74
src/lib/uTop_complete.ml
View File

@ -338,28 +338,82 @@ let add_modules_from_directory acc dir =
acc
(Sys.readdir (if dir = "" then Filename.current_dir_name else dir))
#if ocaml_version >= (4, 0, 0)
let field_name (id, _, _) = Ident.name id
let constructor_name (id, _, _) = Ident.name id
#else
let field_name (name, _, _) = name
let constructor_name (name, _) = name
#endif
let add_fields_of_type decl acc =
match decl.type_kind with
| Type_variant constructors ->
acc
| Type_record(fields, _) ->
List.fold_left (fun acc (name, _, _) -> add name acc) acc fields
| Type_record (fields, _) ->
List.fold_left (fun acc field -> add (field_name field) acc) acc fields
| Type_abstract ->
acc
let add_names_of_type decl acc =
match decl.type_kind with
| Type_variant constructors ->
#if ocaml_version >= (3, 13, 0)
List.fold_left (fun acc (name, _, _) -> add name acc) acc constructors
#else
List.fold_left (fun acc (name, _) -> add name acc) acc constructors
#endif
| Type_record(fields, _) ->
List.fold_left (fun acc (name, _, _) -> add name acc) acc fields
List.fold_left (fun acc cstr -> add (constructor_name cstr) acc) acc constructors
| Type_record (fields, _) ->
List.fold_left (fun acc field -> add (field_name field) acc) acc fields
| Type_abstract ->
acc
#if ocaml_version >= (4, 0, 0)
let rec names_of_module_type = function
| Mty_signature decls ->
List.fold_left
(fun acc decl -> match decl with
| Sig_value (id, _)
| Sig_exception (id, _)
| Sig_module (id, _, _)
| Sig_modtype (id, _)
| Sig_class (id, _, _)
| Sig_class_type (id, _, _) ->
add (Ident.name id) acc
| Sig_type (id, decl, _) ->
add_names_of_type decl (add (Ident.name id) acc))
String_set.empty decls
| Mty_ident path -> begin
match lookup_env Env.find_modtype path !Toploop.toplevel_env with
| Some Modtype_abstract -> String_set.empty
| Some Modtype_manifest module_type -> names_of_module_type module_type
| None -> String_set.empty
end
| _ ->
String_set.empty
let rec fields_of_module_type = function
| Mty_signature decls ->
List.fold_left
(fun acc decl -> match decl with
| Sig_value (id, _)
| Sig_exception (id, _)
| Sig_module (id, _, _)
| Sig_modtype (id, _)
| Sig_class (id, _, _)
| Sig_class_type (id, _, _) ->
acc
| Sig_type (id, decl, _) ->
add_fields_of_type decl acc)
String_set.empty decls
| Mty_ident path -> begin
match lookup_env Env.find_modtype path !Toploop.toplevel_env with
| Some Modtype_abstract -> String_set.empty
| Some Modtype_manifest module_type -> fields_of_module_type module_type
| None -> String_set.empty
end
| _ ->
String_set.empty
#else
let rec names_of_module_type = function
| Tmty_signature decls ->
List.fold_left
@ -406,6 +460,8 @@ let rec fields_of_module_type = function
| _ ->
String_set.empty
#endif
let names_of_module longident =
try
Longident_map.find longident !local_names_by_longident

23
src/lib/uTop_main.ml
View File

@ -217,6 +217,15 @@ let print_out_phrase term string =
| Lwt_main.run auto-insertion |
+-----------------------------------------------------------------+ *)
#if ocaml_version >= (4, 0, 0)
let with_loc loc str = {
Location.txt = str;
Location.loc = loc;
}
#else
let with_loc loc str = str
#endif
let longident_lwt_main_run = Longident.Ldot (Longident.Lident "Lwt_main", "run")
let is_eval = function
@ -232,6 +241,14 @@ let rec is_lwt_t typ =
| _ ->
false
#if ocaml_version >= (4, 0, 0)
let str_items_of_typed_structure tstr = tstr.Typedtree.str_items
let str_desc_of_typed_str_item tstr = tstr.Typedtree.str_desc
#else
let str_items_of_typed_structure tstr = tstr
let str_desc_of_typed_str_item tstr = tstr
#endif
let insert_lwt_main_run phrase =
match phrase with
| Parsetree.Ptop_def pstr ->
@ -248,10 +265,11 @@ let insert_lwt_main_run phrase =
in
if lwt_main_run_is_the_real_one && List.exists is_eval pstr then
let tstr, _, _ = Typemod.type_structure env pstr Location.none in
let tstr = str_items_of_typed_structure tstr in
Parsetree.Ptop_def
(List.map2
(fun pstr_item tstr_item ->
match pstr_item, tstr_item with
match pstr_item, str_desc_of_typed_str_item tstr_item with
| { Parsetree.pstr_desc = Parsetree.Pstr_eval e; Parsetree.pstr_loc = loc },
Typedtree.Tstr_eval { Typedtree.exp_type = typ } when is_lwt_t typ ->
{
@ -259,7 +277,8 @@ let insert_lwt_main_run phrase =
Parsetree.Pstr_eval {
Parsetree.pexp_desc =
Parsetree.Pexp_apply
({ Parsetree.pexp_desc = Parsetree.Pexp_ident longident_lwt_main_run; Parsetree.pexp_loc = loc },
({ Parsetree.pexp_desc = Parsetree.Pexp_ident (with_loc loc longident_lwt_main_run);
Parsetree.pexp_loc = loc },
[("", e)]);
Parsetree.pexp_loc = loc;
};