read-print.scm 29 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821
  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2021-2023 Ludovic Courtès <ludo@gnu.org>
  3. ;;;
  4. ;;; This file is part of GNU Guix.
  5. ;;;
  6. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 3 of the License, or (at
  9. ;;; your option) any later version.
  10. ;;;
  11. ;;; GNU Guix is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  14. ;;; GNU General Public License for more details.
  15. ;;;
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  18. (define-module (guix read-print)
  19. #:use-module (ice-9 control)
  20. #:use-module (ice-9 match)
  21. #:use-module (ice-9 rdelim)
  22. #:use-module (ice-9 vlist)
  23. #:use-module (srfi srfi-1)
  24. #:use-module (srfi srfi-26)
  25. #:use-module (srfi srfi-34)
  26. #:use-module (srfi srfi-35)
  27. #:use-module (guix i18n)
  28. #:use-module ((guix diagnostics)
  29. #:select (formatted-message
  30. &fix-hint &error-location
  31. location))
  32. #:export (pretty-print-with-comments
  33. pretty-print-with-comments/splice
  34. read-with-comments
  35. read-with-comments/sequence
  36. object->string*
  37. blank?
  38. vertical-space
  39. vertical-space?
  40. vertical-space-height
  41. canonicalize-vertical-space
  42. page-break
  43. page-break?
  44. comment
  45. comment?
  46. comment->string
  47. comment-margin?
  48. canonicalize-comment))
  49. ;;; Commentary:
  50. ;;;
  51. ;;; This module provides a comment-preserving reader and a comment-preserving
  52. ;;; pretty-printer smarter than (ice-9 pretty-print).
  53. ;;;
  54. ;;; Code:
  55. ;;;
  56. ;;; Comment-preserving reader.
  57. ;;;
  58. (define <blank>
  59. ;; The parent class for "blanks".
  60. (make-record-type '<blank> '()
  61. (lambda (obj port)
  62. (format port "#<blank ~a>"
  63. (number->string (object-address obj) 16)))
  64. #:extensible? #t))
  65. (define blank? (record-predicate <blank>))
  66. (define <vertical-space>
  67. (make-record-type '<vertical-space> '(height)
  68. #:parent <blank>
  69. #:extensible? #f))
  70. (define vertical-space? (record-predicate <vertical-space>))
  71. (define vertical-space (record-type-constructor <vertical-space>))
  72. (define vertical-space-height (record-accessor <vertical-space> 'height))
  73. (define canonicalize-vertical-space
  74. (let ((unit (vertical-space 1)))
  75. (lambda (space)
  76. "Return a vertical space corresponding to a single blank line."
  77. unit)))
  78. (define <page-break>
  79. (make-record-type '<page-break> '()
  80. #:parent <blank>
  81. #:extensible? #f))
  82. (define page-break? (record-predicate <page-break>))
  83. (define page-break
  84. (let ((break ((record-type-constructor <page-break>))))
  85. (lambda ()
  86. break)))
  87. (define <comment>
  88. ;; Comments.
  89. (make-record-type '<comment> '(str margin?)
  90. #:parent <blank>
  91. #:extensible? #f))
  92. (define comment? (record-predicate <comment>))
  93. (define string->comment (record-type-constructor <comment>))
  94. (define comment->string (record-accessor <comment> 'str))
  95. (define comment-margin? (record-accessor <comment> 'margin?))
  96. (define* (comment str #:optional margin?)
  97. "Return a new comment made from STR. When MARGIN? is true, return a margin
  98. comment; otherwise return a line comment. STR must start with a semicolon and
  99. end with newline, otherwise an error is raised."
  100. (when (or (string-null? str)
  101. (not (eqv? #\; (string-ref str 0)))
  102. (not (string-suffix? "\n" str)))
  103. (raise (condition
  104. (&message (message "invalid comment string")))))
  105. (string->comment str margin?))
  106. (define char-set:whitespace-sans-page-break
  107. ;; White space, excluding #\page.
  108. (char-set-difference char-set:whitespace (char-set #\page)))
  109. (define (space? chr)
  110. "Return true if CHR is white space, except for page breaks."
  111. (char-set-contains? char-set:whitespace-sans-page-break chr))
  112. (define (read-vertical-space port)
  113. "Read from PORT until a non-vertical-space character is met, and return a
  114. single <vertical-space> record."
  115. (let loop ((height 1))
  116. (match (read-char port)
  117. (#\newline (loop (+ 1 height)))
  118. ((? eof-object?) (vertical-space height))
  119. ((? space?) (loop height))
  120. (chr (unread-char chr port) (vertical-space height)))))
  121. (define (read-until-end-of-line port)
  122. "Read white space from PORT until the end of line, included."
  123. (let loop ()
  124. (match (read-char port)
  125. (#\newline #t)
  126. ((? eof-object?) #t)
  127. ((? space?) (loop))
  128. (chr (unread-char chr port)))))
  129. (define* (read-with-comments port #:key (blank-line? #t))
  130. "Like 'read', but include <blank> objects when they're encountered. When
  131. BLANK-LINE? is true, assume PORT is at the beginning of a new line."
  132. ;; Note: Instead of implementing this functionality in 'read' proper, which
  133. ;; is the best approach long-term, this code is a layer on top of 'read',
  134. ;; such that we don't have to rely on a specific Guile version.
  135. (define dot (list 'dot))
  136. (define (dot? x) (eq? x dot))
  137. (define (missing-closing-paren-error)
  138. (raise (make-compound-condition
  139. (formatted-message (G_ "unexpected end of file"))
  140. (condition
  141. (&error-location
  142. (location (match (port-filename port)
  143. (#f #f)
  144. (file (location file
  145. (port-line port)
  146. (port-column port))))))
  147. (&fix-hint
  148. (hint (G_ "Did you forget a closing parenthesis?")))))))
  149. (define (reverse/dot lst)
  150. ;; Reverse LST and make it an improper list if it contains DOT.
  151. (let loop ((result '())
  152. (lst lst))
  153. (match lst
  154. (() result)
  155. (((? dot?) . rest)
  156. (if (pair? rest)
  157. (let ((dotted (reverse rest)))
  158. (set-cdr! (last-pair dotted) (car result))
  159. dotted)
  160. (car result)))
  161. ((x . rest) (loop (cons x result) rest)))))
  162. (let loop ((blank-line? blank-line?)
  163. (return (const 'unbalanced)))
  164. (match (read-char port)
  165. ((? eof-object? eof)
  166. eof) ;oops!
  167. (chr
  168. (cond ((eqv? chr #\newline)
  169. (if blank-line?
  170. (read-vertical-space port)
  171. (loop #t return)))
  172. ((eqv? chr #\page)
  173. ;; Assume that a page break is on a line of its own and read
  174. ;; subsequent white space and newline.
  175. (read-until-end-of-line port)
  176. (page-break))
  177. ((char-set-contains? char-set:whitespace chr)
  178. (loop blank-line? return))
  179. ((memv chr '(#\( #\[))
  180. (let/ec return
  181. (let liip ((lst '()))
  182. (define item
  183. (loop (match lst
  184. (((? blank?) . _) #t)
  185. (_ #f))
  186. (lambda ()
  187. (return (reverse/dot lst)))))
  188. (if (eof-object? item)
  189. (missing-closing-paren-error)
  190. (liip (cons item lst))))))
  191. ((memv chr '(#\) #\]))
  192. (return))
  193. ((eq? chr #\')
  194. (list 'quote (loop #f return)))
  195. ((eq? chr #\`)
  196. (list 'quasiquote (loop #f return)))
  197. ((eq? chr #\#)
  198. (match (read-char port)
  199. (#\~ (list 'gexp (loop #f return)))
  200. (#\$ (list (match (peek-char port)
  201. (#\@
  202. (read-char port) ;consume
  203. 'ungexp-splicing)
  204. (_
  205. 'ungexp))
  206. (loop #f return)))
  207. (#\+ (list (match (peek-char port)
  208. (#\@
  209. (read-char port) ;consume
  210. 'ungexp-native-splicing)
  211. (_
  212. 'ungexp-native))
  213. (loop #f return)))
  214. (chr
  215. (unread-char chr port)
  216. (unread-char #\# port)
  217. (read port))))
  218. ((eq? chr #\,)
  219. (list (match (peek-char port)
  220. (#\@
  221. (read-char port)
  222. 'unquote-splicing)
  223. (_
  224. 'unquote))
  225. (loop #f return)))
  226. ((eqv? chr #\;)
  227. (unread-char chr port)
  228. (string->comment (read-line port 'concat)
  229. (not blank-line?)))
  230. (else
  231. (unread-char chr port)
  232. (match (read port)
  233. ((and token '#{.}#)
  234. (if (eq? chr #\.) dot token))
  235. (token token))))))))
  236. (define (read-with-comments/sequence port)
  237. "Read from PORT until the end-of-file is reached and return the list of
  238. expressions and blanks that were read."
  239. (let loop ((lst '())
  240. (blank-line? #t))
  241. (match (read-with-comments port #:blank-line? blank-line?)
  242. ((? eof-object?)
  243. (reverse! lst))
  244. ((? blank? blank)
  245. (loop (cons blank lst) #t))
  246. (exp
  247. (loop (cons exp lst) #f)))))
  248. ;;;
  249. ;;; Comment-preserving pretty-printer.
  250. ;;;
  251. (define-syntax vhashq
  252. (syntax-rules (quote)
  253. ((_) vlist-null)
  254. ((_ (key (quote (lst ...))) rest ...)
  255. (vhash-consq key '(lst ...) (vhashq rest ...)))
  256. ((_ (key value) rest ...)
  257. (vhash-consq key '((() . value)) (vhashq rest ...)))))
  258. (define %special-forms
  259. ;; Forms that are indented specially. The number is meant to be understood
  260. ;; like Emacs' 'scheme-indent-function' symbol property. When given an
  261. ;; alist instead of a number, the alist gives "context" in which the symbol
  262. ;; is a special form; for instance, context (modify-phases) means that the
  263. ;; symbol must appear within a (modify-phases ...) expression.
  264. (vhashq
  265. ('begin 1)
  266. ('case 2)
  267. ('cond 1)
  268. ('lambda 2)
  269. ('lambda* 2)
  270. ('match-lambda 1)
  271. ('match-lambda* 1)
  272. ('define 2)
  273. ('define* 2)
  274. ('define-public 2)
  275. ('define*-public 2)
  276. ('define-syntax 2)
  277. ('define-syntax-rule 2)
  278. ('define-module 2)
  279. ('define-gexp-compiler 2)
  280. ('define-record-type 2)
  281. ('define-record-type* 4)
  282. ('define-configuration 2)
  283. ('package/inherit 2)
  284. ('let 2)
  285. ('let* 2)
  286. ('letrec 2)
  287. ('letrec* 2)
  288. ('match 2)
  289. ('match-record 3)
  290. ('match-record-lambda 2)
  291. ('when 2)
  292. ('unless 2)
  293. ('package 1)
  294. ('origin 1)
  295. ('channel 1)
  296. ('modify-inputs 2)
  297. ('modify-phases 2)
  298. ('add-after '(((modify-phases) . 3)))
  299. ('add-before '(((modify-phases) . 3)))
  300. ('replace '(((modify-phases) . 2))) ;different from 'modify-inputs'
  301. ('substitute* 2)
  302. ('substitute-keyword-arguments 2)
  303. ('call-with-input-file 2)
  304. ('call-with-output-file 2)
  305. ('with-output-to-file 2)
  306. ('with-input-from-file 2)
  307. ('with-directory-excursion 2)
  308. ('wrap-program 2)
  309. ('wrap-script 2)
  310. ;; (gnu system) and (gnu services).
  311. ('operating-system 1)
  312. ('bootloader-configuration 1)
  313. ('mapped-device 1)
  314. ('file-system 1)
  315. ('swap-space 1)
  316. ('user-account 1)
  317. ('user-group 1)
  318. ('setuid-program 1)
  319. ('modify-services 2)
  320. ;; (gnu home).
  321. ('home-environment 1)))
  322. (define %newline-forms
  323. ;; List heads that must be followed by a newline. The second argument is
  324. ;; the context in which they must appear. This is similar to a special form
  325. ;; of 1, except that indent is 1 instead of 2 columns.
  326. (vhashq
  327. ('arguments '(package))
  328. ('sha256 '(origin source package))
  329. ('base32 '(sha256 origin))
  330. ('git-reference '(uri origin source))
  331. ('search-paths '(package))
  332. ('native-search-paths '(package))
  333. ('search-path-specification '())
  334. ('services '(operating-system))
  335. ('set-xorg-configuration '())
  336. ('services '(home-environment))
  337. ('home-bash-configuration '(service))
  338. ('introduction '(channel))))
  339. (define (prefix? candidate lst)
  340. "Return true if CANDIDATE is a prefix of LST."
  341. (let loop ((candidate candidate)
  342. (lst lst))
  343. (match candidate
  344. (() #t)
  345. ((head1 . rest1)
  346. (match lst
  347. (() #f)
  348. ((head2 . rest2)
  349. (and (equal? head1 head2)
  350. (loop rest1 rest2))))))))
  351. (define (special-form-lead symbol context)
  352. "If SYMBOL is a special form in the given CONTEXT, return its number of
  353. arguments; otherwise return #f. CONTEXT is a stack of symbols lexically
  354. surrounding SYMBOL."
  355. (match (vhash-assq symbol %special-forms)
  356. (#f #f)
  357. ((_ . alist)
  358. (any (match-lambda
  359. ((prefix . level)
  360. (and (prefix? prefix context) (- level 1))))
  361. alist))))
  362. (define (newline-form? symbol context)
  363. "Return true if parenthesized expressions starting with SYMBOL must be
  364. followed by a newline."
  365. (let ((matches (vhash-foldq* cons '() symbol %newline-forms)))
  366. (find (cut prefix? <> context)
  367. matches)))
  368. (define (escaped-string str)
  369. "Return STR with backslashes and double quotes escaped. Everything else, in
  370. particular newlines, is left as is."
  371. (list->string
  372. `(#\"
  373. ,@(string-fold-right (lambda (chr lst)
  374. (match chr
  375. (#\" (cons* #\\ #\" lst))
  376. (#\\ (cons* #\\ #\\ lst))
  377. (_ (cons chr lst))))
  378. '()
  379. str)
  380. #\")))
  381. (define %natural-whitespace-string-forms
  382. ;; When a string has one of these forms as its parent, only double quotes
  383. ;; and backslashes are escaped; newlines, tabs, etc. are left as-is.
  384. '(synopsis description G_ N_))
  385. (define (printed-string str context)
  386. "Return the read syntax for STR depending on CONTEXT."
  387. (define (preserve-newlines? str)
  388. (and (> (string-length str) 40)
  389. (string-index str #\newline)))
  390. (match context
  391. (()
  392. (if (preserve-newlines? str)
  393. (escaped-string str)
  394. (object->string str)))
  395. ((head . _)
  396. (if (or (memq head %natural-whitespace-string-forms)
  397. (preserve-newlines? str))
  398. (escaped-string str)
  399. (object->string str)))))
  400. (define (string-width str)
  401. "Return the \"width\" of STR--i.e., the width of the longest line of STR."
  402. (apply max (map string-length (string-split str #\newline))))
  403. (define (canonicalize-comment comment indent)
  404. "Canonicalize COMMENT, which is to be printed at INDENT, ensuring it has the
  405. \"right\" number of leading semicolons."
  406. (if (zero? indent)
  407. comment ;leave top-level comments unchanged
  408. (let ((line (string-trim-both
  409. (string-trim (comment->string comment) (char-set #\;)))))
  410. (string->comment (string-append
  411. (if (comment-margin? comment)
  412. ";"
  413. (if (string-null? line)
  414. ";;" ;no trailing space
  415. ";; "))
  416. line "\n")
  417. (comment-margin? comment)))))
  418. (define %not-newline
  419. (char-set-complement (char-set #\newline)))
  420. (define (print-multi-line-comment str indent port)
  421. "Print to PORT STR as a multi-line comment, with INDENT spaces preceding
  422. each line except the first one (they're assumed to be already there)."
  423. ;; While 'read-with-comments' only returns one-line comments, user-provided
  424. ;; comments might span multiple lines, which is why this is necessary.
  425. (let loop ((lst (string-tokenize str %not-newline)))
  426. (match lst
  427. (() #t)
  428. ((last)
  429. (display last port)
  430. (newline port))
  431. ((head tail ...)
  432. (display head port)
  433. (newline port)
  434. (display (make-string indent #\space) port)
  435. (loop tail)))))
  436. (define %integer-forms
  437. ;; Forms that take an integer as their argument, where said integer should
  438. ;; be printed in base other than decimal base.
  439. (letrec-syntax ((vhashq (syntax-rules ()
  440. ((_) vlist-null)
  441. ((_ (key value) rest ...)
  442. (vhash-consq key value (vhashq rest ...))))))
  443. (vhashq
  444. ('chmod 8)
  445. ('umask 8)
  446. ('mkdir 8)
  447. ('mkstemp 8)
  448. ('logand 16)
  449. ('logior 16)
  450. ('logxor 16)
  451. ('lognot 16))))
  452. (define (integer->string integer context)
  453. "Render INTEGER as a string using a base suitable based on CONTEXT."
  454. (define (form-base form)
  455. (match (vhash-assq form %integer-forms)
  456. (#f 10)
  457. ((_ . base) base)))
  458. (define (octal? form)
  459. (= 8 (form-base form)))
  460. (define base
  461. (match context
  462. ((head . tail)
  463. (match (form-base head)
  464. (8 8)
  465. (16 (if (any octal? tail) 8 16))
  466. (10 10)))
  467. (_ 10)))
  468. (string-append (match base
  469. (10 "")
  470. (16 "#x")
  471. (8 "#o"))
  472. (number->string integer base)))
  473. (define %special-non-extended-symbols
  474. ;; Special symbols that can be written without the #{...}# notation for
  475. ;; extended symbols: 1+, 1-, 123/, etc.
  476. (make-regexp "^[0-9]+[[:graph:]]+$" regexp/icase))
  477. (define (symbol->display-string symbol context)
  478. "Return the most appropriate representation of SYMBOL, resorting to extended
  479. symbol notation only when strictly necessary."
  480. (let ((str (symbol->string symbol)))
  481. (if (regexp-exec %special-non-extended-symbols str)
  482. str ;no need for the #{...}# notation
  483. (object->string symbol))))
  484. (define* (pretty-print-with-comments port obj
  485. #:key
  486. (format-comment
  487. (lambda (comment indent) comment))
  488. (format-vertical-space identity)
  489. (indent 0)
  490. (max-width 78)
  491. (long-list 5))
  492. "Pretty-print OBJ to PORT, attempting to at most MAX-WIDTH character columns
  493. and assuming the current column is INDENT. Comments present in OBJ are
  494. included in the output.
  495. Lists longer than LONG-LIST are written as one element per line. Comments are
  496. passed through FORMAT-COMMENT before being emitted; a useful value for
  497. FORMAT-COMMENT is 'canonicalize-comment'. Vertical space is passed through
  498. FORMAT-VERTICAL-SPACE; a useful value of 'canonicalize-vertical-space'."
  499. (define (list-of-lists? head tail)
  500. ;; Return true if HEAD and TAIL denote a list of lists--e.g., a list of
  501. ;; 'let' bindings.
  502. (match head
  503. ((thing _ ...) ;proper list
  504. (and (not (memq thing
  505. '(quote quasiquote unquote unquote-splicing)))
  506. (pair? tail)))
  507. (_ #f)))
  508. (define (starts-with-line-comment? lst)
  509. ;; Return true if LST starts with a line comment.
  510. (match lst
  511. ((x . _) (and (comment? x) (not (comment-margin? x))))
  512. (_ #f)))
  513. (let loop ((indent indent)
  514. (column indent)
  515. (delimited? #t) ;true if comes after a delimiter
  516. (context '()) ;list of "parent" symbols
  517. (obj obj))
  518. (define (print-sequence context indent column lst delimited?)
  519. (define long?
  520. (> (length lst) long-list))
  521. (let print ((lst lst)
  522. (first? #t)
  523. (delimited? delimited?)
  524. (column column))
  525. (match lst
  526. (()
  527. column)
  528. ((item . tail)
  529. (define newline?
  530. ;; Insert a newline if ITEM is itself a list, or if TAIL is long,
  531. ;; but only if ITEM is not the first item. Also insert a newline
  532. ;; before a keyword.
  533. (and (or (pair? item) long?
  534. (and (keyword? item)
  535. (not (eq? item #:allow-other-keys))))
  536. (not first?) (not delimited?)
  537. (not (blank? item))))
  538. (when newline?
  539. (newline port)
  540. (display (make-string indent #\space) port))
  541. (let ((column (if newline? indent column)))
  542. (print tail
  543. (keyword? item) ;keep #:key value next to one another
  544. (blank? item)
  545. (loop indent column
  546. (or newline? delimited?)
  547. context
  548. item)))))))
  549. (define (sequence-would-protrude? indent lst)
  550. ;; Return true if elements of LST written at INDENT would protrude
  551. ;; beyond MAX-WIDTH. This is implemented as a cheap test with false
  552. ;; negatives to avoid actually rendering all of LST.
  553. (find (match-lambda
  554. ((? string? str)
  555. (>= (+ (string-width str) 2 indent) max-width))
  556. ((? symbol? symbol)
  557. (>= (+ (string-width (symbol->display-string symbol context))
  558. indent)
  559. max-width))
  560. ((? boolean?)
  561. (>= (+ 2 indent) max-width))
  562. (()
  563. (>= (+ 2 indent) max-width))
  564. (_ ;don't know
  565. #f))
  566. lst))
  567. (define (special-form? head)
  568. (special-form-lead head context))
  569. (match obj
  570. ((? comment? comment)
  571. (if (comment-margin? comment)
  572. (begin
  573. (display " " port)
  574. (display (comment->string (format-comment comment indent))
  575. port))
  576. (begin
  577. ;; When already at the beginning of a line, for example because
  578. ;; COMMENT follows a margin comment, no need to emit a newline.
  579. (unless (= column indent)
  580. (newline port)
  581. (display (make-string indent #\space) port))
  582. (print-multi-line-comment (comment->string
  583. (format-comment comment indent))
  584. indent port)))
  585. (display (make-string indent #\space) port)
  586. indent)
  587. ((? vertical-space? space)
  588. (unless delimited? (newline port))
  589. (let loop ((i (vertical-space-height (format-vertical-space space))))
  590. (unless (zero? i)
  591. (newline port)
  592. (loop (- i 1))))
  593. (display (make-string indent #\space) port)
  594. indent)
  595. ((? page-break?)
  596. (unless delimited? (newline port))
  597. (display #\page port)
  598. (newline port)
  599. (display (make-string indent #\space) port)
  600. indent)
  601. (('quote lst)
  602. (unless delimited? (display " " port))
  603. (display "'" port)
  604. (loop indent (+ column (if delimited? 1 2)) #t context lst))
  605. (('quasiquote lst)
  606. (unless delimited? (display " " port))
  607. (display "`" port)
  608. (loop indent (+ column (if delimited? 1 2)) #t context lst))
  609. (('unquote lst)
  610. (unless delimited? (display " " port))
  611. (display "," port)
  612. (loop indent (+ column (if delimited? 1 2)) #t context lst))
  613. (('unquote-splicing lst)
  614. (unless delimited? (display " " port))
  615. (display ",@" port)
  616. (loop indent (+ column (if delimited? 2 3)) #t context lst))
  617. (('gexp lst)
  618. (unless delimited? (display " " port))
  619. (display "#~" port)
  620. (loop indent (+ column (if delimited? 2 3)) #t context lst))
  621. (('ungexp obj)
  622. (unless delimited? (display " " port))
  623. (display "#$" port)
  624. (loop indent (+ column (if delimited? 2 3)) #t context obj))
  625. (('ungexp-native obj)
  626. (unless delimited? (display " " port))
  627. (display "#+" port)
  628. (loop indent (+ column (if delimited? 2 3)) #t context obj))
  629. (('ungexp-splicing lst)
  630. (unless delimited? (display " " port))
  631. (display "#$@" port)
  632. (loop indent (+ column (if delimited? 3 4)) #t context lst))
  633. (('ungexp-native-splicing lst)
  634. (unless delimited? (display " " port))
  635. (display "#+@" port)
  636. (loop indent (+ column (if delimited? 3 4)) #t context lst))
  637. (((? special-form? head) arguments ...)
  638. ;; Special-case 'let', 'lambda', 'modify-inputs', etc. so the second
  639. ;; and following arguments are less indented.
  640. (let* ((lead (special-form-lead head context))
  641. (context (cons head context))
  642. (head (symbol->display-string head (cdr context)))
  643. (total (length arguments)))
  644. (unless delimited? (display " " port))
  645. (display "(" port)
  646. (display head port)
  647. (unless (zero? lead)
  648. (display " " port))
  649. ;; Print the first LEAD arguments.
  650. (let* ((indent (+ column 2
  651. (if delimited? 0 1)))
  652. (column (+ column 1
  653. (if (zero? lead) 0 1)
  654. (if delimited? 0 1)
  655. (string-length head)))
  656. (initial-indent column))
  657. (define new-column
  658. (let inner ((n lead)
  659. (arguments (take arguments (min lead total)))
  660. (column column))
  661. (if (zero? n)
  662. (begin
  663. (newline port)
  664. (display (make-string indent #\space) port)
  665. indent)
  666. (match arguments
  667. (() column)
  668. ((head . tail)
  669. (inner (- n 1) tail
  670. (loop initial-indent column
  671. (= n lead)
  672. context
  673. head)))))))
  674. ;; Print the remaining arguments.
  675. (let ((column (print-sequence
  676. context indent new-column
  677. (drop arguments (min lead total))
  678. #t)))
  679. (display ")" port)
  680. (+ column 1)))))
  681. ((head tail ...)
  682. (let* ((overflow? (>= column max-width))
  683. (column (if overflow?
  684. (+ indent 1)
  685. (+ column (if delimited? 1 2))))
  686. (newline? (or (newline-form? head context)
  687. (list-of-lists? head tail) ;'let' bindings
  688. (starts-with-line-comment? tail)))
  689. (context (cons head context)))
  690. (if overflow?
  691. (begin
  692. (newline port)
  693. (display (make-string indent #\space) port))
  694. (unless delimited? (display " " port)))
  695. (display "(" port)
  696. (let* ((new-column (loop column column #t context head))
  697. (indent (if (or (>= new-column max-width)
  698. (not (symbol? head))
  699. (sequence-would-protrude?
  700. (+ new-column 1) tail)
  701. newline?)
  702. column
  703. (+ new-column 1))))
  704. (when newline?
  705. ;; Insert a newline right after HEAD.
  706. (newline port)
  707. (display (make-string indent #\space) port))
  708. (let ((column
  709. (print-sequence context indent
  710. (if newline? indent new-column)
  711. tail newline?)))
  712. (display ")" port)
  713. (+ column 1)))))
  714. (_
  715. (let* ((str (cond ((string? obj)
  716. (printed-string obj context))
  717. ((integer? obj)
  718. (integer->string obj context))
  719. ((symbol? obj)
  720. (symbol->display-string obj context))
  721. (else
  722. (object->string obj))))
  723. (len (string-width str)))
  724. (if (and (> (+ column 1 len) max-width)
  725. (not delimited?))
  726. (begin
  727. (newline port)
  728. (display (make-string indent #\space) port)
  729. (display str port)
  730. (+ indent len))
  731. (begin
  732. (unless delimited? (display " " port))
  733. (display str port)
  734. (+ column (if delimited? 0 1) len))))))))
  735. (define (object->string* obj indent . args)
  736. "Pretty-print OBJ with INDENT columns as the initial indent. ARGS are
  737. passed as-is to 'pretty-print-with-comments'."
  738. (call-with-output-string
  739. (lambda (port)
  740. (apply pretty-print-with-comments port obj
  741. #:indent indent
  742. args))))
  743. (define* (pretty-print-with-comments/splice port lst
  744. #:rest rest)
  745. "Write to PORT the expressions and blanks listed in LST."
  746. (for-each (lambda (exp)
  747. (apply pretty-print-with-comments port exp rest)
  748. (unless (blank? exp)
  749. (newline port)))
  750. lst))