#lang racket/base

(require "../main.rkt")

(require racket/match)
(require racket/set)

(require rackunit)
(require racket/runtime-path)
(require syntax/srcloc)

(define (d bs #:allow-invalid-prefix? [allow-invalid-prefix? #f])
  (for [(i (in-range 1 (- (bytes-length bs) 1)))]
    (define result (bytes->preserve (subbytes bs 0 i)
                                    #:decode-embedded strip-annotations
                                    #:on-short (lambda () 'short)
                                    void
                                    (bytes-length bs)))
    (when (and (not (eq? result 'short))
               (not (and allow-invalid-prefix? (void? result))))
      (error 'd "~a-byte prefix of ~v does not read as short; result: ~v" i bs result)))
  (bytes->preserve bs
                   #:read-syntax? #t
                   #:decode-embedded strip-annotations
                   #:on-short (lambda () 'short)
                   void))

(define (d-strip bs) (strip-annotations (d bs)))

(struct discard () #:prefab)
(struct capture (detail) #:prefab)
(struct observe (specification) #:prefab)

(struct speak (who what) #:prefab)

(struct date (year month day) #:prefab)
(struct thing (id) #:prefab)
(struct person thing (name date-of-birth) #:prefab)
(struct titled person (title) #:prefab)

(define (run-test-case variety t-name loc binary-form annotated-text-form)
  (define text-form (strip-annotations annotated-text-form))
  (define forward text-form)
  (define back text-form)
  (check-equal? text-form back loc)                      ;; expectation 1
  (check-equal? (d-strip (preserve->bytes #:encode-embedded values text-form))
                back
                loc)                                     ;; expectation 2
  (check-equal? (d-strip (preserve->bytes #:encode-embedded values forward))
                back
                loc)                                     ;; expectation 3
  (check-equal? (d-strip binary-form) back loc)          ;; expectation 4
  (check-equal? (d binary-form) annotated-text-form loc) ;; expectation 5
  (check-equal? (d (preserve->bytes #:encode-embedded values annotated-text-form))
                annotated-text-form
                loc)                                     ;; expectation 6
  (check-equal? (string->preserve #:decode-embedded strip-annotations
                                  (preserve->string #:encode-embedded values text-form))
                back
                loc)                                     ;; expectation 7
  (check-equal? (string->preserve #:decode-embedded strip-annotations
                                  (preserve->string #:encode-embedded values forward))
                back
                loc)                                     ;; expectation 8
  ;; similar to 8:
  (check-equal? (string->preserve #:decode-embedded strip-annotations
                                  (preserve->string #:encode-embedded values
                                                    annotated-text-form)
                                  #:read-syntax? #t)
                annotated-text-form
                loc)
  (when (not (memq variety '(decode)))
    ;; expectations 9 and 10
    (check-equal? (preserve->bytes annotated-text-form
                                   #:encode-embedded values
                                   #:canonicalizing? #t
                                   #:write-annotations? #t)
                  binary-form
                  loc))
  (unless (memq variety '(decode nondeterministic))
    ;; expectation 11
    (check-equal? (preserve->bytes annotated-text-form
                                   #:encode-embedded values
                                   #:write-annotations? #t)
                  binary-form
                  loc)))

(define-runtime-path samples-pr-path "./samples.pr")
(let* ((testfile (call-with-input-file samples-pr-path
                   (lambda (p)
                     (port-count-lines! p)
                     (read-preserve p
                                    #:read-syntax? #t
                                    #:decode-embedded strip-annotations
                                    #:source samples-pr-path)))))
  (match-define (peel-annotations `#s(TestCases ,tests)) testfile)
  (for [((t-name* t*) (in-hash (annotated-item tests)))]
    (define t-name (strip-annotations t-name*))
    (define loc (format "Test case '~a' (~a)" t-name (source-location->string (annotated-srcloc t*))))
    (define (fail-test fmt . args)
      (fail (format "~a: ~a" loc (apply format fmt args))))
    (displayln loc)
    (match (peel-annotations t*)
      [`#s(Test ,(strip-annotations binary-form) ,annotated-text-form)
       (run-test-case 'normal t-name loc binary-form annotated-text-form)]
      [`#s(NondeterministicTest ,(strip-annotations binary-form) ,annotated-text-form)
       (run-test-case 'nondeterministic t-name loc binary-form annotated-text-form)]
      [`#s(DecodeTest ,(strip-annotations binary-form) ,annotated-text-form)
       (run-test-case 'decode t-name loc binary-form annotated-text-form)]
      [`#s(ParseError ,(strip-annotations str))
       (with-handlers [(exn:fail:read:eof?
                        (lambda (e) (fail-test "Unexpected EOF: ~e" e)))
                       (exn:fail:read?
                        (lambda (e) 'ok))
                       ((lambda (e) #t)
                        (lambda (e) (fail-test "Unexpected exception: ~e" e)))]
         (string->preserve str)
         (fail-test "Unexpected success"))]
      [(or `#s(ParseShort ,(strip-annotations str))
           `#s(ParseEOF ,(strip-annotations str)))
       (with-handlers [(exn:fail:read:eof? (lambda (e) 'ok))
                       ((lambda (e) #t)
                        (lambda (e) (fail-test "Unexpected exception: ~e" e)))]
         (string->preserve str)
         (fail-test "Unexpected success"))]
      [(or `#s(DecodeShort ,(strip-annotations bs))
           `#s(DecodeEOF ,(strip-annotations bs)))
       (check-eq? (d bs) 'short loc)]
      [`#s(DecodeError ,(strip-annotations bs))
       (check-true (void? (d bs #:allow-invalid-prefix? #t)) loc)]
      [_
       (write-preserve/text t* #:indent #f)
       (newline)]))
  )