Some getopt improvements: call-with-getopt

doc/reference/getopt.md

@@ -9,9 +9,7 @@ The `:std/getopt` library provides facilities for command line argument parsing.
 ## Interface
 
 ### getopt
-
-::: tip usage
-```
+```scheme
 (getopt <specifier> ...)
 => <parser>
 
@@ -27,41 +25,34 @@ cmd-specifier:
  (rest-arguments id [help: text] [value: proc])
 
 ```
-:::
+
 `getopt` creates a command line parser, which can be used to parse arguments
 with `getopt-parse`.
 
 ### getopt-parse
-
-::: tip usage
-```
+```scheme
 (getopt-parse <parser> args)
 => (values cmd-id options)
    options
 ```
-:::
+
 `getopt-parse` accepts a parser and a list of string arguments and parses
 according to the parser specification. If it is parsing a specification with
 subcommands, it returns two values, the command id and a hash table with the
 parsed options. Otherwise it just returns the hash table with the parsed options.
 An exception is raised if parsing the arguments fails.
 
 ### getopt-error?
-
-::: tip usage
-```
+```scheme
 (getopt-error? obj)
 => boolean
 ```
-:::
 
 If parsing fails, then a `getopt-error` is raised, which can be guarded with
 `getopt-error?`.
 
 ### getopt-display-help
-
-::: tip usage
-```
+```scheme
 (getopt-display-help <tip> program-name [port = (current-output-port)])
 
 
@@ -70,46 +61,58 @@ tip:
  <parser>
  <command>
 ```
-:::
 
 The procedure `getopt-display-help` can be used to display
 a help message for a getopt error according to the argument specification.
 
 ### getopt-display-help-topic
-::: tip usage
-```
+```scheme
 (getopt-display-help-topic <parser> topic program-name [port = (current-output-port)])
 ```
-:::
 
 The procedure `getopt-display-help-topic` can be used to display a help page
 for a subcommand.
 
 ### getopt?
-
-::: tip usage
-```
+```scheme
 (getopt? obj)
 => boolean
 ```
-:::
 
 Returns true if the object is a getopt parser
 
 ### getopt-object?
