;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019, 2020 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 (test-records)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (guix records))

(define (test-module)
  ;; A module in which to evaluate things that are known to fail.
  (let ((module (make-fresh-user-module)))
    (module-use! module (resolve-interface '(guix records)))
    module))


(test-begin "records")

(test-assert "define-record-type*"
  (begin
    (define-record-type* <foo> foo make-foo
      foo?
      (bar foo-bar)
      (baz foo-baz (default (+ 40 2))))
    (and (match (foo (bar 1) (baz 2))
           (($ <foo> 1 2) #t))
         (match (foo (baz 2) (bar 1))
           (($ <foo> 1 2) #t))
         (match (foo (bar 1))
           (($ <foo> 1 42) #t)))))

(test-assert "define-record-type* with let* behavior"
  ;; Make sure field initializers can refer to each other as if they were in
  ;; a 'let*'.
  (begin
    (define-record-type* <bar> bar make-bar
      foo?
      (x bar-x)
      (y bar-y (default (+ 40 2)))
      (z bar-z))
    (and (match (bar (x 1) (y (+ x 1)) (z (* y 2)))
           (($ <bar> 1 2 4) #t))
         (match (bar (x 7) (z (* x 3)))
           (($ <bar> 7 42 21) #t))
         (match (bar (z 21) (x (/ z 3)))
           (($ <bar> 7 42 21) #t)))))

(test-assert "define-record-type* & inherit"
  (begin
    (define-record-type* <foo> foo make-foo
      foo?
      (bar foo-bar)
      (baz foo-baz (default (+ 40 2))))
    (let* ((a (foo (bar 1)))
           (b (foo (inherit a) (baz 2)))
           (c (foo (inherit b) (bar -2)))
           (d (foo (inherit c)))
           (e (foo (inherit (foo (bar 42))) (baz 77))))
     (and (match a (($ <foo> 1 42) #t))
          (match b (($ <foo> 1 2) #t))
          (match c (($ <foo> -2 2) #t))
          (equal? c d)
          (match e (($ <foo> 42 77) #t))))))

(test-assert "define-record-type* & inherit & let* behavior"
  (begin
    (define-record-type* <foo> foo make-foo
      foo?
      (bar foo-bar)
      (baz foo-baz (default (+ 40 2))))
    (let* ((a (foo (bar 77)))
           (b (foo (inherit a) (bar 1) (baz (+ bar 1))))
           (c (foo (inherit b) (baz 2) (bar (- baz 1)))))
     (and (match a (($ <foo> 77 42) #t))
          (match b (($ <foo> 1 2) #t))
          (equal? b c)))))

(test-assert "define-record-type* & inherit & innate"
  (begin
    (define-record-type* <foo> foo make-foo
      foo?
      (bar foo-bar (innate) (default 42)))
    (let* ((a (foo (bar 1)))
           (b (foo (inherit a)))
           (c (foo (inherit a) (bar 3)))
           (d (foo)))
      (and (match a (($ <foo> 1) #t))
           (match b (($ <foo> 42) #t))
           (match c (($ <foo> 3) #t))
           (match d (($ <foo> 42) #t))))))

(test-assert "define-record-type* & thunked"
  (begin
    (define-record-type* <foo> foo make-foo
      foo?
      (bar foo-bar)
      (baz foo-baz (thunked)))

    (let* ((calls 0)
           (x     (foo (bar 2)
                       (baz (begin (set! calls (1+ calls)) 3)))))
      (and (zero? calls)
           (equal? (foo-bar x) 2)
           (equal? (foo-baz x) 3) (= 1 calls)
           (equal? (foo-baz x) 3) (= 2 calls)))))

(test-assert "define-record-type* & thunked & default"
  (begin
    (define-record-type* <foo> foo make-foo
      foo?
      (bar foo-bar)
      (baz foo-baz (thunked) (default 42)))

    (let ((mark (make-parameter #f)))
      (let ((x (foo (bar 2) (baz (mark))))
            (y (foo (bar 2))))
        (and (equal? (foo-bar x) 2)
             (parameterize ((mark (cons 'a 'b)))
               (eq? (foo-baz x) (mark)))
             (equal? (foo-bar y) 2)
             (equal? (foo-baz y) 42))))))

(test-assert "define-record-type* & thunked & inherited"
  (begin
    (define-record-type* <foo> foo make-foo
      foo?
      (bar foo-bar (thunked))
      (baz foo-baz (thunked) (default 42)))

    (let ((mark (make-parameter #f)))
      (let* ((x (foo (bar 2) (baz (mark))))
             (y (foo (inherit x) (bar (mark)))))
        (and (equal? (foo-bar x) 2)
             (parameterize ((mark (cons 'a 'b)))
               (eq? (foo-baz x) (mark)))
             (parameterize ((mark (cons 'a 'b)))
               (eq? (foo-bar y) (mark)))
             (parameterize ((mark (cons 'a 'b)))
               (eq? (foo-baz y) (mark))))))))

(test-assert "define-record-type* & thunked & innate"
  (let ((mark (make-parameter #f)))
    (define-record-type* <foo> foo make-foo
      foo?
      (bar foo-bar (thunked) (innate) (default (mark)))
      (baz foo-baz (default #f)))

    (let* ((x (foo (bar 42)))
           (y (foo (inherit x) (baz 'unused))))
      (and (procedure? (struct-ref x 0))
           (equal? (foo-bar x) 42)
           (parameterize ((mark (cons 'a 'b)))
             (eq? (foo-bar y) (mark)))
           (parameterize ((mark (cons 'a 'b)))
             (eq? (foo-bar y) (mark)))))))

(test-assert "define-record-type* & thunked & this-record"
  (begin
    (define-record-type* <foo> foo make-foo
      foo?
      (bar foo-bar)
      (baz foo-baz (thunked)))

    (let ((x (foo (bar 40)
                  (baz (+ (foo-bar this-record) 2)))))
      (and (= 40 (foo-bar x))
           (= 42 (foo-baz x))))))

(test-assert "define-record-type* & thunked & default & this-record"
  (begin
    (define-record-type* <foo> foo make-foo
      foo?
      (bar foo-bar)
      (baz foo-baz (thunked)
           (default (+ (foo-bar this-record) 2))))

    (let ((x (foo (bar 40))))
      (and (= 40 (foo-bar x))
           (= 42 (foo-baz x))))))

(test-assert "define-record-type* & thunked & inherit & this-record"
  (begin
    (define-record-type* <foo> foo make-foo
      foo?
      (bar foo-bar)
      (baz foo-baz (thunked)
           (default (+ (foo-bar this-record) 2))))

    (let* ((x (foo (bar 40)))
           (y (foo (inherit x) (bar -2)))
           (z (foo (inherit x) (baz -2))))
      (and (= -2 (foo-bar y))
           (=  0 (foo-baz y))
           (= 40 (foo-bar z))
           (= -2 (foo-baz z))))))

(test-assert "define-record-type* & thunked & inherit & custom this"
  (let ()
    (define-record-type* <foo> foo make-foo
      foo? this-foo
      (thing foo-thing (thunked)))
    (define-record-type* <bar> bar make-bar
      bar? this-bar
      (baz bar-baz (thunked)))

    ;; Nest records and test the two self references.
    (let* ((x (foo (thing (bar (baz (list this-bar this-foo))))))
           (y (foo-thing x)))
      (match (bar-baz y)
        ((first second)
         (and (eq? second x)
              (bar? first)
              (eq? first y)))))))

(test-assert "define-record-type* & delayed"
  (begin
    (define-record-type* <foo> foo make-foo
      foo?
      (bar foo-bar (delayed)))

    (let* ((calls 0)
           (x     (foo (bar (begin (set! calls (1+ calls)) 3)))))
      (and (zero? calls)
           (equal? (foo-bar x) 3) (= 1 calls)
           (equal? (foo-bar x) 3) (= 1 calls)
           (equal? (foo-bar x) 3) (= 1 calls)))))

(test-assert "define-record-type* & delayed & default"
  (let ((mark #f))
    (define-record-type* <foo> foo make-foo
      foo?
      (bar foo-bar (delayed) (default mark)))

    (let ((x (foo)))
      (set! mark 42)
      (and (equal? (foo-bar x) 42)
           (begin
             (set! mark 7)
             (equal? (foo-bar x) 42))))))

(test-assert "define-record-type* & delayed & inherited"
  (begin
    (define-record-type* <foo> foo make-foo
      foo?
      (bar foo-bar (delayed))
      (baz foo-baz (delayed)))

    (let* ((m 1)
           (n #f)
           (x (foo (bar m) (baz n)))
           (y (foo (inherit x) (baz 'b))))
      (set! n 'a)
      (and (equal? (foo-bar x) 1)
           (eq? (foo-baz x) 'a)
           (begin
             (set! m 777)
             (equal? (foo-bar y) 1))              ;promise was already forced
           (eq? (foo-baz y) 'b)))))

(test-assert "define-record-type* & wrong field specifier"
  (let ((exp '(begin
                (define-record-type* <foo> foo make-foo
                  foo?
                  (bar foo-bar (default 42))
                  (baz foo-baz))

                (foo (baz 1 2 3 4 5))))           ;syntax error
        (loc         (current-source-location)))  ;keep this alignment!
    (catch 'syntax-error
      (lambda ()
        (eval exp (test-module))
        #f)
      (lambda (key proc message location form subform . _)
        (and (eq? proc 'foo)
             (string-match "invalid field" message)
             (equal? subform '(baz 1 2 3 4 5))
             (equal? form '(foo (baz 1 2 3 4 5)))

             ;; Make sure the location is that of the field specifier.
             ;; See <http://bugs.gnu.org/23969>.
             (lset= equal?
                    (pk 'expected-loc
                        `((line . ,(- (assq-ref loc 'line) 1))
                          ,@(alist-delete 'line loc)))
                    (pk 'actual-loc location)))))))

(test-assert "define-record-type* & wrong field specifier, identifier"
  (let ((exp '(begin
                (define-record-type* <foo> foo make-foo
                  foo?
                  (bar foo-bar (default 42))
                  (baz foo-baz))

                (foo
                 baz)))                           ;syntax error
        (loc    (current-source-location)))       ;keep this alignment!
    (catch 'syntax-error
      (lambda ()
<tr><td><span title='2017-04-22 01:25:22 +0200'>2017-04-22</span></td><td><a href='/guix/commit/gnu/packages/ssh.scm?id=befbaebf72d43ac71404065551dc613d6e5a303b'>gnu: Add guile2.2-ssh.</a><span class='msg-avail'>...<span class='msg-tooltip'>* gnu/packages/ssh.scm (guile2.2-ssh): New variable.
</span></span></td><td>Ludovic Courtès</td></tr>
<tr><td><span title='2017-03-27 21:19:38 -0400'>2017-03-27</span></td><td><a href='/guix/commit/gnu/packages/ssh.scm?id=c17383f400d3b942c22ec46b556cad8ca3a2fce1'>Merge branch 'master' into core-updates</a></td><td>Leo Famulari</td></tr>
<tr><td><span title='2017-03-27 20:20:05 +0200'>2017-03-27</span></td><td><a href='/guix/commit/gnu/packages/ssh.scm?id=81d95a121aa2c73c72f26266c2971dc398380d55'>gnu: corkscrew: Install the README file.</a><span class='msg-avail'>...<span class='msg-tooltip'>* gnu/packages/ssh.scm (corkscrew)[arguments]: Add a very basic
‘install-documentation’ phase.
</span></span></td><td>Tobias Geerinckx-Rice</td></tr>
<tr><td><span title='2017-03-27 17:42:52 +0200'>2017-03-27</span></td><td><a href='/guix/commit/gnu/packages/ssh.scm?id=10c95711b4ec69706377bd0f3db86f1cf2bb047a'>gnu: corkscrew: Improve descriptions.</a><span class='msg-avail'>...<span class='msg-tooltip'>* gnu/packages/ssh.scm (corkscrew)[synopsis, description]: Fix typos and
condense.  Remove scary warning (the tunnel is always encrypted through
SSH) and speculation.
</span></span></td><td>Tobias Geerinckx-Rice</td></tr>
<tr><td><span title='2017-03-27 17:42:51 +0200'>2017-03-27</span></td><td><a href='/guix/commit/gnu/packages/ssh.scm?id=040ae44aa1fb42b8e801b2abbebc8ec869eaaa65'>gnu: corkscrew: Download source from a mirror.</a><span class='msg-avail'>...<span class='msg-tooltip'>* gnu/packages/ssh.scm (corkscrew)[source]: Use
‘https://downloads.openwrt.org’.
</span></span></td><td>Tobias Geerinckx-Rice</td></tr>
<tr><td><span title='2017-03-27 17:42:51 +0200'>2017-03-27</span></td><td><a href='/guix/commit/gnu/packages/ssh.scm?id=a800c2175f47887eaba36cc8220f665026d433e5'>gnu: mosh: Update to 1.3.0.</a><span class='msg-avail'>...<span class='msg-tooltip'>* gnu/packages/ssh.scm (mosh): Update to 1.3.0.
</span></span></td><td>Tobias Geerinckx-Rice</td></tr>
<tr><td><span title='2017-03-22 12:57:37 +0200'>2017-03-22</span></td><td><a href='/guix/commit/gnu/packages/ssh.scm?id=378de69c59ee0700c67b10b38592c213821b41f2'>Merge remote-tracking branch 'origin/master' into core-updates</a></td><td>Efraim Flashner</td></tr>
<tr><td><span title='2017-03-22 02:37:31 -0400'>2017-03-22</span></td><td><a href='/guix/commit/gnu/packages/ssh.scm?id=d8be338f16c7da4acfa55f29f58beaf908d3ad60'>gnu: openssh: Update to 7.5p1.</a><span class='msg-avail'>...<span class='msg-tooltip'>* gnu/packages/ssh.scm (openssh): Update to 7.5p1.
</span></span></td><td>Leo Famulari</td></tr>
<tr><td><span title='2017-03-19 23:42:57 +0100'>2017-03-19</span></td><td><a href='/guix/commit/gnu/packages/ssh.scm?id=d5c969ce0c3cb0de0e68551de3db62588fd2c534'>gnu: lsh: Use libc's argp instead of the bundled one.</a><span class='msg-avail'>...<span class='msg-tooltip'>* gnu/packages/ssh.scm (lsh)[arguments] &lt;#:configure-flags&gt;: Add
--with-system-argp and CPPFLAGS=-DHAVE_ARGP_PARSE.
&lt;#:phases&gt;: In 'pre-configure' phase, modify src/Makefile.in.
</span></span></td><td>Ludovic Courtès</td></tr>
<tr><td><span title='2017-03-09 16:35:41 +0100'>2017-03-09</span></td><td><a href='/guix/commit/gnu/packages/ssh.scm?id=e90e0fad1b3ba79d81f02424e143ee6f4f736e8b'>Merge branch 'master' into core-updates</a></td><td>Ludovic Courtès</td></tr>
<tr><td><span title='2017-02-26 22:05:42 +0100'>2017-02-26</span></td><td><a href='/guix/commit/gnu/packages/ssh.scm?id=ac2d5de3dae5a1854f27e1a0b4c09f71001cb91a'>gnu: libssh2: Fix build failure after 1.8.0 upgrade.</a><span class='msg-avail'>...<span class='msg-tooltip'>* gnu/packages/patches/libssh2-fix-build-failure-with-gcrypt.patch: New file.
* gnu/local.mk (dist_patch_DATA): Add it.
* gnu/packages/ssh.scm (libssh2)[source]: Use it.
[arguments]: Add 'autoreconf' phase.
[native-inputs]: Add AUTOCONF and AUTOMAKE.
</span></span></td><td>Marius Bakke</td></tr>
<tr><td><span title='2017-02-26 21:46:45 +0100'>2017-02-26</span></td><td><a href='/guix/commit/gnu/packages/ssh.scm?id=5d79b1bf575139dba9b3f919c7cc7b7f0853a67c'>gnu: libssh: Update to 0.7.4.</a><span class='msg-avail'>...<span class='msg-tooltip'>* gnu/packages/ssh.scm (libssh): Update to 0.7.4.
[home-page]: Use HTTPS.
</span></span></td><td>Marius Bakke</td></tr>
<tr><td><span title='2017-01-23 22:33:10 +0100'>2017-01-23</span></td><td><a href='/guix/commit/gnu/packages/ssh.scm?id=58ea4d407c2e4adbe51b2d7b71dc8bef095677c7'>Merge branch 'master' into core-updates</a></td><td>Ludovic Courtès</td></tr>
<tr><td><span title='2017-01-19 00:11:15 +0100'>2017-01-19</span></td><td><a href='/guix/commit/gnu/packages/ssh.scm?id=89e34644d94860fafc053b759961ba8b55a6c77c'>gnu: Move