(import (scheme base) (scheme write) (scheme process-context) (srfi 1)
        (chibi ast) (chibi config) (chibi filesystem) (chibi match)
        (chibi pathname) (chibi process) (chibi regexp) (chibi string)
        (chibi io) (chibi tar) (chibi test)
        (chibi snow package))

(test-begin "snow")

;; setup a temp root to install packages
(define install-prefix (make-path (current-directory) "tests/snow/tmp-root"))
(define install-libdir (make-path install-prefix "/share/snow/chibi"))
(if (file-exists? install-prefix)
    (delete-file-hierarchy install-prefix))
(create-directory install-prefix)

;; setup chicken install directory with minimum required modules
(define chicken-lib-dir "/usr/local/lib/chicken/8")
(define chicken-install-dir (make-path install-prefix "lib/chicken/8"))
(create-directory* chicken-install-dir)
(if (file-exists? chicken-lib-dir)
    (let ((rx-required
           '(: (or "chicken" "csi" "data-structures" "extras" "files"
                   "foreign" "irregex" "lolevel" "make" "matchable"
                   "modules" "numbers" "ports" "posix" "r7rs" "scheme"
                   "srfi" "tcp" "types" "utils")
               (or "." "-")
               (* any))))
      (for-each
      (lambda (file)
        (if (regexp-matches? rx-required file)
            (system 'cp
                    (make-path chicken-lib-dir file)
                    chicken-install-dir)))
      (directory-files chicken-lib-dir))))
(setenv "CHICKEN_REPOSITORY" chicken-install-dir)

;; ignore any personal config settings
(setenv "SNOW_CHIBI_CONFIG" "no-such-file")

