#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)))
(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))