@@ -35,6 +35,9 @@ (define-module (guix read-print)
vertical-space-height
canonicalize-vertical-space
+ page-break
+ page-break?
+
comment
comment?
comment->string
@@ -83,6 +86,18 @@ (define canonicalize-vertical-space
"Return a vertical space corresponding to a single blank line."
unit)))
+(define <page-break>
+ (make-record-type '<page-break> '()
+ #:parent <blank>
+ #:extensible? #f))
+
+(define page-break? (record-predicate <page-break>))
+(define page-break
+ (let ((break ((record-type-constructor <page-break>))))
+ (lambda ()
+ break)))
+
+
(define <comment>
;; Comments.
(make-record-type '<comment> '(str margin?)
@@ -105,12 +120,17 @@ (define* (comment str #:optional margin?)
(&message (message "invalid comment string")))))
(string->comment str margin?))
+(define char-set:whitespace-sans-page-break
+ ;; White space, excluding #\page.
+ (char-set-difference char-set:whitespace (char-set #\page)))
+
+(define (space? chr)
+ "Return true if CHR is white space, except for page breaks."
+ (char-set-contains? char-set:whitespace-sans-page-break chr))
+
(define (read-vertical-space port)
"Read from PORT until a non-vertical-space character is met, and return a
single <vertical-space> record."
- (define (space? chr)
- (char-set-contains? char-set:whitespace chr))
-
(let loop ((height 1))
(match (read-char port)
(#\newline (loop (+ 1 height)))
@@ -118,6 +138,15 @@ (define (space? chr)
((? space?) (loop height))
(chr (unread-char chr port) (vertical-space height)))))
+(define (read-until-end-of-line port)
+ "Read white space from PORT until the end of line, included."
+ (let loop ()
+ (match (read-char port)
+ (#\newline #t)
+ ((? eof-object?) #t)
+ ((? space?) (loop))
+ (chr (unread-char chr port)))))
+
(define (read-with-comments port)
"Like 'read', but include <blank> objects when they're encountered."
;; Note: Instead of implementing this functionality in 'read' proper, which
@@ -148,6 +177,11 @@ (define (reverse/dot lst)
(if blank-line?
(read-vertical-space port)
(loop #t return)))
+ ((eqv? chr #\page)
+ ;; Assume that a page break is on a line of its own and read
+ ;; subsequent white space and newline.
+ (read-until-end-of-line port)
+ (page-break))
((char-set-contains? char-set:whitespace chr)
(loop blank-line? return))
((memv chr '(#\( #\[))
@@ -444,6 +478,12 @@ (define (special-form? head)
(loop (- i 1))))
(display (make-string indent #\space) port)
indent)
+ ((? page-break?)
+ (unless delimited? (newline port))
+ (display #\page port)
+ (newline port)
+ (display (make-string indent #\space) port)
+ indent)
(('quote lst)
(unless delimited? (display " " port))
(display "'" port)
@@ -70,6 +70,21 @@ (define-syntax-rule (test-pretty-print str args ...)
(read-with-comments port)
(read-with-comments port)))))
+(test-equal "read-with-comments: top-level page break"
+ (list (comment ";; Begin.\n") (vertical-space 1)
+ (page-break)
+ (comment ";; End.\n"))
+ (call-with-input-string "\
+;; Begin.
+
+
+;; End.\n"
+ (lambda (port)
+ (list (read-with-comments port)
+ (read-with-comments port)
+ (read-with-comments port)
+ (read-with-comments port)))))
+
(test-pretty-print "(list 1 2 3 4)")
(test-pretty-print "((a . 1) (b . 2))")
(test-pretty-print "(a b c . boom)")
@@ -229,6 +244,13 @@ (define-syntax-rule (test-pretty-print str args ...)
;; Comment after blank line.
two)")
+(test-pretty-print "\
+(begin
+ break
+
+ ;; page break above
+ end)")
+
(test-equal "pretty-print-with-comments, canonicalize-comment"
"\
(list abc
* guix/read-print.scm (<page-break>, page-break?, page-break) (char-set:whitespace-sans-page-break): New variables. (space?): New procedure. (read-vertical-space): Use it. (read-until-end-of-line): New procedure. (read-with-comments): Add #\page case. (pretty-print-with-comments): Add 'page-break?' case. * tests/read-print.scm ("read-with-comments: top-level page break"): New test. Add round-trip test with page break within an sexp. --- guix/read-print.scm | 46 +++++++++++++++++++++++++++++++++++++++++--- tests/read-print.scm | 22 +++++++++++++++++++++ 2 files changed, 65 insertions(+), 3 deletions(-)