(module parser-sigs mzscheme
  
  (require (lib "unit.ss"))

  (require (only (lib "etc.ss") opt-lambda))    ; Required for expansion
  (require (lib "lex.ss" "parser-tools")
           (lib "string.ss") (lib "list.ss"))
  
  (provide (all-defined))
  
  (define-signature-form (terminals stx)
    (syntax-case stx ()
      [(_ group (elt ...))
       (and (identifier? #'group)
            (andmap identifier? (syntax->list #'(elt ...))))
       (syntax->list #`(elt ...
                        #,@(map (lambda (e) 
                                  (datum->syntax-object e
                                                        (string->symbol 
                                                         (format "token-~a" (syntax-e e)))))
                                (syntax->list #'(elt ...)))))]))
  
  (define-signature language-dictionary^ (misspelled misscap missclass))
    
  (define-signature combinator-parser-forms^ 
    (terminal choice seq repeat
     (define-syntaxes (define-simple-terminals)
       (values 
        (lambda (stx)
          (syntax-case stx ()
            ((_ group elts)
             (let ([name-string-thunks 
                    (let loop ([elt-list (syntax elts)])
                      (syntax-case elt-list (lambda)
                        [() null]
                        [(id . rest)
                         (identifier? (syntax id))
                         (cons (list (syntax id)
                                     (syntax (symbol->string (quote id)))
                                     `(lambda (x . args) x))
                               (loop (syntax rest)))]
                        [((id name) . rest)
                         (and (identifier? (syntax id)) (string? (syntax-e (syntax name))))
                         (cons (list (syntax id)
                                     (syntax name)
                                     `(lambda (x . args) x))
                               (loop (syntax rest)))]
                        [((id thunk) . rest)
                         (and (identifier? (syntax id)) (identifier? (syntax thunk)))
                         (cons (list (syntax id)
                                     (syntax (symbol->string (quote id)))
                                     (syntax thunk))
                               (loop (syntax rest)))]
                        [((id (lambda x body ...)) . rest)
                         (identifier? (syntax id))
                         (cons (list (syntax id)
                                     (syntax (symbol->string (quote id)))
                                     (syntax (lambda x body ...)))
                               (loop (syntax rest)))]
                        [((id name thunk) . rest)
                         (and (identifier? (syntax id)) (string? (syntax-e (syntax name))))
                         (cons (list (syntax id)
                                     (syntax name)
                                     (syntax thunk))
                               (loop (syntax rest)))]))])
               (with-syntax ([(id ...) (map car name-string-thunks)]
                             [(name ...) (map cadr name-string-thunks)]
                             [(thunk ...) (map caddr name-string-thunks)])
                 (syntax
                  (begin
                    (define-empty-tokens group (id ...))
                    (define id
                      (terminal 
                       (lambda (token) (eq? (token-name token) (quote id)))
                       thunk
                       name)) ...)))))))))
     
     (define-syntaxes (define-terminals)
       (values 
        (lambda (stx)
          (syntax-case stx ()
            [(_ group elts)
             (identifier? (syntax group))
             (let ([name-string-thunks 
                    (let loop ([elt-list (syntax elts)])
                      (syntax-case elt-list (lambda)
                        [() null]
                        [((id (lambda (arg1 ...) body ...)) . rest)
                         (identifier? (syntax id))
                         (cons (list (syntax id)
                                     (syntax (symbol->string (quote id)))
                                     (syntax (lambda (arg1 ...) body ...)))
                               (loop (syntax rest)))]
                        [((id thunk) . rest)
                         (and (identifier? (syntax id)) (identifier? (syntax thunk)))
                         (cons (list (syntax id)
                                     (syntax (symbol->string (quote id)))
                                     (syntax thunk))
                               (loop (syntax rest)))]
                        [((id name thunk) . rest)
                         (cons (list (syntax id)
                                     (syntax name)
                                     (syntax thunk))
                               (loop (syntax rest)))]))])
               (with-syntax ([(id ...) (map car name-string-thunks)]
                             [(name ...) (map cadr name-string-thunks)]
                             [(thunk ...) (map caddr name-string-thunks)])
                 (syntax
                  (begin
                    (define-tokens group (id ...))
                    (define id
                      (terminal 
                       (lambda (token) (eq? (token-name token) (quote id)))
                       (lambda (x . args) 
                         (if (null? args)
                             (thunk (token-value x))
                             (thunk (token-value x) (car args) (cadr args))))
                       name
                       (lambda (token) 0)
                       (lambda (token) #f))) ...))))]))))
        
     (define-syntaxes (sequence choose ^)
       (let ([insert-name
              (lambda (stx name)
                (let loop ([term stx]
                           [pos 0]
                           [id-pos 0]
                           [terms null])
                  (syntax-case term (sequence choose ^)
                    [((sequence a b) . rest)
                     (loop (syntax rest) (add1 pos) id-pos
                           (cons (quasisyntax (sequence a b #,name)) terms))]
                    [((choose a) . rest)
                     (loop (syntax rest) (add1 pos) id-pos
                           (cons (quasisyntax (choose a #,name)) terms))]
                    [((^ a) . rest)
                     (loop (syntax (a . rest))
                           pos (add1 pos) terms)]
                    [(a . rest)
                     (loop (syntax rest) (add1 pos) id-pos (cons (syntax a) terms))]
                    [() (list (reverse terms) id-pos)])))])
         (values
          (lambda (stx)
            (syntax-case stx (^)
              [(_ (term ...) proc) 
               (syntax
                (seq (list term ...) proc (symbol->string (gensym 'seq))))]
              [(_ terms proc name)
               (let ([new-terms (insert-name (syntax terms) (syntax name))])
                 (with-syntax (((term ...) (car new-terms))
                               (id-pos (cadr new-terms)))
                   (syntax (seq (list term ...) proc name id-pos))))]))
          (lambda (stx)
            (syntax-case stx ()
              [(_ (term ...))
               (syntax
                (choice (list term ...) (symbol->string (gensym 'choice))))]
              [(_ terms name)
               (with-syntax (((term ...) [car (insert-name (syntax terms) (syntax name))]))
                 (syntax
                  (choice (list term ...) name)))]))
          (syntax-rules ()
            [(_ f) f]))))
     
     (define-syntaxes (eta)
       (values (syntax-rules ()
                 [(_ f)
                  (opt-lambda (x [c 1]) (f x c))])))
     ))
    
  (define-signature parser^ (parser))
  (define-signature out^ ((struct err (msg src))))
  
  (define-signature language-format-parameters^ (class-type input->output-name))
  
  (define-signature error-format-parameters^ 
    (src? input-type show-options max-depth max-choice-depth))
  
  (define-signature ranking-parameters^ 
    (rank-misspell rank-caps rank-class rank-wrong rank-end rank-choice))
  
  (define-signature updating-rank^
    (blamed-terminal failed-last-parse))
 
  (define-signature error^ (fail-type->message))
  
  (define-signature combinator-parser^ extends combinator-parser-forms^ (parser))
  (define-signature err^ (err? err-msg err-src))
    
  )