;;;; -*- scheme -*-
;;;; command-line-processor.scm --- command-line options processing
;;;;
;;;; Copyright (C) 1998, 2001, 2006, 2009, 2011, 2020
;;;; Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;;;; 02110-1301 USA
;;; Author: Dale Mellor May, 2020
;;; Commentary:
;;; Where the Guile (ice-9 getopt-long) module, modelled after the GNU C
;;; libraryʼs ‘getopt_long’ function, allows an application to construct
;;; a grammar prescribing the decomposition of the command-line options,
;;; this module, inspired by the C libraryʼs ‘argp’ parser, gives the
;;; application a higher-level paradigm in which the command-line
;;; processing is specified declaratively. This includes enough of the
;;; application meta-data and some fragmentary help strings for the
;;; completely automatic generation of responses to GNU-standard
;;; ‘--help’, ‘--version’ and ‘--usage’ options, thus alleviating the
;;; need of the application itself to deal with these things.
;;;
;;; The module has three specific aims.
;;;
;;; 1) Provide higher-level declarative interface, easier to use.
;;;
;;; 2) Automatically respond to --help, --version and --usage
;;; options.
;;;
;;; 3) Allow amalgamation of specifications, so that an application
;;; can mix in requirements from modules into its own option
;;; specification--THIS IS NOT CURRENTLY IMPLEMENTED.
;;;
;;; There is just one function which needs to be called to get all of
;;; this functionality: it is ‘process-command-line’, and has the side
;;; effect that new variable bindings appear in the current module
;;; corresponding to all the options. For example, if a declared option
;;; is ‘--do-this’, then a variable called, literally, ‘--do-this’ will
;;; be injected in the current namespace and will have the value
;;; provided on the command-line, or simply #t or #f to indicate whether
;;; or not that option was present on the command line.
;;;
;;; Alternatively, it is possible to create and compose the
;;; specification in separate steps, and then call the above method with
;;; the results. The functions ‘command-line-specification’ and
;;; ‘merge-command-line-specifications’ are provided to this end.
;;; (process-command-line COMMAND-LINE SPECIFICATION)
;;; Process the COMMAND-LINE according to the application SPECIFICATION.
;;;
;;; COMMAND-LINE is a list of strings, such as that returned from the
;;; core ‘command-line’ function.
;;;
;;; SPECIFICATION is a form holding a space-separated mix of selection
;;; words followed by their respective declarations. The selection
;;; words are ‘application’, ‘author’, ‘bug-address’, ‘copyright’,
;;; ‘help-preamble’, ‘help-postamble’, ‘license’, ‘option’, ‘usage’ and
;;; ‘version’, and can appear in any order.
;;;
;;; ‘application’ should be followed by a string: the name of the
;;; application with possibly the package name in
;;; parentheses afterwards
;;; ‘author’ should be followed by a string giving the name of one of
;;; the packageʼs authors. This selection word can be
;;; repeated as many times as necessary to provide the names
;;; of all authors.
;;; ‘bug-address’ should be followed by a string giving the URL of a
;;; contact-point for sending bug reports, such as an
;;; e-mail address or web address of bug-tracking system
;;; interface
;;; ‘copyright’ should be followed by a string containing a list of
;;; years and an entity to whom the copyright is assigned.
;;; This may be repeated to list other assignees
;;; ‘help-preamble’ should be followed by a number of strings which
;;; make up a short paragraph of text displayed before
;;; a full list of the available program options
;;; ‘help-postamble’, like the preamble, is followed by strings which
;;; make up a paragraph of text, shown after the list
;;; of options
;;; ‘license’ can be followed by one of the words ‘GPLv3’ [this is
;;; currently the only standard choice implemented], or else
;;; a string which briefly gives out the terms of the license
;;; ‘option’ is followed by an option declaration, described below
;;; ‘usage’ is followed by a string describing the usage of the
;;; application on one line
;;; ‘version’ is followed by a string providing the current version
;;; number of this program
;;;
;;; The ‘option’ declaration is followed by another form bracketed by
;;; parentheses and holding a space-separated mix of declarations (order
;;; irrelevant).
;;;
;;; A word beginning with two hyphens, an optional exclamation point,
;;; alpha-numeric characters, an optional equals sign, and an
;;; optional further word. There must be exactly one of these, and
;;; they determine the long name of the option. An exclamation point
;;; indicates that the option MUST appear on the command line, an
;;; equals indicates that the option MUST have a value unless it is
;;; followed in the specification by a value, in which case the value
;;; on the command-line is optional and the one in the specification
;;; will be taken as the default when not given on the command line.
;;;
;;; A word comprised of one hyphen and one letter or number. There
;;; can be exactly zero or one of these, and it declares that the
;;; option has this short form available on the command-line. As a
;;; very special exception: if you want to use ‘-i’ as an option, it
;;; must be specified with the identifier ‘short-i’ (a naked /-i/ is
;;; read as a complex number); ditto ‘short-I’ for ‘-I’.
;;;
;;; A number of strings which are catenated together to provide a
;;; short, succinct description of the option. These strings should
;;; be approximately half the width of a page, i.e. about 40
;;; characters.
;;;
;;; A function which will be used as a predicate to decide if a value
;;; is allowable for this option. There should be zero or one of
;;; these.
;;;
;;; For the precise presentation of options on the command-line, the
;;; reader should refer to the description of the ‘getopt-long’ module,
;;; which underlies the present one.
;;;
;;; At this point a short example is in order. The main entry point for
;;; the GNU Mcron program has as its first clause
;;;
;;; (process-command-line (command-line)
;;; application "mcron"
;;; version "1.4"
;;; usage "[OPTIONS]... [FILES]..."
;;; help-preamble
;;; "Run an mcron process according to the specifications in the FILE... "
;;; "(`-' for standard input), or use all the files in ~/.config/cron "
;;; "(or the deprecated ~/.cron) with .guile or .vixie extensions.\n"
;;; "Note that --daemon and --schedule are mutually exclusive."
;;; option (--daemon -d
;;; "run as a daemon process")
;;; option (--stdin=guile short-i (λ (in) (or (string=? in "guile")
;;; (string=? in "vixie")))
;;; "format of data passed as standard input or file "
;;; "arguments, 'guile' or 'vixie' (default guile)")
;;; option (--schedule=8 -s string->number
;;; "display the next N (or 8) jobs that will be run")
;;; help-postamble
;;; "Mandatory or optional arguments to long options are also mandatory or "
;;; "optional for any corresponding short options."
;;; bug-address "bug-mcron@gnu.org"
;;; copyright "2003, 2006, 2014, 2020 Free Software Foundation, Inc."
;;; license GPLv3)
;;;
;;; after which there are four new variable bindings in the present
;;; namespace: --daemon, --stdin, --schedule and --! (the latter holds
;;; all the command-line arguments that did not partake in option
;;; processing) whose values depend on the specific command-line options
;;; the end user furnished.
;;; (command-line-specification SPECIFICATION)
;;; Compiles an object which encapsulates the given SPECIFICATION.
;;;
;;; For details of how to give a SPECIFICATION, see the description of
;;; the full ‘process-command-line’ function above. The return from
;;; this method can be used in the partial version of
;;; ‘process-command-line’ described below, and in the following
;;; ‘merge-command-line-specifications’ function.
;;; (merge-command-line-specifications SPECIFICATION_OBJECT ...) Make a
;;; single specification object which embodies the amalgamation of all
;;; of the specification objects given as arguments.
;;;
;;; Order is important: if two option items specify the same short form
;;; for the option (a single letter), then only the first option will
;;; actually have that short form available at the command-line.
;;; Similarly, if two options have exactly the same name, the second (or
;;; later) ones will have a numerical digit appended to their name.
;;; (process-command-line COMMAND-LINE SPECIFICATION-OBJECT) Perform
;;; exactly the same function as the full ‘process-command-line’
;;; function described above, but takes a pre-made specification object
;;; produced using the two functions above.
;;; Bugs/To do
;;;
;;; 1) This stuff currently only works in the top-level module.
;;;
;;; 2) Want to be able to amalgamate command-line specifications from
;;; different modules. Will need to get to the bottom of the first
;;; issue before we can tackle this one (somehow need to put the
;;; --option variable bindings into the right places, or at least
;;; replicate them all in all modules which want to do some processing
;;; of the command line).
;;;
;;; 3) Want more license boilerplate text; currently we only have GPLv3.
;;; Code:
(define-module (mcron command-line-processor)
#:use-module (srfi srfi-1) ;; fold
#:use-module (srfi srfi-9) ;; records
#:use-module (srfi srfi-9 gnu) ;; set/get-fields
#:use-module (mcron getopt-long)
#:use-module (ice-9 regex)
#:export (specific option item
obtain-getopt-long-results
process-getopt-long-results
;; These are the real public exports.
process-command-line
command-line-specification
merge-command-line-specifications))
(define-record-type <<specification>>
(make-specification- preamble postamble copyright authors options)
specification?
(name spec:name spec:set-name!)
(version spec:version spec:set-version!)
(usage spec:usage spec:set-usage!)
(preamble spec:preamble spec:set-preamble!)
(postamble spec:postamble spec:set-postamble!)
(bug-address spec:bugs spec:set-bugs!)
(copyright spec:copyright spec:set-copyright!)
(license spec:license spec:set-license!)
(authors spec:authors spec:set-authors!)
(options spec:options spec:set-all-options!))
;; We initialize the fields which are supposed to be lists, but
;; generally this procedure should *not* be considered to be producing a
;; properly specified <<specification>> record.
(define (make-specification) (make-specification- '() '() '() '() '()))
(define-record-type <<option>>
(make-option- description)
option?
(name option:name option:set-name!)
(required? option:required?)
(short-letter option:short option:set-short!)
(value? option:value?)
(default option:default)
(description option:description option:set-description!)
(predicate option:predicate option:set-predicate!))
;; As above, this initializer does *not* return a properly defined
;; object.
(define (make-option) (make-option- '()))
(define (has-option-short-form spec letter)
(not (or (not letter)
(eq? #f (find (λ (a) (eqv? letter (option:short a)))
(spec:options spec))))))
(define (has-option-name spec name)
(not (eq? #f (find (λ (a) (string=? (option:name a) name))
(spec:options spec)))))
(define (merge-command-line-specifications- A B)
(for-each (λ (b-option)
(when (has-option-short-form A (option:short b-option))
(option:set-short! b-option #f))
(let ((base-name (option:name b-option)))
(when (has-option-name A base-name)
(let loop ((count 1))
(let ((new-name (string-append base-name "-"
(number->string count))))
(if (has-option-name A new-name)
(loop (1+ count))
(option:set-name! b-option new-name))))))
(spec:set-all-options! A (append (spec:options A)
(list b-option))))
(spec:options B))
A)
(define-syntax merge-command-line-specifications
(syntax-rules ()
"- Scheme Procedure: merge-command-line-specifications A B ...
Append the list of options in A with those in B, but drop any
short-forms in B which clash with existing ones, and if a long option
name clashes then append a number to make it unique. All of the
arguments will be mutilated in the process, and a new specification
object will be returned."
((_ A B) (merge-command-line-specifications- A B))
((_ A B . C) (merge-command-line-specifications
(merge-command-line-specifications- A B)
. C))))
(define long-re (make-regexp "^--(!)?([[:alnum:]][-_[:alnum:]]*)(=(.+)?)?$"))
(define short-re (make-regexp "^-[[:alnum:]]$"))
(define-syntax item ;; As in, an option item (long name, short form...).
(λ (x) (syntax-case x (short-i short-I)
;; No more work to do.
((_ O) #'#t)
;; Next option is a string: take as description.
((_ O desc . args)
(string? (syntax->datum #'desc))
#'(begin (option:set-description! O (append (option:description O)
(list desc)))
(item O . args)))
;; Next option is short-form.
((_ O short-i . args)
#'(begin (option:set-short! O #\i)
(item O . args)))
((_ O short-I . args)
#'(begin (option:set-short! O #\I)
(item O . args)))
((_ O short . args)
(and (identifier? #'short)
(regexp-exec short-re (symbol->string (syntax->datum #'short))))
#'(begin (option:set-short! O (string-ref (symbol->string 'short) 1))
(item O . args)))
;; Next option is long-form.
((_ O long . args)
(and (identifier? #'long)
(regexp-exec long-re (symbol->string (syntax->datum #'long))))
#'(begin (let ((match (regexp-exec long-re
(symbol->string (syntax->datum #'long)))))
(set! O
(set-fields O
((option:name) (match:substring match 2))
((option:required?) (if (match:substring match 1) #t #f))
((option:value?)
(cond ((not (match:substring match 3)) #f)
((match:substring match 4) 'optional)
(else #t)))
((option:default) (match:substring match 4)))))
(item O . args)))
;; Next option is a procedure: take as predicate.
((_ O (lambda args ...) . Args)
#'(begin (option:set-predicate! O (lambda args ...))
(item O . Args)))
((_ O pred . args)
(and (identifier? #'pred)
;; (procedure? (primitive-eval (syntax->datum #'pred)))
)
#'(begin (option:set-predicate! O pred)
(item O . args))))))
(define-syntax-rule (option args ...)
(let ((O (make-option))) (item O args ...) O))
(define-syntax specific
(λ (x) (syntax-case x (application author bug-address
copyright help-preamble help-postamble
license option usage
version)
((specific spec application A args ...)
(string? (syntax->datum #'A))
#'(begin (spec:set-name! spec A)
(specific spec args ...)))
((specific spec author A args ...)
(string? (syntax->datum #'A))
#'(begin (spec:set-author! spec (append (spec:authors spec)
(list A)))
(specific spec args ...)))
((specific spec bug-address B args ...)
(string? (syntax->datum #'B))
#'(begin (spec:set-bugs! spec B)
(specific spec args ...)))
((specific spec copyright C args ...)
(string? (syntax->datum #'C))
#'(begin (spec:set-copyright! spec (append (spec:copyright spec)
(list C)))
(specific spec args ...)))
((specific spec help-preamble id args ...)
(identifier? #'id)
#'(specific spec id args ...))
((specific spec help-preamble quotation args ...)
(string? (syntax->datum #'quotation))
#'(begin (spec:set-preamble! spec (append (spec:preamble spec)
(list quotation)))
(specific spec help-preamble args ...)))
((specific spec help-postamble id args ...)
(identifier? #'id)
#'(specific spec id args ...))
((specific spec help-postamble quotation args ...)
(string? (syntax->datum #'quotation))
#'(begin (spec:set-postamble! spec (append (spec:postamble spec)
(list quotation)))
(specific spec help-postamble args ...)))
((specific spec license L args ...)
(identifier? #'L)
#'(begin (spec:set-license! spec 'L)
(specific spec args ...)))
((specific spec license L args ...)
(string? (syntax->datum #'L))
#'(begin (spec:set-license! spec L)
(specific spec args ...)))
((specific spec option (args ...) Args ...)
#'(begin (spec:set-all-options! spec
(append (spec:options spec)
(list (option args ...))))
(specific spec Args ...)))
((specific spec usage U args ...)
(string? (syntax->datum #'U))
#'(begin (spec:set-usage! spec U)
(specific spec args ...)))
((specific spec version V args ...)
(string? (syntax->datum #'V))
#'(begin (spec:set-version! spec V)
(specific spec args ...)))
((specific spec) #'#t))))
(define-syntax-rule (command-line-specification args ...)
;; " - Scheme Procedure: command-line-specification ARGS ...
;; Furnish an application specification object with attributes specified in
;; ARGS followed by a number of values for the attribute. Please refer to
;; full documentation for a proper description of a specification object.
;; The attributes are
;; application: string: the formal name of this application. Must appear
;; exactly once.
;; author: string: the name of an author. May appear any number of times.
;; bug-address: string: The URI to which bug reports should be addressed.
;; May appear zero or one times.
;; copyright: string: list of years and owning entity. May appear any
;; number of times.
;; help-preamble: string: text to precede the list of options in a
;; response to the --help option. This attribute may appear any
;; number of times, and each occurrence can be followed by one or
;; more strings which will be assembled together into paragraphs.
;; help-postamble: string: text to succeed the list of options in a help
;; message. Same considerations apply as to ‘help-preamble’.
;; license: identifier or string: either the identifier ‘GPLv3’ or a
;; string describing the terms of the license.
;; option: (sub-form): the sub-form must contain one identifier composed
;; of two hyphens, an optional exclamation point, a token of
;; letters, numbers, underscore and hyphen, an optional equals
;; sign, and an optional word; the sub-form may have zero or one
;; identifiers composed of a hyphen and a single letter; any
;; number of strings which will be composed into a paragraph of
;; help for the option (these should be sized to half-line
;; lengths); and zero or one procedures which will be applied as a
;; predicate on allowable option values. Any number of these
;; option attributes may appear in the specification.
;; usage: string: a single line of text prototyping the command line.
;; Zero or one of these may appear.
;; version: string: the version number of this application. Zero or one
;; of these attributes may appear."
(let ((spec (make-specification)))
(specific spec args ...)
spec))
(define (version-string spec)
(with-output-to-string (λ ()
(display (if (string? (spec:name spec))
(spec:name spec)
(car (command-line))))
(when (string? (spec:version spec))
(for-each display `(" " ,(spec:version spec) "\n")))
(unless (null? (spec:copyright spec))
(for-each display `("Copyright © "
,(string-join (spec:copyright spec) "\n ")
"\n")))
(cond ((eq? (spec:license spec) 'GPLv3)
(display (string-append
"License GPLv3+: GNU GPL version 3 or later "
"<https://gnu.org/licenses/gpl.html>.\nThis is "
"free software: you are free to change and "
"redistribute it.\nThere is NO WARRANTY, to the "
"extent permitted by law.\n")))
((string? (spec:license spec))
(display (spec:license spec)) (newline)))
(unless (null? (spec:authors spec))
(display (string-append "Written by "
(case (length (spec:authors spec))
((1 2) (string-join (spec:authors spec) " and "))
(else
(let loop ((a (cdr (spec:authors spec)))
(ret (car (spec:authors spec))))
(if (null? (cdr a))
(string-append ret " and " (car a))
(loop (cdr a) (string-append ret ", "
(car a)))))))
".\n"))))))
(define (usage-string spec)
(string-append "Usage: " (spec:name spec) " " (spec:usage spec) "\n"))
(define (help-string spec)
(with-output-to-string (λ ()
(for-each display `(,(usage-string spec)
,(string-join (spec:preamble spec) "\n")
"\n\n"))
(let ((max-length (fold (λ (o r) (max r (string-length (option:name o))))
0
(spec:options spec))))
(for-each (λ (o)
(display " ")
(cond ((option:short o)
(display "-") (display (option:short o))
(case (option:value? o) ((#t) (display "N, "))
((optional) (display "[N], "))
(else (display ", "))))
(else (display " ")))
(display "--")
(display (option:name o))
(case (option:value? o) ((#t) (display "=N "))
((optional) (display "[=N]"))
(else (display " ")))
(display (make-string (- max-length
(string-length (option:name o)))
#\space))
(display " ")
(when (option:required? o) (display "*REQUIRED*: "))
(display (string-join (option:description o)
(string-append "\n"
(make-string max-length
#\space)
" ")))
(newline))
(spec:options spec)))
(newline)
(display (string-join (spec:postamble spec) "\n"))
(when (spec:bugs spec)
(for-each display
`("\nSend bug reports to " ,(spec:bugs spec) ".\n"))))))
;; Make a list out of the args, omitting any #f.
(define (compose-list . args)
(let loop ((ret '()) (args args))
(cond ((null? args) (reverse ret))
((not (car args)) (loop ret (cdr args)))
(else (loop (cons (car args) ret) (cdr args))))))
(define (make-getopt-long-input spec)
(map (λ (o)
(compose-list (string->symbol (option:name o))
(and=> (option:short o) (λ (x) `(single-char ,x)))
`(required? ,(option:required? o))
`(value ,(if (option:default o)
'optional
(option:value? o)))
(and=> (option:predicate o) (λ (x) `(predicate ,x)))))
(spec:options spec)))
(define-syntax-rule (obtain-getopt-long-results args spec)
(getopt-long args (make-getopt-long-input spec)))
(define (distill-getopt-long-results go-l spec)
(cons (cons "!" (option-ref go-l '() '()))
(map (λ (o)
(let ((g (option-ref go-l
(string->symbol (option:name o))
#f)))
(when g
(case (string->symbol (option:name o))
((help) (display (help-string spec)) (exit 0))
((version) (display (version-string spec)) (exit 0))
((usage) (display (usage-string spec)) (exit 0))))
(cons (option:name o)
(if (and (eq? #t g)
(not (eq? #f (option:default o))))
(option:default o)
g))))
(spec:options spec))))
(define (process-getopt-long-results go-l spec)
(for-each (λ (option)
(module-define!
(current-module)
(string->symbol (string-append "--" (car option)))
(cdr option)))
(distill-getopt-long-results go-l spec)))
(define-syntax process-command-line
;; "- Scheme Procedure: process-command-line COMMAND-LINE SPECS [...]
;; Process the COMMAND-LINE according to the SPECS, extracting options and
;; their values, dealing with --help, --version and --usage requests. The
;; procedure has no return values, but has the side effect of creating
;; variable bindings in the current module corresponding to the long form
;; of the options, plus a variable called ‘--!’ which gets a list of all
;; the arguments on the command-line which did not participate in option
;; processing.
;; The COMMAND-LINE is a list of strings, starting with the name of the
;; program and containing all the tokens passed to the program on the
;; command line, such as returned from the core ‘command-line’ procedure.
;; The SPECS should have been obtained with the
;; ‘command-line-specification’ procedure, or, as a short-cut, can be
;; supplied directly as arguments to this procedure."
(syntax-rules ()
((_ command-line specs)
(let ((S (merge-command-line-specifications
specs
(command-line-specification
option (-h --help "display this help and exit")
option (-V --version "output version information and exit")
option (-u --usage "show brief usage summary")))))
(process-getopt-long-results
(obtain-getopt-long-results command-line S)
S)))
((_ command-line item ...)
(process-command-line
command-line
(command-line-specification item ...)))))
