#lang racket
(require "spec-ast.rkt")
(struct exn:functional-command:parse exn:fail:contract (src) #:transparent)
(provide/contract
[parse-spec (any/c . -> . spec?)]
[struct (exn:functional-command:parse exn:fail:contract)
([message string?]
[continuation-marks continuation-mark-set?]
[src any/c])])
(define parse-spec
(match-lambda
[(list-rest name (? string? summary) commands)
(spec (parse-name "program name" name)
summary
(parse-commands commands))]
[bogus (raise (exn:functional-command:parse
"Expected (<name> <string> <command>+)"
(current-continuation-marks)
bogus))]))
(define parse-name
(lambda (context name)
(cond
[(string? name) name]
[(symbol? name) (symbol->string name)]
[else
(raise (exn:functional-command:parse
(format "Expected name for ~a" context)
(current-continuation-marks)
name))])))
(define parse-commands
(lambda (commands)
(when (null? commands)
(raise (exn:functional-command:parse "Expected at least one command"
(current-continuation-marks)
null)))
(let loop ([input commands]
[command-names (set)])
(if (null? input)
null
(let* ([cmd (parse-command (car input))]
[cmd-name (command-name cmd)])
(if (set-member? command-names cmd-name)
(raise (exn:functional-command:parse
"Duplicate command name"
(current-continuation-marks)
cmd-name))
(cons cmd (loop (cdr input)
(set-add command-names cmd-name)))))))))
(define parse-command
(match-lambda
[(and src
(list name
(? string? short-help)
(? string? long-help)
posn-arg-spec
(? not-procedure? flag-specs) ...
(? procedure? fn)))
(let-values ([(positional-args rest-arg)
(parse-posn-arg-spec posn-arg-spec)]
[(flags) (parse-flag-specs flag-specs)]
[(cmd-name) (parse-name "command name" name)])
(when (string=? cmd-name "help")
(raise (exn:functional-command:parse "Reserved command name \"help\""
(current-continuation-marks)
src)))
(assert-switches-unique! name flags)
(assert-keywords-unique! name flags)
(command cmd-name
short-help
long-help
positional-args
rest-arg
flags
fn))]
[bogus
(raise (exn:functional-command:parse "Bad command spec"
(current-continuation-marks)
bogus))]))
(define parse-posn-arg-spec
(match-lambda
[(quasiquote (,(? symbol? posn-args) ..1 . ,(? symbol? rest-arg)))
(values posn-args rest-arg)]
[(list (? symbol? posn-args) ...)
(values posn-args #f)]
[(? symbol? arg) (values null arg)]
[bogus (raise (exn:functional-command:parse "Bad positional arg spec"
(current-continuation-marks)
bogus))]))
(define parse-flag-specs
(lambda (specs)
(match specs
[(list) null]
[(list-rest '#:once-each
(? not-keyword? once-specs) ..1
rest)
(append (parse-once-specs once-specs)
(parse-flag-specs rest))]
[(list-rest '#:multi
(? not-keyword? multi-specs) ..1
rest)
(append (parse-multi-specs multi-specs)
(parse-flag-specs rest))]
[(list-rest '#:once-any
(? not-keyword? group-specs) ..2
rest)
(cons (parse-group-specs group-specs)
(parse-flag-specs rest))]
[else (raise
(exn:functional-command:parse "Expected flag specs"
(current-continuation-marks)
specs))])))
(define parse-once-specs
(lambda (specs)
(parse-flag-spec-sequence optional-flag (lambda (x) #t) specs)))
(define parse-multi-specs
(lambda (specs)
(parse-flag-spec-sequence multi-flag not-null? specs)))
(define parse-group-specs
(lambda (src)
(group (parse-once-specs src))))
(define parse-flag-spec-sequence
(lambda (make-flag enough-args? src)
(let loop ([src src])
(match src
[(list) null]
[(cons (list (list (? string? switches) ..1)
(? keyword? kw)
help-text
(? symbol? args) ...)
rest)
(for-each assert-switch-valid! switches)
(unless (enough-args? args)
(raise (exn:functional-command:parse "Too few arguments for switch"
(current-continuation-marks)
(car src))))
(cons (make-flag (apply set switches)
kw
(parse-help-text help-text)
args)
(loop (cdr src)))]
[else (raise (exn:functional-command:parse "Invalid flag spec"
(current-continuation-marks)
(car src)))]))))
(define parse-help-text
(match-lambda
[(? string? ht) (list ht)]
[(list (? string? lines) ..1) lines]
[bogus (raise (exn:functional-command:parse "Invalid help text"
(current-continuation-marks)
bogus))]))
(define assert-switch-valid!
(lambda (switch)
(cond
[(string=? switch "--help")
(raise (exn:functional-command:parse "Reserved switch name"
(current-continuation-marks)
switch))]
[(short-switch? switch) (void)]
[(long-switch? switch) (void)]
[else (raise (exn:functional-command:parse "Invalid switch"
(current-continuation-marks)
switch))])))
(define assert-switches-unique!
(lambda (cmd-name flags)
(assert-switches-unique/accum cmd-name flags (set))
(void)))
(define assert-switches-unique/accum
(lambda (cmd-name flags switches-accum)
(match flags
[(list) switches-accum]
[(cons (or (optional-flag switches _ _ _)
(multi-flag switches _ _ _))
rest)
(let ([dups (set-intersect switches switches-accum)])
(if (set-empty? dups)
(assert-switches-unique/accum
cmd-name
rest
(set-union switches switches-accum))
(raise (exn:functional-command:parse
(format "Duplicate switches in command ~a" cmd-name)
(current-continuation-marks)
dups))))]
[(cons (group group-flags) rest)
(assert-switches-unique/accum
cmd-name
rest
(assert-switches-unique/accum cmd-name group-flags switches-accum))])))
(define assert-keywords-unique!
(lambda (cmd-name flags)
(assert-keywords-unique/accum cmd-name flags (seteq))
(void)))
(define assert-keywords-unique/accum
(lambda (cmd-name flags kw-accum)
(match flags
[(list) kw-accum]
[(cons (or (optional-flag _ keyword _ _)
(multi-flag _ keyword _ _))
rest)
(if (set-member? kw-accum keyword)
(raise (exn:functional-command:parse
(format "Duplicate keyword in command ~a" cmd-name)
(current-continuation-marks)
keyword))
(assert-keywords-unique/accum
cmd-name
rest
(set-add kw-accum keyword)))]
[(cons (group group-flags) rest)
(assert-keywords-unique/accum
cmd-name
rest
(assert-keywords-unique/accum cmd-name group-flags kw-accum))])))
(define not-keyword? (compose not keyword?))
(define not-null? (compose not null?))
(define not-procedure? (compose not procedure?))