tests/read-print.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2021-2023 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (tests-style)
  20   #:use-module (guix read-print)
  21   #:use-module (guix gexp)                        ;for the reader extensions
  22   #:use-module (srfi srfi-34)
  23   #:use-module (srfi srfi-35)
  24   #:use-module (srfi srfi-64)
  25   #:use-module (ice-9 match))
  26
  27 (define-syntax-rule (test-pretty-print str args ...)
  28   "Test equality after a round-trip where STR is passed to
  29 'read-with-comments' and the resulting sexp is then passed to
  30 'pretty-print-with-comments'."
  31   (test-equal str
  32     (call-with-output-string
  33       (lambda (port)
  34         (let ((exp (call-with-input-string str
  35                      read-with-comments)))
  36          (pretty-print-with-comments port exp args ...))))))
  37
  38 (define-syntax-rule (test-pretty-print/sequence str args ...)
  39   "Likewise, but read and print entire sequences rather than individual
  40 expressions."
  41   (test-equal str
  42     (call-with-output-string
  43       (lambda (port)
  44         (let ((lst (call-with-input-string str
  45                      read-with-comments/sequence)))
  46          (pretty-print-with-comments/splice port lst args ...))))))
  47
  48 \f
  49 (test-begin "read-print")
  50
  51 (test-assert "read-with-comments: missing closing paren"
  52   (guard (c ((error? c) #t))
  53     (call-with-input-string "(what is going on?"
  54       read-with-comments)))
  55
  56 (test-equal "read-with-comments: dot notation"
  57   (cons 'a 'b)
  58   (call-with-input-string "(a . b)"
  59     read-with-comments))
  60
  61 (test-equal "read-with-comments: list with blank line"
  62   `(list with ,(vertical-space 1) blank line)
  63   (call-with-input-string "\
  64 (list with
  65
  66       blank line)\n"
  67     read-with-comments))
  68
  69 (test-equal "read-with-comments: list with multiple blank lines"
  70   `(list with ,(comment ";multiple\n" #t)
  71          ,(vertical-space 3) blank lines)
  72   (call-with-input-string "\
  73 (list with ;multiple
  74
  75
  76
  77       blank lines)\n"
  78     read-with-comments))
  79
  80 (test-equal "read-with-comments: top-level blank lines"
  81   (list (vertical-space 2) '(a b c) (vertical-space 2))
  82   (call-with-input-string "
  83
  84 (a b c)\n\n"
  85     (lambda (port)
  86       (list (read-with-comments port)
  87             (read-with-comments port)
  88             (read-with-comments port)))))
  89
  90 (test-equal "read-with-comments: top-level page break"
  91   (list (comment ";; Begin.\n") (vertical-space 1)
  92         (page-break)
  93         (comment ";; End.\n"))
  94   (call-with-input-string "\
  95 ;; Begin.
  96
  97 \f
  98 ;; End.\n"
  99     (lambda (port)
 100       (list (read-with-comments port)
 101             (read-with-comments port)
 102             (read-with-comments port)
 103             (read-with-comments port)))))
 104
 105 (test-pretty-print "(list 1 2 3 4)")
 106 (test-pretty-print "((a . 1) (b . 2))")
 107 (test-pretty-print "(a b c . boom)")
 108 (test-pretty-print "(list 1
 109                           2
 110                           3
 111                           4)"
 112                    #:long-list 3
 113                    #:indent 20)
 114 (test-pretty-print "\
 115 (list abc
 116       def)"
 117                    #:max-width 11)
 118 (test-pretty-print "\
 119 (#:foo
 120  #:bar)"
 121                    #:max-width 10)
 122
 123 (test-pretty-print "\
 124 (#:first 1
 125  #:second 2
 126  #:third 3)")
 127
 128 (test-pretty-print "\
 129 ((x
 130   1)
 131  (y
 132   2)
 133  (z
 134   3))"
 135                    #:max-width 3)
 136
 137 (test-pretty-print "\
 138 (let ((x 1)
 139       (y 2)
 140       (z 3)
 141       (p 4))
 142   (+ x y))"
 143                    #:max-width 11)
 144
 145 (test-pretty-print "\
 146 (begin
 147   1+ 1- 123/ 456*
 148   (1+ 41))")
 149
 150 (test-pretty-print "\
 151 (lambda (x y)
 152   ;; This is a procedure.
 153   (let ((z (+ x y)))
 154     (* z z)))")
 155
 156 (test-pretty-print "\
 157 (case x
 158   ((1)
 159    'one)
 160   ((2)
 161    'two))")
 162
 163 (test-pretty-print "\
 164 (cond
 165   ((zero? x)
 166    'zero)
 167   ((odd? x)
 168    'odd)
 169   (else #f))")
 170
 171 (test-pretty-print "\
 172 #~(string-append #$coreutils \"/bin/uname\")")
 173
 174 (test-pretty-print "\
 175 (package
 176   (inherit coreutils)
 177   (version \"42\"))")
 178
 179 (test-pretty-print "\
 180 (modify-phases %standard-phases
 181   (add-after 'unpack 'post-unpack
 182     (lambda _
 183       #t))
 184   (add-before 'check 'pre-check
 185     (lambda* (#:key inputs #:allow-other-keys)
 186       do things ...)))")
 187
 188 (test-pretty-print "\
 189 (#:phases (modify-phases sdfsdf
 190             (add-before 'x 'y
 191               (lambda _
 192                 xyz))))")
 193
 194 (test-pretty-print "\
 195 (string-append \"a\\tb\" \"\\n\")")
 196
 197 (test-pretty-print "\
 198 (description \"abcdefghijkl
 199 mnopqrstuvwxyz.\")"
 200                    #:max-width 30)
 201
 202 (test-pretty-print "\
 203 (description
 204  \"abcdefghijkl
 205 mnopqrstuvwxyz.\")"
 206                    #:max-width 12)
 207
 208 (test-pretty-print "\
 209 (description
 210  \"abcdefghijklmnopqrstuvwxyz\")"
 211                    #:max-width 33)
 212
 213 (test-pretty-print "\
 214 (modify-phases %standard-phases
 215   (replace 'build
 216     ;; Nicely indented in 'modify-phases' context.
 217     (lambda _
 218       #t)))")
 219
 220 (test-pretty-print "\
 221 (modify-inputs inputs
 222   ;; Regular indentation for 'replace' here.
 223   (replace \"gmp\" gmp))")
 224
 225 (test-pretty-print "\
 226 (package
 227   ;; Here 'sha256', 'base32', and 'arguments' must be
 228   ;; immediately followed by a newline.
 229   (source (origin
 230             (method url-fetch)
 231             (sha256
 232              (base32
 233               \"not a real base32 string\"))))
 234   (arguments
 235    '(#:phases %standard-phases
 236      #:tests? #f)))")
 237
 238 ;; '#:key value' is kept on the same line.
 239 (test-pretty-print "\
 240 (package
 241   (name \"keyword-value-same-line\")
 242   (arguments
 243    (list #:phases #~(modify-phases %standard-phases
 244                       (add-before 'x 'y
 245                         (lambda* (#:key inputs #:allow-other-keys)
 246                           (foo bar baz))))
 247          #:make-flags #~'(\"ANSWER=42\")
 248          #:tests? #f)))")
 249
 250 (test-pretty-print "\
 251 (let ((x 1)
 252       (y 2)
 253       (z (let* ((a 3)
 254                 (b 4))
 255            (+ a b))))
 256   (list x y z))")
 257
 258 (test-pretty-print "\
 259 (begin
 260   (chmod \"foo\" #o750)
 261   (chmod port
 262          (logand #o644
 263                  (lognot (umask))))
 264   (logand #x7f xyz))")
 265
 266 (test-pretty-print "\
 267 (substitute-keyword-arguments (package-arguments x)
 268   ((#:phases phases)
 269    `(modify-phases ,phases
 270       (add-before 'build 'do-things
 271         (lambda _
 272           #t))))
 273   ((#:configure-flags flags)
 274    `(cons \"--without-any-problem\"
 275           ,flags)))")
 276
 277 (test-pretty-print "\
 278 (vertical-space one:
 279
 280                 two:
 281
 282
 283                 three:
 284
 285
 286
 287                 end)")
 288
 289 (test-pretty-print "\
 290 (vertical-space one
 291
 292                 ;; Comment after blank line.
 293                 two)")
 294
 295 (test-pretty-print "\
 296 (begin
 297   break
 298 \f
 299   ;; page break above
 300   end)")
 301
 302 (test-pretty-print "\
 303 (home-environment
 304   (services
 305    (list (service-type home-bash-service-type))))")
 306
 307 (test-pretty-print/sequence "\
 308 ;;; This is a top-level comment.
 309
 310 \f
 311 ;; Above is a page break.
 312 (this is an sexp
 313       ;; with a comment
 314       !!)
 315
 316 ;; The end.\n")
 317
 318 (test-pretty-print/sequence "
 319 ;;; Hello!
 320 ;;; Notice that there are three semicolons here.
 321
 322 (define-module (foo bar)
 323   #:use-module (guix)
 324   #:use-module (gnu))
 325
 326
 327 ;; And now, the OS.
 328 (operating-system
 329   (host-name \"komputilo\")
 330   (locale \"eo_EO.UTF-8\")
 331
 332   (services
 333    (cons (service mcron-service-type) %base-services)))\n"
 334                             #:format-comment canonicalize-comment)
 335
 336 (test-equal "pretty-print-with-comments, canonicalize-comment"
 337   "\
 338 (list abc
 339       ;; Not a margin comment.
 340       ;; Ditto.
 341       ;;
 342       ;; There's a blank line above.
 343       def ;margin comment
 344       ghi)"
 345   (let ((sexp (call-with-input-string
 346                   "\
 347 (list abc
 348   ;Not a margin comment.
 349   ;;;  Ditto.
 350   ;;;;;
 351   ; There's a blank line above.
 352   def  ;; margin comment
 353   ghi)"
 354                 read-with-comments)))
 355     (call-with-output-string
 356       (lambda (port)
 357         (pretty-print-with-comments port sexp
 358                                     #:format-comment
 359                                     canonicalize-comment)))))
 360
 361 (test-equal "pretty-print-with-comments, canonicalize-vertical-space"
 362   "\
 363 (list abc
 364
 365       def
 366
 367       ;; last one
 368       ghi)"
 369   (let ((sexp (call-with-input-string
 370                   "\
 371 (list abc
 372
 373
 374
 375   def
 376
 377
 378 ;; last one
 379   ghi)"
 380                 read-with-comments)))
 381     (call-with-output-string
 382       (lambda (port)
 383         (pretty-print-with-comments port sexp
 384                                     #:format-vertical-space
 385                                     canonicalize-vertical-space)))))
 386
 387 (test-equal "pretty-print-with-comments, multi-line comment"
 388   "\
 389 (list abc
 390       ;; This comment spans
 391       ;; two lines.
 392       def)"
 393   (call-with-output-string
 394     (lambda (port)
 395       (pretty-print-with-comments port
 396                                   `(list abc ,(comment "\
 397 ;; This comment spans\n
 398 ;; two lines.\n")
 399                                          def)))))
 400
 401 (test-end)