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

change the trick for getting type errors 

Instead of generating "module (_ : sig end) = struct <phrase> end", we
generate "let _ () = let module _ = struct <phrase> end in ()". This
avoid type errors due to the use of first-class module inside a
functor.
This commit is contained in:
Jeremie Dimino 2013-07-15 09:24:18 +01:00
parent e02a18b4d7
commit 3df2cccf51
1 changed files with 31 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
src/lib/uTop.ml
View File

@ -276,40 +276,51 @@ let with_loc loc str = str
(* Check that the given phrase can be evaluated without typing/compile (* Check that the given phrase can be evaluated without typing/compile
errors. *) errors. *)
let check_phrase phrase = let check_phrase phrase =
let open Parsetree in
match phrase with match phrase with
| Parsetree.Ptop_dir _ -> | Ptop_dir _ ->
None None
| Parsetree.Ptop_def [] -> | Ptop_def [] ->
None None
| Parsetree.Ptop_def (item :: items) -> | Ptop_def (item :: items) ->
let loc = { let loc = {
Location.loc_start = item.Parsetree.pstr_loc.Location.loc_start; Location.loc_start = item.pstr_loc.Location.loc_start;
Location.loc_end = (last item items).Parsetree.pstr_loc.Location.loc_end; Location.loc_end = (last item items).pstr_loc.Location.loc_end;
Location.loc_ghost = false; Location.loc_ghost = false;
} in } in
(* Backup. *) (* Backup. *)
let snap = Btype.snapshot () in let snap = Btype.snapshot () in
let env = !Toploop.toplevel_env in let env = !Toploop.toplevel_env in
(* Construct "module _(_ : sig end) = struct <items> end" in (* Construct "let _ () = let module _ = struct <items> end in ()" in order to test
order to test the typing and compilation of [items] without the typing and compilation of [items] without evaluating them. *)
evaluating them. *) let structure = {
let wrapped_items = { pmod_loc = loc;
Parsetree.pmod_loc = loc; pmod_desc = Pmod_structure (item :: items);
Parsetree.pmod_desc = Parsetree.Pmod_structure (item :: items);
} in } in
let empty_sig = { let unit = with_loc loc (Longident.Lident "()") in
Parsetree.pmty_loc = loc; let unit_expr = {
Parsetree.pmty_desc = Parsetree.Pmty_signature []; pexp_desc = Pexp_construct (unit, None, false);
pexp_loc = loc;
} in } in
let funct = { let unit_patt = {
Parsetree.pmod_loc = loc; ppat_desc = Ppat_construct (unit, None, false);
Parsetree.pmod_desc = Parsetree.Pmod_functor (with_loc loc "_", empty_sig, wrapped_items); ppat_loc = loc;
} in
let letmodule = {
pexp_desc = Pexp_letmodule (with_loc loc "_", structure, unit_expr);
pexp_loc = loc;
} in
let func = {
pexp_desc = Pexp_function ("", None, [(unit_patt, letmodule)]);
pexp_loc = loc;
} in } in
let top_def = { let top_def = {
Parsetree.pstr_loc = loc; pstr_desc = Pstr_value (Asttypes.Nonrecursive,
Parsetree.pstr_desc = Parsetree.Pstr_module (with_loc loc "_", funct); [({ ppat_desc = Ppat_var (with_loc loc "_");
ppat_loc = loc }, func)]);
pstr_loc = loc;
} in } in
let check_phrase = Parsetree.Ptop_def [top_def] in let check_phrase = Ptop_def [top_def] in
try try
let _ = let _ =
discard_formatters [Format.err_formatter] (fun () -> discard_formatters [Format.err_formatter] (fun () ->