[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
03/17: style: Move reader and printer to (guix read-print).
|
From: |
guix-commits |
|
Subject: |
03/17: style: Move reader and printer to (guix read-print). |
|
Date: |
Mon, 8 Aug 2022 05:55:09 -0400 (EDT) |
civodul pushed a commit to branch master
in repository guix.
commit 5817e222faf46f76fbdb66ba8fd6c8cd643aefb5
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Wed Jul 20 19:11:21 2022 +0200
style: Move reader and printer to (guix read-print).
* 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'.
---
Makefile.am | 2 +
guix/{scripts/style.scm => read-print.scm} | 444 +---------------------------
guix/scripts/import.scm | 4 +-
guix/scripts/style.scm | 457 +----------------------------
tests/read-print.scm | 209 +++++++++++++
tests/style.scm | 181 ------------
6 files changed, 230 insertions(+), 1067 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index e5363140fb..2cda20e61c 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -130,6 +130,7 @@ MODULES = \
guix/cve.scm \
guix/workers.scm \
guix/least-authority.scm \
+ guix/read-print.scm \
guix/ipfs.scm \
guix/platform.scm \
guix/platforms/arm.scm \
@@ -524,6 +525,7 @@ SCM_TESTS = \
tests/profiles.scm \
tests/publish.scm \
tests/pypi.scm \
+ tests/read-print.scm \
tests/records.scm \
tests/scripts.scm \
tests/search-paths.scm \
diff --git a/guix/scripts/style.scm b/guix/read-print.scm
similarity index 50%
copy from guix/scripts/style.scm
copy to guix/read-print.scm
index 9fd652beb1..69ab8ac8b3 100644
--- a/guix/scripts/style.scm
+++ b/guix/read-print.scm
@@ -16,41 +16,28 @@
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
-;;; Commentary:
-;;;
-;;; This script updates package definitions so they use the "simplified" style
-;;; for input lists, as in:
-;;;
-;;; (package
-;;; ;; ...
-;;; (inputs (list foo bar baz)))
-;;;
-;;; Code:
-
-(define-module (guix scripts style)
- #:autoload (gnu packages) (specification->package fold-packages)
- #:use-module (guix scripts)
- #:use-module ((guix scripts build) #:select (%standard-build-options))
- #:use-module (guix combinators)
- #:use-module (guix ui)
- #:use-module (guix packages)
- #:use-module (guix utils)
- #:use-module (guix i18n)
- #:use-module (guix diagnostics)
+(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)
- #:use-module (srfi srfi-26)
- #:use-module (srfi srfi-34)
- #:use-module (srfi srfi-37)
#:export (pretty-print-with-comments
read-with-comments
- canonicalize-comment
+ object->string*
+
+ comment?
+ comment->string
+ comment-margin?
+ canonicalize-comment))
- guix-style))
+;;; Commentary:
+;;;
+;;; This module provides a comment-preserving reader and a comment-preserving
+;;; pretty-printer smarter than (ice-9 pretty-print).
+;;;
+;;; Code:
;;;
@@ -494,411 +481,10 @@ FORMAT-COMMENT is 'canonicalize-comment'."
(+ 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))))
-
-
-;;;
-;;; Simplifying input expressions.
-;;;
-
-(define (label-matches? label name)
- "Return true if LABEL matches NAME, a package name."
- (or (string=? label name)
- (and (string-prefix? "python-" label)
- (string-prefix? "python2-" name)
- (string=? (string-drop label (string-length "python-"))
- (string-drop name (string-length "python2-"))))))
-
-(define* (simplify-inputs location package str inputs
- #:key (label-matches? label-matches?))
- "Simplify the inputs field of PACKAGE (a string) at LOCATION; its current
-value is INPUTS the corresponding source code is STR. Return a string to
-replace STR."
- (define (simplify-input-expression return)
- (match-lambda
- ((label ('unquote symbol)) symbol)
- ((label ('unquote symbol) output)
- (list 'quasiquote
- (list (list 'unquote symbol) output)))
- (_
- ;; Expression doesn't look like a simple input.
- (warning location (G_ "~a: complex expression, \
-bailing out~%")
- package)
- (return str))))
-
- (define (simplify-input exp input return)
- (define package* package)
-
- (match input
- ((or ((? string? label) (? package? package))
- ((? string? label) (? package? package)
- (? string?)))
- ;; If LABEL doesn't match PACKAGE's name, then simplifying would incur
- ;; a rebuild, and perhaps it would break build-side code relying on
- ;; this specific label.
- (if (label-matches? label (package-name package))
- ((simplify-input-expression return) exp)
- (begin
- (warning location (G_ "~a: input label \
-'~a' does not match package name, bailing out~%")
- package* label)
- (return str))))
- (_
- (warning location (G_ "~a: non-trivial input, \
-bailing out~%")
- package*)
- (return str))))
-
- (define (simplify-expressions exp inputs return)
- ;; Simplify the expressions in EXP, which correspond to INPUTS, and return
- ;; a list of expressions. Call RETURN with a string when bailing out.
- (let loop ((result '())
- (exp exp)
- (inputs inputs))
- (match exp
- (((? comment? head) . rest)
- (loop (cons head result) rest inputs))
- ((head . rest)
- (match inputs
- ((input . inputs)
- ;; HEAD (an sexp) and INPUT (an input tuple) are correlated.
- (loop (cons (simplify-input head input return) result)
- rest inputs))
- (()
- ;; If EXP and INPUTS have a different length, that
- ;; means EXP is a non-trivial input list, for example
- ;; with input-splicing, conditionals, etc.
- (warning location (G_ "~a: input expression is too short~%")
- package)
- (return str))))
- (()
- ;; It's possible for EXP to contain fewer elements than INPUTS, for
- ;; example in the case of input splicing. No bailout here. (XXX)
- (reverse result)))))
-
- (define inputs-exp
- (call-with-input-string str read-with-comments))
-
- (match inputs-exp
- (('list _ ...) ;already done
- str)
- (('modify-inputs _ ...) ;already done
- str)
- (('quasiquote ;prepending inputs
- (exp ...
- ('unquote-splicing
- ((and symbol (or 'package-inputs 'package-native-inputs
- 'package-propagated-inputs))
- arg))))
- (let/ec return
- (object->string*
- (let ((things (simplify-expressions exp inputs return)))
- `(modify-inputs (,symbol ,arg)
- (prepend ,@things)))
- (location-column location))))
- (('quasiquote ;replacing an input
- ((and exp ((? string? to-delete) ('unquote replacement)))
- ('unquote-splicing
- ('alist-delete (? string? to-delete)
- ((and symbol
- (or 'package-inputs 'package-native-inputs
- 'package-propagated-inputs))
- arg)))))
- (let/ec return
- (object->string*
- (let ((things (simplify-expressions (list exp)
- (list (car inputs))
- return)))
- `(modify-inputs (,symbol ,arg)
- (replace ,to-delete ,replacement)))
- (location-column location))))
-
- (('quasiquote ;removing an input
- (exp ...
- ('unquote-splicing
- ('alist-delete (? string? to-delete)
- ((and symbol
- (or 'package-inputs 'package-native-inputs
- 'package-propagated-inputs))
- arg)))))
- (let/ec return
- (object->string*
- (let ((things (simplify-expressions exp inputs return)))
- `(modify-inputs (,symbol ,arg)
- (delete ,to-delete)
- (prepend ,@things)))
- (location-column location))))
- (('fold 'alist-delete ;removing several inputs
- ((and symbol
- (or 'package-inputs 'package-native-inputs
- 'package-propagated-inputs))
- arg)
- ('quote ((? string? to-delete) ...)))
- (object->string*
- `(modify-inputs (,symbol ,arg)
- (delete ,@to-delete))
- (location-column location)))
- (('quasiquote ;removing several inputs and adding others
- (exp ...
- ('unquote-splicing
- ('fold 'alist-delete
- ((and symbol
- (or 'package-inputs 'package-native-inputs
- 'package-propagated-inputs))
- arg)
- ('quote ((? string? to-delete) ...))))))
- (let/ec return
- (object->string*
- (let ((things (simplify-expressions exp inputs return)))
- `(modify-inputs (,symbol ,arg)
- (delete ,@to-delete)
- (prepend ,@things)))
- (location-column location))))
- (('quasiquote (exp ...))
- (let/ec return
- (object->string*
- `(list ,@(simplify-expressions exp inputs return))
- (location-column location))))
- (_
- (warning location (G_ "~a: unsupported input style, \
-bailing out~%")
- package)
- str)))
-
-(define (edit-expression/dry-run properties rewrite-string)
- "Like 'edit-expression' but display what would be edited without actually
-doing it."
- (edit-expression properties
- (lambda (str)
- (unless (string=? (rewrite-string str) str)
- (info (source-properties->location properties)
- (G_ "would be edited~%")))
- str)))
-
-(define (absolute-location loc)
- "Replace the file name in LOC by an absolute location."
- (location (if (string-prefix? "/" (location-file loc))
- (location-file loc)
-
- ;; 'search-path' might return #f in obscure cases, such as
- ;; when %LOAD-PATH includes "." or ".." and LOC comes from a
- ;; file in a subdirectory thereof.
- (match (search-path %load-path (location-file loc))
- (#f
- (raise (formatted-message
- (G_ "file '~a' not found on load path")
- (location-file loc))))
- (str str)))
- (location-line loc)
- (location-column loc)))
-
-(define* (simplify-package-inputs package
- #:key (policy 'silent)
- (edit-expression edit-expression))
- "Edit the source code of PACKAGE to simplify its inputs field if needed.
-POLICY is a symbol that defines whether to simplify inputs; it can one of
-'silent (change only if the resulting derivation is the same), 'safe (change
-only if semantics are known to be unaffected), and 'always (fearlessly
-simplify inputs!). Call EDIT-EXPRESSION to actually edit the source of
-PACKAGE."
- (for-each (lambda (field-name field)
- (match (field package)
- (()
- #f)
- (inputs
- (match (package-field-location package field-name)
- (#f
- ;; If the location of FIELD-NAME is not found, it may be
- ;; that PACKAGE inherits from another package.
- #f)
- (location
- (edit-expression
- (location->source-properties (absolute-location location))
- (lambda (str)
- (define matches?
- (match policy
- ('silent
- ;; Simplify inputs only when the label matches
- ;; perfectly, such that the resulting derivation
- ;; is unchanged.
- label-matches?)
- ('safe
- ;; If PACKAGE has no arguments, labels are known
- ;; to have no effect: this is a "safe" change, but
- ;; it may change the derivation.
- (if (null? (package-arguments package))
- (const #t)
- label-matches?))
- ('always
- ;; Assume it's gonna be alright.
- (const #t))))
-
- (simplify-inputs location
- (package-name package)
- str inputs
- #:label-matches? matches?))))))))
- '(inputs native-inputs propagated-inputs)
- (list package-inputs package-native-inputs
- package-propagated-inputs)))
-
-
-;;;
-;;; Formatting package definitions.
-;;;
-
-(define* (format-package-definition package
- #:key policy
- (edit-expression edit-expression))
- "Reformat the definition of PACKAGE."
- (unless (package-definition-location package)
- (leave (package-location package)
- (G_ "no definition location for package ~a~%")
- (package-full-name package)))
-
- (edit-expression
- (location->source-properties
- (absolute-location (package-definition-location package)))
- (lambda (str)
- (let ((exp (call-with-input-string str
- read-with-comments)))
- (object->string* exp
- (location-column
- (package-definition-location package))
- #:format-comment canonicalize-comment)))))
-
-(define (package-location<? p1 p2)
- "Return true if P1's location is \"before\" P2's."
- (let ((loc1 (package-location p1))
- (loc2 (package-location p2)))
- (and loc1 loc2
- (if (string=? (location-file loc1) (location-file loc2))
- (< (location-line loc1) (location-line loc2))
- (string<? (location-file loc1) (location-file loc2))))))
-
-
-;;;
-;;; Options.
-;;;
-
-(define %options
- ;; Specification of the command-line options.
- (list (find (lambda (option)
- (member "load-path" (option-names option)))
- %standard-build-options)
-
- (option '(#\n "dry-run") #f #f
- (lambda (opt name arg result)
- (alist-cons 'dry-run? #t result)))
- (option '(#\e "expression") #t #f
- (lambda (opt name arg result)
- (alist-cons 'expression arg result)))
- (option '(#\S "styling") #t #f
- (lambda (opt name arg result)
- (alist-cons 'styling-procedure
- (match arg
- ("inputs" simplify-package-inputs)
- ("format" format-package-definition)
- (_ (leave (G_ "~a: unknown styling~%")
- arg)))
- result)))
- (option '("input-simplification") #t #f
- (lambda (opt name arg result)
- (let ((symbol (string->symbol arg)))
- (unless (memq symbol '(silent safe always))
- (leave (G_ "~a: invalid input simplification policy~%")
- arg))
- (alist-cons 'input-simplification-policy symbol
- result))))
-
- (option '(#\h "help") #f #f
- (lambda args
- (show-help)
- (exit 0)))
- (option '(#\l "list-stylings") #f #f
- (lambda args
- (show-stylings)
- (exit 0)))
- (option '(#\V "version") #f #f
- (lambda args
- (show-version-and-exit "guix style")))))
-
-(define (show-stylings)
- (display (G_ "Available styling rules:\n"))
- (display (G_ "- format: Format the given package definition(s)\n"))
- (display (G_ "- inputs: Rewrite package inputs to the “new style”\n")))
-
-(define (show-help)
- (display (G_ "Usage: guix style [OPTION]... [PACKAGE]...
-Update package definitions to the latest style.\n"))
- (display (G_ "
- -S, --styling=RULE apply RULE, a styling rule"))
- (display (G_ "
- -l, --list-stylings display the list of available style rules"))
- (newline)
- (display (G_ "
- -n, --dry-run display files that would be edited but do nothing"))
- (display (G_ "
- -L, --load-path=DIR prepend DIR to the package module search path"))
- (display (G_ "
- -e, --expression=EXPR consider the package EXPR evaluates to"))
- (display (G_ "
- --input-simplification=POLICY
- follow POLICY for package input simplification, one
- of 'silent', 'safe', or 'always'"))
- (newline)
- (display (G_ "
- -h, --help display this help and exit"))
- (display (G_ "
- -V, --version display version information and exit"))
- (newline)
- (show-bug-report-information))
-
-(define %default-options
- ;; Alist of default option values.
- `((input-simplification-policy . silent)
- (styling-procedure . ,format-package-definition)))
-
-
-;;;
-;;; Entry point.
-;;;
-
-(define-command (guix-style . args)
- (category packaging)
- (synopsis "update the style of package definitions")
-
- (define (parse-options)
- ;; Return the alist of option values.
- (parse-command-line args %options (list %default-options)
- #:build-options? #f))
-
- (let* ((opts (parse-options))
- (packages (filter-map (match-lambda
- (('argument . spec)
- (specification->package spec))
- (('expression . str)
- (read/eval str))
- (_ #f))
- opts))
- (edit (if (assoc-ref opts 'dry-run?)
- edit-expression/dry-run
- edit-expression))
- (style (assoc-ref opts 'styling-procedure))
- (policy (assoc-ref opts 'input-simplification-policy)))
- (with-error-handling
- (for-each (lambda (package)
- (style package #:policy policy
- #:edit-expression edit))
- ;; Sort package by source code location so that we start
editing
- ;; files from the bottom and going upward. That way, the
- ;; 'location' field of <package> records is not invalidated as
- ;; we modify files.
- (sort (if (null? packages)
- (fold-packages cons '() #:select? (const #t))
- packages)
- (negate package-location<?))))))
diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm
index 71ab4b4fed..bd3cfd2dc3 100644
--- a/guix/scripts/import.scm
+++ b/guix/scripts/import.scm
@@ -1,5 +1,5 @@
;;; 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 © 2018 Kyle Meyer <kyle@kyleam.com>
;;; Copyright © 2019, 2022 Ricardo Wurmus <rekado@elephly.net>
@@ -25,7 +25,7 @@
(define-module (guix scripts import)
#:use-module (guix ui)
#:use-module (guix scripts)
- #:use-module (guix scripts style)
+ #:use-module (guix read-print)
#:use-module (guix utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm
index 9fd652beb1..e2530e80c0 100644
--- a/guix/scripts/style.scm
+++ b/guix/scripts/style.scm
@@ -37,468 +37,15 @@
#:use-module (guix utils)
#:use-module (guix i18n)
#:use-module (guix diagnostics)
+ #:use-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)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-37)
- #:export (pretty-print-with-comments
- 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))))
+ #:export (guix-style))
;;;
diff --git a/tests/read-print.scm b/tests/read-print.scm
new file mode 100644
index 0000000000..e9ba1127d4
--- /dev/null
+++ b/tests/read-print.scm
@@ -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)
diff --git a/tests/style.scm b/tests/style.scm
index 55bad2b3ba..4ac5ae7c09 100644
--- a/tests/style.scm
+++ b/tests/style.scm
@@ -113,17 +113,6 @@
(lambda (port)
(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")
@@ -377,176 +366,6 @@
(list (package-inputs (@ (my-packages) my-coreutils))
(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)
- branch master updated (bde902cb78 -> 6db3b34d72), guix-commits, 2022/08/08
- 03/17: style: Move reader and printer to (guix read-print).,
guix-commits <=
- 04/17: read-print: Add System and Home special forms., guix-commits, 2022/08/08
- 09/17: read-print: Recognize page breaks., guix-commits, 2022/08/08
- 11/17: read-print: 'canonicalize-comment' leaves top-level comments unchanged., guix-commits, 2022/08/08
- 01/17: lint: Add '-e'., guix-commits, 2022/08/08
- 05/17: read-print: Expose comment constructor., guix-commits, 2022/08/08
- 02/17: gnu: go-gitlab.com-shackra-goimapnotify: Update to 2.3.7., guix-commits, 2022/08/08
- 07/17: style: Adjust test to not emit blank lines., guix-commits, 2022/08/08
- 08/17: read-print: Read and render vertical space., guix-commits, 2022/08/08
- 10/17: read-print: Add code to read and write sequences of expressions/blanks., guix-commits, 2022/08/08
- 12/17: style: Add '--whole-file' option., guix-commits, 2022/08/08