;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021-2022 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 packages)
  #:use-module (guix scripts style)
  #:use-module ((guix utils) #:select (call-with-temporary-directory))
  #:use-module ((guix build utils) #:select (substitute*))
  #:use-module (guix gexp)                        ;for the reader extension
  #:use-module (guix diagnostics)
  #:use-module (gnu packages acl)
  #:use-module (gnu packages multiprecision)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 match)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 pretty-print))

(define (call-with-test-package inputs proc)
  (call-with-temporary-directory
   (lambda (directory)
     (call-with-output-file (string-append directory "/my-packages.scm")
       (lambda (port)
         (pretty-print
          `(begin
             (define-module (my-packages)
               #:use-module (guix)
               #:use-module (guix licenses)
               #:use-module (gnu packages acl)
               #:use-module (gnu packages base)
               #:use-module (gnu packages multiprecision)
               #:use-module (srfi srfi-1))

             (define base
               (package
                 (inherit coreutils)
                 (inputs '())
                 (native-inputs '())
                 (propagated-inputs '())))

             (define (sdl-union . lst)
               (package
                 (inherit base)
                 (name "sdl-union")))

             (define-public my-coreutils
               (package
                 (inherit base)
                 ,@inputs
                 (name "my-coreutils"))))
          port)))

     (proc directory))))

(define test-directory
  ;; Directory where the package definition lives.
  (make-parameter #f))

(define-syntax-rule (with-test-package fields exp ...)
  (call-with-test-package fields
    (lambda (directory)
      (define file
        (string-append directory "/my-packages.scm"))

      ;; Run as a separate process to make sure FILE is reloaded.
      (system* "guix" "style" "-L" directory "-S" "inputs"
               "my-coreutils")
      (system* "cat" file)

      (load file)
      (parameterize ((test-directory directory))
        exp ...))))

(define* (read-lines port line #:optional (count 1))
  "Read COUNT lines from PORT, starting from LINE."
  (let loop ((lines '())
             (count count))
    (cond ((< (port-line port) (- line 1))
           (read-char port)
           (loop lines count))
          ((zero? count)
           (string-concatenate-reverse lines))
          (else
           (match (read-line port 'concat)
             ((? eof-object?)
              (loop lines 0))
             (line
              (loop (cons line lines) (- count 1))))))))

(define* (read-package-field package field #:optional (count 1))
  (let* ((location (package-field-location package field))
         (file (location-file location))
         (line (location-line location)))
    (call-with-input-file (if (string-prefix? "/" file)
                              file
                              (string-append (test-directory) "/"
                                             file))
      (lambda (port)
        (read-lines port line count)))))


(test-begin "style")

(test-equal "nothing to rewrite"
  '()
  (with-test-package '()
    (package-direct-inputs (@ (my-packages) my-coreutils))))

(test-equal "input labels, mismatch"
  (list `(("foo" ,gmp) ("bar" ,acl))
        "      (inputs `((\"foo\" ,gmp) (\"bar\" ,acl)))\n")
  (with-test-package '((inputs `(("foo" ,gmp) ("bar" ,acl))))
    (list (package-direct-inputs (@ (my-packages) my-coreutils))
          (read-package-field (@ (my-packages) my-coreutils) 'inputs))))

(test-equal "input labels, simple"
  (list `(("gmp" ,gmp) ("acl" ,acl))
        "      (inputs (list gmp acl))\n")
  (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl))))
    (list (package-direct-inputs (@ (my-packages) my-coreutils))
          (read-package-field (@ (my-packages) my-coreutils) 'inputs))))

(test-equal "input labels, long list with one item per line"
  (list (concatenate (make-list 4 `(("gmp" ,gmp) ("acl" ,acl))))
        "\
        (list gmp
              acl
              gmp
              acl
              gmp
              acl
              gmp
              acl))\n")
  (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
                                 ("gmp" ,gmp) ("acl" ,acl)
                                 ("gmp" ,gmp) ("acl" ,acl)
                                 ("gmp" ,gmp) ("acl" ,acl))))
    (list (package-direct-inputs (@ (my-packages) my-coreutils))
          (read-package-field (@ (my-packages) my-coreutils) 'inputs 8))))

(test-equal "input labels, sdl-union"
  "\
        (list gmp acl
              (sdl-union 1 2 3 4)))\n"
  (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
                                 ("sdl-union" ,(sdl-union 1 2 3 4)))))
    (read-package-field (@ (my-packages) my-coreutils) 'inputs 2)))

(test-equal "input labels, output"
  (list `(("gmp" ,gmp "debug") ("acl" ,acl))
        "      (inputs (list `(,gmp \"debug\") acl))\n")
<br/>index 86e0598344..4c08679bc8 100644<br/>--- a/<a href='/guix/tree/gnu/packages/aspell.scm?id=d8c9be80794335285daa332f0a836bec6083eafc'>gnu/packages/aspell.scm</a><br/>+++ b/<a href='/guix/tree/gnu/packages/aspell.scm?id=74a40ddd64792a9b07fb6cfe565bbafaa8412f2b'>gnu/packages/aspell.scm</a></div><div class='hunk'>@@ -130,6 +130,14 @@ dictionaries, including personal ones.")</div><div class='ctx'>                      (base32</div><div class='ctx'>                       "01p92qj66cqb346gk7hjfynaap5sbcn85xz07kjfdq623ghr8v5s")))</div><div class='ctx'> </div><div class='add'>+(define-public aspell-dict-el</div><div class='add'>+  (aspell-dictionary "el" "Greek"</div><div class='add'>+                     #:version "0.08-0"</div><div class='add'>+                     #:prefix "aspell6-"</div><div class='add'>+                     #:sha256</div><div class='add'>+                     (base32</div><div class='add'>+                      "1ljcc30zg2v2h3w5h5jr5im41mw8jbsgvvhdd2cii2yzi8d0zxja")))</div><div class='add'>+</div><div class='ctx'> (define-public aspell-dict-en</div><div class='ctx'>   (aspell-dictionary "en" "English"</div><div class='ctx'>                      #:version "2017.01.22-0"</div><div class='hunk'>@@ -159,12 +167,19 @@ dictionaries, including personal ones.")</div><div class='ctx'>                      (base32</div><div class='ctx'>                       "14ffy9mn5jqqpp437kannc3559bfdrpk7r36ljkzjalxa53i0hpr")))</div><div class='ctx'> </div><div class='del'>-(define-public aspell-dict-ru</div><div class='del'>-  (aspell-dictionary "ru" "Russian"</div><div class='del'>-                     #:version "0.99f7-1"</div><div class='add'>+(define-public aspell-dict-grc</div><div class='add'>+  (aspell-dictionary "grc" "Ancient Greek"</div><div class='add'>+                     #:version "0.02-0"</div><div class='ctx'>                      #:sha256</div><div class='ctx'>                      (base32</div><div class='del'>-                      "0ip6nq43hcr7vvzbv4lwwmlwgfa60hrhsldh9xy3zg2prv6bcaaw")))</div><div class='add'>+                      "1zxr8958v37v260fkqd4pg37ns5h5kyqm54hn1hg70wq5cz8h512")))</div><div class='add'>+</div><div class='add'>+(define-public aspell-dict-he</div><div class='add'>+  (aspell-dictionary "he" "Hebrew"</div><div class='add'>+                     #:version "1.0-0"</div><div class='add'>+                     #:sha256</div><div class='add'>+                     (base32</div><div class='add'>+                      "13bhbghx5b8g0119g3wxd4n8mlf707y41vlf59irxjj0kynankfn")))</div><div class='ctx'> </div><div class='ctx'> (define-public aspell-dict-it</div><div class='ctx'>   (aspell-dictionary "it" "Italian"</div><div class='hunk'>@@ -181,12 +196,20 @@ dictionaries, including personal ones.")</div><div class='ctx'>                      (base32</div><div class='ctx'>                       "0ffb87yjsh211hllpc4b9khqqrblial4pzi1h9r3v465z1yhn3j4")))</div><div class='ctx'> </div><div class='del'>-(define-public aspell-dict-he</div><div class='del'>-  (aspell-dictionary "he" "Hebrew"</div><div class='del'>-                     #:version "1.0-0"</div><div class='add'>+(define-public aspell-dict-pt-br</div><div class='add'>+  (aspell-dictionary "pt-br" "Brazilian Portuguese"</div><div class='add'>+                     #:version "20090702-0"</div><div class='add'>+                     #:prefix "aspell6-"</div><div class='ctx'>                      #:sha256</div><div class='ctx'>                      (base32</div><div class='del'>-                      "13bhbghx5b8g0119g3wxd4n8mlf707y41vlf59irxjj0kynankfn")))</div><div class='add'>+                      "1y09lx9zf2rnp55r16b2vgj953l3538z1vaqgflg9mdvm555bz3p")))</div><div class='add'>+</div><div class='add'>+(define-public aspell-dict-ru</div><div class='add'>+  (aspell-dictionary "ru" "Russian"</div><div class='add'>+                     #:version "0.99f7-1"</div><div class='add'>+                     #:sha256</div><div class='add'>+                     (base32</div><div class='add'>+                      "0ip6nq43hcr7vvzbv4lwwmlwgfa60hrhsldh9xy3zg2prv6bcaaw")))</div><div class='ctx'> </div><div class='ctx'> (define-public aspell-dict-sv</div><div class='ctx'>   (aspell-dictionary "sv" "Swedish"</div><div class='hunk'>@@ -196,29 +219,6 @@ dictionaries, including personal ones.")</div><div class='ctx'>                      (base32</div><div class='ctx'>                       "02jwkjhr32kvyibnyzgx3smbnm576jwdzg3avdf6zxwckhy5fw4v")))</div><div class='ctx'> </div><div class='del'>-(define-public aspell-dict-el</div><div class='del'>-  (aspell-dictionary "el" "Greek"</div><div class='del'>-                     #:version "0.08-0"</div><div class='del'>-                     #:prefix "aspell6-"</div><div class='del'>-                     #:sha256</div><div class='del'>-                     (base32</div><div class='del'>-                      "1ljcc30zg2v2h3w5h5jr5im41mw8jbsgvvhdd2cii2yzi8d0zxja")))</div><div class='del'>-</div><div class='del'>-(define-public aspell-dict-grc</div><div class='del'>-  (aspell-dictionary "grc" "Ancient Greek"</div><div class='del'>-                     #:version "0.02-0"</div><div class='del'>-                     #:sha256</div><div class='del'>-                     (base32</div><div class='del'>-                      "1zxr8958v37v260fkqd4pg37ns5h5kyqm54hn1hg70wq5cz8h512")))</div><div class='del'>-</div><div class='del'>-(define-public aspell-dict-pt-br</div><div class='del'>-  (aspell-dictionary "pt-br" "Brazilian Portuguese"</div><div class='del'>-                     #:version "20090702-0"</div><div class='del'>-                     #:prefix "aspell6-"</div><div class='del'>-                     #:sha256</div><div class='del'>-                     (base32</div><div class='del'>-                      "1y09lx9zf2rnp55r16b2vgj953l3538z1vaqgflg9mdvm555bz3p")))</div><div class='del'>-</div><div class='ctx'> </div><div class='ctx'> ;;;</div><div class='ctx'> ;;; Hunspell packages made from the Aspell word lists.</div></td></tr></table></div> <!-- class=content -->
                         <div class=footer>generated by
                             <a href="https://git.zx2c4.com/cgit/about/">
                                 cgit
                             </a>
                         </div>
                        </div> <!-- id=cgit -->
</body>
</html>
,acl))
        "\
      (inputs (list gmp
                    ;; line comment!
                    acl))\n")
  (call-with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl))))
    (lambda (directory)
      (define file
        (string-append directory "/my-packages.scm"))

      (substitute* file
        ((",gmp\\)(.*)$" _ rest)
         (string-append ",gmp)\n   ;; line comment!\n" rest)))

      (system* "guix" "style" "-L" directory "-S" "inputs"
               "my-coreutils")

      (load file)
      (list (package-inputs (@ (my-packages) my-coreutils))
            (read-package-field (@ (my-packages) my-coreutils) 'inputs 3)))))

(test-equal "input labels, modify-inputs and margin comment"
  (list `(("gmp" ,gmp) ("acl" ,acl) ("mpfr" ,mpfr))
        "\
        (modify-inputs (package-propagated-inputs coreutils)
          (prepend gmp ;margin comment
                   acl ;another one
                   mpfr)))\n")
  (call-with-test-package '((inputs
                             `(("gmp" ,gmp) ("acl" ,acl) ("mpfr" ,mpfr)
                               ,@(package-propagated-inputs coreutils))))
    (lambda (directory)
      (define file
        (string-append directory "/my-packages.scm"))

      (substitute* file
        ((",gmp\\)(.*)$" _ rest)
         (string-append ",gmp) ;margin comment" rest))
        ((",acl\\)(.*)$" _ rest)
         (string-append ",acl) ;another one" rest)))

      (system* "guix" "style" "-L" directory "-S" "inputs"
               "my-coreutils")

      (load file)
      (list (package-inputs (@ (my-packages) my-coreutils))
            (read-package-field (@ (my-packages) my-coreutils) 'inputs 4)))))


(test-end)

;; Local Variables:
;; eval: (put 'with-test-package 'scheme-indent-function 1)
;; eval: (put 'call-with-test-package 'scheme-indent-function 1)
;; End: