;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2023 Bruno Victal <mirai@makinata.eu>
;;;
;;; 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</td></tr></table>
<table class='tabs'><tr><td>
<a href='/guix/about/'>about</a><a href='/guix/'>summary</a><a href='/guix/refs/?id=b9c30fe7d61d1594fa7589cda6945095af1d27ac'>refs</a><a class='active' href='/guix/log/gnu/packages/video.scm'>log</a><a href='/guix/tree/gnu/packages/video.scm?id=b9c30fe7d61d1594fa7589cda6945095af1d27ac'>tree</a><a href='/guix/commit/gnu/packages/video.scm?id=b9c30fe7d61d1594fa7589cda6945095af1d27ac'>commit</a><a href='/guix/diff/gnu/packages/video.scm?id=b9c30fe7d61d1594fa7589cda6945095af1d27ac'>diff</a></td><td class='form'><form class='right' method='get' action='/guix/log/gnu/packages/video.scm'>
<input type='hidden' name='id' value='b9c30fe7d61d1594fa7589cda6945095af1d27ac'/><select name='qt'>
<option value='grep'>log msg</option>
<option value='author'>author</option>
<option value='committer'>committer</option>
<option value='range'>range</option>
</select>
<input class='txt' type='search' size='10' name='q' value=''/>
<input type='submit' value='search'/>
</form>
</td></tr></table>
<div class='path'>path: <a href='/guix/log/?id=b9c30fe7d61d1594fa7589cda6945095af1d27ac'>root</a>/<a href='/guix/log/gnu?id=b9c30fe7d61d1594fa7589cda6945095af1d27ac'>gnu</a>/<a href='/guix/log/gnu/packages?id=b9c30fe7d61d1594fa7589cda6945095af1d27ac'>packages</a>/<a href='/guix/log/gnu/packages/video.scm?id=b9c30fe7d61d1594fa7589cda6945095af1d27ac'>video.scm</a></div><div class='content'><table class='list nowrap'><tr class='nohover'><th class='left'>Age</th><th class='left'>Commit message (<a href='/guix/log/gnu/packages/video.scm?id=b9c30fe7d61d1594fa7589cda6945095af1d27ac&amp;showmsg=1'>Expand</a>)</th><th class='left'>Author</th></tr>
<tr><td><span title='2020-07-25 16:16:10 +0200'>2020-07-25</span></td><td><a href='/guix/commit/gnu/packages/video.scm?id=5060b49336fb915ec8cef0e2e69ff861ac87aa9c'>gnu: libva: Update to 2.8.0.</a><span class='msg-avail'>...<span class='msg-tooltip'>* gnu/packages/video.scm (libva): Update to 2.8.0.
</span></span></td><td>Marius Bakke</td></tr>
<tr><td><span title='2020-07-25 16:16:10 +0200'>2020-07-25</span></td><td><a href='/guix/commit/gnu/packages/video.scm?id=9c71b3411d8d7da0437dbd83805899a747fd223b'>gnu: libvdpau: Update to 1.4.</a><span class='msg-avail'>...<span class='msg-tooltip'>* gnu/packages/video.scm (libvdpau): Update to 1.4.
</span></span></td><td>Marius Bakke</td></tr>
<tr><td><span title='2020-07-24 21:08:35 +0200'>2020-07-24</span></td><td><a href='/guix/commit/gnu/packages/video.scm?id=24128818d0f894b266ae4a8725ad063a0180b67f'>gnu: libaacs: Update to 0.11.0.</a><span class='msg-avail'>...<span class='msg-tooltip'>* gnu/packages/video.scm (libaacs): Update to 0.11.0.
</span></span></td><td>Marius Bakke</td></tr>
<tr><td><span title='2020-07-24 21:08:35 +0200'>2020-07-24</span></td><td><a href='/guix/commit/gnu/packages/video.scm?id=edfd70dbe48c1ee6bbe1276ce482ed31bce46338'>gnu: ffmpeg: Update to 4.3.1.</a><span class='msg-avail'>...<span class='msg-tooltip'>* gnu/packages/video.scm (ffmpeg): Update to 4.3.1.
</span></span></td><td>Marius Bakke</td></tr>
<tr><td><span title='2020-07-24 21:08:35 +0200'>2020-07-24</span></td><td><a href='/guix/commit/gnu/packages/video.scm?id=457a9a134354af0e1773bf60ce6e079d90a7a1f7'>gnu: libmatroska: Update to 1.6.0.</a><span class='msg-avail'>...<span class='msg-tooltip'>* gnu/packages/video.scm (libmatroska): Update to 1.6.0.
</span></span></td><td>Marius Bakke</td></tr>
>approximate-sexp x)
        (current-module)))

(define (port? value)
  (or (string? value) (number? value)))

(define (sanitize-port value)
  (cond ((number? value) value)
        ((string? value) (string->number value))
        (else (raise (formatted-message (G_ "Bad value: ~a") value)))))

(test-group "Basic sanitizer literal tests"
  (define serialize-port serialize-number)

  (define-configuration config-with-sanitizer
    (port
     (port 80)
     "Lorem Ipsum."
     (sanitizer sanitize-port)))

  (test-equal "default value, sanitizer"
    80
    (config-with-sanitizer-port (config-with-sanitizer)))

  (test-equal "string value, sanitized to number"
    56
    (config-with-sanitizer-port (config-with-sanitizer
                                 (port "56"))))

  (define (custom-serialize-port field-name value)
    (number->string value))

  (define-configuration config-serializer
    (port
     (port 80)
     "Lorem Ipsum."
     (serializer custom-serialize-port)))

  (test-equal "default value, serializer literal"
    "80"
    (eval-gexp
     (serialize-configuration (config-serializer)
                              config-serializer-fields))))

