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

Remove camlp4 remnants

This commit is contained in:
Anton Kochkov 2019-07-08 15:30:37 +08:00 committed by Perry E. Metzger
parent 0c17ffa6b2
commit ca00ce6146
8 changed files with 50 additions and 196 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
src/lib/uTop.ml
View File

@ -66,15 +66,9 @@ let make_variable ?eq x =
let set v = set v in
(signal, (fun () -> S.value signal), set)
type syntax =
| Normal
| Camlp4o
| Camlp4r
let hide_reserved, get_hide_reserved, set_hide_reserved = make_variable true
let create_implicits, get_create_implicits, set_create_implicits = make_variable false
let show_box, get_show_box, set_show_box = make_variable true
let syntax, get_syntax, set_syntax = make_variable Normal
let phrase_terminator, get_phrase_terminator, set_phrase_terminator = make_variable ";;"
let auto_run_lwt, get_auto_run_lwt, set_auto_run_lwt = make_variable true
let auto_run_async, get_auto_run_async, set_auto_run_async = make_variable true
@ -661,7 +655,7 @@ let () =
Hashtbl.add Toploop.directive_table "utop_save" (Toploop.Directive_string fn)
(* +-----------------------------------------------------------------+
| Camlp4 |
| Findlib stuff |
+-----------------------------------------------------------------+ *)
let print_error msg =
@ -681,55 +675,6 @@ let handle_findlib_error = function
| exn ->
raise exn
let check_for_camlp4_support () =
try
ignore (Fl_package_base.query "utop.camlp4");
true
with Fl_package_base.No_such_package("utop.camlp4", "") ->
Lwt_main.run (print_error "utop was built without camlp4 support.\n");
false
let set_syntax syntax =
match get_syntax (), syntax with
| Normal, Normal
| Camlp4o, Camlp4o
| Camlp4r, Camlp4r ->
()
| (Camlp4o | Camlp4r), _ ->
Lwt_main.run (print_error "Camlp4 already loaded, you cannot change the syntax now.\n")
| Normal, Camlp4o ->
if check_for_camlp4_support () then begin
Topfind.syntax "camlp4o";
Topfind.load_deeply ["utop.camlp4"];
set_syntax Camlp4o;
set_phrase_terminator ";;"
end
| Normal, Camlp4r ->
if check_for_camlp4_support () then begin
Topfind.syntax "camlp4r";
Topfind.load_deeply ["utop.camlp4"];
set_syntax Camlp4r;
set_phrase_terminator ";";
add_keyword "value"
end
let () =
Hashtbl.add
Toploop.directive_table
"camlp4o"
(Toploop.Directive_none
(fun () -> set_syntax Camlp4o));
Hashtbl.add
Toploop.directive_table
"camlp4r"
(Toploop.Directive_none
(fun () -> set_syntax Camlp4r))
(* +-----------------------------------------------------------------+
| Findlib stuff |
+-----------------------------------------------------------------+ *)
let topfind_log, set_topfind_log = S.create ~eq:(fun _ _ -> false) []
let () =
@ -781,11 +726,7 @@ let split_words str =
let require packages =
try
let eff_packages = Findlib.package_deep_ancestors !Topfind.predicates packages in
if get_syntax () = Normal && List.mem "camlp4" eff_packages then begin
set_syntax Camlp4o;
Topfind.load_deeply packages
end else
Topfind.load eff_packages
Topfind.load eff_packages
with exn ->
handle_findlib_error exn

28
src/lib/uTop.mli
View File

