(module pattern mzscheme
  
  (require "xml-core.ss")
  
  (require-for-syntax "rules-helper.ss"
                      "valid-types-helper.ss")
  
  (provide xml-pat
           template-wrapper
           match-xml-pat)
  
  (define-struct ele-pat (tag attributes contents))
  (define-struct attr-pat (tag var))
  (define-struct (attr-pat/def attr-pat) (default))
  (define-struct lit-attr-pat (tag value))
  (define-struct literal-pat (value))
  (define-struct dots-pat (pat))
  (define-struct tail-pat (var))
  (define-struct var-pat (var))
  (define-struct typed-var-pat (var tag))
  (define-struct type-pat (tag))
  (define-struct guard-pat (pat fender))
  (define-struct nodeset-pat (contents))
  
  (define-syntax (xml-pat stx)
    (letrec ((nodeset-pat (lambda (stx)
                            (syntax-case stx ()
                              (var
                               (identifier? (syntax var))
                               #'(list (make-tail-pat 'var)))
                              ((item1)
                               #`(list #,(translate-pattern (syntax item1))))
                              ((item ellipses)
                               (eq? '... (syntax-e #'ellipses))
                               #`(list (make-dots-pat #,(translate-pattern #'item))))
                              ((item1 . items)
                               #`(cons #,(translate-pattern (syntax item1))
                                       #,(nodeset-pat (syntax items)))))))
             (ele-helper (lambda (stx attr-acc)
                           (syntax-case stx ()
                             ((ele-tag)
                              #`(make-ele-pat #,(if (eq? '_ (syntax-e #'ele-tag))
                                                    #f
                                                    #`'#,(type-exists? #'ele-tag))
                                              (list #,@(reverse attr-acc))
                                              '()))
                             ((ele-tag key var)
                              (keyword-identifier? (syntax-e #'key))
                              (syntax-case #'var ()
                                (name
                                 (identifier? #'name)
                                 (ele-helper #`(ele-tag)
                                             (cons #`(make-attr-pat '#,(attr-exists? #'key) 'name)
                                                   attr-acc)))
                                ((name default)
                                 (identifier? #'name)
                                 (ele-helper #`(ele-tag)
                                             (cons #`(make-attr-pat/def '#,(attr-exists? #'key) 'name default)
                                                   attr-acc)))
                                (str
                                 (string? (syntax-e #'str))
                                 (ele-helper #`(ele-tag)
                                             (cons #`(make-lit-attr-pat '#,(attr-exists? #'key) str)
                                                   attr-acc)))))
                             ((ele-tag key var . items)
                              (keyword-identifier? (syntax-e #'key))
                              (syntax-case #'var ()
                                (name
                                 (identifier? #'name)
                                 (ele-helper #`(ele-tag . items)
                                             (cons #`(make-attr-pat '#,(attr-exists? #'key) 'name) 
                                                   attr-acc)))
                                ((name default)
                                 (identifier? #'name)
                                 (ele-helper #`(ele-tag . items)
                                             (cons #`(make-attr-pat/def '#,(attr-exists? #'key) 'name default)
                                                   attr-acc)))
                                (str
                                 (string? (syntax-e #'str))
                                 (ele-helper #`(ele-tag . items)
                                             (cons #`(make-lit-attr-pat '#,(attr-exists? #'key) str)
                                                   attr-acc)))))
                             ((ele-tag . items)
                              #`(make-ele-pat #,(if (eq? '_ (syntax-e #'ele-tag))
                                                    #f
                                                    #`'#,(type-exists? #'ele-tag))
                                              (list #,@(reverse attr-acc))
                                              #,(nodeset-pat #'items))))))
             (element-pat (lambda (stx)
                            (ele-helper stx '())))
             (translate-pattern (lambda (stx)
                                  (syntax-case stx (_ $)
                                    (var
                                     (identifier? #'var)
                                     (syntax (make-var-pat 'var)))
                                    (($ var type-tag)
                                     (begin
                                       (unless (identifier? #'var)
                                         (raise-syntax-error #f
                                                             "expected an identifier"
                                                             stx
                                                             #'var))
                                       (unless (identifier? #'type-tag)
                                         (raise-syntax-error #f
                                                             "expected an identifier"
                                                             stx
                                                             #'type-tag))
                                       #`(make-typed-var-pat 'var '#,(type-exists? #'type-tag))))
                                    ((_)
                                     #`(make-ele-pat #f '() '()))
                                    (str
                                     (string? (syntax-e #'str))
                                     #'(make-literal-pat str))
                                    ((tag)
                                     (and (identifier? #'tag)
                                          (eq? 'list (syntax-e #'tag)))
                                     #'(make-nodeset-pat '()))
                                    ((ele-tag)
                                     #`(make-ele-pat '#,(type-exists? #'ele-tag) '() '()))
                                    ((tag . contents)
                                     (and (identifier? #'tag)
                                          (eq? 'list (syntax-e #'tag)))
                                     #`(make-nodeset-pat #,(nodeset-pat #'contents)))
                                    ((ele-tag . contents)
                                     (element-pat #'(ele-tag . contents)))
                                    (xx
                                     (raise-syntax-error
                                      #f
                                      "error in XML pattern, expected an element, string, or variable"
                                      stx
                                      #'xx))))))
      (syntax-case stx ()
        ((_ pat) (translate-pattern (syntax pat))))))
  
  (define (match-xml-pat pat datum)
    (cond
      ((literal-pat? pat)
       (if (and (pcdata? datum)
                (string=? (literal-pat-value pat)
                          (pcdata->string datum)))
           '()
           #f))
      ((var-pat? pat)
       (list (list (var-pat-var pat) datum)))
      ((typed-var-pat? pat)
       (if (eq? (xml-element-tag datum) (typed-var-pat-tag pat))
           (list (list (typed-var-pat-var pat) datum))
           #f))
      ((nodeset-pat? pat)
       (match-contents (nodeset-pat-contents pat) datum))
      ((and (ele-pat? pat)
            (xml-element? datum)
            (or (not (ele-pat-tag pat))
                (eq? (xml-element-tag datum) (ele-pat-tag pat))))
       (cond ((match-contents (ele-pat-contents pat) (xml-element-contents datum))
              => (lambda (bindings)
                   (cond ((match-attributes (ele-pat-attributes pat)
                                            datum)
                          => (lambda (attr-bindings)
                               (append attr-bindings bindings)))
                         (else #f))))
             (else #f)))
      (else #f)))
  
  (define (match-contents pat-list nodeset)
    (cond
      ((and (null? pat-list) (null? nodeset))
       '())
      ((and (null? pat-list) (not (null? nodeset)))
       #f)
      ((tail-pat? (car pat-list))
       (list (list (tail-pat-var (car pat-list)) nodeset)))
      ((and (not (null? pat-list)) (null? nodeset))
       #f)
      ((dots-pat? (car pat-list))
       (match-dotted-pat (car pat-list) nodeset))
      (else (let ((bindings (match-xml-pat (car pat-list) (car nodeset))))
              (if bindings
                  (let ((second (match-contents (cdr pat-list) (cdr nodeset))))
                    (if second
                        (append bindings second)
                        #f))
                  #f)))))
  
  (define (match-one-attribute pat attr-list)
    (cond
      ((attr-pat? pat)
       (let ((attr? (match-xml-attribute (attr-pat-tag pat) attr-list)))
         (if attr?
             (list (attr-pat-var pat) (xml-attribute-value attr?))
             (if (attr-pat/def? pat)
                 (list (attr-pat-var pat) (attr-pat/def-default pat))
                 #f))))
      ((lit-attr-pat? pat)
       (let ((attr? (match-xml-attribute (lit-attr-pat-tag pat) attr-list)))
         (if (and attr?
                  (string=? (lit-attr-pat-value pat)
                            (xml-attribute-value attr?)))
             '()
             #f)))
      (else (error "internal error (match-one-attribute)"))))
  
  (define (match-attributes pat-list datum)
    (let ((attr-list (xml-element-attributes datum)))
      (let iter ((pat-list pat-list))
        (if (null? pat-list)
            '()
            (let* ((first? (match-one-attribute (car pat-list) attr-list)))
              (if first?
                  (let ((rest? (iter (cdr pat-list))))
                    (if rest?
                        (cons first? rest?)
                        #f))
                  #f))))))
  
  (define (dotted-bindings bindings)
    (map (lambda (binding)
           (list (car binding) (list (cadr binding))))
         bindings))
  
  (define (merge-bindings first-bindings rest-bindings)
    (map (lambda (single dotted)
           (list (car single)
                 (cons (cadr single) (cadr dotted))))
         first-bindings
         rest-bindings))
  
  (define (match-dotted-pat pat nodeset)
    (if (null? nodeset)
        '()
        (let ((first-bindings (match-xml-pat (dots-pat-pat pat) (car nodeset))))
          (if first-bindings
              (let ((rest-bindings (match-dotted-pat pat (cdr nodeset))))
                (if rest-bindings
                    (if (pair? rest-bindings)
                        (merge-bindings first-bindings rest-bindings)
                        (dotted-bindings first-bindings))
                    #f))
              #f))))
  
  (define (extract-binding var bindings)
    (let ((binding (assq var bindings)))
      (if binding
          (cadr binding)
          (error "xml-rules: template variable not present in the source pattern: " var))))
  
  (define-syntax (rewrite-template stx)
    (letrec ((nodeset-tplt (lambda (stx dvars)
                             (syntax-case stx ()
                               (var
                                (identifier? (syntax var))
                                (syntax var))
                               ((var)
                                (identifier? (syntax var))
                                (syntax (list var)))
                               ((item1)
                                (with-syntax ((new-item (translate-template (syntax item1) dvars)))
                                  (syntax (list new-item))))
                               ((item ellipses)
                                (eq? '... (syntax-object->datum (syntax ellipses)))
                                (with-syntax ((new-item (translate-template (syntax item) dvars))
                                              (vars (dotted-subset (all-vars (syntax item)) dvars)))
                                  (syntax (map (lambda vars new-item) . vars))))
                               ((item ellipses . items)
                                (eq? '... (syntax-object->datum (syntax ellipses)))
                                (with-syntax ((new-item (translate-template (syntax item) dvars))
                                              (vars (dotted-subset (all-vars (syntax item)) dvars))
                                              (rest-items (nodeset-tplt (syntax items) dvars)))
                                  (syntax (append (map (lambda vars new-item) . vars)
                                                  rest-items))))
                               ((var . items)
                                (identifier? (syntax var))
                                (with-syntax ((rest-item (nodeset-tplt (syntax items) dvars)))
                                  (syntax (cons var rest-item))))
                               ((item1 . items)
                                (with-syntax ((first-item (translate-template (syntax item1) dvars))
                                              (rest-item (nodeset-tplt (syntax items) dvars)))
                                  (syntax (cons first-item rest-item)))))))
             (ele-helper (lambda (stx dvars)
                           (syntax-case stx ()
                             (()
                              (syntax ()))
                             ((key var)
                              (and (keyword-identifier? (syntax-object->datum (syntax key)))
                                   (identifier? (syntax var)))
                              (syntax (list key var)))
                             ; need to change this- allow function calls, but not an element!
                             ((key exp)
                              (keyword-identifier? (syntax-object->datum (syntax key)))
                              (with-syntax ((new-exp (translate-template (syntax exp) dvars)))
                                (syntax (list key new-exp))))
                             ((key var . items)
                              (and (keyword-identifier? (syntax-object->datum (syntax key)))
                                   (identifier? (syntax var)))
                              (with-syntax ((rest-items (ele-helper (syntax items)
                                                                    dvars)))
                                (syntax (cons key (cons var rest-items)))))
                             ; need to change this- allow function calls, but not an element!
                             ((key exp . items)
                              (keyword-identifier? (syntax-object->datum (syntax key)))
                              (with-syntax ((new-exp (translate-template (syntax exp) dvars))
                                            (rest-items (ele-helper (syntax items)
                                                                    dvars)))
                                (syntax (cons key (cons new-exp rest-items)))))
                             (items
                              (nodeset-tplt (syntax items) dvars)))))
             (element-tplt (lambda (stx dvars)
                             (syntax-case stx ()
                               ((ele-tag . items)
                                (with-syntax ((new-items (ele-helper (syntax items)
                                                                     dvars)))
                                  (syntax (apply ele-tag new-items)))))))
             (translate-template (lambda (stx dvars)
                                   (syntax-case stx ()
                                     (var
                                      (identifier? (syntax var))
                                      (syntax var))
                                     ((ele-tag)
                                      (syntax (ele-tag)))
                                     ((ele-tag . contents)
                                      (with-syntax ((new-ele (element-tplt (syntax (ele-tag . contents))
                                                                           dvars)))
                                        (syntax new-ele)))
                                     (item (syntax item)))))
             (process-template 
              (lambda (pat bindings-id item)
                (syntax-case (all-vars pat) ()
                  (() ())
                  ((name ...) (with-syntax ((bindings bindings-id)
                                            (exp (translate-template item
                                                                     (dotted-vars pat))))
                                (syntax (let ((name (extract-binding (quote name) bindings)) ...)
                                          exp))))))))
      (syntax-case stx ()
        ((_ pat bindings template) (process-template (syntax pat)
                                                     (syntax bindings)
                                                     (syntax template))))))
  
  (define-syntax (template-wrapper stx)
    (letrec ((traverse 
              (lambda (output)
                (syntax-case output (xml-template)
                  ((_ pat bindings (xml-template template))
                   (syntax (rewrite-template pat bindings template)))
                  ((_ pat bindings (a . b))
                   (with-syntax ((first (traverse (syntax (_ pat bindings a))))
                                 (rest (traverse (syntax (_ pat bindings b)))))
                     (syntax (first . rest))))
                  ((_ pat bindings c)
                   (syntax c))))))
      (traverse stx)))
  
  )