amaharaneko/guix-mirrors
1
1
Fork 0
mirror of https://codeberg.org/guix/guix.git synced 2025-10-02 02:15:12 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

style: Move reader and printer to (guix read-print).

Browse source 
* guix/scripts/style.scm (<comment>, read-with-comments)
(vhashq, %special-forms, %newline-forms, prefix?)
(special-form-lead, newline-form?, escaped-string)
(string-width, canonicalize-comment, pretty-print-with-comments)
(object->string*): Move to...
* guix/read-print.scm: ... here.  New file.
* guix/scripts/import.scm: Adjust accordingly.
* tests/style.scm: Move 'test-pretty-print' and tests to...
* tests/read-print.scm: ... here.  New file.
* Makefile.am (MODULES): Add 'guix/read-print.scm'.
(SCM_TESTS): Add 'tests/read-print.scm'.
This commit is contained in:
Ludovic Courtès 2022-07-20 19:11:21 +02:00
parent bc3eaf9d83
commit 5817e222fa
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
6 changed files with 705 additions and 638 deletions
Download patch file Download diff file Expand all files Collapse all files

2
Makefile.am
View file

@ -130,6 +130,7 @@ MODULES = \
guix/cve.scm \ guix/cve.scm \
guix/workers.scm \ guix/workers.scm \
guix/least-authority.scm \ guix/least-authority.scm \
guix/read-print.scm \
guix/ipfs.scm \ guix/ipfs.scm \
guix/platform.scm \ guix/platform.scm \
guix/platforms/arm.scm \ guix/platforms/arm.scm \
@ -524,6 +525,7 @@ SCM_TESTS = \
tests/profiles.scm \ tests/profiles.scm \
tests/publish.scm \ tests/publish.scm \
tests/pypi.scm \ tests/pypi.scm \
tests/read-print.scm \
tests/records.scm \ tests/records.scm \
tests/scripts.scm \ tests/scripts.scm \
tests/search-paths.scm \ tests/search-paths.scm \

490
guix/read-print.scm Normal file
View file

