(module io mzscheme
  (require (planet "test.ss" ("schematics" "schemeunit.plt" 1)))
  (require (planet "util.ss" ("schematics" "schemeunit.plt" 1)))
  (require (planet "test.ss" ("dherman" "test.plt" 1)))
  (require (lib "async-channel.ss"))
  (require (lib "etc.ss"))
  (require (lib "port.ss"))
  (require (lib "inflate.ss"))
  (require (lib "match.ss"))
  (require/expose "../../io.ss" (ones-mask make-filter-input-port/debug))

  (define test:with-output-to-string
    (make-test-suite
     "with-output-to-string"
     (make-test-case "empty string"
                     (assert string=? (with-output-to-string (void)) ""))
     (make-test-case "a few display operations"
                     (assert string=? (with-output-to-string
                                       (display "hello")
                                       (display ", ")
                                       (display "world")
                                       (display "!")
                                       (newline))
                             "hello, world!\n"))))

  (define test:ones-mask
    (make-test-suite
     "ones-mask"
     (make-test-case "zero"
                     (assert = (ones-mask 0) 0))
     (make-test-case "one through ten"
                     (let loop ([i 1])
                       (unless (>= i 10)
                         (let ([ans (ones-mask i)]
                               [expected (build-string (* 8 i) (lambda (x) #\1))])
                           (assert string=? (format "~b" ans) expected)))))))

  (define test:bit-set?
    (make-test-suite
     "bit-set?"
     (make-test-case ""
                     (assert-true (bit-set? 0 #b1)))
     (make-test-case ""
                     (assert-true (bit-set? 1 #b10)))
     (make-test-case ""
                     (assert-true (bit-set? 2 #b100)))
     (make-test-case ""
                     (assert-true (bit-set? 9 #b1000000000)))
     (make-test-case ""
                     (assert-false (bit-set? 0 #b11111111110)))
     (make-test-case ""
                     (assert-false (bit-set? 1 #b11111111101)))
     (make-test-case ""
                     (assert-false (bit-set? 2 #b11111111011)))
     (make-test-case ""
                     (assert-false (bit-set? 9 #b10111111111)))
     ))

  (define test:stretch-bytes
    (make-test-suite
     "stretch-bytes"
     (make-test-case "stretch big-endian"
                     (assert bytes=? (stretch-bytes #"dave" 8 #t (char->integer #\X))
                                     #"XXXXdave"))
     (make-test-case "stretch small-endian"
                     (assert bytes=? (stretch-bytes #"dave" 8 #f (char->integer #\X))
                                     #"daveXXXX"))
     (make-test-case "stretch big-endian with default fill"
                     (assert bytes=? (stretch-bytes #"dave" 8 #t)
                                     #"\0\0\0\0dave"))
     (make-test-case "stretch small-endian with default fill"
                     (assert bytes=? (stretch-bytes #"dave" 8 #f)
                                     #"dave\0\0\0\0"))
     (make-test-case "stretch none big-endian"
                     (assert bytes=? (stretch-bytes #"dave" 4 #t)
                                     #"dave"))
     (make-test-case "stretch none small-endian"
                     (assert bytes=? (stretch-bytes #"dave" 4 #f)
                                     #"dave"))
     ;; TODO: why isn't this an exn:fail:contract?
     (make-test-case "stretch not enough big-endian"
                     (assert-exn exn:fail?
                                 (lambda ()
                                   (stretch-bytes #"dave" 2 #t))))
     (make-test-case "stretch not enough small-endian"
                     (assert-exn exn:fail?
                                 (lambda ()
                                   (stretch-bytes #"dave" 3 #f))))
     ))

  (define (integer->bytes->integer n big-endian?)
    (bytes->integer (integer->integer-bytes n 4 #f big-endian?)
                    #t
                    big-endian?))

  (define test:bytes->integer/unsigned
    (make-test-suite
     "bytes->integer (unsigned)"
     (make-test-case "No bytes - big-endian"
                     (assert = (bytes->integer (bytes) #f #t) 0))
     (make-test-case "No bytes - small-endian"
                     (assert = (bytes->integer (bytes) #f #f) 0))
     (make-test-case "Simple test 1 - big-endian"
                     (assert = (bytes->integer (bytes 2 1) #f #t) 513))
     (make-test-case "Simple test 1 - small-endian"
                     (assert = (bytes->integer (bytes 2 1) #f #f) 258))
     (make-test-case "Reverse endianness"
                     (assert = (bytes->integer (bytes 24 28 200 12) #f #t)
                               (bytes->integer (bytes 12 200 28 24) #f #f)))
     (make-test-case "compatible with integer->integer-bytes"
                     (assert = (integer->bytes->integer 2461357 #t) 2461357))
     ))

  (define test:bytes->integer/signed
    (make-test-suite
     "bytes->integer (signed)"
     (make-test-case "-1 in one byte"
                     (assert = (bytes->integer #"\377" #t #t) -1))
     (make-test-case "-1 in two bytes"
                     (assert = (bytes->integer #"\377\377" #t #t) -1))
     (make-test-case "-1 in four bytes"
                     (assert = (bytes->integer #"\377\377\377\377" #t #t) -1))
     (make-test-case "-20"
                     (assert = (bytes->integer #"\377\354" #t #t) -20))
     (make-test-case "-38274773"
                     (assert = (bytes->integer #"\375\267\371+" #t #t) -38274773))
     (make-test-case "-3333333333333333333"
                     (assert =
                             (bytes->integer #"\321\275\236\376|\262\252\253" #t #t)
                             -3333333333333333333))
     ))

  (define test:integer->bytes/unsigned
    (make-test-suite
     "integer->bytes (unsigned)"
     (make-test-case "1"
                     (assert bytes=? (integer->bytes 1 #f #t 1) #"\001"))
     (make-test-case "255"
                     (assert bytes=? (integer->bytes 255 #f #t 2) #"\000\377"))
     (make-test-case "3527688"
                     (assert bytes=? (integer->bytes 3527688 #f #t 4) #"\0005\324\b"))
     ))

  (define test:integer->bytes/signed
    (make-test-suite
     "integer->bytes (signed)"
     (make-test-case "-1"
                     (assert bytes=? (integer->bytes -1 #t #t 1) #"\377"))
     (make-test-case "-255"
                     (assert bytes=? (integer->bytes -255 #t #t 2) #"\377\1"))
     (make-test-case "-3527688"
                     (assert bytes=? (integer->bytes -3527688 #t #t 4) #"\377\312+\370"))
     ))

  (define (read-it path ch close-early?)
    (with-handlers ([(lambda (exn) #t)
                     (lambda (exn)
                       (sleep 1)
                       (async-channel-put ch `(main-thread-exn ,exn)))])
      (with-input-from-file path
        (lambda ()
          (file-position (current-input-port) #x26)
          (let ([in (make-filter-input-port/debug inflate (current-input-port) ch)])
            (when close-early?
              (thread (lambda ()
                        (sleep 0.1)
                        (close-input-port in))))
            (let loop ([read-anything? #f] [i 0])
              (unless read-anything?
                (async-channel-put ch 'trying-to-read))
              (when (> i 4440)
                (async-channel-put ch `(reading-line ,i)))
              (cond
                [(read-line in 'any)
                 => (lambda (line)
                      (unless (eof-object? line)
                        (loop #t (add1 i))))]))
            (async-channel-put ch 'done-reading))))))

  ;; TODO: make this better! give better error info upon failure

  (define (test-script script ch)
    (let loop ([script script])
      (or (null? script)
          (let ([expected (car script)]
                [actual (async-channel-get ch)])
            (fprintf (current-error-port) "expected: ~v, actual: ~v~n" expected actual)
            (and (match expected
                   [('reading-line i)
                    (match actual
                      [('reading-line j) (= i j)]
                      [_ #f])]
                   [(sym expected-val)
                    (match actual
                      [(sym* val*)
                       (and (eq? sym sym*)
                            (or (not (procedure? expected-val))
                                (expected-val val*)))]
                      [_ #f])]
                   [_ (eq? expected actual)])
                 (loop (cdr script)))))))

  (define (make-broken-copy from to k)
    (with-input-from-file from
      (lambda ()
        (let ([in (make-limited-input-port (current-input-port) k)])
          (with-output-to-file to
            (lambda ()
              (copy-port in (current-output-port))))))))

  (define test:make-filter-input-port
    (make-test-suite
     "make-filter-input-port tests (ooooh.. concurrency..)"
     (make-test-case "relatively big file"
                     (in-this-directory
                      (let ([ch (make-async-channel 100)])
                        (thread (lambda ()
                                  (read-it (build-path "examples" "big.zip") ch #f)))
                        (assert-true
                         (test-script '(trying-to-read
                                        done-transform
                                        (reading-line 4441)
                                        (reading-line 4442)
                                        (reading-line 4443)
                                        (reading-line 4444)
                                        done-reading)
                                      ch)))))
     (make-test-case "interrupting mid-transform"
                     (in-this-directory
                      (let ([ch (make-async-channel 100)])
                        (thread (lambda ()
                                  (read-it (build-path "examples" "big.zip") ch #t)))
                        (assert-true
                         (test-script `(trying-to-read
                                        transform-exn
                                        (main-thread-exn ,exn:fail?))
                                      ch)))))
     (make-test-case "exception mid-transform"
                     (in-this-directory
                      (in-new-directory "sandbox"
                       (make-broken-copy (build-path 'up "examples" "big.zip")
                                         "broken.zip"
                                         42440)
                       (let ([ch (make-async-channel 100)])
                         (thread (lambda ()
                                   (read-it "broken.zip" ch #f)))
                         (assert-true
                          (test-script `(trying-to-read
                                         transform-exn
                                         (main-thread-exn ,exn:fail:contract?))
                                       ch))))))
     ))

  (define io-tests
    (make-test-suite
     "All io.ss tests"
     test:ones-mask
     test:with-output-to-string
     test:bit-set?
     test:stretch-bytes
     test:bytes->integer/unsigned
     test:bytes->integer/signed
     test:integer->bytes/unsigned
     test:integer->bytes/signed
     test:make-filter-input-port
     ))

  (provide io-tests))