tests/read-print.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2021-2022 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 (lambda (x y)
 147   ;; This is a procedure.
 148   (let ((z (+ x y)))
 149     (* z z)))")
 150
 151 (test-pretty-print "\
 152 (case x
 153   ((1)
 154    'one)
 155   ((2)
 156    'two))")
 157
 158 (test-pretty-print "\
 159 (cond
 160   ((zero? x)
 161    'zero)
 162   ((odd? x)
 163    'odd)
 164   (else #f))")
 165
 166 (test-pretty-print "\
 167 #~(string-append #$coreutils \"/bin/uname\")")
 168
 169 (test-pretty-print "\
 170 (package
 171   (inherit coreutils)
 172   (version \"42\"))")
 173
 174 (test-pretty-print "\
 175 (modify-phases %standard-phases
 176   (add-after 'unpack 'post-unpack
 177     (lambda _
 178       #t))
 179   (add-before 'check 'pre-check
 180     (lambda* (#:key inputs #:allow-other-keys)
 181       do things ...)))")
 182
 183 (test-pretty-print "\
 184 (#:phases (modify-phases sdfsdf
 185             (add-before 'x 'y
 186               (lambda _
 187                 xyz))))")
 188
 189 (test-pretty-print "\
 190 (description \"abcdefghijkl
 191 mnopqrstuvwxyz.\")"
 192                    #:max-width 30)
 193
 194 (test-pretty-print "\
 195 (description
 196  \"abcdefghijkl
 197 mnopqrstuvwxyz.\")"
 198                    #:max-width 12)
 199
 200 (test-pretty-print "\
 201 (description
 202  \"abcdefghijklmnopqrstuvwxyz\")"
 203                    #:max-width 33)
 204
 205 (test-pretty-print "\
 206 (modify-phases %standard-phases
 207   (replace 'build
 208     ;; Nicely indented in 'modify-phases' context.
 209     (lambda _
 210       #t)))")
 211
 212 (test-pretty-print "\
 213 (modify-inputs inputs
 214   ;; Regular indentation for 'replace' here.
 215   (replace \"gmp\" gmp))")
 216
 217 (test-pretty-print "\
 218 (package
 219   ;; Here 'sha256', 'base32', and 'arguments' must be
 220   ;; immediately followed by a newline.
 221   (source (origin
 222             (method url-fetch)
 223             (sha256
 224              (base32
 225               \"not a real base32 string\"))))
 226   (arguments
 227    '(#:phases %standard-phases
 228      #:tests? #f)))")
 229
 230 ;; '#:key value' is kept on the same line.
 231 (test-pretty-print "\
 232 (package
 233   (name \"keyword-value-same-line\")
 234   (arguments
 235    (list #:phases #~(modify-phases %standard-phases
 236                       (add-before 'x 'y
 237                         (lambda* (#:key inputs #:allow-other-keys)
 238                           (foo bar baz))))
 239          #:make-flags #~'(\"ANSWER=42\")
 240          #:tests? #f)))")
 241
 242 (test-pretty-print "\
 243 (let ((x 1)
 244       (y 2)
 245       (z (let* ((a 3)
 246                 (b 4))
 247            (+ a b))))
 248   (list x y z))")
 249
 250 (test-pretty-print "\
 251 (begin
 252   (chmod \"foo\" #o750)
 253   (chmod port
 254          (logand #o644
 255                  (lognot (umask))))
 256   (logand #x7f xyz))")
 257
 258 (test-pretty-print "\
 259 (substitute-keyword-arguments (package-arguments x)
 260   ((#:phases phases)
 261    `(modify-phases ,phases
 262       (add-before 'build 'do-things
 263         (lambda _
 264           #t))))
 265   ((#:configure-flags flags)
 266    `(cons \"--without-any-problem\"
 267           ,flags)))")
 268
 269 (test-pretty-print "\
 270 (vertical-space one:
 271
 272                 two:
 273
 274
 275                 three:
 276
 277
 278
 279                 end)")
 280
 281 (test-pretty-print "\
 282 (vertical-space one
 283
 284                 ;; Comment after blank line.
 285                 two)")
 286
 287 (test-pretty-print "\
 288 (begin
 289   break
 290 \f
 291   ;; page break above
 292   end)")
 293
 294 (test-pretty-print/sequence "\
 295 ;;; This is a top-level comment.
 296
 297 \f
 298 ;; Above is a page break.
 299 (this is an sexp
 300       ;; with a comment
 301       !!)
 302
 303 ;; The end.\n")
 304
 305 (test-pretty-print/sequence "
 306 ;;; Hello!
 307 ;;; Notice that there are three semicolons here.
 308
 309 (define-module (foo bar)
 310   #:use-module (guix)
 311   #:use-module (gnu))
 312
 313
 314 ;; And now, the OS.
 315 (operating-system
 316   (host-name \"komputilo\")
 317   (locale \"eo_EO.UTF-8\")
 318
 319   (services
 320    (cons (service mcron-service-type) %base-services)))\n"
 321                             #:format-comment canonicalize-comment)
 322
 323 (test-equal "pretty-print-with-comments, canonicalize-comment"
 324   "\
 325 (list abc
 326       ;; Not a margin comment.
 327       ;; Ditto.
 328       ;;
 329       ;; There's a blank line above.
 330       def ;margin comment
 331       ghi)"
 332   (let ((sexp (call-with-input-string
 333                   "\
 334 (list abc
 335   ;Not a margin comment.
 336   ;;;  Ditto.
 337   ;;;;;
 338   ; There's a blank line above.
 339   def  ;; margin comment
 340   ghi)"
 341                 read-with-comments)))
 342     (call-with-output-string
 343       (lambda (port)
 344         (pretty-print-with-comments port sexp
 345                                     #:format-comment
 346                                     canonicalize-comment)))))
 347
 348 (test-equal "pretty-print-with-comments, canonicalize-vertical-space"
 349   "\
 350 (list abc
 351
 352       def
 353
 354       ;; last one
 355       ghi)"
 356   (let ((sexp (call-with-input-string
 357                   "\
 358 (list abc
 359
 360
 361
 362   def
 363
 364
 365 ;; last one
 366   ghi)"
 367                 read-with-comments)))
 368     (call-with-output-string
 369       (lambda (port)
 370         (pretty-print-with-comments port sexp
 371                                     #:format-vertical-space
 372                                     canonicalize-vertical-space)))))
 373
 374 (test-equal "pretty-print-with-comments, multi-line comment"
 375   "\
 376 (list abc
 377       ;; This comment spans
 378       ;; two lines.
 379       def)"
 380   (call-with-output-string
 381     (lambda (port)
 382       (pretty-print-with-comments port
 383                                   `(list abc ,(comment "\
 384 ;; This comment spans\n
 385 ;; two lines.\n")
 386                                          def)))))
 387
 388 (test-end)