;; getopt-long.scm --- tests for getopt-long    -*- coding: utf-8 -*-
;;
;; Copyright (C) 2019 Alex Sassmannshausen <alex@pompo.co>
;;
;; Author: Alex Sassmannshausen <alex@pompo.co>
;; Created: 24 January 2019
;;
;; This file is part of Config.
;;
;; Config 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.
;;
;; Config 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 config; if not, contact:
;;
;; Free Software Foundation           Voice:  +1-617-542-5942
;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
;; Boston, MA  02111-1307,  USA       gnu@gnu.org

;;; Commentary:
;;
;; Unit tests for getopt-long.scm.
;;
;; Source-file: config/getopt-long.scm
;;
;;; Code:

(define-module (tests getopt-long)
  #:use-module (config)
  #:use-module (config api)
  #:use-module (config getopt-long)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-64))


;;;; Tests

(test-begin "config")

;; Test data
(define cdx (codex #f (metadata "" "" #f '() "" #f #t #t #t #f)
                   (valus
                    (list
                     (switch (name 'opt1)
                             (default "test")
                             (test string?))
                     (switch (name 'opt2)
                             (test number?)
                             (default 10))
                     (switch (name 'opt3)
                             (default 666)
                             (test (λ (v c)
                                     (and (codex? c)
                                          (not (empty? (option-ref c 'opt2)))
                                          (number? v)))))
                     (switch (name 'opt4)
                             (default (empty))
                             (test (const #t))))
                    '())
                   (reagents '((script)) #f #f #f)))

;;;;; Test switch/setting predicate handling

(define test-kwd/arg (@@ (config getopt-long) test-kwd/arg))

(test-error "Switch predicate fails"
  'getopt-long
  (test-kwd/arg (switch (name 'test) (test number?) (default "test")) 'cdx))

(test-assert "Switch predicate passes"
  (test-kwd/arg (switch (name 'test) (test number?) (default 5)) 'cdx))

(test-assert "Switch with arity 2 predicate"
  (test-kwd/arg (switch (name 'test) (test (λ (v c) (number? v))) (default 5))
                'cdx))

(test-assert "Switch with companion switch"
  (test-kwd/arg (third (valus-keywords (codex-valus cdx))) cdx))

(test-error "Switch with empty companion switch"
  'getopt-long
  (test-kwd/arg (switch (name 'test)
                        (test (λ (v c)
                                (and (codex? c)
                                     (not (empty? (option-ref c 'opt4)))
                                     (number? v))))
                        (default 75))
                cdx))

;;;;; Test codex testing phase

(test-assert "Test codex"
  (codex? ((@@ (config getopt-long) test-codex) cdx)))

;;;;; Testing our custom option-ref, overriding core getopt-long

(define opts '((opt1 . 1) (opt2 . 2) (opt1 . 4) (opt3 . 3) (opt1 . 7)))

(test-assert "option-ref override default"
  (equal? ((@@ (config getopt-long) option-ref) opts 'missing 'default)
          'default))

(test-assert "option-ref override simple"
  (equal? ((@@ (config getopt-long) option-ref) opts 'opt2 'default)
          2))

(test-assert "option-ref override multi"
  (equal? '(1 4 7)
          ((@@ (config getopt-long) option-ref) opts 'opt1 'default)))

;; Testing fetching values after parsing a full commandline

(define cmdline '("_" "--opt1" "1" "--opt2" "2" "--opt1" "4" "--opt3" "3"
                  "--opt1" "7" "--opt2" "5"))

(define cdx1 (codex #f (metadata "" "" #f '() "" #f #t #t #t #f)
                   (valus (list
                           (switch (name 'opt1)
                                   (merge-strategy (lambda (elem previous)
                                                     (cons elem previous)))
                                   (handler string-join)
                                   (test string?))
                           (switch (name 'opt2)
                                   (test number?)
                                   (handler string->number))
                           (switch (name 'opt3)))
                          '())
                   (reagents '((script)) #f #f #f)))

(test-equal "option-ref simple"
  (option-ref (read-commandline cmdline '() cdx1) 'opt3 'default)
  "3")

(test-equal "option-ref merge"
  (option-ref (read-commandline cmdline '() cdx1) 'opt1 'default)
  "1 4 7")

(test-eqv "option-ref override"
  (option-ref (read-commandline cmdline '() cdx1) 'opt2 'default)
  2)

;; Bug: a switch's or setting's handler is invoked twice on the original
;; value. This can be measured with a procedure that contains state and which
;; sets n to that state.
(test-assert "keyword-handler-once"
  (= 1
     (option-ref
      (read-commandline
       '("script" "--test" "5") '()
       (codex #f (metadata "" "" #f '() "" #f #t #t #t #f)
              (valus `(,(switch (name 'test)
                                (test number?)
                                ;; Handler just tests how many times it is
                                ;; invoked and returns its count.
                                (handler (let ((x 0))
                                           (lambda (n)
                                             (set! x (1+ x))
                                             x)))))
                     '())
              (reagents '((script)) #f #f #f)))
      'test)))

(define parse-arguments (@@ (config getopt-long) parse-arguments))

(define arguments
  (list (argument (name 'arg1) (handler identity) (test string?) (default ""))))

(define arg-values
  (list "test"))

(test-assert "Simple arguments parsing"
  (equal? "test"
          (argument-default
           (first (parse-arguments arguments arg-values)))))

(test-end "config")