@ -0,0 +1,490 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021-2022 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix read-print)
#:use-module (ice-9 control)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 vlist)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:export (pretty-print-with-comments
read-with-comments
object->string*
comment?
comment->string
comment-margin?
canonicalize-comment))
;;; Commentary:
;;;
;;; This module provides a comment-preserving reader and a comment-preserving
;;; pretty-printer smarter than (ice-9 pretty-print).
;;;
;;; Code:
;;;
;;; Comment-preserving reader.
;;;
;; A comment.
(define-record-type <comment>
(comment str margin?)
comment?
(str comment->string)
(margin? comment-margin?))
(define (read-with-comments port)
"Like 'read', but include <comment> objects when they're encountered."
;; Note: Instead of implementing this functionality in 'read' proper, which
;; is the best approach long-term, this code is a layer on top of 'read',
;; such that we don't have to rely on a specific Guile version.
(define dot (list 'dot))
(define (dot? x) (eq? x dot))
(define (reverse/dot lst)
;; Reverse LST and make it an improper list if it contains DOT.
(let loop ((result '())
(lst lst))
(match lst
(() result)
(((? dot?) . rest)
(let ((dotted (reverse rest)))
(set-cdr! (last-pair dotted) (car result))
dotted))
((x . rest) (loop (cons x result) rest)))))
(let loop ((blank-line? #t)
(return (const 'unbalanced)))
(match (read-char port)
((? eof-object? eof)
eof) ;oops!
(chr
(cond ((eqv? chr #\newline)
(loop #t return))
((char-set-contains? char-set:whitespace chr)
(loop blank-line? return))
((memv chr '(#\( #\[))
(let/ec return
(let liip ((lst '()))
(liip (cons (loop (match lst
(((? comment?) . _) #t)
(_ #f))
(lambda ()
(return (reverse/dot lst))))
lst)))))
((memv chr '(#\) #\]))
(return))
((eq? chr #\')
(list 'quote (loop #f return)))
((eq? chr #\`)
(list 'quasiquote (loop #f return)))
((eq? chr #\,)
(list (match (peek-char port)
(#\@
(read-char port)
'unquote-splicing)
(_
'unquote))
(loop #f return)))
((eqv? chr #\;)
(unread-char chr port)
(comment (read-line port 'concat)
(not blank-line?)))
(else
(unread-char chr port)
(match (read port)
((and token '#{.}#)
(if (eq? chr #\.) dot token))
(token token))))))))
;;;
;;; Comment-preserving pretty-printer.
;;;
(define-syntax vhashq
(syntax-rules (quote)
((_) vlist-null)
((_ (key (quote (lst ...))) rest ...)
(vhash-consq key '(lst ...) (vhashq rest ...)))
((_ (key value) rest ...)
(vhash-consq key '((() . value)) (vhashq rest ...)))))
(define %special-forms
;; Forms that are indented specially. The number is meant to be understood
;; like Emacs' 'scheme-indent-function' symbol property. When given an
;; alist instead of a number, the alist gives "context" in which the symbol
;; is a special form; for instance, context (modify-phases) means that the
;; symbol must appear within a (modify-phases ...) expression.
(vhashq
('begin 1)
('lambda 2)
('lambda* 2)
('match-lambda 1)
('match-lambda* 2)
('define 2)
('define* 2)
('define-public 2)
('define*-public 2)
('define-syntax 2)
('define-syntax-rule 2)
('define-module 2)
('define-gexp-compiler 2)
('let 2)
('let* 2)
('letrec 2)
('letrec* 2)
('match 2)
('when 2)
('unless 2)
('package 1)
('origin 1)
('operating-system 1)
('modify-inputs 2)
('modify-phases 2)
('add-after '(((modify-phases) . 3)))
('add-before '(((modify-phases) . 3)))
('replace '(((modify-phases) . 2))) ;different from 'modify-inputs'
('substitute* 2)
('substitute-keyword-arguments 2)
('call-with-input-file 2)
('call-with-output-file 2)
('with-output-to-file 2)
('with-input-from-file 2)))
(define %newline-forms
;; List heads that must be followed by a newline. The second argument is
;; the context in which they must appear. This is similar to a special form
;; of 1, except that indent is 1 instead of 2 columns.
(vhashq
('arguments '(package))
('sha256 '(origin source package))
('base32 '(sha256 origin))
('git-reference '(uri origin source))
('search-paths '(package))
('native-search-paths '(package))
('search-path-specification '())))
(define (prefix? candidate lst)
"Return true if CANDIDATE is a prefix of LST."
(let loop ((candidate candidate)
(lst lst))
(match candidate
(() #t)
((head1 . rest1)
(match lst
(() #f)
((head2 . rest2)
(and (equal? head1 head2)
(loop rest1 rest2))))))))
(define (special-form-lead symbol context)
"If SYMBOL is a special form in the given CONTEXT, return its number of
arguments; otherwise return #f. CONTEXT is a stack of symbols lexically
surrounding SYMBOL."
(match (vhash-assq symbol %special-forms)
(#f #f)
((_ . alist)
(any (match-lambda
((prefix . level)
(and (prefix? prefix context) (- level 1))))
alist))))
(define (newline-form? symbol context)
"Return true if parenthesized expressions starting with SYMBOL must be
followed by a newline."
(match (vhash-assq symbol %newline-forms)
(#f #f)
((_ . prefix)
(prefix? prefix context))))
(define (escaped-string str)
"Return STR with backslashes and double quotes escaped. Everything else, in
particular newlines, is left as is."
(list->string
`(#\"
,@(string-fold-right (lambda (chr lst)
(match chr
(#\" (cons* #\\ #\" lst))
(#\\ (cons* #\\ #\\ lst))
(_ (cons chr lst))))
'()
str)
#\")))
(define (string-width str)
"Return the \"width\" of STR--i.e., the width of the longest line of STR."
(apply max (map string-length (string-split str #\newline))))
(define (canonicalize-comment c)
"Canonicalize comment C, ensuring it has the \"right\" number of leading
semicolons."
(let ((line (string-trim-both
(string-trim (comment->string c) (char-set #\;)))))
(comment (string-append
(if (comment-margin? c)
";"
(if (string-null? line)
";;" ;no trailing space
";; "))
line "\n")
(comment-margin? c))))
(define* (pretty-print-with-comments port obj
#:key
(format-comment identity)
(indent 0)
(max-width 78)
(long-list 5))
"Pretty-print OBJ to PORT, attempting to at most MAX-WIDTH character columns
and assuming the current column is INDENT. Comments present in OBJ are
included in the output.
Lists longer than LONG-LIST are written as one element per line. Comments are
passed through FORMAT-COMMENT before being emitted; a useful value for
FORMAT-COMMENT is 'canonicalize-comment'."
(define (list-of-lists? head tail)
;; Return true if HEAD and TAIL denote a list of lists--e.g., a list of
;; 'let' bindings.
(match head
((thing _ ...) ;proper list
(and (not (memq thing
'(quote quasiquote unquote unquote-splicing)))
(pair? tail)))
(_ #f)))
(let loop ((indent indent)
(column indent)
(delimited? #t) ;true if comes after a delimiter
(context '()) ;list of "parent" symbols
(obj obj))
(define (print-sequence context indent column lst delimited?)
(define long?
(> (length lst) long-list))
(let print ((lst lst)
(first? #t)
(delimited? delimited?)
(column column))
(match lst
(()
column)
((item . tail)
(define newline?
;; Insert a newline if ITEM is itself a list, or if TAIL is long,
;; but only if ITEM is not the first item. Also insert a newline
;; before a keyword.
(and (or (pair? item) long?
(and (keyword? item)
(not (eq? item #:allow-other-keys))))
(not first?) (not delimited?)
(not (comment? item))))
(when newline?
(newline port)
(display (make-string indent #\space) port))
(let ((column (if newline? indent column)))
(print tail
(keyword? item) ;keep #:key value next to one another
(comment? item)
(loop indent column
(or newline? delimited?)
context
item)))))))
(define (sequence-would-protrude? indent lst)
;; Return true if elements of LST written at INDENT would protrude
;; beyond MAX-WIDTH. This is implemented as a cheap test with false
;; negatives to avoid actually rendering all of LST.
(find (match-lambda
((? string? str)
(>= (+ (string-width str) 2 indent) max-width))
((? symbol? symbol)
(>= (+ (string-width (symbol->string symbol)) indent)
max-width))
((? boolean?)
(>= (+ 2 indent) max-width))
(()
(>= (+ 2 indent) max-width))
(_ ;don't know
#f))
lst))
(define (special-form? head)
(special-form-lead head context))
(match obj
((? comment? comment)
(if (comment-margin? comment)
(begin
(display " " port)
(display (comment->string (format-comment comment))
port))
(begin
;; When already at the beginning of a line, for example because
;; COMMENT follows a margin comment, no need to emit a newline.
(unless (= column indent)
(newline port)
(display (make-string indent #\space) port))
(display (comment->string (format-comment comment))
port)))
(display (make-string indent #\space) port)
indent)
(('quote lst)
(unless delimited? (display " " port))
(display "'" port)
(loop indent (+ column (if delimited? 1 2)) #t context lst))
(('quasiquote lst)
(unless delimited? (display " " port))
(display "`" port)
(loop indent (+ column (if delimited? 1 2)) #t context lst))
(('unquote lst)
(unless delimited? (display " " port))
(display "," port)
(loop indent (+ column (if delimited? 1 2)) #t context lst))
(('unquote-splicing lst)
(unless delimited? (display " " port))
(display ",@" port)
(loop indent (+ column (if delimited? 2 3)) #t context lst))
(('gexp lst)
(unless delimited? (display " " port))
(display "#~" port)
(loop indent (+ column (if delimited? 2 3)) #t context lst))
(('ungexp obj)
(unless delimited? (display " " port))
(display "#$" port)
(loop indent (+ column (if delimited? 2 3)) #t context obj))
(('ungexp-native obj)
(unless delimited? (display " " port))
(display "#+" port)
(loop indent (+ column (if delimited? 2 3)) #t context obj))
(('ungexp-splicing lst)
(unless delimited? (display " " port))
(display "#$@" port)
(loop indent (+ column (if delimited? 3 4)) #t context lst))
(('ungexp-native-splicing lst)
(unless delimited? (display " " port))
(display "#+@" port)
(loop indent (+ column (if delimited? 3 4)) #t context lst))
(((? special-form? head) arguments ...)
;; Special-case 'let', 'lambda', 'modify-inputs', etc. so the second
;; and following arguments are less indented.
(let* ((lead (special-form-lead head context))
(context (cons head context))
(head (symbol->string head))
(total (length arguments)))
(unless delimited? (display " " port))
(display "(" port)
(display head port)
(unless (zero? lead)
(display " " port))
;; Print the first LEAD arguments.
(let* ((indent (+ column 2
(if delimited? 0 1)))
(column (+ column 1
(if (zero? lead) 0 1)
(if delimited? 0 1)
(string-length head)))
(initial-indent column))
(define new-column
(let inner ((n lead)
(arguments (take arguments (min lead total)))
(column column))
(if (zero? n)
(begin
(newline port)
(display (make-string indent #\space) port)
indent)
(match arguments
(() column)
((head . tail)
(inner (- n 1) tail
(loop initial-indent column
(= n lead)
context
head)))))))
;; Print the remaining arguments.
(let ((column (print-sequence
context indent new-column
(drop arguments (min lead total))
#t)))
(display ")" port)
(+ column 1)))))
((head tail ...)
(let* ((overflow? (>= column max-width))
(column (if overflow?
(+ indent 1)
(+ column (if delimited? 1 2))))
(newline? (or (newline-form? head context)
(list-of-lists? head tail))) ;'let' bindings
(context (cons head context)))
(if overflow?
(begin
(newline port)
(display (make-string indent #\space) port))
(unless delimited? (display " " port)))
(display "(" port)
(let* ((new-column (loop column column #t context head))
(indent (if (or (>= new-column max-width)
(not (symbol? head))
(sequence-would-protrude?
(+ new-column 1) tail)
newline?)
column
(+ new-column 1))))
(when newline?
;; Insert a newline right after HEAD.
(newline port)
(display (make-string indent #\space) port))
(let ((column
(print-sequence context indent
(if newline? indent new-column)
tail newline?)))
(display ")" port)
(+ column 1)))))
(_
(let* ((str (if (string? obj)
(escaped-string obj)
(object->string obj)))
(len (string-width str)))
(if (and (> (+ column 1 len) max-width)
(not delimited?))
(begin
(newline port)
(display (make-string indent #\space) port)
(display str port)
(+ indent len))
(begin
(unless delimited? (display " " port))
(display str port)
(+ column (if delimited? 0 1) len))))))))
(define (object->string* obj indent . args)
"Pretty-print OBJ with INDENT columns as the initial indent. ARGS are
passed as-is to 'pretty-print-with-comments'."
(call-with-output-string
(lambda (port)
(apply pretty-print-with-comments port obj
#:indent indent
args))))

4
guix/scripts/import.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2012-2014, 2020-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 David Thompson <davet@gnu.org> ;;; Copyright © 2014 David Thompson <davet@gnu.org>
;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
;;; Copyright © 2019, 2022 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2019, 2022 Ricardo Wurmus <rekado@elephly.net>
@ -25,7 +25,7 @@
(define-module (guix scripts import) (define-module (guix scripts import)
#:use-module (guix ui) #:use-module (guix ui)
#:use-module (guix scripts) #:use-module (guix scripts)
#:use-module (guix scripts style) #:use-module (guix read-print)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)

457
guix/scripts/style.scm
View file

@ -37,468 +37,15 @@
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix i18n) #:use-module (guix i18n)
#:use-module (guix diagnostics) #:use-module (guix diagnostics)
#:use-module (guix read-print)
#:use-module (ice-9 control) #:use-module (ice-9 control)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 vlist)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
#:use-module (srfi srfi-37) #:use-module (srfi srfi-37)
#:export (pretty-print-with-comments #:export (guix-style))
read-with-comments
canonicalize-comment
guix-style))
;;;
;;; Comment-preserving reader.
;;;
;; A comment.
(define-record-type <comment>
(comment str margin?)
comment?
(str comment->string)
(margin? comment-margin?))
(define (read-with-comments port)
"Like 'read', but include <comment> objects when they're encountered."
;; Note: Instead of implementing this functionality in 'read' proper, which
;; is the best approach long-term, this code is a layer on top of 'read',
;; such that we don't have to rely on a specific Guile version.
(define dot (list 'dot))
(define (dot? x) (eq? x dot))
(define (reverse/dot lst)
;; Reverse LST and make it an improper list if it contains DOT.
(let loop ((result '())
(lst lst))
(match lst
(() result)
(((? dot?) . rest)
(let ((dotted (reverse rest)))
(set-cdr! (last-pair dotted) (car result))
dotted))
((x . rest) (loop (cons x result) rest)))))
(let loop ((blank-line? #t)
(return (const 'unbalanced)))
(match (read-char port)
((? eof-object? eof)
eof) ;oops!
(chr
(cond ((eqv? chr #\newline)
(loop #t return))
((char-set-contains? char-set:whitespace chr)
(loop blank-line? return))
((memv chr '(#\( #\[))
(let/ec return
(let liip ((lst '()))
(liip (cons (loop (match lst
(((? comment?) . _) #t)
(_ #f))
(lambda ()
(return (reverse/dot lst))))
lst)))))
((memv chr '(#\) #\]))
(return))
((eq? chr #\')
(list 'quote (loop #f return)))
((eq? chr #\`)
(list 'quasiquote (loop #f return)))
((eq? chr #\,)
(list (match (peek-char port)
(#\@
(read-char port)
'unquote-splicing)
(_
'unquote))
(loop #f return)))
((eqv? chr #\;)
(unread-char chr port)
(comment (read-line port 'concat)
(not blank-line?)))
(else
(unread-char chr port)
(match (read port)
((and token '#{.}#)
(if (eq? chr #\.) dot token))
(token token))))))))
;;;
;;; Comment-preserving pretty-printer.
;;;
(define-syntax vhashq
(syntax-rules (quote)
((_) vlist-null)
((_ (key (quote (lst ...))) rest ...)
(vhash-consq key '(lst ...) (vhashq rest ...)))
((_ (key value) rest ...)
(vhash-consq key '((() . value)) (vhashq rest ...)))))
(define %special-forms
;; Forms that are indented specially. The number is meant to be understood
;; like Emacs' 'scheme-indent-function' symbol property. When given an
;; alist instead of a number, the alist gives "context" in which the symbol
;; is a special form; for instance, context (modify-phases) means that the
;; symbol must appear within a (modify-phases ...) expression.
(vhashq
('begin 1)
('lambda 2)
('lambda* 2)
('match-lambda 1)
('match-lambda* 2)
('define 2)
('define* 2)
('define-public 2)
('define*-public 2)
('define-syntax 2)
('define-syntax-rule 2)
('define-module 2)
('define-gexp-compiler 2)
('let 2)
('let* 2)
('letrec 2)
('letrec* 2)
('match 2)
('when 2)
('unless 2)
('package 1)
('origin 1)
('operating-system 1)
('modify-inputs 2)
('modify-phases 2)
('add-after '(((modify-phases) . 3)))
('add-before '(((modify-phases) . 3)))
('replace '(((modify-phases) . 2))) ;different from 'modify-inputs'
('substitute* 2)
('substitute-keyword-arguments 2)
('call-with-input-file 2)
('call-with-output-file 2)
('with-output-to-file 2)
('with-input-from-file 2)))
(define %newline-forms
;; List heads that must be followed by a newline. The second argument is
;; the context in which they must appear. This is similar to a special form
;; of 1, except that indent is 1 instead of 2 columns.
(vhashq
('arguments '(package))
('sha256 '(origin source package))
('base32 '(sha256 origin))
('git-reference '(uri origin source))
('search-paths '(package))
('native-search-paths '(package))
('search-path-specification '())))
(define (prefix? candidate lst)
"Return true if CANDIDATE is a prefix of LST."
(let loop ((candidate candidate)
(lst lst))
(match candidate
(() #t)
((head1 . rest1)
(match lst
(() #f)
((head2 . rest2)
(and (equal? head1 head2)
(loop rest1 rest2))))))))
(define (special-form-lead symbol context)
"If SYMBOL is a special form in the given CONTEXT, return its number of
arguments; otherwise return #f. CONTEXT is a stack of symbols lexically
surrounding SYMBOL."
(match (vhash-assq symbol %special-forms)
(#f #f)
((_ . alist)
(any (match-lambda
((prefix . level)
(and (prefix? prefix context) (- level 1))))
alist))))
(define (newline-form? symbol context)
"Return true if parenthesized expressions starting with SYMBOL must be
followed by a newline."
(match (vhash-assq symbol %newline-forms)
(#f #f)
((_ . prefix)
(prefix? prefix context))))
(define (escaped-string str)
"Return STR with backslashes and double quotes escaped. Everything else, in
particular newlines, is left as is."
(list->string
`(#\"
,@(string-fold-right (lambda (chr lst)
(match chr
(#\" (cons* #\\ #\" lst))
(#\\ (cons* #\\ #\\ lst))
(_ (cons chr lst))))
'()
str)
#\")))
(define (string-width str)
"Return the \"width\" of STR--i.e., the width of the longest line of STR."
(apply max (map string-length (string-split str #\newline))))
(define (canonicalize-comment c)
"Canonicalize comment C, ensuring it has the \"right\" number of leading
semicolons."
(let ((line (string-trim-both
(string-trim (comment->string c) (char-set #\;)))))
(comment (string-append
(if (comment-margin? c)
";"
(if (string-null? line)
";;" ;no trailing space
";; "))
line "\n")
(comment-margin? c))))
(define* (pretty-print-with-comments port obj
#:key
(format-comment identity)
(indent 0)
(max-width 78)
(long-list 5))
"Pretty-print OBJ to PORT, attempting to at most MAX-WIDTH character columns
and assuming the current column is INDENT. Comments present in OBJ are
included in the output.
Lists longer than LONG-LIST are written as one element per line. Comments are
passed through FORMAT-COMMENT before being emitted; a useful value for
FORMAT-COMMENT is 'canonicalize-comment'."
(define (list-of-lists? head tail)
;; Return true if HEAD and TAIL denote a list of lists--e.g., a list of
;; 'let' bindings.
(match head
((thing _ ...) ;proper list
(and (not (memq thing
'(quote quasiquote unquote unquote-splicing)))
(pair? tail)))
(_ #f)))
(let loop ((indent indent)
(column indent)
(delimited? #t) ;true if comes after a delimiter
(context '()) ;list of "parent" symbols
(obj obj))
(define (print-sequence context indent column lst delimited?)
(define long?
(> (length lst) long-list))
(let print ((lst lst)
(first? #t)
(delimited? delimited?)
(column column))
(match lst
(()
column)
((item . tail)
(define newline?
;; Insert a newline if ITEM is itself a list, or if TAIL is long,
;; but only if ITEM is not the first item. Also insert a newline
;; before a keyword.
(and (or (pair? item) long?
(and (keyword? item)
(not (eq? item #:allow-other-keys))))
(not first?) (not delimited?)
(not (comment? item))))
(when newline?
(newline port)
(display (make-string indent #\space) port))
(let ((column (if newline? indent column)))
(print tail
(keyword? item) ;keep #:key value next to one another
(comment? item)
(loop indent column
(or newline? delimited?)
context
item)))))))
(define (sequence-would-protrude? indent lst)
;; Return true if elements of LST written at INDENT would protrude
;; beyond MAX-WIDTH. This is implemented as a cheap test with false
;; negatives to avoid actually rendering all of LST.
(find (match-lambda
((? string? str)
(>= (+ (string-width str) 2 indent) max-width))
((? symbol? symbol)
(>= (+ (string-width (symbol->string symbol)) indent)
max-width))
((? boolean?)
(>= (+ 2 indent) max-width))
(()
(>= (+ 2 indent) max-width))
(_ ;don't know
#f))
lst))
(define (special-form? head)
(special-form-lead head context))
(match obj
((? comment? comment)
(if (comment-margin? comment)
(begin
(display " " port)
(display (comment->string (format-comment comment))
port))
(begin
;; When already at the beginning of a line, for example because
;; COMMENT follows a margin comment, no need to emit a newline.
(unless (= column indent)
(newline port)
(display (make-string indent #\space) port))
(display (comment->string (format-comment comment))
port)))
(display (make-string indent #\space) port)
indent)
(('quote lst)
(unless delimited? (display " " port))
(display "'" port)
(loop indent (+ column (if delimited? 1 2)) #t context lst))
(('quasiquote lst)
(unless delimited? (display " " port))
(display "`" port)
(loop indent (+ column (if delimited? 1 2)) #t context lst))
(('unquote lst)
(unless delimited? (display " " port))
(display "," port)
(loop indent (+ column (if delimited? 1 2)) #t context lst))
(('unquote-splicing lst)
(unless delimited? (display " " port))
(display ",@" port)
(loop indent (+ column (if delimited? 2 3)) #t context lst))
(('gexp lst)
(unless delimited? (display " " port))
(display "#~" port)
(loop indent (+ column (if delimited? 2 3)) #t context lst))
(('ungexp obj)
(unless delimited? (display " " port))
(display "#$" port)
(loop indent (+ column (if delimited? 2 3)) #t context obj))
(('ungexp-native obj)
(unless delimited? (display " " port))
(display "#+" port)
(loop indent (+ column (if delimited? 2 3)) #t context obj))
(('ungexp-splicing lst)
(unless delimited? (display " " port))
(display "#$@" port)
(loop indent (+ column (if delimited? 3 4)) #t context lst))
(('ungexp-native-splicing lst)
(unless delimited? (display " " port))
(display "#+@" port)
(loop indent (+ column (if delimited? 3 4)) #t context lst))
(((? special-form? head) arguments ...)
;; Special-case 'let', 'lambda', 'modify-inputs', etc. so the second
;; and following arguments are less indented.
(let* ((lead (special-form-lead head context))
(context (cons head context))
(head (symbol->string head))
(total (length arguments)))
(unless delimited? (display " " port))
(display "(" port)
(display head port)
(unless (zero? lead)
(display " " port))
;; Print the first LEAD arguments.
(let* ((indent (+ column 2
(if delimited? 0 1)))
(column (+ column 1
(if (zero? lead) 0 1)
(if delimited? 0 1)
(string-length head)))
(initial-indent column))
(define new-column
(let inner ((n lead)
(arguments (take arguments (min lead total)))
(column column))
(if (zero? n)
(begin
(newline port)
(display (make-string indent #\space) port)
indent)
(match arguments
(() column)
((head . tail)
(inner (- n 1) tail
(loop initial-indent column
(= n lead)
context
head)))))))
;; Print the remaining arguments.
(let ((column (print-sequence
context indent new-column
(drop arguments (min lead total))
#t)))
(display ")" port)
(+ column 1)))))
((head tail ...)
(let* ((overflow? (>= column max-width))
(column (if overflow?
(+ indent 1)
(+ column (if delimited? 1 2))))
(newline? (or (newline-form? head context)
(list-of-lists? head tail))) ;'let' bindings
(context (cons head context)))
(if overflow?
(begin
(newline port)
(display (make-string indent #\space) port))
(unless delimited? (display " " port)))
(display "(" port)
(let* ((new-column (loop column column #t context head))
(indent (if (or (>= new-column max-width)
(not (symbol? head))
(sequence-would-protrude?
(+ new-column 1) tail)
newline?)
column
(+ new-column 1))))
(when newline?
;; Insert a newline right after HEAD.
(newline port)
(display (make-string indent #\space) port))
(let ((column
(print-sequence context indent
(if newline? indent new-column)
tail newline?)))
(display ")" port)
(+ column 1)))))
(_
(let* ((str (if (string? obj)
(escaped-string obj)
(object->string obj)))
(len (string-width str)))
(if (and (> (+ column 1 len) max-width)
(not delimited?))
(begin
(newline port)
(display (make-string indent #\space) port)
(display str port)
(+ indent len))
(begin
(unless delimited? (display " " port))
(display str port)
(+ column (if delimited? 0 1) len))))))))
(define (object->string* obj indent . args)
(call-with-output-string
(lambda (port)
(apply pretty-print-with-comments port obj
#:indent indent
args))))
;;; ;;;

209
tests/read-print.scm Normal file
View file

@ -0,0 +1,209 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021-2022 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (tests-style)
#:use-module (guix read-print)
#:use-module (guix gexp) ;for the reader extensions
#:use-module (srfi srfi-64))
(define-syntax-rule (test-pretty-print str args ...)
"Test equality after a round-trip where STR is passed to
'read-with-comments' and the resulting sexp is then passed to
'pretty-print-with-comments'."
(test-equal str
(call-with-output-string
(lambda (port)
(let ((exp (call-with-input-string str
read-with-comments)))
(pretty-print-with-comments port exp args ...))))))
(test-begin "read-print")
(test-equal "read-with-comments: dot notation"
(cons 'a 'b)
(call-with-input-string "(a . b)"
read-with-comments))
(test-pretty-print "(list 1 2 3 4)")
(test-pretty-print "((a . 1) (b . 2))")
(test-pretty-print "(a b c . boom)")
(test-pretty-print "(list 1
2
3
4)"
#:long-list 3
#:indent 20)
(test-pretty-print "\
(list abc
def)"
#:max-width 11)
(test-pretty-print "\
(#:foo
#:bar)"
#:max-width 10)
(test-pretty-print "\
(#:first 1
#:second 2
#:third 3)")
(test-pretty-print "\
((x
1)
(y
2)
(z
3))"
#:max-width 3)
(test-pretty-print "\
(let ((x 1)
(y 2)
(z 3)
(p 4))
(+ x y))"
#:max-width 11)
(test-pretty-print "\
(lambda (x y)
;; This is a procedure.
(let ((z (+ x y)))
(* z z)))")
(test-pretty-print "\
#~(string-append #$coreutils \"/bin/uname\")")
(test-pretty-print "\
(package
(inherit coreutils)
(version \"42\"))")
(test-pretty-print "\
(modify-phases %standard-phases
(add-after 'unpack 'post-unpack
(lambda _
#t))
(add-before 'check 'pre-check
(lambda* (#:key inputs #:allow-other-keys)
do things ...)))")
(test-pretty-print "\
(#:phases (modify-phases sdfsdf
(add-before 'x 'y
(lambda _
xyz))))")
(test-pretty-print "\
(description \"abcdefghijkl
mnopqrstuvwxyz.\")"
#:max-width 30)
(test-pretty-print "\
(description
\"abcdefghijkl
mnopqrstuvwxyz.\")"
#:max-width 12)
(test-pretty-print "\
(description
\"abcdefghijklmnopqrstuvwxyz\")"
#:max-width 33)
(test-pretty-print "\
(modify-phases %standard-phases
(replace 'build
;; Nicely indented in 'modify-phases' context.
(lambda _
#t)))")
(test-pretty-print "\
(modify-inputs inputs
;; Regular indentation for 'replace' here.
(replace \"gmp\" gmp))")
(test-pretty-print "\
(package
;; Here 'sha256', 'base32', and 'arguments' must be
;; immediately followed by a newline.
(source (origin
(method url-fetch)
(sha256
(base32
\"not a real base32 string\"))))
(arguments
'(#:phases %standard-phases
#:tests? #f)))")
;; '#:key value' is kept on the same line.
(test-pretty-print "\
(package
(name \"keyword-value-same-line\")
(arguments
(list #:phases #~(modify-phases %standard-phases
(add-before 'x 'y
(lambda* (#:key inputs #:allow-other-keys)
(foo bar baz))))
#:make-flags #~'(\"ANSWER=42\")
#:tests? #f)))")
(test-pretty-print "\
(let ((x 1)
(y 2)
(z (let* ((a 3)
(b 4))
(+ a b))))
(list x y z))")
(test-pretty-print "\
(substitute-keyword-arguments (package-arguments x)
((#:phases phases)
`(modify-phases ,phases
(add-before 'build 'do-things
(lambda _
#t))))
((#:configure-flags flags)
`(cons \"--without-any-problem\"
,flags)))")
(test-equal "pretty-print-with-comments, canonicalize-comment"
"\
(list abc
;; Not a margin comment.
;; Ditto.
;;
;; There's a blank line above.
def ;margin comment
ghi)"
(let ((sexp (call-with-input-string
"\
(list abc
;Not a margin comment.
;;; Ditto.
;;;;;
; There's a blank line above.
def ;; margin comment
ghi)"
read-with-comments)))
(call-with-output-string
(lambda (port)
(pretty-print-with-comments port sexp
#:format-comment
canonicalize-comment)))))
(test-end)

181
tests/style.scm
View file

@ -113,17 +113,6 @@
(lambda (port) (lambda (port)
(read-lines port line count))))) (read-lines port line count)))))
(define-syntax-rule (test-pretty-print str args ...)
"Test equality after a round-trip where STR is passed to
'read-with-comments' and the resulting sexp is then passed to
'pretty-print-with-comments'."
(test-equal str
(call-with-output-string
(lambda (port)
(let ((exp (call-with-input-string str
read-with-comments)))
(pretty-print-with-comments port exp args ...))))))
(test-begin "style") (test-begin "style")
@ -377,176 +366,6 @@
(list (package-inputs (@ (my-packages) my-coreutils)) (list (package-inputs (@ (my-packages) my-coreutils))
(read-package-field (@ (my-packages) my-coreutils) 'inputs 4))))) (read-package-field (@ (my-packages) my-coreutils) 'inputs 4)))))
(test-equal "read-with-comments: dot notation"
(cons 'a 'b)
(call-with-input-string "(a . b)"
read-with-comments))
(test-pretty-print "(list 1 2 3 4)")
(test-pretty-print "((a . 1) (b . 2))")
(test-pretty-print "(a b c . boom)")
(test-pretty-print "(list 1
2
3
4)"
#:long-list 3
#:indent 20)
(test-pretty-print "\
(list abc
def)"
#:max-width 11)
(test-pretty-print "\
(#:foo
#:bar)"
#:max-width 10)
(test-pretty-print "\
(#:first 1
#:second 2
#:third 3)")
(test-pretty-print "\
((x
1)
(y
2)
(z
3))"
#:max-width 3)
(test-pretty-print "\
(let ((x 1)
(y 2)
(z 3)
(p 4))
(+ x y))"
#:max-width 11)
(test-pretty-print "\
(lambda (x y)
;; This is a procedure.
(let ((z (+ x y)))
(* z z)))")
(test-pretty-print "\
#~(string-append #$coreutils \"/bin/uname\")")
(test-pretty-print "\
(package
(inherit coreutils)
(version \"42\"))")
(test-pretty-print "\
(modify-phases %standard-phases
(add-after 'unpack 'post-unpack
(lambda _
#t))
(add-before 'check 'pre-check
(lambda* (#:key inputs #:allow-other-keys)
do things ...)))")
(test-pretty-print "\
(#:phases (modify-phases sdfsdf
(add-before 'x 'y
(lambda _
xyz))))")
(test-pretty-print "\
(description \"abcdefghijkl
mnopqrstuvwxyz.\")"
#:max-width 30)
(test-pretty-print "\
(description
\"abcdefghijkl
mnopqrstuvwxyz.\")"
#:max-width 12)
(test-pretty-print "\
(description
\"abcdefghijklmnopqrstuvwxyz\")"
#:max-width 33)
(test-pretty-print "\
(modify-phases %standard-phases
(replace 'build
;; Nicely indented in 'modify-phases' context.
(lambda _
#t)))")
(test-pretty-print "\
(modify-inputs inputs
;; Regular indentation for 'replace' here.
(replace \"gmp\" gmp))")
(test-pretty-print "\
(package
;; Here 'sha256', 'base32', and 'arguments' must be
;; immediately followed by a newline.
(source (origin
(method url-fetch)
(sha256
(base32
\"not a real base32 string\"))))
(arguments
'(#:phases %standard-phases
#:tests? #f)))")
;; '#:key value' is kept on the same line.
(test-pretty-print "\
(package
(name \"keyword-value-same-line\")
(arguments
(list #:phases #~(modify-phases %standard-phases
(add-before 'x 'y
(lambda* (#:key inputs #:allow-other-keys)
(foo bar baz))))
#:make-flags #~'(\"ANSWER=42\")
#:tests? #f)))")
(test-pretty-print "\
(let ((x 1)
(y 2)
(z (let* ((a 3)
(b 4))
(+ a b))))
(list x y z))")
(test-pretty-print "\
(substitute-keyword-arguments (package-arguments x)
((#:phases phases)
`(modify-phases ,phases
(add-before 'build 'do-things
(lambda _
#t))))
((#:configure-flags flags)
`(cons \"--without-any-problem\"
,flags)))")
(test-equal "pretty-print-with-comments, canonicalize-comment"
"\
(list abc
;; Not a margin comment.
;; Ditto.
;;
;; There's a blank line above.
def ;margin comment
ghi)"
(let ((sexp (call-with-input-string
"\
(list abc
;Not a margin comment.
;;; Ditto.
;;;;;
; There's a blank line above.
def ;; margin comment
ghi)"
read-with-comments)))
(call-with-output-string
(lambda (port)
(pretty-print-with-comments port sexp
#:format-comment
canonicalize-comment)))))
(test-end) (test-end)