adjustments for ocaml 4

Ignore-this: 8dcb773296b6ac7a6e83bb0b00f6697f

darcs-hash:20120615142321-c41ad-563f6c26dba5a942182e86a369167547ffbff121

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

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, _) ->
+    | Type_record (fields, _) ->
-        List.fold_left (fun acc (name, _, _) -> add name acc) acc 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 cstr -> add (constructor_name cstr) acc) acc constructors
-        List.fold_left (fun acc (name, _, _) -> add name acc) acc constructors
+    | Type_record (fields, _) ->
-#else
+        List.fold_left (fun acc field -> add (field_name field) acc) acc fields
-        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
     | 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

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;
                             };