[bpt/guile.git] / srfi / srfi-37.scm

;;; srfi-37.scm --- args-fold

;; 	Copyright (C) 2007 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 2.1 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
\f
#! Commentary

To use this module with Guile, use (cdr (program-arguments)) as
the ARGS argument to `args-fold'.  Here is a short example:

 (args-fold (cdr (program-arguments))
	    (let ((display-and-exit-proc
		   (lambda (msg)
		     (lambda (opt name arg)
		       (display msg) (quit) (values)))))
	      (list (option '(#\v "version") #f #f
			    (display-and-exit-proc "Foo version 42.0\n"))
		    (option '(#\h "help") #f #f
			    (display-and-exit-proc
			     "Usage: foo scheme-file ..."))))
	    (lambda (opt name arg)
	      (error "Unrecognized option `~A'" name))
	    (lambda (op) (load op) (values)))
!#
\f
;;;; Module definition & exports
(define-module (srfi srfi-37)
  #:use-module (srfi srfi-9)
  #:export (option option-names option-required-arg? 
	    option-optional-arg? option-processor
	    args-fold))

(cond-expand-provide (current-module) '(srfi-37))
\f
;;;; args-fold and periphery procedures

;;; An option as answered by `option'.  `names' is a list of
;;; characters and strings, representing associated short-options and
;;; long-options respectively that should use this option's
;;; `processor' in an `args-fold' call.
;;;
;;; `required-arg?' and `optional-arg?' are mutually exclusive
;;; booleans and indicate whether an argument must be or may be
;;; provided.  Besides the obvious, this affects semantics of
;;; short-options, as short-options with a required or optional
;;; argument cannot be followed by other short options in the same
;;; program-arguments string, as they will be interpreted collectively
;;; as the option's argument.
;;;
;;; `processor' is called when this option is encountered.  It should
;;; accept the containing option, the element of `names' (by `equal?')
;;; encountered, the option's argument (or #f if none), and the seeds
;;; as variadic arguments, answering the new seeds as values.
(define-record-type srfi-37:option
  (option names required-arg? optional-arg? processor)
  option?
  (names option-names)
  (required-arg? option-required-arg?)
  (optional-arg? option-optional-arg?)
  (processor option-processor))

