API tools faq
paste
Guest User

Untitled

a guest
Feb 18th, 2019
68
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 9.99 KB | None | 0 0
raw download clone embed print report
  1. From c2179b338925399f22cf9cd3e99dc7c5ee36853b Mon Sep 17 00:00:00 2001
  2. From: Pierre Chambart <pierre.chambart@ocamlpro.com>
  3. Date: Thu, 19 Jun 2014 21:01:03 +0200
  4. Subject: [PATCH 1/4] toplevel: allows the extension of 'genprintval.ml' with
  5. parameterised printer.
  6.  
  7. ---
  8. toplevel/genprintval.ml | 129 ++++++++++++++++++++++++++++++++++++-----------
  9. toplevel/genprintval.mli | 14 +++++
  10. toplevel/toploop.ml | 6 +++
  11. toplevel/toploop.mli | 11 ++++
  12. 4 files changed, 130 insertions(+), 30 deletions(-)
  13.  
  14. diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
  15. index 625a0a5..2aec7aa 100644
  16. --- a/toplevel/genprintval.ml
  17. +++ b/toplevel/genprintval.ml
  18. @@ -37,11 +37,25 @@ module type EVALPATH =
  19. val same_value: valu -> valu -> bool
  20. end
  21.  
  22. +type ('a, 'b) gen_printer =
  23. + | Zero of 'b
  24. + | Succ of ('a -> ('a, 'b) gen_printer)
  25. +
  26. module type S =
  27. sig
  28. type t
  29. val install_printer :
  30. Path.t -> Types.type_expr -> (formatter -> t -> unit) -> unit
  31. + val install_generic_printer :
  32. + Path.t -> Path.t ->
  33. + (int -> (int -> t -> Outcometree.out_value,
  34. + t -> Outcometree.out_value) gen_printer) ->
  35. + unit
  36. + val install_generic_printer' :
  37. + Path.t -> Path.t ->
  38. + (formatter -> t -> unit,
  39. + formatter -> t -> unit) gen_printer ->
  40. + unit
  41. val remove_printer : Path.t -> unit
  42. val outval_of_untyped_exception : t -> Outcometree.out_value
  43. val outval_of_value :
  44. @@ -104,47 +118,73 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
  45.  
  46. (* The user-defined printers. Also used for some builtin types. *)
  47.  
  48. + type printer =
  49. + | Simple of Types.type_expr * (O.t -> Outcometree.out_value)
  50. + | Generic of Path.t * (int -> (int -> O.t -> Outcometree.out_value,
  51. + O.t -> Outcometree.out_value) gen_printer)
  52. +
  53. let printers = ref ([
  54. - Pident(Ident.create "print_int"), Predef.type_int,
  55. - (fun x -> Oval_int (O.obj x : int));
  56. - Pident(Ident.create "print_float"), Predef.type_float,
  57. - (fun x -> Oval_float (O.obj x : float));
  58. - Pident(Ident.create "print_char"), Predef.type_char,
  59. - (fun x -> Oval_char (O.obj x : char));
  60. - Pident(Ident.create "print_string"), Predef.type_string,
  61. - (fun x -> Oval_string (O.obj x : string));
  62. - Pident(Ident.create "print_int32"), Predef.type_int32,
  63. - (fun x -> Oval_int32 (O.obj x : int32));
  64. - Pident(Ident.create "print_nativeint"), Predef.type_nativeint,
  65. - (fun x -> Oval_nativeint (O.obj x : nativeint));
  66. - Pident(Ident.create "print_int64"), Predef.type_int64,
  67. - (fun x -> Oval_int64 (O.obj x : int64))
  68. - ] : (Path.t * type_expr * (O.t -> Outcometree.out_value)) list)
  69. + ( Pident(Ident.create "print_int"),
  70. + Simple (Predef.type_int,
  71. + (fun x -> Oval_int (O.obj x : int))) );
  72. + ( Pident(Ident.create "print_float"),
  73. + Simple (Predef.type_float,
  74. + (fun x -> Oval_float (O.obj x : float))) );
  75. + ( Pident(Ident.create "print_char"),
  76. + Simple (Predef.type_char,
  77. + (fun x -> Oval_char (O.obj x : char))) );
  78. + ( Pident(Ident.create "print_string"),
  79. + Simple (Predef.type_string,
  80. + (fun x -> Oval_string (O.obj x : string))) );
  81. + ( Pident(Ident.create "print_int32"),
  82. + Simple (Predef.type_int32,
  83. + (fun x -> Oval_int32 (O.obj x : int32))) );
  84. + ( Pident(Ident.create "print_nativeint"),
  85. + Simple (Predef.type_nativeint,
  86. + (fun x -> Oval_nativeint (O.obj x : nativeint))) );
  87. + ( Pident(Ident.create "print_int64"),
  88. + Simple (Predef.type_int64,
  89. + (fun x -> Oval_int64 (O.obj x : int64)) ))
  90. + ] : (Path.t * printer) list)
  91. +
  92. + let exn_printer ppf path =
  93. + fprintf ppf "<printer %a raised an exception>" Printtyp.path path
  94. +
  95. + let out_exn path =
  96. + Oval_printer (fun ppf -> exn_printer ppf path)
  97.  
  98. let install_printer path ty fn =
  99. let print_val ppf obj =
  100. - try fn ppf obj with
  101. - | exn ->
  102. - fprintf ppf "<printer %a raised an exception>" Printtyp.path path in
  103. + try fn ppf obj with exn -> exn_printer ppf path in
  104. let printer obj = Oval_printer (fun ppf -> print_val ppf obj) in
  105. - printers := (path, ty, printer) :: !printers
  106. + printers := (path, Simple (ty, printer)) :: !printers
  107. +
  108. + let install_generic_printer path ty_path fn =
  109. + printers := (path, Generic (ty_path, fn)) :: !printers
  110. +
  111. + let install_generic_printer' path ty_path fn =
  112. + let rec build gp depth =
  113. + match gp with
  114. + | Zero fn ->
  115. + let out_printer obj =
  116. + let printer ppf = try fn ppf obj with _ -> exn_printer ppf path in
  117. + Oval_printer printer in
  118. + Zero out_printer
  119. + | Succ fn ->
  120. + let print_val fn_arg =
  121. + let print_arg ppf o =
  122. + !Oprint.out_value ppf (fn_arg (depth+1) o) in
  123. + build (fn print_arg) depth in
  124. + Succ print_val in
  125. + printers := (path, Generic (ty_path, build fn)) :: !printers
  126.  
  127. let remove_printer path =
  128. let rec remove = function
  129. | [] -> raise Not_found
  130. - | (p, ty, fn as printer) :: rem ->
  131. + | ((p, _) as printer) :: rem ->
  132. if Path.same p path then rem else printer :: remove rem in
  133. printers := remove !printers
  134.  
  135. - let find_printer env ty =
  136. - let rec find = function
  137. - | [] -> raise Not_found
  138. - | (name, sch, printer) :: remainder ->
  139. - if Ctype.moregeneral env false sch ty
  140. - then printer
  141. - else find remainder
  142. - in find !printers
  143. -
  144. (* Print a constructor or label, giving it the same prefix as the type
  145. it comes from. Attempt to omit the prefix if the type comes from
  146. a module that has been opened. *)
  147. @@ -205,7 +245,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
  148. if !printer_steps < 0 || depth < 0 then Oval_ellipsis
  149. else begin
  150. try
  151. - find_printer env ty obj
  152. + find_printer depth env ty obj
  153. with Not_found ->
  154. match (Ctype.repr ty).desc with
  155. | Tvar _ | Tunivar _ ->
  156. @@ -416,6 +456,35 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
  157. | None ->
  158. Oval_stuff "<extension>"
  159.  
  160. + and find_printer depth env ty =
  161. + let rec find = function
  162. + | [] -> raise Not_found
  163. + | (name, Simple (sch, printer)) :: remainder ->
  164. + if Ctype.moregeneral env false sch ty
  165. + then printer
  166. + else find remainder
  167. + | (name, Generic (path, fn)) :: remainder ->
  168. + begin match (Ctype.expand_head env ty).desc with
  169. + | Tconstr (p, args, _) when Path.same p path ->
  170. + begin try apply_generic_printer path (fn depth) args
  171. + with _ -> (fun obj -> out_exn path) end
  172. + | _ -> find remainder end in
  173. + find !printers
  174. +
  175. + and apply_generic_printer path printer args =
  176. + match (printer, args) with
  177. + | (Zero fn, []) -> (fun (obj : O.t)-> try fn obj with _ -> out_exn path)
  178. + | (Succ fn, arg :: args) ->
  179. + let printer = fn (fun depth obj -> tree_of_val depth obj arg) in
  180. + apply_generic_printer path printer args
  181. + | _ ->
  182. + (fun obj ->
  183. + let printer ppf =
  184. + fprintf ppf "<internal error: incorrect arity for '%a'>"
  185. + Printtyp.path path in
  186. + Oval_printer printer)
  187. +
  188. +
  189. in nest tree_of_val max_depth obj ty
  190.  
  191. end
  192. diff --git a/toplevel/genprintval.mli b/toplevel/genprintval.mli
  193. index 3f7b85a..a1cd6b9 100644
  194. --- a/toplevel/genprintval.mli
  195. +++ b/toplevel/genprintval.mli
  196. @@ -33,11 +33,25 @@ module type EVALPATH =
  197. val same_value: valu -> valu -> bool
  198. end
  199.  
  200. +type ('a, 'b) gen_printer =
  201. + | Zero of 'b
  202. + | Succ of ('a -> ('a, 'b) gen_printer)
  203. +
  204. module type S =
  205. sig
  206. type t
  207. val install_printer :
  208. Path.t -> Types.type_expr -> (formatter -> t -> unit) -> unit
  209. + val install_generic_printer :
  210. + Path.t -> Path.t ->
  211. + (int -> (int -> t -> Outcometree.out_value,
  212. + t -> Outcometree.out_value) gen_printer) ->
  213. + unit
  214. + val install_generic_printer' :
  215. + Path.t -> Path.t ->
  216. + (formatter -> t -> unit,
  217. + formatter -> t -> unit) gen_printer ->
  218. + unit
  219. val remove_printer : Path.t -> unit
  220. val outval_of_untyped_exception : t -> Outcometree.out_value
  221. val outval_of_value :
  222. diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml
  223. index 2261dcc..0ee8799 100644
  224. --- a/toplevel/toploop.ml
  225. +++ b/toplevel/toploop.ml
  226. @@ -96,7 +96,13 @@ let outval_of_value env obj ty =
  227. let print_value env obj ppf ty =
  228. !print_out_value ppf (outval_of_value env obj ty)
  229.  
  230. +type ('a, 'b) gen_printer = ('a, 'b) Genprintval.gen_printer =
  231. + | Zero of 'b
  232. + | Succ of ('a -> ('a, 'b) gen_printer)
  233. +
  234. let install_printer = Printer.install_printer
  235. +let install_generic_printer = Printer.install_generic_printer
  236. +let install_generic_printer' = Printer.install_generic_printer'
  237. let remove_printer = Printer.remove_printer
  238.  
  239. (* Hooks for parsing functions *)
  240. diff --git a/toplevel/toploop.mli b/toplevel/toploop.mli
  241. index 5f0b86e..5ebfec3 100644
  242. --- a/toplevel/toploop.mli
  243. +++ b/toplevel/toploop.mli
  244. @@ -68,8 +68,19 @@ val eval_path: Env.t -> Path.t -> Obj.t
  245. val print_value: Env.t -> Obj.t -> formatter -> Types.type_expr -> unit
  246. val print_untyped_exception: formatter -> Obj.t -> unit
  247.  
  248. +type ('a, 'b) gen_printer =
  249. + | Zero of 'b
  250. + | Succ of ('a -> ('a, 'b) gen_printer)
  251. +
  252. val install_printer :
  253. Path.t -> Types.type_expr -> (formatter -> Obj.t -> unit) -> unit
  254. +val install_generic_printer :
  255. + Path.t -> Path.t ->
  256. + (int -> (int -> Obj.t -> Outcometree.out_value,
  257. + Obj.t -> Outcometree.out_value) gen_printer) -> unit
  258. +val install_generic_printer' :
  259. + Path.t -> Path.t -> (formatter -> Obj.t -> unit,
  260. + formatter -> Obj.t -> unit) gen_printer -> unit
  261. val remove_printer : Path.t -> unit
  262.  
  263. val max_printer_depth: int ref
  264. --
  265. 2.0.0
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!