@@ -78,6 +78,10 @@ module Lexbuf = struct
7878 | Parser. SEMISEMI -> lexbuf.Lexing. lex_last_action
7979 | _ -> assert false
8080
81+ let map_error_loc ~f (error : Location.error ) =
82+ let f_msg (msg : Location.msg ) = { msg with loc = f msg.loc } in
83+ { error with main = f_msg error.main; sub = List. map f_msg error.sub }
84+
8185 let shift_location_error start =
8286 map_error_loc ~f: (shift_toplevel_location ~start )
8387
@@ -105,6 +109,12 @@ module Phrase = struct
105109
106110 let start t = t.startpos
107111
112+ let error_of_exn exn =
113+ match Location. error_of_exn exn with
114+ | None -> None
115+ | Some `Already_displayed -> None
116+ | Some (`Ok error ) -> Some error
117+
108118 let parse lines =
109119 let contents = String. concat " \n " in
110120 let lexbuf = Lexing. from_string contents in
@@ -143,14 +153,21 @@ module Phrase = struct
143153 let lines = if ends_by_semi_semi lines then lines else lines @ [ " ;;" in
144154 match parse lines with exception End_of_file -> None | t -> Some t
145155
156+ (* * Returns the name of the toplevel directive or [None] if the given phrase
157+ is not a directive *)
158+ let top_directive_name (toplevel_phrase : Parsetree.toplevel_phrase ) =
159+ match toplevel_phrase with
160+ | Ptop_def _ -> None
161+ | Ptop_dir { pdir_name = { txt; _ } ; _ } -> Some txt
162+
146163 let is_findlib_directive =
147164 let findlib_directive = function
148165 | "require" | "use" | "camlp4o" | "camlp4r" | "thread" -> true
149166 | _ -> false
150167 in
151168 function
152169 | { parsed = Ok toplevel_phrase ; _ } -> (
153- match Compat_top. top_directive_name toplevel_phrase with
170+ match top_directive_name toplevel_phrase with
154171 | Some dir -> findlib_directive dir
155172 | None -> false )
156173 | _ -> false
@@ -212,6 +229,11 @@ module Rewrite = struct
212229 | _ -> path)
213230 | _ -> path
214231
232+ let rec get_id_in_path = function
233+ | Path. Pident id -> id
234+ | Path. Pdot (p , _ ) -> get_id_in_path p
235+ | Path. Papply (_ , p ) -> get_id_in_path p
236+
215237 let is_persistent_value env longident =
216238 let is_persistent_path p = Ident. persistent (get_id_in_path p) in
217239 try is_persistent_path (fst (Compat_top. lookup_value longident env))
@@ -271,9 +293,19 @@ module Rewrite = struct
271293 Ptop_def pstr)
272294 | _ -> phrase
273295
296+ (* * [top_directive require "pkg"] builds the AST for [#require "pkg"] *)
297+ let top_directive_require pkg =
298+ Parsetree. Ptop_dir
299+ {
300+ pdir_name = { txt = " require" = Location. none };
301+ pdir_arg =
302+ Some { pdira_desc = Pdir_string pkg; pdira_loc = Location. none };
303+ pdir_loc = Location. none;
304+ }
305+
274306 let preload verbose ppf =
275307 let require pkg =
276- let p = Compat_top. top_directive_require pkg in
308+ let p = top_directive_require pkg in
277309 let _ = Toploop. execute_phrase verbose ppf p in
278310 ()
279311 in
@@ -428,12 +460,55 @@ let eval t cmd =
428460 |> List. concat
429461 |> fun x -> if ! errors then Result. Error x else Result. Ok x))
430462
463+ let add_directive ~name ~doc kind =
464+ let directive =
465+ match kind with
466+ | `Bool f -> Toploop. Directive_bool f
467+ | `Show_prim to_sig ->
468+ let show_prim to_sig lid =
469+ let env = ! Toploop. toplevel_env in
470+ let loc = Location. none in
471+ try
472+ let s =
473+ match lid with
474+ | Longident. Lident s -> s
475+ | Longident. Ldot (_ , s ) -> s
476+ | Longident. Lapply _ ->
477+ Format. printf " Invalid path %a@." Printtyp. longident lid;
478+ raise Exit
479+ in
480+ let id = Ident. create_persistent s in
481+ let sg = to_sig env loc id lid in
482+ Printtyp. wrap_printing_env ~error: false env (fun () ->
483+ Format. printf " @[%a@]@." Printtyp. signature sg)
484+ with
485+ | Not_found -> Format. printf " @[Unknown element.@]@."
486+ | Exit -> ()
487+ in
488+ Toploop. Directive_ident (show_prim to_sig)
489+ in
490+ Toploop. add_directive name directive { section = " Environment queries"
491+
431492let all_show_funs = ref []
432493
433494let reg_show_prim name to_sig doc =
434495 all_show_funs := to_sig :: ! all_show_funs;
435496 add_directive ~name ~doc (`Show_prim to_sig)
436497
498+ let sig_value id desc = Types. Sig_value (id, desc, Exported )
499+
500+ let sig_type id desc = Types. Sig_type (id, desc, Trec_not , Exported )
501+
502+ let sig_typext id ext = Types. Sig_typext (id, ext, Text_exception , Exported )
503+
504+ let sig_module id md = Types. Sig_module (id, Mp_present , md, Trec_not , Exported )
505+
506+ let sig_modtype id desc = Types. Sig_modtype (id, desc, Exported )
507+
508+ let sig_class id desc = Types. Sig_class (id, desc, Trec_not , Exported )
509+
510+ let sig_class_type id desc = Types. Sig_class_type (id, desc, Trec_not , Exported )
511+
437512let show_val () =
438513 reg_show_prim " show_val"
439514 (fun env loc id lid ->
@@ -469,6 +544,31 @@ let show_exception () =
469544 [ sig_typext id ext ])
470545 " Print the signature of the corresponding exception."
471546
547+ let mty_path =
548+ let open Types in
549+ function
550+ | Mty_alias path -> Some path
551+ | Mty_ident _ | Mty_signature _ | Mty_functor _ -> None
552+
553+ let map_sig_attributes ~f =
554+ let open Types in
555+ List. map (function
556+ | Sig_module (id , mp , md , rs , visibility ) ->
557+ Sig_module
558+ ( id,
559+ mp,
560+ { md with md_attributes = f md.md_attributes },
561+ rs,
562+ visibility )
563+ | item -> item)
564+
565+ let attribute ~name ~payload =
566+ {
567+ Parsetree. attr_name = name;
568+ attr_payload = payload;
569+ attr_loc = Location. none;
570+ }
571+
472572let show_module () =
473573 let open Types in
474574 let trim_signature = function
@@ -632,6 +732,8 @@ let init ~verbose:v ~silent:s ~verbose_findlib ~directives ~packages ~predicates
632732
633733let envs = Hashtbl. create 8
634734
735+ let is_predef_or_global id = Ident. is_predef id || Ident. global id
736+
635737let rec save_summary acc s =
636738 let default_case summary = save_summary acc summary in
637739 let add summary id =
0 commit comments