@ -101,34 +101,6 @@ val set_margin_function : (LTerm_geom.size -> int option) -> unit
]}
*)
(** Syntax. *)
type syntax =
| Normal
(** No camlp4. *)
| Camlp4o
(** Camlp4, original syntax. *)
| Camlp4r
(** Camlp4, revised syntax. *)
val syntax : syntax signal
(** The syntax in use. If it is {!Camlp4o} or {!Camlp4r} quotations
are recognized. It is modified when you type [#camlp4o] or
[#camlp4r]. At the beginning it is {!Normal}. *)
val get_syntax : unit -> syntax
(** Returns the current value of {!syntax}. *)
val set_syntax : syntax -> unit
(** Changes the syntax used in utop. If the syntax is the same as
the current one, it does nothing. Otherwise it loads camlp4 and
setup several configuration variables.
Notes:
- the syntax can only be changed once. Once you set it to
{!Camlp4o} or {!Camlp4r} you cannot change it again.
- Typing [#camlp4o] is the same as calling [set_syntax Camlp4o].
- Typing [#camlp4r] is the same as calling [set_syntax Camlp4r]. *)
val phrase_terminator : string signal
(** The phrase terminator. It is ";;" by default and ";" when you
use revised syntax. *)

39
src/lib/uTop_complete.ml
View File

@ -623,19 +623,6 @@ let replace x y set =
else
set
let global_names_revised () =
get_cached global_names_revised
(fun () ->
let set = global_names () in
replace "true" "True" (replace "false" "False" set))
let global_names syntax =
match syntax with
| UTop.Normal | UTop.Camlp4o ->
global_names ()
| UTop.Camlp4r ->
global_names_revised ()
let list_global_fields () =
let rec loop acc = function
| Env.Env_empty -> acc
@ -873,15 +860,9 @@ and find_context_in_quotation = function
| Completion |
+-----------------------------------------------------------------+ *)
let complete ~syntax ~phrase_terminator ~input =
let true_name, false_name =
match syntax with
| UTop.Normal | UTop.Camlp4o ->
("true", "false")
| UTop.Camlp4r ->
("True", "False")
in
let tokens = UTop_lexer.lex_string syntax input in
let complete ~phrase_terminator ~input =
let true_name, false_name = ("true", "false") in
let tokens = UTop_lexer.lex_string input in
(* Filter blanks and comments. *)
let tokens = filter tokens in
match tokens with
@ -918,7 +899,7 @@ let complete ~syntax ~phrase_terminator ~input =
let start = loc.idx1 + 1 + (String.length prefix - String.length last_prefix) in
(start, List.map (fun w -> (w, "")) compls)
| _ ->
let set = global_names syntax in
let set = global_names () in
let compls = lookup prefix (String_set.elements set) in
(loc.idx1 + 1, List.map (fun w -> (w, "")) compls)
end
@ -1029,7 +1010,7 @@ let complete ~syntax ~phrase_terminator ~input =
| Some (Toploop.Directive_string _) -> [(" \"", "")]
| Some (Toploop.Directive_bool _) -> [(true_name, phrase_terminator); (false_name, phrase_terminator)]
| Some (Toploop.Directive_int _) -> []
| Some (Toploop.Directive_ident _) -> List.map (fun w -> (w, "")) (String_set.elements (global_names syntax))
| Some (Toploop.Directive_ident _) -> List.map (fun w -> (w, "")) (String_set.elements (global_names ()))
| None -> [])
| (Symbol "#", _) :: ((Lident dir | Uident dir), _) :: tokens -> begin
match try Some (Hashtbl.find Toploop.directive_table dir) with Not_found -> None with
@ -1049,7 +1030,7 @@ let complete ~syntax ~phrase_terminator ~input =
| Some (Toploop.Directive_ident _) -> begin
match parse_longident (List.rev tokens) with
| Some (Value, None, start, id) ->
(start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (global_names syntax))))
(start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (global_names ()))))
| Some (Value, Some longident, start, id) ->
(start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (names_of_module longident))))
| _ ->
@ -1065,7 +1046,7 @@ let complete ~syntax ~phrase_terminator ~input =
| None ->
(0, [])
| Some [] ->
(0, List.map (fun w -> (w, "")) (String_set.elements (String_set.union !UTop.keywords (global_names syntax))))
(0, List.map (fun w -> (w, "")) (String_set.elements (String_set.union !UTop.keywords (global_names ()))))
| Some tokens ->
match parse_method tokens with
| Some (longident, meths, start, meth) ->
@ -1085,7 +1066,7 @@ let complete ~syntax ~phrase_terminator ~input =
| None ->
(0, [])
| Some (Value, None, start, id) ->
(start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (String_set.union !UTop.keywords (global_names syntax)))))
(start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (String_set.union !UTop.keywords (global_names ())))))
| Some (Value, Some longident, start, id) ->
(start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (names_of_module longident))))
| Some (Field, None, start, id) ->
@ -1093,8 +1074,8 @@ let complete ~syntax ~phrase_terminator ~input =
| Some (Field, Some longident, start, id) ->
(start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (fields_of_module longident))))
let complete ~syntax ~phrase_terminator ~input =
let complete ~phrase_terminator ~input =
try
(complete ~syntax ~phrase_terminator ~input : int * (string * string) list)
(complete ~phrase_terminator ~input : int * (string * string) list)
with Cmi_format.Error _ ->
(0, [])

