#lang scheme/base

(require "honu.ss"
         (for-syntax "debug.ss"
                     "contexts.ss"
                     scheme/base
                     syntax/parse
                     syntax/stx
                     scheme/pretty
                     scheme/trace))

(provide honu-macro)

(define-for-syntax (extract-conventions pattern)
  (let loop ([out '()]
             [in pattern])
    (syntax-case in (:)
      [(any : attribute rest ...)
       ;; todo: export honu attributes for syntax/parse
       (loop (cons #'(any expr) out)
             #'(rest ...))
       #;
       (loop (cons #'(any attribute) out)
             #'(rest ...))]
      [(foo rest1 rest ...)
       (loop out #'(rest1 rest ...))]
      [(foo) out])))

(define-syntax (semicolon stx)
  stx)

(define-for-syntax (extract-patterns pattern)
  (let loop ([out '()]
             [in pattern])
    (syntax-case in (:)
      [(any : attribute rest ...)
       (loop (cons #'any out)
             #'(rest ...))]
      [(foo rest1 rest ...)
       (let ([f (if (eq? (syntax->datum #'foo) 'crackers)
                  #'(... ...)
                  #'foo)])
         (loop (cons f out)
               #'(rest1 rest ...)))]
      [(foo) (reverse (cons #'foo out))])))

#|
(define-for-syntax (convert stx)
  (syntax-case stx (...)
    [(_ x ...)
     |#

(define-for-syntax (fix-template stx) stx)

#|
(define-for-syntax (fix-template stx)
  [(any \;
            (... ...) rest1 rest ...)
       (loop (cons #'(semicolon any (... ..)))
             #'(rest1 rest ...))]
      [((any1 any ...) rest1 rest ...)
       (loop (loop out #'(any1 any ...))
             #'(rest1 rest ...))]
      |#


;; x = 1 + y; ...

#;
(define-honu-syntax honu-macro
  (lambda (stx ctx)
    (debug "Original macro: ~a\n" (syntax->datum stx))
    (syntax-case stx (#%parens #%braces)
      [(_ (#%parens honu-literal ...)
          (#%braces (#%braces name pattern ...))
          (#%braces (#%braces template ...))
          . rest)
       (with-syntax ([(conventions ...)
                      (extract-conventions #'(pattern ...))]
                     [(raw-patterns ...)
                      (extract-patterns #'(pattern ...))]
                     [(fixed-template ...)
                      (fix-template #'(template ...))])
         (debug "new template ~a\n" (syntax->datum #'(fixed-template ...)))
         (values
           (syntax/loc
             stx
             (begin
               #|
               (define honu-literal (lambda () (error 'honu-literal "cant use this")))
               ...
               |#
               (define-honu-syntax name
                 (lambda (stx ctx)
                   (debug "Try to match against pattern ~a. Literals ~a\n" '(name raw-patterns ... . rrest) '(honu-literal ...))
                   (debug "stx is ~a\n" (syntax->datum stx))
                   ;; (printf "head is ~a\n" (stx-car stx))
                   ;; (printf "= is ~a\n" =)
                   (debug "my matcher ~a\n"
                           (syntax-case stx (to set! do honu-end honu-literal ...)
                             [(name q set! v to m do bb (... ...) honu-end) (syntax->datum #'(bb (... ...)))]
                             [(name raw-patterns ...)
                              'ok2]
                             [(name pattern ...) 'ok5]
                             [(name v (... ...) honu-literal ...) 'ok4]
                             [(name v (... ...)) 'ok3]
                             #;
                             [(name v (... ...)) (syntax->datum #'(v (... ...)))]
                             [else 'bad]))
                   #;
                   (debug "case pattern ~a\n"
                           #'(syntax-case stx
                               (honu-literal ...)
                               [(name pattern ...)
                                #'(honu-unparsed-block
                                    #f obj 'obj #f ctx
                                    fixed-template ...)]))

                   (let ([result (syntax-case stx
                                   #;
                                   (to set! do honu-end)
                                   (honu-literal ...)
                                   #;
                                   [(name q set! v to m do bb (... ...) honu-end) (syntax->datum #'(bb (... ...)))]
                                   [(name pattern ...) 'ok]
                                   [(name raw-patterns ...)
                                    #'(honu-unparsed-block
                                        #f obj 'obj #f ctx
                                        fixed-template ...)]
                                   [else 'fail-boat])])
                     (debug "result was ~a\n" result))
                   (syntax-case stx (honu-literal ...)
                     [(name raw-patterns ... . rrest)
                      (values
                        #'(honu-unparsed-block
                            #f obj 'obj #f ctx
                            fixed-template ...)
                        #'rrest)])))
               #;
               (define-honu-syntax name
                 (lambda (stx ctx)
                   (define-conventions honu-conventions conventions ...)
                   #;
                   (debug "Hello from ~a transformer. Syntax is ~a\n" 'name (syntax->datum stx))
                   (syntax-parse stx
                                 #:literals (honu-literal ...)
                                 #:conventions (honu-conventions)
                                 [(name raw-patterns ... . rrest)
                                  (values
                                    #'(honu-unparsed-block
                                        #f obj 'obj #f ctx
                                        fixed-template ...)
                                    #'rrest)])))))
           #'rest))])
    ))

(define-for-syntax (delimiter? x)
  (or (free-identifier=? x #'\;)))

(define-syntax (my-ellipses stx) (raise-syntax-error 'my-ellipses "dont use this"))
;; (define-syntax (wrapped stx) (raise-syntax-error 'wrapped "dont use wrap"))
;; just a phase 0 identifier
(define wrapped #f)
(define unwrap #f)

(define-for-syntax (pull stx)
  (define (reverse-syntax stx)
    (with-syntax ([(x ...) (reverse (syntax->list stx))])
      #'(x ...)))
  (define-syntax-class stop-class
    (pattern x:id #:when (or (free-identifier=? #'x #'(... ...))
                             (free-identifier=? #'x #'\;))))
  (define (do-ellipses stx)
    (let loop ([ellipses '()]
               [body '()]
               [stx stx])
      (cond
        [(null? stx) (values (with-syntax ([(ellipses ...) ellipses]
                                           [(body ...) body])
                               #'(ellipses ... body ...))
                             stx)]
        [(and (identifier? (car stx))
              (free-identifier=? (car stx) #'(... ...)))
         (loop (cons #'(... ...) ellipses) body (cdr stx))]
        [(and (identifier? (car stx))
              (free-identifier=? (car stx) #'\;))
         ;; (printf "Found a ; in ~a\n" (syntax->datum stx))
         (with-syntax ([all (cdr stx)])
           ;; (printf "Found a ; -- ~a\n" (syntax->datum #'all))
           (syntax-parse #'all
                         [((~and x (~not _:stop-class)) ... stop:stop-class y ...)
                          (with-syntax ([(ellipses ...) ellipses]
                                        [(x* ...) (reverse-syntax #'(x ...))])
                            (values #'(ellipses ... (wrapped x* ... \;) unwrap)
                                    #'(stop y ...)))]
                         [else (with-syntax ([(f ...) (reverse-syntax #'all)]
                                             [(ellipses ...) ellipses])
                                 (values #'(ellipses ... (wrapped f ... \;) unwrap)
                                         #'()))]))])))
  (let loop ([all '()]
             [stx (reverse (syntax->list stx))])
    (if (null? stx)
        (with-syntax ([x all])
          #'x)
        (let ([head (car stx)]
              [tail (cdr stx)])
          (cond
            [(and (identifier? head)
                  (free-identifier=? head #'(... ...)))
             (let-values ([(wrapped rest) (do-ellipses (cons head tail))])
               (loop (cons (reverse-syntax wrapped) all) (syntax->list rest)))]
            [else (loop (cons head all) tail)])))))

;; rename this to wrap
#;
(define-for-syntax (pull stx)
  (define (reverse-syntax stx)
    (with-syntax ([(x ...) (reverse (syntax->list stx))])
      #'(x ...)))
  (define-syntax-class delimiter-class
    (pattern x:id #:when (delimiter? #'x)))
  (define-syntax-class ellipses-class
                       (pattern x:id #:when (free-identifier=? #'x #'(... ...))))
  (define-syntax-class not-ellipses-class
                       (pattern x:id #:when (not (free-identifier=? #'x #'(... ...)))))
  ;; use this if you are defining your own ellipses identifier
  #;
  (define-syntax-class ellipses-class
                       #:literals (...)
                       (pattern my-ellipses))
  (if (not (stx-pair? stx))
    stx
    (let ([stx (reverse (syntax->list stx))])
      ;; (debug-parse stx (ellipses1:ellipses-class ellipses:ellipses-class ... x ...))
      ;; (printf "stx is ~a\n" stx)
      ;; (printf "... = ~a\n" (free-identifier=? #'(... ...) (stx-car stx)))
      (syntax-parse stx
        [(before:not-ellipses-class ... ellipses1:ellipses-class ellipses:ellipses-class ... delimiter:delimiter-class x ...)
         (with-syntax ([(x* ...) (reverse-syntax (pull #'(delimiter x ...)))])
           (reverse-syntax
             (with-syntax ([wrapped #'wrapped]
                           [original
                            (with-syntax ([(ellipses* ...) (map (lambda (_)
                                                            #'((... ...) (... ...)))
                                                          (syntax->list #'(ellipses1 ellipses ...)))]
                                          [(x-new ...) (generate-temporaries #'(delimiter x ...))])
                              (reverse-syntax #'(before ... ellipses* ... x-new ...)))]
                           #;
                           [original (syntax->datum (reverse-syntax #'(ellipses1 ellipses ... x ...)))])
               #'(ellipses1 ellipses ... (wrapped x* ...) unwrap))))]
        [(ellipses1:ellipses-class ellipses:ellipses-class ... x ...)
         (with-syntax ([(x* ...) (reverse-syntax (pull #'(x ...)))])
           (reverse-syntax
             (with-syntax ([wrapped #'wrapped]
                           [original
                            (with-syntax ([(ellipses* ...) (map (lambda (_)
                                                            #'((... ...) (... ...)))
                                                          (syntax->list #'(ellipses1 ellipses ...)))]
                                          [(x-new ...) (generate-temporaries #'(x ...))])
                              (reverse-syntax #'(ellipses* ... x-new ...)))]
                           #;
                           [original (syntax->datum (reverse-syntax #'(ellipses1 ellipses ... x ...)))])
               #'(ellipses1 ellipses ... (wrapped x* ...) unwrap))))]
        [(x ...) (with-syntax ([(x* ...) (map pull (syntax->list #'(x ...)))])
                   (reverse-syntax #'(x* ...)))]))))

;; (begin-for-syntax (trace pull))

(define-for-syntax (unpull stx)
  (define-syntax-class ellipses-class
    (pattern x:id #:when (free-identifier=? #'x #'(... ...))))
  (define-syntax-class delimiter-class
    (pattern x:id #:when (delimiter? #'x)))
  ;; (printf "unpull ~a\n" (syntax->datum stx))
  (syntax-parse stx
                #:literals (wrapped unwrap)
                [((~and z (~not (unwrap _ ...))) ... (unwrap (wrapped x ... delimiter:delimiter-class) ...) rest ...)
                 (with-syntax ([(x1 ...) (apply append (map syntax->list (syntax->list #'((x ... delimiter) ...))))]
                               [(rest* ...) (unpull #'(rest ...))])
                 #'(z ... x1 ... rest* ...))]
                [(unwrap (wrapped x ... delimiter:delimiter-class) ...)
                 (with-syntax ([(x1 ...) (apply append (map syntax->list (syntax->list #'((x ... delimiter) ...))))])
                 #'(x1 ...))]
                [(unwrap (wrapped x ... y) ...)
                 (with-syntax ([(x1 ...) (car (syntax->list #'((x ...) ...)))])
                   (with-syntax ([(x1* ...) (map unpull (syntax->list #'(x1 ...)))]
                                 [(y* ...) (map unpull (syntax->list #'(y ...)))])
                     #'(x1* ... y* ...)))]
                [(unwrap . x) (raise-syntax-error 'unpull "unhandled unwrap ~a" stx)]
                [(x ...) (with-syntax ([(x* ...) (map unpull (syntax->list #'(x ...)))])
                           #'(x* ...))]
                [else stx]))

;; rename this to unwrap
#;
(define-syntax (unpull stx)
  (define-syntax-class ellipses-class
                       (pattern x:id #:when (free-identifier=? #'x #'(... ...))))
  (define (do-it stx)
    (syntax-parse stx
      #:literals (wrapped)
      [((wrapped x ... y) ...)
       (with-syntax ([(x1 ...) (car (syntax->list #'((x ...) ...)))])
         #'(x1 ... y ...))]
      [((wrapped x ...) ellipses1:ellipses-class ellipses:ellipses-class ...)
       (with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))])
         #'(x* ...  ellipses1 ellipses ...))]
      [(x ...) (with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))])
                 #'(x* ...))]
      [else stx]))
  (syntax-case stx ()
    [(_ x ...) (do-it #'(x ...))]))

;; (provide unpull)
#;
(define-honu-syntax unpull
  (lambda (stx ctx)
    (define-syntax-class ellipses-class
      (pattern x:id #:when (free-identifier=? #'x #'(... ...))))
    (define (do-it stx)
      (syntax-parse stx
                    #:literals (wrapped)
                    [((wrapped x ... y) ...)
                     (with-syntax ([(x1 ...) (car (syntax->list #'((x ...) ...)))])
                       #'(x1 ... y ...))]
                    [((wrapped x ...) ellipses1:ellipses-class ellipses:ellipses-class ...)
                     (with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))])
                       #'(x* ...  ellipses1 ellipses ...))]
                    [(x ...) (with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))])
                               (printf "x* is ~a\n" #'(x* ...))
                               #'(x* ...))]
                    [else stx]))
    (syntax-case stx ()
      [(_ x ...) (values (do-it #'(x ...))
                         #'())])))
 
#;
(define-syntax (test stx)
  (syntax-case stx ()
    [(_ x ...)
     (begin
       (pretty-print (syntax->datum (pull #'(x ...))))
       (pretty-print (syntax->datum (unpull (pull #'(x ...)))))
       #'1)]))

(define-syntax (my-syntax stx)
  (syntax-case stx ()
    [(_ name pattern template)
     (with-syntax ([wrap-it (pull #'template)])
       #'(define-syntax (name stx)
           (syntax-case stx ()
             [pattern #'wrap-it]
             [else (raise-syntax-error 'name (format "~a does not match pattern ~a"
                                                     (syntax->datum stx)
                                                     'pattern))]
             )))]))

(define-syntax (test2 stx)
  (syntax-case stx ()
    [(_ x ...)
     (begin
       (with-syntax ([pulled (pull #'(x ...))])
         #'(unpull pulled)))]))

(define-honu-syntax honu-macro
  (lambda (stx ctx)
    (syntax-case stx (#%parens #%braces)
      [(_ (#%parens honu-literal ...)
          (#%braces (#%braces name pattern ...))
          (#%braces (#%braces template ...))
          . rest)
       (with-syntax ([pulled (pull #'(template ...))]
                     [(pattern* ...) (map (lambda (stx)
                                            (if (and (identifier? stx)
                                                     (not (ormap (lambda (f)
                                                                   (free-identifier=? stx f))
                                                                 (syntax->list #'(honu-literal ...))))
                                                     (not (free-identifier=? stx #'(... ...))))
                                                (with-syntax ([x stx])
                                                  #'(~and x (~not (~or honu-literal ...))))
                                                stx))
                                          (syntax->list #'(pattern ...)))]
                     )
         (values
          #'(define-honu-syntax name
              (lambda (stx ctx)
                ;; (define-literal-set literals (honu-literal ...))
                (syntax-parse stx
                              ;; #:literal-sets (literals)
                              #:literals (honu-literal ...)
                  [(name pattern* ... . rrest)
                   (with-syntax ([(out (... ...)) (unpull #'pulled)])
                     (define (X) (raise-syntax-error (syntax->datum #'name) "implement for this context"))
                     (values
                      ;; this is sort of ugly, is there a better way?
                      (cond
                        [(type-context? ctx) (X)]
                        [(type-or-expression-context? ctx) (X)]
                        [(expression-context? ctx) #'(honu-unparsed-expr out (... ...))]
                        [(expression-block-context? ctx)
                         #'(honu-unparsed-begin out (... ...))]
                        [(block-context? ctx)
                         #'(honu-unparsed-begin out (... ...))]
                        [(variable-definition-context? ctx) (X)]
                        [(constant-definition-context? ctx) (X)]
                        [(function-definition-context? ctx) (X)]
                        [(prototype-context? ctx) (X)]
                        [else #'(honu-unparsed-expr out (... ...))])
                      #;
                      #'(honu-unparsed-begin out (... ...))
                      #'rrest)
                     #;
                     #'(honu-unparsed-block
                        #f obj 'obj #f ctx
                        out (... ...))
                     #;
                     (values
                      #;
                      #'(honu-unparsed-expr out (... ...))
                      #'(honu-unparsed-block
                         #f obj 'obj #f ctx
                         out (... ...) rrest)
                      #;
                      #'rrest))])))
          #'rest))])))

;; (my-syntax guz (_ display (#%parens x ...)) (+ x ...))
;; (guz display (#%parens 1 2 3 4))

;; (local-expand stx 'expression (list #'wrapped))

#|
(begin-for-syntax
  (trace pull))
(test display (#%parens x))
(test display (#%parens x ... ...) ...)
|#