API tools faq
paste
Guest User

Untitled

a guest
Feb 16th, 2019
94
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 14.23 KB | None | 0 0
raw download clone embed print report
  1. Index: parsing/printast.mli
  2. ===================================================================
  3. --- parsing/printast.mli (revision 13953)
  4. +++ parsing/printast.mli (working copy)
  5. @@ -16,3 +16,4 @@
  6. val interface : formatter -> signature_item list -> unit;;
  7. val implementation : formatter -> structure_item list -> unit;;
  8. val top_phrase : formatter -> toplevel_phrase -> unit;;
  9. +val string_of_kind : ident_kind -> string;;
  10. Index: parsing/pprintast.ml
  11. ===================================================================
  12. --- parsing/pprintast.ml (revision 13953)
  13. +++ parsing/pprintast.ml (working copy)
  14. @@ -1192,8 +1192,10 @@
  15. | Pdir_none -> ()
  16. | Pdir_string (s) -> pp f "@ %S" s
  17. | Pdir_int (i) -> pp f "@ %d" i
  18. - | Pdir_ident (li) -> pp f "@ %a" self#longident li
  19. - | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b))
  20. + | Pdir_ident {txt=li} -> pp f "@ %a" self#longident li
  21. + | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b)
  22. + | Pdir_show (k, {txt=li}) ->
  23. + pp f "@ %s %a" (Printast.string_of_kind k) self#longident li)
  24.  
  25. method toplevel_phrase f x =
  26. match x with
  27. Index: parsing/parser.mly
  28. ===================================================================
  29. --- parsing/parser.mly (revision 13953)
  30. +++ parsing/parser.mly (working copy)
  31. @@ -516,9 +516,9 @@
  32. | SEMISEMI EOF { [] }
  33. | SEMISEMI seq_expr use_file_tail { Ptop_def[mkstrexp $2] :: $3 }
  34. | SEMISEMI structure_item use_file_tail { Ptop_def[$2] :: $3 }
  35. - | SEMISEMI toplevel_directive use_file_tail { $2 :: $3 }
  36. | structure_item use_file_tail { Ptop_def[$1] :: $2 }
  37. - | toplevel_directive use_file_tail { $1 :: $2 }
  38. + | SEMISEMI toplevel_directive SEMISEMI use_file_tail { $2 :: $4 }
  39. + | toplevel_directive SEMISEMI use_file_tail { $1 :: $3 }
  40. ;
  41.  
  42. /* Module expressions */
  43. @@ -1779,16 +1779,26 @@
  44. | FALSE { Lident "false" }
  45. | TRUE { Lident "true" }
  46. ;
  47. +ident_kind:
  48. + VAL { Pkind_val }
  49. + | TYPE { Pkind_type }
  50. + | EXCEPTION { Pkind_exception }
  51. + | MODULE { Pkind_module }
  52. + | MODULE TYPE { Pkind_modtype }
  53. + | CLASS { Pkind_class }
  54. + | CLASS TYPE { Pkind_cltype }
  55. +;
  56.  
  57. /* Toplevel directives */
  58.  
  59. toplevel_directive:
  60. - SHARP ident { Ptop_dir($2, Pdir_none) }
  61. - | SHARP ident STRING { Ptop_dir($2, Pdir_string $3) }
  62. - | SHARP ident INT { Ptop_dir($2, Pdir_int $3) }
  63. - | SHARP ident val_longident { Ptop_dir($2, Pdir_ident $3) }
  64. - | SHARP ident FALSE { Ptop_dir($2, Pdir_bool false) }
  65. - | SHARP ident TRUE { Ptop_dir($2, Pdir_bool true) }
  66. + SHARP ident { Ptop_dir($2, Pdir_none) }
  67. + | SHARP ident STRING { Ptop_dir($2, Pdir_string $3) }
  68. + | SHARP ident INT { Ptop_dir($2, Pdir_int $3) }
  69. + | SHARP ident val_longident { Ptop_dir($2, Pdir_ident (mkrhs $3 3)) }
  70. + | SHARP ident ident_kind any_longident { Ptop_dir($2, Pdir_show ($3, mkrhs $4 4)) }
  71. + | SHARP ident FALSE { Ptop_dir($2, Pdir_bool false) }
  72. + | SHARP ident TRUE { Ptop_dir($2, Pdir_bool true) }
  73. ;
  74.  
  75. /* Miscellaneous */
  76. Index: parsing/parsetree.mli
  77. ===================================================================
  78. --- parsing/parsetree.mli (revision 13953)
  79. +++ parsing/parsetree.mli (working copy)
  80. @@ -294,6 +294,15 @@
  81.  
  82. (* Toplevel phrases *)
  83.  
  84. +type ident_kind =
  85. + Pkind_val
  86. + | Pkind_type
  87. + | Pkind_exception
  88. + | Pkind_module
  89. + | Pkind_modtype
  90. + | Pkind_class
  91. + | Pkind_cltype
  92. +
  93. type toplevel_phrase =
  94. Ptop_def of structure
  95. | Ptop_dir of string * directive_argument
  96. @@ -302,5 +311,6 @@
  97. Pdir_none
  98. | Pdir_string of string
  99. | Pdir_int of int
  100. - | Pdir_ident of Longident.t
  101. + | Pdir_ident of Longident.t Location.loc
  102. + | Pdir_show of ident_kind * Longident.t Location.loc
  103. | Pdir_bool of bool
  104. Index: parsing/printast.ml
  105. ===================================================================
  106. --- parsing/printast.ml (revision 13953)
  107. +++ parsing/printast.ml (working copy)
  108. @@ -737,6 +737,16 @@
  109. core_type (i+1) ppf ct
  110. ;;
  111.  
  112. +let string_of_kind = function
  113. + Pkind_val -> "val"
  114. + | Pkind_type -> "type"
  115. + | Pkind_exception -> "exception"
  116. + | Pkind_module -> "module"
  117. + | Pkind_modtype -> "module type"
  118. + | Pkind_class -> "class"
  119. + | Pkind_cltype -> "class type"
  120. +;;
  121. +
  122. let rec toplevel_phrase i ppf x =
  123. match x with
  124. | Ptop_def (s) ->
  125. @@ -751,7 +761,9 @@
  126. | Pdir_none -> line i ppf "Pdir_none\n"
  127. | Pdir_string (s) -> line i ppf "Pdir_string \"%s\"\n" s;
  128. | Pdir_int (i) -> line i ppf "Pdir_int %d\n" i;
  129. - | Pdir_ident (li) -> line i ppf "Pdir_ident %a\n" fmt_longident li;
  130. + | Pdir_ident {txt=li} -> line i ppf "Pdir_ident %a\n" fmt_longident li;
  131. + | Pdir_show (kind,{txt=li}) ->
  132. + line i ppf "Pdir_show %s %a\n" (string_of_kind kind) fmt_longident li;
  133. | Pdir_bool (b) -> line i ppf "Pdir_bool %s\n" (string_of_bool b);
  134. ;;
  135.  
  136. Index: toplevel/opttoploop.ml
  137. ===================================================================
  138. --- toplevel/opttoploop.ml (revision 13953)
  139. +++ toplevel/opttoploop.ml (working copy)
  140. @@ -53,6 +53,7 @@
  141. | Directive_string of (string -> unit)
  142. | Directive_int of (int -> unit)
  143. | Directive_ident of (Longident.t -> unit)
  144. + | Directive_show of (ident_kind -> Longident.t -> unit)
  145. | Directive_bool of (bool -> unit)
  146.  
  147.  
  148. @@ -270,6 +271,7 @@
  149. | (Directive_string f, Pdir_string s) -> f s; true
  150. | (Directive_int f, Pdir_int n) -> f n; true
  151. | (Directive_ident f, Pdir_ident lid) -> f lid; true
  152. + | (Directive_show f, Pdir_show (kind,lid)) -> f kind lid; true
  153. | (Directive_bool f, Pdir_bool b) -> f b; true
  154. | (_, _) ->
  155. fprintf ppf "Wrong type of argument for directive `%s'.@." dir_name;
  156. Index: toplevel/topdirs.ml
  157. ===================================================================
  158. --- toplevel/topdirs.ml (revision 13953)
  159. +++ toplevel/topdirs.ml (working copy)
  160. @@ -15,6 +15,7 @@
  161. open Format
  162. open Misc
  163. open Longident
  164. +open Parsetree
  165. open Types
  166. open Cmo_format
  167. open Trace
  168. @@ -191,9 +192,9 @@
  169. Ctype.generalize ty_arg;
  170. ty_arg
  171.  
  172. -let find_printer_type ppf lid =
  173. +let find_printer_type ppf {Location.loc; txt=lid} =
  174. try
  175. - let (path, desc) = Env.lookup_value lid !toplevel_env in
  176. + let (path, desc) = Typetexp.find_value !toplevel_env loc lid in
  177. let (ty_arg, is_old_style) =
  178. try
  179. (match_printer_type ppf desc "printer_type_new", false)
  180. @@ -201,12 +202,12 @@
  181. (match_printer_type ppf desc "printer_type_old", true) in
  182. (ty_arg, path, is_old_style)
  183. with
  184. - | Not_found ->
  185. - fprintf ppf "Unbound value %a.@." Printtyp.longident lid;
  186. + Typetexp.Error _ as exn ->
  187. + Errors.report_error ppf exn;
  188. raise Exit
  189. | Ctype.Unify _ ->
  190. fprintf ppf "%a has a wrong type for a printing function.@."
  191. - Printtyp.longident lid;
  192. + Printtyp.longident lid;
  193. raise Exit
  194.  
  195. let dir_install_printer ppf lid =
  196. @@ -227,7 +228,7 @@
  197. begin try
  198. remove_printer path
  199. with Not_found ->
  200. - fprintf ppf "No printer named %a.@." Printtyp.longident lid
  201. + fprintf ppf "No printer named %a.@." Printtyp.longident lid.Location.txt
  202. end
  203. with Exit -> ()
  204.  
  205. @@ -244,9 +245,9 @@
  206. get_code_pointer
  207. (Obj.repr (fun arg -> Trace.print_trace (current_environment()) arg))
  208.  
  209. -let dir_trace ppf lid =
  210. +let dir_trace ppf {Location.loc; txt=lid} =
  211. try
  212. - let (path, desc) = Env.lookup_value lid !toplevel_env in
  213. + let (path, desc) = Typetexp.find_value !toplevel_env loc lid in
  214. (* Check if this is a primitive *)
  215. match desc.val_kind with
  216. | Val_prim p ->
  217. @@ -278,11 +279,11 @@
  218. fprintf ppf "%a is now traced.@." Printtyp.longident lid
  219. end else fprintf ppf "%a is not a function.@." Printtyp.longident lid
  220. with
  221. - | Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid
  222. + Typetexp.Error _ as exn -> Errors.report_error ppf exn
  223.  
  224. -let dir_untrace ppf lid =
  225. +let dir_untrace ppf {Location.loc; txt=lid} =
  226. try
  227. - let (path, desc) = Env.lookup_value lid !toplevel_env in
  228. + let (path, desc) = Typetexp.find_value !toplevel_env loc lid in
  229. let rec remove = function
  230. | [] ->
  231. fprintf ppf "%a was not traced.@." Printtyp.longident lid;
  232. @@ -295,7 +296,7 @@
  233. end else f :: remove rem in
  234. traced_functions := remove !traced_functions
  235. with
  236. - | Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid
  237. + Typetexp.Error _ as exn -> Errors.report_error ppf exn
  238.  
  239. let dir_untrace_all ppf () =
  240. List.iter
  241. @@ -305,10 +306,74 @@
  242. !traced_functions;
  243. traced_functions := []
  244.  
  245. +(* Warnings *)
  246. +
  247. let parse_warnings ppf iserr s =
  248. try Warnings.parse_options iserr s
  249. with Arg.Bad err -> fprintf ppf "%s.@." err
  250.  
  251. +(* Typing information *)
  252. +
  253. +let rec trim_modtype = function
  254. + Mty_signature _ -> Mty_signature []
  255. + | Mty_functor (id, mty, mty') ->
  256. + Mty_functor (id, mty, trim_modtype mty')
  257. + | Mty_ident _ as mty -> mty
  258. +
  259. +let trim_signature = function
  260. + Mty_signature sg ->
  261. + Mty_signature
  262. + (List.map
  263. + (function
  264. + Sig_module (id, mty, rs) ->
  265. + Sig_module (id, trim_modtype mty, rs)
  266. + (*| Sig_modtype (id, Modtype_manifest mty) ->
  267. + Sig_modtype (id, Modtype_manifest (trim_modtype mty))*)
  268. + | item -> item)
  269. + sg)
  270. + | mty -> mty
  271. +
  272. +let dir_show ppf kind {Location.loc; txt=lid} =
  273. + let env = !Toploop.toplevel_env in
  274. + try
  275. + let id =
  276. + let s = match lid with
  277. + Longident.Lident s -> s
  278. + | Longident.Ldot (_,s) -> s
  279. + | Longident.Lapply _ -> failwith "invalid"
  280. + in Ident.create_persistent s
  281. + in
  282. + let item =
  283. + match kind with
  284. + Pkind_val ->
  285. + let path, desc = Typetexp.find_value env loc lid in
  286. + Sig_value (id, desc)
  287. + | Pkind_type ->
  288. + let path, desc = Typetexp.find_type env loc lid in
  289. + Sig_type (id, desc, Trec_not)
  290. + | Pkind_exception ->
  291. + let desc = Typetexp.find_constructor env loc lid in
  292. + Sig_exception (id, {exn_args=desc.cstr_args; exn_loc=Location.none})
  293. + | Pkind_module ->
  294. + let path, desc = Typetexp.find_module env loc lid in
  295. + Sig_module (id, trim_signature desc, Trec_not)
  296. + | Pkind_modtype ->
  297. + let path, desc = Typetexp.find_modtype env loc lid in
  298. + Sig_modtype (id, desc)
  299. + | Pkind_class ->
  300. + let path, desc = Typetexp.find_class env loc lid in
  301. + Sig_class (id, desc, Trec_not)
  302. + | Pkind_cltype ->
  303. + let path, desc = Typetexp.find_class_type env loc lid in
  304. + Sig_class_type (id, desc, Trec_not)
  305. + in
  306. + fprintf ppf "%a@." Printtyp.signature [item]
  307. + with
  308. + Not_found ->
  309. + fprintf ppf "Unknown %s.@." (Printast.string_of_kind kind)
  310. + | Failure "invalid" ->
  311. + fprintf ppf "Invalid path %a@." Printtyp.longident lid
  312. +
  313. let _ =
  314. Hashtbl.add directive_table "trace" (Directive_ident (dir_trace std_out));
  315. Hashtbl.add directive_table "untrace" (Directive_ident (dir_untrace std_out));
  316. @@ -337,4 +402,7 @@
  317. (Directive_string (parse_warnings std_out false));
  318.  
  319. Hashtbl.add directive_table "warn_error"
  320. - (Directive_string (parse_warnings std_out true))
  321. + (Directive_string (parse_warnings std_out true));
  322. +
  323. + Hashtbl.add directive_table "show"
  324. + (Directive_show (dir_show std_out))
  325. Index: toplevel/toploop.ml
  326. ===================================================================
  327. --- toplevel/toploop.ml (revision 13953)
  328. +++ toplevel/toploop.ml (working copy)
  329. @@ -25,7 +25,8 @@
  330. | Directive_none of (unit -> unit)
  331. | Directive_string of (string -> unit)
  332. | Directive_int of (int -> unit)
  333. - | Directive_ident of (Longident.t -> unit)
  334. + | Directive_ident of (Longident.t Location.loc -> unit)
  335. + | Directive_show of (ident_kind -> Longident.t Location.loc -> unit)
  336. | Directive_bool of (bool -> unit)
  337.  
  338. (* The table of toplevel value bindings and its accessors *)
  339. @@ -280,6 +281,7 @@
  340. | (Directive_string f, Pdir_string s) -> f s; true
  341. | (Directive_int f, Pdir_int n) -> f n; true
  342. | (Directive_ident f, Pdir_ident lid) -> f lid; true
  343. + | (Directive_show f, Pdir_show (kind,lid)) -> f kind lid; true
  344. | (Directive_bool f, Pdir_bool b) -> f b; true
  345. | (_, _) ->
  346. fprintf ppf "Wrong type of argument for directive `%s'.@." dir_name;
  347. Index: toplevel/topdirs.mli
  348. ===================================================================
  349. --- toplevel/topdirs.mli (revision 13953)
  350. +++ toplevel/topdirs.mli (working copy)
  351. @@ -20,11 +20,12 @@
  352. val dir_cd : string -> unit
  353. val dir_load : formatter -> string -> unit
  354. val dir_use : formatter -> string -> unit
  355. -val dir_install_printer : formatter -> Longident.t -> unit
  356. -val dir_remove_printer : formatter -> Longident.t -> unit
  357. -val dir_trace : formatter -> Longident.t -> unit
  358. -val dir_untrace : formatter -> Longident.t -> unit
  359. +val dir_install_printer : formatter -> Longident.t Location.loc -> unit
  360. +val dir_remove_printer : formatter -> Longident.t Location.loc -> unit
  361. +val dir_trace : formatter -> Longident.t Location.loc -> unit
  362. +val dir_untrace : formatter -> Longident.t Location.loc -> unit
  363. val dir_untrace_all : formatter -> unit -> unit
  364. +val dir_show : formatter -> Parsetree.ident_kind -> Longident.t Location.loc -> unit
  365.  
  366. type 'a printer_type_new = Format.formatter -> 'a -> unit
  367. type 'a printer_type_old = 'a -> unit
  368. Index: toplevel/toploop.mli
  369. ===================================================================
  370. --- toplevel/toploop.mli (revision 13953)
  371. +++ toplevel/toploop.mli (working copy)
  372. @@ -37,7 +37,8 @@
  373. | Directive_none of (unit -> unit)
  374. | Directive_string of (string -> unit)
  375. | Directive_int of (int -> unit)
  376. - | Directive_ident of (Longident.t -> unit)
  377. + | Directive_ident of (Longident.t Location.loc -> unit)
  378. + | Directive_show of (Parsetree.ident_kind -> Longident.t Location.loc -> unit)
  379. | Directive_bool of (bool -> unit)
  380.  
  381. val directive_table : (string, directive_fun) Hashtbl.t
Add Comment
Please, Sign In to add comment
Public Pastes
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!