(import (scheme base) (scheme read) (chibi test)
        (chibi show) (chibi show base) (chibi show pretty))

(test-begin "show")

;; basic data types

(test "hi" (show #f "hi"))
(test "\"hi\"" (show #f (written "hi")))
(test "\"hi \\\"bob\\\"\"" (show #f (written "hi \"bob\"")))
(test "\"hello\\nworld\"" (show #f (written "hello\nworld")))
(test "#(1 2 3)" (show #f (written '#(1 2 3))))
(test "(1 2 3)" (show #f (written '(1 2 3))))
(test "(1 2 . 3)" (show #f (written '(1 2 . 3))))
(test "ABC" (show #f (upcased "abc")))
(test "abc" (show #f (downcased "ABC")))

(test "abc     def" (show #f "abc" (tab-to) "def"))
(test "abc  def" (show #f "abc" (tab-to 5) "def"))
(test "abcdef" (show #f "abc" (tab-to 3) "def"))

;; numbers

(test "-1" (show #f -1))
(test "0" (show #f 0))
(test "1" (show #f 1))
(test "10" (show #f 10))
(test "100" (show #f 100))
(test "-1" (show #f (numeric -1)))
(test "0" (show #f (numeric 0)))
(test "1" (show #f (numeric 1)))
(test "10" (show #f (numeric 10)))
(test "100" (show #f (numeric 100)))
(test "57005" (show #f #xDEAD))
(test "#xDEAD" (show #f (with ((radix 16)) #xDEAD)))
(test "#xDEAD1234" (show #f (with ((radix 16)) #xDEAD) 1234))
(test "DE.AD"
    (show #f (with ((radix 16) (precision 2)) (numeric (/ #xDEAD #x100)))))
(test "D.EAD"
    (show #f (with ((radix 16) (precision 3)) (numeric (/ #xDEAD #x1000)))))
(test "0.DEAD"
    (show #f (with ((radix 16) (precision 4)) (numeric (/ #xDEAD #x10000)))))
(test "1G"
    (show #f (with ((radix 17)) (numeric 33))))

(test "3.14159" (show #f 3.14159))
(test "3.14" (show #f (with ((precision 2)) 3.14159)))
(test "3.14" (show #f (with ((precision 2)) 3.14)))
(test "3.00" (show #f (with ((precision 2)) 3.)))
(test "1.10" (show #f (with ((precision 2)) 1.099)))
(test "0.00" (show #f (with ((precision 2)) 1e-17)))
(test "0.0000000010" (show #f (with ((precision 10)) 1e-9)))
(test "0.0000000000" (show #f (with ((precision 10)) 1e-17)))
(test "0.000004" (show #f (with ((precision 6)) 0.000004)))
(test "0.0000040" (show #f (with ((precision 7)) 0.000004)))
(test "0.00000400" (show #f (with ((precision 8)) 0.000004)))

(test "   3.14159" (show #f (with ((decimal-align 5)) (numeric 3.14159))))
(test "  31.4159" (show #f (with ((decimal-align 5)) (numeric 31.4159))))
(test " 314.159" (show #f (with ((decimal-align 5)) (numeric 314.159))))
(test "3141.59" (show #f (with ((decimal-align 5)) (numeric 3141.59))))
(test "31415.9" (show #f (with ((decimal-align 5)) (numeric 31415.9))))
(test "  -3.14159" (show #f (with ((decimal-align 5)) (numeric -3.14159))))
(test " -31.4159" (show #f (with ((decimal-align 5)) (numeric -31.4159))))
(test "-314.159" (show #f (with ((decimal-align 5)) (numeric -314.159))))
(test "-3141.59" (show #f (with ((decimal-align 5)) (numeric -3141.59))))
(test "-31415.9" (show #f (with ((decimal-align 5)) (numeric -31415.9))))

(cond
 ((exact? (/ 1 3)) ;; exact rationals
  (test "333.333333333333333333333333333333"
      (show #f (with ((precision 30)) (numeric 1000/3))))
  (test  "33.333333333333333333333333333333"
      (show #f (with ((precision 30)) (numeric 100/3))))
  (test   "3.333333333333333333333333333333"
      (show #f (with ((precision 30)) (numeric 10/3))))
  (test   "0.333333333333333333333333333333"
      (show #f (with ((precision 30)) (numeric 1/3))))
  (test   "0.033333333333333333333333333333"
      (show #f (with ((precision 30)) (numeric 1/30))))
  (test   "0.003333333333333333333333333333"
      (show #f (with ((precision 30)) (numeric 1/300))))
  (test   "0.000333333333333333333333333333"
      (show #f (with ((precision 30)) (numeric 1/3000))))
  (test   "0.666666666666666666666666666667"
      (show #f (with ((precision 30)) (numeric 2/3))))
  (test   "0.090909090909090909090909090909"
      (show #f (with ((precision 30)) (numeric 1/11))))
  (test   "1.428571428571428571428571428571"
      (show #f (with ((precision 30)) (numeric 10/7))))
  (test "0.123456789012345678901234567890"
      (show #f (with ((precision 30))
                 (numeric (/  123456789012345678901234567890
                              1000000000000000000000000000000)))))
  (test  " 333.333333333333333333333333333333"
      (show #f (with ((precision 30) (decimal-align 5)) (numeric 1000/3))))
  (test  "  33.333333333333333333333333333333"
      (show #f (with ((precision 30) (decimal-align 5)) (numeric 100/3))))
  (test  "   3.333333333333333333333333333333"
      (show #f (with ((precision 30) (decimal-align 5)) (numeric 10/3))))
  (test  "   0.333333333333333333333333333333"
      (show #f (with ((precision 30) (decimal-align 5)) (numeric 1/3))))
  ))

(test "11.75" (show #f (with ((precision 2)) (/ 47 4))))
(test "-11.75" (show #f (with ((precision 2)) (/ -47 4))))

(test "(#x11 #x22 #x33)" (show #f (with ((radix 16)) '(#x11 #x22 #x33))))

(test "299792458" (show #f (with ((comma-rule 3)) 299792458)))
(test "299,792,458" (show #f (with ((comma-rule 3)) (numeric 299792458))))
(test "-29,97,92,458"
    (show #f (with ((comma-rule '(3 . 2))) (numeric -299792458))))
(test "299.792.458"
    (show #f (with ((comma-rule 3) (comma-sep #\.)) (numeric 299792458))))
(test "299.792.458,0"
    (show #f (with ((comma-rule 3) (decimal-sep #\,)) (numeric 299792458.0))))

(test "100,000" (show #f (with ((comma-rule 3)) (numeric 100000))))
(test "100,000.0"
    (show #f (with ((comma-rule 3) (precision 1)) (numeric 100000))))
(test "100,000.00"
    (show #f (with ((comma-rule 3) (precision 2)) (numeric 100000))))

(cond-expand
 (complex
  (test "1+2i" (show #f (string->number "1+2i")))
  (test "1.00+2.00i"
      (show #f (with ((precision 2)) (string->number "1+2i"))))
  (test "3.14+2.00i"
      (show #f (with ((precision 2)) (string->number "3.14159+2i"))))))

;; padding/trimming

(test "abc  " (show #f (padded 5 "abc")))
(test "  abc" (show #f (padded/left 5 "abc")))
(test " abc " (show #f (padded/both 5 "abc")))
(test "abcde" (show #f (padded 5 "abcde")))
(test "abcdef" (show #f (padded 5 "abcdef")))

(test "abc" (show #f (trimmed 3 "abcde")))
(test "abc" (show #f (trimmed 3 "abcd")))
(test "abc" (show #f (trimmed 3 "abc")))
(test "ab" (show #f (trimmed 3 "ab")))
(test "a" (show #f (trimmed 3 "a")))
(test "cde" (show #f (trimmed/left 3 "abcde")))
(test "bcd" (show #f (trimmed/both 3 "abcde")))
(test "bcdef" (show #f (trimmed/both 5 "abcdefgh")))
(test "abc" (show #f (trimmed/lazy 3 "abcde")))
(test "abc" (show #f (trimmed/lazy 3 "abc\nde")))

(test "prefix: abc" (show #f "prefix: " (trimmed 3 "abcde")))
(test "prefix: cde" (show #f "prefix: " (trimmed/left 3 "abcde")))
(test "prefix: bcd" (show #f "prefix: " (trimmed/both 3 "abcde")))
(test "prefix: abc" (show #f "prefix: " (trimmed/lazy 3 "abcde")))
(test "prefix: abc" (show #f "prefix: " (trimmed/lazy 3 "abc\nde")))

(test "abc :suffix" (show #f (trimmed 3 "abcde") " :suffix"))
(test "cde :suffix" (show #f (trimmed/left 3 "abcde") " :suffix"))
(test "bcd :suffix" (show #f (trimmed/both 3 "abcde") " :suffix"))
(test "abc :suffix" (show #f (trimmed/lazy 3 "abcde") " :suffix"))
(test "abc :suffix" (show #f (trimmed/lazy 3 "abc\nde") " :suffix"))

(test "abcde"
    (show #f (with ((ellipsis "...")) (trimmed 5 "abcde"))))
(test "ab..."
    (show #f (with ((ellipsis "...")) (trimmed 5 "abcdef"))))
(test "abc..."
    (show #f (with ((ellipsis "...")) (trimmed 6 "abcdefg"))))
(test "abcde"
    (show #f (with ((ellipsis "...")) (trimmed/left 5 "abcde"))))
(test "...ef"
    (show #f (with ((ellipsis "...")) (trimmed/left 5 "abcdef"))))
(test "...efg"
    (show #f (with ((ellipsis "...")) (trimmed/left 6 "abcdefg"))))
(test "abcdefg"
    (show #f (with ((ellipsis "...")) (trimmed/both 7 "abcdefg"))))
(test "...d..."
    (show #f (with ((ellipsis "...")) (trimmed/both 7 "abcdefgh"))))
(test "...e..."
    (show #f (with ((ellipsis "...")) (trimmed/both 7 "abcdefghi"))))

(test "abc  " (show #f (fitted 5 "abc")))
(test "  abc" (show #f (fitted/left 5 "abc")))
(test " abc " (show #f (fitted/both 5 "abc")))
(test "abcde" (show #f (fitted 5 "abcde")))
(test "abcde" (show #f (fitted/left 5 "abcde")))
(test "abcde" (show #f (fitted/both 5 "abcde")))
(test "abcde" (show #f (fitted 5 "abcdefgh")))
(test "defgh" (show #f (fitted/left 5 "abcdefgh")))
(test "bcdef" (show #f (fitted/both 5 "abcdefgh")))

(test "prefix: abc   :suffix"
    (show #f "prefix: " (fitted 5 "abc") " :suffix"))
(test "prefix:   abc :suffix"
    (show #f "prefix: " (fitted/left 5 "abc") " :suffix"))
(test "prefix:  abc  :suffix"
    (show #f "prefix: " (fitted/both 5 "abc") " :suffix"))
(test "prefix: abcde :suffix"
    (show #f "prefix: " (fitted 5 "abcde") " :suffix"))
(test "prefix: abcde :suffix"
    (show #f "prefix: " (fitted/left 5 "abcde") " :suffix"))
(test "prefix: abcde :suffix"
    (show #f "prefix: " (fitted/both 5 "abcde") " :suffix"))
(test "prefix: abcde :suffix"
    (show #f "prefix: " (fitted 5 "abcdefgh") " :suffix"))
(test "prefix: defgh :suffix"
    (show #f "prefix: " (fitted/left 5 "abcdefgh") " :suffix"))
(test "prefix: bcdef :suffix"
    (show #f "prefix: " (fitted/both 5 "abcdefgh") " :suffix"))

;; joining

(test "1 2 3" (show #f (joined each '(1 2 3) " ")))

(test ":abc:123"
    (show #f (joined/prefix
              (lambda (x) (trimmed 3 x))
              '("abcdef" "123456")
              ":")))

(test "abc\n123\n"
    (show #f (joined/suffix
              (lambda (x) (trimmed 3 x))
              '("abcdef" "123456")
              nl)))

(test "lions, tigers, and bears"
    (show #f (joined/last
              each
              (lambda (x) (each "and " x))
              '(lions tigers bears)
              ", ")))

(test "lions, tigers, or bears"
    (show #f (joined/dot
              each
              (lambda (x) (each "or " x))
              '(lions tigers . bears)
              ", ")))

;; shared structures

(test "#0=(1 . #0#)"
    (show #f (written (let ((ones (list 1))) (set-cdr! ones ones) ones))))
(test "(0 . #0=(1 . #0#))"
    (show #f (written (let ((ones (list 1)))
                        (set-cdr! ones ones)
                        (cons 0 ones)))))
(test "(sym . #0=(sym . #0#))"
    (show #f (written (let ((syms (list 'sym)))
                        (set-cdr! syms syms)
                        (cons 'sym syms)))))
(test "(#0=(1 . #0#) #1=(2 . #1#))"
    (show #f (written (let ((ones (list 1))
                            (twos (list 2)))
                        (set-cdr! ones ones)
                        (set-cdr! twos twos)
                        (list ones twos)))))
(test "(#0=(1 . #0#) #0#)"
    (show #f (written (let ((ones (list 1)))
                        (set-cdr! ones ones)
                        (list ones ones)))))
(test "((1) (1))"
    (show #f (written (let ((ones (list 1)))
                        (list ones ones)))))

(test "(#0=(1) #0#)"
    (show #f (written-shared (let ((ones (list 1)))
                               (list ones ones)))))

;; cycles without shared detection

(test "(1 1 1 1 1"
    (show #f (trimmed/lazy
             10
             (written-simply
              (let ((ones (list 1))) (set-cdr! ones ones) ones)))))

(test "(1 1 1 1 1 "
    (show #f (trimmed/lazy
             11
             (written-simply
              (let ((ones (list 1))) (set-cdr! ones ones) ones)))))

;; pretty printing

(define-syntax test-pretty
  (syntax-rules ()
    ((test-pretty str)
     (let ((sexp (read (open-input-string str))))
       (test str (show #f (pretty sexp)))))))

(test-pretty "(foo bar)\n")

(test-pretty
"((self . aquanet-paper-1991)
 (type . paper)
 (title . \"Aquanet: a hypertext tool to hold your\"))
")

(test-pretty
"(abracadabra xylophone
             bananarama
             yellowstonepark
             cryptoanalysis
             zebramania
             delightful
             wubbleflubbery)\n")

(test-pretty
 "#(0  1  2  3  4  5  6  7  8  9  10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25
  26 27 28 29 30 31 32 33 34 35 36 37)\n")

(test-pretty
 "(0  1  2  3  4  5  6  7  8  9  10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25
 26 27 28 29 30 31 32 33 34 35 36 37)\n")

(test-pretty
 "(define (fold kons knil ls)
  (define (loop ls acc)
    (if (null? ls) acc (loop (cdr ls) (kons (car ls) acc))))
  (loop ls knil))\n")

(test-pretty
"(do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec) (vector-set! vec i i))\n")

(test-pretty
"(do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec)
  (vector-set! vec i 'supercalifrajalisticexpialidocious))\n")

(test-pretty
"(do ((my-vector (make-vector 5)) (index 0 (+ index 1)))
    ((= index 5) my-vector)
  (vector-set! my-vector index index))\n")

(test-pretty
 "(define (fold kons knil ls)
  (let loop ((ls ls) (acc knil))
    (if (null? ls) acc (loop (cdr ls) (kons (car ls) acc)))))\n")

(test-pretty
 "(define (file->sexp-list pathname)
  (call-with-input-file pathname
    (lambda (port)
      (let loop ((res '()))
        (let ((line (read port)))
          (if (eof-object? line) (reverse res) (loop (cons line res))))))))\n")

(test "(let ((ones '#0=(1 . #0#))) ones)\n"
    (show #f (pretty (let ((ones (list 1)))
                       (set-cdr! ones ones)
                       `(let ((ones ',ones)) ones)))))

'(test
"(let ((zeros '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
      (ones '#0=(1 . #0#)))
  (append zeros ones))\n"
    (show #f (pretty
              (let ((ones (list 1)))
                (set-cdr! ones ones)
                `(let ((zeros '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
                       (ones ',ones))
                   (append zeros ones))))))

(test-end)