this repo has no description
Remove utop stuff
+1
-2054
+1
-2
lib/dune
+1
-2
lib/dune
-390
lib/uTop.ml
-390
lib/uTop.ml
···
1
-
(*
2
-
* uTop.ml
3
-
* -------
4
-
* Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
5
-
* Licence : BSD3
6
-
*
7
-
* This file is a part of utop.
8
-
*)
9
-
10
-
[@@@warning "-27"]
11
-
12
-
13
-
module String_set = Set.Make(String)
14
-
15
-
let version = "2.7.0"
16
-
17
-
(* +-----------------------------------------------------------------+
18
-
| Keywords |
19
-
+-----------------------------------------------------------------+ *)
20
-
21
-
let default_keywords = [
22
-
"and"; "as"; "assert"; "begin"; "class"; "constraint"; "do";
23
-
"done"; "downto"; "else"; "end"; "exception"; "external";
24
-
"for"; "fun"; "function"; "functor"; "if"; "in"; "include";
25
-
"inherit"; "initializer"; "lazy"; "let"; "match"; "method"; "module";
26
-
"mutable"; "new"; "object"; "of"; "open"; "private"; "rec"; "sig";
27
-
"struct"; "then"; "to"; "try"; "type"; "val"; "virtual";
28
-
"when"; "while"; "with"; "try_lwt"; "finally"; "for_lwt"; "lwt";
29
-
]
30
-
31
-
let keywords = ref (String_set.of_list default_keywords)
32
-
let add_keyword kwd = keywords := String_set.add kwd !keywords
33
-
34
-
(* +-----------------------------------------------------------------+
35
-
| Span of Lines |
36
-
+-----------------------------------------------------------------+ *)
37
-
38
-
type lines = {
39
-
start: int;
40
-
stop: int;
41
-
}
42
-
43
-
(* +-----------------------------------------------------------------+
44
-
| Error reporting |
45
-
+-----------------------------------------------------------------+ *)
46
-
47
-
let get_message func x =
48
-
let buffer = Buffer.create 1024 in
49
-
let pp = Format.formatter_of_buffer buffer in
50
-
func pp x;
51
-
Format.pp_print_flush pp ();
52
-
Buffer.contents buffer
53
-
54
-
let get_ocaml_error_message exn =
55
-
let buffer = Buffer.create 1024 in
56
-
let pp = Format.formatter_of_buffer buffer in
57
-
Errors.report_error pp exn;
58
-
Format.pp_print_flush pp ();
59
-
let str = Buffer.contents buffer in
60
-
try
61
-
Scanf.sscanf
62
-
str
63
-
"Characters %d-%d:\n%[\000-\255]"
64
-
(fun start stop msg -> ((start, stop), msg, None))
65
-
with Scanf.Scan_failure(_) ->
66
-
try
67
-
Scanf.sscanf
68
-
str
69
-
"Line %d, characters %d-%d:\n%[\000-\255]"
70
-
(fun line start stop msg -> ((start, stop), msg, Some{start=line; stop=line}))
71
-
with Scanf.Scan_failure(_) ->
72
-
try
73
-
Scanf.sscanf
74
-
str
75
-
"Lines %d-%d, characters %d-%d:\n%[\000-\255]"
76
-
(fun start_line stop_line start stop msg -> ((start, stop),
77
-
msg, Some{start=start_line;stop=stop_line}))
78
-
with Scanf.Scan_failure(_) ->
79
-
((0, 0), str, None)
80
-
81
-
let collect_formatters buf pps f =
82
-
(* First flush all formatters. *)
83
-
List.iter (fun pp -> Format.pp_print_flush pp ()) pps;
84
-
(* Save all formatter functions. *)
85
-
let save = List.map (fun pp -> Format.pp_get_formatter_out_functions pp ()) pps in
86
-
let restore () =
87
-
List.iter2
88
-
(fun pp out_functions ->
89
-
Format.pp_print_flush pp ();
90
-
Format.pp_set_formatter_out_functions pp out_functions)
91
-
pps save
92
-
in
93
-
(* Output functions. *)
94
-
let out_functions =
95
-
let ppb = Format.formatter_of_buffer buf in
96
-
Format.pp_get_formatter_out_functions ppb ()
97
-
in
98
-
(* Replace formatter functions. *)
99
-
List.iter
100
-
(fun pp ->
101
-
Format.pp_set_formatter_out_functions pp out_functions)
102
-
pps;
103
-
try
104
-
let x = f () in
105
-
restore ();
106
-
x
107
-
with exn ->
108
-
restore ();
109
-
raise exn
110
-
111
-
let discard_formatters pps f =
112
-
(* First flush all formatters. *)
113
-
List.iter (fun pp -> Format.pp_print_flush pp ()) pps;
114
-
(* Save all formatter functions. *)
115
-
let save = List.map (fun pp -> Format.pp_get_formatter_out_functions pp ()) pps in
116
-
let restore () =
117
-
List.iter2
118
-
(fun pp out_functions ->
119
-
Format.pp_print_flush pp ();
120
-
Format.pp_set_formatter_out_functions pp out_functions)
121
-
pps save
122
-
in
123
-
(* Output functions. *)
124
-
let out_functions = {
125
-
Format.out_string = (fun _ _ _ -> ()); out_flush = ignore;
126
-
out_newline = ignore; out_spaces = ignore
127
-
#if OCAML_VERSION >= (4, 06, 0)
128
-
; out_indent = ignore
129
-
#endif
130
-
} in
131
-
(* Replace formatter functions. *)
132
-
List.iter (fun pp -> Format.pp_set_formatter_out_functions pp out_functions) pps;
133
-
try
134
-
let x = f () in
135
-
restore ();
136
-
x
137
-
with exn ->
138
-
restore ();
139
-
raise exn
140
-
141
-
(* +-----------------------------------------------------------------+
142
-
| Parsing |
143
-
+-----------------------------------------------------------------+ *)
144
-
145
-
type location = int * int
146
-
147
-
type 'a result =
148
-
| Value of 'a
149
-
| Error of location list * string
150
-
151
-
exception Need_more
152
-
153
-
let input_name = "//toplevel//"
154
-
155
-
let lexbuf_of_string eof str =
156
-
let pos = ref 0 in
157
-
let lexbuf =
158
-
Lexing.from_function
159
-
(fun buf len ->
160
-
if !pos = String.length str then begin
161
-
eof := true;
162
-
0
163
-
end else begin
164
-
let len = min len (String.length str - !pos) in
165
-
String.blit str !pos buf 0 len;
166
-
pos := !pos + len;
167
-
len
168
-
end)
169
-
in
170
-
Location.init lexbuf input_name;
171
-
lexbuf
172
-
173
-
let mkloc loc =
174
-
(loc.Location.loc_start.Lexing.pos_cnum,
175
-
loc.Location.loc_end.Lexing.pos_cnum)
176
-
177
-
let inline_code =
178
-
Misc.Style.inline_code
179
-
let invalid_package_error_to_string err =
180
-
let invalid ppf ipt = match ipt with
181
-
| Syntaxerr.Parameterized_types ->
182
-
Format.fprintf ppf "parametrized types are not supported"
183
-
| Constrained_types ->
184
-
Format.fprintf ppf "constrained types are not supported"
185
-
| Private_types ->
186
-
Format.fprintf ppf "private types are not supported"
187
-
| Not_with_type ->
188
-
Format.fprintf ppf "only %a constraints are supported"
189
-
inline_code "with type t ="
190
-
| Neither_identifier_nor_with_type ->
191
-
Format.fprintf ppf
192
-
"only module type identifier and %a constraints are supported"
193
-
inline_code "with type"
194
-
in
195
-
let buf = Buffer.create 128 in
196
-
let fmt = Format.formatter_of_buffer buf in
197
-
Format.fprintf fmt "Invalid package type: %a%!" invalid err;
198
-
Buffer.contents buf
199
-
200
-
let parse_default parse str eos_is_error =
201
-
let eof = ref false in
202
-
let lexbuf = lexbuf_of_string eof str in
203
-
try
204
-
(* Try to parse the phrase. *)
205
-
let phrase = parse lexbuf in
206
-
Value phrase
207
-
with
208
-
| _ when !eof && not eos_is_error ->
209
-
(* This is not an error, we just need more input. *)
210
-
raise Need_more
211
-
| End_of_file ->
212
-
(* If the string is empty, do not report an error. *)
213
-
raise Need_more
214
-
| Lexer.Error (error, loc) ->
215
-
(match Location.error_of_exn (Lexer.Error (error, loc)) with
216
-
| Some (`Ok error)->
217
-
Error ([mkloc loc], get_message Location.print_report error)
218
-
| _-> raise Need_more)
219
-
| Syntaxerr.Error error -> begin
220
-
match error with
221
-
| Syntaxerr.Unclosed (opening_loc, opening, closing_loc, closing) ->
222
-
Error ([mkloc opening_loc; mkloc closing_loc],
223
-
Printf.sprintf "Syntax error: '%s' expected, the highlighted '%s' might be unmatched" closing opening)
224
-
| Syntaxerr.Applicative_path loc ->
225
-
Error ([mkloc loc],
226
-
"Syntax error: applicative paths of the form F(X).t are not supported when the option -no-app-funct is set.")
227
-
| Syntaxerr.Other loc ->
228
-
Error ([mkloc loc],
229
-
"Syntax error")
230
-
| Syntaxerr.Expecting (loc, nonterm) ->
231
-
Error ([mkloc loc],
232
-
Printf.sprintf "Syntax error: %s expected." nonterm)
233
-
| Syntaxerr.Variable_in_scope (loc, var) ->
234
-
Error ([mkloc loc],
235
-
Printf.sprintf "In this scoped type, variable '%s is reserved for the local type %s." var var)
236
-
| Syntaxerr.Not_expecting (loc, nonterm) ->
237
-
Error ([mkloc loc],
238
-
Printf.sprintf "Syntax error: %s not expected" nonterm)
239
-
| Syntaxerr.Ill_formed_ast (loc, s) ->
240
-
Error ([mkloc loc],
241
-
Printf.sprintf "Error: broken invariant in parsetree: %s" s)
242
-
| Syntaxerr.Invalid_package_type (loc, s) ->
243
-
Error ([mkloc loc],
244
-
Printf.sprintf "Invalid package type: %s" (invalid_package_error_to_string s))
245
-
#if OCAML_VERSION >= (5, 0, 0)
246
-
| Syntaxerr.Removed_string_set loc ->
247
-
Error ([mkloc loc],
248
-
"Syntax error: strings are immutable, there is no assignment \
249
-
syntax for them.\n\
250
-
Hint: Mutable sequences of bytes are available in the Bytes module.\n\
251
-
Hint: Did you mean to use 'Bytes.set'?")
252
-
#endif
253
-
end
254
-
| Syntaxerr.Escape_error | Parsing.Parse_error ->
255
-
Error ([mkloc (Location.curr lexbuf)],
256
-
"Syntax error")
257
-
| exn ->
258
-
Error ([], "Unknown parsing error (please report it to the utop project): " ^ Printexc.to_string exn)
259
-
260
-
let parse_toplevel_phrase_default = parse_default Parse.toplevel_phrase
261
-
let parse_toplevel_phrase = ref parse_toplevel_phrase_default
262
-
263
-
(* +-----------------------------------------------------------------+
264
-
| Safety checking |
265
-
+-----------------------------------------------------------------+ *)
266
-
267
-
let null = Format.make_formatter (fun str ofs len -> ()) ignore
268
-
269
-
let rec last head tail =
270
-
match tail with
271
-
| [] ->
272
-
head
273
-
| head :: tail ->
274
-
last head tail
275
-
276
-
let with_loc loc str = {
277
-
Location.txt = str;
278
-
Location.loc = loc;
279
-
}
280
-
281
-
let fun_ ~loc p e =
282
-
let open Parsetree in
283
-
let open Ast_helper in
284
-
let args = [{
285
-
pparam_loc=loc;
286
-
pparam_desc=Pparam_val (Nolabel, None, p);
287
-
}] in
288
-
(Exp.function_ args None (Pfunction_body e))
289
-
290
-
(* Check that the given phrase can be evaluated without typing/compile
291
-
errors. *)
292
-
let check_phrase phrase =
293
-
let open Parsetree in
294
-
match phrase with
295
-
| Ptop_dir _ ->
296
-
None
297
-
| Ptop_def [] ->
298
-
None
299
-
| Ptop_def (item :: items) ->
300
-
let loc = {
301
-
Location.loc_start = item.pstr_loc.Location.loc_start;
302
-
Location.loc_end = (last item items).pstr_loc.Location.loc_end;
303
-
Location.loc_ghost = false;
304
-
} in
305
-
(* Backup. *)
306
-
let snap = Btype.snapshot () in
307
-
let env = !Toploop.toplevel_env in
308
-
(* Construct "let _ () = let module _ = struct <items> end in ()" in order to test
309
-
the typing and compilation of [items] without evaluating them. *)
310
-
let unit =
311
-
let (%.) a b = Longident.Ldot (a, b) in
312
-
with_loc loc (Lident "Stdlib" %. "Unit" %. "()")
313
-
in
314
-
let top_def =
315
-
let open Ast_helper in
316
-
with_default_loc loc
317
-
(fun () ->
318
-
let punit = (Pat.construct unit None) in
319
-
let body = (Exp.letmodule ~loc:loc
320
-
(with_loc loc (Some "_"))
321
-
(Mod.structure (item :: items))
322
-
(Exp.construct unit None)) in
323
-
Str.eval (fun_ ~loc punit body))
324
-
in
325
-
let check_phrase = Ptop_def [top_def] in
326
-
try
327
-
let _ =
328
-
discard_formatters [Format.err_formatter] (fun () ->
329
-
Env.reset_cache_toplevel ();
330
-
Toploop.execute_phrase false null check_phrase)
331
-
in
332
-
(* The phrase is safe. *)
333
-
Toploop.toplevel_env := env;
334
-
Btype.backtrack snap;
335
-
None
336
-
with exn ->
337
-
(* The phrase contains errors. *)
338
-
let loc, msg, line = get_ocaml_error_message exn in
339
-
Toploop.toplevel_env := env;
340
-
Btype.backtrack snap;
341
-
Some ([loc], msg, [line])
342
-
343
-
344
-
345
-
(*let try_finally ~always work=
346
-
#if OCAML_VERSION >= (4, 08, 0)
347
-
Misc.try_finally ~always work
348
-
#else
349
-
Misc.try_finally work always
350
-
#endif
351
-
352
-
let use_output command =
353
-
let fn = Filename.temp_file "ocaml" "_toploop.ml" in
354
-
try_finally ~always:(fun () ->
355
-
try Sys.remove fn with Sys_error _ -> ())
356
-
(fun () ->
357
-
match
358
-
Printf.ksprintf Sys.command "%s > %s"
359
-
command
360
-
(Filename.quote fn)
361
-
with
362
-
| 0 ->
363
-
ignore (Toploop.use_file Format.std_formatter fn : bool)
364
-
| n ->
365
-
Format.printf "Command exited with code %d.@." n)
366
-
367
-
let () =
368
-
let name = "use_output" in
369
-
if not (Hashtbl.mem Toploop.directive_table name) then
370
-
Hashtbl.add
371
-
Toploop.directive_table
372
-
name
373
-
(Toploop.Directive_string use_output)
374
-
*)
375
-
376
-
(* +-----------------------------------------------------------------+
377
-
| Compiler-libs re-exports |
378
-
+-----------------------------------------------------------------+ *)
379
-
380
-
let get_load_path () =
381
-
let {Load_path.visible; hidden} = Load_path.get_paths () in
382
-
visible @ hidden
383
-
384
-
385
-
#if OCAML_VERSION >= (5, 0, 0)
386
-
let set_load_path visible =
387
-
Load_path.init ~auto_include:Load_path.no_auto_include ~visible ~hidden:[]
388
-
#else
389
-
let set_load_path path = Load_path.init path
390
-
#endif
-108
lib/uTop.mli
-108
lib/uTop.mli
···
1
-
(*
2
-
* uTop.mli
3
-
* --------
4
-
* Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
5
-
* Licence : BSD3
6
-
*
7
-
* This file is a part of utop.
8
-
*)
9
-
10
-
(** UTop configuration. *)
11
-
12
-
val version : string
13
-
(** Version of utop. *)
14
-
15
-
val keywords : Set.Make(String).t ref
16
-
(** The set of OCaml keywords. *)
17
-
18
-
val add_keyword : string -> unit
19
-
(** Add a new OCaml keyword. *)
20
-
21
-
(** {6 Parsing} *)
22
-
23
-
type location = int * int
24
-
(** Type of a string-location. It is composed of a start and stop offsets (in
25
-
bytes). *)
26
-
27
-
type lines = { start : int; stop : int }
28
-
(** Type for a range of lines in a buffer from start to stop. *)
29
-
30
-
(** Result of a function processing a programx. *)
31
-
type 'a result =
32
-
| Value of 'a (** The function succeeded and returned this value. *)
33
-
| Error of location list * string
34
-
(** The function failed. Arguments are a list of locations to highlight in
35
-
the source and an error message. *)
36
-
37
-
exception Need_more
38
-
(** Exception raised by a parser when it need more data. *)
39
-
40
-
val parse_toplevel_phrase :
41
-
(string -> bool -> Parsetree.toplevel_phrase result) ref
42
-
(** [parse_toplevel_phrase] is the function used to parse a phrase typed in the
43
-
toplevel.
44
-
45
-
Its arguments are:
46
-
47
-
- [input]: the string to parse
48
-
- [eos_is_error]
49
-
50
-
If [eos_is_error] is [true] and the parser reach the end of input, then
51
-
{!Parse_failure} should be returned.
52
-
53
-
If [eos_is_error] is [false] and the parser reach the end of input, the
54
-
exception {!Need_more} must be thrown.
55
-
56
-
Except for {!Need_more}, the function must not raise any exception. *)
57
-
58
-
val parse_toplevel_phrase_default :
59
-
string -> bool -> Parsetree.toplevel_phrase result
60
-
(** The default parser for toplevel phrases. It uses the standard ocaml parser.
61
-
*)
62
-
63
-
val parse_default : (Lexing.lexbuf -> 'a) -> string -> bool -> 'a result
64
-
(** The default parser. It uses the standard ocaml parser. *)
65
-
66
-
val input_name : string
67
-
(** The name you must use in location to let ocaml know that it is from the
68
-
toplevel. *)
69
-
70
-
val lexbuf_of_string : bool ref -> string -> Lexing.lexbuf
71
-
(** [lexbuf_of_string eof str] is the same as [Lexing.from_string str] except
72
-
that if the lexer reach the end of [str] then [eof] is set to [true]. *)
73
-
74
-
(** {6 Helpers} *)
75
-
76
-
val get_message : (Format.formatter -> 'a -> unit) -> 'a -> string
77
-
(** [get_message printer x] applies [printer] on [x] and returns everything it
78
-
prints as a string. *)
79
-
80
-
val get_ocaml_error_message : exn -> location * string * lines option
81
-
(** [get_ocaml_error_message exn] returns the location and error message for the
82
-
exception [exn] which must be an exception from the compiler. *)
83
-
84
-
val check_phrase :
85
-
Parsetree.toplevel_phrase ->
86
-
(location list * string * lines option list) option
87
-
(** [check_phrase phrase] checks that [phrase] can be executed without typing or
88
-
compilation errors. It returns [None] if [phrase] is OK and an error message
89
-
otherwise. If the result is [None] it is guaranteed that
90
-
[Toploop.execute_phrase] won't raise any exception. *)
91
-
92
-
val collect_formatters : Buffer.t -> Format.formatter list -> (unit -> 'a) -> 'a
93
-
(** [collect_formatters buf pps f] executes [f] and redirect everything it
94
-
prints on [pps] to [buf]. *)
95
-
96
-
val discard_formatters : Format.formatter list -> (unit -> 'a) -> 'a
97
-
(** [discard_formatters pps f] executes [f], dropping everything it prints on
98
-
[pps]. *)
99
-
100
-
(** {6 compiler-libs reexports} *)
101
-
102
-
val get_load_path : unit -> string list
103
-
104
-
val set_load_path : string list -> unit
105
-
(** [get_load_path] and [set_load_path] manage the include directories.
106
-
107
-
The internal variable contains the list of directories added by
108
-
findlib-required packages and [#directory] directives. *)
-152
lib/uTop_compat.ml
-152
lib/uTop_compat.ml
···
1
-
let get_desc x =
2
-
#if OCAML_VERSION >= (4, 14, 0)
3
-
Types.get_desc x
4
-
#else
5
-
x.Types.desc
6
-
#endif
7
-
8
-
let toploop_get_directive name =
9
-
#if OCAML_VERSION >= (4, 13, 0)
10
-
Toploop.get_directive name
11
-
#else
12
-
try Some (Hashtbl.find Toploop.directive_table name) with Not_found -> None
13
-
#endif
14
-
15
-
let toploop_all_directive_names () =
16
-
#if OCAML_VERSION >= (4, 13, 0)
17
-
Toploop.all_directive_names ()
18
-
#else
19
-
Hashtbl.fold (fun dir _ acc -> dir::acc) Toploop.directive_table []
20
-
#endif
21
-
22
-
let get_load_path () =
23
-
#if OCAML_VERSION >= (5, 2, 0)
24
-
let {Load_path.visible; hidden} = Load_path.get_paths () in
25
-
visible @ hidden
26
-
#else
27
-
Load_path.get_paths ()
28
-
#endif
29
-
30
-
let set_load_path visible =
31
-
#if OCAML_VERSION >= (5, 2, 0)
32
-
Load_path.init ~auto_include:Load_path.no_auto_include ~visible ~hidden:[]
33
-
#elif OCAML_VERSION >= (5, 0, 0)
34
-
Load_path.init ~auto_include:Load_path.no_auto_include visible
35
-
#else
36
-
Load_path.init visible
37
-
#endif
38
-
39
-
let toploop_use_silently fmt name =
40
-
#if OCAML_VERSION >= (4, 14, 0)
41
-
Toploop.use_silently fmt (match name with "" -> Stdin | _ -> File name)
42
-
#else
43
-
Toploop.use_silently fmt name
44
-
#endif
45
-
46
-
let toploop_set_paths () =
47
-
#if OCAML_VERSION >= (5, 0, 0)
48
-
Toploop.set_paths ~auto_include:Load_path.no_auto_include ()
49
-
#else
50
-
Toploop.set_paths ()
51
-
#endif
52
-
53
-
let toploop_load_file ppf fn =
54
-
#if OCAML_VERSION >= (4, 13, 0)
55
-
Toploop.load_file ppf fn
56
-
#else
57
-
Topdirs.load_file ppf fn
58
-
#endif
59
-
60
-
(** Returns whether the given path is persistent. *)
61
-
let rec is_persistent_path = function
62
-
| Path.Pident id -> Ident.persistent id
63
-
| Path.Pdot (p, _) -> is_persistent_path p
64
-
| Path.Papply (_, p) -> is_persistent_path p
65
-
#if OCAML_VERSION >= (5, 1, 0)
66
-
| Path.Pextra_ty (p, _) -> is_persistent_path p
67
-
#endif
68
-
69
-
#if OCAML_VERSION >= (5, 2, 0)
70
-
let inline_code =
71
-
#if OCAML_VERSION >= (5, 3, 0)
72
-
(Format_doc.compat Misc.Style.inline_code)
73
-
#else
74
-
Misc.Style.inline_code
75
-
#endif
76
-
#endif
77
-
78
-
let invalid_package_error_to_string err =
79
-
#if OCAML_VERSION >= (5, 2, 0)
80
-
(* NOTE: from https://github.com/ocaml/ocaml/blob/9b059b1e7a66e9d2f04d892a4de34c418cd96f69/parsing/parse.ml#L149 *)
81
-
let invalid ppf ipt = match ipt with
82
-
| Syntaxerr.Parameterized_types ->
83
-
Format.fprintf ppf "parametrized types are not supported"
84
-
| Constrained_types ->
85
-
Format.fprintf ppf "constrained types are not supported"
86
-
| Private_types ->
87
-
Format.fprintf ppf "private types are not supported"
88
-
| Not_with_type ->
89
-
Format.fprintf ppf "only %a constraints are supported"
90
-
inline_code "with type t ="
91
-
| Neither_identifier_nor_with_type ->
92
-
Format.fprintf ppf
93
-
"only module type identifier and %a constraints are supported"
94
-
inline_code "with type"
95
-
in
96
-
let buf = Buffer.create 128 in
97
-
let fmt = Format.formatter_of_buffer buf in
98
-
Format.fprintf fmt "Invalid package type: %a%!" invalid err;
99
-
Buffer.contents buf
100
-
#else
101
-
err
102
-
#endif
103
-
104
-
module Exp = struct
105
-
open Ast_helper
106
-
#if OCAML_VERSION >= (5, 2, 0)
107
-
open Parsetree
108
-
let fun_ ~loc p e =
109
-
let args = [{
110
-
pparam_loc=loc;
111
-
pparam_desc=Pparam_val (Nolabel, None, p);
112
-
}] in
113
-
(Exp.function_ args None (Pfunction_body e))
114
-
#else
115
-
let fun_ ~loc p e = Exp.fun_ ~loc Nolabel None p e
116
-
#endif
117
-
end
118
-
119
-
let abstract_type_kind =
120
-
#if OCAML_VERSION >= (5, 2, 0)
121
-
Types.(Type_abstract Definition)
122
-
#else
123
-
Types.Type_abstract
124
-
#endif
125
-
126
-
let find_in_path_normalized =
127
-
#if OCAML_VERSION >= (5, 2, 0)
128
-
Misc.find_in_path_normalized
129
-
#else
130
-
Misc.find_in_path_uncap
131
-
#endif
132
-
133
-
let visible_paths_for_cmt_infos (cmt_infos: Cmt_format.cmt_infos) =
134
-
#if OCAML_VERSION >= (5, 2, 0)
135
-
cmt_infos.cmt_loadpath.visible
136
-
#else
137
-
cmt_infos.cmt_loadpath
138
-
#endif
139
-
140
-
let add_cmi_hook f =
141
-
let default_load = !Persistent_env.Persistent_signature.load in
142
-
#if OCAML_VERSION >= (5, 2, 0)
143
-
let load ~allow_hidden ~unit_name =
144
-
let res = default_load ~unit_name ~allow_hidden in
145
-
#else
146
-
let load ~unit_name =
147
-
let res = default_load ~unit_name in
148
-
#endif
149
-
(match res with None -> () | Some x -> f x.cmi);
150
-
res
151
-
in
152
-
Persistent_env.Persistent_signature.load := load
-1095
lib/uTop_complete.ml
-1095
lib/uTop_complete.ml
···
1
-
(*
2
-
* uTop_complete.ml
3
-
* ----------------
4
-
* Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
5
-
* Licence : BSD3
6
-
*
7
-
* This file is a part of utop.
8
-
*)
9
-
10
-
[@@@warning "-9-27-32"]
11
-
12
-
open Types
13
-
open UTop_token
14
-
15
-
module String_set = Set.Make(String)
16
-
module String_map = Map.Make(String)
17
-
18
-
let lookup_assoc word words = List.filter (fun (word', _) -> Astring.String.is_prefix ~affix:word word') words
19
-
let lookup word words = List.filter (fun word' -> Astring.String.is_prefix word' ~affix:word) words
20
-
21
-
let set_of_list = List.fold_left (fun set x -> String_set.add x set) String_set.empty
22
-
23
-
(* +-----------------------------------------------------------------+
24
-
| Utils |
25
-
+-----------------------------------------------------------------+ *)
26
-
let get_desc x =
27
-
#if OCAML_VERSION >= (4, 14, 0)
28
-
Types.get_desc x
29
-
#else
30
-
x.Types.desc
31
-
#endif
32
-
33
-
(* Transform a non-empty list of strings into a long-identifier. *)
34
-
let longident_of_list = function
35
-
| [] ->
36
-
invalid_arg "UTop_complete.longident_of_list"
37
-
| component :: rest ->
38
-
let rec loop acc = function
39
-
| [] -> acc
40
-
| component :: rest -> loop (Longident.Ldot(acc, component)) rest
41
-
in
42
-
loop (Longident.Lident component) rest
43
-
44
-
(* Check whether an identifier is a valid one. *)
45
-
let is_valid_identifier id =
46
-
id <> "" &&
47
-
(match id.[0] with
48
-
| 'A' .. 'Z' | 'a' .. 'z' | '_' -> true
49
-
| _ -> false)
50
-
51
-
let add id set = if is_valid_identifier id then String_set.add id set else set
52
-
53
-
let lookup_env f x env =
54
-
try
55
-
Some (f x env)
56
-
with Not_found | Env.Error _ ->
57
-
None
58
-
59
-
(* +-----------------------------------------------------------------+
60
-
| Parsing |
61
-
+-----------------------------------------------------------------+ *)
62
-
63
-
(* The following functions takes a list of tokens in reverse order. *)
64
-
65
-
type value_or_field = Value | Field
66
-
(* Either a value, or a record field. *)
67
-
68
-
(* Parse something of the form [M1.M2. ... .Mn.id] or
69
-
[field.M1.M2. ... .Mn.id] *)
70
-
let parse_longident tokens =
71
-
let rec loop acc tokens =
72
-
match tokens with
73
-
| (Symbol ".", _) :: (Uident id, _) :: tokens ->
74
-
loop (id :: acc) tokens
75
-
| (Symbol ".", _) :: (Lident id, _) :: tokens ->
76
-
(Field,
77
-
match acc with
78
-
| [] -> None
79
-
| l -> Some (longident_of_list l))
80
-
| _ ->
81
-
(Value,
82
-
match acc with
83
-
| [] -> None
84
-
| l -> Some (longident_of_list l))
85
-
in
86
-
match tokens with
87
-
| ((Comment (_, false) | String (_, false) | Quotation (_, false)), _) :: _ ->
88
-
(* An unterminated command, string, or quotation. *)
89
-
None
90
-
| ((Uident id | Lident id), { idx1 = start }) :: tokens ->
91
-
(* An identifier. *)
92
-
let kind, path = loop [] tokens in
93
-
Some (kind, path, start, id)
94
-
| (Blanks, { idx2 = stop }) :: tokens ->
95
-
(* Some blanks at the end. *)
96
-
let kind, path = loop [] tokens in
97
-
Some (kind, path, stop, "")
98
-
| (_, { idx2 = stop }) :: _ ->
99
-
(* Otherwise complete after the last token. *)
100
-
let kind, path = loop [] tokens in
101
-
Some (kind, path, stop, "")
102
-
| [] ->
103
-
None
104
-
105
-
(* Parse something of the form [M1.M2. ... .Mn.id#m1#m2# ... #mp#m] *)
106
-
let parse_method tokens =
107
-
(* Collect [M1.M2. ... .Mn.id] and returns the corresponding
108
-
longidentifier. *)
109
-
let rec loop_uidents acc tokens =
110
-
match tokens with
111
-
| (Symbol ".", _) :: (Uident id, _) :: tokens ->
112
-
loop_uidents (id :: acc) tokens
113
-
| _ ->
114
-
longident_of_list acc
115
-
in
116
-
(* Collect [m1#m2# ... #mp] *)
117
-
let rec loop_methods acc tokens =
118
-
match tokens with
119
-
| (Lident meth, _) :: (Symbol "#", _) :: tokens ->
120
-
loop_methods (meth :: acc) tokens
121
-
| (Lident id, _) :: tokens ->
122
-
Some (loop_uidents [id] tokens, acc)
123
-
| _ ->
124
-
None
125
-
in
126
-
match tokens with
127
-
| (Lident meth, { idx1 = start }) :: (Symbol "#", _) :: tokens -> begin
128
-
match loop_methods [] tokens with
129
-
| None -> None
130
-
| Some (path, meths) -> Some (path, meths, start, meth)
131
-
end
132
-
| (Symbol "#", { idx2 = stop }) :: tokens
133
-
| (Blanks, { idx2 = stop }) :: (Symbol "#", _) :: tokens -> begin
134
-
match loop_methods [] tokens with
135
-
| None -> None
136
-
| Some (path, meths) -> Some (path, meths, stop, "")
137
-
end
138
-
| _ ->
139
-
None
140
-
141
-
type label_kind = Required | Optional
142
-
(* Kind of labels: required or optional. *)
143
-
144
-
type fun_or_new = Fun | New
145
-
(* Either a function application, either an object creation. *)
146
-
147
-
(* Parse something of the form [M1.M2. ... .Mn.id#m1#m2# ... #mp expr1 ... exprq ~label]
148
-
or [new M1.M2. ... .Mn.id expr1 ... exprq ~label] *)
149
-
let parse_label tokens =
150
-
(* Collect [M1.M2. ... .Mn] *)
151
-
let rec loop_uidents acc_uidents acc_methods tokens =
152
-
match tokens with
153
-
| (Lident "new", _) :: _ ->
154
-
Some (New, longident_of_list acc_uidents, acc_methods)
155
-
| ((Lident id | Uident id), _) :: _ when String_set.mem id !UTop.keywords ->
156
-
Some (Fun, longident_of_list acc_uidents, acc_methods)
157
-
| (Symbol ".", _) :: (Uident id, _) :: tokens ->
158
-
loop_uidents (id :: acc_uidents) acc_methods tokens
159
-
| (Symbol ("~" | "?" | ":" | "." | "#" | "!" | "`"), _) :: tokens ->
160
-
search tokens
161
-
| (Symbol ")", _) :: tokens ->
162
-
skip tokens "(" []
163
-
| (Symbol "}", _) :: tokens ->
164
-
skip tokens "{" []
165
-
| (Symbol "]", _) :: tokens ->
166
-
skip tokens "[" []
167
-
| (Symbol _, _) :: _ ->
168
-
Some (Fun, longident_of_list acc_uidents, acc_methods)
169
-
| [] ->
170
-
Some (Fun, longident_of_list acc_uidents, acc_methods)
171
-
| _ ->
172
-
search tokens
173
-
and loop_methods acc tokens =
174
-
match tokens with
175
-
| ((Lident id | Uident id), _) :: _ when String_set.mem id !UTop.keywords ->
176
-
None
177
-
| (Symbol ("~" | "?" | ":" | "." | "#" | "!" | "`"), _) :: tokens ->
178
-
search tokens
179
-
| (Symbol ")", _) :: tokens ->
180
-
skip tokens "(" []
181
-
| (Symbol "}", _) :: tokens ->
182
-
skip tokens "{" []
183
-
| (Symbol "]", _) :: tokens ->
184
-
skip tokens "[" []
185
-
| (Symbol _, _) :: _ ->
186
-
None
187
-
| (Lident id, _) :: (Symbol "#", _) :: tokens ->
188
-
loop_methods (id :: acc) tokens
189
-
| (Lident id, _) :: tokens ->
190
-
loop_uidents [id] acc tokens
191
-
| [] ->
192
-
None
193
-
| _ ->
194
-
search tokens
195
-
and search tokens =
196
-
match tokens with
197
-
| ((Lident id | Uident id), _) :: _ when String_set.mem id !UTop.keywords ->
198
-
None
199
-
| (Symbol ("~" | "?" | ":" | "." | "#" | "!" | "`"), _) :: tokens ->
200
-
search tokens
201
-
| (Symbol ")", _) :: tokens ->
202
-
skip tokens "(" []
203
-
| (Symbol "}", _) :: tokens ->
204
-
skip tokens "{" []
205
-
| (Symbol "]", _) :: tokens ->
206
-
skip tokens "[" []
207
-
| (Symbol _, _) :: _ ->
208
-
None
209
-
| (Lident id, _) :: (Symbol "#", _) :: tokens ->
210
-
loop_methods [id] tokens
211
-
| (Lident id, _) :: tokens ->
212
-
loop_uidents [id] [] tokens
213
-
| _ :: tokens ->
214
-
search tokens
215
-
| [] ->
216
-
None
217
-
and skip tokens top stack =
218
-
match tokens with
219
-
| (Symbol symbol, _) :: tokens when symbol = top -> begin
220
-
match stack with
221
-
| [] -> search tokens
222
-
| top :: stack -> skip tokens top stack
223
-
end
224
-
| (Symbol ")", _) :: tokens ->
225
-
skip tokens "(" (top :: stack)
226
-
| (Symbol "}", _) :: tokens ->
227
-
skip tokens "{" (top :: stack)
228
-
| (Symbol "]", _) :: tokens ->
229
-
skip tokens "[" (top :: stack)
230
-
| _ :: tokens ->
231
-
skip tokens top stack
232
-
| [] ->
233
-
None
234
-
in
235
-
match tokens with
236
-
| (Lident label, { idx1 = start }) :: (Symbol "~", _) :: tokens -> begin
237
-
match search tokens with
238
-
| None -> None
239
-
| Some (kind, id, meths) -> Some (kind, id, meths, Required, start, label)
240
-
end
241
-
| (Symbol "~", { idx2 = stop }) :: tokens -> begin
242
-
match search tokens with
243
-
| None -> None
244
-
| Some (kind, id, meths) -> Some (kind, id, meths, Required, stop, "")
245
-
end
246
-
| (Lident label, { idx1 = start }) :: (Symbol "?", _) :: tokens -> begin
247
-
match search tokens with
248
-
| None -> None
249
-
| Some (kind, id, meths) -> Some (kind, id, meths, Optional, start, label)
250
-
end
251
-
| (Symbol "?", { idx2 = stop }) :: tokens -> begin
252
-
match search tokens with
253
-
| None -> None
254
-
| Some (kind, id, meths) -> Some (kind, id, meths, Optional, stop, "")
255
-
end
256
-
| _ ->
257
-
None
258
-
259
-
(* +-----------------------------------------------------------------+
260
-
| Directive listing |
261
-
+-----------------------------------------------------------------+ *)
262
-
263
-
let[@alert "-deprecated"] list_directives phrase_terminator =
264
-
String_map.bindings
265
-
(Hashtbl.fold
266
-
(fun dir kind map ->
267
-
let suffix =
268
-
match kind with
269
-
| Toploop.Directive_none _ -> phrase_terminator
270
-
| Toploop.Directive_string _ -> " \""
271
-
| Toploop.Directive_bool _ | Toploop.Directive_int _ | Toploop.Directive_ident _ -> " "
272
-
in
273
-
String_map.add dir suffix map)
274
-
Toploop.directive_table
275
-
String_map.empty)
276
-
277
-
(* +-----------------------------------------------------------------+
278
-
| File listing |
279
-
+-----------------------------------------------------------------+ *)
280
-
281
-
type file_kind = Directory | File
282
-
283
-
let basename name =
284
-
let name' = Filename.basename name in
285
-
if name' = "." && not (Astring.String.is_suffix name ~affix:".") then
286
-
""
287
-
else
288
-
name'
289
-
290
-
let add_files filter acc dir =
291
-
Array.fold_left
292
-
(fun map name ->
293
-
let absolute_name = Filename.concat dir name in
294
-
if try Sys.is_directory absolute_name with Sys_error _ -> false then
295
-
String_map.add (Filename.concat name "") Directory map
296
-
else if filter name then
297
-
String_map.add name File map
298
-
else
299
-
map)
300
-
acc
301
-
(try Sys.readdir dir with Sys_error _ -> [||])
302
-
303
-
let list_directories dir =
304
-
String_set.elements
305
-
(Array.fold_left
306
-
(fun set name ->
307
-
let absolute_name = Filename.concat dir name in
308
-
if try Sys.is_directory absolute_name with Sys_error _ -> false then
309
-
String_set.add name set
310
-
else
311
-
set)
312
-
String_set.empty
313
-
(try Sys.readdir (if dir = "" then Filename.current_dir_name else dir) with Sys_error _ -> [||]))
314
-
315
-
let path () = []
316
-
317
-
(* +-----------------------------------------------------------------+
318
-
| Names listing |
319
-
+-----------------------------------------------------------------+ *)
320
-
321
-
module Path_map = Map.Make(struct type t = Path.t let compare = compare end)
322
-
module Longident_map = Map.Make(struct type t = Longident.t let compare = compare end)
323
-
324
-
(* All names accessible without a path. *)
325
-
let global_names = ref None
326
-
let global_names_revised = ref None
327
-
328
-
(* All names accessible with a path, by path. *)
329
-
let local_names_by_path = ref Path_map.empty
330
-
331
-
(* All names accessible with a path, by long identifier. *)
332
-
let local_names_by_longident = ref Longident_map.empty
333
-
334
-
(* All record fields accessible without a path. *)
335
-
let global_fields = ref None
336
-
337
-
(* All record fields accessible with a path, by path. *)
338
-
let local_fields_by_path = ref Path_map.empty
339
-
340
-
(* All record fields accessible with a path, by long identifier. *)
341
-
let local_fields_by_longident = ref Longident_map.empty
342
-
343
-
(* All visible modules according to Config.load_path. *)
344
-
let visible_modules = ref None
345
-
346
-
let reset () =
347
-
visible_modules := None;
348
-
global_names := None;
349
-
global_names_revised := None;
350
-
local_names_by_path := Path_map.empty;
351
-
local_names_by_longident := Longident_map.empty;
352
-
global_fields := None;
353
-
local_fields_by_path := Path_map.empty;
354
-
local_fields_by_longident := Longident_map.empty
355
-
356
-
let get_cached var f =
357
-
match !var with
358
-
| Some x ->
359
-
x
360
-
| None ->
361
-
let x = f () in
362
-
var := Some x;
363
-
x
364
-
365
-
(* List all visible modules. *)
366
-
let visible_modules () =
367
-
get_cached visible_modules
368
-
(fun () ->
369
-
List.fold_left
370
-
(fun acc dir ->
371
-
try
372
-
Array.fold_left
373
-
(fun acc fname ->
374
-
if Filename.check_suffix fname ".cmi" then
375
-
String_set.add (String.capitalize_ascii (Filename.chop_suffix fname ".cmi")) acc
376
-
else
377
-
acc)
378
-
acc
379
-
(Sys.readdir (if dir = "" then Filename.current_dir_name else dir))
380
-
with Sys_error _ ->
381
-
acc)
382
-
#if OCAML_VERSION >= (4, 08, 0)
383
-
String_set.empty @@ UTop_compat.get_load_path ()
384
-
#else
385
-
String_set.empty !Config.load_path
386
-
#endif
387
-
)
388
-
389
-
let field_name { ld_id = id } = Ident.name id
390
-
let constructor_name { cd_id = id } = Ident.name id
391
-
392
-
let add_fields_of_type decl acc =
393
-
match decl.type_kind with
394
-
#if OCAML_VERSION >= (4, 13, 0)
395
-
| Type_variant (constructors,_) ->
396
-
#else
397
-
| Type_variant constructors ->
398
-
#endif
399
-
acc
400
-
| Type_record (fields, _) ->
401
-
List.fold_left (fun acc field -> add (field_name field) acc) acc fields
402
-
#if OCAML_VERSION >= (5, 2, 0)
403
-
| Type_abstract _ ->
404
-
#else
405
-
| Type_abstract ->
406
-
#endif
407
-
acc
408
-
| Type_open ->
409
-
acc
410
-
411
-
let add_names_of_type decl acc =
412
-
match decl.type_kind with
413
-
#if OCAML_VERSION >= (4, 13, 0)
414
-
| Type_variant (constructors,_) ->
415
-
#else
416
-
| Type_variant constructors ->
417
-
#endif
418
-
List.fold_left (fun acc cstr -> add (constructor_name cstr) acc) acc constructors
419
-
| Type_record (fields, _) ->
420
-
List.fold_left (fun acc field -> add (field_name field) acc) acc fields
421
-
#if OCAML_VERSION >= (5, 2, 0)
422
-
| Type_abstract _ ->
423
-
#else
424
-
| Type_abstract ->
425
-
#endif
426
-
acc
427
-
| Type_open ->
428
-
acc
429
-
430
-
#if OCAML_VERSION >= (4, 08, 0)
431
-
let path_of_mty_alias = function
432
-
| Mty_alias path -> path
433
-
| _ -> assert false
434
-
#elif OCAML_VERSION >= (4, 04, 0)
435
-
let path_of_mty_alias = function
436
-
| Mty_alias (_, path) -> path
437
-
| _ -> assert false
438
-
#else
439
-
let path_of_mty_alias = function
440
-
| Mty_alias path -> path
441
-
| _ -> assert false
442
-
#endif
443
-
444
-
let rec names_of_module_type = function
445
-
| Mty_signature decls ->
446
-
List.fold_left
447
-
(fun acc decl -> match decl with
448
-
#if OCAML_VERSION >= (4, 08, 0)
449
-
| Sig_value (id, _, _)
450
-
| Sig_typext (id, _, _, _)
451
-
| Sig_module (id, _, _, _, _)
452
-
| Sig_modtype (id, _, _)
453
-
| Sig_class (id, _, _, _)
454
-
| Sig_class_type (id, _, _, _) ->
455
-
#else
456
-
| Sig_value (id, _)
457
-
| Sig_typext (id, _, _)
458
-
| Sig_module (id, _, _)
459
-
| Sig_modtype (id, _)
460
-
| Sig_class (id, _, _)
461
-
| Sig_class_type (id, _, _) ->
462
-
#endif
463
-
add (Ident.name id) acc
464
-
#if OCAML_VERSION >= (4, 08, 0)
465
-
| Sig_type (id, decl, _, _) ->
466
-
#else
467
-
| Sig_type (id, decl, _) ->
468
-
#endif
469
-
add_names_of_type decl (add (Ident.name id) acc))
470
-
String_set.empty decls
471
-
| Mty_ident path -> begin
472
-
match lookup_env Env.find_modtype path !Toploop.toplevel_env with
473
-
| Some { mtd_type = None } -> String_set.empty
474
-
| Some { mtd_type = Some module_type } -> names_of_module_type module_type
475
-
| None -> String_set.empty
476
-
end
477
-
| Mty_alias _ as mty_alias -> begin
478
-
let path = path_of_mty_alias mty_alias in
479
-
match lookup_env Env.find_module path !Toploop.toplevel_env with
480
-
| None -> String_set.empty
481
-
| Some { md_type = module_type } -> names_of_module_type module_type
482
-
end
483
-
| _ ->
484
-
String_set.empty
485
-
486
-
let rec fields_of_module_type = function
487
-
| Mty_signature decls ->
488
-
List.fold_left
489
-
(fun acc decl -> match decl with
490
-
| Sig_value _
491
-
| Sig_typext _
492
-
| Sig_module _
493
-
| Sig_modtype _
494
-
| Sig_class _
495
-
| Sig_class_type _ ->
496
-
acc
497
-
#if OCAML_VERSION >= (4, 08, 0)
498
-
| Sig_type (_, decl, _, _) ->
499
-
#else
500
-
| Sig_type (_, decl, _) ->
501
-
#endif
502
-
add_fields_of_type decl acc)
503
-
String_set.empty decls
504
-
| Mty_ident path -> begin
505
-
match lookup_env Env.find_modtype path !Toploop.toplevel_env with
506
-
| Some { mtd_type = None } -> String_set.empty
507
-
| Some { mtd_type = Some module_type } -> fields_of_module_type module_type
508
-
| None -> String_set.empty
509
-
end
510
-
| Mty_alias _ as mty_alias -> begin
511
-
let path = path_of_mty_alias mty_alias in
512
-
match lookup_env Env.find_module path !Toploop.toplevel_env with
513
-
| None -> String_set.empty
514
-
| Some { md_type = module_type } -> fields_of_module_type module_type
515
-
end
516
-
| _ ->
517
-
String_set.empty
518
-
519
-
let lookup_module id env =
520
-
#if OCAML_VERSION >= (4, 10, 0)
521
-
let path, decl = Env.find_module_by_name id env in
522
-
(path, decl.md_type)
523
-
#else
524
-
let path = Env.lookup_module id env ~load:true in
525
-
(path, (Env.find_module path env).md_type)
526
-
#endif
527
-
528
-
let find_module path env = (Env.find_module path env).md_type
529
-
530
-
let names_of_module longident =
531
-
try
532
-
Longident_map.find longident !local_names_by_longident
533
-
with Not_found ->
534
-
match lookup_env lookup_module longident !Toploop.toplevel_env with
535
-
| Some(path, module_type) ->
536
-
let names = names_of_module_type module_type in
537
-
local_names_by_path := Path_map.add path names !local_names_by_path;
538
-
local_names_by_longident := Longident_map.add longident names !local_names_by_longident;
539
-
names
540
-
| None ->
541
-
local_names_by_longident := Longident_map.add longident String_set.empty !local_names_by_longident;
542
-
String_set.empty
543
-
544
-
let fields_of_module longident =
545
-
try
546
-
Longident_map.find longident !local_fields_by_longident
547
-
with Not_found ->
548
-
match lookup_env lookup_module longident !Toploop.toplevel_env with
549
-
| Some(path, module_type) ->
550
-
let fields = fields_of_module_type module_type in
551
-
local_fields_by_path := Path_map.add path fields !local_fields_by_path;
552
-
local_fields_by_longident := Longident_map.add longident fields !local_fields_by_longident;
553
-
fields
554
-
| None ->
555
-
local_fields_by_longident := Longident_map.add longident String_set.empty !local_fields_by_longident;
556
-
String_set.empty
557
-
558
-
let list_global_names () =
559
-
let rec loop acc = function
560
-
| Env.Env_empty -> acc
561
-
#if OCAML_VERSION >= (4, 10, 0)
562
-
| Env.Env_value_unbound _-> acc
563
-
| Env.Env_module_unbound _-> acc
564
-
#endif
565
-
| Env.Env_value(summary, id, _) ->
566
-
loop (add (Ident.name id) acc) summary
567
-
| Env.Env_type(summary, id, decl) ->
568
-
loop (add_names_of_type decl (add (Ident.name id) acc)) summary
569
-
| Env.Env_extension(summary, id, _) ->
570
-
loop (add (Ident.name id) acc) summary
571
-
#if OCAML_VERSION >= (4, 08, 0)
572
-
| Env.Env_module(summary, id, _, _) ->
573
-
#else
574
-
| Env.Env_module(summary, id, _) ->
575
-
#endif
576
-
loop (add (Ident.name id) acc) summary
577
-
| Env.Env_modtype(summary, id, _) ->
578
-
loop (add (Ident.name id) acc) summary
579
-
| Env.Env_class(summary, id, _) ->
580
-
loop (add (Ident.name id) acc) summary
581
-
| Env.Env_cltype(summary, id, _) ->
582
-
loop (add (Ident.name id) acc) summary
583
-
| Env.Env_functor_arg(summary, id) ->
584
-
loop (add (Ident.name id) acc) summary
585
-
#if OCAML_VERSION >= (4, 08, 0)
586
-
| Env.Env_persistent (summary, id) ->
587
-
loop (add (Ident.name id) acc) summary
588
-
#endif
589
-
#if OCAML_VERSION >= (4, 04, 0)
590
-
| Env.Env_constraints (summary, _) ->
591
-
loop acc summary
592
-
#endif
593
-
#if OCAML_VERSION >= (4, 10, 0)
594
-
| Env.Env_copy_types summary ->
595
-
loop acc summary
596
-
#elif OCAML_VERSION >= (4, 06, 0)
597
-
| Env.Env_copy_types (summary, _) ->
598
-
loop acc summary
599
-
#endif
600
-
#if OCAML_VERSION >= (4, 08, 0)
601
-
| Env.Env_open(summary, path) ->
602
-
#elif OCAML_VERSION >= (4, 07, 0)
603
-
| Env.Env_open(summary, _, path) ->
604
-
#else
605
-
| Env.Env_open(summary, path) ->
606
-
#endif
607
-
match try Some (Path_map.find path !local_names_by_path) with Not_found -> None with
608
-
| Some names ->
609
-
loop (String_set.union acc names) summary
610
-
| None ->
611
-
match lookup_env find_module path !Toploop.toplevel_env with
612
-
| Some module_type ->
613
-
let names = names_of_module_type module_type in
614
-
local_names_by_path := Path_map.add path names !local_names_by_path;
615
-
loop (String_set.union acc names) summary
616
-
| None ->
617
-
local_names_by_path := Path_map.add path String_set.empty !local_names_by_path;
618
-
loop acc summary
619
-
in
620
-
(* Add names of the environment: *)
621
-
let acc = loop String_set.empty (Env.summary !Toploop.toplevel_env) in
622
-
(* Add accessible modules: *)
623
-
String_set.union acc (visible_modules ())
624
-
625
-
let global_names () = get_cached global_names list_global_names
626
-
627
-
let replace x y set =
628
-
if String_set.mem x set then
629
-
String_set.add y (String_set.remove x set)
630
-
else
631
-
set
632
-
633
-
let list_global_fields () =
634
-
let rec loop acc = function
635
-
| Env.Env_empty -> acc
636
-
#if OCAML_VERSION >= (4, 10, 0)
637
-
| Env.Env_value_unbound _-> acc
638
-
| Env.Env_module_unbound _-> acc
639
-
#endif
640
-
| Env.Env_value(summary, id, _) ->
641
-
loop (add (Ident.name id) acc) summary
642
-
| Env.Env_type(summary, id, decl) ->
643
-
loop (add_fields_of_type decl (add (Ident.name id) acc)) summary
644
-
| Env.Env_extension(summary, id, _) ->
645
-
loop (add (Ident.name id) acc) summary
646
-
#if OCAML_VERSION >= (4, 08, 0)
647
-
| Env.Env_module(summary, id, _, _) ->
648
-
#else
649
-
| Env.Env_module(summary, id, _) ->
650
-
#endif
651
-
loop (add (Ident.name id) acc) summary
652
-
| Env.Env_functor_arg(summary, id) ->
653
-
loop (add (Ident.name id) acc) summary
654
-
| Env.Env_modtype(summary, id, _) ->
655
-
loop (add (Ident.name id) acc) summary
656
-
| Env.Env_class(summary, id, _) ->
657
-
loop (add (Ident.name id) acc) summary
658
-
| Env.Env_cltype(summary, id, _) ->
659
-
loop (add (Ident.name id) acc) summary
660
-
#if OCAML_VERSION >= (4, 08, 0)
661
-
| Env.Env_persistent (summary, id) ->
662
-
loop (add (Ident.name id) acc) summary
663
-
#endif
664
-
#if OCAML_VERSION >= (4, 04, 0)
665
-
| Env.Env_constraints (summary, _) ->
666
-
loop acc summary
667
-
#endif
668
-
#if OCAML_VERSION >= (4, 10, 0)
669
-
| Env.Env_copy_types summary ->
670
-
loop acc summary
671
-
#elif OCAML_VERSION >= (4, 06, 0)
672
-
| Env.Env_copy_types (summary, _) ->
673
-
loop acc summary
674
-
#endif
675
-
#if OCAML_VERSION >= (4, 07, 0)
676
-
#if OCAML_VERSION >= (4, 08, 0)
677
-
| Env.Env_open(summary, path) ->
678
-
#else
679
-
| Env.Env_open(summary, _, path) ->
680
-
#endif
681
-
#else
682
-
| Env.Env_open(summary, path) ->
683
-
#endif
684
-
match try Some (Path_map.find path !local_fields_by_path) with Not_found -> None with
685
-
| Some fields ->
686
-
loop (String_set.union acc fields) summary
687
-
| None ->
688
-
match lookup_env find_module path !Toploop.toplevel_env with
689
-
| Some module_type ->
690
-
let fields = fields_of_module_type module_type in
691
-
local_fields_by_path := Path_map.add path fields !local_fields_by_path;
692
-
loop (String_set.union acc fields) summary
693
-
| None ->
694
-
local_fields_by_path := Path_map.add path String_set.empty !local_fields_by_path;
695
-
loop acc summary
696
-
in
697
-
(* Add fields of the environment: *)
698
-
let acc = loop String_set.empty (Env.summary !Toploop.toplevel_env) in
699
-
(* Add accessible modules: *)
700
-
String_set.union acc (visible_modules ())
701
-
702
-
let global_fields () = get_cached global_fields list_global_fields
703
-
704
-
(* +-----------------------------------------------------------------+
705
-
| Listing methods |
706
-
+-----------------------------------------------------------------+ *)
707
-
708
-
let rec find_method meth type_expr =
709
-
match get_desc type_expr with
710
-
| Tlink type_expr ->
711
-
find_method meth type_expr
712
-
| Tobject (type_expr, _) ->
713
-
find_method meth type_expr
714
-
| Tfield (name, _, type_expr, rest) ->
715
-
if name = meth then
716
-
Some type_expr
717
-
else
718
-
find_method meth rest
719
-
| Tpoly (type_expr, _) ->
720
-
find_method meth type_expr
721
-
| Tconstr (path, _, _) -> begin
722
-
match lookup_env Env.find_type path !Toploop.toplevel_env with
723
-
| None
724
-
| Some { type_manifest = None } ->
725
-
None
726
-
| Some { type_manifest = Some type_expr } ->
727
-
find_method meth type_expr
728
-
end
729
-
| _ ->
730
-
None
731
-
732
-
let rec methods_of_type acc type_expr =
733
-
match get_desc type_expr with
734
-
| Tlink type_expr ->
735
-
methods_of_type acc type_expr
736
-
| Tobject (type_expr, _) ->
737
-
methods_of_type acc type_expr
738
-
| Tfield (name, _, _, rest) ->
739
-
methods_of_type (add name acc) rest
740
-
| Tpoly (type_expr, _) ->
741
-
methods_of_type acc type_expr
742
-
| Tconstr (path, _, _) -> begin
743
-
match lookup_env Env.find_type path !Toploop.toplevel_env with
744
-
| None
745
-
| Some { type_manifest = None } ->
746
-
acc
747
-
| Some { type_manifest = Some type_expr } ->
748
-
methods_of_type acc type_expr
749
-
end
750
-
| _ ->
751
-
acc
752
-
753
-
let rec find_object meths type_expr =
754
-
match meths with
755
-
| [] ->
756
-
Some type_expr
757
-
| meth :: meths ->
758
-
match find_method meth type_expr with
759
-
| Some type_expr ->
760
-
find_object meths type_expr
761
-
| None ->
762
-
None
763
-
764
-
let methods_of_object longident meths =
765
-
let lookup_value=
766
-
#if OCAML_VERSION >= (4, 10, 0)
767
-
Env.find_value_by_name
768
-
#else
769
-
Env.lookup_value
770
-
#endif
771
-
in
772
-
match lookup_env lookup_value longident !Toploop.toplevel_env with
773
-
| None ->
774
-
[]
775
-
| Some (path, { val_type = type_expr }) ->
776
-
match find_object meths type_expr with
777
-
| None ->
778
-
[]
779
-
| Some type_expr ->
780
-
String_set.elements (methods_of_type String_set.empty type_expr)
781
-
782
-
(* +-----------------------------------------------------------------+
783
-
| Listing labels |
784
-
+-----------------------------------------------------------------+ *)
785
-
786
-
let rec labels_of_type acc type_expr =
787
-
match get_desc type_expr with
788
-
| Tlink te ->
789
-
labels_of_type acc te
790
-
| Tpoly (te, _) ->
791
-
labels_of_type acc te
792
-
| Tarrow(label, _, te, _) ->
793
-
#if OCAML_VERSION < (4, 03, 0)
794
-
if label = "" then
795
-
labels_of_type acc te
796
-
else if label.[0] = '?' then
797
-
labels_of_type (String_map.add (String.sub label 1 (String.length label - 1)) Optional acc) te
798
-
else
799
-
labels_of_type (String_map.add label Required acc) te
800
-
#else
801
-
(match label with
802
-
| Nolabel ->
803
-
labels_of_type acc te
804
-
| Optional label ->
805
-
labels_of_type (String_map.add label Optional acc) te
806
-
| Labelled label ->
807
-
labels_of_type (String_map.add label Required acc) te)
808
-
#endif
809
-
| Tconstr(path, _, _) -> begin
810
-
match lookup_env Env.find_type path !Toploop.toplevel_env with
811
-
| None
812
-
| Some { type_manifest = None } ->
813
-
String_map.bindings acc
814
-
| Some { type_manifest = Some type_expr } ->
815
-
labels_of_type acc type_expr
816
-
end
817
-
| _ ->
818
-
String_map.bindings acc
819
-
820
-
let labels_of_function longident meths =
821
-
let lookup_value=
822
-
#if OCAML_VERSION >= (4, 10, 0)
823
-
Env.find_value_by_name
824
-
#else
825
-
Env.lookup_value
826
-
#endif
827
-
in
828
-
match lookup_env lookup_value longident !Toploop.toplevel_env with
829
-
| None ->
830
-
[]
831
-
| Some (path, { val_type = type_expr }) ->
832
-
match find_object meths type_expr with
833
-
| None ->
834
-
[]
835
-
| Some type_expr ->
836
-
labels_of_type String_map.empty type_expr
837
-
838
-
let labels_of_newclass longident =
839
-
let lookup_class=
840
-
#if OCAML_VERSION >= (4, 10, 0)
841
-
Env.find_class_by_name
842
-
#else
843
-
Env.lookup_class
844
-
#endif
845
-
in
846
-
match lookup_env lookup_class longident !Toploop.toplevel_env with
847
-
| None ->
848
-
[]
849
-
| Some (path, { cty_new = None }) ->
850
-
[]
851
-
| Some (path, { cty_new = Some type_expr }) ->
852
-
labels_of_type String_map.empty type_expr
853
-
854
-
(* +-----------------------------------------------------------------+
855
-
| Tokens processing |
856
-
+-----------------------------------------------------------------+ *)
857
-
858
-
(* Filter blanks and comments except for the last token. *)
859
-
let filter tokens =
860
-
let rec aux acc = function
861
-
| [] -> acc
862
-
| [((Blanks | Comment (_, true)), loc)] -> (Blanks, loc) :: acc
863
-
| ((Blanks | Comment (_, true)), _) :: rest -> aux acc rest
864
-
| x :: rest -> aux (x :: acc) rest
865
-
in
866
-
List.rev (aux [] tokens)
867
-
868
-
(* Reverse and filter blanks and comments except for the last
869
-
token. *)
870
-
let rec rev_filter acc tokens =
871
-
match tokens with
872
-
| [] -> acc
873
-
| [((Blanks | Comment (_, true)), loc)] -> (Blanks, loc) :: acc
874
-
| ((Blanks | Comment (_, true)), _) :: rest -> rev_filter acc rest
875
-
| x :: rest -> rev_filter (x :: acc) rest
876
-
877
-
(* Find the current context. *)
878
-
let rec find_context tokens = function
879
-
| [] ->
880
-
Some (rev_filter [] tokens)
881
-
| [(Quotation (items, false), _)] ->
882
-
find_context_in_quotation items
883
-
| _ :: rest ->
884
-
find_context tokens rest
885
-
886
-
and find_context_in_quotation = function
887
-
| [] ->
888
-
None
889
-
| [(Quot_anti { a_closing = None; a_contents = tokens }, _)] ->
890
-
find_context tokens tokens
891
-
| _ :: rest ->
892
-
find_context_in_quotation rest
893
-
894
-
(* +-----------------------------------------------------------------+
895
-
| Completion |
896
-
+-----------------------------------------------------------------+ *)
897
-
898
-
#if OCAML_VERSION < (4, 11, 0)
899
-
let longident_parse= Longident.parse
900
-
#else
901
-
let longident_parse str=
902
-
let lexbuf= Lexing.from_string str in
903
-
Parse.longident lexbuf
904
-
#endif
905
-
906
-
let complete ~phrase_terminator ~input =
907
-
let true_name, false_name = ("true", "false") in
908
-
let tokens = UTop_lexer.lex_string input in
909
-
(* Filter blanks and comments. *)
910
-
let tokens = filter tokens in
911
-
match tokens with
912
-
913
-
(* Completion on directive names. *)
914
-
| [(Symbol "#", { idx2 = stop })]
915
-
| [(Symbol "#", _); (Blanks, { idx2 = stop })] ->
916
-
(stop, list_directives phrase_terminator)
917
-
| [(Symbol "#", _); ((Lident src | Uident src), { idx1 = start })] ->
918
-
(start, lookup_assoc src (list_directives phrase_terminator))
919
-
920
-
(* Complete with ";;" when possible. *)
921
-
| [(Symbol "#", _); ((Lident _ | Uident _), _); (String (_, true), { idx2 = stop })]
922
-
| [(Symbol "#", _); ((Lident _ | Uident _), _); (String (_, true), _); (Blanks, { idx2 = stop })] ->
923
-
(stop, [(phrase_terminator, "")])
924
-
| [(Symbol "#", _); ((Lident _ | Uident _), _); (String (_, true), _); (Symbol sym, { idx1 = start })] ->
925
-
if Astring.String.is_prefix phrase_terminator ~affix:sym then
926
-
(start, [(phrase_terminator, "")])
927
-
else
928
-
(0, [])
929
-
930
-
(* Completion on #require. *)
931
-
| [(Symbol "#", _); (Lident "require", _); (String (tlen, false), loc)] ->
932
-
let pkg = String.sub input (loc.ofs1 + tlen) (String.length input - loc.ofs1 - tlen) in
933
-
let pkgs = lookup pkg [] in
934
-
(loc.idx1 + 1, List.map (fun pkg -> (pkg, "\"" ^ phrase_terminator)) (List.sort compare pkgs))
935
-
936
-
| [(Symbol "#", _); (Lident "typeof", _); (String (tlen, false), loc)] ->
937
-
let prefix = String.sub input (loc.ofs1 + tlen) (String.length input - loc.ofs1 - tlen) in
938
-
begin match longident_parse prefix with
939
-
| Longident.Ldot (lident, last_prefix) ->
940
-
let set = names_of_module lident in
941
-
let compls = lookup last_prefix (String_set.elements set) in
942
-
let start = loc.idx1 + 1 + (String.length prefix - String.length last_prefix) in
943
-
(start, List.map (fun w -> (w, "")) compls)
944
-
| _ ->
945
-
let set = global_names () in
946
-
let compls = lookup prefix (String_set.elements set) in
947
-
(loc.idx1 + 1, List.map (fun w -> (w, "")) compls)
948
-
end
949
-
950
-
(* Completion on #load. *)
951
-
| [(Symbol "#", _); (Lident ("load" | "load_rec"), _); (String (tlen, false), loc)] ->
952
-
let file = String.sub input (loc.ofs1 + tlen) (String.length input - loc.ofs1 - tlen) in
953
-
let filter name = Filename.check_suffix name ".cma" || Filename.check_suffix name ".cmo" in
954
-
let map =
955
-
if Filename.is_relative file then
956
-
let dir = Filename.dirname file in
957
-
List.fold_left
958
-
(fun acc d -> add_files filter acc (Filename.concat d dir))
959
-
String_map.empty
960
-
(Filename.current_dir_name ::
961
-
#if OCAML_VERSION >= (4, 08, 0)
962
-
(UTop_compat.get_load_path ())
963
-
#else
964
-
!Config.load_path
965
-
#endif
966
-
)
967
-
968
-
else
969
-
add_files filter String_map.empty (Filename.dirname file)
970
-
in
971
-
let list = String_map.bindings map in
972
-
let name = basename file in
973
-
let result = lookup_assoc name list in
974
-
(loc.idx2 - String.length name,
975
-
List.map (function (w, Directory) -> (w, "") | (w, File) -> (w, "\"" ^ phrase_terminator)) result)
976
-
977
-
(* Completion on #use and #mod_use *)
978
-
| [(Symbol "#", _); (Lident "use", _); (String (tlen, false), loc)]
979
-
| [(Symbol "#", _); (Lident "mod_use", _); (String (tlen, false), loc)] ->
980
-
let file = String.sub input (loc.ofs1 + tlen) (String.length input - loc.ofs1 - tlen) in
981
-
let filter name =
982
-
match try Some (String.rindex name '.') with Not_found -> None with
983
-
| None ->
984
-
true
985
-
| Some idx ->
986
-
let ext = String.sub name (idx + 1) (String.length name - (idx + 1)) in
987
-
ext = "ml"
988
-
in
989
-
let map =
990
-
if Filename.is_relative file then
991
-
let dir = Filename.dirname file in
992
-
List.fold_left
993
-
(fun acc d -> add_files filter acc (Filename.concat d dir))
994
-
String_map.empty
995
-
(Filename.current_dir_name ::
996
-
#if OCAML_VERSION >= (4, 08, 0)
997
-
UTop_compat.get_load_path ()
998
-
#else
999
-
!Config.load_path
1000
-
#endif
1001
-
)
1002
-
else
1003
-
add_files filter String_map.empty (Filename.dirname file)
1004
-
in
1005
-
let list = String_map.bindings map in
1006
-
let name = basename file in
1007
-
let result = lookup_assoc name list in
1008
-
(loc.idx2 - String.length name,
1009
-
List.map (function (w, Directory) -> (w, "") | (w, File) -> (w, "\"" ^ phrase_terminator)) result)
1010
-
1011
-
(* Completion on #directory and #cd. *)
1012
-
| [(Symbol "#", _); (Lident ("cd" | "directory"), _); (String (tlen, false), loc)] ->
1013
-
let file = String.sub input (loc.ofs1 + tlen) (String.length input - loc.ofs1 - tlen) in
1014
-
let list = list_directories (Filename.dirname file) in
1015
-
let name = basename file in
1016
-
let result = lookup name list in
1017
-
(loc.idx2 - String.length name, List.map (function dir -> (dir, "")) result)
1018
-
1019
-
(* Generic completion on directives. *)
1020
-
| [(Symbol "#", _); ((Lident dir | Uident dir), _); (Blanks, { idx2 = stop })] ->
1021
-
(stop,
1022
-
match[@alert "-deprecated"] try Some (Hashtbl.find Toploop.directive_table dir) with Not_found -> None with
1023
-
| Some (Toploop.Directive_none _) -> [(phrase_terminator, "")]
1024
-
| Some (Toploop.Directive_string _) -> [(" \"", "")]
1025
-
| Some (Toploop.Directive_bool _) -> [(true_name, phrase_terminator); (false_name, phrase_terminator)]
1026
-
| Some (Toploop.Directive_int _) -> []
1027
-
| Some (Toploop.Directive_ident _) -> List.map (fun w -> (w, "")) (String_set.elements (global_names ()))
1028
-
| None -> [])
1029
-
| (Symbol "#", _) :: ((Lident dir | Uident dir), _) :: tokens -> begin
1030
-
match[@alert "-deprecated"] try Some (Hashtbl.find Toploop.directive_table dir) with Not_found -> None with
1031
-
| Some (Toploop.Directive_none _) ->
1032
-
(0, [])
1033
-
| Some (Toploop.Directive_string _) ->
1034
-
(0, [])
1035
-
| Some (Toploop.Directive_bool _) -> begin
1036
-
match tokens with
1037
-
| [(Lident id, { idx1 = start })] ->
1038
-
(start, lookup_assoc id [(true_name, phrase_terminator); (false_name, phrase_terminator)])
1039
-
| _ ->
1040
-
(0, [])
1041
-
end
1042
-
| Some (Toploop.Directive_int _) ->
1043
-
(0, [])
1044
-
| Some (Toploop.Directive_ident _) -> begin
1045
-
match parse_longident (List.rev tokens) with
1046
-
| Some (Value, None, start, id) ->
1047
-
(start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (global_names ()))))
1048
-
| Some (Value, Some longident, start, id) ->
1049
-
(start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (names_of_module longident))))
1050
-
| _ ->
1051
-
(0, [])
1052
-
end
1053
-
| None ->
1054
-
(0, [])
1055
-
end
1056
-
1057
-
(* Completion on identifiers. *)
1058
-
| _ ->
1059
-
match find_context tokens tokens with
1060
-
| None ->
1061
-
(0, [])
1062
-
| Some [] ->
1063
-
(0, List.map (fun w -> (w, "")) (String_set.elements (String_set.union !UTop.keywords (global_names ()))))
1064
-
| Some tokens ->
1065
-
match parse_method tokens with
1066
-
| Some (longident, meths, start, meth) ->
1067
-
(start, List.map (fun w -> (w, "")) (lookup meth (methods_of_object longident meths)))
1068
-
| None ->
1069
-
match parse_label tokens with
1070
-
| Some (Fun, longident, meths, Optional, start, label) ->
1071
-
(start, List.map (fun (w, kind) -> (w, ":")) (lookup_assoc label (List.filter (function (w, Optional) -> true | (w, Required) -> false) (labels_of_function longident meths))))
1072
-
| Some (Fun, longident, meths, Required, start, label) ->
1073
-
(start, List.map (fun (w, kind) -> (w, ":")) (lookup_assoc label (labels_of_function longident meths)))
1074
-
| Some (New, longident, meths, Optional, start, label) ->
1075
-
(start, List.map (fun (w, kind) -> (w, ":")) (lookup_assoc label (List.filter (function (w, Optional) -> true | (w, Required) -> false) (labels_of_newclass longident))))
1076
-
| Some (New, longident, meths, Required, start, label) ->
1077
-
(start, List.map (fun (w, kind) -> (w, ":")) (lookup_assoc label (labels_of_newclass longident)))
1078
-
| None ->
1079
-
match parse_longident tokens with
1080
-
| None ->
1081
-
(0, [])
1082
-
| Some (Value, None, start, id) ->
1083
-
(start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (String_set.union !UTop.keywords (global_names ())))))
1084
-
| Some (Value, Some longident, start, id) ->
1085
-
(start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (names_of_module longident))))
1086
-
| Some (Field, None, start, id) ->
1087
-
(start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (global_fields ()))))
1088
-
| Some (Field, Some longident, start, id) ->
1089
-
(start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (fields_of_module longident))))
1090
-
1091
-
let complete ~phrase_terminator ~input =
1092
-
try
1093
-
(complete ~phrase_terminator ~input : int * (string * string) list)
1094
-
with Cmi_format.Error _ ->
1095
-
(0, [])
-18
lib/uTop_complete.mli
-18
lib/uTop_complete.mli
···
1
-
(*
2
-
* uTop_complete.mli
3
-
* -----------------
4
-
* Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
5
-
* Licence : BSD3
6
-
*
7
-
* This file is a part of utop.
8
-
*)
9
-
10
-
(** OCaml completion. *)
11
-
12
-
val complete :
13
-
phrase_terminator:string -> input:string -> int * (string * string) list
14
-
(** [complete ~phrase_terminator ~input] returns the start of the completed word
15
-
in [input] and the list of possible completions with their suffixes. *)
16
-
17
-
val reset : unit -> unit
18
-
(** Reset global cache. It must be called before each interactive read line. *)
-11
lib/uTop_lexer.mli
-11
lib/uTop_lexer.mli
···
1
-
(*
2
-
* uTop_lexer.mli
3
-
* --------------
4
-
* Copyright : (c) 2012, Jeremie Dimino <jeremie@dimino.org>
5
-
* Licence : BSD3
6
-
*
7
-
* This file is a part of utop.
8
-
*)
9
-
10
-
val lex_string : string -> (UTop_token.t * UTop_token.location) list
11
-
(** [lex_string str] returns all the tokens contained in [str]. *)
-230
lib/uTop_lexer.mll
-230
lib/uTop_lexer.mll
···
1
-
(*
2
-
* uTop_lexer.mll
3
-
* --------------
4
-
* Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
5
-
* Licence : BSD3
6
-
*
7
-
* This file is a part of utop.
8
-
*)
9
-
10
-
(* Lexer for the OCaml language. *)
11
-
12
-
{
13
-
open Lexing
14
-
open UTop_token
15
-
16
-
let mkloc idx1 idx2 ofs1 ofs2 = {
17
-
idx1 = idx1;
18
-
idx2 = idx2;
19
-
ofs1 = ofs1;
20
-
ofs2 = ofs2;
21
-
}
22
-
23
-
(* Only for ascii-only lexemes. *)
24
-
let lexeme_loc idx lexbuf =
25
-
let ofs1 = lexeme_start lexbuf and ofs2 = lexeme_end lexbuf in
26
-
{
27
-
idx1 = idx;
28
-
idx2 = idx + (ofs2 - ofs1);
29
-
ofs1 = ofs1;
30
-
ofs2 = ofs2;
31
-
}
32
-
33
-
let _merge_loc l1 l2 = {
34
-
idx1 = l1.idx1;
35
-
idx2 = l2.idx2;
36
-
ofs1 = l1.ofs1;
37
-
ofs2 = l2.ofs2;
38
-
}
39
-
40
-
}
41
-
42
-
let uchar = ['\x00' - '\x7f'] | _ [ '\x80' - '\xbf' ]*
43
-
44
-
let blank = [' ' '\009' '\012']
45
-
let lowercase = ['a'-'z' '_']
46
-
let uppercase = ['A'-'Z']
47
-
let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9']
48
-
let lident = lowercase identchar*
49
-
let uident = uppercase identchar*
50
-
let ident = (lowercase|uppercase) identchar*
51
-
52
-
let hexa_char = ['0'-'9' 'A'-'F' 'a'-'f']
53
-
let decimal_literal =
54
-
['0'-'9'] ['0'-'9' '_']*
55
-
let hex_literal =
56
-
'0' ['x' 'X'] hexa_char ['0'-'9' 'A'-'F' 'a'-'f' '_']*
57
-
let oct_literal =
58
-
'0' ['o' 'O'] ['0'-'7'] ['0'-'7' '_']*
59
-
let bin_literal =
60
-
'0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']*
61
-
let int_literal =
62
-
decimal_literal | hex_literal | oct_literal | bin_literal
63
-
let float_literal =
64
-
['0'-'9'] ['0'-'9' '_']*
65
-
('.' ['0'-'9' '_']* )?
66
-
(['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)?
67
-
68
-
let symbolchar =
69
-
['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~']
70
-
71
-
rule tokens idx acc = parse
72
-
| eof
73
-
{ (idx, None, List.rev acc) }
74
-
| ('\n' | blank)+
75
-
{ let loc = lexeme_loc idx lexbuf in
76
-
tokens loc.idx2 ((Blanks, loc) :: acc) lexbuf }
77
-
| lident
78
-
{ let src = lexeme lexbuf in
79
-
let loc = lexeme_loc idx lexbuf in
80
-
let tok =
81
-
match src with
82
-
| ("true" | "false") ->
83
-
Constant src
84
-
| _ ->
85
-
Lident src
86
-
in
87
-
tokens loc.idx2 ((tok, loc) :: acc) lexbuf }
88
-
| uident
89
-
{ let src = lexeme lexbuf in
90
-
let loc = lexeme_loc idx lexbuf in
91
-
let tok = Uident src in
92
-
tokens loc.idx2 ((tok, loc) :: acc) lexbuf }
93
-
| int_literal "l"
94
-
| int_literal "L"
95
-
| int_literal "n"
96
-
| int_literal
97
-
| float_literal
98
-
{ let loc = lexeme_loc idx lexbuf in
99
-
let tok = Constant (lexeme lexbuf) in
100
-
tokens loc.idx2 ((tok, loc) :: acc) lexbuf }
101
-
| '"'
102
-
{ let ofs = lexeme_start lexbuf in
103
-
let item, idx2= cm_string (idx + 1) lexbuf in
104
-
let loc = mkloc idx idx2 ofs (lexeme_end lexbuf) in
105
-
tokens idx2 ((item, loc) :: acc) lexbuf }
106
-
| '{' (lowercase* as tag) '|'
107
-
{ let ofs = lexeme_start lexbuf in
108
-
let delim_len = String.length tag + 2 in
109
-
let idx2, terminated = quoted_string (idx + delim_len) tag lexbuf in
110
-
let loc = mkloc idx idx2 ofs (lexeme_end lexbuf) in
111
-
tokens idx2 ((String (delim_len, terminated), loc) :: acc) lexbuf }
112
-
| "'" [^'\'' '\\'] "'"
113
-
| "'\\" ['\\' '"' 'n' 't' 'b' 'r' ' ' '\'' 'x' '0'-'9'] eof
114
-
| "'\\" ['\\' '"' 'n' 't' 'b' 'r' ' ' '\''] "'"
115
-
| "'\\" (['0'-'9'] ['0'-'9'] | 'x' hexa_char) eof
116
-
| "'\\" (['0'-'9'] ['0'-'9'] ['0'-'9'] | 'x' hexa_char hexa_char) eof
117
-
| "'\\" (['0'-'9'] ['0'-'9'] ['0'-'9'] | 'x' hexa_char hexa_char) "'"
118
-
{ let loc = lexeme_loc idx lexbuf in
119
-
tokens loc.idx2 ((Char, loc) :: acc) lexbuf }
120
-
| "'\\" uchar
121
-
{ let loc = mkloc idx (idx + 3) (lexeme_start lexbuf) (lexeme_end lexbuf) in
122
-
tokens loc.idx2 ((Error, loc) :: acc) lexbuf }
123
-
| "(*)"
124
-
{ let loc = lexeme_loc idx lexbuf in
125
-
tokens loc.idx2 ((Comment (Comment_reg, true), loc) :: acc) lexbuf }
126
-
| "(**)"
127
-
{ let loc = lexeme_loc idx lexbuf in
128
-
tokens loc.idx2 ((Comment (Comment_doc, true), loc) :: acc) lexbuf }
129
-
| "(**"
130
-
{ let ofs = lexeme_start lexbuf in
131
-
let idx2, terminated = comment (idx + 3) 0 lexbuf in
132
-
let loc = mkloc idx idx2 ofs (lexeme_end lexbuf) in
133
-
tokens idx2 ((Comment (Comment_doc, terminated), loc) :: acc) lexbuf }
134
-
| "(*"
135
-
{ let ofs = lexeme_start lexbuf in
136
-
let idx2, terminated = comment (idx + 2) 0 lexbuf in
137
-
let loc = mkloc idx idx2 ofs (lexeme_end lexbuf) in
138
-
tokens idx2 ((Comment (Comment_reg, terminated), loc) :: acc) lexbuf }
139
-
| ""
140
-
{ symbol idx acc lexbuf }
141
-
142
-
and symbol idx acc = parse
143
-
| "(" | ")"
144
-
| "[" | "]"
145
-
| "{" | "}"
146
-
| "`"
147
-
| "#"
148
-
| ","
149
-
| ";" | ";;"
150
-
| symbolchar+
151
-
{ let loc = lexeme_loc idx lexbuf in
152
-
let tok = Symbol (lexeme lexbuf) in
153
-
tokens loc.idx2 ((tok, loc) :: acc) lexbuf }
154
-
| uchar
155
-
{
156
-
let loc = mkloc idx (idx + 1) (lexeme_start lexbuf) (lexeme_end lexbuf) in
157
-
tokens loc.idx2 ((Error, loc) :: acc) lexbuf
158
-
}
159
-
160
-
and cm_string idx= parse
161
-
| '"'
162
-
{ (String (1, true), idx+1) }
163
-
| "\\\""
164
-
{ let idx2, terminated= string (idx + 2) lexbuf in
165
-
(String (1, terminated), idx2)
166
-
}
167
-
| uchar
168
-
{
169
-
170
-
let idx2, terminated= string (idx + 1) lexbuf in
171
-
(String (1, terminated), idx2)
172
-
}
173
-
| eof
174
-
{ (String (1, false), idx) }
175
-
176
-
and comment idx depth = parse
177
-
| "(*"
178
-
{ comment (idx + 2) (depth + 1) lexbuf }
179
-
| "*)"
180
-
{ if depth = 0 then
181
-
(idx + 2, true)
182
-
else
183
-
comment (idx + 2) (depth - 1) lexbuf }
184
-
| '"'
185
-
{ let idx, terminated = string (idx + 1) lexbuf in
186
-
if terminated then
187
-
comment idx depth lexbuf
188
-
else
189
-
(idx, false) }
190
-
| uchar
191
-
{
192
-
comment (idx + 1) depth lexbuf
193
-
194
-
}
195
-
| eof
196
-
{ (idx, false) }
197
-
198
-
and string idx = parse
199
-
| '"'
200
-
{ (idx + 1, true) }
201
-
| "\\\""
202
-
{ string (idx + 2) lexbuf }
203
-
| uchar
204
-
{
205
-
string (idx + 1) lexbuf
206
-
207
-
}
208
-
| eof
209
-
{ (idx, false) }
210
-
211
-
and quoted_string idx tag = parse
212
-
| '|' (lowercase* as tag2) '}'
213
-
{ let idx = idx + 2 + String.length tag2 in
214
-
if tag = tag2 then
215
-
(idx, true)
216
-
else
217
-
quoted_string idx tag lexbuf }
218
-
| eof
219
-
{ (idx, false) }
220
-
| uchar
221
-
{
222
-
quoted_string (idx + 1) tag lexbuf
223
-
224
-
}
225
-
226
-
{
227
-
let lex_string str =
228
-
let _, _, items = tokens 0 [] (Lexing.from_string str) in
229
-
items
230
-
}
-48
lib/uTop_token.ml
-48
lib/uTop_token.ml
···
1
-
(*
2
-
* uTop_token.ml
3
-
* -------------
4
-
* Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
5
-
* Licence : BSD3
6
-
*
7
-
* This file is a part of utop.
8
-
*)
9
-
10
-
(** Tokens.
11
-
12
-
The type of tokens is semi-structured: parentheses construct and quotations
13
-
are nested and others tokens are flat list. *)
14
-
15
-
type location = {
16
-
idx1 : int; (** Start position in unicode characters. *)
17
-
idx2 : int; (** Stop position in unicode characters. *)
18
-
ofs1 : int; (** Start position in bytes. *)
19
-
ofs2 : int; (** Stop position in bytes. *)
20
-
}
21
-
(** Locations in the source string, which is encoded in UTF-8. *)
22
-
23
-
type t =
24
-
| Symbol of string
25
-
| Lident of string
26
-
| Uident of string
27
-
| Constant of string
28
-
| Char
29
-
| String of int * bool (** [String (quote_size, terminated)]. *)
30
-
| Comment of comment_kind * bool (** [Comment (kind, terminated)]. *)
31
-
| Blanks
32
-
| Error
33
-
| Quotation of (quotation_item * location) list * bool
34
-
(** [Quotation (items, terminated)]. *)
35
-
36
-
and comment_kind =
37
-
| Comment_reg (** Regular comment. *)
38
-
| Comment_doc (** Documentation comment. *)
39
-
40
-
and quotation_item = Quot_data | Quot_anti of antiquotation
41
-
42
-
and antiquotation = {
43
-
a_opening : location; (** Location of the opening [$]. *)
44
-
a_closing : location option; (** Location of the closing [$]. *)
45
-
a_name : (location * location) option;
46
-
(** Location of the name and colon if any. *)
47
-
a_contents : (t * location) list; (** Contents of the location. *)
48
-
}