;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021-2023 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-34)
#:use-module (srfi srfi-35)
#:use-module (srfi srfi-64)
#:use-module (ice-9 match))
(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 ...))))))
(define-syntax-rule (test-pretty-print/sequence str args ...)
"Likewise, but read and print entire sequences rather than individual
expressions."
(test-equal str
(call-with-output-string
(lambda (port)
(let ((lst (call-with-input-string str
read-with-comments/sequence)))
(pretty-print-with-comments/splice port lst args ...))))))
(test-begin "read-print")
(test-assert "read-with-comments: missing closing paren"
(guard (c ((error? c) #t))
(call-with-input-string "(what is going on?"
read-with-comments)))
(test-equal "read-with-comments: dot notation"
(cons 'a 'b)
(call-with-input-string "(a . b)"
read-with-comments))
(test-equal "read-with-comments: half dot notation"
'(lambda x x)
(call-with-input-string "(lambda (. x) x)"
read-with-comments))
(test-equal "read-with-comments: list with blank line"
`(list with ,(vertical-space 1) blank line)
(call-with-input-string "\
(list with
blank line)\n"
read-with-comments))
(test-equal "read-with-comments: list with multiple blank lines"
`(list with ,(comment ";multiple\n" #t)
,(vertical-space 3) blank lines)
(call-with-input-string "\
(list with ;multiple
blank lines)\n"
read-with-comments))
(test-equal "read-with-comments: top-level blank lines"
(list (vertical-space 2) '(a b c) (vertical-space 2))
(call-with-input-string "
(a b c)\n\n"
(lambda (port)
(list (read-with-comments port)
(read-with-comments port)
(read-with-comments port)))))
(test-equal "read-with-comments: top-level page break"
(list (comment ";; Begin.\n") (vertical-space 1)
(page-break)
(comment ";; End.\n"))
(call-with-input-string "\
;; Begin.
;; End.\n"
(lambda (port)
(list (read-with-comments port)
(read-with-comments port)
(read-with-comments port)
(read-with-comments port)))))
(test-pretty-print "(list 1 2 3 4)")
(test-pretty-print "((a . 1) (b . 2))")
(test-pretty-print "(a b c . boom)")
(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 "\
(begin
1+ 1- 123/ 456*
(1+ 41))")
(test-pretty-print "\
(lambda (x y)
;; This is a procedure.
(let ((z (+ x y)))
(* z z)))")
(test-pretty-print "\
(case x
((1)
'one)
((2)
'two))")
(test-pretty-print "\
(cond
((zero? x)
'zero)
((odd? x)
'odd)
(else #f))")
(test-pretty-print "\
(parameterize ((a 1)
(b 2))
(call f g h))")
(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 "\
(string-append \"a\\tb\" \"\\n\")")
(test-pretty-print "\
(display \"This is a very long string.
It contains line breaks, which are preserved,
because it's a long string.\")")
(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 "\
(list ;margin comment
a b c)")
(test-pretty-print "\
(list
;; This is a line comment immediately following the list head.
#:test-flags #~(list \"-m\" \"not external and not samples\"))")
(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 "\
#~(modify-phases phases
(add-after 'whatever 'something-else
(lambda _
;; This comment appears inside a gexp.
42)))")
(test-pretty-print "\
#~(list #$@(list coreutils ;yup
grep) ;margin comment
#+sed
;; Line comment.
#$grep)")
(test-pretty-print "\
(package
;; Here 'source', 'sha256', 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 "\
(begin
(chmod \"foo\" #o750)
(chmod port
(logand #o644
(lognot (umask))))
(logand #x7f xyz))")
(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-pretty-print "\
(vertical-space one:
two:
three:
end)")
(test-pretty-print "\
(vertical-space one
;; Comment after blank line.
two)")
(test-pretty-print "\
(begin
break
;; page break above
end)")
(test-pretty-print "\
(home-environment
(services
(list (service-type home-bash-service-type))))")
(test-pretty-print/sequence "\
;;; This is a top-level comment.
;; Above is a page break.
(this is an sexp
;; with a comment
!!)
;; The end.\n")
(test-pretty-print/sequence "
;;; Hello!
;;; Notice that there are three semicolons here.
(define-module (foo bar)
#:use-module (guix)
#:use-module (gnu))
;; And now, the OS.
(operating-system
(host-name \"komputilo\")
(locale \"eo_EO.UTF-8\")
(services
(cons (service mcron-service-type) %base-services)))\n"
#:format-comment canonicalize-comment)
(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-equal "pretty-print-with-comments, canonicalize-vertical-space"
"\
(list abc
def
;; last one
ghi)"
(let ((sexp (call-with-input-string
"\
(list abc
def
;; last one
ghi)"
read-with-comments)))
(call-with-output-string
(lambda (port)
(pretty-print-with-comments port sexp
#:format-vertical-space
canonicalize-vertical-space)))))
(test-equal "pretty-print-with-comments, multi-line comment"
"\
(list abc
;; This comment spans
;; two lines.
def)"
(call-with-output-string
(lambda (port)
(pretty-print-with-comments port
`(list abc ,(comment "\
;; This comment spans\n
;; two lines.\n")
def)))))
(test-end)
