(module render-test-list-impl mzscheme
  
  (require (lib "stx.ss" "syntax"))
  (require (rename (lib "1.ss" "srfi") map-append append-map))
  
  (require "match-error.ss"
           "match-helper.ss"
           "test-structure.scm"
           "coupling-and-binding.scm"
           "update-counts.scm"
           "update-binding-counts.scm"
           "reorder-tests.scm"
           "match-expander-struct.ss"
           "render-helpers.ss")
  
  (require "render-sigs.ss"
           (lib "unitsig.ss"))
  
  (require-for-syntax "match-helper.ss"
                      "match-expander-struct.ss"
                      "test-no-order.ss")
  
  (require-for-template mzscheme
			"match-error.ss"
			"test-no-order.ss"
                        "match-helper.ss")
  
  (provide render-test-list@)
  
  
  
  
  (define render-test-list@
    (unit/sig render-test-list^ (import ddk-handlers^ getbindings^)
      
      ;; some convenient syntax for make-reg-test and make-shape-test
      (define make-test-gen
        (case-lambda
          [(constructor test ae emitter) (make-test-gen constructor test ae emitter ae)]
          [(constructor test ae emitter ae2)
           (constructor test ae
                        (lambda (ks kf let-bound)
                          (lambda (sf bv)
                            (emit emitter ae2 let-bound sf bv kf ks))))]))
      
      (define (reg-test . args) (apply make-test-gen make-reg-test args))
      (define (shape-test . args) (apply make-test-gen make-shape-test args))
      
      ;; produce a matcher for the empty list
      (define (emit-null ae)  
        (list (reg-test `(null? ,(syntax-object->datum ae)) 
                        ae (lambda (exp) #`(null? #,exp)))))
      
      ;; generic helper for producing set/get matchers
      (define-syntax (set/get-matcher stx)    
        (syntax-case stx (set! get!)
          [(_ set!/get! ae p arg set/get-func) #`(set/get-matcher set!/get! ae p let-bound arg set/get-func)]
          [(_ set!/get! ae p let-bound arg set/get-func)              
           (with-syntax ([sym (syntax-case  #'set!/get! (set! get!) ['set! #''set!-pat] ['get! #''get!-pat])])
             #`(syntax-case arg ()
                 [(ident)
                  (identifier? #'ident)
                  (list (make-act
                         sym
                         ae
                         (lambda (ks kf let-bound)
                           (lambda (sf bv)
                             (ks sf (cons (cons #'ident
                                                set/get-func)
                                          bv))))))]
                 [() (match:syntax-err p
                                       (format "there should be an identifier after ~a in pattern" set!/get!))]
                 [(_) (match:syntax-err p
                                        (format " ~a followed by something that is not an identifier" set!/get!))]
                 [(_ (... ...))
                  (match:syntax-err p
                                    (format "there should be only one identifier after ~a in pattern" set!/get!))]
                 [_ (match:syntax-err p
                                      (format "invalid ~a pattern syntax" set!/get!))]))]))
      
      
      ;; expand the regexp-matcher into an (and) with string?
      (define (regexp-matcher ae stx pred)
        (render-test-list #`(and (? string?) #,pred) ae stx))
      
      
      ;;!(function or-gen
      ;;         (form (or-gen exp orpatlist sf bv ks kf let-bound)
      ;;               ->
      ;;               syntax)
      ;;         (contract (syntax list list list (list list -> syntax) 
      ;;                    (list list -> syntax) list)
      ;;                   ->
      ;;                   syntax))
      ;; The function or-gen is very similar to the function gen except
      ;; that it is called when an or pattern is compiled.  An or
      ;; pattern is essentially the same as a match pattern with several
      ;; clauses.  The key differences are that it exists within a
      ;; larger pattern and the state of compilation has information
      ;; that will help optimaize its compilation.  And the success of
      ;; any pattern results in the same outcome.
      (define (or-gen exp orpatlist sf bv ks kf let-bound)
        (define rendered-list
          (map
           (lambda (pat) 
             (cons (render-test-list pat exp)
                   (lambda (fail let-bound)
                     (lambda (sf bv)
                       (let ((bv (map
                                  (lambda (bind)
                                    (cons (car bind)
                                          (subst-bindings (cdr bind) 
                                                          let-bound)))
                                  bv)))
                         (ks sf bv))))))
           orpatlist))
        (update-counts rendered-list)
        (update-binding-counts rendered-list)
        ((meta-couple (reorder-all-lists rendered-list) kf let-bound bv) sf bv))
      
      
      ;;!(function render-test-list
      ;;          (form (render-test-list p ae stx) -> test-list)
      ;;          (contract (syntax syntax syntax) -> list))
      ;; This is the most important function of the entire compiler.
      ;; This is where the functionality of each pattern is implemented.
      ;; This function maps out how each pattern is compiled.  While it
      ;; only returns a list of tests, the comp field of those tests
      ;; contains a function which inturn knows enough to compile the
      ;; pattern.
      ;; <p>This is implemented in what Wright terms as mock-continuation-passing
      ;; style.  The functions that create the syntax for a match success and failure
      ;; are passed forward
      ;; but they are always called in emit.  This is extremely effective for
      ;; handling the different structures that are matched.  This way we can
      ;; specify ahead of time how the rest of the elements of a list or vector
      ;; should be handled.  Otherwise we would have to pass more information
      ;; forward in the argument list of next and then test for it later and
      ;; then take the appropriate action.  To understand this better take a
      ;; look at how proper and improper lists are handled.
      (define/opt (render-test-list p ae [stx #'here])
        (syntax-case*
            p
          (_ list quote quasiquote vector box ? app and or not struct set! var
             list-rest get! ... ___ unquote unquote-splicing cons
             list-no-order hash-table regexp pregexp cons) stx-equal?
          
          ;; this is how we extend match
          [(expander args ...)
           (and (identifier? #'expander) 
                (match-expander? (syntax-local-value #'expander (lambda () #f))))
           (let ([transformer (match-expander-plt-match-xform (syntax-local-value #'expander))])                  
             (if (not transformer)
                 (match:syntax-err #'expander
                                   "This expander only works with standard match.")            
                 (render-test-list (transformer #'(expander args ...))
                                   ae stx)))]
          
          ;; underscore is reserved to match nothing
          (_ '()) ;(ks sf bv let-bound))
          
          ;; plain identifiers expand into (var) patterns
          (pt
           (and (pattern-var? (syntax pt))
                (not (stx-dot-dot-k? (syntax pt))))
           (render-test-list #'(var pt) ae stx))
          
          ;; for variable patterns, we do bindings, and check if we've seen this variable before
          ((var pt)
           (identifier? (syntax pt))
           (list (make-act `bind-var-pat
                           ae
                           (lambda (ks kf let-bound)
                             (lambda (sf bv)                           
                               (cond [(ormap (lambda (x)
                                               (if (stx-equal? #'pt (car x))
                                                   (cdr x) #f)) bv)
                                      => (lambda (bound-exp)
                                           (emit (lambda (exp)
                                                   #`((match-equality-test) #,exp #,(subst-bindings bound-exp let-bound)))
                                                 ae
                                                 let-bound
                                                 sf bv kf ks))]
                                     [else
                                      (ks sf (cons (cons (syntax pt) ae) bv))]))))))
          
          ;; Recognize the empty list
          ((list) (emit-null ae))
          ('() (emit-null ae))
          
          
          ;; This recognizes constants such strings
          [pt
           (let ([pt (syntax-object->datum #'pt)])
             (or (string? pt)
                 (boolean? pt)
                 (char? pt)
                 (number? pt)))
           (list
            (reg-test 
             `(equal? ,(syntax-object->datum ae)
                      ,(syntax-object->datum (syntax pt)))
             ae (lambda (exp) #`(equal? #,exp pt))))]
          
          ;(pt
          ; (stx-? regexp? (syntax pt))
          ; (render-test-list (syntax/loc p (regex pt)) ae stx))
          
          ;; match a quoted datum
          ;; this is very similar to the previous pattern, except for the second argument to equal?
          [(quote _)
           (list 
            (reg-test
             `(equal? ,(syntax-object->datum ae)
                      ,(syntax-object->datum p))
             ae (lambda (exp) #`(equal? #,exp #,p))))]
          
          ;; I do not understand this, or why it is ever matched, but removing it causes test failures
          ('item
            (list 
             (reg-test
              `(equal? ,(syntax-object->datum ae)
                       ,(syntax-object->datum p))
              ae (lambda (exp) #`(equal? #,exp #,p)))))
          
          (`quasi-pat
            (render-test-list (parse-quasi #'quasi-pat) ae stx))
          
          
          ;; check for predicate patterns
          ;; could we check to see if a predicate is a procedure here?
          ((? pred?)
           (list (reg-test 
                  `(,(syntax-object->datum #'pred?)
                     ,(syntax-object->datum ae))
                  ae (lambda (exp) #`(pred? #,exp)))))
          
          ;; predicate patterns with binders are redundant with and patterns
          ((? pred? pats ...)
           (render-test-list #'(and (? pred?) pats ...) ae stx))
          
          ;; syntax checking
          ((? anything ...)
           (match:syntax-err
            p
            (if (zero? (length (syntax-e #'(anything ...))))
                "a predicate pattern must have a predicate following the ?"
                "syntax error in predicate pattern")))
          
          ((regexp reg-exp)
           (regexp-matcher ae stx #'(? (lambda (x) (regexp-match reg-exp x)))))
          ((pregexp reg-exp) 
           (regexp-matcher ae stx #'(? (lambda (x) (pregexp-match-with-error reg-exp x)))))
          ((regexp reg-exp pat)
           (regexp-matcher ae stx #'(app (lambda (x) (regexp-match reg-exp x)) pat)))
          ((pregexp reg-exp pat)
           (regexp-matcher ae stx #'(app (lambda (x) (pregexp-match-with-error reg-exp x)) pat)))
          
          ;; app patterns just apply their operation.  I'm not sure why they exist.
          ((app op pat)
           (render-test-list #'pat #`(op #,ae) stx))
          
          ;; syntax checking
          ((app . op)
           (match:syntax-err
            p
            (if (zero? (length (syntax-e #'op)))
                "an operation pattern must have a procedure following the app"
                "there should be one pattern following the operator")))
          ((and . pats)
           (let loop
             ((p #'pats))
             (syntax-case p ()
               ;; empty and always succeeds
               [() '()] ;(ks seensofar boundvars let-bound))
               [(pat . rest)
                (append (render-test-list #'pat ae stx)
                        (loop #'rest))])))
          
          ((or . pats)
           (list (make-act
                  'or-pat ;`(or-pat ,(syntax-object->datum ae))
                  ae
                  (lambda (ks kf let-bound)
                    (lambda (sf bv)
                      (or-gen ae (syntax-e #'pats)
                              sf bv ks kf let-bound))))))
          
          
          ((not pat)
           (list (make-act
                  'not-pat ;`(not-pat ,(syntax-object->datum ae))
                  ae
                  (lambda (ks kf let-bound)
                    (lambda (sf bv)
                      ;; swap success and fail
                      (next-outer #'pat ae sf bv let-bound ks kf))))))
          
          ;; (cons a b) == (list-rest a b)
          [(cons p1 p2) (render-test-list #'(list-rest p1 p2) ae stx)]
          
          ;; could try to catch syntax local value error and rethrow syntax error      
          ((list-no-order pats ...)
           (if (stx-null? (syntax (pats ...)))
               (render-test-list #'(list) ae stx)
               (let* ((pat-list (syntax->list (syntax (pats ...))))
                      (ddk-list (ddk-in-list? pat-list))
                      (ddk (ddk-only-at-end-of-list? pat-list)))
                 (if (or (not ddk-list)
                         (and ddk-list ddk))
                     (let* ((bound (getbindings (append-if-necc 'list
                                                                (syntax (pats ...)))))
                            (bind-map
                             (map (lambda (x)
                                    (cons x #`#,(gensym (syntax-object->datum x))))
                                  bound)))
                       
                       (list
                        (shape-test
                         `(list? ,(syntax-object->datum ae))
                         ae (lambda (exp) #`(list? #,exp)))
                        (make-act
                         'list-no-order
                         ae
                         (lambda (ks kf let-bound)
                           (lambda (sf bv)
                             (let ((last-test
                                    (if ddk
                                        (let ((pl (cdr (reverse pat-list))))
                                          (begin
                                            (set! pat-list (reverse (cdr pl)))
                                            (create-test-func (car pl)
                                                              sf
                                                              let-bound
                                                              bind-map
                                                              #t)))
                                        #f)))
                               #`(let #,(map (lambda (b)
                                               #`(#,(cdr b) '()))
                                             bind-map)
                                   (let ((last-test #,last-test)
                                         (test-list
                                          (list
                                           #,@(map (lambda (p)
                                                     (create-test-func
                                                      p
                                                      sf
                                                      let-bound
                                                      bind-map
                                                      #f))
                                                   pat-list))))
                                     (if (match:test-no-order test-list
                                                              #,ae
                                                              last-test
                                                              #,ddk)
                                         #,(ks sf (append bind-map bv))
                                         #,(kf sf bv))))))))))
                     (match:syntax-err
                      p
                      (string-append "dot dot k can only appear at "
                                     "the end of unordered match patterns"))))))
          
          ((hash-table pats ...)
           ;; must check the structure
           (proper-hash-table-pattern? (syntax->list (syntax (pats ...))))
           (list
            (shape-test
             `(hash-table? ,(syntax-object->datum ae))
             ae (lambda (exp) #`(hash-table? #,exp)))
            
            (let ((mod-pat
                   (lambda (pat)
                     (syntax-case pat ()
                       ((key value) (syntax (list key value)))
                       (ddk
                        (stx-dot-dot-k? (syntax ddk))
                        (syntax ddk))
                       (id
                        (and (pattern-var? (syntax id))
                             (not (stx-dot-dot-k? (syntax id))))
                        (syntax id))
                       (p (match:syntax-err
                           (syntax/loc stx p)
                           "poorly formed hash-table pattern"))))))
              (make-act
               'hash-table-pat
               ae
               (lambda (ks kf let-bound)
                 (lambda (sf bv)
                   (let ((hash-name (gensym 'hash)))
                     #`(let ((#,hash-name
                                (hash-table-map #,(subst-bindings ae
                                                                  let-bound)
                                                (lambda (k v) (list k v)))))
                         #,(next-outer #`(list-no-order #,@(map mod-pat (syntax->list (syntax (pats ...)))))
                                       #`#,hash-name
                                       sf
                                       ;; these tests have to be true
                                       ;;(append (list
                                       ;;         '(pair? exp)
                                       ;;         '(pair? (cdr exp))
                                       ;;         '(null? (cdr (cdr exp))))
                                       ;;        sf)
                                       bv
                                       let-bound
                                       kf
                                       ks)))))))))
          
          ((hash-table . pats)
           (match:syntax-err
            p
            "improperly formed hash table pattern"))
          
          ((struct struct-name (fields ...))
           (identifier? (syntax struct-name))
           (let*-values ([(field-pats) (syntax->list (syntax (fields ...)))]
                         [(num-of-fields) (length field-pats)]
                         [(pred accessors mutators parental-chain)
                          (struct-pred-accessors-mutators #'struct-name)]
                         ;; check that we have the right number of fields
                         [(dif) (- (length accessors) num-of-fields)])
             (unless (zero? dif)
               (match:syntax-err
                p
                (string-append
                 (if (> dif 0) "not enough " "too many ")
                 "fields for structure in pattern")))
             (cons
              (shape-test
               `(struct-pred ,(syntax-object->datum pred)
                             ,(map syntax-object->datum parental-chain)
                             ,(syntax-object->datum ae))
               ae (lambda (exp) #`(struct-pred #,pred #,parental-chain #,exp)))
              (map-append 
               (lambda (cur-pat cur-mutator cur-accessor) 
                 (syntax-case cur-pat (set! get!)
                   [(set! . rest)
                    (unless cur-mutator (match:syntax-err cur-pat "Cannot use set! pattern with immutable fields"))
                    (set/get-matcher 'set! ae p #'rest
                                     #`(lambda (y)
                                         (#,cur-mutator #,ae y)))]
                   [(get! . rest)
                    (set/get-matcher 'get! ae p #'rest
                                     #`(lambda ()
                                         (#,cur-accessor #,ae)))]
                   [_ (render-test-list 
                       cur-pat
                       (quasisyntax/loc stx (#,cur-accessor #,ae))
                       stx)]))
               field-pats mutators accessors))))
          
          ;; syntax checking
          ((struct ident ...)
           (match:syntax-err
            p
            (if (zero? (length (syntax-e (syntax (ident ...)))))
                (format "~a~n~a~n~a"
                        "a structure pattern must have the name "
                        "of a defined structure followed by a list of patterns "
                        "to match each field of that structure")
                "syntax error in structure pattern")))
          ;; use a helper macro to match set/get patterns.  
          ;; we give it the whole rest so that it can do error-checking and reporting
          [(set! . rest)
           (set/get-matcher 'set! ae p let-bound (syntax rest)
                            (setter ae p let-bound))]
          [(get! . rest)
           (set/get-matcher 'get! ae p let-bound (syntax rest)
                            (getter ae p let-bound))]
          
          ;; list pattern with ooo or ook
          ((list pat dot-dot-k pat-rest ...)
           (and (not (or (memq (syntax-e (syntax pat))
                               '(unquote unquote-splicing ... ___))
                         (stx-dot-dot-k? (syntax pat))))
                (stx-dot-dot-k? (syntax dot-dot-k)))
           (list
            (shape-test
             `(list? ,(syntax-object->datum ae))
             ae (lambda (exp) #`(list? #,exp)))
            (make-act
             'list-ddk-pat
             ae
             (lambda (ks kf let-bound)
               (if (stx-null? (syntax (pat-rest ...)))
                   (handle-end-ddk-list ae kf ks
                                        (syntax pat)
                                        (syntax dot-dot-k)
                                        let-bound)
                   (handle-inner-ddk-list ae kf ks
                                          (syntax pat)
                                          (syntax dot-dot-k)
                                          (append-if-necc 'list
                                                          (syntax (pat-rest ...)))
                                          let-bound))))))
          
          ;; list-rest pattern with a ooo or ook pattern
          ((list-rest pat dot-dot-k pat-rest ...)
           (and (not (or (memq (syntax-e (syntax pat))
                               '(unquote unquote-splicing ... ___))
                         (stx-dot-dot-k? (syntax pat))
                         (stx-null? (syntax (pat-rest ...)))))
                (stx-dot-dot-k? (syntax dot-dot-k)))
           (list
            (shape-test
             `(pair? ,(syntax-object->datum ae))
             ae (lambda (exp) #`(pair? #,exp)))
            (make-act
             'list-ddk-pat
             ae
             (lambda (ks kf let-bound)
               (handle-inner-ddk-list
                ae kf ks
                (syntax pat)
                (syntax dot-dot-k)
                (if (= 1 (length
                          (syntax->list (syntax (pat-rest ...)))))
                    (stx-car (syntax (pat-rest ...)))
                    (append-if-necc  'list-rest
                                     (syntax (pat-rest ...))))
                let-bound)))))
          
          ;; list-rest pattern for improper lists
          ;; handle proper and improper lists      
          ((list-rest car-pat cdr-pat) ;pattern ;(pat1 pats ...)
           (not (or (memq (syntax-e (syntax car-pat))
                          '(unquote unquote-splicing))
                    (stx-dot-dot-k? (syntax car-pat))))
           (cons
            (shape-test
             `(pair? ,(syntax-object->datum ae))
             ae (lambda (exp) #`(pair? #,exp)))
            (append
             (render-test-list (syntax car-pat)
                               (quasisyntax/loc (syntax car-pat) (car #,ae))
                               stx) ;(add-a e)
             (render-test-list
              (syntax cdr-pat)
              #`(cdr #,ae)
              stx))))
          
          ;; list-rest pattern
          ((list-rest car-pat cdr-pat ...) ;pattern ;(pat1 pats ...)
           (not (or (memq (syntax-e (syntax car-pat))
                          '(unquote unquote-splicing))
                    (stx-dot-dot-k? (syntax car-pat))))
           (cons
            (shape-test
             `(pair? ,(syntax-object->datum ae))
             ae (lambda (exp) #`(pair? #,exp)))
            (append
             (render-test-list (syntax car-pat)
                               #`(car #,ae)
                               stx) ;(add-a e)
             (render-test-list
              (append-if-necc 'list-rest (syntax (cdr-pat ...)))
              #`(cdr #,ae)
              stx))))
          
          ;; general list pattern
          ((list car-pat cdr-pat ...) ;pattern ;(pat1 pats ...)
           (not (or (memq (syntax-e (syntax car-pat))
                          '(unquote unquote-splicing))
                    (stx-dot-dot-k? (syntax car-pat))))
           (cons
            (shape-test
             `(pair? ,(syntax-object->datum ae))
             ae (lambda (exp) #`(pair? #,exp)))
            (append
             (render-test-list (syntax car-pat)
                               #`(car #,ae)
                               stx) ;(add-a e)
             (if (stx-null? (syntax (cdr-pat ...)))
                 (list
                  (shape-test
                   `(null? (cdr ,(syntax-object->datum ae)))
                   ae (lambda (exp) #`(null? #,exp)) #`(cdr #,ae)))
                 (render-test-list
                  (append-if-necc 'list (syntax (cdr-pat ...)))
                  #`(cdr #,ae)
                  stx)))))
          
          ;; vector pattern with ooo or ook at end
          ((vector pats ...)
           (ddk-only-at-end-of-list? (syntax-e (syntax (pats ...))))
           (list
            (shape-test
             `(vector? ,(syntax-object->datum ae))
             ae (lambda (exp) #`(vector? #,exp)))
            (make-act
             'vec-ddk-pat
             ae
             (lambda (ks kf let-bound)
               (handle-ddk-vector ae kf ks
                                  #'#(pats ...)
                                  let-bound)))))
          
          ;; vector pattern with ooo or ook, but not at end
          ((vector pats ...)
           (let* ((temp (syntax-e (syntax (pats ...))))
                  (len (length temp)))
             (and (>= len 2)
                  (ddk-in-list? temp)))
           ;; make this contains ddk with no ddks consecutive
           ;;(stx-dot-dot-k? (vector-ref temp (sub1 len))))))
           (list
            (shape-test
             `(vector? ,(syntax-object->datum ae))
             ae (lambda (exp) #`(vector? #,exp)))
            ;; we have to look at the first pattern and see if a ddk follows it
            ;; if so handle that case else handle the pattern
            (make-act
             'vec-ddk-pat
             ae
             (lambda (ks kf let-bound)
               (handle-ddk-vector-inner ae kf ks
                                        #'#(pats ...)
                                        let-bound)))))
          
          ;; plain old vector pattern
          ((vector pats ...)
           (let* ((syntax-vec (list->vector (syntax->list (syntax (pats ...)))))
                  (vlen (vector-length syntax-vec)))
             (list*
              (shape-test
               `(vector? ,(syntax-object->datum ae)) ae
               (lambda (exp) #`(vector? #,exp)))
              (shape-test
               `(equal? (vector-length ,(syntax-object->datum ae)) ,vlen)
               ae (lambda (exp) #`(equal? (vector-length #,exp) #,vlen)))
              (let vloop ((n 0))
                (if (= n vlen)
                    '()
                    (append
                     (render-test-list
                      (vector-ref syntax-vec n)
                      #`(vector-ref #,ae #,n)
                      stx)
                     (vloop (+ 1 n))))))))
          
          ((box pat)
           (cons
            (shape-test
             `(box? ,(syntax-object->datum ae))
             ae (lambda (exp) #`(box? #,exp)))
            (render-test-list
             #'pat #`(unbox #,ae) stx)))
          
          ;; This pattern wasn't a valid form.
          (got-too-far
           (match:syntax-err
            #'got-too-far
            "syntax error in pattern"))))
      
      ;; end of render-test-list@
      ))
  
  )