diff options
| -rw-r--r-- | Makefile.am | 2 | ||||
| -rw-r--r-- | guix/read-print.scm | 490 | ||||
| -rw-r--r-- | guix/scripts/import.scm | 4 | ||||
| -rw-r--r-- | guix/scripts/style.scm | 457 | ||||
| -rw-r--r-- | tests/read-print.scm | 209 | ||||
| -rw-r--r-- | tests/style.scm | 181 |
6 files changed, 705 insertions, 638 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/read-print.scm b/guix/read-print.scm new file mode 100644 index 0000000000..69ab8ac8b3 --- /dev/null +++ b/guix/read-print.scm @@ -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)))) 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) |