/** * 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 )