me
/
guix
Archived
1
0
Fork 0
Code

style: Improve pretty printer and add tests. 

* guix/scripts/style.scm (vhashq): New macro.
(%special-forms): New variable.
(special-form?): New procedure.
(pretty-print-with-comments): Add many clauses and tweak existing
rules.
* tests/style.scm (test-pretty-print): New macro.
<top level>: Add 'test-pretty-print' tests.
master
Ludovic Courtès 2021-12-28 21:51:20 +01:00
parent 3dcc74d3ae
commit 97d0055edb
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 316 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

270
guix/scripts/style.scm
View File

@ -40,11 +40,15 @@
#: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 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-37) #:use-module (srfi srfi-37)
#:export (guix-style)) #:export (pretty-print-with-comments
read-with-comments
guix-style))
;;; ;;;
@ -109,15 +113,136 @@
;;; Comment-preserving pretty-printer. ;;; Comment-preserving pretty-printer.
;;; ;;;
(define-syntax vhashq
(syntax-rules ()
((_) vlist-null)
((_ (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.
(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 3)
('add-before 3)
;; ('replace 2)
('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 (special-form? symbol)
(vhash-assq symbol %special-forms))
(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* (pretty-print-with-comments port obj (define* (pretty-print-with-comments port obj
#:key #:key
(indent 0) (indent 0)
(max-width 78) (max-width 78)
(long-list 5)) (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."
(let loop ((indent indent) (let loop ((indent indent)
(column indent) (column indent)
(delimited? #t) ;true if comes after a delimiter (delimited? #t) ;true if comes after a delimiter
(obj obj)) (obj obj))
(define (print-sequence 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 #f
(comment? item)
(loop indent column
(or newline? delimited?)
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))
(match obj (match obj
((? comment? comment) ((? comment? comment)
(if (comment-margin? comment) (if (comment-margin? comment)
@ -145,57 +270,104 @@
(unless delimited? (display " " port)) (unless delimited? (display " " port))
(display "," port) (display "," port)
(loop indent (+ column (if delimited? 1 2)) #t lst)) (loop indent (+ column (if delimited? 1 2)) #t lst))
(('modify-inputs inputs clauses ...) (('unquote-splicing lst)
;; Special-case 'modify-inputs' to have one clause per line and custom (unless delimited? (display " " port))
;; indentation. (display ",@" port)
(let ((head "(modify-inputs ")) (loop indent (+ column (if delimited? 2 3)) #t lst))
(('gexp lst)
(unless delimited? (display " " port))
(display "#~" port)
(loop indent (+ column (if delimited? 2 3)) #t lst))
(('ungexp obj)
(unless delimited? (display " " port))
(display "#$" port)
(loop indent (+ column (if delimited? 2 3)) #t obj))
(('ungexp-native obj)
(unless delimited? (display " " port))
(display "#+" port)
(loop indent (+ column (if delimited? 2 3)) #t obj))
(('ungexp-splicing lst)
(unless delimited? (display " " port))
(display "#$@" port)
(loop indent (+ column (if delimited? 3 4)) #t lst))
(('ungexp-native-splicing lst)
(unless delimited? (display " " port))
(display "#+@" port)
(loop indent (+ column (if delimited? 3 4)) #t lst))
(((? special-form? head) arguments ...)
;; Special-case 'let', 'lambda', 'modify-inputs', etc. so the second
;; and following arguments are less indented.
(let* ((lead (- (cdr (vhash-assq head %special-forms)) 1))
(head (symbol->string head))
(total (length arguments)))
(unless delimited? (display " " port))
(display "(" port)
(display head port) (display head port)
(loop (+ indent 4) (unless (zero? lead)
(+ column (string-length head)) (display " " port))
#t
inputs) ;; Print the first LEAD arguments.
(let* ((indent (+ indent 2)) (let* ((indent (+ column 2
(column (fold (lambda (clause column) (if delimited? 0 1)))
(newline port) (column (+ column 1
(display (make-string indent #\space) (if (zero? lead) 0 1)
port) (if delimited? 0 1)
(loop indent indent #t clause)) (string-length head)))
indent (initial-indent column))
clauses))) (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)
head)))))))
;; Print the remaining arguments.
(let ((column (print-sequence
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)))))
(if overflow?
(begin
(newline port)
(display (make-string indent #\space) port))
(unless delimited? (display " " port)))
(display "(" port)
(let* ((new-column (loop column column #t head))
(indent (if (or (>= new-column max-width)
(not (symbol? head))
(sequence-would-protrude?
(+ new-column 1) tail))
column
(+ new-column 1))))
(define column
(print-sequence indent new-column tail #f))
(display ")" port) (display ")" port)
(+ column 1)))) (+ column 1))))
((head tail ...)
(unless delimited? (display " " port))
(display "(" port)
(let* ((new-column (loop indent (+ 1 column) #t head))
(indent (+ indent (- new-column column)))
(long? (> (length tail) long-list)))
(define column
(fold2 (lambda (item column first?)
(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.
(and (or (pair? item) long?)
(not first?) (not (comment? item))))
(when newline?
(newline port)
(display (make-string indent #\space) port))
(let ((column (if newline? indent column)))
(values (loop indent
column
(= column indent)
item)
(comment? item))))
(+ 1 new-column)
#t ;first
tail))
(display ")" port)
(+ column 1)))
(_ (_
(let* ((str (object->string obj)) (let* ((str (if (string? obj)
(len (string-length str))) (escaped-string obj)
(if (> (+ column 1 len) max-width) (object->string obj)))
(len (string-width str)))
(if (and (> (+ column 1 len) max-width)
(not delimited?))
(begin (begin
(newline port) (newline port)
(display (make-string indent #\space) port) (display (make-string indent #\space) port)
@ -204,7 +376,7 @@
(begin (begin
(unless delimited? (display " " port)) (unless delimited? (display " " port))
(display str port) (display str port)
(+ column (if delimited? 1 2) len)))))))) (+ column (if delimited? 0 1) len))))))))
(define (object->string* obj indent) (define (object->string* obj indent)
(call-with-output-string (call-with-output-string

95
tests/style.scm
View File

@ -21,6 +21,7 @@
#:use-module (guix scripts style) #:use-module (guix scripts style)
#:use-module ((guix utils) #:select (call-with-temporary-directory)) #:use-module ((guix utils) #:select (call-with-temporary-directory))
#:use-module ((guix build utils) #:select (substitute*)) #:use-module ((guix build utils) #:select (substitute*))
#:use-module (guix gexp) ;for the reader extension
#:use-module (guix diagnostics) #:use-module (guix diagnostics)
#:use-module (gnu packages acl) #:use-module (gnu packages acl)
#:use-module (gnu packages multiprecision) #:use-module (gnu packages multiprecision)
@ -111,6 +112,17 @@
(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")
@ -358,6 +370,89 @@
(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-pretty-print "(list 1 2 3 4)")
(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-end) (test-end)
;; Local Variables: ;; Local Variables: