/**
* Strategies for handling command-line options.
*
* Example:
* ---------------------------------------------------------------------------
* module option-demo
* imports options
*
* strategies
*
* main =
* io-wrap(demo-options, demo-usage, default-system-about, demo-impl)
*
* demo-impl = id
*
* demo-options =
* Option("--option1"
* , <set-config> ("--option1", ())
* , !"--option1 This is a an example option"
* )
* + ArgOption("--arg1"
* , <set-config> ("--arg1", <id>)
* , !"--arg1 This is an example arg option"
* )
*
* demo-usage =
* default-system-usage(
* !"Usage: option-demo [options]"
* , !
* " This is a test program to demonstrate use of
* parse-options and generation of usage info
* from option and switch specificatios. These
* now contain usage info as additional third
* argument."
* )
* ---------------------------------------------------------------------------
*
* option-demo --help now displays:
* ---------------------------------------------------------------------------
* Usage: option-demo [options]
*
* Options:
* --option1 This is a an example option
* --arg1 This is an example arg option
* -i f|--input f Read input from f
* -o f|--output f Write output to f
* -b Write binary output
* -S|--silent Silent execution (same as --verbose 0)
* --verbose i Verbosity level i (default 1)
* -s Turn on statistics
* -k i | --keep i Keep intermediates (default 0)
* -h|-?|--help Display usage information
* --about Display information about this program
* --version Same as --about
*
* Description:
* This is a test program to demonstrate use of
* parse-options and generation of usage info
* from option and switch specificatios. These
* now contain usage info as additional third
* argument.
* ---------------------------------------------------------------------------
*/
module util/config/parse-options
imports
util/config/common
signature
sorts Option
constructors
Program : String -> Option
Undefined : String -> Option
strategies
/**
* Always provide --help switch.
*/
system-usage-switch =
Option("--help" + "-h" + "-?"
, <set-config> ("--help", ())
, !"-h|-?|--help Display usage information"
)
/**
* Always provide the --about and --version switch.
*/
system-about-switch =
Option( "--about"
, <set-config> ("--about", ())
, !"--about Display information about this program"
)
+ Option("--version"
, where(<set-config> ("--about", ()); <set-config> ("-v",()))
, !"--version Same as --about"
)
/**
* Parse command-line options
*/
strategies
/**
* Invokes system-usage and system-about on help and about.
*/
parse-options(s) =
parse-options(s, system-usage, system-about)
/**
* Parse options. Add system-usage switch and display usage info when user
* specified '-h' switch.
*/
parse-options(s, usage, about) =
where(<table-put> ("usage-table", "usage", []))
; parse-options'(s <+ system-usage-switch <+ system-about-switch)
; try(
where(<get-config> "--help")
; usage
; <exit> 0
<+ where(<get-config> "--about")
; about
; <exit> 0
<+ fetch(Undefined(?option))
; <fprintnl> (stderr(), ["Invalid option: ", option])
; usage
; <exit> 1
)
; where(<table-destroy> "usage-table")
/**
* Register all usages of all defined switches; then parse switches as
* specified by the user.
*/
parse-options'(s)=
?[program | args]
; where(<set-config> ("program", program))
; where(id
// apply s to register the usage info
; try(<s> "register-usage-info")
// apply s to perform the initial actions
; try(<s> ("handle-init-action", args))
)
// apply s to handle the command-line options
; [!Program(<id>) | rec x(([] + s; [id|x]) <+ UndefinedOption)]
; where(id
// apply s to perform the default actions
; try(<s> ("handle-default-action", args))
// apply s to perform the check actions
; try(<s> ("handle-check-action", args))
)
strategies
/**
* Register useage info 's' by storing 's' in the table "usage-table".
* Use fail, such that program execution continues with the next
* alternative Option or ArgOption. This way we collect all usage info.
*/
register-usage(s) =
<table-push>("usage-table", "usage", <s>())
; fail
system-usage =
override-system-usage
<+ default-system-usage
system-about =
override-system-about
<+ default-system-about
/**
* No default long description. Overrule to include program description in usage info.
*/
short-description(s) = fail
/**
* No default short description. Overrule to include in usage info.
*/
long-description(s) = fail
/**
* No override of the default system usage.
*/
override-system-usage = fail
/**
* No override of the default system about.
*/
override-system-about = fail
/**
* Default system usage that invokes the short-description and long-description hook.
*/
default-system-usage =
where(<get-config> "program" => p <+ option-defined(Program(?p)))
; default-system-usage(short-description(!p), long-description(!p))
/**
* Display usage info containing a short description of the program., if
* defined, followed by the usages of all switches. Finally, the long
* description of the program is displayed when it is defined.
*/
default-system-usage(short, long) =
(<get-config> "program" => p <+ option-defined(Program(?p)))
; try(short; echo)
; <echo> "\nOptions:"
; <table-get; reverse> ("usage-table", "usage")
; map(<echo> [" ", <id>])
; <echo> "\nDescription:"
; try(long; if is-string then ![<id>] end; echo)
/**
* Just shows the name of the program.
*/
default-system-about =
<get-config; echo> "program"
rules
Option(is-flag, label, s) :
[flag|rest] -> [<label>()|rest]
where
<is-flag> flag
Option(is-flag, label) =
Option(is-flag, label, !"")
/**
* Registere usage info, when Option is applied to the term "register-usage-info"
*/
Option(is-flag, label, s) =
"register-usage-info"
; register-usage(s)
rules
ArgOption(is-flag, label, s) :
[flag, arg | rest] -> [<label> arg | rest]
where <is-flag> flag
ArgOption(is-flag, label) =
ArgOption(is-flag, label, !"")
ArgOption(is-flag, label, s) =
"register-usage-info"
; register-usage(s)
rules
Arg2Option(is-flag, label) =
Arg2Option(is-flag, label, !"")
Arg2Option(is-flag, label, s) :
[flag, arg1, arg2 | rest] -> [<label> (arg1, arg2) | rest]
where
<is-flag> flag
Arg2Option(is-flag, label, s) =
"register-usage-info"
; register-usage(s)
rules
UndefinedOption :
[x | rest] -> [Undefined(x) | rest]
strategies
option-defined(s) = fetch(s)
rules
/**
* The handlers argument of this ArgOption variant must be an OptionHandler.
*/
Option(is-flag, handlers | msg) :
[flag | rest] -> [<handlers> ("handle-user-action", flag) | rest]
where
<is-flag> flag
/**
* Handle a special action, which is specified by a tuple.
*/
Option(is-flag, handlers | msg) =
OptionHandlerHelper(is-flag, handlers)
rules
/**
* The handlers argument of this ArgOption variant must be an OptionHandler.
*/
ArgOption(is-flag, handlers | msg) :
[flag, arg | rest] -> [<handlers> ("handle-user-action", arg) | rest]
where
<is-flag> flag
/**
* Handle a special action, which is specified by a tuple.
*/
ArgOption(is-flag, handlers | msg) =
OptionHandlerHelper(is-flag, handlers)
/**
* @param Initial action
* @param Handle user-specified option
* @param Default action (no user-specified option)
* @param Check action (applied before all options, can be used to very invalid combinations)
*/
strategies
OptionHandlerHelper(is-flag, handlers) =
?("handle-default-action", args)
; if not(<fetch(is-flag)> args) then
handlers
end
; fail
OptionHandlerHelper(is-flag, handlers) =
?(action, _)
; where(not(!action => "handle-default-action"))
; handlers
; fail
OptionHandler(user) =
OptionHandler(id, user, id)
OptionHandler(init, user, default) =
?("handle-init-action", args)
; <init> args
OptionHandler(init, user, default) =
?("handle-user-action", arg)
; <user> arg
OptionHandler(init, user, default) =
?("handle-default-action", args)
; <default> args
/**
* Checks for command-line options.
*/
strategies
/**
* The exit parameter can
* - be <exit> 1 for immediate failure
* - be <set-config> "--help" to report the usage and exit.
* - not fail: failure will silently be ignored
*/
OptionCheck(exit, checks | msg) =
?("handle-check-action", <id>)
; ( checks
<+ <fprintnl> (stderr(), [msg])
; exit
)
; fail
/**
* Checks that this option is not used together with other options.
*/
OptionNotCombinedCheck(is-flag, other-flags) =
where(
if fetch(is-flag) then
if fetch(other-flags) then
fail
end
end
)
/**
* Checks that this option is specified just once, or not at all.
*/
OptionZeroOrOneCheck(is-flag) =
where(
filter(is-flag)
; if ?[_, _ | _] then
fail
end
)
/**
* Checks that this option is used exactly once.
*/
OptionOneCheck(is-flag) =
where(
filter(is-flag)
; if ?[] + ?[_, _ | _] then
fail
end
)
/**
* Checks that this option is used one or more times.
*/
OptionOneOrMoreCheck(is-flag) =
where(
filter(is-flag)
; if ?[] then
fail
end
)