-
Notifications
You must be signed in to change notification settings - Fork 0
/
command-line.scm
166 lines (163 loc) · 6.45 KB
/
command-line.scm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Command line argument handling for R7RS Scheme.
;;;
;;; See README and command-line.sld for more information.
;;;
;;; This software is written by Evan Hanson <[email protected]> and
;;; placed in the Public Domain. All warranties are disclaimed.
;;;
;;
;; `match-option` matches a single option specification against a list
;; of command line arguments.
;;
;; If the given `arguments` don't match the `specification`, an error is
;; signaled. Otherwise, the matching items in `arguments` are collected
;; into an association pair and the continuation `continue` is called
;; with the list of remaining items and resulting pair as arguments.
;;
;; This procedure is internal to command-line.sld.
;;
(define (match-option specification arguments continue)
(let lp ((spec (cdr specification))
(args (cdr arguments))
(cont (lambda (args vals)
(continue args (cons (car specification) vals)))))
(cond ((null? spec)
(cont args (list)))
((null? args)
(error "Insufficient arguments for command line option"
(car specification)))
((string=? "--" (car args))
(error "Invalid value for command line option"
(car specification)))
((pair? spec)
(if (pair? (car spec)) ; Nested option specs aren't supported.
(error "Invalid command line option specification" specification)
(lp (car spec)
(list (car args))
(lambda (_ head)
(lp (cdr spec)
(cdr args)
(lambda (args tail)
(cont args (cons head tail))))))))
((procedure? spec)
(cont (cdr args) (spec (car args))))
(else
(cont (cdr args) (car args))))))
;;
;; `normalize-grammar` compiles an options grammar into a standardized
;; format. Currently, this means splitting any option specifications
;; whose `car` is a list into multiple entries, allowing the following
;; abbreviated syntax for option aliases:
;;
;; (normalize-grammar '(((--foo --bar --baz) . qux)))
;; ; => ((--foo . qux)
;; (--bar . qux)
;; (--baz . qux))
;;
;; This procedure is internal to command-line.sld.
;;
(define normalize-grammar
(letrec ((fold (lambda (f a l)
(if (pair? l) (fold f (f a (car l)) (cdr l)) a))))
(lambda (grammar)
(fold (lambda (a g)
(if (pair? g)
(let ((n (car g))
(s (cdr g)))
(if (list? n)
(append (map (lambda (k) (cons k s)) n) a)
(cons g a)))
(error "Invalid command line option specification" g)))
'()
(reverse grammar)))))
;;
;; `parse-command-line` parses a program's command line arguments into
;; an association list according to an S-expressive options grammar.
;;
;; It takes one required and two optional arguments: an option matching
;; procedure, an S-expressive options `grammar`, and a list of command
;; line argument strings. If `matcher` is not given a basic string
;; comparison is used, while `arguments` defaults to the value of `(cdr
;; (command-line))`.
;;
;; `grammar` is a finite list of pairs whose `car`s are symbols and
;; whose `cdr`s are pairs or atoms. All other `car`s in the grammar must
;; be atoms; grammars may not be nested.
;;
;; The given `arguments` are matched as symbols against the `car`s of
;; the options grammar. When a match is found, an association from the
;; matched symbol to the arguments immediately following the matched
;; item in the arguments list is added, following the form of the
;; matched pair.
;;
;; (parse-command-line
;; '("foo" "bar")
;; '((foo . bar))) ; => ((foo . "bar")
;; (--))
;;
;; (parse-command-line
;; '("foo" "bar" "baz" "qux")
;; '((foo)
;; (bar baz qux))) ; => ((foo)
;; (bar "baz" "qux")
;; (--))
;;
;; Unmatched arguments are added to the resulting association list under
;; the key `--`. Similarly, any arguments following a `"--"` in the
;; arguments list are treated as unmatched.
;;
;; (parse-command-line
;; '("foo" "bar" "baz")
;; '((foo . bar))) ; => ((foo . "bar")
;; (-- "baz"))
;;
;; (parse-command-line
;; '("foo" "bar" "--" "baz" "qux")
;; '((foo . bar)
;; (baz . qux))) ; => ((foo . "bar")
;; (-- "baz" "qux"))
;;
;; In a matched options form, procedures are replaced by the result of
;; invoking that procedure on the corresponding item in the arguments
;; list. All other objects are replaced by the corresponding argument
;; string directly.
;;
;; (parse-command-line
;; '("foo" "bar" "42" "qux")
;; `((foo ,list ,string->number ,string->symbol)))
;; ; => ((foo ("bar") 42 qux)
;; (--))
;;
(define parse-command-line
(case-lambda
((grammar)
(parse-command-line (lambda _ #f) (cdr (command-line)) grammar))
((arguments grammar)
(parse-command-line (lambda _ #f) arguments grammar))
((matcher arguments grammar)
(let ((grammar (normalize-grammar grammar)))
(let lp ((args arguments)
(unmatched (list))
(matched (list)))
(if (null? args)
(reverse (cons (cons '-- (reverse unmatched)) matched))
(let ((arg (car args))
(cont (lambda (args vals)
(lp args unmatched (cons vals matched)))))
(cond ;; Simple match.
((assq (string->symbol arg) grammar) =>
(lambda (spec)
(match-option spec args cont)))
;; Custom match (via `matcher` procedure).
((matcher arg grammar) =>
(lambda (handler)
(handler args (lambda (spec args)
(match-option spec args cont)))))
;; Treat all arguments following "--" as unmatched.
((string=? "--" arg)
(lp (list) (append (reverse (cdr args)) unmatched) matched))
;; An unmatched argument.
(else
(lp (cdr args) (cons arg unmatched) matched))))))))))