#lang racket

(require rackunit
         "spec-ast.rkt"
         "parser.rkt")

(require/expose "parser.rkt"
                (parse-name
                 parse-command
                 parse-posn-arg-spec
                 parse-help-text
                 parse-once-specs
                 parse-multi-specs
                 parse-flag-specs
                 parse-commands
                 assert-switch-valid!
                 assert-switches-unique!
                 assert-keywords-unique!))

(provide parser-tests)

(define parse-name-tests
  (test-suite "parse-name"
    (test-case "string input"
      (check-equal? (parse-name "foo" "bar") "bar"))
    (test-case "symbol input"
      (check-equal? (parse-name "foo" 'bar) "bar"))
    (test-case "bogus input"
      (check-exn exn:functional-command:parse?
                 (lambda ()
                   (parse-name "foo" 3))))))

(define assert-switch-valid-tests
  (test-suite "assert-switch-valid!"
    (test-case "valid single-char switch"
      (check-not-false (assert-switch-valid! "-x")))
    (test-case "valid long switch"
      (check-not-false (assert-switch-valid! "--long-form")))
    (test-case "bogus long switch"
      (check-exn exn:functional-command:parse?
                 (lambda () (assert-switch-valid! "--xyz!abc"))))
    (test-case "bogus short switch"
      (check-exn exn:functional-command:parse?
                 (lambda () (assert-switch-valid! "-!"))))
    (test-case "short switch too long"
      (check-exn exn:functional-command:parse?
                 (lambda () (assert-switch-valid! "-long-form"))))
    (test-case "reserved switch name"
      (check-exn exn:functional-command:parse?
                 (lambda () (assert-switch-valid! "--help"))))))

(define parse-posn-arg-spec-tests
  (test-suite "parse-posn-arg-spec"
    (test-case "empty arg list"
      (check-equal? (values->list (parse-posn-arg-spec '()))
                    '(() #f)))
    (test-case "singleton argument"
      (check-equal? (values->list (parse-posn-arg-spec '(x)))
                    '((x) #f)))
    (test-case "multiple arguments"
      (check-equal? (values->list (parse-posn-arg-spec '(x y)))
                    '((x y) #f)))
    (test-case "rest arg"
      (check-equal? (values->list (parse-posn-arg-spec '(x y . rest)))
                    '((x y) rest)))
    (test-case "rest arg w/o required args"
      (check-equal? (values->list (parse-posn-arg-spec 'rest))
                    '(() rest)))
    (test-case "bogus input: bad list structure"
      (check-exn exn:functional-command:parse?
                 (lambda () (parse-posn-arg-spec '(x (y) z . a)))))
    (test-case "bogus input: non symbol"
      (check-exn exn:functional-command:parse?
                 (lambda () (parse-posn-arg-spec '(x 3 y)))))))

(define parse-help-tests
  (test-suite "parse-help-text"
    (test-case "single line"
      (check-equal? (parse-help-text "foo") '("foo")))
    (test-case "multiple lines"
      (check-equal? (parse-help-text '("foo" "bar")) '("foo" "bar")))
    (test-case "bogus list element"
      (check-exn exn:functional-command:parse?
                 (lambda () (parse-help-text '("foo" 3)))))
    (test-case "bogus value"
      (check-exn exn:functional-command:parse?
                 (lambda () (parse-help-text 3))))))

(define parse-once-specs-tests
  (test-suite "parse-once-specs"
    (test-case "single spec, no args"
      (check-equal?
       (parse-once-specs '((("-l" "--long-switch") #:long "simple help")))
       (list (optional-flag (set "-l" "--long-switch")
                            '#:long
                            '("simple help")
                            null))))
    (test-case "single spec, arguments"
      (check-equal?
       (parse-once-specs '((("-l" "--long-switch") #:long
                            ("help text" "with multiple lines")
                            foo bar)))
       (list (optional-flag (set "-l" "--long-switch")
                            '#:long
                            '("help text" "with multiple lines")
                            '(foo bar)))))
    (test-case "multiple specs"
      (check-equal?
       (parse-once-specs
        '((("-a" "--switch-a") #:a "foo" foo bar)
          (("-b" "--switch-b") #:b "bar" foo bar)))
       (list
        (optional-flag (set "-a" "--switch-a") '#:a '("foo") '(foo bar))
        (optional-flag (set "-b" "--switch-b") '#:b '("bar") '(foo bar)))))))

(define parse-multi-specs-tests
  (test-suite "parse-multi-specs"
    (test-case "single spec, no args"
      (check-exn exn:functional-command:parse?
                 (lambda ()
                   (parse-multi-specs
                    '((("-l" "--long-switch") #:long "simple help"))))))
    (test-case "single spec, arguments"
      (check-equal?
       (parse-multi-specs '((("-l" "--long-switch") #:long
                             ("help text" "with multiple lines")
                             foo bar)))
       (list (multi-flag (set "-l" "--long-switch")
                         '#:long
                         '("help text" "with multiple lines")
                         '(foo bar)))))
    (test-case "multiple specs"
      (check-equal?
       (parse-multi-specs '((("-a" "--switch-a") #:a "foo" foo bar)
                            (("-b" "--switch-b") #:b "bar" foo bar)))
       (list (multi-flag (set "-a" "--switch-a") '#:a '("foo") '(foo bar))
             (multi-flag (set "-b" "--switch-b") '#:b '("bar") '(foo bar)))))))

(define parse-flag-specs-tests
  (test-suite "parse-flag-specs"
    (test-case "empty"
      (check-equal? (parse-flag-specs null) null))
    (test-case "two optional flags"
      (check-equal?
       (parse-flag-specs '(#:once-each
                           (("-a") #:a "foo" a)
                           (("-b") #:b "bar" b)))
       (list (optional-flag (set "-a") '#:a '("foo") '(a))
             (optional-flag (set "-b") '#:b '("bar") '(b)))))
    (test-case "two optional flags in different sections"
      (check-equal?
       (parse-flag-specs '(#:once-each
                           (("-a") #:a "foo" a)
                           #:once-each
                           (("-b") #:b "bar" b)))
       (list (optional-flag (set "-a") '#:a '("foo") '(a))
             (optional-flag (set "-b") '#:b '("bar") '(b)))))
    (test-case "optional & multi"
      (check-equal?
       (parse-flag-specs '(#:multi
                           (("-a") #:a "foo" a)
                           #:once-each
                           (("-b") #:b "bar" b)))
       (list (multi-flag (set "-a") '#:a '("foo") '(a))
             (optional-flag (set "-b") '#:b '("bar") '(b)))))
    (test-case "optional, multi, and group"
      (check-equal?
       (parse-flag-specs '(#:multi
                           (("-a") #:a "foo" a)
                           #:once-any
                           (("-c") #:c "baz" c)
                           (("-d") #:d "quux" d)
                           #:once-each
                           (("-b") #:b "bar" b)))
       (list (multi-flag (set "-a") '#:a '("foo") '(a))
             (group (list (optional-flag (set "-c") '#:c '("baz") '(c))
                          (optional-flag (set "-d") '#:d '("quux") '(d))))
             (optional-flag (set "-b") '#:b '("bar") '(b)))))
    (test-case "two groups"
      (check-equal?
       (parse-flag-specs '(#:once-any
                           (("-c") #:c "baz" c)
                           (("-d") #:d "quux" d1 d2)
                           #:once-any
                           (("-a") #:a "foo" a)
                           (("-b") #:b ("bar" "bar2") b)))
       (list (group (list (optional-flag (set "-c") '#:c '("baz") '(c))
                          (optional-flag (set "-d") '#:d '("quux") '(d1 d2))))
             (group (list (optional-flag (set "-a") '#:a '("foo") '(a))
                          (optional-flag (set "-b") '#:b '("bar" "bar2")
                                         '(b)))))))))

(define assert-switches-unique-tests
  (test-suite "assert-switches-unique!"
    (test-case "no dups"
      (check-not-false
       (assert-switches-unique!
        "foo"
        (list (multi-flag (set "-b" "--long-2") '#:b '("b") '(b))
              (optional-flag (set "-a" "--long-1") '#:a '("a") null)
              (group
               (list (optional-flag (set "-c" "--long-3") '#:c '("c") null)
                     (optional-flag (set "-d" "--long-4") '#:d '("d")
                                    null)))))))
    (test-case "dups across groups"
      (check-exn
       exn:functional-command:parse?
       (lambda ()
         (assert-switches-unique!
          "foo"
          (list
           (group
            (list (optional-flag (set "-b" "--long-2") '#:b '("b") '(b))
                  (optional-flag (set "-a" "--long-1") '#:a '("a") null)))
           (group
            (list (optional-flag (set "-c" "--long-2") '#:c '("c") null)
                  (optional-flag (set "-d" "--long-4") '#:d '("d")
                                 null))))))))
    (test-case "dup in group & optional"
      (check-exn
       exn:functional-command:parse?
       (lambda ()
         (assert-switches-unique!
          "foo"
          (list (multi-flag (set "-b" "--long-2") '#:b '("b") '(b))
                (optional-flag (set "-a" "--long-4") '#:a '("a") null)
                (group
                 (list (optional-flag (set "-c" "--long-3") '#:c '("c") null)
                       (optional-flag (set "-d" "--long-4") '#:d '("d")
                                      null))))))))
    (test-case "dup outside group"
      (check-exn
       exn:functional-command:parse?
       (lambda ()
         (assert-switches-unique!
          "foo"
          (list (multi-flag (set "-b" "--long-2") '#:b '("b") '(b))
                (optional-flag (set "-a" "--long-2") '#:a '("a") null)
                (group
                 (list (optional-flag (set "-c" "--long-3") '#:c '("c") null)
                       (optional-flag (set "-d" "--long-4") '#:d '("d")
                                      null))))))))))

(define assert-keywords-unique-tests
  (test-suite "assert-keywords-unique!"
    (test-case "no dups"
      (check-not-false
       (assert-keywords-unique!
        "foo"
        (list (multi-flag (set "-b" "--long-2") '#:b '("b") '(b))
              (optional-flag (set "-a" "--long-1") '#:a '("a") null)
              (group
               (list (optional-flag (set "-c" "--long-3") '#:c '("c") null)
                     (optional-flag (set "-d" "--long-4") '#:d '("d")
                                    null)))))))
    (test-case "dups across groups"
      (check-exn
       exn:functional-command:parse?
       (lambda ()
         (assert-keywords-unique!
          "foo"
          (list
           (group
            (list (optional-flag (set "-b" "--long-2") '#:b '("b") '(b))
                  (optional-flag (set "-a" "--long-1") '#:a '("a") null)))
           (group
            (list (optional-flag (set "-c" "--long-3") '#:a '("c") null)
                  (optional-flag (set "-d" "--long-4") '#:d '("d")
                                 null))))))))
    (test-case "dups in group & optional"
      (check-exn
       exn:functional-command:parse?
       (lambda ()
         (assert-keywords-unique!
          "foo"
          (list (multi-flag (set "-b" "--long-2") '#:b '("b") '(b))
                (optional-flag (set "-a" "--long-4") '#:c '("a") null)
                (group
                 (list (optional-flag (set "-c" "--long-3") '#:c '("c") null)
                       (optional-flag (set "-d" "--long-4") '#:d '("d")
                                      null))))))))
    (test-case "dup outside group"
      (check-exn
       exn:functional-command:parse?
       (lambda ()
         (assert-keywords-unique!
          "foo"
          (list
           (multi-flag (set "-b" "--long-2") '#:b '("b") '(b))
           (optional-flag (set "-a" "--long-4") '#:b '("a") null)
           (group
            (list (optional-flag (set "-c" "--long-3") '#:c '("c") null)
                  (optional-flag (set "-d" "--long-4") '#:d '("d")
                                 null))))))))))

(define parse-command-tests
  (test-suite "parse-command"
    (test-case "basic"
      (let ([cmd-name "show"]
            [short-help "Shows detailed info about a task"]
            [long-help
             "Displays full details about the task with the identifier <id>."]
            [f (lambda args args)])
      (check-equal?
       (parse-command
        `(,cmd-name ,short-help ,long-help (id) ,f))
       (command cmd-name short-help long-help '(id) #f null f))))
    (test-case "rest args"
      (let ([f (lambda args args)])
        (check-equal?
         (parse-command
          `("add" "foo" "bar" summary
            #:once-each
            (("-s" "--start-date") #:start-date "x" date)
            (("-d" "--due-date") #:due-date "y" date)
            #:once-any
            (("-n" "--note") #:note "n" filename)
            (("-e" "--edit-note") #:edit-note "e")
            #:once-each
            (("-u" "--url") #:url "u" url)
            ,f))
         (command "add" "foo" "bar"
                  null
                  'summary
                  (list (optional-flag (set "-s" "--start-date")
                                       '#:start-date
                                       '("x")
                                       '(date))
                        (optional-flag (set "-d" "--due-date")
                                       '#:due-date
                                       '("y")
                                       '(date))
                        (group
                         (list
                          (optional-flag (set "-n" "--note")
                                         '#:note
                                         '("n")
                                         '(filename))
                          (optional-flag (set "-e" "--edit-note")
                                         '#:edit-note
                                         '("e")
                                         null)))
                        (optional-flag (set "-u" "--url")
                                       '#:url
                                       '("u")
                                       '(url)))
                  f))))
    (test-case "duplicate switch"
      (check-exn
       exn:functional-command:parse?
       (lambda ()
         (parse-command
          `("add" "foo" "bar" summary
            #:once-each
            (("-s" "--start-date") #:start-date "x" date)
            (("-d" "--note") #:due-date "y" date)
            #:once-any
            (("-n" "--note") #:note "n" filename)
            (("-e" "--edit-note") #:edit-note "e")
            #:once-each
            (("-u" "--url") #:url "u" url)
            ,(lambda (x) x))))))
    (test-case "duplicate keyword"
      (check-exn
       exn:functional-command:parse?
       (lambda ()
         (parse-command
          `("add" "foo" "bar" summary
            #:once-each
            (("-s" "--start-date") #:start-date "x" date)
            (("-d" "--due-date") #:due-date "y" date)
            #:once-any
            (("-n" "--note") #:note "n" filename)
            (("-e" "--edit-note") #:edit-note "e")
            #:once-each
            (("-u" "--url") #:note "u" url)
            ,(lambda (x) x))))))
    (test-case "help not string"
      (check-exn
       exn:functional-command:parse?
       (lambda ()
         (parse-command
          `(add foo "bar" ,(lambda (x) x))))))
    (test-case "missing function"
      (check-exn
       exn:functional-command:parse?
       (lambda ()
         (parse-command '(add "foo" "bar")))))
    (test-case "crud after function"
      (check-exn
       exn:functional-command:parse?
       (lambda ()
         (parse-command `(add "foo" "bar" ,(lambda (x) x) positional-arg)))))
    (test-case "reserved command name"
      (check-exn
       exn:functional-command:parse?
       (lambda ()
         (parse-command `(help "foo" "bar" ,(lambda (x) x))))))
    (test-case "reserved switch name"
      (check-exn
       exn:functional-command:parse?
       (lambda ()
         (parse-command `(foo "bar" "baz"
                              #:once-each
                              (("-h" "--help" #:help "x"))
                              ,(lambda (x) x))))))))

(define parse-commands-tests
  (test-suite "Tests for parse-commands"
    (test-case "empty"
      (check-exn
       exn:functional-command:parse?
       (lambda () (parse-commands null))))
    (test-case "no dups"
      (let ([f (lambda args args)])
        (check-equal?
         (parse-commands
          `((show "show" "show long" (id) ,f)
            (complete "complete" "complete long" (id) ,f)))
         (list (command "show" "show" "show long" '(id) #f null f)
               (command "complete" "complete" "complete long"
                        '(id) #f null f)))))
    (test-case "dup cmd name"
      (check-exn
       exn:functional-command:parse?
       (lambda ()
         (parse-commands
          `((show "show" "show long" (id) ,(lambda (x) x))
            (show "complete" "complete long" (id) ,(lambda (x) x)))))))))

(define parse-spec-tests
  (let ([f (lambda args args)])
    (test-suite "parse-spec"
      (test-equal? "simple"
        (parse-spec `("test" "spec for testing"
                      (show "show" "show long" (id) ,f)
                      (complete "complete" "complete long" (id) ,f)))
        (spec "test"
              "spec for testing"
              (list (command "show" "show" "show long" '(id) #f null f)
                    (command "complete" "complete" "complete long"
                             '(id) #f null f))))
      (test-exn "bad help text"
        exn:functional-command:parse?
        (lambda ()
          (parse-spec `("test" invalid-help
                        (show "show" "show long" (id) ,f)))))
      (test-exn "bad syntax"
        exn:functional-command:parse?
        (lambda () (parse-spec '(x y)))))))

(define spec-parser-tests
  (test-suite "Tests for the command line specification parser"
    parse-name-tests
    assert-switch-valid-tests
    parse-posn-arg-spec-tests
    parse-help-tests
    parse-once-specs-tests
    parse-multi-specs-tests
    parse-flag-specs-tests
    assert-switches-unique-tests
    assert-keywords-unique-tests
    parse-command-tests
    parse-commands-tests
    parse-spec-tests))

(define parser-tests
  (test-suite "Tests for parser.rkt"
    spec-parser-tests))

(define-syntax values->list
  (lambda (stx)
    (syntax-case stx ()
      [(values->list e)
       #'(call-with-values (lambda () e) list)])))