1#lang racket/base 2 3;; Minimize imports here, because `raco setup' has to load this file 4;; and its dependencies from source 5 6(require (for-syntax racket/base)) 7 8(provide command-line parse-command-line) 9 10(define-syntax (command-line stx) 11 (define (id=? x y) 12 (eq? (syntax-e x) (syntax-e y))) 13 (define (serror msg . detail) 14 (apply raise-syntax-error #f msg stx detail)) 15 (define (extract-one what args . detail) 16 (if (null? args) 17 (apply serror (format "missing ~a" what) detail) 18 (values (car args) (cdr args)))) 19 (define (extract-list stx/list pred) 20 (let loop ([xs null] 21 [rest (if (syntax? stx/list) (syntax->list stx/list) stx/list)]) 22 (if (and (pair? rest) (pred (car rest))) 23 (loop (cons (car rest) xs) (cdr rest)) 24 (values (reverse xs) rest)))) 25 (define (formal-names l) 26 (map (lambda (a) 27 (datum->syntax 28 (quote-syntax here) 29 (let ([s (symbol->string (syntax-e a))]) 30 (if (char=? #\* (string-ref s (sub1 (string-length s)))) 31 (substring s 0 (sub1 (string-length s))) 32 s)) 33 #f)) 34 l)) 35 (define (extract-arg kw lst default) 36 (if (and (pair? lst) 37 (eq? kw (syntax-e (car lst)))) 38 (if (null? (cdr lst)) 39 (serror (format "missing expression for ~a" kw) (car lst)) 40 (values (cadr lst) (cddr lst))) 41 (values default lst))) 42 (define (up-to-next-keyword lst) 43 (cond 44 [(null? lst) null] 45 [(keyword? (syntax-e (car lst))) null] 46 [else (cons (car lst) (up-to-next-keyword (cdr lst)))])) 47 (define (at-next-keyword lst) 48 (cond 49 [(null? lst) null] 50 [(keyword? (syntax-e (car lst))) lst] 51 [else (at-next-keyword (cdr lst))])) 52 (define (check-ok-flag flag) 53 (unless (regexp-match? #rx"^([-+][^-+]$|(--|[+][+])[^-+])" (syntax-e flag)) 54 (serror "bad flag string" flag)) 55 (when (regexp-match? #rx"^[-+][0-9]$" (syntax-e flag)) 56 (serror "number flag not allowed" flag)) 57 (when (regexp-match? #rx"^(-h|--help)$" (syntax-e flag)) 58 (serror "pre-defined flag not allowed" flag))) 59 (let ([lst (syntax->list stx)]) 60 (unless lst 61 (raise-syntax-error #f "bad syntax (misuse of `.')" stx)) 62 (let*-values ([(lst) (cdr lst)] 63 [(prog-name-expr lst) 64 (extract-arg '#:program lst #'(find-system-path 'run-file))] 65 [(argv-expr lst) 66 (extract-arg '#:argv lst #'(current-command-line-arguments))]) 67 (let-values ([(table args) 68 (let loop ([lst lst] [accum null]) 69 (if (null? lst) 70 (loop (syntax->list #'(#:args () (void))) accum) 71 (let ([a (syntax-e (car lst))] 72 [pieces (up-to-next-keyword (cdr lst))]) 73 (case a 74 [(#:usage-help) 75 (for ([x (in-list pieces)]) 76 (unless (string? (syntax-e x)) 77 (serror "#:usage-help clause contains non-string" 78 x))) 79 (loop (at-next-keyword (cdr lst)) 80 (cons (list* #'list #`(quote usage-help) pieces) 81 accum))] 82 [(#:help-labels) 83 (for ([x (in-list pieces)]) 84 (unless (string? (syntax-e x)) 85 (serror "#:help-labels clause contains non-string" 86 x))) 87 (loop (at-next-keyword (cdr lst)) 88 (cons (list* #'list #`(quote help-labels) pieces) 89 accum))] 90 [(#:ps) 91 (for ([x (in-list pieces)]) 92 (unless (string? (syntax-e x)) 93 (serror "#:ps clause contains non-string" 94 x))) 95 (loop (at-next-keyword (cdr lst)) 96 (cons (list* #'list #`(quote ps) pieces) 97 accum))] 98 [(#:once-each #:once-any #:multi #:final) 99 (let ([sublines 100 (let slloop ([sublines pieces]) 101 (if (null? sublines) 102 #'() 103 (with-syntax ([looped (slloop (cdr sublines))] 104 [subline 105 (with-syntax 106 ([flags 107 (syntax-case (car sublines) () 108 [((flag ...) . rest) 109 (let ([flags (syntax->list #'(flag ...))]) 110 (unless (andmap 111 (lambda (x) (string? (syntax-e x))) 112 flags) 113 (serror 114 "flag specification is not a string or sequence of strings" 115 (syntax-case (car sublines) () 116 [(flags . rest) 117 #'flags]))) 118 (for-each check-ok-flag flags) 119 #'(flag ...))] 120 [(flag . rest) 121 (string? (syntax-e #'flag)) 122 (begin 123 (check-ok-flag #'flag) 124 #'(flag))] 125 [else 126 (serror "clause does not start with flags")])]) 127 (syntax-case* (car sublines) (=>) id=? 128 [(_ => a b) 129 #'(list 'flags a b)] 130 [(_ rest ...) 131 (let*-values ([(formals rest) 132 (extract-list #'(rest ...) identifier?)] 133 [(helps rest) 134 (cond 135 [(not (pair? rest)) 136 (serror "missing help string(s)" (car sublines))] 137 [(string? (syntax-e (car rest))) 138 (values (list (car rest)) (cdr rest))] 139 [(syntax->list (car rest)) 140 => (lambda (l) 141 (values l (cdr rest)))] 142 [else 143 (serror "missing help string(s)" (car sublines))])] 144 [(expr1 rest) 145 (extract-one 146 "handler body expressions" rest (car sublines))]) 147 (with-syntax ([formals formals] 148 [formal-names (formal-names formals)] 149 [helps helps] 150 [expr1 expr1] 151 [rest rest]) 152 #'(list 'flags 153 (lambda (flag . formals) expr1 . rest) 154 (cons (list . helps) 'formal-names))))]))]) 155 #'(subline . looped))))]) 156 (loop (at-next-keyword (cdr lst)) 157 (cons (list* #'list 158 #`(quote #,(string->symbol (keyword->string a))) 159 sublines) 160 accum)))] 161 [(#:args) 162 (when (null? pieces) 163 (serror "#:args clause missing formals" (car lst))) 164 (let ([formal-names 165 (let loop ([f (car pieces)]) 166 (syntax-case f () 167 [() null] 168 [(arg . rest) 169 (identifier? #'arg) 170 (cons #'arg (loop #'rest))] 171 [([arg def] . rest) 172 (identifier? #'arg) 173 (cons #'[arg def] (loop #'rest))] 174 [arg 175 (identifier? #'arg) 176 (list #'arg)] 177 [else 178 (serror "bad formals for #:args" (car pieces))]))]) 179 (when (null? (cdr pieces)) 180 (serror "#:args clause missing body after formals" (car lst))) 181 (unless (null? (at-next-keyword (cdr lst))) 182 (serror "#:args must not be followed by another keyword" (car lst))) 183 (with-syntax ([formals (car pieces)] 184 [formal-names (map (lambda (x) 185 (let ([d (syntax->datum x)]) 186 (symbol->string 187 (if (pair? d) (car d) d)))) 188 formal-names)] 189 [body (cdr pieces)]) 190 (values (reverse accum) 191 (list #'(lambda (accume . formals) . body) 192 (syntax 'formal-names)))))] 193 [(#:handlers) 194 (let ([len (length pieces)]) 195 (when (len . < . 1) 196 (serror "missing finish-proc expression for #:handlers" (car lst))) 197 (when (len . < . 2) 198 (serror "missing arg-strings expression for #:handlers" (car lst))) 199 (when (len . > . 4) 200 (let ([e (list-ref pieces 4)]) 201 (if (keyword? (syntax-e e)) 202 (serror "#:handlers must not be followed by another keyword" e) 203 (serror "unexpected expression for #:handlers" e))))) 204 (values (reverse accum) pieces)] 205 [else 206 (serror "expected a clause keyword, such as #:multi or #:args" (car lst))]))))]) 207 (with-syntax ([program-name prog-name-expr] 208 [argv argv-expr] 209 [table table] 210 [args args]) 211 #'(parse-command-line program-name argv (list . table) . args)))))) 212 213(define (print-args port l f) 214 (let loop ([l l] 215 [n 1]) 216 (unless (null? l) 217 (define optional? (procedure-arity-includes? f n)) 218 (fprintf port " ~a<~a>~a" 219 (if optional? "[" "") 220 (car l) 221 (if optional? "]" "")) 222 (when (and (null? (cdr l)) 223 (procedure-arity-includes? f (+ n 2))) 224 (fprintf port " ...")) 225 (loop (cdr l) (add1 n))))) 226 227(define (procedure-arity-includes-at-least? p n) 228 (let a-c ([a (procedure-arity p)]) 229 (cond [(number? a) (>= a n)] 230 [(arity-at-least? a) #t] 231 [else (ormap a-c a)]))) 232 233(define (program-name program) 234 (string->symbol (if (path? program) 235 (let-values ([(base name dir?) (split-path program)]) 236 (if (path? name) 237 (path-element->string name) 238 (path->string program))) 239 program))) 240 241(define (parse-command-line 242 program arguments0 table finish finish-help 243 [help (lambda (s) (display s) (exit 0))] 244 [unknown-flag (lambda (flag) 245 (raise-user-error (program-name program) 246 "unknown switch: ~a" flag))]) 247 (define arguments 248 (if (vector? arguments0) (vector->list arguments0) arguments0)) 249 (define (bad-table fmt . args) 250 (raise-type-error 251 'parse-command-line 252 (format "table as a list of flag-list/procedure pairs (~a)" 253 (apply format fmt args)) 254 table)) 255 (unless (or (string? program) (path? program)) 256 (raise-type-error 'parse-command-line "program name string" program)) 257 (unless (and (list? arguments) 258 (andmap string? arguments)) 259 (raise-type-error 'parse-command-line "argument vector/list of strings" 260 arguments0)) 261 (unless (list? table) 262 (raise-type-error 'parse-command-line "table of spec sets" table)) 263 (for ([spec (in-list table)]) 264 (unless (and (list? spec) (pair? spec)) 265 (bad-table "spec-set must be a non-empty list: ~a" spec)) 266 (unless (memq (car spec) '(once-any once-each multi final help-labels usage-help ps)) 267 (bad-table "spec-set type must be 'once-any, 'once-each, 'multi, 'final, 'help-labels, 'usage-help, or 'ps: ~a" 268 (car spec))) 269 (for ([line (in-list (cdr spec))]) 270 (if (memq (car spec) '(help-labels ps usage-help)) 271 (unless (string? line) 272 (bad-table "~a line must be a string: ~e" (car spec) line)) 273 (begin 274 (unless (and (list? line) (= (length line) 3)) 275 (bad-table "spec-line must be a list of three items: ~e" line)) 276 (unless (list? (car line)) 277 (bad-table "flags part of a spec-line must be a list: ~e" (car line))) 278 (for ([flag (in-list (car line))]) 279 (unless (string? flag) 280 (bad-table "flag must be a string: ~e" flag)) 281 (unless (regexp-match? #rx"^([-+][^-+]$|(--|[+][+])[^-+])" flag) 282 (bad-table "no ill-formed flags: ~e" flag)) 283 (when (regexp-match? #rx"^[-+][0-9]*([.][0-9]*)?$" flag) 284 (bad-table "no ill-formed flags: ~e" flag)) 285 (when (regexp-match? #rx"^(-h|--help)$" flag) 286 (bad-table "no pre-defined flags: ~e" flag))) 287 (unless (procedure? (cadr line)) 288 (bad-table "second item in a spec-line must be a procedure: ~e" 289 (cadr line))) 290 (let ([a (procedure-arity (cadr line))] 291 [h (caddr line)] 292 [l (length (caddr line))]) 293 (cond 294 [(number? a) 295 (unless (>= a 1) 296 (bad-table "flag handler procedure must take at least 1 argument: ~e" 297 (cadr line)))] 298 [(not (arity-at-least? a)) 299 (bad-table "flag handler procedure cannot have multiple cases: ~e" 300 (cadr line))]) 301 (unless (and (pair? h) 302 (or (string? (car h)) (andmap string? (car h))) 303 (andmap string? (cdr h))) 304 (bad-table "spec-line help section must be ~a" 305 "a list of string-or-string-list and strings")) 306 (unless (if (number? a) 307 (= a l) 308 (and (>= l 1) (>= l (arity-at-least-value a)))) 309 (bad-table "spec-line help list strings must match procedure arguments"))))))) 310 (unless (and (procedure? finish) 311 (procedure-arity-includes-at-least? finish 1)) 312 (raise-type-error 'parse-command-line "finish procedure accepting at least 1 argument" finish)) 313 (unless (and (list? finish-help) (andmap string? finish-help)) 314 (raise-type-error 'parse-command-line "argument help list of strings" finish-help)) 315 (unless (and (procedure? help) (procedure-arity-includes? help 1)) 316 (raise-type-error 'parse-command-line "help procedure of arity 1" help)) 317 (unless (and (procedure? unknown-flag) (procedure-arity-includes? unknown-flag 1) 318 (let ([a (procedure-arity unknown-flag)]) 319 (or (number? a) (arity-at-least? a)))) 320 (raise-type-error 'parse-command-line "unknown-flag procedure of simple arity, accepting 1 argument (an perhaps more)" unknown-flag)) 321 322 (unless (procedure-arity-includes? finish (add1 (length finish-help))) 323 (raise-arguments-error 'parse-command-line 324 "mismatch in length of argument help string and finish procedure arity" 325 "argument help string" finish-help 326 "finish procedure" finish)) 327 328 (let* ([finalled? #f] ; set to true when 'once-final is seen 329 [once-spec-set 330 (lambda (lines) 331 (let ([set (mcons #f (apply append (map car lines)))]) 332 (map 333 (lambda (line) (cons set line)) 334 lines)))] 335 [first? (lambda (x lst) 336 (and (pair? lst) (eq? x (car lst))))] 337 [last? (lambda (x lst) 338 (and (pair? lst) 339 (let loop ([l lst]) 340 (if (pair? (cdr l)) 341 (loop (cdr l)) 342 (eq? x (car l))))))] 343 [table 344 ;; list of (list <once-set> <spec-line> ...) 345 ;; If <once-set> is #f, then flags in <spec-line> are allowed 346 ;; any number of times. 347 ;; If <once-set> is 'final, then its like #f, and `finalled?' should 348 ;; be set. 349 ;; Otherwise, <once-set> is (mcons <bool> (list <string> ...)) where <bool> 350 ;; starts as #f and is mutated to #t when one of <string> is 351 ;; matched. 352 (apply 353 append 354 (list 355 (list #f 356 (list "--help" "-h") 357 (lambda (f) 358 (let ([sp (open-output-string)]) 359 (fprintf sp "usage: ~a [ <option> ... ]" (program-name program)) 360 (print-args sp finish-help finish) 361 (for ([set (in-list table)] 362 #:when (eq? (car set) 'usage-help)) 363 (for ([line (in-list (cdr set))]) 364 (fprintf sp "\n ~a" line))) 365 (fprintf sp "\n\n<option> is one of\n\n") 366 (for ([set (in-list table)] ; the original table 367 #:unless (memq (car set) '(ps usage-help))) 368 (if (eq? (car set) 'help-labels) 369 (for ([line (in-list (cdr set))]) 370 (fprintf sp " ~a\n" line)) 371 (for ([line (in-list (cdr set))]) 372 (let* ([helps (caaddr line)] 373 [helps (if (string? helps) (list helps) helps)]) 374 (for ([help (in-list helps)]) 375 (fprintf sp 376 (cond [(and (eq? (car set) 'once-any) 377 (pair? (cddr set))) 378 (cond 379 [(and (first? line (cdr set)) 380 (first? help helps)) 381 "/"] 382 [(and (last? line (cdr set)) 383 (last? help helps) 384 (> (length helps) 1)) 385 "\\"] 386 [else "|"])] 387 [(and (memq (car set) '(multi final)) 388 (first? help helps)) 389 "*"] 390 [else " "])) 391 (if (first? help helps) 392 (begin 393 (let loop ([flags (car line)]) 394 (let ([flag (car flags)]) 395 (fprintf sp " ~a" flag) 396 (print-args sp (cdaddr line) (cadr line))) 397 (unless (null? (cdr flags)) 398 (fprintf sp ",") 399 (loop (cdr flags)))) 400 (if (and (eq? (car set) 'once-any) 401 (pair? (cddr set))) 402 (if (and (last? line (cdr set)) 403 (last? help helps)) 404 ; | -i 405 ; \ description <- 406 (fprintf sp "\n\\ ") 407 ; | -i 408 ; | description 1 <- 409 ; \ description 2 410 (fprintf sp "\n| ")) 411 (fprintf sp "\n "))) 412 (fprintf sp " ")) 413 (fprintf sp " ~a\n" help)))))) 414 (fprintf sp " --help, -h\n Show this help\n") 415 (fprintf sp " --\n Do not treat any remaining argument as a switch (at this level)\n") 416 (fprintf sp "\n") 417 (when (or (assq 'multi table) (assq 'final table)) 418 (fprintf sp " * Asterisks indicate options allowed multiple times.\n")) 419 (when (assq 'once-any table) 420 (fprintf sp " /|\\ Brackets indicate mutually exclusive options.\n")) 421 (when (or (assq 'multi table) (assq 'final table) (assq 'once-any table)) 422 (fprintf sp "\n")) 423 (fprintf sp " Multiple single-letter switches can be combined after\n") 424 (fprintf sp " one `-`. For example, `-h-` is the same as `-h --`.\n") 425 (for ([set (in-list table)] ; the original table 426 #:when (eq? (car set) 'ps)) 427 (for ([line (in-list (cdr set))]) 428 (fprintf sp " ~a\n" line))) 429 (help (get-output-string sp)))) 430 (list "Help"))) 431 (for/list ([spec (in-list table)]) 432 (cond 433 [(eq? (car spec) 'once-each) 434 (apply 435 append 436 (map (lambda (line) (once-spec-set (list line))) 437 (cdr spec)))] 438 [(eq? (car spec) 'once-any) 439 (once-spec-set (cdr spec))] 440 [(eq? (car spec) 'usage-help) 441 null] 442 [(eq? (car spec) 'help-labels) 443 null] 444 [(eq? (car spec) 'ps) 445 null] 446 [(eq? (car spec) 'multi) 447 (map 448 (lambda (line) (cons #f line)) 449 (cdr spec))] 450 [(eq? (car spec) 'final) 451 (map 452 (lambda (line) (cons 'final line)) 453 (cdr spec))])))] 454 [done 455 (lambda (args r-acc) 456 (let ([options (reverse r-acc)] 457 [c (length args)]) 458 (if (procedure-arity-includes? finish (add1 c)) 459 (apply finish options args) 460 (raise-user-error 461 (program-name program) 462 "expects~a on the command line, given ~a argument~a~a" 463 (if (null? finish-help) 464 " no arguments" 465 (let ([s (open-output-string)]) 466 (parameterize ([current-output-port s]) 467 (print-args s finish-help finish)) 468 (let ([s (get-output-string s)]) 469 (if (equal? 2 (procedure-arity finish)) 470 (format " 1~a" s) 471 s)))) 472 c 473 (cond [(zero? c) "s"] [(= c 1) ": "] [else "s: "]) 474 (let loop ([args args]) 475 (if (null? args) 476 "" 477 (string-append (car args) " " (loop (cdr args)))))))))] 478 [call-handler 479 (lambda (handler flag args r-acc k) 480 (let* ([a (procedure-arity handler)] 481 [remaining (length args)] 482 [needed (if (number? a) 483 (sub1 a) 484 (sub1 (arity-at-least-value a)))] 485 [use (if (number? a) 486 (sub1 a) 487 remaining)]) 488 (if (< remaining needed) 489 (raise-user-error (program-name program) 490 "the ~s option needs ~a argument~a, but ~a~a provided" 491 flag needed (if (> needed 1) "s" "") 492 (if (zero? remaining) "" "only ") 493 remaining) 494 (let ([v (apply handler 495 flag 496 (let loop ([n use][args args]) 497 (if (zero? n) 498 null 499 (cons (car args) 500 (loop (sub1 n) (cdr args))))))]) 501 (k (list-tail args use) 502 (if (void? v) r-acc (cons v r-acc)))))))] 503 [handle-flag 504 (lambda (flag args r-acc orig-multi k) 505 (let loop ([table table]) 506 (cond 507 [(null? table) 508 (call-handler unknown-flag flag args r-acc k)] 509 [(member flag (cadar table)) 510 (when (eq? 'final (caar table)) 511 (set! finalled? #t)) 512 (when (mpair? (caar table)) 513 (let ([set (caar table)]) 514 (if (mcar set) 515 (let ([flags (mcdr set)]) 516 (raise-user-error 517 (program-name program) 518 (let ([s (if (= 1 (length flags)) 519 (format "the ~a option can only be specified once" (car flags)) 520 (format "only one instance of one option from ~a is allowed" flags))]) 521 (if (and orig-multi 522 (not (equal? flag orig-multi))) 523 (format "~a; note that ~s is shorthand for ~s, in contrast to ~s" 524 s 525 orig-multi 526 (let loop ([prefix (string-ref orig-multi 0)] 527 [flags (string->list (substring orig-multi 1 (string-length orig-multi)))] 528 [sep ""]) 529 (if (null? flags) 530 "" 531 (format "~a~a~a~a" sep prefix (car flags) 532 (loop prefix (cdr flags) " ")))) 533 (string-append (substring orig-multi 0 1) orig-multi)) 534 s)))) 535 (set-mcar! set #t)))) 536 (call-handler (caddar table) flag args r-acc k)] 537 [else (loop (cdr table))])))]) 538 (let loop ([args arguments][r-acc null]) 539 (if (null? args) 540 (done args r-acc) 541 (let ([arg (car args)] 542 [rest (cdr args)]) 543 (cond 544 [finalled? 545 (done args r-acc)] 546 [(regexp-match #rx"^[-+][0-9]*(|[.][0-9]*)$" arg) 547 (done args r-acc)] 548 [(regexp-match "^--$" arg) 549 (done (cdr args) r-acc)] 550 [(regexp-match "^[-+][-+]" arg) 551 (handle-flag arg rest r-acc #f loop)] 552 [(regexp-match "^[-+]." arg) 553 (let a-loop ([s (string->list (substring arg 1 (string-length arg)))] 554 [rest rest] 555 [r-acc r-acc]) 556 (if (null? s) 557 (loop rest r-acc) 558 (handle-flag (string (string-ref arg 0) (car s)) 559 rest r-acc 560 arg 561 (lambda (args r-acc) 562 (a-loop (cdr s) args r-acc)))))] 563 [else (done args r-acc)])))))) 564