#lang scheme

(require (planet schematics/schemeunit:2:10/test)
         "checks.ss"
         "../text.ss")

(provide test-text)

(define test-text
  (test-suite "text.ss"
    (test-suite "text/c"
      (test-case "accept string"
        (check-contract-accept text/c "text"))
      (test-case "accept byte string"
        (check-contract-accept text/c #"text"))
      (test-case "accept symbol"
        (check-contract-accept text/c 'text))
      (test-case "accept keyword"
        (check-contract-accept text/c '#:text))
      (test-case "accept string literal"
        (check-contract-accept text/c #'"text"))
      (test-case "accept byte string literal"
        (check-contract-accept text/c #'#"text"))
      (test-case "accept identifier"
        (check-contract-accept text/c #'text))
      (test-case "accept keyword literal"
        (check-contract-accept text/c #'#:text))
      (test-case "reject non-text"
        (check-contract-reject text/c '(not text))))
    (test-suite "text?"
      (test-case "accept string"
        (check-pred text? "text"))
      (test-case "accept byte string"
        (check-pred text? #"text"))
      (test-case "accept symbol"
        (check-pred text? 'text))
      (test-case "accept keyword"
        (check-pred text? '#:text))
      (test-case "accept string literal"
        (check-pred text? #'"text"))
      (test-case "accept byte string literal"
        (check-pred text? #'#"text"))
      (test-case "accept identifier"
        (check-pred text? #'text))
      (test-case "accept keyword literal"
        (check-pred text? #'#:text))
      (test-case "reject non-text"
        (check-false (text? '(not text)))))
    (test-suite "string-literal?"
      (test-case "accept" (check-true (string-literal? #'"string")))
      (test-case "reject" (check-false (string-literal? "string"))))
    (test-suite "keyword-literal?"
      (test-case "accept" (check-true (keyword-literal? #'#:keyword)))
      (test-case "reject" (check-false (keyword-literal? '#:keyword))))
    (test-suite "bytes-literal?"
      (test-case "accept" (check-true (bytes-literal? #'#"bytes")))
      (test-case "reject" (check-false (bytes-literal? #"bytes"))))
    (test-suite "text=?"
      (test-case "string = string"
        (check text=? "abc" (string-copy "abc")))
      (test-case "string = identifier"
        (check text=? "car" #'car))
      (test-case "identifier = identifier, different bindings"
        (check text=? #'car (datum->syntax #f 'car))))
    (test-suite "text>?"
      (test-case "string > string"
        (check text>? "def" (string-copy "abc")))
      (test-case "string > identifier"
        (check text>? "car" #'bar))
      (test-case "identifier > identifier"
        (check text>? #'car (datum->syntax #f 'bar))))
    (test-suite "text<?"
      (test-case "string < string"
        (check text<? "abc" (string-copy "def")))
      (test-case "string < identifier"
        (check text<? "bar" #'car))
      (test-case "identifier < identifier"
        (check text<? #'bar (datum->syntax #f 'car))))
    (test-suite "text->string"
      (test-case "single" (check-equal? (text->string 'abc) "abc"))
      (test-case "multiple" (check-equal? (text->string 'a "b" #'c) "abc")))
    (test-suite "text->symbol"
      (test-case "single" (check-equal? (text->symbol "abc") 'abc))
      (test-case "multiple" (check-equal? (text->symbol 'a "b" #'c) 'abc)))
    (test-suite "text->keyword"
      (test-case "single" (check-equal? (text->keyword #'abc) '#:abc))
      (test-case "multiple" (check-equal? (text->keyword 'a "b" #'c) '#:abc)))
    (test-suite "text->bytes"
      (test-case "single" (check-equal? (text->bytes "abc") #"abc"))
      (test-case "multiple" (check-equal? (text->bytes 'a "b" #'c) #"abc")))
    (test-suite "text->identifier"
      (test-case "single, no context"
        (check-equal? (syntax-e (text->identifier "abc")) 'abc))
      (test-case "multiple w/ context"
        (check bound-identifier=?
               (text->identifier #:stx #'here 'a "b" #'c)
               #'abc)))
    (test-suite "text->string-literal"
      (test-case "single"
        (check-equal? (syntax-e (text->string-literal '#:abc)) "abc"))
      (test-case "multiple"
        (check-equal?
         (syntax-e (text->string-literal #:stx #'here 'a "b" #'c))
         "abc")))
    (test-suite "text->keyword-literal"
      (test-case "single"
        (check-equal? (syntax-e (text->keyword-literal #"abc")) '#:abc))
      (test-case "multiple"
        (check-equal?
         (syntax-e (text->keyword-literal #:stx #'here 'a "b" #'c))
         '#:abc)))
    (test-suite "text->bytes-literal"
      (test-case "single"
        (check-equal? (syntax-e (text->bytes-literal 'abc)) #"abc"))
      (test-case "multiple"
        (check-equal?
         (syntax-e (text->bytes-literal #:stx #'here 'a "b" #'c))
         #"abc")))
    (test-suite "text-append"
      (test-case "text equality"
        (check text=? (text-append 'a "b" #'c) "abc"))
      (test-case "string conversion"
        (check-equal? (text->string (text-append 'a "b" #'c)) "abc"))
      (test-case "keyword conversion"
        (check-equal? (text->keyword (text-append 'a "b" #'c)) '#:abc))
      (test-case "identifier conversion"
        (check bound-identifier=?
               (text->identifier #:stx #'here (text-append 'a "b" #'c))
               #'abc)))))