A lightweight reactive document library.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 

391 lines
13 KiB

  1. (**************************************************************************)
  2. (* *)
  3. (* Nottui_pretty, pretty-printer for Nottui *)
  4. (* Frédéric Bour, Tarides *)
  5. (* Copyright 2020 Tarides. All rights reserved. *)
  6. (* *)
  7. (* Based on PPrint *)
  8. (* François Pottier, Inria Paris *)
  9. (* Nicolas Pouillard *)
  10. (* *)
  11. (* Copyright 2007-2019 Inria. All rights reserved. This file is *)
  12. (* distributed under the terms of the GNU Library General Public *)
  13. (* License, with an exception, as described in the file LICENSE. *)
  14. (**************************************************************************)
  15. (* -------------------------------------------------------------------------- *)
  16. (* A type of integers with infinity. *)
  17. type requirement =
  18. int (* with infinity *)
  19. (* Infinity is encoded as [max_int]. *)
  20. let infinity : requirement =
  21. max_int
  22. (* Addition of integers with infinity. *)
  23. let (++) (x : requirement) (y : requirement) : requirement =
  24. if x = infinity || y = infinity
  25. then infinity
  26. else x + y
  27. (* --------------------------------------------------------------------------
  28. UI cache
  29. --------------------------------------------------------------------------
  30. It serves two purposes: representing intermediate UI and caching it.
  31. The cache part is used to speed-up re-computation. It stores the conditions
  32. under which the cached result is the "prettiest" solution.
  33. A flat layout cannot change, so there is no extra condition.
  34. Optimality of non-flat layout is determined by two intervals:
  35. - `min_rem..max_rem`, the remaining space on the current line
  36. - `min_wid..max_wid`, the width of new lines (e.g. maximum width - indent)
  37. The intermediate UI part is necessary because pretty-printing produces two
  38. type of shapes, line and span, while [Nottui.ui] can only represent lines.
  39. Conceptually [Nottui.ui] represents a box, with a width and a height.
  40. However in the middle of pretty-printing, we can get in situations where a
  41. few lines have already been typeset and we stop in the middle of a new line.
  42. In full generality, span represents UI that look like that:
  43. ... [ prefix ]
  44. [ 0 or more ]
  45. [ body lines ]
  46. [ suffix ] ...
  47. Prefix is the first line of the intermediate UI, to which we might prepend
  48. something.
  49. Body is the lines that are fully typeset and won't change. It can be empty.
  50. Suffix is the last line of the intermediate UI, to which we might append
  51. something.
  52. FUTURE WORK: since flat layout never changes, it might be worth caching
  53. separately flat and non-flat results. Flat cache would actually be a lazy
  54. computation.
  55. *)
  56. (* We use a few OCaml tricks to implement caching without introducing too
  57. much indirections.
  58. These optimisations are worthy because of the live/interactive nature of
  59. Nottui_pretty (documents are long-lived). This is not the case for PPrint.
  60. *)
  61. type ui = Nottui.ui
  62. (* Category of intermediate nodes *)
  63. type flat
  64. type nonflat
  65. type uncached
  66. type 'a ui_cache =
  67. | (* A placeholder for a cache that is empty *)
  68. Uncached : uncached ui_cache
  69. | (* A single line that is flat *)
  70. Flat_line : ui -> flat ui_cache
  71. | (* Flat_span is a bit strange...
  72. It can only occur when someone put a `Hardline` in a flat document.
  73. They lied: the document should have been flat, but it is not.
  74. Nevertheless, I chose to accept this case. *)
  75. Flat_span : { prefix: ui; body: ui; suffix: ui } -> flat ui_cache
  76. | (* A line in a non-flat context *)
  77. Nonflat_line : { min_rem: int; max_rem: int; ui: ui; } -> nonflat ui_cache
  78. | (* A span in a non-flat context *)
  79. Nonflat_span : {
  80. min_rem: int; max_rem: int; prefix: ui;
  81. min_wid: int; max_wid: int; body: ui; suffix: ui;
  82. } -> nonflat ui_cache
  83. (* The type of an actual cache slot (stored in document nodes).
  84. It hides the category of the node. *)
  85. type ui_cache_slot = Cache : 'a ui_cache -> ui_cache_slot [@@ocaml.unboxed]
  86. (* -------------------------------------------------------------------------- *)
  87. (* The type of documents. *)
  88. type t =
  89. | Blank of int
  90. | Ui of Nottui.ui
  91. | If_flat of { then_: t; else_: t }
  92. | Hardline
  93. | Cat of { req: requirement; lhs: t; rhs: t; mutable cache : ui_cache_slot }
  94. | Nest of { req: requirement; indent: int; doc: t }
  95. | Group of { req: requirement; doc: t; mutable cache : ui_cache_slot }
  96. (* Only [Cat] and [Group] nodes are cached.
  97. This is because [Cat] is the only place where two sub-documents are
  98. connected. Cache miss here can change the asymptotic complexity of the
  99. computation.
  100. [Group] nodes are the only one where decisions are made (flat or non-flat).
  101. Other nodes, are either leaves ([Blank], [Ui], [Hardline]) or
  102. should normally only have a fixed nesting ([Nest (Nest (Nest ...))] cannot
  103. happen). I suspect that caching is not beneficial, if detrimental, to these
  104. cases.
  105. *)
  106. (* -------------------------------------------------------------------------- *)
  107. (* Retrieving or computing the space requirement of a document. *)
  108. let rec requirement = function
  109. | Blank len -> len
  110. | Ui ui -> Nottui.Ui.layout_width ui
  111. | If_flat t -> requirement t.then_
  112. | Hardline -> infinity
  113. | Cat {req; _} | Nest {req; _} | Group {req; _} -> req
  114. (* -------------------------------------------------------------------------- *)
  115. (* Document constructors. *)
  116. let empty = Blank 0
  117. let ui ui = Ui ui
  118. let hardline = Hardline
  119. let blank = function
  120. | 0 -> Blank 0
  121. | 1 -> Blank 1
  122. | n -> Blank n
  123. let if_flat (If_flat {then_; _} | then_) else_ =
  124. If_flat { then_; else_ }
  125. let internal_break i =
  126. if_flat (blank i) hardline
  127. let break =
  128. let break0 = internal_break 0 in
  129. let break1 = internal_break 1 in
  130. function
  131. | 0 -> break0
  132. | 1 -> break1
  133. | i -> internal_break i
  134. let (^^) x y =
  135. match x, y with
  136. | (Blank 0, t) | (t, Blank 0) -> t
  137. | Blank i, Blank j -> Blank (i + j)
  138. | lhs, rhs ->
  139. Cat {req = requirement lhs ++ requirement rhs; lhs; rhs;
  140. cache = Cache Uncached}
  141. let nest indent doc =
  142. assert (indent >= 0);
  143. match doc with
  144. | Nest t -> Nest {req = t.req; indent = indent + t.indent; doc = t.doc}
  145. | doc -> Nest {req = requirement doc; indent; doc}
  146. let group = function
  147. | Group _ as doc -> doc
  148. | doc ->
  149. let req = requirement doc in
  150. if req = infinity then doc else Group {req; doc; cache = Cache Uncached}
  151. (* -------------------------------------------------------------------------- *)
  152. open Nottui
  153. (* Some intermediate UI *)
  154. let blank_ui =
  155. let space = Ui.space 1 0 in
  156. function
  157. | 0 -> Ui.empty
  158. | 1 -> space
  159. | n -> Ui.space n 0
  160. let flat_hardline =
  161. Flat_span { prefix = Ui.empty; body = Ui.empty; suffix = Ui.empty; }
  162. let mk_body body1 suffix prefix body2 =
  163. Ui.join_y body1 (Ui.join_y (Ui.join_x suffix prefix) body2)
  164. let mk_pad indent body suffix =
  165. let pad = Ui.space indent 0 in
  166. (Ui.join_x pad body, Ui.join_x pad suffix)
  167. (* Flat renderer *)
  168. let flat_cache (Cache slot) = match slot with
  169. | Flat_line _ as ui -> Some ui
  170. | Flat_span _ as ui -> Some ui
  171. | _ -> None
  172. let rec pretty_flat = function
  173. | Ui ui -> Flat_line ui
  174. | Blank n -> Flat_line (blank_ui n)
  175. | Hardline -> flat_hardline
  176. | If_flat t -> pretty_flat t.then_
  177. | Cat t ->
  178. begin match flat_cache t.cache with
  179. | Some ui -> ui
  180. | None ->
  181. let result =
  182. let lhs = pretty_flat t.lhs and rhs = pretty_flat t.rhs in
  183. match lhs, rhs with
  184. | Flat_line l, Flat_line r ->
  185. Flat_line (Ui.join_x l r)
  186. | Flat_line l, Flat_span r ->
  187. Flat_span {r with prefix = Ui.join_x l r.prefix}
  188. | Flat_span l, Flat_line r ->
  189. Flat_span {l with suffix = Ui.join_x l.suffix r}
  190. | Flat_span l, Flat_span r ->
  191. Flat_span {prefix = l.prefix;
  192. body = mk_body l.body l.suffix r.prefix r.body;
  193. suffix = r.suffix}
  194. in
  195. t.cache <- Cache result;
  196. result
  197. end
  198. | Nest t ->
  199. begin match pretty_flat t.doc with
  200. | Flat_line _ as ui -> ui
  201. | Flat_span s ->
  202. let body, suffix = mk_pad t.indent s.body s.suffix in
  203. Flat_span {s with body; suffix}
  204. end
  205. | Group t ->
  206. begin match flat_cache t.cache with
  207. | Some ui -> ui
  208. | None ->
  209. let result = pretty_flat t.doc in
  210. t.cache <- Cache result;
  211. result
  212. end
  213. (* Nonflat renderer.
  214. Steps:
  215. - check cache validity
  216. - compute normal, non-interactive pretty-printing
  217. - cache result and determine validity conditions
  218. The three steps could be implemented separately, but doing so would
  219. introduce redundant checks or indirections.
  220. For performance reasons and to reduce memory pressure, I preferred
  221. this ugly 100-lines long implementation.
  222. *)
  223. let maxi i j : int = if i < j then j else i
  224. let mini i j : int = if i < j then i else j
  225. let (+++) i j = let result = i + j in if result < 0 then max_int else result
  226. let nonflat_line ui =
  227. Nonflat_line {min_rem = min_int; max_rem = max_int; ui}
  228. let nonflat_cache (Cache slot) rem wid = match slot with
  229. | Nonflat_line t' as t when t'.min_rem <= rem && rem < t'.max_rem -> Some t
  230. | Nonflat_span t' as t
  231. when t'.min_rem <= rem && rem < t'.max_rem &&
  232. t'.min_wid <= wid && wid < t'.max_wid -> Some t
  233. | _ -> None
  234. let span_hardline = Nonflat_span {
  235. min_rem = min_int; max_rem = max_int;
  236. min_wid = min_int; max_wid = max_int;
  237. prefix = Ui.empty; body = Ui.empty; suffix = Ui.empty;
  238. }
  239. let rec pretty (rem: int) (wid : int) = function
  240. | Ui ui -> nonflat_line ui
  241. | Blank n -> nonflat_line (blank_ui n)
  242. | Hardline -> span_hardline
  243. | If_flat t -> pretty rem wid t.else_
  244. | Cat t ->
  245. begin match nonflat_cache t.cache rem wid with
  246. | Some ui -> ui
  247. | None ->
  248. let lhs = pretty rem wid t.lhs in
  249. let result = match lhs with
  250. | Nonflat_line l ->
  251. let lw = Ui.layout_width l.ui in
  252. begin match pretty (rem - lw) wid t.rhs with
  253. | Nonflat_line r ->
  254. Nonflat_line {
  255. min_rem = maxi l.min_rem (r.min_rem + lw);
  256. max_rem = mini l.max_rem (r.max_rem +++ lw);
  257. ui = Ui.join_x l.ui r.ui;
  258. }
  259. | Nonflat_span r ->
  260. Nonflat_span {
  261. r with
  262. min_rem = maxi l.min_rem (r.min_rem + lw);
  263. max_rem = mini l.max_rem (r.max_rem +++ lw);
  264. prefix = Ui.join_x l.ui r.prefix;
  265. }
  266. end
  267. | Nonflat_span l ->
  268. let lw = Ui.layout_width l.suffix in
  269. begin match pretty (wid - lw) wid t.rhs with
  270. | Nonflat_line r ->
  271. Nonflat_span {
  272. l with
  273. min_wid = maxi l.min_wid (r.min_rem + lw);
  274. max_wid = mini l.max_wid (r.max_rem +++ lw);
  275. suffix = Ui.join_x l.suffix r.ui;
  276. }
  277. | Nonflat_span r ->
  278. Nonflat_span {
  279. prefix = l.prefix; min_rem = l.min_rem; max_rem = l.max_rem;
  280. min_wid = maxi (maxi l.min_wid (r.min_rem + lw)) r.min_wid;
  281. max_wid = mini (mini l.max_wid (r.max_rem +++ lw)) r.max_wid;
  282. body = mk_body l.body l.suffix r.prefix r.body;
  283. suffix = r.suffix;
  284. }
  285. end
  286. in
  287. t.cache <- Cache result;
  288. result
  289. end
  290. | Nest t ->
  291. begin match pretty rem (wid - t.indent) t.doc with
  292. | Nonflat_line _ as ui -> ui
  293. | Nonflat_span s ->
  294. let body, suffix = mk_pad t.indent s.body s.suffix in
  295. Nonflat_span {
  296. min_rem = s.min_rem; max_rem = s.max_rem;
  297. min_wid = s.min_wid + t.indent;
  298. max_wid = s.max_wid +++ t.indent;
  299. prefix = s.prefix; body; suffix;
  300. }
  301. end
  302. | Group t as self ->
  303. begin if t.req <= rem then
  304. match pretty_flat self with
  305. | Flat_line ui ->
  306. Nonflat_line { min_rem = t.req; max_rem = max_int; ui }
  307. | Flat_span ui ->
  308. Nonflat_span {
  309. min_rem = t.req; max_rem = max_int;
  310. min_wid = min_int; max_wid = max_int;
  311. prefix = ui.prefix;
  312. body = ui.body;
  313. suffix = ui.suffix;
  314. }
  315. else match nonflat_cache t.cache rem wid with
  316. | Some ui -> ui
  317. | None ->
  318. let result = match pretty rem wid t.doc with
  319. | Nonflat_line ui -> Nonflat_line {ui with max_rem = t.req}
  320. | Nonflat_span ui ->
  321. Nonflat_span {ui with max_rem = mini t.req ui.max_rem}
  322. in
  323. t.cache <- Cache result;
  324. result
  325. end
  326. (* -------------------------------------------------------------------------- *)
  327. (* The engine's entry point. *)
  328. let pretty width doc =
  329. match pretty width width doc with
  330. | Nonflat_line t -> t.ui
  331. | Nonflat_span t -> Ui.join_y t.prefix (Ui.join_y t.body t.suffix)