Mirror of GNU Guix
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

233 lines
8.4 KiB

  1. ;;; srfi-37.scm --- args-fold
  2. ;; Copyright (C) 2007, 2008, 2013 Free Software Foundation, Inc.
  3. ;;
  4. ;; This library is free software; you can redistribute it and/or
  5. ;; modify it under the terms of the GNU Lesser General Public
  6. ;; License as published by the Free Software Foundation; either
  7. ;; version 3 of the License, or (at your option) any later version.
  8. ;;
  9. ;; This library is distributed in the hope that it will be useful,
  10. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  12. ;; Lesser General Public License for more details.
  13. ;;
  14. ;; You should have received a copy of the GNU Lesser General Public
  15. ;; License along with this library; if not, write to the Free Software
  16. ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17. ;;; Commentary:
  18. ;;
  19. ;; To use this module with Guile, use (cdr (program-arguments)) as
  20. ;; the ARGS argument to `args-fold'. Here is a short example:
  21. ;;
  22. ;; (args-fold (cdr (program-arguments))
  23. ;; (let ((display-and-exit-proc
  24. ;; (lambda (msg)
  25. ;; (lambda (opt name arg)
  26. ;; (display msg) (quit) (values)))))
  27. ;; (list (option '(#\v "version") #f #f
  28. ;; (display-and-exit-proc "Foo version 42.0\n"))
  29. ;; (option '(#\h "help") #f #f
  30. ;; (display-and-exit-proc
  31. ;; "Usage: foo scheme-file ..."))))
  32. ;; (lambda (opt name arg)
  33. ;; (error "Unrecognized option `~A'" name))
  34. ;; (lambda (op) (load op) (values)))
  35. ;;
  36. ;;; Code:
  37. ;;;; Module definition & exports
  38. (define-module (srfi srfi-37)
  39. #:use-module (srfi srfi-9)
  40. #:export (option option-names option-required-arg?
  41. option-optional-arg? option-processor
  42. args-fold))
  43. (cond-expand-provide (current-module) '(srfi-37))
  44. ;;;; args-fold and periphery procedures
  45. ;;; An option as answered by `option'. `names' is a list of
  46. ;;; characters and strings, representing associated short-options and
  47. ;;; long-options respectively that should use this option's
  48. ;;; `processor' in an `args-fold' call.
  49. ;;;
  50. ;;; `required-arg?' and `optional-arg?' are mutually exclusive
  51. ;;; booleans and indicate whether an argument must be or may be
  52. ;;; provided. Besides the obvious, this affects semantics of
  53. ;;; short-options, as short-options with a required or optional
  54. ;;; argument cannot be followed by other short options in the same
  55. ;;; program-arguments string, as they will be interpreted collectively
  56. ;;; as the option's argument.
  57. ;;;
  58. ;;; `processor' is called when this option is encountered. It should
  59. ;;; accept the containing option, the element of `names' (by `equal?')
  60. ;;; encountered, the option's argument (or #f if none), and the seeds
  61. ;;; as variadic arguments, answering the new seeds as values.
  62. (define-record-type srfi-37:option
  63. (option names required-arg? optional-arg? processor)
  64. option?
  65. (names option-names)
  66. (required-arg? option-required-arg?)
  67. (optional-arg? option-optional-arg?)
  68. (processor option-processor))
  69. (define (error-duplicate-option option-name)
  70. (scm-error 'program-error "args-fold"
  71. "Duplicate option name `~A~A'"
  72. (list (if (char? option-name) #\- "--")
  73. option-name)
  74. #f))
  75. (define (build-options-lookup options)
  76. "Answer an `equal?' Guile hash-table that maps OPTIONS' names back
  77. to the containing options, signalling an error if a name is
  78. encountered more than once."
  79. (let ((lookup (make-hash-table (* 2 (length options)))))
  80. (for-each
  81. (lambda (opt)
  82. (for-each (lambda (name)
  83. (let ((assoc (hash-create-handle!
  84. lookup name #f)))
  85. (if (cdr assoc)
  86. (error-duplicate-option (car assoc))
  87. (set-cdr! assoc opt))))
  88. (option-names opt)))
  89. options)
  90. lookup))
  91. (define (args-fold args options unrecognized-option-proc
  92. operand-proc . seeds)
  93. "Answer the results of folding SEEDS as multiple values against the
  94. program-arguments in ARGS, as decided by the OPTIONS'
  95. `option-processor's, UNRECOGNIZED-OPTION-PROC, and OPERAND-PROC."
  96. (let ((lookup (build-options-lookup options)))
  97. ;; I don't like Guile's `error' here
  98. (define (error msg . args)
  99. (scm-error 'misc-error "args-fold" msg args #f))
  100. (define (mutate-seeds! procedure . params)
  101. (set! seeds (call-with-values
  102. (lambda ()
  103. (apply procedure (append params seeds)))
  104. list)))
  105. ;; Clean up the rest of ARGS, assuming they're all operands.
  106. (define (rest-operands)
  107. (for-each (lambda (arg) (mutate-seeds! operand-proc arg))
  108. args)
  109. (set! args '()))
  110. ;; Call OPT's processor with OPT, NAME, an argument to be decided,
  111. ;; and the seeds. Depending on OPT's *-arg? specification, get
  112. ;; the parameter by calling REQ-ARG-PROC or OPT-ARG-PROC thunks;
  113. ;; if no argument is allowed, call NO-ARG-PROC thunk.
  114. (define (invoke-option-processor
  115. opt name req-arg-proc opt-arg-proc no-arg-proc)
  116. (mutate-seeds!
  117. (option-processor opt) opt name
  118. (cond ((option-required-arg? opt) (req-arg-proc))
  119. ((option-optional-arg? opt) (opt-arg-proc))
  120. (else (no-arg-proc) #f))))
  121. ;; Compute and answer a short option argument, advancing ARGS as
  122. ;; necessary, for the short option whose character is at POSITION
  123. ;; in the current ARG.
  124. (define (short-option-argument position)
  125. (cond ((< (1+ position) (string-length (car args)))
  126. (let ((result (substring (car args) (1+ position))))
  127. (set! args (cdr args))
  128. result))
  129. ((pair? (cdr args))
  130. (let ((result (cadr args)))
  131. (set! args (cddr args))
  132. result))
  133. ((pair? args)
  134. (set! args (cdr args))
  135. #f)
  136. (else #f)))
  137. ;; Interpret the short-option at index POSITION in (car ARGS),
  138. ;; followed by the remaining short options in (car ARGS).
  139. (define (short-option position)
  140. (if (>= position (string-length (car args)))
  141. (begin
  142. (set! args (cdr args))
  143. (next-arg))
  144. (let* ((opt-name (string-ref (car args) position))
  145. (option-here (hash-ref lookup opt-name)))
  146. (cond ((not option-here)
  147. (mutate-seeds! unrecognized-option-proc
  148. (option (list opt-name) #f #f
  149. unrecognized-option-proc)
  150. opt-name #f)
  151. (short-option (1+ position)))
  152. (else
  153. (invoke-option-processor
  154. option-here opt-name
  155. (lambda ()
  156. (or (short-option-argument position)
  157. (error "Missing required argument after `-~A'" opt-name)))
  158. (lambda ()
  159. ;; edge case: -xo -zf or -xo -- where opt-name=#\o
  160. ;; GNU getopt_long resolves these like I do
  161. (short-option-argument position))
  162. (lambda () #f))
  163. (if (not (or (option-required-arg? option-here)
  164. (option-optional-arg? option-here)))
  165. (short-option (1+ position))))))))
  166. ;; Process the long option in (car ARGS). We make the
  167. ;; interesting, possibly non-standard assumption that long option
  168. ;; names might contain #\=, so keep looking for more #\= in (car
  169. ;; ARGS) until we find a named option in lookup.
  170. (define (long-option)
  171. (let ((arg (car args)))
  172. (let place-=-after ((start-pos 2))
  173. (let* ((index (string-index arg #\= start-pos))
  174. (opt-name (substring arg 2 (or index (string-length arg))))
  175. (option-here (hash-ref lookup opt-name)))
  176. (if (not option-here)
  177. ;; look for a later #\=, unless there can't be one
  178. (if index
  179. (place-=-after (1+ index))
  180. (mutate-seeds!
  181. unrecognized-option-proc
  182. (option (list opt-name) #f #f unrecognized-option-proc)
  183. opt-name #f))
  184. (invoke-option-processor
  185. option-here opt-name
  186. (lambda ()
  187. (if index
  188. (substring arg (1+ index))
  189. (error "Missing required argument after `--~A'" opt-name)))
  190. (lambda () (and index (substring arg (1+ index))))
  191. (lambda ()
  192. (if index
  193. (error "Extraneous argument after `--~A'" opt-name))))))))
  194. (set! args (cdr args)))
  195. ;; Process the remaining in ARGS. Basically like calling
  196. ;; `args-fold', but without having to regenerate `lookup' and the
  197. ;; funcs above.
  198. (define (next-arg)
  199. (if (null? args)
  200. (apply values seeds)
  201. (let ((arg (car args)))
  202. (cond ((or (not (char=? #\- (string-ref arg 0)))
  203. (= 1 (string-length arg))) ;"-"
  204. (mutate-seeds! operand-proc arg)
  205. (set! args (cdr args)))
  206. ((char=? #\- (string-ref arg 1))
  207. (if (= 2 (string-length arg)) ;"--"
  208. (begin (set! args (cdr args)) (rest-operands))
  209. (long-option)))
  210. (else (short-option 1)))
  211. (next-arg))))
  212. (next-arg)))
  213. ;;; srfi-37.scm ends here