(module rules-helper mzscheme
  
  (provide keyword-identifier?
           all-vars
           dotted-vars
           dotted-subset
           member-identifier?
           sub-id
           sub-id/weak)
  
  (define (sub-id id env)
    (let ((keys (car env))
          (vals (cdr env)))
      (define (find k v)
        (cond ((null? k) (error "sub-id: could not match identifier" (syntax-e id)))
              ((eq? (syntax-object->datum (car k)) (syntax-object->datum id)) (car v))
              (else (find (cdr k) (cdr v)))))
      (find keys vals)))
  
  ; weak version. returns id if id not found in the substitution env
  (define (sub-id/weak id env)
    (let ((keys (car env))
          (vals (cdr env)))
      (define (find k v)
        (cond ((null? k) id)
              ((eq? (syntax-object->datum (car k)) (syntax-object->datum id)) (car v))
              (else (find (cdr k) (cdr v)))))
      (find keys vals)))
  
  (define (member-id? id lst)
    (if (null? lst)
        #f
        (if (eq? (syntax-object->datum id) (syntax-object->datum (car lst)))
            lst
            (member-id? id (cdr lst)))))
  
  (define (member-identifier? id lst)
    (if (pair? lst)
        (member-id? id lst)
        (begin (write "syntax in member-identifier?" (current-error-port))
               (member-id? id (syntax->list lst)))))
  
  (define (dotted-subset tplt-vars var-lst)
    (cond
      ((null? tplt-vars) '())
      ((member-id? (car tplt-vars) var-lst)
       (cons (car tplt-vars) (dotted-subset (cdr tplt-vars) var-lst)))
      (else (dotted-subset (cdr tplt-vars) var-lst))))
  
  (define keyword-identifier? (lambda (s)
                                (and (symbol? s)
                                     (char=? #\:
                                             (let ((st (symbol->string s)))
                                               (string-ref st (- (string-length st) 1)))))))
  
  (define (merge-ids lst-a lst-b)
    (cond
      ((null? lst-a) lst-b)
      ((null? lst-b) lst-a)
      ((member-id? (car lst-a) lst-b) (merge-ids (cdr lst-a) lst-b))
      (else (merge-ids (cdr lst-a) (cons (car lst-a) lst-b)))))
  
  (define (all-vars stx)
    (letrec ((nodeset-pat (lambda (stx)
                            (syntax-case stx ($)
                              (var
                               (identifier? (syntax var))
                               (list #'var))
                              ((var)
                               (identifier? (syntax var))
                               (list #'var))
                              ((($ var type-tag))
                               (identifier? (syntax var))
                               (list #'var))
                              ((item1)
                               (translate-pattern (syntax item1)))
                              ((item ellipses)
                               (eq? '... (syntax-object->datum (syntax ellipses)))
                               (translate-pattern (syntax item)))
                              ((var . items)
                               (identifier? (syntax var))
                               (let ((rst-ids (nodeset-pat #'items)))
                                 (if (member-id? #'var rst-ids)
                                     rst-ids
                                     (cons #'var rst-ids))))
                              ((($ var type-tag) . items)
                               (identifier? (syntax var))
                               (let ((rst-ids (nodeset-pat #'items)))
                                 (if (member-id? #'var rst-ids)
                                     rst-ids
                                     (cons #'var rst-ids))))
                              ((item1 . items)
                               (merge-ids (translate-pattern (syntax item1))
                                          (nodeset-pat (syntax items)))))))
             (ele-helper (lambda (stx)
                           (syntax-case stx ()
                             ((ele-tag)
                              '())
                             ((ele-tag key str)
                              (and (keyword-identifier? (syntax-object->datum (syntax key)))
                                   (string? (syntax-e #'str)))
                              '())
                             ((ele-tag key var)
                              (and (keyword-identifier? (syntax-object->datum (syntax key)))
                                   (identifier? (syntax var)))
                              (list #'var))
                             ((ele-tag key (var default))
                              (and (keyword-identifier? (syntax-object->datum (syntax key)))
                                   (identifier? (syntax var)))
                              (list #'var))
                             ((ele-tag key str . items)
                              (and (keyword-identifier? (syntax-object->datum (syntax key)))
                                   (string? (syntax-e #'str)))
                              (ele-helper (syntax (ele-tag 
                                                   . items))))
                             ((ele-tag key var . items)
                              (and (keyword-identifier? (syntax-object->datum (syntax key)))
                                   (identifier? (syntax var)))
                              (let ((rst-ids (ele-helper (syntax (ele-tag . items)))))
                                (if (member-id? #'var rst-ids)
                                    rst-ids
                                    (cons #'var rst-ids))))
                             ((ele-tag key (unqt exp) . items)
                              (and (keyword-identifier? (syntax-object->datum (syntax key)))
                                   (eq? 'unquote (syntax-e #'unqt)))
                              (merge-ids (translate-pattern (syntax exp))
                                         (ele-helper (syntax (ele-tag . items)))))
                             ((ele-tag key (var default) . items)
                              (and (keyword-identifier? (syntax-object->datum (syntax key)))
                                   (identifier? (syntax var)))
                              (let ((rst-ids (ele-helper (syntax (ele-tag . items)))))
                                (if (member-id? #'var rst-ids)
                                    rst-ids
                                    (cons #'var rst-ids))))
                             ((ele-tag . items)
                              (nodeset-pat (syntax items))))))
             (translate-pattern (lambda (stx)
                                  (syntax-case stx ($)
                                    (var
                                     (identifier? (syntax var))
                                     (list #'var))
                                    (($ var type-tag)
                                     (identifier? (syntax var))
                                     (list #'var))
                                    (str
                                     (string? (syntax-e #'str))
                                     '())
                                    ((ele-tag)
                                     '())
                                    ((ele-tag . contents)
                                     (ele-helper (syntax (ele-tag . contents))))
                                    (item '())))))
      (translate-pattern stx)))
  
  (define (dotted-vars stx)
    (letrec ((nodeset-pat (lambda (stx)
                            (syntax-case stx ($)
                              (var
                               (identifier? (syntax var))
                               '())
                              ((var)
                               (identifier? (syntax var))
                               '())
                              ((($ var type-tag))
                               (identifier? (syntax var))
                               '())
                              ((item1)
                               (translate-pattern (syntax item1)))
                              ((item ellipses)
                               (eq? '... (syntax-object->datum (syntax ellipses)))
                               (all-vars (syntax item)))
                              ((var . items)
                               (identifier? (syntax var))
                               (nodeset-pat (syntax items)))
                              ((($ var type-tag) . items)
                               (identifier? (syntax var))
                               (nodeset-pat (syntax items)))
                              ((item1 . items)
                               (merge-ids (translate-pattern (syntax item1))
                                          (nodeset-pat (syntax items)))))))
             (ele-helper (lambda (stx)
                           (syntax-case stx ()
                             ((ele-tag)
                              '())
                             ((ele-tag key var)
                              (and (keyword-identifier? (syntax-object->datum (syntax key))))
                              '())
                             ((ele-tag key var . items)
                              (and (keyword-identifier? (syntax-object->datum (syntax key))))
                              (ele-helper (syntax (ele-tag . items))))
                             ((ele-tag . items)
                              (nodeset-pat (syntax items))))))
             (translate-pattern (lambda (stx)
                                  (syntax-case stx ($)
                                    (var
                                     (identifier? (syntax var))
                                     '())
                                    (($ var type-tag)
                                     (identifier? (syntax var))
                                     '())
                                    (str
                                     (string? (syntax-e #'str))
                                     '())
                                    ((ele-tag)
                                     '())
                                    ((ele-tag . contents)
                                     (ele-helper (syntax (ele-tag . contents))))
                                    (item '())))))
      (translate-pattern stx)))
  
  )