#lang racket

;; INPUT SPEC
;;
;; <spec> ::= (<name> <string> <command>+)
;; <command> ::= (<name> <string> <string>
;;                  <posn-arg-spec>
;;                  <flag-specs> ...
;;                  <lambda>)
;;    The command name "help" is reserved.
;;
;; <posn-arg-spec> ::= (<symbol>*)
;;                   | (<symbol>+ . <symbol>)
;;                   | <symbol>               -- rest arg
;;
;; <flag-specs> ::= #:once-each <flag-spec>+
;;                | #:multi <flag-spec>+
;;                | #:once-any <flag-spec>..2
;;
;; <flag-spec> ::= ((<switch>+) <keyword> <help-spec> <symbol>*)
;;   must have at least 1 symbol for a #:multi spec
;;
;; <switch> ::= string naming switch.  Either "-[:alpha:]" or
;;              "--[-a-zA-Z0-9]+"
;;    The switch name "--help" is reserved.
;; <lambda> ::= a closure
;; <name> ::= either a string or a symbol
;;
;; <help-spec> ::= <string> | (<string>+)

;; XXX allow a single flag-spec after #:once-any; turn it into a #:once-each.
;; Similarly, allow ("foo") as a <help-spec>.  Easier for macros that generate
;; these things.

(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])])

;; parse-spec :: x -> Spec
;; parses an s-expr-based command line spec
(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))]))

;; parse-name :: String <name> -> String
;; parses a name string/symbol; uses context for message on failure
(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))])))

;; parse-commands :: (Listof <command>) -> (NEListof Command)
(define parse-commands
  (lambda (commands)
    (when (null? commands)
      (raise (exn:functional-command:parse "Expected at least one command"
                                           (current-continuation-marks)
                                           null)))
    ;; not tail recursive because we want to preserve order of commands in
    ;; input.  Also, we don't expect too many commands, so stack depth not
    ;; likely to be an issue.
    (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)))))))))

;; parse-command :: <command> -> Command
(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))]))

;; parse-posn-arg-spec :: <posn-arg-spec> -> (Listof Symbol) (Optional Symbol)
;; parse-posn-arg-spec returns list of symbols & optional symbol
(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))]))

;; parse-flag-specs :: (List <flag-specs> ...) -> (Listof Flag)
;; Parses flag specs for a single command
(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))])))


;; parse-once-specs :: (NEListof <flag-spec>) -> (NEListof Flag)
;; Parses a #:once-each sequence of flag specs.
(define parse-once-specs
  (lambda (specs)
    (parse-flag-spec-sequence optional-flag (lambda (x) #t) specs)))

;; parse-multi-specs :: (NEListof <flag-spec>)
;;                   -> (Listof Flag) (Set-eq Keyword) (Set-equal String)
;; I'd combine this with parse-once-specs into a more general form, but the
;; match patterns differ, so I'd have to use a macro, and it's not worth it.
(define parse-multi-specs
  (lambda (specs)
    (parse-flag-spec-sequence multi-flag not-null? specs)))

;; parse-group-specs :: (NEListof <flag-spec>) -> Group
(define parse-group-specs
  (lambda (src)
    (group (parse-once-specs src))))


;; parse-flag-spec-sequence
;;  :: ((FSet String) Keyword (NEListof String) (Listof Symbol)
;;     ((Listof Symbol) -> Boolean)
;;     (NEListof <flag-spec>)
;;  -> (NEListof Flag)
;; make-flag should construct & return Flag representation.  We check for # of
;; args here because we have the src so it's more convenient for us to throw an
;; exception rather than delegating this to make-flag.
;; We leave checks for duplicate switches and keywords to caller.
(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)))]))))

;; parse-help-text :: <help-spec> -> (NEListof String)
;; Parses help text clause from a <flag-spec>.
(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))]))

;; assert-switch-valid! :: (NEListof String) -> ()
;; signals error if we have an invalid switch
(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))])))

;; assert-switches-unique! :: String (Listof Flag) -> Void
;; ensures that input list does not contain duplicate switches
;; cmd-name solely for diagnostics
(define assert-switches-unique!
  (lambda (cmd-name flags)
    (assert-switches-unique/accum cmd-name flags (set))
    (void)))

;; assert-switches-unique/accum :: String (Listof Flag) (Set String)
;;                              -> (Set String)
;; asserts that flags' switches are unique; throws an error on dup or
;; returns set of switches seen so far.
(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))])))

;; assert-keywords-unique! :: String (Listof Flag) -> Void
;; ensures that flags do not contain duplicate keywords.  cmd-name solely for
;; diagnostics.
(define assert-keywords-unique!
  (lambda (cmd-name flags)
    (assert-keywords-unique/accum cmd-name flags (seteq))
    (void)))

;; assert-keywords-unique/accum :: String (Listof Flag) (SetEQ Keyword)
;;                              -> (SetEQ Keyword)
(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?))