#lang scheme

(require mzlib/etc
         planet/util
         "checks.ss"
         "../syntax.ss")

(provide test-syntax)

(define test-syntax
  (test-suite "syntax.ss"

    (test-suite "Contracts"

      (test-suite "syntax-datum/c"
        (test-case "accept"
          (check-contract-accept
           (syntax-datum/c (listof (listof natural-number/c)))
           #'((0 1 2) () (3 4) (5))))
        (test-case "reject ill-formed syntax"
          (check-contract-reject
           (syntax-datum/c (listof (listof natural-number/c)))
           #'((x y z))))
        (test-case "reject non-syntax"
          (check-contract-reject (syntax-datum/c string?) "xyz")))

      (test-suite "syntax-listof/c"
        (test-case "accept"
          (check-contract-accept (syntax-listof/c identifier?) #'(a b c)))
        (test-case "reject ill-formed element"
          (check-contract-reject (syntax-listof/c identifier?) #'(1 2 3)))
        (test-case "reject improper list"
          (check-contract-reject (syntax-listof/c identifier?) #'(a b . c)))
        (test-case "reject non-syntax"
          (check-contract-reject (syntax-listof/c identifier?) '(#'a #'b #'c))))

      (test-suite "syntax-list/c"
        (test-case "accept"
          (check-contract-accept
           (syntax-list/c identifier? (syntax/c string?))
           #'(a "b")))
        (test-case "reject extra element"
          (check-contract-reject
           (syntax-list/c identifier? (syntax/c string?))
           #'(a "b" #:c)))
        (test-case "reject ill-formed element"
          (check-contract-reject
           (syntax-list/c identifier? (syntax/c string?))
           #'(a b)))
        (test-case "reject improper list"
          (check-contract-reject
           (syntax-list/c identifier? (syntax/c string?))
           #'(a "b" . c)))
        (test-case "reject non-syntax"
          (check-contract-reject
           (syntax-list/c identifier? (syntax/c string?))
           '(#'a #'"b")))))

    (test-suite "Syntax Lists"

      (test-suite "syntax-map"
        (test-case "identifiers to symbols"
          (check-equal? (syntax-map syntax-e #'(a b c)) '(a b c)))))

    (test-suite "Syntax Conversions"

      (test-suite "to-syntax"
        (test-case "symbol + context = identifier"
          (check bound-identifier=?
                 (to-syntax #:stx #'here 'id)
                 #'id)))

      (test-suite "to-datum"
        (test-case "syntax"
          (check-equal? (to-datum #'((a b) () (c)))
                        '((a b) () (c))))
        (test-case "non-syntax"
          (check-equal? (to-datum '((a b) () (c)))
                        '((a b) () (c))))
        (test-case "nested syntax"
          (let* ([stx-ab #'(a b)]
                 [stx-null #'()]
                 [stx-c #'(c)])
            (check-equal? (to-datum (list stx-ab stx-null stx-c))
                          (list stx-ab stx-null stx-c))))))

    (test-suite "Syntax Source Locations"

      (test-suite "syntax-source-file-name"
        (test-case "here"
          (check-equal? (syntax-source-file-name #'here)
                        (this-expression-file-name)))
        (test-case "fail"
          (check-equal? (syntax-source-file-name (datum->syntax #f 'fail))
                        #f)))

      (test-suite "syntax-source-directory"
        (test-case "here"
          (check-equal? (syntax-source-directory #'here)
                        (this-expression-source-directory)))
        (test-case "fail"
          (check-equal? (syntax-source-directory (datum->syntax #f 'fail))
                        #f)))

      (test-suite "syntax-source-planet-package"
        (test-case "here"
          (check-equal? (syntax-source-planet-package #'here)
                        (this-package-version)))
        (test-case "fail"
          (check-equal? (syntax-source-planet-package (datum->syntax #f 'fail))
                        #f)))

      (test-suite "syntax-source-planet-package-owner"
        (test-case "here"
          (check-equal? (syntax-source-planet-package-owner #'here)
                        (this-package-version-owner)))
        (test-case "fail"
          (check-equal? (syntax-source-planet-package-owner
                         (datum->syntax #f 'fail))
                        #f)))

      (test-suite "syntax-source-planet-package-name"
        (test-case "here"
          (check-equal? (syntax-source-planet-package-name #'here)
                        (this-package-version-name)))
        (test-case "fail"
          (check-equal? (syntax-source-planet-package-name
                         (datum->syntax #f 'fail))
                        #f)))

      (test-suite "syntax-source-planet-package-major"
        (test-case "here"
          (check-equal? (syntax-source-planet-package-major #'here)
                        (this-package-version-maj)))
        (test-case "fail"
          (check-equal? (syntax-source-planet-package-major
                         (datum->syntax #f 'fail))
                        #f)))

      (test-suite "syntax-source-planet-package-minor"
        (test-case "here"
          (check-equal? (syntax-source-planet-package-minor #'here)
                        (this-package-version-min)))
        (test-case "fail"
          (check-equal? (syntax-source-planet-package-minor
                         (datum->syntax #f 'fail))
                        #f)))

      (test-suite "syntax-source-planet-package-symbol"
        (test-case "here"
          (check-equal? (syntax-source-planet-package-symbol #'here)
                        (string->symbol
                         (format "~a/~a:~a:~a"
                                 (this-package-version-owner)
                                 (regexp-replace "\\.plt$"
                                                 (this-package-version-name)
                                                 "")
                                 (this-package-version-maj)
                                 (this-package-version-min)))))
        (test-case "here/there"
          (check-equal? (syntax-source-planet-package-symbol #'here "there")
                        (string->symbol
                         (format "~a/~a:~a:~a/there"
                                 (this-package-version-owner)
                                 (regexp-replace "\\.plt$"
                                                 (this-package-version-name)
                                                 "")
                                 (this-package-version-maj)
                                 (this-package-version-min)))))
        (test-case "fail"
          (check-equal? (syntax-source-planet-package-minor
                         (datum->syntax #f 'fail))
                        #f))))

    (test-suite "Pattern Bindings"

      (test-suite "with-syntax*"
        (test-case "identifier"
          (check bound-identifier=?
                 (with-syntax* ([a #'id] [b #'a]) #'b)
                 #'id))))))