-
-::: tip usage
-```
+```scheme
 (getopt-object? obj)
 => boolean
 ```
-:::
 
 Returns true if the object is a getopt command or command specifier.
 
+### call-with-getopt
+```scheme
+(call-with-getopt proc args
+                  program: program
+                  help: (help #f)
+                  exit-on-error: (exit-on-error? #t)
+                  . gopts)
+```
+
+This shim around getopt parsing eliminates all the repetitive
+boilerplate around argument parsing with getopt.
+
+It creates a getopt parser that parses with options `gopts`, automatically
+including a help option or command accordingly.
+
+It then uses the parser to pare `args`, handling the exceptions and
+displayin help accordingly; if `exit-on-error` is true (the default),
+then parsing errors will exit the program.
+
+If the parse succeeds it invokes `proc` with the output of the parse.
+
 ## Example
 
-For an example, here is a command line parser for the `gxpkg` program:
+For an example, here the a command line parser for the `gxpkg` program:
 ```scheme
 (def (main . args)
   (def install-cmd
@@ -140,49 +143,46 @@ For an example, here is a command line parser for the `gxpkg` program:
     (command 'list help: "list installed packages"))
   (def retag-cmd
     (command 'retag help: "retag installed packages"))
-  (def help-cmd
-    (command 'help help: "display help; help <command> for command help"
-             (optional-argument 'command value: string->symbol)))
-  (def gopt
-    (getopt install-cmd
-            uninstall-cmd
-            update-cmd
-            link-cmd
-            unlink-cmd
-            build-cmd
-            clean-cmd
-            list-cmd
-            retag-cmd
-            help-cmd))
-
-  (try
-   (let ((values cmd opt) (getopt-parse gopt args))
-     (let-hash opt
-       (case cmd
-         ((install)
-          (install-pkgs .pkg))
-         ((uninstall)
-          (uninstall-pkgs .pkg .?force))
-         ((update)
-          (update-pkgs .pkg))
-         ((link)
-          (link-pkg .pkg .src))
-         ((unlink)
-          (unlink-pkgs .pkg .?force))
-         ((build)
-          (build-pkgs .pkg))
-         ((clean)
-          (clean-pkgs .pkg))
-         ((list)
-          (list-pkgs))
-         ((retag)
-          (retag-pkgs))
-         ((help)
-          (getopt-display-help-topic gopt .?command "gxkpg")))))
-   (catch (getopt-error? exn)
-     (getopt-display-help exn "gxpkg" (current-error-port))
-     (exit 1))
-   (catch (e)
-     (display-exception e (current-error-port))
-     (exit 2))))
+  (def search-cmd
+    (command 'search help: "search the package directory"
+             (rest-arguments 'keywords help: "keywords to search for")))
+
+  (call-with-getopt gxpkg-main args
+    program: "gxpkg"
+    help: "The Gerbil Package Manager"
+    install-cmd
+    uninstall-cmd
+    update-cmd
+    link-cmd
+    unlink-cmd
+    build-cmd
+    clean-cmd
+    list-cmd
+    retag-cmd
+    search-cmd))
+
+(def (gxpkg-main cmd opt)
+  (let-hash opt
+    (case cmd
+      ((install)
+       (install-pkgs .pkg))
+      ((uninstall)
+       (uninstall-pkgs .pkg .?force))
+      ((update)
+       (update-pkgs .pkg))
+      ((link)
+       (link-pkg .pkg .src))
+      ((unlink)
+       (unlink-pkgs .pkg .?force))
+      ((build)
+       (build-pkgs .pkg))
+      ((clean)
+       (clean-pkgs .pkg))
+      ((list)
+       (list-pkgs))
+      ((retag)
+       (retag-pkgs))
+      ((search)
+       (search-pkgs .keywords)))))
+
 ```

src/std/build-deps

@@ -204,7 +204,9 @@
    gerbil/gambit/ports
    std/misc/repr))
  (std/assert "assert" (gerbil/core gerbil/expander std/format std/sugar))
- (std/getopt "getopt" (gerbil/core std/error std/format))
+ (std/getopt
+  "getopt"
+  (gerbil/core gerbil/gambit/exceptions std/error std/format std/sugar))
  (std/logger
   "logger"
   (gerbil/core

src/std/getopt.ss

@@ -2,7 +2,9 @@
 ;;; (C) vyzo
 ;;; Command-line option and command argument parsing
 
-(import :std/error
+(import :gerbil/gambit/exceptions
+        :std/error
+        :std/sugar
         :std/format)
 (export getopt
         (rename: !getopt? getopt?)
@@ -17,6 +19,7 @@
         argument
         optional-argument
         rest-arguments
+        call-with-getopt
         )
 
 (defstruct (getopt-error <error>) (e))
@@ -351,3 +354,50 @@
     (if (fx< len tablen)
       (make-string (fx- tablen len) #\space)
       "")))
+
+(def (call-with-getopt proc args
+                       program: program
+                       help: (help #f)
+                       exit-on-error: (exit-on-error? #t)
+                       . gopts)
+  (def (parse! gopt return)
+    (try
+     (getopt-parse gopt args)
+     (catch (getopt-error? exn)
+       (getopt-display-help exn program (current-error-port))
+       (if exit-on-error?
+         (exit 1)
+         (return 'error)))
+     (catch (e)
+       (display-exception e (current-error-port))
+       (if exit-on-error?
+         (exit 2)
+         (return 'error)))))
+
+  (let/cc return
+    (let* ((gopt (apply getopt help: help gopts))
+           (cmds (!getopt-cmds gopt)))
+      (if (null? cmds)
+        ;; it only has options; add -h/--help
+        (let ((help-flag
+               (flag 'help "-h" "--help"
+                 help: "display help"))
+              (opts (!getopt-opts gopt)))
+          (if (null? opts)
+            (set! (!getopt-opts gopt)
+              [help-flag])
+            (set-cdr! (last-pair opts)
+                      [help-flag]))
+          (let (opt (parse! gopt return))
+            (if (hash-get opt 'help)
+              (getopt-display-help gopt program)
+              (proc opt))))
+        ;; it has commands; add help <command>
+        (let (help-cmd
+              (command 'help  help: "display help; help <command> for command help"
+                (optional-argument 'command value: string->symbol)))
+          (set-cdr! (last-pair cmds) [help-cmd])
+          (let ((values cmd opt) (parse! gopt return))
+            (if (eq? cmd 'help)
+              (getopt-display-help-topic gopt (hash-get opt 'command) program)
+              (proc cmd opt))))))))

src/tools/gxpkg.ss

@@ -73,56 +73,44 @@
   (def search-cmd
     (command 'search help: "search the package directory"
              (rest-arguments 'keywords help: "keywords to search for")))
-  (def help-cmd
-    (command 'help help: "display help; help <command> for command help"
-             (optional-argument 'command value: string->symbol)))
-  (def gopt
-    (getopt
-     help: "the Gerbil Package Manager"
-     install-cmd
-     uninstall-cmd
-     update-cmd
-     link-cmd
-     unlink-cmd
-     build-cmd
-     clean-cmd
-     list-cmd
-     retag-cmd
-     search-cmd
-     help-cmd))
-
-  (try
-   (let ((values cmd opt) (getopt-parse gopt args))
-     (let-hash opt
-       (case cmd
-         ((install)
-          (install-pkgs .pkg))
-         ((uninstall)
-          (uninstall-pkgs .pkg .?force))
-         ((update)
-          (update-pkgs .pkg))
-         ((link)
-          (link-pkg .pkg .src))
-         ((unlink)
-          (unlink-pkgs .pkg .?force))
-         ((build)
-          (build-pkgs .pkg))
-         ((clean)
-          (clean-pkgs .pkg))
-         ((list)
-          (list-pkgs))
-         ((retag)
-          (retag-pkgs))
-         ((search)
-          (search-pkgs .keywords))
-         ((help)
-          (getopt-display-help-topic gopt .?command "gxkpg")))))
-   (catch (getopt-error? exn)
-     (getopt-display-help exn "gxpkg" (current-error-port))
-     (exit 1))
-   (catch (e)
-     (display-exception e (current-error-port))
-     (exit 2))))
+
+  (call-with-getopt gxpkg-main args
+    program: "gxpkg"
+    help: "The Gerbil Package Manager"
+    install-cmd
+    uninstall-cmd
+    update-cmd
+    link-cmd
+    unlink-cmd
+    build-cmd
+    clean-cmd
+    list-cmd
+    retag-cmd
+    search-cmd))
+
+(def (gxpkg-main cmd opt)
+  (let-hash opt
+    (case cmd
+      ((install)
+       (install-pkgs .pkg))
+      ((uninstall)
+       (uninstall-pkgs .pkg .?force))
+      ((update)
+       (update-pkgs .pkg))
+      ((link)
+       (link-pkg .pkg .src))
+      ((unlink)
+       (unlink-pkgs .pkg .?force))
+      ((build)
+       (build-pkgs .pkg))
+      ((clean)
+       (clean-pkgs .pkg))
+      ((list)
+       (list-pkgs))
+      ((retag)
+       (retag-pkgs))
+      ((search)
+       (search-pkgs .keywords)))))
 
 ;;; commands
 (defrules fold-pkgs ()