(define (error-duplicate-option option-name)
  (scm-error 'program-error "args-fold"
	     "Duplicate option name `~A~A'"
	     (list (if (char? option-name) #\- "--")
		   option-name)
	     #f))

(define (build-options-lookup options)
  "Answer an `equal?' Guile hash-table that maps OPTIONS' names back
to the containing options, signalling an error if a name is
encountered more than once."
  (let ((lookup (make-hash-table (* 2 (length options)))))
    (for-each
     (lambda (opt)
       (for-each (lambda (name)
		   (let ((assoc (hash-create-handle!
				 lookup name #f)))
		     (if (cdr assoc)
			 (error-duplicate-option (car assoc))
			 (set-cdr! assoc opt))))
		 (option-names opt)))
     options)
    lookup))

(define (args-fold args options unrecognized-option-proc
		   operand-proc . seeds)
  "Answer the results of folding SEEDS as multiple values against the
program-arguments in ARGS, as decided by the OPTIONS'
`option-processor's, UNRECOGNIZED-OPTION-PROC, and OPERAND-PROC."
  (let ((lookup (build-options-lookup options)))
    ;; I don't like Guile's `error' here
    (define (error msg . args)
      (scm-error 'misc-error "args-fold" msg args #f))

    (define (mutate-seeds! procedure . params)
      (set! seeds (call-with-values
		      (lambda ()
			(apply procedure (append params seeds)))
		    list)))

    ;; Clean up the rest of ARGS, assuming they're all operands.
    (define (rest-operands)
      (for-each (lambda (arg) (mutate-seeds! operand-proc arg))
		args)
      (set! args '()))

    ;; Call OPT's processor with OPT, NAME, an argument to be decided,
    ;; and the seeds.  Depending on OPT's *-arg? specification, get
    ;; the parameter by calling REQ-ARG-PROC or OPT-ARG-PROC thunks;
    ;; if no argument is allowed, call NO-ARG-PROC thunk.
    (define (invoke-option-processor
	     opt name req-arg-proc opt-arg-proc no-arg-proc)
      (mutate-seeds!
       (option-processor opt) opt name
       (cond ((option-required-arg? opt) (req-arg-proc))
	     ((option-optional-arg? opt) (opt-arg-proc))
	     (else (no-arg-proc) #f))))

    ;; Compute and answer a short option argument, advancing ARGS as
    ;; necessary, for the short option whose character is at POSITION
    ;; in the current ARG.
    (define (short-option-argument position)
      (cond ((< (1+ position) (string-length (car args)))
	     (let ((result (substring (car args) (1+ position))))
	       (set! args (cdr args))
	       result))
	    ((pair? (cdr args))
	     (let ((result (cadr args)))
	       (set! args (cddr args))
	       result))
	    (else #f)))

    ;; Interpret the short-option at index POSITION in (car ARGS),
    ;; followed by the remaining short options in (car ARGS).
    (define (short-option position)
      (if (>= position (string-length (car args)))
	  (next-arg)
	  (let* ((opt-name (string-ref (car args) position))
		 (option-here (hash-ref lookup opt-name)))
	    (cond ((not option-here)
		   (mutate-seeds! unrecognized-option-proc
				  (option (list opt-name) #f #f
					  unrecognized-option-proc)
				  opt-name #f)
		   (short-option (1+ position)))
		  (else
		   (invoke-option-processor
		    option-here opt-name
		    (lambda ()
		      (or (short-option-argument position)
			  (error "Missing required argument after `-~A'" opt-name)))
		    (lambda ()
		      ;; edge case: -xo -zf or -xo -- where opt-name=#\o
		      ;; GNU getopt_long resolves these like I do
		      (short-option-argument position))
		    (lambda () #f))
		   (if (not (or (option-required-arg? option-here)
				(option-optional-arg? option-here)))
		       (short-option (1+ position))))))))

    ;; Process the long option in (car ARGS).  We make the
    ;; interesting, possibly non-standard assumption that long option
    ;; names might contain #\=, so keep looking for more #\= in (car
    ;; ARGS) until we find a named option in lookup.
    (define (long-option)
      (let ((arg (car args)))
	(let place-=-after ((start-pos 2))
	  (let* ((index (string-index arg #\= start-pos))
		 (opt-name (substring arg 2 (or index (string-length arg))))
		 (option-here (hash-ref lookup opt-name)))
	    (if (not option-here)
		;; look for a later #\=, unless there can't be one
		(if index
		    (place-=-after (1+ index))
		    (mutate-seeds!
		     unrecognized-option-proc
		     (option (list opt-name) #f #f unrecognized-option-proc)
		     opt-name #f))
		(invoke-option-processor
		 option-here opt-name
		 (lambda ()
		   (if index
		       (substring arg (1+ index))
		       (error "Missing required argument after `--~A'" opt-name)))
		 (lambda () (and index (substring arg (1+ index))))
		 (lambda ()
		   (if index
		       (error "Extraneous argument after `--~A'" opt-name))))))))
      (set! args (cdr args)))

    ;; Process the remaining in ARGS.  Basically like calling
    ;; `args-fold', but without having to regenerate `lookup' and the
    ;; funcs above.
    (define (next-arg)
      (if (null? args)
	  (apply values seeds)
	  (let ((arg (car args)))
	    (cond ((or (not (char=? #\- (string-ref arg 0)))
		       (= 1 (string-length arg))) ;"-"
		   (mutate-seeds! operand-proc arg)
		   (set! args (cdr args)))
		  ((char=? #\- (string-ref arg 1))
		   (if (= 2 (string-length arg)) ;"--"
		       (begin (set! args (cdr args)) (rest-operands))
		       (long-option)))
		  (else (short-option 1)))
	    (next-arg))))

    (next-arg)))

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