4
src/lib/uTop_complete.mli
View File

@ -9,8 +9,8 @@
(** OCaml completion. *)
val complete : syntax : UTop.syntax -> phrase_terminator : string -> input : string -> int * (string * string) list
(** [complete ~syntax ~phrase_terminator ~input] returns the start
val complete : phrase_terminator : string -> input : string -> int * (string * string) list
(** [complete ~phrase_terminator ~input] returns the start
of the completed word in [input] and the list of possible
completions with their suffixes. *)

4
src/lib/uTop_lexer.mli
View File

@ -7,6 +7,6 @@
* This file is a part of utop.
*)
val lex_string : UTop.syntax -> string -> (UTop_token.t * UTop_token.location) list
(** [lex_string syntax str] returns all the tokens contained in
val lex_string : string -> (UTop_token.t * UTop_token.location) list
(** [lex_string str] returns all the tokens contained in
[str]. *)

96
src/lib/uTop_lexer.mll
View File

@ -75,36 +75,28 @@ let float_literal =
let symbolchar =
['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~']
rule tokens syntax context idx acc = parse
rule tokens context idx acc = parse
| eof
{ (idx, None, List.rev acc) }
| ('\n' | blank)+
{ let loc = lexeme_loc idx lexbuf in
tokens syntax context loc.idx2 ((Blanks, loc) :: acc) lexbuf }
tokens context loc.idx2 ((Blanks, loc) :: acc) lexbuf }
| lident
{ let src = lexeme lexbuf in
let loc = lexeme_loc idx lexbuf in
let tok =
match syntax, src with
| (UTop.Normal | UTop.Camlp4o), ("true" | "false") ->
match src with
| ("true" | "false") ->
Constant src
| _ ->
Lident src
in
tokens syntax context loc.idx2 ((tok, loc) :: acc) lexbuf }
tokens context loc.idx2 ((tok, loc) :: acc) lexbuf }
| uident
{ let src = lexeme lexbuf in
let loc = lexeme_loc idx lexbuf in
let tok =
match syntax, src with
| UTop.Camlp4r, "True" ->
Constant "true"
| UTop.Camlp4r, "False" ->
Constant "false"
| _ ->
Uident src
in
tokens syntax context loc.idx2 ((tok, loc) :: acc) lexbuf }
let tok = Uident src in
tokens context loc.idx2 ((tok, loc) :: acc) lexbuf }
| int_literal "l"
| int_literal "L"
| int_literal "n"
@ -112,18 +104,18 @@ rule tokens syntax context idx acc = parse
| float_literal
{ let loc = lexeme_loc idx lexbuf in
let tok = Constant (lexeme lexbuf) in
tokens syntax context loc.idx2 ((tok, loc) :: acc) lexbuf }
tokens context loc.idx2 ((tok, loc) :: acc) lexbuf }
| '"'
{ let ofs = lexeme_start lexbuf in
let item, idx2= cm_string (idx + 1) lexbuf in
let loc = mkloc idx idx2 ofs (lexeme_end lexbuf) in
tokens syntax context idx2 ((item, loc) :: acc) lexbuf }
tokens context idx2 ((item, loc) :: acc) lexbuf }
| '{' (lowercase* as tag) '|'
{ let ofs = lexeme_start lexbuf in
let delim_len = String.length tag + 2 in
let idx2, terminated = quoted_string (idx + delim_len) tag false lexbuf in
let loc = mkloc idx idx2 ofs (lexeme_end lexbuf) in
tokens syntax context idx2 ((String (delim_len, terminated), loc) :: acc) lexbuf }
tokens context idx2 ((String (delim_len, terminated), loc) :: acc) lexbuf }
| "'" [^'\'' '\\'] "'"
| "'\\" ['\\' '"' 'n' 't' 'b' 'r' ' ' '\'' 'x' '0'-'9'] eof
| "'\\" ['\\' '"' 'n' 't' 'b' 'r' ' ' '\''] "'"
@ -131,37 +123,30 @@ rule tokens syntax context idx acc = parse
| "'\\" (['0'-'9'] ['0'-'9'] ['0'-'9'] | 'x' hexa_char hexa_char) eof
| "'\\" (['0'-'9'] ['0'-'9'] ['0'-'9'] | 'x' hexa_char hexa_char) "'"
{ let loc = lexeme_loc idx lexbuf in
tokens syntax context loc.idx2 ((Char, loc) :: acc) lexbuf }
tokens context loc.idx2 ((Char, loc) :: acc) lexbuf }
| "'\\" uchar
{ let loc = mkloc idx (idx + 3) (lexeme_start lexbuf) (lexeme_end lexbuf) in
tokens syntax context loc.idx2 ((Error, loc) :: acc) lexbuf }
tokens context loc.idx2 ((Error, loc) :: acc) lexbuf }
| "(*)"
{ let loc = lexeme_loc idx lexbuf in
tokens syntax context loc.idx2 ((Comment (Comment_reg, true), loc) :: acc) lexbuf }
tokens context loc.idx2 ((Comment (Comment_reg, true), loc) :: acc) lexbuf }
| "(**)"
{ let loc = lexeme_loc idx lexbuf in
tokens syntax context loc.idx2 ((Comment (Comment_doc, true), loc) :: acc) lexbuf }
tokens context loc.idx2 ((Comment (Comment_doc, true), loc) :: acc) lexbuf }
| "(**"
{ let ofs = lexeme_start lexbuf in
let idx2, terminated = comment (idx + 3) 0 false lexbuf in
let loc = mkloc idx idx2 ofs (lexeme_end lexbuf) in
tokens syntax context idx2 ((Comment (Comment_doc, terminated), loc) :: acc) lexbuf }
tokens context idx2 ((Comment (Comment_doc, terminated), loc) :: acc) lexbuf }
| "(*"
{ let ofs = lexeme_start lexbuf in
let idx2, terminated = comment (idx + 2) 0 false lexbuf in
let loc = mkloc idx idx2 ofs (lexeme_end lexbuf) in
tokens syntax context idx2 ((Comment (Comment_reg, terminated), loc) :: acc) lexbuf }
tokens context idx2 ((Comment (Comment_reg, terminated), loc) :: acc) lexbuf }
| ""
{ if syntax = UTop.Normal then
symbol syntax context idx acc lexbuf
else
match context with
| Toplevel ->
camlp4_toplevel syntax context idx acc lexbuf
| Antiquot ->
camlp4_antiquot syntax context idx acc lexbuf }
{ symbol context idx acc lexbuf }
and symbol syntax context idx acc = parse
and symbol context idx acc = parse
| "(" | ")"
| "[" | "]"
| "{" | "}"
@ -172,7 +157,7 @@ and symbol syntax context idx acc = parse
| symbolchar+
{ let loc = lexeme_loc idx lexbuf in
let tok = Symbol (lexeme lexbuf) in
tokens syntax context loc.idx2 ((tok, loc) :: acc) lexbuf }
tokens context loc.idx2 ((tok, loc) :: acc) lexbuf }
| uchar as uchar
{ let uChar= Zed_utf8.unsafe_extract uchar 0 in
if Zed_char.is_combining_mark uChar then
@ -186,10 +171,10 @@ and symbol syntax context idx acc = parse
| _-> tok
in
let loc= { loc with ofs2= lexeme_end lexbuf } in
tokens syntax context loc.idx2 ((tok, loc) :: tl) lexbuf
tokens context loc.idx2 ((tok, loc) :: tl) lexbuf
else
let loc = mkloc idx (idx + 1) (lexeme_start lexbuf) (lexeme_end lexbuf) in
tokens syntax context loc.idx2 ((Error, loc) :: acc) lexbuf
tokens context loc.idx2 ((Error, loc) :: acc) lexbuf
}
and cm_string idx= parse
@ -211,23 +196,6 @@ and cm_string idx= parse
| eof
{ (String (1, false), idx) }
and camlp4_toplevel syntax context idx acc = parse
| '<' (':' ident)? ('@' lident)? '<'
{ let ofs = lexeme_start lexbuf in
let idx2, items, terminated = quotation syntax 0 idx (idx + lexeme_size lexbuf) (lexeme_start lexbuf) false lexbuf in
let ofs2 = lexeme_end lexbuf in
tokens syntax context idx2
((Quotation (items, terminated), mkloc idx idx2 ofs ofs2) :: acc)
lexbuf }
| ""
{ symbol syntax context idx acc lexbuf }
and camlp4_antiquot syntax context idx acc = parse
| '$'
{ (idx + 1, Some (lexeme_loc idx lexbuf), List.rev acc) }
| ""
{ camlp4_toplevel syntax context idx acc lexbuf }
and comment idx depth combining= parse
| "(*"
{ comment (idx + 2) (depth + 1) false lexbuf }
@ -302,15 +270,15 @@ and quoted_string idx tag combining= parse
quoted_string (idx + 1) tag true lexbuf
}
and quotation syntax depth idx1 idx2 ofs1 combining= parse
and quotation depth idx1 idx2 ofs1 combining= parse
| '<' (':' ident)? ('@' lident)? '<'
{ quotation syntax (depth + 1) idx1 (idx2 + lexeme_size lexbuf) ofs1 false lexbuf }
{ quotation (depth + 1) idx1 (idx2 + lexeme_size lexbuf) ofs1 false lexbuf }
| ">>"
{ if depth = 0 then
let loc = mkloc idx1 (idx2 + 2) ofs1 (lexeme_end lexbuf) in
(idx2 + 2, [(Quot_data, loc)], true)
else
quotation syntax (depth - 1) idx1 (idx2 + 2) ofs1 false lexbuf }
quotation (depth - 1) idx1 (idx2 + 2) ofs1 false lexbuf }
| '$'
{ let quot_data_loc =
if idx1 = idx2 then
@ -320,7 +288,7 @@ and quotation syntax depth idx1 idx2 ofs1 combining= parse
in
let opening_loc = lexeme_loc idx2 lexbuf in
let idx, name = quotation_name (idx2 + 1) lexbuf in
let idx, closing_loc, items = tokens syntax Antiquot idx [] lexbuf in
let idx, closing_loc, items = tokens Antiquot idx [] lexbuf in
let anti = {
a_opening = opening_loc;
a_closing = closing_loc;
@ -329,7 +297,7 @@ and quotation syntax depth idx1 idx2 ofs1 combining= parse
} in
let ofs = lexeme_end lexbuf in
let loc = mkloc opening_loc.idx1 idx opening_loc.ofs2 ofs in
let idx, quot_items, terminated = quotation syntax depth idx idx ofs false lexbuf in
let idx, quot_items, terminated = quotation depth idx idx ofs false lexbuf in
let quot_items = (Quot_anti anti, loc) :: quot_items in
match quot_data_loc with
| Some loc ->
@ -340,14 +308,14 @@ and quotation syntax depth idx1 idx2 ofs1 combining= parse
{ let uChar= Zed_utf8.unsafe_extract uchar 0 in
if not combining then
if Zed_char.is_combining_mark uChar then
quotation syntax depth idx1 (idx2 + 1) ofs1 false lexbuf
quotation depth idx1 (idx2 + 1) ofs1 false lexbuf
else
quotation syntax depth idx1 (idx2 + 1) ofs1 true lexbuf
quotation depth idx1 (idx2 + 1) ofs1 true lexbuf
else
if Zed_char.is_combining_mark uChar then
quotation syntax depth idx1 idx2 ofs1 true lexbuf
quotation depth idx1 idx2 ofs1 true lexbuf
else
quotation syntax depth idx1 (idx2 + 1) ofs1 true lexbuf
quotation depth idx1 (idx2 + 1) ofs1 true lexbuf
}
| eof
{ if idx1 = idx2 then
@ -366,7 +334,7 @@ and quotation_name idx = parse
{ (idx, None) }
{
let lex_string syntax str =
let _, _, items = tokens syntax Toplevel 0 [] (Lexing.from_string str) in
let lex_string str =
let _, _, items = tokens Toplevel 0 [] (Lexing.from_string str) in
items
}

7
src/lib/uTop_main.ml
View File

@ -224,7 +224,7 @@ class read_phrase ~term = object(self)
styled.(i) <- (ch, LTerm_style.merge token_style style)
done
in
UTop_styles.stylise stylise (UTop_lexer.lex_string (UTop.get_syntax ()) (Zed_string.to_utf8 (LTerm_text.to_string styled)));
UTop_styles.stylise stylise (UTop_lexer.lex_string (Zed_string.to_utf8 (LTerm_text.to_string styled)));
if not last then
(* Parenthesis matching. *)
@ -249,7 +249,6 @@ class read_phrase ~term = object(self)
method! completion =
let pos, words =
UTop_complete.complete
~syntax:(UTop.get_syntax ())
~phrase_terminator:(UTop.get_phrase_terminator ())
~input:(Zed_string.to_utf8 (Zed_rope.to_string self#input_prev))
in
@ -306,7 +305,7 @@ let render_out_phrase term string =
styled.(i) <- (ch, LTerm_style.merge token_style style)
done
in
UTop_styles.stylise stylise (UTop_lexer.lex_string (UTop.get_syntax ()) string);
UTop_styles.stylise stylise (UTop_lexer.lex_string string);
LTerm.fprints term styled
end
@ -1088,7 +1087,6 @@ module Emacs(M : sig end) = struct
let input = read_data () in
let _, words =
UTop_complete.complete
~syntax:(UTop.get_syntax ())
~phrase_terminator:(UTop.get_phrase_terminator ())
~input
in
@ -1100,7 +1098,6 @@ module Emacs(M : sig end) = struct
let input = read_data () in
let start, words =
UTop_complete.complete
~syntax:(UTop.get_syntax ())
~phrase_terminator:(UTop.get_phrase_terminator ())
~input
in

5
src/top/utop.el
View File

@ -211,11 +211,6 @@ to add the newline character if it is not accepted).")
"List of packages to load when visiting OCaml buffer.
Useful as file variable."))
(make-variable-buffer-local
(defvar utop-ocaml-preprocessor nil
"Name of preprocesor. Currently supported camlp4o, camlp4r.
Useful as file variable."))
(defvar utop-next-phrase-beginning 'utop-compat-next-phrase-beginning
"The function used to find the beginning of the next phrase.")