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