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

make utop work with trunk

This commit is contained in:
Jeremie Dimino 2014-02-14 09:49:00 +00:00
parent db93b45222
commit 991ae65caa
5 changed files with 121 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/camlp4/uTop_camlp4.ml
View File

@ -13,7 +13,11 @@ open Camlp4.PreCast
module Ast2pt = Camlp4.Struct.Camlp4Ast2OCamlAst.Make(Ast)
#if ocaml_version < (4, 2, 0)
external cast_toplevel_phrase : Camlp4_import.Parsetree.toplevel_phrase -> Parsetree.toplevel_phrase = "%identity"
#else
let cast_toplevel_phrase x = x
#endif
let print_camlp4_error pp exn =
Format.fprintf pp "@[<0>%a@]" Camlp4.ErrorHandler.print exn;

18
src/lib/uTop.ml
View File

@ -249,6 +249,11 @@ let parse_default parse str eos_is_error =
| Syntaxerr.Variable_in_scope (loc, var) ->
Error ([mkloc loc],
Printf.sprintf "In this scoped type, variable '%s is reserved for the local type %s." var var)
#endif
#if ocaml_version >= (4, 2, 0)
| Syntaxerr.Not_expecting (loc, nonterm) ->
Error ([mkloc loc],
Printf.sprintf "Syntax error: %s not expected" nonterm)
#endif
end
| Syntaxerr.Escape_error | Parsing.Parse_error ->
@ -305,6 +310,7 @@ let check_phrase phrase =
let env = !Toploop.toplevel_env in
(* Construct "let _ () = let module _ = struct <items> end in ()" in order to test
the typing and compilation of [items] without evaluating them. *)
#if ocaml_version < (4, 2, 0)
let structure = {
pmod_loc = loc;
pmod_desc = Pmod_structure (item :: items);
@ -332,6 +338,18 @@ let check_phrase phrase =
ppat_loc = loc }, func)]);
pstr_loc = loc;
} in
#else
let top_def =
let open Ast_helper in
let open Convenience in
with_default_loc loc
(fun () ->
Str.eval
(Exp.letmodule (with_loc loc "_")
(Mod.structure (item :: items))
(unit ())))
in
#endif
let check_phrase = Ptop_def [top_def] in
try
let _ =

41
src/lib/uTop_complete.ml
View File

@ -369,7 +369,10 @@ let visible_modules () =
acc)
String_set.empty !Config.load_path)
#if ocaml_version >= (4, 0, 0)
#if ocaml_version >= (4, 2, 0)
let field_name { ld_id = id } = Ident.name id
let constructor_name { cd_id = id } = Ident.name id
#elif ocaml_version >= (4, 0, 0)
let field_name (id, _, _) = Ident.name id
let constructor_name (id, _, _) = Ident.name id
#else
@ -413,8 +416,13 @@ let rec names_of_module_type = function
String_set.empty decls
| Mty_ident path -> begin
match lookup_env Env.find_modtype path !Toploop.toplevel_env with
#if ocaml_version < (4, 2, 0)
| Some Modtype_abstract -> String_set.empty
| Some Modtype_manifest module_type -> names_of_module_type module_type
#else
| Some { mtd_type = None } -> String_set.empty
| Some { mtd_type = Some module_type } -> names_of_module_type module_type
#endif
| None -> String_set.empty
end
| _ ->
@ -436,8 +444,13 @@ let rec fields_of_module_type = function
String_set.empty decls
| Mty_ident path -> begin
match lookup_env Env.find_modtype path !Toploop.toplevel_env with
#if ocaml_version < (4, 2, 0)
| Some Modtype_abstract -> String_set.empty
| Some Modtype_manifest module_type -> fields_of_module_type module_type
#else
| Some { mtd_type = None } -> String_set.empty
| Some { mtd_type = Some module_type } -> fields_of_module_type module_type
#endif
| None -> String_set.empty
end
| _ ->
@ -493,11 +506,21 @@ let rec fields_of_module_type = function
#endif
#if ocaml_version < (4, 2, 0)
let lookup_module = Env.lookup_module
let find_module = Env.find_module
#else
let lookup_module id env =
let path = Env.lookup_module id env in
(path, Env.find_modtype_expansion path env)
let find_module path env = (Env.find_module path env).md_type
#endif
let names_of_module longident =
try
Longident_map.find longident !local_names_by_longident
with Not_found ->
match lookup_env Env.lookup_module longident !Toploop.toplevel_env with
match lookup_env lookup_module longident !Toploop.toplevel_env with
| Some(path, module_type) ->
let names = names_of_module_type module_type in
local_names_by_path := Path_map.add path names !local_names_by_path;
@ -511,7 +534,7 @@ let fields_of_module longident =
try
Longident_map.find longident !local_fields_by_longident
with Not_found ->
match lookup_env Env.lookup_module longident !Toploop.toplevel_env with
match lookup_env lookup_module longident !Toploop.toplevel_env with
| Some(path, module_type) ->
let fields = fields_of_module_type module_type in
local_fields_by_path := Path_map.add path fields !local_fields_by_path;
@ -538,12 +561,16 @@ let list_global_names () =
loop (add (Ident.name id) acc) summary
| Env.Env_cltype(summary, id, _) ->
loop (add (Ident.name id) acc) summary
#if ocaml_version >= (4, 2, 0)
| Env.Env_functor_arg(summary, id) ->
loop (add (Ident.name id) acc) summary
#endif
| Env.Env_open(summary, path) ->
match try Some (Path_map.find path !local_names_by_path) with Not_found -> None with
| Some names ->
loop (String_set.union acc names) summary
| None ->
match lookup_env Env.find_module path !Toploop.toplevel_env with
match lookup_env find_module path !Toploop.toplevel_env with
| Some module_type ->
let names = names_of_module_type module_type in
local_names_by_path := Path_map.add path names !local_names_by_path;
@ -589,6 +616,10 @@ let list_global_fields () =
loop (add (Ident.name id) acc) summary
| Env.Env_module(summary, id, _) ->
loop (add (Ident.name id) acc) summary
#if ocaml_version >= (4, 2, 0)
| Env.Env_functor_arg(summary, id) ->
loop (add (Ident.name id) acc) summary
#endif
| Env.Env_modtype(summary, id, _) ->
loop (add (Ident.name id) acc) summary
| Env.Env_class(summary, id, _) ->
@ -600,7 +631,7 @@ let list_global_fields () =
| Some fields ->
loop (String_set.union acc fields) summary
| None ->
match lookup_env Env.find_module path !Toploop.toplevel_env with
match lookup_env find_module path !Toploop.toplevel_env with
| Some module_type ->
let fields = fields_of_module_type module_type in
local_fields_by_path := Path_map.add path fields !local_fields_by_path;

79
src/lib/uTop_main.ml
View File

