(load-relative "../racket/loadtest.rktl")

(Section 'srcloc)
(require unstable/srcloc)
(require racket/shared)

(test #t source-location? #f)
(test #f source-location? #t)
(test #t source-location? (list #f #f #f #f #f))
(test #t source-location? (list 'here 1 0 1 0))
(test #t source-location? (list #f 1 0 1 0))
(test #f source-location? (list 'here #f 0 1 0))
(test #f source-location? (list 'here 1 #f 1 0))
(test #t source-location? (list 'here 1 0 #f 0))
(test #t source-location? (list 'here 1 0 1 #f))
(test #f source-location? (list 'here 1 -1 1 0))
(test #f source-location? (list 'here 1 0 0 0))
(test #f source-location? (list 'here 1 0 1 -1))
(test #f source-location? (shared ([x (list* 'here 1 0 1 0 x)]) x))
(test #t source-location? (vector #f #f #f #f #f))
(test #t source-location? (vector 'here 1 0 1 0))
(test #t source-location? (vector #f 1 0 1 0))
(test #f source-location? (vector 'here #f 0 1 0))
(test #f source-location? (vector 'here 1 #f 1 0))
(test #t source-location? (vector 'here 1 0 #f 0))
(test #t source-location? (vector 'here 1 0 1 #f))
(test #f source-location? (vector 'here 0 0 1 0))
(test #f source-location? (vector 'here 1 -1 1 0))
(test #f source-location? (vector 'here 1 0 0 0))
(test #f source-location? (vector 'here 1 0 1 -1))
(test #t source-location? (make-srcloc #f #f #f #f #f))
(test #t source-location? (make-srcloc 'here 1 0 1 0))
(test #t source-location? (make-srcloc #f 1 0 1 0))
(test #f source-location? (make-srcloc 'here #f 0 1 0))
(test #f source-location? (make-srcloc 'here 1 #f 1 0))
(test #t source-location? (make-srcloc 'here 1 0 #f 0))
(test #t source-location? (make-srcloc 'here 1 0 1 #f))
(test #t source-location? (datum->syntax #f null #f))
(test #t source-location? (datum->syntax #f null (list 'here 1 0 1 0)))
(test #t source-location? (datum->syntax #f null (list #f 1 0 1 0)))
;;(test #f source-location? (datum->syntax #f null (list 'here #f 0 1 0))) ;; won't run
;;(test #f source-location? (datum->syntax #f null (list 'here 1 #f 1 0))) ;; won't run
(test #t source-location? (datum->syntax #f null (list 'here 1 0 #f 0)))
(test #t source-location? (datum->syntax #f null (list 'here 1 0 1 #f)))

(test #f source-location-list? #f)
(test #t source-location-list? (list #f #f #f #f #f))
(test #t source-location-list? (list 'here 1 0 1 0))
(test #t source-location-list? (list #f 1 0 1 0))
(test #f source-location-list? (list 'here #f 0 1 0))
(test #f source-location-list? (list 'here 1 #f 1 0))
(test #t source-location-list? (list 'here 1 0 #f 0))
(test #t source-location-list? (list 'here 1 0 1 #f))
(test #f source-location-list? (list 'here 0 0 1 0))
(test #f source-location-list? (list 'here 1 -1 1 0))
(test #f source-location-list? (list 'here 1 0 0 0))
(test #f source-location-list? (list 'here 1 0 1 -1))
(test #f source-location-list? (shared ([x (list* 'here 1 0 1 0 x)]) x))
(test #f source-location-list? (vector 'here 1 0 1 0))
(test #f source-location-list? (make-srcloc 'here 1 0 1 0))
(test #f source-location-list? (datum->syntax #f null #f))
(test #f source-location-list? (datum->syntax #f null (list 'here 1 0 1 0)))

(test #f source-location-vector? #f)
(test #f source-location-vector? (list 'here 1 0 1 0))
(test #t source-location-vector? (vector #f 1 0 1 0))
(test #f source-location-vector? (vector 'here #f 0 1 0))
(test #f source-location-vector? (vector 'here 1 #f 1 0))
(test #t source-location-vector? (vector 'here 1 0 #f 0))
(test #t source-location-vector? (vector 'here 1 0 1 #f))
(test #t source-location-vector? (vector #f #f #f #f #f))
(test #t source-location-vector? (vector 'here 1 0 1 0))
(test #f source-location-vector? (vector 'here 0 0 1 0))
(test #f source-location-vector? (vector 'here 1 -1 1 0))
(test #f source-location-vector? (vector 'here 1 0 0 0))
(test #f source-location-vector? (vector 'here 1 0 1 -1))
(test #f source-location-vector? (make-srcloc 'here 1 0 1 0))
(test #f source-location-vector? (datum->syntax #f null #f))
(test #f source-location-vector? (datum->syntax #f null (list 'here 1 0 1 0)))

(test (void) check-source-location! 'test-srcloc #f)
(err/rt-test (check-source-location! 'test-srcloc #t) exn:fail:contract?)
(test (void) check-source-location! 'test-srcloc (list #f #f #f #f #f))
(test (void) check-source-location! 'test-srcloc (list 'here 1 0 1 0))
(test (void) check-source-location! 'test-srcloc (list #f 1 0 1 0))
(err/rt-test (check-source-location! 'test-srcloc (list 'here #f 0 1 0)) exn:fail:contract?)
(err/rt-test (check-source-location! 'test-srcloc (list 'here 1 #f 1 0)) exn:fail:contract?)
(test (void) check-source-location! 'test-srcloc (list 'here 1 0 #f 0))
(test (void) check-source-location! 'test-srcloc (list 'here 1 0 1 #f))
(err/rt-test (check-source-location! 'test-srcloc (list 'here 0 0 1 0)) exn:fail:contract?)
(err/rt-test (check-source-location! 'test-srcloc (list 'here 1 -1 1 0)) exn:fail:contract?)
(err/rt-test (check-source-location! 'test-srcloc (list 'here 1 0 0 0)) exn:fail:contract?)
(err/rt-test (check-source-location! 'test-srcloc (list 'here 1 0 1 -1)) exn:fail:contract?)
(err/rt-test (check-source-location! 'test-srcloc (shared ([x (list* 'here 1 0 1 0 x)]) x)) exn:fail:contract?)
(test (void) check-source-location! 'test-srcloc (vector #f #f #f #f #f))
(test (void) check-source-location! 'test-srcloc (vector 'here 1 0 1 0))
(test (void) check-source-location! 'test-srcloc (vector #f 1 0 1 0))
(err/rt-test (check-source-location! 'test-srcloc (vector 'here #f 0 1 0)) exn:fail:contract?)
(err/rt-test (check-source-location! 'test-srcloc (vector 'here 1 #f 1 0)) exn:fail:contract?)
(test (void) check-source-location! 'test-srcloc (vector 'here 1 0 #f 0))
(test (void) check-source-location! 'test-srcloc (vector 'here 1 0 1 #f))
(err/rt-test (check-source-location! 'test-srcloc (vector 'here 0 0 1 0)) exn:fail:contract?)
(err/rt-test (check-source-location! 'test-srcloc (vector 'here 1 -1 1 0)) exn:fail:contract?)
(err/rt-test (check-source-location! 'test-srcloc (vector 'here 1 0 0 0)) exn:fail:contract?)
(err/rt-test (check-source-location! 'test-srcloc (vector 'here 1 0 1 -1)) exn:fail:contract?)
(test (void) check-source-location! 'test-srcloc (make-srcloc #f #f #f #f #f))
(test (void) check-source-location! 'test-srcloc (make-srcloc 'here 1 0 1 0))
(test (void) check-source-location! 'test-srcloc (make-srcloc #f 1 0 1 0))
(err/rt-test (check-source-location! 'test-srcloc (make-srcloc 'here #f 0 1 0)) exn:fail:contract?)
(err/rt-test (check-source-location! 'test-srcloc (make-srcloc 'here 1 #f 1 0)) exn:fail:contract?)
(test (void) check-source-location! 'test-srcloc (make-srcloc 'here 1 0 #f 0))
(test (void) check-source-location! 'test-srcloc (make-srcloc 'here 1 0 1 #f))
(test (void) check-source-location! 'test-srcloc (datum->syntax #f null #f))
(test (void) check-source-location! 'test-srcloc (datum->syntax #f null (list 'here 1 0 1 0)))
(test (void) check-source-location! 'test-srcloc (datum->syntax #f null (list #f 1 0 1 0)))
;;(err/rt-test (check-source-location! 'test-srcloc (datum->syntax #f null (list 'here #f 0 1 0))) exn:fail:contract?) ;; won't run
;;(err/rt-test (check-source-location! 'test-srcloc (datum->syntax #f null (list 'here 1 #f 1 0))) exn:fail:contract?) ;; won't run
(test (void) check-source-location! 'test-srcloc (datum->syntax #f null (list 'here 1 0 #f 0)))
(test (void) check-source-location! 'test-srcloc (datum->syntax #f null (list 'here 1 0 1 #f)))

(test (make-srcloc #f #f #f #f #f) build-source-location)
(test (make-srcloc #f #f #f #f #f) build-source-location #f)
(test (make-srcloc 'here 1 0 1 0) build-source-location (make-srcloc 'here 1 0 1 0))
(test (make-srcloc 'here 1 0 1 0) build-source-location (vector 'here 1 0 1 0))
(test (make-srcloc 'here 1 0 1 0) build-source-location (list 'here 1 0 1 0))
(test (make-srcloc 'here 1 0 1 0) build-source-location (datum->syntax #f null (list 'here 1 0 1 0)))
(test (make-srcloc 'here 1 0 1 3) build-source-location (list 'here 1 0 1 0) (vector 'here 2 1 3 1))
(test (make-srcloc 'here 1 0 1 3) build-source-location (vector 'here 2 1 3 1) (list 'here 1 0 1 0))
(test (make-srcloc #f #f #f #f #f) build-source-location (vector 'here 2 1 3 1) (list 'there 1 0 1 0))
(err/rt-test (build-source-location (list 'bad 0 0 0 0)) exn:fail:contract?)

(test (list #f #f #f #f #f) build-source-location-list)
(test (list #f #f #f #f #f) build-source-location-list #f)
(test (list 'here 1 0 1 0) build-source-location-list (make-srcloc 'here 1 0 1 0))
(test (list 'here 1 0 1 0) build-source-location-list (vector 'here 1 0 1 0))
(test (list 'here 1 0 1 0) build-source-location-list (list 'here 1 0 1 0))
(test (list 'here 1 0 1 0) build-source-location-list (datum->syntax #f null (list 'here 1 0 1 0)))
(test (list 'here 1 0 1 3) build-source-location-list (list 'here 1 0 1 0) (vector 'here 2 1 3 1))
(test (list 'here 1 0 1 3) build-source-location-list (vector 'here 2 1 3 1) (list 'here 1 0 1 0))
(test (list #f #f #f #f #f) build-source-location-list (vector 'here 2 1 3 1) (list 'there 1 0 1 0))
(err/rt-test (build-source-location-list (list 'bad 0 0 0 0)) exn:fail:contract?)

(test (vector #f #f #f #f #f) build-source-location-vector)
(test (vector #f #f #f #f #f) build-source-location-vector #f)
(test (vector 'here 1 0 1 0) build-source-location-vector (make-srcloc 'here 1 0 1 0))
(test (vector 'here 1 0 1 0) build-source-location-vector (vector 'here 1 0 1 0))
(test (vector 'here 1 0 1 0) build-source-location-vector (list 'here 1 0 1 0))
(test (vector 'here 1 0 1 0) build-source-location-vector (datum->syntax #f null (list 'here 1 0 1 0)))
(test (vector 'here 1 0 1 3) build-source-location-vector (list 'here 1 0 1 0) (vector 'here 2 1 3 1))
(test (vector 'here 1 0 1 3) build-source-location-vector (vector 'here 2 1 3 1) (list 'here 1 0 1 0))
(test (vector #f #f #f #f #f) build-source-location-vector (vector 'here 2 1 3 1) (list 'there 1 0 1 0))
(err/rt-test (build-source-location-vector (list 'bad 0 0 0 0)) exn:fail:contract?)

(define-syntax-rule (test-stx-srcloc (list src line col pos span) fn arg ...)
  (begin
    (test #t syntax? (fn arg ...))
    (test src syntax-source (fn arg ...))
    (test line syntax-line (fn arg ...))
    (test col syntax-column (fn arg ...))
    (test pos syntax-position (fn arg ...))
    (test span syntax-span (fn arg ...))))

(test-stx-srcloc (list #f #f #f #f #f) build-source-location-syntax)
(test-stx-srcloc (list #f #f #f #f #f) build-source-location-syntax #f)
(test-stx-srcloc (list 'here 1 0 1 0) build-source-location-syntax (make-srcloc 'here 1 0 1 0))
(test-stx-srcloc (list 'here 1 0 1 0) build-source-location-syntax (vector 'here 1 0 1 0))
(test-stx-srcloc (list 'here 1 0 1 0) build-source-location-syntax (list 'here 1 0 1 0))
(test-stx-srcloc (list 'here 1 0 1 0) build-source-location-syntax (datum->syntax #f null (list 'here 1 0 1 0)))
(test-stx-srcloc (list 'here 1 0 1 3) build-source-location-syntax (list 'here 1 0 1 0) (vector 'here 2 1 3 1))
(test-stx-srcloc (list 'here 1 0 1 3) build-source-location-syntax (vector 'here 2 1 3 1) (list 'here 1 0 1 0))
(test-stx-srcloc (list #f #f #f #f #f) build-source-location-syntax (vector 'here 2 1 3 1) (list 'there 1 0 1 0))
(err/rt-test (build-source-location-syntax (list 'bad 0 0 0 0)) exn:fail:contract?)

(test #f source-location-known? #f)
(test #t source-location-known? (list 'here 1 0 1 0))
(test #f source-location-known? (list #f #f #f #f #f))
(test #t source-location-known? (vector 'here 1 0 1 0))
(test #f source-location-known? (vector #f #f #f #f #f))
(test #t source-location-known? (make-srcloc 'here 1 0 1 0))
(test #f source-location-known? (make-srcloc #f #f #f #f #f))
(test #t source-location-known? (datum->syntax #f null (list 'here 1 0 1 0)))
(test #f source-location-known? (datum->syntax #f null (list #f #f #f #f #f)))

(test #f source-location-source #f)
(test 'here source-location-source (list 'here 1 2 3 4))
(test 'here source-location-source (vector 'here 1 2 3 4))
(test 'here source-location-source (make-srcloc 'here 1 2 3 4))
(test 'here source-location-source (datum->syntax #f null (list 'here 1 2 3 4)))

(test #f source-location-line #f)
(test 1 source-location-line (list 'here 1 2 3 4))
(test 1 source-location-line (vector 'here 1 2 3 4))
(test 1 source-location-line (make-srcloc 'here 1 2 3 4))
(test 1 source-location-line (datum->syntax #f null (list 'here 1 2 3 4)))

(test #f source-location-column #f)
(test 2 source-location-column (list 'here 1 2 3 4))
(test 2 source-location-column (vector 'here 1 2 3 4))
(test 2 source-location-column (make-srcloc 'here 1 2 3 4))
(test 2 source-location-column (datum->syntax #f null (list 'here 1 2 3 4)))

(test #f source-location-position #f)
(test 3 source-location-position (list 'here 1 2 3 4))
(test 3 source-location-position (vector 'here 1 2 3 4))
(test 3 source-location-position (make-srcloc 'here 1 2 3 4))
(test 3 source-location-position (datum->syntax #f null (list 'here 1 2 3 4)))

(test #f source-location-span #f)
(test 4 source-location-span (list 'here 1 2 3 4))
(test 4 source-location-span (vector 'here 1 2 3 4))
(test 4 source-location-span (make-srcloc 'here 1 2 3 4))
(test 4 source-location-span (datum->syntax #f null (list 'here 1 2 3 4)))

(test #f source-location-end #f)
(test 7 source-location-end (list 'here 1 2 3 4))
(test #f source-location-end (list 'here 1 2 #f 4))
(test #f source-location-end (list 'here 1 2 3 #f))
(test 7 source-location-end (vector 'here 1 2 3 4))
(test #f source-location-end (vector 'here 1 2 #f 4))
(test #f source-location-end (vector 'here 1 2 3 #f))
(test 7 source-location-end (make-srcloc 'here 1 2 3 4))
(test #f source-location-end (make-srcloc 'here 1 2 #f 4))
(test #f source-location-end (make-srcloc 'here 1 2 3 #f))
(test 7 source-location-end (datum->syntax #f null (list 'here 1 2 3 4)))
(test #f source-location-end (datum->syntax #f null (list 'here 1 2 #f 4)))
(test #f source-location-end (datum->syntax #f null (list 'here 1 2 3 #f)))

(test "" source-location->string #f)

(test "" source-location->string (list #f #f #f #f #f))
(test "here" source-location->string (list 'here #f #f #f #f))
(test "here:1.2" source-location->string (list 'here 1 2 3 #f))
(test "here::3" source-location->string (list 'here #f #f 3 #f))
(test "::3-7" source-location->string (list #f #f #f 3 4))
(test ":1.2" source-location->string (list #f 1 2 3 #f))
(test "::3" source-location->string (list #f #f #f 3 #f))
(test "::3-7" source-location->string (list #f #f #f 3 4))

(test "" source-location->string (vector #f #f #f #f #f))
(test "here" source-location->string (vector 'here #f #f #f #f))
(test "here:1.2" source-location->string (vector 'here 1 2 3 #f))
(test "here::3" source-location->string (vector 'here #f #f 3 #f))
(test "::3-7" source-location->string (vector #f #f #f 3 4))
(test ":1.2" source-location->string (vector #f 1 2 3 #f))
(test "::3" source-location->string (vector #f #f #f 3 #f))
(test "::3-7" source-location->string (vector #f #f #f 3 4))

(test "" source-location->string (make-srcloc #f #f #f #f #f))
(test "here" source-location->string (make-srcloc 'here #f #f #f #f))
(test "here:1.2" source-location->string (make-srcloc 'here 1 2 3 #f))
(test "here::3" source-location->string (make-srcloc 'here #f #f 3 #f))
(test "::3-7" source-location->string (make-srcloc #f #f #f 3 4))
(test ":1.2" source-location->string (make-srcloc #f 1 2 3 #f))
(test "::3" source-location->string (make-srcloc #f #f #f 3 #f))
(test "::3-7" source-location->string (make-srcloc #f #f #f 3 4))

(test "" source-location->string (datum->syntax #f null (list #f #f #f #f #f)))
(test "here" source-location->string (datum->syntax #f null (list 'here #f #f #f #f)))
(test "here:1.2" source-location->string (datum->syntax #f null (list 'here 1 2 3 #f)))
(test "here::3" source-location->string (datum->syntax #f null (list 'here #f #f 3 #f)))
(test "::3-7" source-location->string (datum->syntax #f null (list #f #f #f 3 4)))
(test ":1.2" source-location->string (datum->syntax #f null (list #f 1 2 3 #f)))
(test "::3" source-location->string (datum->syntax #f null (list #f #f #f 3 #f)))
(test "::3-7" source-location->string (datum->syntax #f null (list #f #f #f 3 4)))

(test "" source-location->prefix #f)

(test "" source-location->prefix (list #f #f #f #f #f))
(test "here: " source-location->prefix (list 'here #f #f #f #f))
(test "here:1.2: " source-location->prefix (list 'here 1 2 3 #f))
(test "here::3: " source-location->prefix (list 'here #f #f 3 #f))
(test "::3-7: " source-location->prefix (list #f #f #f 3 4))
(test ":1.2: " source-location->prefix (list #f 1 2 3 #f))
(test "::3: " source-location->prefix (list #f #f #f 3 #f))
(test "::3-7: " source-location->prefix (list #f #f #f 3 4))

(test "" source-location->prefix (vector #f #f #f #f #f))
(test "here: " source-location->prefix (vector 'here #f #f #f #f))
(test "here:1.2: " source-location->prefix (vector 'here 1 2 3 #f))
(test "here::3: " source-location->prefix (vector 'here #f #f 3 #f))
(test "::3-7: " source-location->prefix (vector #f #f #f 3 4))
(test ":1.2: " source-location->prefix (vector #f 1 2 3 #f))
(test "::3: " source-location->prefix (vector #f #f #f 3 #f))
(test "::3-7: " source-location->prefix (vector #f #f #f 3 4))

(test "" source-location->prefix (make-srcloc #f #f #f #f #f))
(test "here: " source-location->prefix (make-srcloc 'here #f #f #f #f))
(test "here:1.2: " source-location->prefix (make-srcloc 'here 1 2 3 #f))
(test "here::3: " source-location->prefix (make-srcloc 'here #f #f 3 #f))
(test "::3-7: " source-location->prefix (make-srcloc #f #f #f 3 4))
(test ":1.2: " source-location->prefix (make-srcloc #f 1 2 3 #f))
(test "::3: " source-location->prefix (make-srcloc #f #f #f 3 #f))
(test "::3-7: " source-location->prefix (make-srcloc #f #f #f 3 4))

(test "" source-location->prefix (datum->syntax #f null (list #f #f #f #f #f)))
(test "here: " source-location->prefix (datum->syntax #f null (list 'here #f #f #f #f)))
(test "here:1.2: " source-location->prefix (datum->syntax #f null (list 'here 1 2 3 #f)))
(test "here::3: " source-location->prefix (datum->syntax #f null (list 'here #f #f 3 #f)))
(test "::3-7: " source-location->prefix (datum->syntax #f null (list #f #f #f 3 4)))
(test ":1.2: " source-location->prefix (datum->syntax #f null (list #f 1 2 3 #f)))
(test "::3: " source-location->prefix (datum->syntax #f null (list #f #f #f 3 #f)))
(test "::3-7: " source-location->prefix (datum->syntax #f null (list #f #f #f 3 4)))

(report-errs)