(module zip mzscheme
  (require (lib "struct.ss"))
  (require-for-syntax (lib "plt-match.ss")
                      (lib "list.ss")
                      "zip-help.ss")   
  (provide (all-defined))
  
  ; A macro system for describing Zipper invocations.
  ; - A Zipper is a path through a data-structure to a point to update (functionally).
  ; - These may be done one after the other (i.e. composed)
  ;   However, this can duplicate work if the n updates share a common prefix.
  ; - So, we optimize this.
  
  ; Wish-list
  ; - support list (first / rest)
  ; - support pair
  ; - support string
  
  ; Todo list
  ; - support (struct field)
  
  ; Helpers
  (define-for-syntax (resolve-field struct-stx field-stx)
    (unless (identifier? struct-stx)
      (raise-syntax-error 'resolve-field "Not a struct definition." struct-stx))
    (unless (identifier? field-stx)
      (raise-syntax-error 'resolve-field "Not an identifier" field-stx))
    (datum->syntax-object 
     field-stx
     (string->symbol
      (format "~a-~a"
              (symbol->string (syntax-e struct-stx))
              (symbol->string (syntax-e field-stx))))))
  
  ; Wrappers
  (define-syntax change
    (syntax-rules ()
      [(_ d ([s f] ... v) ...)
       (update d ([s f] ... (lambda _ v)) ...)]))
  (define-syntax look
    (syntax-rules ()
      [(_ d ([s f] ... v))
       (let/ec esc
         (update d ([s f] ... (lambda (v) (esc v)))))]))
  
  ; Implementation
  (define-for-syntax show-optimize? #f)
  
  (define-syntax (update stx)
    (syntax-case stx ()
      [(_ a-struct
          ([struct field]
           ...
           updater)
          ...)
       (quasisyntax/loc stx
         (update* a-struct
                  #,@(map (lambda (stx)
                            (syntax-case stx ()
                              [([struct1 field1] ... updater1)
                               (with-syntax ([([struct2 field2] ...)
                                              (map (lambda (s f)
                                                     (list s (resolve-field s f)))
                                                   (syntax->list #`(struct1 ...))
                                                   (syntax->list #`(field1 ...)))])
                                 (quasisyntax/loc stx
                                   ([struct2 field2]
                                    ...
                                    updater1)))]))
                          (syntax->list
                           #`(([struct field]
                               ...
                               updater)
                              ...)))))]))
  
  (define-syntax (update* stx)
    (syntax-case stx ()
      [(p-u a-struct
            (updater))
       (syntax/loc stx
         (updater a-struct))]
      [(p-u a-struct
            ([top-struct top-field]
             [struct field]
             ...
             updater)
            ...)
       (match 
           (foldl (match-lambda*
                    [(list stx mi-map)
                     (syntax-case stx ()
                       [([top-s top-f]
                         [s f] ...
                         up)
                        (mi-insert (list #`top-s #`top-f) stx mi-map)])])
                  empty
                  (syntax->list #`(([top-struct top-field]
                                    [struct field]
                                    ...
                                    updater)
                                   ...)))
         [(list (list (list a-top-struct-stx a-top-field-stx) (list update-stx ...)) ...)
          (when (empty? a-top-struct-stx)
            (raise-syntax-error 'update "No updates given"
                                #`p-u #`a-struct))
          (unless (andmap/mi a-top-struct-stx)
            (raise-syntax-error 'update "Structures on branch do not match" 
                                #`p-u (first a-top-struct-stx)))
          (let ([the-top-struct (first a-top-struct-stx)])
            (quasisyntax/loc stx
              (let ([the-struct a-struct])
                (copy-struct #,the-top-struct the-struct
                             #,@(map (lambda (a-top-field-stx update-stx-lst)
                                       (when show-optimize?
                                         (printf "~a: ~S~n"
                                                 (if (>= (length update-stx-lst) 2)
                                                     "Optimize"
                                                     "No Optimize")
                                                 (map (lambda (update-stx)
                                                        (with-syntax
                                                            ([([top-s top-f]
                                                               [s f] ...
                                                               up)
                                                              update-stx])
                                                          #`top-f))
                                                      update-stx-lst)))
                                       #`[#,a-top-field-stx
                                            (update* (#,a-top-field-stx
                                                        the-struct)
                                                     #,@(map (lambda (update-stx)
                                                               (with-syntax
                                                                   ([([top-s top-f]
                                                                      [s f] ...
                                                                      up)
                                                                     update-stx])
                                                                 #`([s f] 
                                                                    ...
                                                                    up)))
                                                             update-stx-lst))])
                                     a-top-field-stx
                                     update-stx)))))])])))