(test-group "empty-serializer as literal/procedure tests"
  (define-configuration config-with-literal
    (port
     (port 80)
     "Lorem Ipsum."
     empty-serializer))

  (define-configuration config-with-proc
    (port
     (port 80)
     "Lorem Ipsum."
     (serializer empty-serializer)))

  (test-equal "empty-serializer as literal"
    ""
    (eval-gexp
     (serialize-configuration (config-with-literal)
                              config-with-literal-fields)))

  (test-equal "empty-serializer as procedure"
    ""
    (eval-gexp
     (serialize-configuration (config-with-proc)
                              config-with-proc-fields))))

(test-group "permutation tests"
  (define-configuration config-san+empty-ser
    (port
     (port 80)
     "Lorem Ipsum."
     (sanitizer sanitize-port)
     empty-serializer))

  (define-configuration config-san+ser
    (port
     (port 80)
     "Lorem Ipsum."
     (sanitizer sanitize-port)
     (serializer (lambda _ "foo"))))

  (test-equal "default value, sanitizer, permutation"
    80
    (config-san+empty-ser-port (config-san+empty-ser)))

  (test-equal "default value, serializer, permutation"
    "foo"
    (eval-gexp
     (serialize-configuration (config-san+ser) config-san+ser-fields)))

  (test-equal "string value sanitized to number, permutation"
    56
    (config-san+ser-port (config-san+ser
                          (port "56"))))

  ;; Ordering tests.
  (define-configuration config-ser+san
    (port
     (port 80)
     "Lorem Ipsum."
     (sanitizer sanitize-port)
     (serializer (lambda _ "foo"))))

  (define-configuration config-empty-ser+san
    (port
     (port 80)
     "Lorem Ipsum."
     empty-serializer
     (sanitizer sanitize-port)))

  (test-equal "default value, sanitizer, permutation 2"
    56
    (config-empty-ser+san-port (config-empty-ser+san
                                (port "56"))))

  (test-equal "default value, serializer, permutation 2"
    "foo"
    (eval-gexp
     (serialize-configuration (config-ser+san) config-ser+san-fields))))

(test-group "duplicated/conflicting entries"
  (test-error
   "duplicate sanitizer" #t
   (macroexpand '(define-configuration dupe-san
                   (foo
                    (list '())
                    "Lorem Ipsum."
                    (sanitizer (lambda () #t))
                    (sanitizer (lambda () #t))))))

  (test-error
   "duplicate serializer" #t
   (macroexpand '(define-configuration dupe-ser
                   (foo
                    (list '())
                    "Lorem Ipsum."
                    (serializer (lambda _ ""))
                    (serializer (lambda _ ""))))))

  (test-error
   "conflicting use of serializer + empty-serializer" #t
   (macroexpand '(define-configuration ser+empty-ser
                   (foo
                    (list '())
                    "Lorem Ipsum."
                    (serializer (lambda _ "lorem"))
                    empty-serializer)))))

(test-group "Mix of deprecated and new syntax"
  (test-error
   "Mix of bare serializer and new syntax" #t
   (macroexpand '(define-configuration mixed
                   (foo
                    (list '())
                    "Lorem Ipsum."
                    (sanitizer (lambda () #t))
                    (lambda _ "lorem")))))

  (test-error
   "Mix of bare serializer and new syntax, permutation)" #t
   (macroexpand '(define-configuration mixed
                   (foo
                    (list '())
                    "Lorem Ipsum."
                    (lambda _ "lorem")
                    (sanitizer (lambda () #t)))))))


;;;
;;; define-maybe macro.
;;;
(define-maybe number)

(define-configuration config-with-maybe-number
  (port  (maybe-number 80) "")
  (count maybe-number ""))

(test-equal "maybe value serialization"
  "port=80"
  (serialize-maybe-number "port" 80))

(define (config-with-maybe-number->string x)
  (eval (gexp->approximate-sexp
         (serialize-configuration x config-with-maybe-number-fields))
        (current-module)))

(test-equal "maybe value serialization of the instance"
  "port=42count=43"
  (config-with-maybe-number->string
   (config-with-maybe-number
    (port 42)
    (count 43))))

(test-equal "maybe value serialization of the instance, unspecified"
  "port=42"
  (config-with-maybe-number->string
   (config-with-maybe-number
    (port 42))))

(define (serialize-symbol name value)
  (format #f "~a=~a~%" name value))

(define-maybe symbol)

(define-configuration config-with-maybe-symbol
  (protocol maybe-symbol ""))

(test-equal "symbol maybe value serialization, unspecified"
  ""
  (eval-gexp
   (serialize-configuration (config-with-maybe-symbol)
                            config-with-maybe-symbol-fields)))

(define-maybe/no-serialization string)

(define-configuration config-with-maybe-string/no-serialization
  (name (maybe-string) "The name of the item.")
  (no-serialization))

(test-assert "maybe value without serialization no procedure bound"
  (not (defined? 'serialize-maybe-string)))

(test-assert "maybe type, no default"
  (eq? %unset-value
       (config-with-maybe-string/no-serialization-name
        (config-with-maybe-string/no-serialization))))

(test-assert "maybe type, with default"
  (equal?
   "foo"
   (config-with-maybe-string/no-serialization-name
    (config-with-maybe-string/no-serialization
     (name "foo")))))