;; config.scm --- tests for config    -*- coding: utf-8 -*-
;;
;; Copyright (C) 2015 Alex Sassmannshausen <alex@pompo.co>
;;
;; Author: Alex Sassmannshausen <alex@pompo.co>
;; Created: 23 November 2016
;;
;; 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 config.scm.
;;
;; Source-file: config.scm
;;
;;; Code:

(define-module (tests config)
  #:use-module (config)
  #:use-module (config api)
  #:use-module (config parser sexp)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-64)
  #:use-module (tests quickcheck)
  #:use-module (tests quickcheck-defs))


;;;; Tests

(test-begin "config")

(quickcheck-assert "Configurations?"
                   configuration? ($configuration))

(quickcheck-assert
 "Check getopt-config-auto parsing works."
 (λ (c)
   (identity (getopt-config-auto `(,(symbol->string (configuration-name c)))
                                 c)))
 ($configuration 2))

(quickcheck-assert
 "Getopt-Config?"
 (lambda (config)
   (codex? (getopt-config `(,(symbol->string
                              (configuration-name config)))
                          config)))
 ($configuration))

;;;; Test error handlers

(define (error-handler type)
  (lambda (r k v c)
    (or (and (symbol? r)
             (match k ((or switch? setting? secret? argument?) #t) (_ #f))
             (codex? c))
        (throw (symbol-append type '-incorrect-arguments)
               r k v c))
    (match r
      ('mandatory-missing (throw (symbol-append type '-mandatory)))
      ('predicate-fails (throw (symbol-append type '-predicate)))
      ('expect-value (throw (symbol-append type '-value)))
      ('expect-boolean (throw (symbol-append type '-bool))))))

(define %config
  (configuration
   (name '_)
   (keywords
    (list
     (switch (name 'int-switch) (optional? #f) (test integer?)
             (handler string->number) (error (error-handler 'switch)))
     (switch (name 'bool-switch) (default #f)
             (test boolean?) (error (error-handler 'switch)))
     (setting (name 'int-setting) (default 5) (optional? #f) (test integer?)
              (handler string->number) (error (error-handler 'setting)))
     (setting (name 'bool-setting) (default #f)
              (test boolean?) (error (error-handler 'setting)))))))

;; FIXME: test-error is broken: it doesn't spot wrong error codes, so we shim
;; it.
(define (shim key args)
  (catch key
    (λ _ (getopt-config-auto args %config))
    (λ _ #t)))

(test-assert "switch-mandatory"
  (shim 'switch-mandatory '("_")))
(test-assert "switch-predicate"
  (shim 'switch-predicate '("_" "--int-switch=test")))
(test-assert "setting-predicate"
  (shim 'setting-predicate '("_" "--int-switch=5" "--int-setting=test")))
(test-assert "switch-value"
  (shim 'switch-value '("_" "--int-switch")))
(test-assert "setting-value"
  (shim 'setting-value '("_" "--int-switch=5" "--int-setting")))
(test-assert "switch-bool"
  (shim 'switch-bool '("_" "--int-switch=5" "--bool-switch=test")))
(test-assert "setting-bool"
  (shim 'setting-bool '("_" "--int-switch=5" "--bool-setting=test")))

(set! %config
  (configuration
   (name '_)
   (arguments
    (list
     (argument (name 'int-arg) (test integer?) (handler string->number)
               (error (error-handler 'argument)))))))

;; This works because we've used SET! to change %config: non-functional
;; manipulation of `shim'!!  
(test-assert "argument-mandatory"
  (shim 'argument-mandatory '("_")))
(test-assert "argument-predicate"
  (shim 'argument-predicate '("_" "test")))

(set! %config
  (configuration
   (name '_)
   (arguments
    (list
     (argument (name 'int-arg) (test integer?) (handler string->number))))))

(test-assert "default-handler"
  (with-error-to-string
    (λ _
      (catch 'quit
        (λ _ (getopt-config-auto '("_") %config))
        (λ _ #t)))))

;; Issue 16: Confused mandatory / optional semantics

(set! %config
  (configuration
   (name '_)
   (keywords
    (list
     (switch
      (name 'run)
      (character #\r)
      (handler identity)
      (test (lambda (value)
              (and (string? value)
                   (file-exists? value))))
      (synopsis "Run workflow from FILE")
      (error (λ (r k v c) (throw 'no-value v)))
      (example "FILE"))))))

(test-assert "mandatory non-optional keyword #f"
  (catch 'no-value
    (λ _ (getopt-config-auto '("_" "--run") %config))
    (λ (k v) (not v))))

(test-assert "mandatory non-optional keyword OK"
  (codex? (getopt-config-auto '("_" "--run=/tmp/") %config)))

;;;; Config Files

(quickcheck-assert
 "No config files created?"
 (lambda (config)
   (and (codex? (getopt-config `(,(symbol->string
                                   (configuration-name config)))
                               config))
        (not (file-exists?
              (path-given (configuration-directory config))))))
 ($configuration #:keywords (list $secret $switch) #:parser sexp-parser))

(quickcheck-assert
 "Config files created?"
 (lambda (config)
   (and (codex? (getopt-config `(,(symbol->string
                                   (configuration-name config)))
                               config))
        (cond ((null? (configuration-keywords config)) #t)
              ((file-exists? (path-given (configuration-directory config))) #t)
              (else #f))))
 ($configuration #:keywords (list $setting) #:parser sexp-parser))

(quickcheck-assert
 "Multi config files created?"
 (lambda (config)
   (and (codex? (getopt-config `(,(symbol->string
                                   (configuration-name config)))
                               config))
        (or (null? (configuration-keywords config))
            (every file-exists?
                   (map path-given (configuration-directory config))))))
 ($configuration #:keywords (list $setting) #:parser sexp-parser
                 #:directories
                 (($short-list
                   (lambda _
                     (path (given (string-append (tmpnam)
                                                 file-name-separator-string))
                           (eager? #t)))))))

(system "rm -r /tmp/file*")

(test-end "config")