;; run snow-chibi command as a separate process with test defaults
(define chibi-path "./chibi-scheme")
(define (snow-command . args)
  ;;(write `(snow ,@args)) (newline)
  `("./tools/snow-chibi"
    --verbose
    --always-no
    --implementations "chibi"
    --chibi-path ,(string-append chibi-path " -A" install-libdir)
    --install-prefix ,install-prefix
    --local-user-repository "tests/snow/repo-cache"
    ,@args))

(define-syntax snow
  (syntax-rules ()
    ((snow args ...)
     (match (process->output+error+status (apply snow-command `(args ...)))
       ((output error (? zero?))
        ;; (display output)
        ;; (display error)
        )
       ((output error status)
        (display "Snow failed: ")
        (display status)
        (newline)
        (display output)
        (display error)
        (newline))
       (other
        (display "Snow error:\n")
        (display other)
        (newline))))))

(define-syntax snow->string
  (syntax-rules ()
    ((snow->string args ...)
     (process->string (apply snow-command `(args ...))))))

(define-syntax snow->sexp
  (syntax-rules ()
    ((snow->sexp args ...)
     (process->sexp (apply snow-command `(--sexp args ...))))))

(define-syntax snow-status
  (syntax-rules ()
    ((snow-status args ...)
     (snow->sexp args ... status))))

(define (installed-status status lib-name . o)
  (let* ((impl (if (pair? o) (car o) 'chibi))
         (impl-status (assq impl status)))
    (and impl-status
         (assoc lib-name (cdr impl-status)))))

(define (installed-version status lib-name . o)
  (cond ((apply installed-status status lib-name o) => cadr)
        (else #f)))

(define (snowball-test->sexp-list pkg file)
  (let ((path (make-path (package-file-top-directory file)
                         (assoc-get pkg 'test))))
    (call-with-input-string
        (utf8->string (tar-extract-file (package-file-unzipped file) path))
      port->sexp-list)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; basics

(define lucas-sld-path
  (make-path install-libdir "edouard/lucas.sld"))

(test-group "basics"

;; package
(snow package --output-dir tests/snow --authors "Édouard Lucas"
      --description "Lucas recurrence relation"
      tests/snow/repo0/edouard/lucas.sld)
(test-assert (file-exists? "tests/snow/edouard-lucas.tgz"))

;; install
(snow install tests/snow/edouard-lucas.tgz)
(test-assert (file-exists? lucas-sld-path))
(delete-file "tests/snow/edouard-lucas.tgz")

;; status
(test-assert (installed-status (snow-status) '(edouard lucas)))

;; remove
(snow remove edouard.lucas)
(test-not (file-exists? lucas-sld-path))
(test-not (installed-version (snow-status) '(edouard lucas)))

)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; install/upgrade via local repos

(define repo1 '(--repository-uri tests/snow/repo1/repo.scm))
(define repo2 '(--repository-uri tests/snow/repo2/repo.scm))
(define repo3 '(--repository-uri tests/snow/repo3/repo.scm))

(test-group "local repo"

(snow package --output-dir tests/snow/repo1/
      --version 1.0 --authors "Leonardo Fibonacci"
      --description "Fibonacci recurrence relation"
      --test tests/snow/repo1/leonardo/fibonacci-test.scm
      tests/snow/repo1/leonardo/fibonacci.sld)
(snow index ,(cadr repo1) tests/snow/repo1/leonardo-fibonacci-1.0.tgz)
(snow ,@repo1 install --show-tests leonardo.fibonacci)
(test "1.0" (installed-version (snow-status) '(leonardo fibonacci)))

(snow package --output-dir tests/snow/repo2/
      --version 1.1 --authors "Leonardo Fibonacci"
      --description "Fibonacci recurrence relation"
      --test tests/snow/repo2/leonardo/fibonacci-test.scm
      tests/snow/repo2/leonardo/fibonacci.sld)
(snow index ,(cadr repo2))
(snow ,@repo2 upgrade leonardo.fibonacci)
(test "1.1" (installed-version (snow-status) '(leonardo fibonacci)))

(setenv "PINGALA_GANAS_PATH"
        "pingala:tests/snow/tmp-root/share/snow/chibi/pingala")
(snow package --output-dir tests/snow/repo3/
      --version 1.0 --authors "Pingala"
      --description "Factorial"
      tests/snow/repo3/pingala/factorial.scm)
(snow package --output-dir tests/snow/repo3/
      --version 1.0 --authors "Pingala"
      --description "Binomial Coefficients"
      --test tests/snow/repo3/pingala/binomial-test.scm
      tests/snow/repo3/pingala/binomial.scm)
(snow package --output-dir tests/snow/repo3/
      --version 1.0 --authors "Pingala"
      --description "Pingala's test framework"
      tests/snow/repo3/pingala/test-map.scm)
(snow package --output-dir tests/snow/repo3/
      --version 1.0 --authors "Pingala"
      --description "Library for Sanskrit poetry"
      --test-library "tests/snow/repo3/pingala/prosody-test.sld"
      --data-files tests/snow/repo3/pingala/ganas.txt
      tests/snow/repo3/pingala/prosody.sld)
(snow package --output-dir tests/snow/repo3/
      --version 1.0 --authors "Pingala" --name "(pingala triangle)"
      --description "Program to print a Sierpinski Triangle"
      --programs tests/snow/repo3/pingala/triangle.scm)
(snow package --output-dir tests/snow/repo3/
      --version 1.0 --authors "Robert Recorde"
      --description "Equality implementation"
      --test-library "tests/snow/repo3/recorde/equal-test.sld"
      tests/snow/repo3/recorde/equal.sld)
(snow package --output-dir tests/snow/repo3/
      --version "2.7.1" --authors "Leonhard Euler"
      --description "Euler's Totient function"
      --test "tests/snow/repo3/totient-test.scm"
      tests/snow/repo3/totient.scm)
(snow package --output-dir tests/snow/repo3/
      --version 1.0 --authors "Pythagoras"
      --description "Pythagoran Theorem"
      --test "tests/snow/repo3/pythagoras/hypotenuse-test.sch"
      tests/snow/repo3/pythagoras/hypotenuse.sch)
(snow package --output-dir tests/snow/repo3/
      --version 1.0 --authors "Seki Takakazu"
      --description "Bernoulli Numbers"
      --test "tests/snow/repo3/takakazu/bernoulli-test.scm"
      tests/snow/repo3/takakazu/bernoulli.sld)
(snow index ,(cadr repo3))
(snow ,@repo3 install pingala.binomial)
(snow ,@repo3 install euler.totient)
(snow ,@repo3 install takakazu.bernoulli)
(let ((status (snow-status)))
  (test-assert (installed-version status '(pingala binomial)))
  (test-assert (installed-version status '(pingala factorial)))
  (test "2.7.1" (installed-version status '(euler totient)))
  (test-assert (installed-version status '(takakazu bernoulli))))

;; programs
(snow ,@repo3 install pingala.triangle)
(test-assert (file-exists? "tests/snow/tmp-root/bin/triangle"))
(test "1
1 1
1 2 1
1 3 3 1
1 4 6 4 1
1 5 10 10 5 1
"
    (process->string "tests/snow/tmp-root/bin/triangle"))
(test "1
1 1
1 2 1
1 3 3 1
"
    (process->string '("tests/snow/tmp-root/bin/triangle" "3")))

(snow ,@repo3 remove pingala.triangle)
(test-not (file-exists? "tests/snow/tmp-root/bin/triangle"))

;; data files
(snow ,@repo3 install pingala.prosody)
(test-assert (installed-version (snow-status) '(pingala prosody)))
(test-assert
    (file-exists? "tests/snow/tmp-root/share/snow/chibi/pingala/ganas.txt"))

;; chibi ffi
(snow ,@repo3 install pythagoras.hypotenuse)
(test-assert (installed-version (snow-status) '(pythagoras hypotenuse)))

)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; other implementations

(test-group "other impls"

(snow ,@repo2 --implementations "gauche,kawa,larceny"
      install leonardo.fibonacci)
(let ((status (snow-status  --implementations "gauche,kawa,larceny")))
  (test "1.1" (installed-version status '(leonardo fibonacci) 'gauche))
  (test "1.1" (installed-version status '(leonardo fibonacci) 'kawa))
  (test "1.1" (installed-version status '(leonardo fibonacci) 'larceny)))

;; Programs with dependencies fail in a local repo due to chicken's
;; inability to override the repo.
;; (snow ,@repo3 --implementations "chicken" --program-implementation "chicken"
;;       install pingala.triangle)
;; (let ((status (snow-status --implementations "chicken")))
;;   (test-assert (installed-version status '(pingala binomial) 'chicken))
;;   (test-assert (installed-version status '(pingala factorial) 'chicken))
;;   (test "1\n1 1\n1 2 1\n1 3 3 1\n"
;;       (process->string '("tests/snow/tmp-root/bin/triangle" "3"))))

(snow ,@repo3 --implementations "foment" install pingala.binomial)
(let ((status (snow-status --implementations "foment")))
  (test-assert (installed-version status '(pingala binomial) 'foment))
  (test-assert (installed-version status '(pingala factorial) 'foment)))

(snow ,@repo3 --implementations "gauche,kawa,larceny"
      install pingala.binomial)
(let ((status (snow-status --implementations "gauche,kawa,larceny")))
  (test-assert (installed-version status '(pingala binomial) 'gauche))
  (test-assert (installed-version status '(pingala factorial) 'gauche))
  (test-assert (installed-version status '(pingala binomial) 'kawa))
  (test-assert (installed-version status '(pingala factorial) 'kawa))
  (test-assert (installed-version status '(pingala binomial) 'larceny))
  (test-assert (installed-version status '(pingala factorial) 'larceny)))

;; this library is fine but the test fails, so this should't be installed
(snow ,@repo3 --implementations "chibi,chicken,gauche,kawa,larceny"
      install recorde.equal)
(let ((status
       (snow-status --implementations "chibi,chicken,gauche,kawa,larceny")))
  (test-not (installed-version status '(recorde equal) 'chibi))
  (test-not (installed-version status '(recorde equal) 'chicken))
  (test-not (installed-version status '(recorde equal) 'gauche))
  (test-not (installed-version status '(recorde equal) 'kawa))
  (test-not (installed-version status '(recorde equal) 'larceny)))

)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; smart packaging

(define repo4 '(--repository-uri tests/snow/repo4/repo.scm))

(test-group "packaging"

(setenv "SNOW_CHIBI_CONFIG" "tests/snow/repo4/config.scm")

(snow ,@repo4 package --output-dir tests/snow/repo4/
      tests/snow/repo4/euler/interest.sld)
(snow ,@repo4 package --output-dir tests/snow/repo4/
      tests/snow/repo4/euler/exponential.sld)
(snow index ,(cadr repo4))
(let* ((pkg-file "tests/snow/repo4/euler-interest-2.3.tgz")
       (pkg (package-file-meta pkg-file))
       (libs (package-libraries pkg)))
  (test 2 (length libs))
  (for-each
   (lambda (lib)
     (test "Leonhard Euler" (assoc-get lib 'author)))
   libs)
  (test 'bsd (assoc-get pkg 'license))
  (test "Library for computing (optionally continuously) compounded interest."
      (assoc-get pkg 'description))
  (test '((import (rename (euler interest-test)
                          (run-tests run-euler-interest-test-tests)))
          (run-euler-interest-test-tests))
      (snowball-test->sexp-list pkg pkg-file)))
(let* ((pkg-file "tests/snow/repo4/euler-exponential-2.3.tgz")
       (pkg (package-file-meta pkg-file))
       (libs (package-libraries pkg)))
  (test 2 (length libs))
  (for-each
   (lambda (lib)
     (test "Leonhard Euler" (assoc-get lib 'author)))
   libs)
  (test 'bsd (assoc-get pkg 'license))
  (test "Library for computing the natural exponential function."
      (assoc-get pkg 'description))
  (test '((import (rename (euler exponential-test)
                          (run-tests run-euler-exponential-test-tests)))
          (run-euler-exponential-test-tests))
      (snowball-test->sexp-list pkg pkg-file)))

)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; multiple repos

(define repo3+4
  '(--repository-uri "tests/snow/repo3/repo.scm,tests/snow/repo4/repo.scm"))

(define repo5 '(--repository-uri tests/snow/repo5/repo.scm))

(test-group "multiple repos"

(let ((ls (snow->sexp ,@repo3+4 search euler)))
  (test-assert (assoc '(euler interest) ls))
  (test-assert (assoc '(euler totient) ls)))

(let ((ls (snow->sexp ,@repo5 search euler)))
  (test-assert (assoc '(euler interest) ls))
  (test-assert (assoc '(euler totient) ls)))

)

(test-end)
