;;;; srfi-29-test.scm

;To use w/ TLS:
;(cd .../srfi-29/trunk/tests; \
;sudo csi -n -R posix -e '(setenv "SRFI29_TLS" "1")' -s run.scm)

(import (scheme))

;(import (test-utils gloss) (only (chicken format) format))
(import test)

(import (srfi 29))

(import (chicken base))
(import (chicken sort))
(import (only (srfi 1) assoc every))
(import (only (chicken pathname) make-pathname) (only (chicken file) delete-directory))

(define (allow-sysops?)
  (import (chicken platform))
  (import (chicken process-context posix))
  (or (eq? 'windows (software-type))
      (zero? (current-effective-user-id))) )

(define (boolean x) (and x #t))

(define pathname? string?)

(define (alist=? a b #!optional (=? equal?))
  (every (lambda (cell-a) (=? cell-a (assoc (car cell-a) b =?)))
         a) )

(define (sort-by-length ls)
  (sort ls (lambda (a b) (< (length a) (length b)))) )

;;

(test-begin "SRFI 29")

(test-group "Basics"

  (let ((bal1 '((foo1 . 1) ("bar1" . 2) (baz1 . 3)))
        (bal2 '((foo2 . 4) ("bar2" . 5) (baz2 . 6)))
        (bal3 '((foo3 . 7) ("bar3" . 8) (baz3 . 9))) )

    (test-group "Locale"

      (test-assert "L1" (current-language))
      (test-assert "L2" (current-country))
      (test-assert "L3" (current-locale-details))

      (test-assert "L4" (symbol? (current-language)))
      (test-assert "L5" (symbol? (current-country)))
      (test-assert "L6" (list? (current-locale-details)))

      (test-assert "L7" (current-language 'foo))
      (test-assert "L8" (current-country 'bar))
      (test-assert "L9" (current-locale-details '(baz)))

      (test "L10" 'foo (current-language))
      (test "L11" 'bar (current-country))
      (test "L12" '(baz) (current-locale-details))

      (reset-locale-parameters)
    )

    (test-group "Bundles"

      (test-assert "" (declare-bundle! '(srfi-29-test) bal1))
      (test-assert "" (declare-bundle! '(srfi-29-test foo) bal2))
      (test-assert "" (declare-bundle! '(srfi-29-test foo bar) bal3))

      (test "declared-bundle-specifiers"
            '((srfi-29-test) (srfi-29-test foo) (srfi-29-test foo bar))
            (sort-by-length (declared-bundle-specifiers)))
      (test-assert "declared-bundle-templates"
        (alist=? bal1 (declared-bundle-templates '(srfi-29-test))))
      (test-assert "declared-bundle-templates foo"
        (alist=? bal2 (declared-bundle-templates '(srfi-29-test foo))))
      (test-assert "declared-bundle-templates foo bar"
        (alist=? bal3 (declared-bundle-templates '(srfi-29-test foo bar))))

      (test "declared-bundle-templates foo1" 1 (localized-template 'srfi-29-test 'foo1))
      (test "declared-bundle-templates bar1" 2 (localized-template 'srfi-29-test "bar1"))
      (test "declared-bundle-templates baz1" 3 (localized-template 'srfi-29-test 'baz1))

      (test-assert "undeclare-bundle!" (undeclare-bundle! '(srfi-29-test)))
      (test-assert "undeclare-bundle! foo" (undeclare-bundle! '(srfi-29-test foo)))
      (test-assert "undeclare-bundle! foo bar" (undeclare-bundle! '(srfi-29-test foo bar)))

      (test-assert "undeclared foo1" (not (localized-template 'srfi-29-test 'foo1)))
      (test-assert "undeclared bar1" (not (localized-template 'srfi-29-test "bar1")))
      (test-assert "undeclared baz1" (not (localized-template 'srfi-29-test 'baz1)))
    )

    (test-group "Bundles (Using Alternate Directory)"

      (define altdir ".")

      ;NOTE decl top down or bottom up or ... (independent!) but use top down
      (test-assert "decls t" (declare-bundle! '(srfi-29-test) bal1))
      (test-assert "decls t f" (declare-bundle! '(srfi-29-test foo) bal2))
      (test-assert "decls t f b" (declare-bundle! '(srfi-29-test foo bar) bal3))

      ;NOTE store top down to isolate failure better
      (test-assert "stores t" (store-bundle! '(srfi-29-test) altdir))
      (test-assert "stores t f" (store-bundle! '(srfi-29-test foo) altdir))
      (test-assert "stores t f b" (store-bundle! '(srfi-29-test foo bar) altdir))

      ;NOTE not documented as returning pathname on success
      (test-assert "exists t" (pathname? (existing-bundle? '(srfi-29-test) altdir)))
      (test-assert "exists t f" (pathname? (existing-bundle? '(srfi-29-test foo) altdir)))
      (test-assert "exists t f b" (pathname? (existing-bundle? '(srfi-29-test foo bar) altdir)))

      ;NOTE load top down to isolate failure better
      (test-assert "loads t" (load-bundle! '(srfi-29-test) altdir))
      (test-assert "loads t f" (load-bundle! '(srfi-29-test foo) altdir))
      (test-assert "loads t f b" (load-bundle! '(srfi-29-test foo bar) altdir))

      ;NOTE remove bottom up to isolate failure better
      (test-assert "removes t f b" (remove-bundle! '(srfi-29-test foo bar) altdir))
      (test-assert "removes t f" (remove-bundle! '(srfi-29-test foo) altdir))
      (test-assert "removes t" (remove-bundle! '(srfi-29-test) altdir))

      (test-assert "!loads t f b" (not (load-bundle! '(srfi-29-test foo bar) altdir)))
      (test-assert "!loads t f" (not (load-bundle! '(srfi-29-test foo) altdir)))
      (test-assert "!loads t" (not (load-bundle! '(srfi-29-test) altdir)))

      ;Clean Up - remember (foo) & (foo bar) are independent!
      (test-assert "RmDir t f b" (remove-bundle-directory! '(srfi-29-test foo bar) altdir))
      (test-assert "RmDir t f" (remove-bundle-directory! '(srfi-29-test foo) altdir))

      #| ;NOTE doesn't signal remove of non-existent & doesn't document it does
      ;so don't bother to test
      (test-assert "removes t" (remove-bundle! '(srfi-29-test) altdir))
      (test-assert "removes t f" (remove-bundle! '(srfi-29-test foo) altdir))
      (test-assert "removes t f b" (remove-bundle! '(srfi-29-test foo bar) altdir))
      |#
    )

    (test-group "Test Bundle Installed"
      (load-best-available-bundle! (most-specific-bundle-specifier 'srfi-29))
      (test "SRFI 29" (localized-template/default 'srfi-29 'srfi-29))
    )

    (when (allow-sysops?)
      (test-group "Bundles System Directory"

        ;; Build

        (test-assert "B16" (declare-bundle! '(srfi-29-test) bal1))
        (test-assert "B17" (declare-bundle! '(srfi-29-test foo) bal2))
        (test-assert "B18" (declare-bundle! '(srfi-29-test foo bar) bal3))

        (test-assert "B19" (store-bundle! '(srfi-29-test)))
        (test-assert "B20" (store-bundle! '(srfi-29-test foo)))
        (test-assert "B21" (store-bundle! '(srfi-29-test foo bar)))

        (test-assert "B24" (undeclare-bundle! '(srfi-29-test foo bar)))
        (test-assert "B23" (undeclare-bundle! '(srfi-29-test foo)))
        (test-assert "B22" (undeclare-bundle! '(srfi-29-test)))

        ;; Test

        (test-assert "B25.1" (not (localized-template 'srfi-29-test 'foo1)))
        (test-assert "B26.1" (not (localized-template 'srfi-29-test "bar1")))
        (test-assert "B27.1" (not (localized-template 'srfi-29-test 'baz1)))

        (test-assert "B22.1" (load-bundle! '(srfi-29-test)))
        (test-assert "B23.1" (load-bundle! '(srfi-29-test foo)))
        (test-assert "B24.1" (load-bundle! '(srfi-29-test foo bar)))

        (test "B25" 1 (localized-template 'srfi-29-test 'foo1))
        (test "B26" 2 (localized-template 'srfi-29-test "bar1"))
        (test "B27" 3 (localized-template 'srfi-29-test 'baz1))

        (test-assert "localized-templates"
          (alist=? bal1 (localized-templates 'srfi-29-test)))

        (current-language 'foo)

        (test "B28" 4 (localized-template 'srfi-29-test 'foo2))
        (test "B29" 5 (localized-template 'srfi-29-test "bar2"))
        (test "B30" 6 (localized-template 'srfi-29-test 'baz2))

        (test-assert "localized-templates language foo"
          (alist=? bal2 (localized-templates 'srfi-29-test)))

        (current-country 'bar)

        (test "B31" 7 (localized-template 'srfi-29-test 'foo3))
        (test "B32" 8 (localized-template 'srfi-29-test "bar3"))
        (test "B33" 9 (localized-template 'srfi-29-test 'baz3))

        (test-assert "localized-templates language foo, country bar"
          (alist=? bal3 (localized-templates 'srfi-29-test)))

        (test-assert "B37.1" (localized-template-set! 'srfi-29-test 'baz3 'foobar))
        (test "B37.2" 'foobar (localized-template 'srfi-29-test 'baz3))
        (test-assert "B37.3" (not (localized-template-set! 'foobar 'baz3 #t)))
        (test-assert "B37.4" (localized-template-set! 'srfi-29-test 'barf 16))
        (test "B37.5" 16 (localized-template 'srfi-29-test 'barf))

        (test-assert "B36" (remove-bundle! '(srfi-29-test foo bar)))
        (test-assert "B35" (remove-bundle! '(srfi-29-test foo)))
        (test-assert "B34" (remove-bundle! '(srfi-29-test)))

        ; independent!
        (test-assert "SysDir RmDir" (remove-bundle-directory! '(srfi-29-test foo bar)))
        (test-assert "SysDir RmDir" (remove-bundle-directory! '(srfi-29-test foo)))

        (reset-locale-parameters)
      )
    )
  )

  #;(test-assert "B22.2" (load-best-available-bundle! (most-specific-bundle-specifier 'srfi-19)))
  #;(test "B22.3 English" "August" (localized-template 'srfi-19 'august))
  #;(test "B22.4 English" "December" (localized-template 'srfi-19 'december))
)

(import srfi-29-logic)

(import (chicken process))

(test-group "Logic (extension)"

  ;for compile & load so extension assumed
  (define test-logic-filename "test-logic")

  ;compile logic
  (system (string-append "csc -s " test-logic-filename))

  ;declare logic pkg
  (declare-bundle! '(srfi-29-test)
    `((library . ,test-logic-filename)              ;pathname of compiled logic (for load)
      (srfi-29-test . (srfi-29-test . test-star))   ;module ident
      (srfi-29-test-0 . srfi-29-test-0)             ;0 arg proc
      (srfi-29-test-1 . srfi-29-test-1)             ;1 arg proc
      (srfi-29-test-N . srfi-29-test-N)))           ;N arg proc

  (define item@ (make-required-localized-template 'srfi-29-test))
  (test-assert (procedure? item@))

  ;load logic
  (load-localized-compiled-code
    (item@ 'library)
    'srfi-29-test
    '(srfi-29-test-0 srfi-29-test-1 srfi-29-test-N srfi-29-test))

  (define srfi-29-test (item@ 'srfi-29-test))
  (define srfi-29-test-0 (item@ 'srfi-29-test-0))
  (define srfi-29-test-1 (item@ 'srfi-29-test-1))
  (define srfi-29-test-N (item@ 'srfi-29-test-N))

  ;test logic
  (test-assert (procedure? srfi-29-test))
  (test-assert (procedure? srfi-29-test-0))
  (test-assert (procedure? srfi-29-test-1))
  (test-assert (procedure? srfi-29-test-N))

  (test 0 (srfi-29-test-0))
  (test -56 (srfi-29-test-1 56))
  (test '(1 2 3 4 5 6) (srfi-29-test-N 1 2 3 4 5 6))
  (test '(* hello) (srfi-29-test 'hello))
)

(test-end "SRFI 29")

(test-exit)