(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-struct running-script (thread channel port file-port))

  ;; interrupt-script : running-script -> any
  ;; interferes with a running script by closing its underlying file port
  (define (interrupt-script running)
    (close-input-port (running-script-file-port running)))

  ;; start-script : (union path string) -> running-script
  ;; NOTE: *only* works with big.zip and broken.zip
  (define (start-script path)
    (let* ([history (make-async-channel 100)]
           [file-in (open-input-file path)]
           [filter-in (make-filter-input-port/debug inflate file-in #f history)])
      (file-position file-in #x26)
      (make-running-script
       (thread
        (lambda ()
          (let ([handler (lambda (e)
                           (sleep 1)
                           (async-channel-put history `(exn main-thread ,e)))])
            (with-handlers ([exn? handler])
              (async-channel-put history 'trying-to-read)
              (let loop ([i 0])
                (when (> i 4440)
                  (async-channel-put history `(reading-line ,i)))
                (cond
                  [(read-line filter-in 'any)
                   => (lambda (line)
                        (unless (eof-object? line)
                          (loop (add1 i))))]))
              (async-channel-put history 'done-reading)))))
       history
       filter-in
       file-in)))

  ;; script-wait : running-script -> (listof event)
  ;; waits for a running script to finish, cleans up, and returns the transcript
  (define (script-wait running)
    (thread-wait (running-script-thread running))
    (close-input-port (running-script-port running))
    (close-input-port (running-script-file-port running))
    (let loop ([result '()])
      (let ([event (async-channel-try-get (running-script-channel running))])
        (if (not event)
            (reverse result)
            (loop (cons event result))))))

  ;; transcript-element=? : event event -> boolean
  (define (transcript-element=? act exp)
    (match exp
      [('reading-line i)
       (match act
         [('reading-line j) (= i j)]
         [_ #f])]
      [('exn context correct-type?)
       (match act
         [('exn context* val)
          (and (eq? context context*)
               (correct-type? val))]
         [_ #f])]
      [_ (eq? exp act)]))

  ;; transcript=? : (listof event) (listof event) -> boolean
  (define (transcript=? act exp)
    (and (= (length act) (length exp))
         (andmap transcript-element=? act exp)))

  ;; assert-script : running-script (listof event) -> ?
  (define (assert-script running expected)
    (let ([transcript (script-wait running)])
      (assert transcript=? transcript expected
              (format "expected: ~v, actual: ~v" expected transcript))))

  (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
                      (assert-script
                       (start-script (build-path "examples" "big.zip"))
                       '(trying-to-read
                         done-transform
                         (reading-line 4441)
                         (reading-line 4442)
                         (reading-line 4443)
                         (reading-line 4444)
                         done-reading))))
     (make-test-case "interrupting mid-transform"
                     (in-this-directory
                      (let ([running (start-script (build-path "examples" "big.zip"))])
                        (interrupt-script running)
                        (assert-script running
                                       `(trying-to-read
                                         (exn transformer ,exn:fail?)
                                         (exn main-thread ,exn:fail?))))))
     (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)
                       (assert-script
                        (start-script "broken.zip")
                        `(trying-to-read
                          (exn transformer ,exn:fail:contract?)
                          (exn main-thread ,exn:fail:contract?))))))
     ))

  (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))