;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021-2023 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2023 Kierin Bell <fernseed@fernseed.me>
;;;
;;; 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 ...))))))

(define (read-with-comments-elisp port)
  (read-with-comments port #:elisp? #t))

(define-syntax-rule (test-pretty-print-elisp str args ...)
  "Test equality after a round-trip as with `test-pretty-print', but read and write Elisp."
  (test-equal str
    (call-with-output-string
      (lambda (port)
        (let ((exp (call-with-input-string str
                    read-with-comments-elisp)))
          (pretty-print-with-comments port exp
                                      #:elisp? #t
                                      args ...))))))

\f
(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.

\f
;; 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 b)
 (c d))")
(test-pretty-print "\
((a . 1)
 (b . 2))")
(test-pretty-print "((a b) c d)")
(test-pretty-print "(a b c . boom)")
(test-pretty-print "`(a b . ,c)")
(test-pretty-print "`(a . ,(list a b c))")
(test-pretty-print "#(a b c)")

(test-pretty-print "\
(long-regexp-var-with-backlashes
 \"[!?;.]\\\\|--\\\\|\\\\w\\\\{3,\\\\}\\\\.\\\\|:[[:blank:]]+\")"
                   #:max-width 78)

(test-pretty-print "\
((alist-key . alist-val)
 (long-regexp-entry-with-backlashes
  . \"[!?;.]\\\\|--\\\\|\\\\w\\\\{3,\\\\}\\\\.\\\\|:[[:blank:]]+\"))"
                   #:max-width 78)

(test-pretty-print "\
(long-variable-name-with-function-value
 #~long-gexp-with-hash-read-syntax)"
                         #:max-width 50)

(test-pretty-print "(list 1
                          2
                          3
                          4)"
                   #:long-list 3
                   #:indent 20)
(test-pretty-print "(1 2 3 4 5)"
                   #:long-list 5)
(test-pretty-print "\
(1
 2
 3
 4
 5
 6)"
                   #:long-list 5)
(test-pretty-print "(single constant)")
(test-pretty-print "\
'(list
  2
  3
  4
  5
  6)"
                   #:long-list 5)
(test-pretty-print "\
(1
 2
 3
 4
 5
 . 6)"
                   #:long-list 5)
(test-pretty-print "\
(list
 (initial-list-argument-with-long-element))"
                   #:max-width 40)
(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 "\
#~(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 '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 "\
(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
\f
  ;; 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.

\f
;; 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-equal "read-with-comments, Elisp: integer"
  1
  (call-with-input-string "1"
    read-with-comments-elisp))

(test-equal "read-with-comments, Elisp: float"
  1.0
  (call-with-input-string "1.0"
    read-with-comments-elisp))

(test-equal "read-with-comments, Elisp: basic character"
  #\a
  (call-with-input-string "?a"
    read-with-comments-elisp))

(test-equal "read-with-comments, Elisp: control character"
  #\alarm
  (call-with-input-string "?\\a"
    read-with-comments-elisp))

(test-equal "read-with-comments, Elisp: codepoint character"
  #\x2014
  (call-with-input-string "?\\u2014"
    read-with-comments-elisp))

(test-equal "read-with-comments, Elisp: dot notation"
  (cons 'a 'b)
  (call-with-input-string "(a . b)"
    read-with-comments-elisp))

(test-equal "read-with-comments, Elisp: vector"
  #(a b c)
  (call-with-input-string "[a b c]"
    read-with-comments-elisp))

(test-equal "read-with-comments, Elisp: vector with comment"
  (list->array 1 `(a ,(comment ";comment\n" #t) b c))
  (call-with-input-string "\
[a ;comment
b c]"
    read-with-comments-elisp))

(test-pretty-print-elisp "?a")
(test-pretty-print-elisp "?\\a")
(test-pretty-print-elisp "?à")
(test-pretty-print-elisp "?\\u2014")
(test-pretty-print-elisp "224")
(test-pretty-print-elisp "224.5")
(test-pretty-print-elisp "-224.5")
(test-pretty-print-elisp "\"string\"")
(test-pretty-print-elisp "symbol")
(test-pretty-print-elisp "'quoted-symbol")
(test-pretty-print-elisp "symbol\\.with\\,escapes")
(test-pretty-print-elisp "123non-confusable-symbol")
(test-pretty-print-elisp "\\123e0")
(test-pretty-print-elisp ":keyword*")

(test-pretty-print-elisp "(a b c)")
(test-pretty-print-elisp "(a . b)")
(test-pretty-print-elisp "(a b . c)")
(test-pretty-print-elisp "`(a b ,c)")
(test-pretty-print-elisp "`(a b . ,c)")
(test-pretty-print-elisp "(a b 'c)")

(test-pretty-print-elisp "\
(foo arg1
     #'longer-than
     arg3 arg4)"
                         #:max-width 15)
(test-pretty-print-elisp "\
(foo
 (list
  longer)
 b c)"
                         #:max-width 10)
(test-pretty-print-elisp "\
(foo
 #'longer-than
 arg1 arg2)"
                         #:max-width 10)
(test-pretty-print-elisp "\
(a
 #'longer-than
 b . c)"
                         #:max-width 10)

(test-pretty-print-elisp "\
(defun foo (x y)
  ;; Comment
  (let ((z (+ x y)))
    (* z z)))")

(test-pretty-print-elisp "[a b c]")
(test-pretty-print-elisp "\
[long-symbol
 b c d]"
                         #:max-width 10)
(test-pretty-print-elisp "\
[(long
  list xx)
 b c d]"
                         #:max-width 10)

(test-pretty-print-elisp "\
(defun foo ()
  (dlet ((x '((a b . \"c\"))))
    x))")

(test-pretty-print-elisp "\
(defvar foo value)")

(test-pretty-print-elisp "\
(defvar foo #'foo-function
  \"Foo function.\")")

(test-pretty-print-elisp "\
(if (fboundp 'foo-function)
  (ding)
  (autoload #'foo-function \"foo\"
    \"Return foo.\"))")

(test-pretty-print-elisp "\
(long-variable-name-with-function-value
 #'long-function-name-with-hash-read-syntax)"
                         #:max-width 78)
(test-pretty-print-elisp "\
(a b ; Comment
   c
   d

   e
   f)"
                         #:long-list 5)

(test-pretty-print-elisp "\
[a
 b ; Comment
 c
 d

 e
 f]"
                         #:long-list 5)

(test-pretty-print-elisp "\
(use-package foo
  :bind ((\"C-c n\" . foo))
  :custom (foo-bar 'bar)
  (foo-baz my--baz)
  :init (ding))"
                         #:special-forms '((use-package . 1)))

;; Newline after list arguments for special forms
(test-pretty-print-elisp "\
(with-current-buffer-window (setq buf
                                  (get-buffer-create buf-name))
    (cd-absolute directory)
    (call-process-shell-command \"ls -l | sort -t _ -k 2\" nil t)
  (dired-virtual directory))")

(test-end)