#lang racket/base

(require "honu-typed-scheme.rkt"
         "literals.rkt"
         syntax/parse
         mzlib/trace
         "syntax.rkt"
         (for-syntax syntax/parse
                     syntax/stx
                     racket/list
                     racket/base
                     "debug.rkt"
                     "contexts.rkt"
                     "syntax.rkt"
                     (only-in racket (... scheme-ellipses))
                     "literals.rkt")
         (for-template "honu-typed-scheme.rkt"
                       "literals.rkt"
                       "syntax.rkt"
                       (only-in racket ...)
                       ))

(provide (all-defined-out))

(define (combine-syntax lexical . all)
  (define consed (for/fold ([item all])
                           ([out '()])
                           (cons item out)))
  (datum->syntax lexical consed lexical))

(define (replace-commas stuff)
  ;; (debug "Replace commas with: ~a\n" (syntax->datum stuff))
  (syntax-parse stuff #:literals (ellipses-comma ellipses-comma*)
    [((ellipses-comma* z ...) thing blah ...)
     #;
     (debug "Thing ~a and blah ~a replaced ~a\n" #'thing #'(blah ...) (replace-commas #'(thing blah ...)))
     (with-syntax ([(rest ...) (replace-commas #'(thing blah ...))])
       (datum->syntax stuff
                      #'(z ... honu-comma rest ...)
                      ;; `(1 ,#'(z ...) ,#'honu-comma ,#'(rest ...))
                      #;
                      (append (syntax->list #'(z ...)) (cons #'honu-comma #'(rest ...)))
                      stuff
                      stuff)
       #;
       #'(z honu-comma rest ...))]
    [((ellipses-comma z) thing blah ...)
     #;
     (debug "Thing ~a and blah ~a replaced ~a\n" #'thing #'(blah ...) (replace-commas #'(thing blah ...)))
     (with-syntax ([(rest ...) (replace-commas #'(thing blah ...))])
       #;
       (combine-syntax stuff #'z #'honu-comma #'(rest ...))
       (datum->syntax stuff (cons #'z (cons #'honu-comma #'(rest ...)))
                      stuff
                      stuff)
       #;
       #'(z honu-comma rest ...))]
    [(front (ellipses-comma* z ...) thing more ...)
     (with-syntax ([front* (replace-commas #'front)]
                   [(rest* ...) (replace-commas #'(thing more ...))])
       (datum->syntax stuff #'(front z ... honu-comma rest* ...) stuff stuff)
       #;
       (datum->syntax stuff (cons #'front* (cons #'(z ...) (cons #'honu-comma #'(rest* ...))))
                      stuff
                      stuff))]
    [(front (ellipses-comma z) thing more ...)
     (define (maybe-apply-raw stx)
       (syntax-parse stuff #:literals (ellipses-comma)
                     [(front (ellipses-comma x) . rest)
                      (if (raw-scheme? #'x)
                        (apply-scheme-syntax stx)
                        stx)]))
     (with-syntax ([front* (replace-commas #'front)]
                   [(rest* ...) (replace-commas #'(thing more ...))])
       (datum->syntax stuff (cons #'front* (cons #'z (cons #'honu-comma #'(rest* ...))))
                      stuff
                      stuff))]
    #;
    [(front (ellipses-comma (z ...)) thing more ...)
     (define (maybe-apply-raw stx)
       (syntax-parse stuff #:literals (ellipses-comma)
                     [(front (ellipses-comma x) . rest)
                      (if (raw-scheme? #'x)
                        (apply-scheme-syntax stx)
                        stx)]))
     (with-syntax ([front* (replace-commas #'front)]
                   [(rest* ...) (replace-commas #'(thing more ...))])
       (datum->syntax stuff (cons #'front*
                                  (cons (datum->syntax stuff #'(z ...) stuff stuff)
                                        (cons #'honu-comma #'(rest* ...))))
                      stuff
                      stuff))]
    #;
    [((ellipses-comma (z ...))) (datum->syntax stuff #'(z ...) stuff stuff)]
    [((ellipses-comma* z ...)) (datum->syntax stuff #'(z ...) stuff stuff)]
    [((ellipses-comma z)) (datum->syntax stuff #'(z) stuff stuff)]
    [(z rest ...)
     (with-syntax ([z* (replace-commas #'z)]
                   [(rest* ...) (replace-commas #'(rest ...))])
       #;
       (combine-syntax stuff #'z #'(rest* ...))
       (datum->syntax stuff
                      (cons #'z* #'(rest* ...))
                      stuff stuff)
       #;
       #'(z* rest* ...))]
    [else stuff]))

;; (trace replace-commas)

(define-syntax (fix-template stuff)
  (define (fix stuff)
    (debug "Macro fix template for ~a\n" (syntax->datum stuff))
    (syntax-parse stuff #:literals (ellipses-comma)
      [(any ellipses-comma rest ...)
       (define (addit item)
         (with-syntax ([i item])
           #'(i honu-comma)))
       (define (remove-last list)
         (take list (sub1 (length list))))
       (define (add-commas stuff)
         (remove-last (apply append (map syntax->list (map addit (syntax->list stuff))))))
       (with-syntax ([(any* ...) (add-commas #'any)]
                     [(rest* ...) (fix #'(rest ...))])
         #'(any* ... rest* ...))]
      [(one rest ...)
       (with-syntax ([one* (fix #'one)]
                     [(rest* ...) (fix #'(rest ...))])
         (datum->syntax stuff (cons #'one*
                                    #'(rest* ...))
                        stuff stuff)
         #;
         #'(one* rest* ...))]
      [else stuff]))
  (define (replace2 stuff)
    (syntax-parse stuff #:literals (ellipses-comma ellipses-repeat #%parens)
      [(ellipses-repeat (#%parens ellipses-comma things-to-repeat ...) rest ...)
       (with-syntax ([(rest* ...) (replace #'(rest ...))])
         (datum->syntax stuff
                        (cons
                          (cons #'ellipses-comma* #'(things-to-repeat ...))
                          (cons
                            #'(... ...)
                            #'(rest* ...)))
                        stuff stuff))
         #;
         #'((ellipses-comma a*) (... ...) rest* ...)]
      [(a ellipses-comma rest ...)
       (with-syntax ([a* (replace #'a)]
                     [(rest* ...) (replace #'(rest ...))])
         (datum->syntax stuff
                        (cons
                          (cons #'ellipses-comma (cons #'a* '()))
                          (cons
                            #'(... ...)
                            #'(rest* ...)))
                        stuff stuff)
         #;
         #'((ellipses-comma a*) (... ...) rest* ...))]
      [(z rest ...)
       (with-syntax ([z* (replace #'z)]
                     [(rest* ...) (replace #'(rest ...))])
         (datum->syntax stuff
                        (cons #'z* #'(rest* ...))
                        stuff stuff)
         #;
         #'(z* rest* ...))]
      [else stuff]))

  (define (replace stuff)
    #|
    (debug "Replacing ~a\n" (syntax->datum stuff))
    (debug "Local phase level ~a\n" (syntax-local-phase-level))
    (debug "Checking..\n")
    (syntax-parse stuff
      [(a b c rest ...)
       (debug "a: ~a\n" #'a)
       (debug "b: ~a identifier ~a = , is ~a. honu-comma at ~a\n" #'b (identifier? #'b) (and (identifier? #'b) (free-identifier=? #'b #'honu-comma)) (identifier-binding #'honu-comma))
       (debug "c: ~a = ... is ~a\n" #'c (and (identifier? #'c) (free-identifier=? #'c #'(... ...))))]
      [else (void)])
    |#
    (syntax-parse stuff
      #:literals (;; honu-comma
                  ;; FIXME! Use a literal-set and #:at instead of this
                  [honu-comma honu-comma #:phase (sub1 (syntax-local-phase-level))]
                  [ellipses ...] ellipses-comma ellipses-repeat #%parens)
      [(a honu-comma ellipses rest ...)
       (with-syntax ([a* (replace #'a)]
                     [(rest* ...) (replace #'(rest ...))])
         (datum->syntax stuff
                        (cons
                          (cons #'ellipses-comma (cons #'a* '()))
                          (cons
                            #'(... ...)
                            #'(rest* ...)))
                        stuff stuff))]
      [(z rest ...)
       (with-syntax ([z* (replace #'z)]
                     [(rest* ...) (replace #'(rest ...))])
         (datum->syntax stuff
                        (cons #'z* #'(rest* ...))
                        stuff stuff))]
      [else stuff]
      ))
  
  (debug "Do fix template for ~a\n" (syntax->datum stuff))
  (syntax-parse stuff
    [(_ blah)
     (let ([replaced (replace #'blah)])
       (debug "Replaced ~a\n" (syntax->datum replaced))
       (with-syntax ([out2 replaced])
         (let ([x #'(apply-scheme-syntax (replace-commas #'out2))])
           (debug "Final syntax ~a\n" (syntax->datum x))
           x)))]
    #;
    [(_ blah ...) (fix #'(blah ...))]))

(define-syntax-rule (honu-syntax-maker maker unparsed)
  (define-honu-syntax maker
    (lambda (stx ctx)
      (syntax-parse stx #:literal-sets ([cruft #:at unparsed])
        [(_ (#%parens expr (... ...)) semicolon . rest)
         (values
           (lambda ()
             (define (show-pattern-variables what)
               (cond
                 [(syntax-pattern-variable? what) (debug "~a is a pattern variable\n") what]
                 [(stx-pair? what) (for-each show-pattern-variables (syntax->list what))]
                 [else (debug "~a is *not* a pattern variable\n" what)]))

             #;
             (debug "Original code is ~a\n" (syntax->datum #'(expr ...)))
             #;
             (debug "Expanded is ~a\n" (syntax->datum (expand-syntax-once #'(expr ...))))
             #;
             (for-each show-pattern-variables (syntax->list #'(expr ...)))
             ;; outer is relative phase 1, inner is relative phase 0
             #|
             #'#'(honu-unparsed-begin expr ...)
             |#

             #;
             (syntax (fix-template (syntax (honu-unparsed-begin expr ...))))

             #;
             (with-syntax ([a #'(fix-template #'(honu-unparsed-begin expr ...))])
               #'a)

             (debug "Making unparsed syntax with `~a'\n" (syntax->datum #'(expr (... ...))))

             #;
             (with-syntax ([unparsed (make-unparsed #'(expr ...))])
               #'(fix-template unparsed))

             #;
             (datum->syntax stx
                            (cons #'fix-template
                                  (cons #'unparsed #'(expr (... ...))))
                            stx stx)

             #;
             (let ([original #'(expr (... ...))])
               (datum->syntax original
                              (cons #'fix-template
                                    (cons #'unparsed #'(expr (... ...))))
                              original original))

             #'(fix-template (unparsed expr (... ...)))

             #;
             #'(fix-template (expr ...))

             #;
             (apply-scheme-syntax #'(fix-template (expr ...)))

             #;
             (let ([x #'(fix-template (honu-unparsed-begin expr ...))])
               (debug "Final syntax ~a\n" (syntax->datum x))
               x)

             #;
             #'(fix-template 1 2 3)

             #;
             (with-syntax ([(out ...) (local-expand #'(expr ...) 'expression '())])
               #'(honu-unparsed-begin out ...)))
           #'rest)]
        [else (raise-syntax-error 'maker "you have used this incorrectly")]
        ))))

(honu-syntax-maker honu-syntax honu-unparsed-begin)
(honu-syntax-maker honu-expression-syntax honu-unparsed-expr)

#;
(define-honu-syntax honu-syntax
  (lambda (stx ctx)
    (syntax-parse stx #:literals (semicolon #%parens)
      [(_ (#%parens expr ...) semicolon . rest)
       (values
         (lambda ()
           (define (show-pattern-variables what)
             (cond
               [(syntax-pattern-variable? what) (debug "~a is a pattern variable\n") what]
               [(stx-pair? what) (for-each show-pattern-variables (syntax->list what))]
               [else (debug "~a is *not* a pattern variable\n" what)]))

           (define (make-unparsed code)
             (debug "Make unparsed in ~a. expression-context? ~a\n" ctx (expression-context? ctx))
             (with-syntax ([(code ...) code])
               (cond
                 [(expression-context? ctx)
                  (syntax/loc stx (honu-unparsed-expr code ...))]
                 [else #'(honu-unparsed-begin code ...)])))

           #;
           (debug "Original code is ~a\n" (syntax->datum #'(expr ...)))
           #;
           (debug "Expanded is ~a\n" (syntax->datum (expand-syntax-once #'(expr ...))))
           #;
           (for-each show-pattern-variables (syntax->list #'(expr ...)))
           ;; outer is relative phase 1, inner is relative phase 0
           #|
           #'#'(honu-unparsed-begin expr ...)
           |#

           #;
           (syntax (fix-template (syntax (honu-unparsed-begin expr ...))))

           #;
           (with-syntax ([a #'(fix-template #'(honu-unparsed-begin expr ...))])
             #'a)

           (debug "Making unparsed syntax???\n")
           (with-syntax ([unparsed (make-unparsed #'(expr ...))])
             #'(fix-template unparsed))
             
           ;; #'(fix-template (honu-unparsed-begin expr ...))

           #;
           #'(fix-template (expr ...))

           #;
           (apply-scheme-syntax #'(fix-template (expr ...)))

           #;
           (let ([x #'(fix-template (honu-unparsed-begin expr ...))])
             (debug "Final syntax ~a\n" (syntax->datum x))
             x)

           #;
           #'(fix-template 1 2 3)

           #;
           (with-syntax ([(out ...) (local-expand #'(expr ...) 'expression '())])
             #'(honu-unparsed-begin out ...)))
         #'rest)])))