diff --git a/src/lib/uTop.ml b/src/lib/uTop.ml index 1034ec8..fcc2e58 100644 --- a/src/lib/uTop.ml +++ b/src/lib/uTop.ml @@ -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 diff --git a/src/lib/uTop_complete.ml b/src/lib/uTop_complete.ml index 2d3a461..a42fdb4 100644 --- a/src/lib/uTop_complete.ml +++ b/src/lib/uTop_complete.ml @@ -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 diff --git a/src/lib/uTop_main.ml b/src/lib/uTop_main.ml index bbdcd8b..1948335 100644 --- a/src/lib/uTop_main.ml +++ b/src/lib/uTop_main.ml @@ -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; };