@ -344,6 +344,7 @@ let longident_async_thread_safe_block_on_async_exn =
Longident.parse "Async.Std.Thread_safe.block_on_async_exn"
let longident_unit = Longident.Lident "()"
#if ocaml_version < (4, 2, 0)
(* Wrap <expr> into: fun () -> <expr> *)
let wrap_unit loc e =
let i = with_loc loc longident_unit in
@ -355,19 +356,28 @@ let wrap_unit loc e =
Parsetree.pexp_desc = Parsetree.Pexp_function ("", None, [(p, e)]);
Parsetree.pexp_loc = loc;
}
#endif
let () =
(* Rewrite Lwt.t expressions to Lwt_main.run <expr> *)
Hashtbl.add rewrite_rules (Longident.Ldot (Longident.Lident "Lwt", "t")) {
required_values = [longident_lwt_main_run];
rewrite = (fun loc e -> {
Parsetree.pexp_desc =
Parsetree.Pexp_apply
({ Parsetree.pexp_desc = Parsetree.Pexp_ident (with_loc loc longident_lwt_main_run);
Parsetree.pexp_loc = loc },
[("", e)]);
Parsetree.pexp_loc = loc;
});
rewrite = (fun loc e ->
#if ocaml_version < (4, 2, 0)
{ Parsetree.pexp_desc =
Parsetree.Pexp_apply
({ Parsetree.pexp_desc = Parsetree.Pexp_ident (with_loc loc longident_lwt_main_run);
Parsetree.pexp_loc = loc },
[("", e)])
; Parsetree.pexp_loc = loc }
#else
let open Ast_helper in
let open Convenience in
with_default_loc loc (fun () ->
Exp.apply (Exp.ident (with_loc loc longident_lwt_main_run)) [("", e)]
)
#endif
);
enabled = UTop.auto_run_lwt;
};
@ -375,15 +385,25 @@ let () =
Async.Std.Thread_safe.block_on_async_exn (fun () -> <expr>). *)
let rule = {
required_values = [longident_async_thread_safe_block_on_async_exn];
rewrite = (fun loc e -> {
Parsetree.pexp_desc =
Parsetree.Pexp_apply
({ Parsetree.pexp_desc = Parsetree.Pexp_ident
(with_loc loc longident_async_thread_safe_block_on_async_exn);
Parsetree.pexp_loc = loc },
[("", wrap_unit loc e)]);
Parsetree.pexp_loc = loc;
});
rewrite = (fun loc e ->
#if ocaml_version < (4, 2, 0)
{ Parsetree.pexp_desc =
Parsetree.Pexp_apply
({ Parsetree.pexp_desc = Parsetree.Pexp_ident
(with_loc loc longident_async_thread_safe_block_on_async_exn);
Parsetree.pexp_loc = loc },
[("", wrap_unit loc e)])
; Parsetree.pexp_loc = loc }
#else
let open Ast_helper in
let open Convenience in
with_default_loc loc (fun () ->
Exp.apply
(Exp.ident (with_loc loc longident_async_thread_safe_block_on_async_exn))
[("", Exp.fun_ "" None (punit ()) e)]
)
#endif
);
enabled = UTop.auto_run_async;
} in
Hashtbl.add rewrite_rules (Longident.parse "Async_core.Ivar.Deferred.t") rule;
@ -448,6 +468,7 @@ let str_items_of_typed_structure tstr = tstr
let str_desc_of_typed_str_item tstr = tstr
#endif
#if ocaml_version < (4, 2, 0)
let rewrite_str_item pstr_item tstr_item =
match pstr_item, str_desc_of_typed_str_item tstr_item with
| ({ Parsetree.pstr_desc = Parsetree.Pstr_eval e;
@ -465,6 +486,25 @@ let rewrite_str_item pstr_item tstr_item =
end
| _ ->
pstr_item
#else
let rewrite_str_item pstr_item tstr_item =
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 }, _)) -> begin
match rule_of_type typ with
| Some rule ->
if React.S.value rule.enabled && List.for_all is_persistent_in_env rule.required_values then
{ Parsetree.pstr_desc = Parsetree.Pstr_eval (rule.rewrite loc e, []);
Parsetree.pstr_loc = loc }
else
pstr_item
| None ->
pstr_item
end
| _ ->
pstr_item
#endif
let rewrite phrase =
match phrase with
@ -963,7 +1003,12 @@ let typeof sid =
Some (Printtyp.tree_of_type_declaration id ty_decl Types.Trec_not)
with Not_found ->
try
#if ocaml_version < (4, 2, 0)
let (path, mod_typ) = Env.lookup_module id env in
#else
let path = Env.lookup_module id env in
let mod_typ = Env.find_modtype_expansion path env in
#endif
let id = Ident.create (Path.name path) in
Some (Printtyp.tree_of_module id mod_typ Types.Trec_not)
with Not_found ->

2
syntax/pa_optcomp.ml
View File

@ -288,7 +288,7 @@ let rec eval env = function
(* Boolean operations *)
| <:expr< not $x$ >> -> Bool(not (eval_bool env x))
| <:expr< $x$ or $y$ >> -> Bool(eval_bool env x or eval_bool env y)
| <:expr< $x$ or $y$ >> -> Bool(eval_bool env x || eval_bool env y)
| <:expr< $x$ || $y$ >> -> Bool(eval_bool env x || eval_bool env y)
| <:expr< $x$ && $y$ >> -> Bool(eval_bool env x && eval_bool env y)