(require 'database-commands)
(require 'databases)
(require 'getopt-parameters)
(require 'parameters)
(require 'getopt)
(require 'fluid-let)
(require 'printf)

(define my-rdb (add-command-tables (create-database #f 'alist-table)))

(define-tables my-rdb
  '(foo-params
    *parameter-columns*
    *parameter-columns*
    ((1 single-string single string
        (lambda (pl) '("str")) #f "single string")
     (2 nary-symbols nary symbol
        (lambda (pl) '()) #f "zero or more symbols")
     (3 nary1-symbols nary1 symbol
        (lambda (pl) '(symb)) #f "one or more symbols")
     (4 optional-number optional ordinal
        (lambda (pl) '()) #f "zero or one number")
     (5 flag boolean boolean
        (lambda (pl) '(#f)) #f "a boolean flag")))
  '(foo-pnames
    ((name string))
    ((parameter-index ordinal))
    (("s" 1)
     ("single-string" 1)
     ("n" 2)
     ("nary-symbols" 2)
     ("N" 3)
     ("nary1-symbols" 3)
     ("o" 4)
     ("optional-number" 4)
     ("f" 5)
     ("flag" 5)))
  '(my-commands
    ((name symbol))
    ((parameters parameter-list)
     (parameter-names parameter-name-translation)
     (procedure expression)
     (documentation string))
    ((foo
      foo-params
      foo-pnames
      (lambda (rdb) (lambda args (print args)))
      "test command arguments"))))

(define (dbutil:serve-command-line rdb command-table command argv)
  (set! *argv* (if (vector? argv) (vector->list argv) argv))
  ((make-command-server rdb command-table)
   command
   (lambda (comname comval options positions
                    arities types defaulters dirs aliases)
     (apply comval (getopt->arglist options positions
                    arities types defaulters dirs aliases)))))

(define (cmd . opts)
  (fluid-let ((*optind* 1))
    (printf "%-34s ⇒ "
            (call-with-output-string
             (lambda (pt) (write (cons 'cmd opts) pt))))
    (set! opts (cons "cmd" opts))
    (force-output)
    (dbutil:serve-command-line
     my-rdb 'my-commands 'foo (length opts) opts)))

(cmd)                              ⇒ ("str" () (symb) () #f)
(cmd "-f")                         ⇒ ("str" () (symb) () #t)
(cmd "--flag")                     ⇒ ("str" () (symb) () #t)
(cmd "-o177")                      ⇒ ("str" () (symb) (177) #f)
(cmd "-o" "177")                   ⇒ ("str" () (symb) (177) #f)
(cmd "--optional" "621")           ⇒ ("str" () (symb) (621) #f)
(cmd "--optional=621")             ⇒ ("str" () (symb) (621) #f)
(cmd "-s" "speciality")            ⇒ ("speciality" () (symb) () #f)
(cmd "-sspeciality")               ⇒ ("speciality" () (symb) () #f)
(cmd "--single" "serendipity")     ⇒ ("serendipity" () (symb) () #f)
(cmd "--single=serendipity")       ⇒ ("serendipity" () (symb) () #f)
(cmd "-n" "gravity" "piety")       ⇒ ("str" () (piety gravity) () #f)
(cmd "-ngravity" "piety")          ⇒ ("str" () (piety gravity) () #f)
(cmd "--nary" "chastity")          ⇒ ("str" () (chastity) () #f)
(cmd "--nary=chastity" "")         ⇒ ("str" () ( chastity) () #f)
(cmd "-N" "calamity")              ⇒ ("str" () (calamity) () #f)
(cmd "-Ncalamity")                 ⇒ ("str" () (calamity) () #f)
(cmd "--nary1" "surety")           ⇒ ("str" () (surety) () #f)
(cmd "--nary1=surety")             ⇒ ("str" () (surety) () #f)
(cmd "-N" "levity" "fealty")       ⇒ ("str" () (fealty levity) () #f)
(cmd "-Nlevity" "fealty")          ⇒ ("str" () (fealty levity) () #f)
(cmd "--nary1" "surety" "brevity") ⇒ ("str" () (brevity surety) () #f)
(cmd "--nary1=surety" "brevity")   ⇒ ("str" () (brevity surety) () #f)
(cmd "-?")
-|
Usage: cmd [OPTION ARGUMENT ...] ...

  -f, --flag
  -o, --optional[=]<number>
  -n, --nary[=]<symbols> ...
  -N, --nary1[=]<symbols> ...
  -s, --single[=]<string>

ERROR: getopt->parameter-list "unrecognized option" "-?"