diff --git a/doc/.vuepress/config.js b/doc/.vuepress/config.js index c07f552746..2ac5d256bf 100644 --- a/doc/.vuepress/config.js +++ b/doc/.vuepress/config.js @@ -121,6 +121,17 @@ module.exports = { ] }, + { title: "Unix Command Line Interface", + path: "/reference/std/cli/", + children: [ + "cli/", + "cli/getopt", + "cli/shell", + "cli/print-exit", + "cli/multicall", + ] + }, + { title: "Databases and Key-Value Stores", path: "/reference/std/db/", children: [ diff --git a/doc/reference/std/cli/README.md b/doc/reference/std/cli/README.md new file mode 100644 index 0000000000..5105e4a4db --- /dev/null +++ b/doc/reference/std/cli/README.md @@ -0,0 +1,7 @@ +# Unix Command Line Interface + +The following libraries are provided to support the Unix Command Line Interface (CLI): +- [:std/cli/getopt](getopt.md) +- [:std/cli/shell](shell.md) +- [:std/cli/print-exit](print-exit.md) +- [:std/cli/multicall](multicall.md) diff --git a/doc/reference/std/cli/getopt.md b/doc/reference/std/cli/getopt.md new file mode 100644 index 0000000000..f37565f8fb --- /dev/null +++ b/doc/reference/std/cli/getopt.md @@ -0,0 +1,269 @@ +# Command Line Argument Parsing + +The `:std/cli/getopt` library provides facilities for command line argument parsing. + +::: tip usage +```scheme +(import :std/cli/getopt) +``` +::: + +This library used to be available as `:std/getopt` up to Gerbil v0.18, +and is still available under that name for now, but its use is deprecated. + +## Interface + +### getopt +```scheme +(getopt ...) +=> + +specifier: + (command id [help: text] ) + ... + +cmd-specifier: + (flag id short [long]) + (option id short [long] [help: text] [value: proc] [default: value]) + (argument id [help: text] [value: proc]) + (optional-argument id [help: text] [value: proc] [default: value]) + (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 +```scheme +(getopt-parse 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? +```scheme +(getopt-error? obj) +=> boolean +``` + +If parsing fails, then a `getopt-error` is raised, which can be guarded with +`getopt-error?`. + +### getopt-display-help +```scheme +(getopt-display-help program-name [port = (current-output-port)]) + +tip: + + + +``` + +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 +```scheme +(getopt-display-help-topic 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? +```scheme +(getopt? obj) +=> boolean +``` + +Returns true if the object is a getopt parser + +### getopt-object? +```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 the a command line parser for the `gxpkg` program: +```scheme +(def (main . args) + (def install-cmd + (command 'install help: "install one or more packages" + (rest-arguments 'pkg help: "package to install"))) + (def uninstall-cmd + (command 'uninstall help: "uninstall one or more packages" + (flag 'force "-f" help: "force uninstall even if there are orphaned dependencies") + (rest-arguments 'pkg help: "package to uninstall"))) + (def update-cmd + (command 'update help: "update one or more packages" + (rest-arguments 'pkg help: "package to update; all for all packages"))) + (def link-cmd + (command 'link help: "link a local development package" + (argument 'pkg help: "package to link") + (argument 'src help: "path to package source directory"))) + (def unlink-cmd + (command 'unlink help: "unlink one or more local development packages" + (flag 'force "-f" help: "force unlink even if there are orphaned dependencies") + (rest-arguments 'pkg help: "package to unlink"))) + (def build-cmd + (command 'build help: "rebuild one or more packages and their dependents" + (rest-arguments 'pkg help: "package to build; all for all packages"))) + (def clean-cmd + (command 'clean help: "clean compilation artefacts from one or more packages" + (rest-arguments 'pkg help: "package to clean"))) + (def list-cmd + (command 'list help: "list installed packages")) + (def retag-cmd + (command 'retag help: "retag installed packages")) + (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))))) +``` + +### getopt-parse->function-arguments +```scheme +(getopt-parse->function-arguments getopt h) => list-of-arguments +``` + +This function takes a `getopt` specification and table `h` of arguments +resulting from calling `getopt-parse`, and returns a list of argument +with which to call a Scheme function that has an analogous call convention: + - supplied positional arguments are passed in order + - they are followed by all the rest arguments + - they are followed by the remaining specified keyword arguments. + +Omitted option arguments without default will be omitted. +Omitted option arguments with a default will be included with the default value; +the programmer must ensure that this default value is the same as +the default value from the Scheme function being called, or there will be +a semantic discrepancy between the CLI interface and the underlying Scheme function. + +NB: `h` will be modified in place, removing positional and rest arguments. +Make sure to use `hash-copy` if you want to preserve the original data. + +TODO: add examples + +### call-with-getopt-parse +```scheme +(call-with-getopt-parse gopt hash fun) => results-of-fun +``` + +Given a getopt specification `gopt`, the `hash` resulting from calling +`getopt-parse` on some provided command-line arguments, and a function `fun` +that has a calling convention analogous to that specified by `gopt`, +call the function with arguments that correspond to those provided by `hash`, +as per `getopt-parse->function-arguments`. + +TODO: add examples, discuss abort-on-error behavior, +lack of automatic help, etc. + +### call-with-processed-command-line +```scheme +(call-with-processed-command-line processor command-line function) => results-of-function +``` + +Generic function of three arguments: + - a `processor` that describes a `getopt` specification, + - a `command-line`, list of strings as provided by the invoking process, and + - a `function` to be called with the results of processing the command-line. + +The function is generic in the first argument. +The default method recognizes a `getopt` specification as first argument, +and appropriately calls `getopt-parse` and `call-with-getopt-parse` +to process the command-line. It also recognizes a list as being arguments +to which to apply `getopt` to obtain a specification, +with which to proceed as above. + +You may define more methods, to work with your own variant of `getopt`, +or with innovative ways to incrementally compose `getopt` specifications +e.g. with prototype objects like `gerbil-poo`. + +TODO: add examples, discuss abort-on-error behavior, +lack of automatic help, etc. + +### ->getopt-spec +```scheme +(->getopt-spec arg) => list-of-getopt-arguments +``` +Given an argument `arg`, return a list *lst* of getopt arguments +to which one can `(apply getopt lst)` to specify a getopt object to parse with. + +Default behavior: + - If `arg` is a list, `flatten` it. + - If `arg` is a natural integer *n*, + specify a list of *n* positional `argument`s. + - If `arg` is `#f`, specify a single `rest-argument` named `rest`, + i.e. let it be a passthrough to be processed by the function being called. + - Otherwise, raise an error. + +This function is useful for calls not just to `getopt` directly, +but also to `command` that itself calls `getopt`, etc. diff --git a/doc/reference/std/cli/multicall.md b/doc/reference/std/cli/multicall.md new file mode 100644 index 0000000000..26ccf07880 --- /dev/null +++ b/doc/reference/std/cli/multicall.md @@ -0,0 +1,129 @@ +# Multicall Binaries + +The `:std/cli/multicall` module provides facilities to define multicall binaries +the behavior of which differs depending on the name of the binary, +just like the gerbil binary itself, or famously like `busybox`. + +::: tip usage +```scheme +(import :std/cli/multicall) +``` +::: + +An earlier version of this library used to be available as `:clan/multicall` +in gerbil-utils. + +## Interface + +### current-program +```scheme +(def current-program (make-parameter [])) +``` +A parameter that contains the name of the current program or subprogram, +as a list in reverse of the successive subcommands used to invoke it. + +### current-program-string +```scheme +(def current-program (make-parameter [])) +``` +Return as a string of space-separated commands and subcommands in order +the name of the current program or subprogram. + +### entry-points +```scheme +entry-points => table +``` +A table, indexed by symbols, of `entry-point` structs, +describing the available shell entry points. + +### entry-point +```scheme +(defstruct entry-point (name function help getopt) transparent: #t) +``` +A struct type describing an available entry-point: + - `name` is a symbol, whose `symbol->string` is used as command or subcommand + to select the entry-point from the CLI. + - `function` is the Scheme function to call if the entry-point is selected. + - `help` is a short help string describing the purpose of the entry-point, + to be displayed to the user when help is requested. + - `getopt` is a `getopt-spec` + based on which the rest of the command-line will be parsed, and + based on which help about the available options is displayed. + +### entry-points-getopt-spec +```scheme +(entry-points-getopt-spec [table]) +``` +Given a `table` of entry-points which default to the variable `entry-points`, +return a getopt-spec (suitable to be passed to `(apply getopt ...)`) of +`command` specifiers, one for each registered entry-point, in asciibetical order. + +### register-entry-point +```scheme +(register-entry-point function + [id: #f] [name: #f] [help: #f] [getopt: #f]) +``` +Register the function as entry-point, +with given `name` (argument passed to `make-symbol`), +or if not specified, a symbol made of only the +[`easy-shell-characters?`](shell.md#easy-shell-characters) of `id`. +The entry-point will have the given `help` and `getopt` fields. + +### define-entry-point +```scheme +(define-entry-point (id . formals) (options ...) body ...) +``` +Syntax that expands to both + 1. defining in the current scope function with the given name `id` + and specified Scheme function formals, and the given `body`. + 2. register an entry-point for that function, + with given `id` and `options`. + +### multicall-default +```scheme +multicall-default +``` +A mutable variable that contains the default function to call +if the command doesn’t match any of the specified commands. + +### set-default-entry-point! +```scheme +(set-default-entry-point! symbol) +``` +Set the default entry-point in `multicall-default` as given `symbol`. + +### help +```scheme +(help [command]) +``` +Global entry-point to print a help message (about the command, if specified) +about the current overall command and subcommands. + +### meta +```scheme +(meta) +``` +Global entry-point to print the available completions for the command, +for use with CLI syntax autodetection. + +### version +```scheme +(version [all?: #f] [layer]) +``` +Global entry-point to print the current version. +If `all?` (flag `-a`) is passed, print all components from build manifest. +If `layer` (flag `-l`) is passed, print the thus-named component. + +### call-entry-point +```scheme +(call-entry-point . args) +``` +Call an entry point as specified by `args`, +or else the `multicall-default` entry point. + +### define-multicall-main +```scheme +define-multicall-main +``` +Define `call-entry-point` as a suitable `main` function +in the current scope. diff --git a/doc/reference/std/cli/print-exit.md b/doc/reference/std/cli/print-exit.md new file mode 100644 index 0000000000..6f9999d7ff --- /dev/null +++ b/doc/reference/std/cli/print-exit.md @@ -0,0 +1,101 @@ +# Print results and Exit + +The `:std/cli/print-exit` module helps you write functions that can be +invoked either from the Scheme REPL or the Unix CLI, and in either case +will print their computation results after their invocation. + +::: tip usage +```scheme +(import :std/cli/print-exit) +``` +::: + +The facilities are named in a way reminiscent of REPL (Read-Eval-Print-Loop), +except that instead of a form being Read and Eval'ed, +a function is called or a body is evaluated as in `begin`, +and after the Print part we Exit rather than Loop. + +## Interface + +### value-printer +```scheme +(define value-printer (make-parameter prn)) +``` +This parameter will return a function called on each value received +by `print-exit` or `print-values` +(unless there is a single value `(void)` that isn't printed). + +Defaults to `prn`. You could instead use `writeln` or `displayln`. + +### print-values +```scheme +(print-values . vs) => (void) +``` +Process a list of values `vs` from a previous computation +(as per `(call-with-values thunk print-values)`), and +print each of those values (as applicable) using `(value-printer)`, +unless there is a single value that is `(void)` +in which case don't print anything +(also don't print anything if provided no values as per `(values)`). + +Any values but `(void)` and `(values)` will thus cause the values to be printed, +one by one, using `(value-printer)`, similar to how the Scheme REPL works. +However, the Scheme REPL would use [`writeln`](../misc/ports.md#writeln) as its +value printer, but the default `(value-printer)` above is +[`prn`](../misc/repr.md#prn) which we found to be more useful in this situation. + +### print-exit +```scheme +(print-exit . vs) => [exit] +``` + +Process a list of values `vs` from a previous computation +(as per `(call-with-values thunk print-exit)`), and +(1) print those values using `print-values`, then +(2) exit with an according exit code. + +Any values but `#f` and `(values)` will cause the exit code 0 to be returned, +which the Unix shell will interpret as success or true. +The values `#f` and `(values)` will cause the exit code 1 to be returned, +which the Unix shell will interpret as failure or false. + +The value `(void)` will thus indicate a silent success, +wherein nothing is printed and success is assumed, as is customary in Scheme. +The value `(values)` meanwhile will thus indicate a silent failure, +wherein nothing is printed and failure is assumed, of which however +only the first part (nothing printed) is customary in Scheme, whereas the +failure assumed is not customary in Scheme (but a false value would be assumed in e.g. CL). + +### silent-exit +```scheme +(silent-exit success?) => void-or-values +``` + +Takes a boolean `success?` and returns a multiple values +that when passed to `print-exit` will not be printed, yet +will cause return an error code that the Unix shell will interpret +as success or true if the boolean is true, and +failure or false if the boolean is false. + +`(void)` is the silent true exit returned if `success?` is true, +and `(values)` is the silent false exit returned if it is false. + +### call-print-exit +```scheme +(call-print-exit fun) => [exit] +``` +Call a function, print the resulting values (if applicable), +and exit with an according exit code, as per `print-exit`. +If an error occurs during execution, +exit with an error code as per +[`with-exit-on-error`](../error.md#with-exit-on-error). + +### begin-print-exit +```scheme +(begin-print-exit body ...) => [exit] +``` +Evaluates the `body` as in an anonymous function called by `call-print-exit`. + +This macro is named in a way reminiscent of REPL (Read-Eval-Print-Loop), +except instead of a form being Read and Eval'ed, the body is evaluated +like `begin`, and after the Print part it Exits rather than Loops. diff --git a/doc/reference/std/cli/shell.md b/doc/reference/std/cli/shell.md new file mode 100644 index 0000000000..b3b61f2962 --- /dev/null +++ b/doc/reference/std/cli/shell.md @@ -0,0 +1,94 @@ +# Shell Command Support + +The `:std/cli/shell` library provides facilities for working with Unix shell code + +::: tip usage +```scheme +(import :std/cli/shell) +``` +::: + +An earlier version of this library used to be available as `:clan/shell` +in gerbil-utils. + +## Interface + +### easy-shell-character? +```scheme +(easy-shell-character? character) => bool +``` + +Returns true if the `character` if a string may contain the character in any position +without that this fact requiring the string to be quoted in any shell. +This include alphanumeric characters and those in `"@%-_=+:,./"` +(not including the double quotes). + +All other ASCII characters may require the string to be quoted. +For good measure we also quote strings containing non-ASCII characters. + +::: tip Examples: +```scheme +> (string-for-each (lambda (c) (or (easy-shell-character? c) (error "foo"))) + "abcdefghijklmnopqrstuvwxzABCDEFGHIJKLMNOPQRSTUVWXZ012345678@%-_=+:,./") ;; no error +> (string-for-each (lambda (c) (or (not (easy-shell-character? c)) (error "foo"))) + "!`~#$^&*()[{]}\\|;'\"<>? \r\n\t\v") ;; no error either +``` +::: + +### needs-shell-escape? +```scheme +(needs-shell-escape? string) => bool +``` +Returns true if the `string` is known not to require quoting in a Unix shell. + +The current implementation only trusts strings where every character +satisfies `easy-shell-character?` to not require quoting. + +::: tip Examples: +```scheme +> (map needs-shell-escape ["foo?" "~user" "$1" "*.*" "!1" "ab\\cd" "{}" "a;b" "&" "|" "a b c"]) +(#t #t #t #t #t #t #t #t #t #t #t) +> (map needs-shell-escape ["foo" "%-_=+:,./" "1" "..." "abcd" "x=y:z,t.z/u+v_w"]) +(#f #f #f #f #f #f) +``` +::: + +### escape-shell-token +```scheme +(escape-shell-token string) => shell-escaped-string +``` +Given a `string`, returns a shell-escaped-string that, +when included in a Unix shell command, will expand into the input `string`. + +::: tip Examples: +```scheme +> (map escape-shell-token ["foo?" "~user" "$1" "*.*" "!1" "ab\\cd" "{}" "a;b" "&" "|" "a b c"]) +("\"foo?\"" "\"~user\"" "\"\\$1\"" "\"*.*\"" "\"!1\"" "\"ab\\\\cd\"" "\"{}\"" "\"a;b\"" "\"&\"" "\"|\"" "\"a b c\"") +> (let (l ["foo" "%-_=+:,./" "1" "..." "abcd" "x=y:z,t.z/u+v_w"]) + (equal? l (map escape-shell-token l))) +#t +``` +::: + +### ->envvar +```scheme +(->envvar . str) => environment-variable-name +``` +Given a list of arguments `str`, return a string to be used as +a shell environment variable name following the convention of having +only upper-case ASCII letters and digits and underscores. + +The arguments are passed to `as-string` then uppercased, and +any non-empty sequence of characters other than letters and digits +are replaced by a single underscore. + +::: tip Examples: +``` scheme +> (->envvar "foo") +"FOO" +> (->envvar "bar baz") +"BAR_BAZ" +> (->envvar '("bar " "+!@#$") #(#\@ #\! "#") "baz") +"BAR_BAZ" +``` +::: diff --git a/doc/reference/std/errors.md b/doc/reference/std/errors.md index 9c5aee9a1a..93f9c92139 100644 --- a/doc/reference/std/errors.md +++ b/doc/reference/std/errors.md @@ -426,7 +426,23 @@ displaying the exception with `display-exception`). ``` Invokes `thunk` with an exception handler that dumps the exception -stack trace with `dump-stack-trace!`. +stack trace with `dump-stack-trace!` +if `(dump-stack-trace?)` is true (the default). + +### dump-stack-trace? +```scheme +(define dump-stack-trace? (make-parameter #t)) +``` +A parameter that controls whether `with-exception-stack-trace` +will actually dump a stack trace to standard error. + +You can `(dump-stack-trace? #f)` +or locally `(parameterize ((dump-stack-trace? #f)) ...)` +to disable this stack trace dump, +in case you are building a program for end-users rather than for developers, +and want to control what limited error output they see. +Or you can re-enable them based on a debug flag at the CLI +in cases you want them to provide you with extra debugging information. ### dump-stack-trace! ```scheme @@ -435,3 +451,38 @@ stack trace with `dump-stack-trace!`. Displays the exception `exn`, dumping the stack trace of continuation `cont` if there is no stack trace information in the exception itself. + +### exit-with-error +```scheme +(exit-with-error exception) => [exit] +``` +Display the `exception` to current error port and exit with error code 2. + +### exit-on-error? +```scheme +(def exit-on-error? (make-parameter #t)) +``` +This parameter controls whether `call-with-exit-on-error`, `with-exit-on-error`, +`call-with-getopt`, and any function that indirectly uses them, +will exit if an error is caught, rather than pass on the error +and return to the REPL (or let a more fundamental function exit). + +### call-with-exit-on-error +```scheme +(call-with-exit-on-error thunk) +``` +Calls the `thunk` in an environment wherein if an error is caught and +`(exit-on-error)` is true, `exit-with-error` will be called, +causing an error message to be printed and the process to exit with exit code 2. +If `(exit-on-error)` is false, the error will simply be raised again. + +This mechanism enables users to modify the parameter +(e.g. via a flag passed at the Unix CLI or a change made at the Scheme REPL) +and control whether to exit with an error (e.g. for end-users) +or enter a debugger REPL (e.g. for developers). + +### with-exit-on-error +```scheme +(with-exit-on-error body ...) +``` +Evaluates the `body` as in a `thunk` passed to `call-with-exit-on-error`. diff --git a/doc/reference/std/getopt.md b/doc/reference/std/getopt.md index 726ef89f15..aa84b9183b 100644 --- a/doc/reference/std/getopt.md +++ b/doc/reference/std/getopt.md @@ -1,188 +1,17 @@ # Command Line Argument Parsing -The `:std/getopt` library provides facilities for command line argument parsing. +This is the old name of the `:std/cli/getopt` module, +that provides facilities for command line argument parsing. -::: tip usage -(import :std/getopt) -::: - -## Interface - -### getopt -```scheme -(getopt ...) -=> - -specifier: - (command id [help: text] ) - ... - -cmd-specifier: - (flag id short [long]) - (option id short [long] [help: text] [value: proc] [default: value]) - (argument id [help: text] [value: proc]) - (optional-argument id [help: text] [value: proc] [default: value]) - (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 -```scheme -(getopt-parse 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? -```scheme -(getopt-error? obj) -=> boolean -``` - -If parsing fails, then a `getopt-error` is raised, which can be guarded with -`getopt-error?`. - -### getopt-display-help -```scheme -(getopt-display-help program-name [port = (current-output-port)]) - - -tip: - - - -``` - -The procedure `getopt-display-help` can be used to display -a help message for a getopt error according to the argument specification. +As of Gerbil v0.19 this name is deprecated and +you should be using the new library instead, +but the old name remains available for now +for the sake of backward compatibility. -### getopt-display-help-topic -```scheme -(getopt-display-help-topic 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? -```scheme -(getopt? obj) -=> boolean -``` - -Returns true if the object is a getopt parser - -### getopt-object? -```scheme -(getopt-object? obj) -=> boolean -``` - -Returns true if the object is a getopt command or command specifier. - -### call-with-getopt +::: tip usage ```scheme -(call-with-getopt proc args - program: program - help: (help #f) - exit-on-error: (exit-on-error? #t) - . gopts) +(import :std/cli/getopt) ``` +::: -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 the a command line parser for the `gxpkg` program: -```scheme -(def (main . args) - (def install-cmd - (command 'install help: "install one or more packages" - (rest-arguments 'pkg help: "package to install"))) - (def uninstall-cmd - (command 'uninstall help: "uninstall one or more packages" - (flag 'force "-f" help: "force uninstall even if there are orphaned dependencies") - (rest-arguments 'pkg help: "package to uninstall"))) - (def update-cmd - (command 'update help: "update one or more packages" - (rest-arguments 'pkg help: "package to update; all for all packages"))) - (def link-cmd - (command 'link help: "link a local development package" - (argument 'pkg help: "package to link") - (argument 'src help: "path to package source directory"))) - (def unlink-cmd - (command 'unlink help: "unlink one or more local development packages" - (flag 'force "-f" help: "force unlink even if there are orphaned dependencies") - (rest-arguments 'pkg help: "package to unlink"))) - (def build-cmd - (command 'build help: "rebuild one or more packages and their dependents" - (rest-arguments 'pkg help: "package to build; all for all packages"))) - (def clean-cmd - (command 'clean help: "clean compilation artefacts from one or more packages" - (rest-arguments 'pkg help: "package to clean"))) - (def list-cmd - (command 'list help: "list installed packages")) - (def retag-cmd - (command 'retag help: "retag installed packages")) - (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))))) - -``` + diff --git a/src/std/build-spec.ss b/src/std/build-spec.ss index 03d1501e66..8c53feedc6 100644 --- a/src/std/build-spec.ss +++ b/src/std/build-spec.ss @@ -37,6 +37,11 @@ "amb" "contract" (gxc: "interface" ,@(include-gambit-sharp)) + ;; cli + "cli/getopt" + "cli/shell" + "cli/print-exit" + "cli/multicall" ;; stdio "io" "io/interface" diff --git a/src/std/cli/getopt.ss b/src/std/cli/getopt.ss new file mode 100644 index 0000000000..16f471c9fc --- /dev/null +++ b/src/std/cli/getopt.ss @@ -0,0 +1,455 @@ +;;; -*- Gerbil -*- +;;; (C) vyzo +;;; Command-line option and command argument parsing + +(import (only-in :std/error deferror-class Error:::init! exit-on-error? exit-with-error) + (only-in :std/generic defgeneric) + (only-in :std/iter for/collect in-iota) + (only-in :std/misc/hash hash->list/sort) + (only-in :std/misc/list when/list flatten) + (only-in :std/misc/number fxnat?) + (only-in :std/misc/string as-stringfunction-arguments + call-with-getopt-parse + call-with-processed-command-line + ->getopt-spec) +(def current-getopt-parser + (make-parameter #f)) + +(deferror-class GetOptError (getopt) getopt-error? + (lambda (self msg args getopt) + (Error:::init! self msg where: 'getopt irritants: args) + (set! (@ self getopt) getopt))) +(def (raise-getopt-error msg . args) + (raise (GetOptError msg args (current-getopt-parser)))) +(def getopt-error-e GetOptError-getopt) + +(defstruct !getopt (opts cmds args help)) +(defstruct !top (key help)) +(defstruct (!command !top) (opts args) + final: #t) +(defstruct (!opt !top) (short long)) +(defstruct (!option !opt) (value default) + final: #t) +(defstruct (!flag !opt) () + final: #t) +(defstruct (!arg !top) (value)) +(defstruct (!reqarg !arg) () + final: #t) +(defstruct (!optarg !arg) (default) + final: #t) +(defstruct (!rest !arg) () + final: #t) + +(def (getopt help: (help #f) . args) + (let lp ((rest args) (opts []) (cmds []) (args [])) + (match rest + ([hd . rest] + (cond + ((!opt? hd) + (lp rest (cons hd opts) cmds args)) + ((!command? hd) + (if (null? args) + (lp rest opts (cons hd cmds) args) + (error "Illegal command; already have arguments" hd))) + ((!reqarg? hd) + (if (null? cmds) + (if (or (null? args) + (and (not (!optarg? (car args))) + (not (!rest? (car args))))) + (lp rest opts cmds (cons hd args)) + (error "Illegal required argument; already have optional or rest arguments" hd)) + (error "Illegal required argument; already have commands" hd))) + ((or (!optarg? hd) + (!rest? hd)) + (if (null? cmds) + (if (or (null? args) + (not (!rest? (car args)))) + (lp rest opts cmds (cons hd args)) + (error "Illegal optional argument; already have rest arguments" hd)) + (error "Illegal optional argument; alreday have commands" hd))) + (else + (error "Illegal argument; must be a getopt-object" hd)))) + (else + (make-!getopt (reverse opts) (reverse cmds) (reverse args) help))))) + +(def (flag id short (long #f) + help: (help #f)) + (make-!flag id help short long)) + +(def (option id short (long #f) + help: (help #f) + value: (value-e identity) + default: (default #f)) + (make-!option id help short long value-e default)) + +(def (command id help: (help #f) . args) + (with ((!getopt opts cmds args) (apply getopt args)) + (if (null? cmds) + (make-!command id help opts args) + (error "Illegal command; cannot contain subcommands")))) + +(def (argument id + help: (help #f) + value: (value-e identity)) + (make-!reqarg id help value-e)) + +(def (optional-argument id + help: (help #f) + value: (value-e identity) + default: (default #f)) + (make-!optarg id help value-e default)) + +(def (rest-arguments id + help: (help #f) + value: (value-e identity)) + (make-!rest id help value-e)) + +(def (getopt-parse gopt args) + (let (ht (make-hash-table-eq)) + (getopt-parse! ht gopt args))) + +(def (getopt-parse! ht gopt rest) + (parameterize ((current-getopt-parser gopt)) + (with ((!getopt opts cmds args) gopt) + (getopt-parse-opts! ht opts rest + (if (null? cmds) + (lambda (rest) + (getopt-parse-args! ht args rest)) + (lambda (rest) + (getopt-parse-cmd! ht cmds rest))))))) + +(def (getopt-parse-opts! ht opts rest K) + (def (end rest) + ;; check for options with default values + (for-each (match <> + ((!option key _ _ _ _ default) + (unless (hash-key? ht key) + (hash-put! ht key default))) + (else (void))) + opts) + (K rest)) + + (def optht (make-hash-table)) + (for-each (lambda (opt) + (with ((!opt _ _ short long) opt) + (when short + (hash-put! optht short opt)) + (when long + (hash-put! optht long opt)))) + opts) + + (let lp ((rest rest)) + (match rest + ([hd . rest*] + (cond + ((string-empty? hd) + (lp rest*)) + ((eq? (string-ref hd 0) #\-) + (cond + ((equal? "--" hd) ; end of options + (end rest*)) + ((hash-get optht hd) + => (lambda (opt) + (match opt + ((!option key _ _ _ value-e) + (match rest* + ([val . rest*] + (hash-put! ht key (value-e val)) + (lp rest*)) + (else + (raise-getopt-error "Missing value for option" hd)))) + ((!flag key) + (hash-put! ht key #t) + (lp rest*))))) + (else + (raise-getopt-error "Unknown option" hd)))) + (else ; doesn't look like an option + (end rest)))) + (else ; we run out of arguments + (end rest))))) + +(def (getopt-parse-args! ht args rest) + (let lp ((args args) (rest rest)) + (match args + ([arg . args] + (match arg + ((!reqarg key _ value-e) + (match rest + ([val . rest] + (hash-put! ht key (value-e val)) + (lp args rest)) + (else + (raise-getopt-error "Missing argument" key)))) + ((!optarg key _ value-e default) + (match rest + ([val . rest] + (hash-put! ht key (value-e val)) + (lp args rest)) + (else + (hash-put! ht key default) + (lp args rest)))) + ((!rest key _ value-e) + (hash-put! ht key (map value-e rest)) + ht))) + (else + (unless (null? rest) + (raise-getopt-error "Unexpected arguments" rest)) + ht)))) + +(def (getopt-parse-cmd! ht cmds rest) + (def cmdht (make-hash-table)) + (for-each (lambda (cmd) + (with ((!command key) cmd) + (hash-put! cmdht (symbol->string key) cmd))) + cmds) + + (match rest + ([cmd . rest] + (cond + ((hash-get cmdht cmd) + => (lambda (cmd) + (with ((!command key _ opts args) cmd) + (parameterize ((current-getopt-parser cmd)) + (getopt-parse-opts! ht opts rest + (lambda (rest) + (getopt-parse-args! ht args rest) + (values key ht))))))) + (else + (raise-getopt-error "Unknown command" cmd)))) + (else + (raise-getopt-error "Missing command")))) + +(def (getopt->positional-names gopt) + (def rest-name #f) + (def argkey !top-key) + (def names (with-list-builder (c) + (for-each (lambda (arg) + (cond + ((or (!reqarg? arg) (!optarg? arg)) + (c (argkey arg))) + ((!rest? arg) (set! rest-name (argkey arg))))) + (!getopt-args gopt)))) + (values names rest-name)) + +(def (getopt-display-help obj program (port (current-output-port))) + (cond + ((!getopt? obj) + (display-help-getopt obj program port)) + ((!command? obj) + (display-help-command obj program port)) + ((getopt-error? obj) + (fprintf port "Error: ~a~n" (error-message obj)) + (unless (null? (error-irritants obj)) + (display "Irritants:" port) + (for-each (lambda(x) (display " " port) (display x port)) + (error-irritants obj)) + (newline)) + (newline) + (getopt-display-help (getopt-error-e obj) program port)) + (else + (error "Unexpected object; expected a getopt, getopt-error, or command" obj)))) + +(def (getopt-display-help-topic gopt topic program (port (current-output-port))) + (let lp ((rest (!getopt-cmds gopt))) + (match rest + ([cmd . rest] + (if (eq? topic (!top-key cmd)) + (getopt-display-help cmd program port) + (lp rest))) + (else + (getopt-display-help gopt program port))))) + +(def (display-help-getopt obj program port) + (with ((!getopt opts cmds args help) obj) + (when help + (fprintf port "~a: ~a~n~n" program help)) + (if (null? cmds) + (begin + (fprintf port "Usage: ~a ~a" + program + (if (null? opts) "" "[option ...]")) + (display-args args port) + (unless (null? opts) + (fprintf port "~nOptions:~n") + (display-option-help opts port)) + (unless (null? args) + (fprintf port "~nArguments:~n") + (display-arg-help args port))) + (begin + (fprintf port "Usage: ~a ~a command-arg ...~n" + program + (if (null? opts) "" "[option ...]")) + (unless (null? opts) + (fprintf port "~nOptions:~n") + (display-option-help opts port)) + (fprintf port "~nCommands:~n") + (for-each (match <> + ((!command key help) + (fprintf port " ~a ~a ~a~n" + key + (tabs key) + (or help "?")))) + cmds))))) + +(def (display-help-command obj program port) + (with ((!command key help opts args) obj) + (fprintf port "Usage: ~a ~a~a" + program key + (if (null? opts) "" " [command-option ...]")) + (display-args args port) + (fprintf port " ~a~n" help) + (unless (null? opts) + (fprintf port "~nCommand Options:~n") + (display-option-help opts port)) + (unless (null? args) + (fprintf port "~nArguments:~n") + (display-arg-help args port)))) + +(def (display-args args port) + (for-each (match <> + ((!reqarg key) + (fprintf port " <~a>" key)) + ((!optarg key) + (fprintf port " [<~a>]" key)) + ((!rest key) + (fprintf port " <~a> ..." key))) + args) + (newline port)) + +(def (display-option-help opts port) + (for-each (match <> + ((!option id help short long _ default) + (fprintf port " ~a ~a <~a> ~a ~a [default: ~a]~n" + (or short "") + (or long "") + id + (tabs (or short "") " " (or long "") " <" (symbol->string id) ">") + (or help "?") + default)) + ((!flag _ help short long) + (fprintf port " ~a ~a ~a ~a~n" + (or short "") + (or long "") + (tabs (or short "") " " (or long "")) + (or help "?")))) + opts)) + +(def (display-arg-help args port) + (for-each (match <> + ((!reqarg key help) + (fprintf port " ~a ~a ~a~n" + key (tabs key) (or help "?"))) + ((!optarg key help _ default) + (fprintf port " ~a ~a ~a [default: ~a]~n" + key (tabs key) (or help "?") + default)) + ((!rest key help) + (fprintf port " ~a ~a ~a~n" + key (tabs key) (or help "?")))) + args)) + +(def (tabs . strs) + (def tablen 31) + (def (string-e str) + (if (symbol? str) + (symbol->string str) + str)) + + (let* (len (foldl + 0 (map string-length (map string-e strs)))) + (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? (exit-on-error?)) + . gopts) + (def (parse! gopt) + (try + (getopt-parse gopt args) + (catch (e) + (cond + ((not exit?) (raise e)) + ((getopt-error? e) + (getopt-display-help e program (current-error-port)) + (exit 1)) + (else + (exit-with-error e)))))) + + (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)) + (if (hash-get opt 'help) + (getopt-display-help gopt program) + (proc opt)))) + ;; it has commands; add help + (let (help-cmd + (command 'help help: "display help; help for command help" + (optional-argument 'command value: string->symbol))) + (set-cdr! (last-pair cmds) [help-cmd]) + (let ((values cmd opt) (parse! gopt)) + (if (eq? cmd 'help) + (getopt-display-help-topic gopt (hash-get opt 'command) program) + (proc cmd opt))))))) + +(def (getopt-parse->positional-arguments! gopt h) + (defvalues (names rest-name) (getopt->positional-names gopt)) + (def (extract n) (begin0 (hash-get h n) (hash-remove! h n))) + (def positional (map extract names)) + (def rest (when/list rest-name (extract rest-name))) + (append positional rest)) + +(def (getopt-parse->function-arguments gopt h) + (def positionals (getopt-parse->positional-arguments! gopt h)) + (append positionals + (foldr (lambda (kv l) (cons* (make-keyword (car kv)) (cdr kv) l)) '() + (hash->list/sort h as-stringfunction-arguments gopt hash))) + +(defgeneric call-with-processed-command-line + (lambda (processor command-line function) + (cond + ((!getopt? processor) + (call-with-getopt-parse processor (getopt-parse processor command-line) function)) + ((list? processor) + (call-with-processed-command-line (apply getopt processor) command-line function))))) + +(defgeneric ->getopt-spec + (lambda (spec) + (cond + ((list? spec) (flatten spec)) + ((fxnat? spec) (for/collect ((i (in-iota spec 1))) (argument (format "arg~d" i)))) + ((not spec) (rest-arguments "rest")) + (else (error "Bad getopt spec"))))) diff --git a/src/std/cli/multicall.ss b/src/std/cli/multicall.ss new file mode 100644 index 0000000000..24c449143e --- /dev/null +++ b/src/std/cli/multicall.ss @@ -0,0 +1,97 @@ +;; -*- Gerbil -*- +;;;; Support for building a single multicall binary that has all the fricfrac functionality. + +(export #t) + +(import + (only-in :std/cli/print-exit begin-print-exit) + (only-in :std/cli/shell easy-shell-character?) + (only-in :std/format format) + (only-in :std/generic defgeneric) + (only-in :std/getopt getopt getopt-display-help-topic getopt-display-help + call-with-processed-command-line ->getopt-spec + command flag option argument optional-argument rest-arguments) + (only-in :std/iter for/collect) + (only-in :std/misc/hash hash->list/sort) + (only-in :std/misc/list flatten) + (only-in :std/misc/number nat?) + (only-in :std/misc/string as-stringlist/sort h as-stringgetopt-spec (entry-point-getopt e))))) + +;; TODO: allow registering a getopt: structure and/or other command information, +;; so we can show detailed help and automatically parse arguments? +;; TODO: also allow a preprocess: function to further process the result of getopt (if specified) +;; or the raw arguments (if no getopt specified). +(def (register-entry-point function + id: (id #f) name: (name #f) help: (help #f) + getopt: (getopt #f)) + (let (name (make-symbol (or name (string-filter easy-shell-character? (as-string id))))) + (hash-put! entry-points name (make-entry-point name function help getopt)))) + +;; TODO: syntax to specify not just help, but getopt, etc. +(defrule (define-entry-point (id . formals) (options ...) body ...) + (begin (def (id . formals) body ...) + (register-entry-point id id: 'id options ...))) + +(defmutable multicall-default 'help) + +(def (set-default-entry-point! x) + (set! multicall-default x)) + +(define-entry-point (help (command #f)) + (help: "Print help about available commands" + getopt: [(optional-argument 'command help: "subcommand for which to display help")]) + (displayln (display-build-manifest (build-manifest/head))) + (def gopt (getopt (entry-points-getopt-spec))) + (def program (current-program-string (cdr (current-program)))) + (if command + (getopt-display-help-topic gopt (make-symbol command) program) + (getopt-display-help gopt program))) + +;; TODO: also handle getopt specifications? +(define-entry-point (meta) + (help: "Print meta-information for completion purposes" + getopt: []) + (displayln (string-join (sort (map as-string (hash-keys entry-points)) string #t)) + "abcdefghijklmnopqrstuvwxzABCDEFGHIJKLMNOPQRSTUVWXZ012345678@%-_=+:,./") + (string-for-each (lambda (c) (check (easy-shell-character? c) => #f)) + "!`~#$^&*()[{]}\\|;'\"<>? \r\n\t\v")) + (test-case "needs-shell-escape?, escape-shell-token" + (defrules checks+1 () + ((_ (s e)) (begin + (check (needs-shell-escape? s) => #t) + (check (escape-shell-token s) => (string-append "\"" e "\"")))) + ((_ s) (begin + (check (needs-shell-escape? s) => #t) + (check (escape-shell-token s) => (string-append "\"" s "\""))))) + (defrule (checks+ x ...) + (begin (checks+1 x) ...)) + (checks+ "foo?" "~user" ("$1" "\\$1") "*.*" "!1" ("ab\\cd" "ab\\\\cd") + "{}" "a;b" "&" "|" "a b c") + (defrule (checks- s ...) (begin (check (needs-shell-escape? s) => #f) ...)) + (checks- "foo" "%-_=+:,./" "1" "..." "abcd" "x=y:z,t.z/u+v_w")) + (test-case "->envvar" + (defrule (checks (s e) ...) + (begin (check (->envvar s) => e) ...)) + (checks ("foo" "FOO") + ("bar baz" "BAR_BAZ")) + (check (->envvar '("bar " "+!@#$") #(#\@ #\! "#") "baz") => "BAR_BAZ")))) diff --git a/src/std/cli/shell.ss b/src/std/cli/shell.ss new file mode 100644 index 0000000000..287c476629 --- /dev/null +++ b/src/std/cli/shell.ss @@ -0,0 +1,42 @@ +;; Support for Unix shells +;; TODO: If Windows shell support is needed, add it here, too. + +(export #t) + +(import + :std/srfi/13 :std/stxutil :std/text/char-set) + +(def (easy-shell-character? x) + (or (char-ascii-alphanumeric? x) (and (string-index "%+,-./:=@_" x) #t))) + +(def (needs-shell-escape? token) + ;; maybe also accept ^ and ~ in non-start position? + (not (string-every easy-shell-character? token))) + +(def (escape-shell-token token) + (if (needs-shell-escape? token) + (call-with-output-string [] + (lambda (port) + (def (p x) (display x port)) + (p #\") + (string-for-each + (lambda (c) (when (string-index "$`\\\"" c) (p #\\)) (p c)) + token) + (p #\"))) + token)) + +(def (escape-shell-tokens tokens) + (string-join (map escape-shell-token tokens) " ")) + +(def (->envvar . args) + (call-with-output-string + (lambda (p) + (def alpha? #t) + (string-for-each + (lambda (c) + (def caa? (char-ascii-alphanumeric? c)) + (when caa? + (unless alpha? (write-char #\_ p)) + (write-char c p)) + (set! alpha? caa?)) + (string-upcase (as-string args)))))) diff --git a/src/std/error.ss b/src/std/error.ss index 65b57047b2..74f0152d48 100644 --- a/src/std/error.ss +++ b/src/std/error.ss @@ -29,7 +29,12 @@ (rename: raise-bug BUG) is-it-bug? with-exception-stack-trace - dump-stack-trace!) + dump-stack-trace? + dump-stack-trace! + exit-with-error + exit-on-error? + call-with-exit-on-error + with-exit-on-error) ;; utility macro for definint error classes (defsyntax (deferror-class stx) @@ -126,7 +131,7 @@ (IOError message irritants: [irritants ...])) (defraise/context (raise-premature-end-of-input where irritants ...) - (PrematureEndOfInput "premature end of input" irritants: [irritants ...])) + (PrematureEndOfInput "premature end of input" irritants: [irritants ...])) (defraise/context (raise-io-closed where message irritants ...) (Closed message irritants: [irritants ...])) @@ -352,3 +357,32 @@ wrong-number-of-values-exception-vals) (wrong-processor-c-return-exception?)) + +(def exit-on-error? (make-parameter #t)) + +(def (exit-with-error e) + (def port (current-error-port)) + (defrules ignore-errors () ((_ body ...) (with-catch void (lambda () body ...)))) + (ignore-errors (force-output port)) + (ignore-errors (display-build-manifest build-manifest port)) + (ignore-errors (newline port)) + (ignore-errors (display-exception e port)) + ;; If the stack trace was printed, making the message out of reach of the user, + ;; then redundantly print the error message at the bottom without the stack trace. + (ignore-errors + (when (and (dump-stack-trace?) (StackTrace? e)) + (parameterize ((dump-stack-trace? #f)) + (display-exception e port)))) + (ignore-errors (force-output port)) + (exit 2)) + +(def (call-with-exit-on-error thunk) + (with-catch + (lambda (e) + (if (exit-on-error?) + (exit-with-error e) + (raise e))) + thunk)) + +(defrules with-exit-on-error () + ((_ body ...) (call-with-exit-on-error (lambda () body ...)))) diff --git a/src/std/getopt.ss b/src/std/getopt.ss index 710ce683de..5d370a1440 100644 --- a/src/std/getopt.ss +++ b/src/std/getopt.ss @@ -1,404 +1,5 @@ -;;; -*- Gerbil -*- -;;; (C) vyzo -;;; Command-line option and command argument parsing +;; Compatibility module for v0.18 +(import :std/cli/getopt) +(export (import: :std/cli/getopt)) -(import :std/error - :std/sugar - :std/format) -(export getopt - (rename: !getopt? getopt?) - (rename: !top? getopt-object?) - getopt-error? - getopt-parse - getopt-display-help - getopt-display-help-topic - option - flag - command - argument - optional-argument - rest-arguments - call-with-getopt - ) -(def current-getopt-parser - (make-parameter #f)) - -(deferror-class GetOptError (getopt) getopt-error? - (lambda (self msg args getopt) - (Error:::init! self msg where: 'getopt irritants: args) - (set! (@ self getopt) getopt))) -(def (raise-getopt-error msg . args) - (raise (GetOptError msg args (current-getopt-parser)))) -(def getopt-error-e GetOptError-getopt) - -(defstruct !getopt (opts cmds args help)) -(defstruct !top (key help)) -(defstruct (!command !top) (opts args) - final: #t) -(defstruct (!opt !top) (short long)) -(defstruct (!option !opt) (value default) - final: #t) -(defstruct (!flag !opt) () - final: #t) -(defstruct (!arg !top) (value)) -(defstruct (!reqarg !arg) () - final: #t) -(defstruct (!optarg !arg) (default) - final: #t) -(defstruct (!rest !arg) () - final: #t) - -(def (getopt help: (help #f) . args) - (let lp ((rest args) (opts []) (cmds []) (args [])) - (match rest - ([hd . rest] - (cond - ((!opt? hd) - (lp rest (cons hd opts) cmds args)) - ((!command? hd) - (if (null? args) - (lp rest opts (cons hd cmds) args) - (error "Illegal command; already have arguments" hd))) - ((!reqarg? hd) - (if (null? cmds) - (if (or (null? args) - (and (not (!optarg? (car args))) - (not (!rest? (car args))))) - (lp rest opts cmds (cons hd args)) - (error "Illegal required argument; already have optional or rest arguments" hd)) - (error "Illegal required argument; already have commands" hd))) - ((or (!optarg? hd) - (!rest? hd)) - (if (null? cmds) - (if (or (null? args) - (not (!rest? (car args)))) - (lp rest opts cmds (cons hd args)) - (error "Illegal optional argument; already have rest arguments" hd)) - (error "Illegal optional argument; alreday have commands" hd))) - (else - (error "Illegal argument; must be a getopt-object" hd)))) - (else - (make-!getopt (reverse opts) (reverse cmds) (reverse args) help))))) - -(def (flag id short (long #f) - help: (help #f)) - (make-!flag id help short long)) - -(def (option id short (long #f) - help: (help #f) - value: (value-e identity) - default: (default #f)) - (make-!option id help short long value-e default)) - -(def (command id help: (help #f) . args) - (with ((!getopt opts cmds args) (apply getopt args)) - (if (null? cmds) - (make-!command id help opts args) - (error "Illegal command; cannot contain subcommands")))) - -(def (argument id - help: (help #f) - value: (value-e identity)) - (make-!reqarg id help value-e)) - -(def (optional-argument id - help: (help #f) - value: (value-e identity) - default: (default #f)) - (make-!optarg id help value-e default)) - -(def (rest-arguments id - help: (help #f) - value: (value-e identity)) - (make-!rest id help value-e)) - -(def (getopt-parse gopt args) - (let (ht (make-hash-table-eq)) - (getopt-parse! ht gopt args))) - -(def (getopt-parse! ht gopt rest) - (parameterize ((current-getopt-parser gopt)) - (with ((!getopt opts cmds args) gopt) - (getopt-parse-opts! ht opts rest - (if (null? cmds) - (lambda (rest) - (getopt-parse-args! ht args rest)) - (lambda (rest) - (getopt-parse-cmd! ht cmds rest))))))) - -(def (getopt-parse-opts! ht opts rest K) - (def (end rest) - ;; check for options with default values - (for-each (match <> - ((!option key _ _ _ _ default) - (unless (hash-key? ht key) - (hash-put! ht key default))) - (else (void))) - opts) - (K rest)) - - (def optht (make-hash-table)) - (for-each (lambda (opt) - (with ((!opt _ _ short long) opt) - (when short - (hash-put! optht short opt)) - (when long - (hash-put! optht long opt)))) - opts) - - (let lp ((rest rest)) - (match rest - ([hd . rest*] - (cond - ((string-empty? hd) - (lp rest*)) - ((eq? (string-ref hd 0) #\-) - (cond - ((equal? "--" hd) ; end of options - (end rest*)) - ((hash-get optht hd) - => (lambda (opt) - (match opt - ((!option key _ _ _ value-e) - (match rest* - ([val . rest*] - (hash-put! ht key (value-e val)) - (lp rest*)) - (else - (raise-getopt-error "Missing value for option" hd)))) - ((!flag key) - (hash-put! ht key #t) - (lp rest*))))) - (else - (raise-getopt-error "Unknown option" hd)))) - (else ; doesn't look like an option - (end rest)))) - (else ; we run out of arguments - (end rest))))) - -(def (getopt-parse-args! ht args rest) - (let lp ((args args) (rest rest)) - (match args - ([arg . args] - (match arg - ((!reqarg key _ value-e) - (match rest - ([val . rest] - (hash-put! ht key (value-e val)) - (lp args rest)) - (else - (raise-getopt-error "Missing argument" key)))) - ((!optarg key _ value-e default) - (match rest - ([val . rest] - (hash-put! ht key (value-e val)) - (lp args rest)) - (else - (hash-put! ht key default) - (lp args rest)))) - ((!rest key _ value-e) - (hash-put! ht key (map value-e rest)) - ht))) - (else - (unless (null? rest) - (raise-getopt-error "Unexpected arguments" rest)) - ht)))) - -(def (getopt-parse-cmd! ht cmds rest) - (def cmdht (make-hash-table)) - (for-each (lambda (cmd) - (with ((!command key) cmd) - (hash-put! cmdht (symbol->string key) cmd))) - cmds) - - (match rest - ([cmd . rest] - (cond - ((hash-get cmdht cmd) - => (lambda (cmd) - (with ((!command key _ opts args) cmd) - (parameterize ((current-getopt-parser cmd)) - (getopt-parse-opts! ht opts rest - (lambda (rest) - (getopt-parse-args! ht args rest) - (values key ht))))))) - (else - (raise-getopt-error "Unknown command" cmd)))) - (else - (raise-getopt-error "Missing command")))) - -(def (getopt-display-help obj program (port (current-output-port))) - (cond - ((!getopt? obj) - (display-help-getopt obj program port)) - ((!command? obj) - (display-help-command obj program port)) - ((getopt-error? obj) - (fprintf port "Error: ~a~n" (error-message obj)) - (unless (null? (error-irritants obj)) - (display "Irritants:" port) - (for-each (lambda(x) (display " " port) (display x port)) - (error-irritants obj)) - (newline)) - (newline) - (getopt-display-help (getopt-error-e obj) program port)) - (else - (error "Unexpected object; expected a getopt, getopt-error, or command" obj)))) - -(def (getopt-display-help-topic gopt topic program (port (current-output-port))) - (let lp ((rest (!getopt-cmds gopt))) - (match rest - ([cmd . rest] - (if (eq? topic (!top-key cmd)) - (getopt-display-help cmd program port) - (lp rest))) - (else - (getopt-display-help gopt program port))))) - -(def (display-help-getopt obj program port) - (with ((!getopt opts cmds args help) obj) - (when help - (fprintf port "~a: ~a~n~n" program help)) - (if (null? cmds) - (begin - (fprintf port "Usage: ~a ~a" - program - (if (null? opts) "" "[option ...]")) - (display-args args port) - (unless (null? opts) - (fprintf port "~nOptions:~n") - (display-option-help opts port)) - (unless (null? args) - (fprintf port "~nArguments:~n") - (display-arg-help args port))) - (begin - (fprintf port "Usage: ~a ~a command-arg ...~n" - program - (if (null? opts) "" "[option ...]")) - (unless (null? opts) - (fprintf port "~nOptions:~n") - (display-option-help opts port)) - (fprintf port "~nCommands:~n") - (for-each (match <> - ((!command key help) - (fprintf port " ~a ~a ~a~n" - key - (tabs key) - (or help "?")))) - cmds))))) - -(def (display-help-command obj program port) - (with ((!command key help opts args) obj) - (fprintf port "Usage: ~a ~a~a" - program key - (if (null? opts) "" " [command-option ...]")) - (display-args args port) - (fprintf port " ~a~n" help) - (unless (null? opts) - (fprintf port "~nCommand Options:~n") - (display-option-help opts port)) - (unless (null? args) - (fprintf port "~nArguments:~n") - (display-arg-help args port)))) - -(def (display-args args port) - (for-each (match <> - ((!reqarg key) - (fprintf port " <~a>" key)) - ((!optarg key) - (fprintf port " [<~a>]" key)) - ((!rest key) - (fprintf port " <~a> ..." key))) - args) - (newline port)) - -(def (display-option-help opts port) - (for-each (match <> - ((!option id help short long _ default) - (fprintf port " ~a ~a <~a> ~a ~a [default: ~a]~n" - (or short "") - (or long "") - id - (tabs (or short "") " " (or long "") " <" (symbol->string id) ">") - (or help "?") - default)) - ((!flag _ help short long) - (fprintf port " ~a ~a ~a ~a~n" - (or short "") - (or long "") - (tabs (or short "") " " (or long "")) - (or help "?")))) - opts)) - -(def (display-arg-help args port) - (for-each (match <> - ((!reqarg key help) - (fprintf port " ~a ~a ~a~n" - key (tabs key) (or help "?"))) - ((!optarg key help _ default) - (fprintf port " ~a ~a ~a [default: ~a]~n" - key (tabs key) (or help "?") - default)) - ((!rest key help) - (fprintf port " ~a ~a ~a~n" - key (tabs key) (or help "?")))) - args)) - -(def (tabs . strs) - (def tablen 31) - (def (string-e str) - (if (symbol? str) - (symbol->string str) - str)) - - (let* (len (foldl + 0 (map string-length (map string-e strs)))) - (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 - (let (help-cmd - (command 'help help: "display help; help 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)))))))) +;; TODO: as a (begin-syntax (warnf ...)) compile-time deprecation warning at some point.