usage-tests.rkt
#lang racket

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

(require/expose "usage.rkt" (print-flag-info print-flag-line sort-for-printing))

(provide usage-tests)

(define baseline-command (command "cmd"
                                  "short help"
                                  "longer help"
                                  null
                                  #f
                                  null
                                  (lambda x x)))

;; footer that appears at the end of print-flag-info's output.
(define switch-info-footer
  (string-append "  --help : Show this help\n"
                 " * Asterisks indicate options allowed multiple times.\n"
                 " /|\\ Brackets indicate mutually exclusive options.\n"))

(define print-flag-info-tests
  (test-suite "print-flag-info"
    (test-equal? "simple switches"
     (with-output-to-string
       (lambda ()
         (print-flag-info
          (list
           (optional-flag (set "-x") '#:x '("enable x") null)
           (optional-flag (set "-y" "--with-y") '#:y '("enable y") '(y-val))))))
     (string-append "  -x : enable x\n"
                    "  -y, --with-y <y-val> : enable y\n"
                    switch-info-footer))
    (test-equal? "multi flags"
      (with-output-to-string
        (lambda ()
          (print-flag-info
           (list
            (multi-flag (set "-x") '#:x '("enable x") '(x-val))
            (multi-flag (set "-y" "--with-y") '#:y '("enable y") '(yv zv))))))
      (string-append "* -x <x-val> : enable x\n"
                     "* -y, --with-y <yv> <zv> : enable y\n"
                     switch-info-footer))
    (test-equal? "group"
      (with-output-to-string
        (lambda ()
          (print-flag-info
           (list
            (group
             (list
              (optional-flag (set "-x") '#:x '("enable x") null)
              (optional-flag (set "-y" "--with-y")
                             '#:y
                             '("enable y")
                             '(y-val))
              (optional-flag (set "-z") '#:z '("z flag") '(a b))))))))
      (string-append "/ -x : enable x\n"
                     "| -y, --with-y <y-val> : enable y\n"
                     "\\ -z <a> <b> : z flag\n"
                     switch-info-footer))
    (test-equal? "combined"
      (with-output-to-string
        (lambda ()
          (print-flag-info
           (list
            (optional-flag (set "-x") '#:x '("enable x") null)
            (optional-flag (set "-y" "--with-y") '#:y '("enable y") '(y-val))
            (multi-flag (set "-x") '#:x '("enable x") '(x-val))
            (multi-flag (set "-y" "--with-y") '#:y '("enable y") '(yv zv))
            (group
             (list
              (optional-flag (set "-x") '#:x '("enable x") null)
              (optional-flag (set "-y" "--with-y") '#:y '("enable y") '(y-val))
              (optional-flag (set "-z") '#:z '("z flag") '(a b))))))))
      (string-append "  -x : enable x\n"
                     "  -y, --with-y <y-val> : enable y\n"
                     "* -x <x-val> : enable x\n"
                     "* -y, --with-y <yv> <zv> : enable y\n"
                     "/ -x : enable x\n"
                     "| -y, --with-y <y-val> : enable y\n"
                     "\\ -z <a> <b> : z flag\n"
                     switch-info-footer))))

(define print-flag-line-tests
  (test-suite "print-flag-line"
    (test-equal? "simple switch"
                 (with-output-to-string
                   (lambda ()
                     (print-flag-line " "
                                      (set "-x")
                                      null
                                      '("sample switch"))))
                 "  -x : sample switch\n")
    (test-equal? "simple switch with one arg"
                 (with-output-to-string
                   (lambda ()
                     (print-flag-line " "
                                      (set "-x")
                                      '(arg)
                                      '("sample switch"))))
                 "  -x <arg> : sample switch\n")
    (test-equal? "multiple switches, flags"
                 (with-output-to-string
                   (lambda ()
                     (print-flag-line " "
                                      (set "-x" "--long-switch")
                                      '(foo bar)
                                      '("sample switch"))))
                 "  -x, --long-switch <foo> <bar> : sample switch\n")))

(define sort-for-printing-tests
  (test-suite "sort-for-printing"
    (test-equal? "all short switches"
                 (sort-for-printing '("-x" "-A" "-a" "-r" "-m"))
                 '("-A" "-a" "-m" "-r" "-x"))
    (test-equal? "all long switches"
                 (sort-for-printing '("--foo" "--bar" "--quux"))
                 '("--bar" "--foo" "--quux"))
    (test-equal? "mixed short & long"
                 (sort-for-printing '("--foo" "-x" "-A" "--bar" "-a"
                                      "-r" "--quux" "-m"))
                 '("-A" "-a" "-m" "-r" "-x"
                   "--bar" "--foo" "--quux"))))

(define print-command-usage-tests
  (test-suite "print-command-usage"
    (test-equal? "no args"
      (with-output-to-string
        (lambda ()
          (print-command-usage baseline-command)))
          #<<EOF
cmd: short help
usage: cmd

longer help

EOF
)
    (test-equal? "only positional args"
      (with-output-to-string
        (lambda ()
          (print-command-usage
           (struct-copy command baseline-command
                        [positional-args '(x y z)]))))
          #<<EOF
cmd: short help
usage: cmd <x> <y> <z>

longer help

EOF
)
    (test-equal? "only rest arg"
      (with-output-to-string
        (lambda ()
          (print-command-usage
           (struct-copy command baseline-command
                        [rest-arg 'rest]))))
      #<<EOF
cmd: short help
usage: cmd [<rest> ...]

longer help

EOF
)
    (test-equal? "positional & rest args"
      (with-output-to-string
        (lambda ()
          (print-command-usage
           (struct-copy command baseline-command
                        [positional-args '(x y z)]
                        [rest-arg 'rest]))))
      #<<EOF
cmd: short help
usage: cmd <x> <y> <z> [<rest> ...]

longer help

EOF
)
    (test-equal? "positional, rest, and flags"
      (with-output-to-string
        (lambda ()
          (print-command-usage
           (struct-copy
            command baseline-command
            [positional-args '(x y z)]
            [rest-arg 'rest]
            [flags
             (list (optional-flag (set "-x") '#:x '("enable x") null)
                   (optional-flag (set "-y" "--with-y")
                                  '#:y
                                  '("enable y")
                                  '(y-val))
                   (multi-flag (set "-a") '#:a '("enable a") '(a-val))
                   (multi-flag (set "-b" "--with-b")
                               '#:b
                               '("enable b")
                               '(bv cv))
                   (group (list (optional-flag (set "-d")
                                               '#:d
                                               '("enable d")
                                               null)
                                (optional-flag (set "-e" "--with-e")
                                               '#:e
                                               '("enable e")
                                               '(e-val))
                                (optional-flag (set "-f")
                                               '#:f
                                               '("f flag")
                                               '(f-a f-b)))))]))))
      (string-append #<<EOF
cmd: short help
usage: cmd [<option> ...] <x> <y> <z> [<rest> ...]

longer help

Valid options:
  -x : enable x
  -y, --with-y <y-val> : enable y
* -a <a-val> : enable a
* -b, --with-b <bv> <cv> : enable b
/ -d : enable d
| -e, --with-e <e-val> : enable e
\ -f <f-a> <f-b> : f flag

EOF
       switch-info-footer))
    ))

(define usage-tests
  (test-suite "Tests of usage printing"
    print-flag-info-tests
    print-flag-line-tests
    sort-for-printing-tests
    print-command-usage-tests))