#lang racket/base
;; For legal info, see file "info.rkt".

;; TODO: !!! IMPLEMENT #:ordering AGAIN

;; TODO: !!! ADD #:eval-before-write? WHICH WORKS WITH ALL #:ordering EXCEPT writes-and-evaluation

;; TODO: !!! MAYBE RENAME #:ordering TO #:eval-ordering OR #:eval-order

(require (for-syntax racket/base
                     "html-template-generate-helpers.rkt"
                     "planet-neil-html-writing.rkt")
         (for-template racket/base
                       "html-template-generate-helpers.rkt"
                       "planet-neil-html-writing.rkt")
         "html-template-generate-helpers.rkt"
         "planet-neil-html-writing.rkt")

;;---------------- Irep Compression

;; TODO: POSSIBLY USE THIS FOR "*verbatim*".
;;
;; (let loop-verbatim ((item-args          (cdr (cdr item)))
;;                                              (reverse-bytes-list '()))
;;                            (if (null? item-args)
;;                                (apply bytes-append (reverse reverse-bytes-list))
;;                                (let ((item-arg (syntax-e (car item-args))))
;;                                  (cond ((bytes? item-arg)
;;                                         (loop-verbatim (cdr item-args)
;;                                                        (cons item-arg
;;                                                              reverse-bytes-list)))
;;                                        ((string? item-arg)
;;                                         (loop-verbatim (cdr item-args)
;;                                                        (cons (string->bytes/utf-8 item-arg)
;;                                                              reverse-bytes-list)))
;;                                        (else item)))))

(provide compress-html-template-irep)
(define (compress-html-template-irep irep)
  ;; (log-debug (format "*DEBUG* compress-html-template-irep: ENTERING irep = ~S" irep))
  (let loop ((irep            irep)
             (reverse-byteses '())
             (reverse-result  '()))
    (if (null? irep)
        (begin
          ;; (log-debug (format "*DEBUG* compress-html-template-irep: ABOUT-TO-EXIT reverse-byteses = ~S reverse-result = ~S"
          ;;                    reverse-byteses
          ;;                    reverse-result))
          (if (null? reverse-byteses)
              (reverse reverse-result)
              (reverse (cons (apply bytes-append (reverse reverse-byteses))
                             reverse-result))))
        (let* ((item (car irep))
               (item (if (and (pair? item)
                              (eq? 'verbatim (car item)))
                         (let ((item-args (cdr (cdr item))))
                           (if (and (not (null? item-args))
                                    (null? (cdr item-args)))
                               (let* ((first-arg-stx (car item-args))
                                      (first-arg-e   (syntax-e first-arg-stx)))
                                 (cond ((bytes?  first-arg-e) first-arg-e)
                                       ((string? first-arg-e) (string->bytes/utf-8 first-arg-e))
                                       (else                  item)))
                               item))
                         item)))
          (if (bytes? item)
              (loop (cdr irep)
                    (cons item reverse-byteses)
                    reverse-result)
              (loop (cdr irep)
                    '()
                    (cons item
                          (if (null? reverse-byteses)
                              reverse-result
                              ;; TODO: !!! WE ARE FIXING THIS cons...
                              (cons (apply bytes-append (reverse reverse-byteses))
                                    reverse-result)))))))))

;;------ Generic Racket Syntax Utils

(provide %html-template:begin-stx)
(define (%html-template:begin-stx ctxt body-stxes)
  (cond ((null? body-stxes)       (quasisyntax/loc ctxt
                                    (void)))
        ((not (list? body-stxes)) (raise-type-error '%html-template:begin-stx
                                                    "list"
                                                    1
                                                    (list ctxt body-stxes)))
        ((null? (cdr body-stxes)) (car body-stxes))
        (else                     (quasisyntax/loc ctxt
                                    (begin #,@body-stxes)))))

(provide %html-template:reverse-lvs-and-body-stxes->stx)
(define (%html-template:reverse-lvs-and-body-stxes->stx ctxt reverse-lvs body-stxes)
  (if (null? reverse-lvs)
      (%html-template:begin-stx ctxt body-stxes)
      (quasisyntax/loc ctxt
        (let-values (#,@(reverse reverse-lvs))
          #,@(cond ((null? body-stxes)       (list (quasisyntax/loc ctxt
                                                     (void))))
                   ((not (list? body-stxes)) (raise-type-error '%html-template:reverse-lvs-and-body-stxes->stxes
                                                               "list"
                                                               2
                                                               (list ctxt reverse-lvs body-stxes)))
                   ((null? (cdr body-stxes)) (list (car body-stxes)))
                   (else                     body-stxes))))))

;;---- Expand

(provide expand-html-template)
(define (expand-html-template #:error-name  error-name
                              #:stx         stx
                              #:ordering    ordering
                              #:reverse-lvs reverse-lvs
                              #:irep        irep
                              #:port-stx    port-stx)
  ;; (log-debug (format "*DEBUG* expand-html-template #:error-name ~S #:stx ~S #:ordering ~S #:reverse-lvs ~S #:irep ~S #:port-stx ~S"
  ;;                    error-name
  ;;                    stx
  ;;                    ordering
  ;;                    reverse-lvs
  ;;                    irep
  ;;                    port-stx))
  (let*-values (((reverse-lvs port-var-stx)
                 (if (identifier? port-stx)
                     (values reverse-lvs port-stx)
                     (let ((out-var-stx (quasisyntax/loc stx
                                          out)))
                       (values (cons (quasisyntax/loc stx
                                       ((#,out-var-stx) #,port-stx))
                                     reverse-lvs)
                               out-var-stx))))
                ((write-stxes)
                 (html-template-irep->write-stxes error-name
                                                  stx
                                                  port-var-stx
                                                  irep)))
    (%html-template:reverse-lvs-and-body-stxes->stx
     stx
     reverse-lvs
     (list (quasisyntax/loc stx
             ;; TODO: Don't do this parameterize if we're completely static.
             (parameterize ((current-output-port html-template-error-catching-output-port))
               #,@write-stxes))))))

(provide html-template-irep->write-stxes)
(define (html-template-irep->write-stxes error-name entire-stx port-var-stx irep)
  (let loop ((irep       irep)
             (need-void? #t))
    (if (null? irep)
        (if need-void?
            (cons (quasisyntax/loc entire-stx
                    (void))
                  '())
            '())
        (let ((item (car irep)))
          ;; TODO: !!! error-check arguments for each form
          (if (bytes? item)
              (cons (if (equal? #" " item)
                        (quasisyntax/loc entire-stx
                          (write-char #\space #,port-var-stx))
                        (quasisyntax/loc entire-stx
                          (write-bytes #,item #,port-var-stx)))
                    (loop (cdr irep) #t))
              (apply (lambda (item-opcode item-stx . item-args)
                       (case item-opcode
                         ((format/attribute-value)
                          (cons (quasisyntax/loc item-stx
                                  (%html-template:format/attribute-value/write
                                   #,(%html-template:begin-stx item-stx item-args)
                                   #,port-var-stx))
                                (loop (cdr irep) #t)))
                         ((format/content)
                          (cons (quasisyntax/loc item-stx
                                  (%html-template:format/content/write
                                   #,(%html-template:begin-stx item-stx item-args)
                                   #,port-var-stx))
                                (loop (cdr irep) #t)))
                         ((verbatim)
                          (cons (quasisyntax/loc item-stx
                                  (%html-template:write-verbatim
                                   #,(%html-template:begin-stx item-stx item-args)
                                   #,port-var-stx))
                                (loop (cdr irep) #t)))
                         ((void)
                          (append item-args (loop (cdr irep) #t)))
                         ((write)
                          (cons (quasisyntax/loc item-stx
                                  (parameterize ((current-output-port #,port-var-stx))
                                    #,@item-args))
                                (loop (cdr irep) #t)))
                         ((write/port)
                          (cons (apply (lambda (local-var-stx . body-stxes)
                                         (or (identifier? local-var-stx)
                                             (raise-syntax-error error-name
                                                                 "expected identifier"
                                                                 local-var-stx))
                                         (quasisyntax/loc item-stx
                                           (let ((#,local-var-stx #,port-var-stx))
                                             #,@body-stxes)))
                                       item-args)
                                (loop (cdr irep) #t)))
                         ((xexp/attributes)
                          (cons (quasisyntax/loc item-stx
                                  (write-html-attributes #,(%html-template:begin-stx item-stx item-args)
                                                         #,port-var-stx))
                                (loop (cdr irep) #t)))
                         ((xexp/attribute-value)
                          (cons (quasisyntax/loc item-stx
                                  (write-html-attribute-value-part #,(%html-template:begin-stx item-stx item-args)
                                                                   #,port-var-stx))
                                (loop (cdr irep) #t)))
                         ((xexp/content)
                          (cons (quasisyntax/loc item-stx
                                  (write-html #,(%html-template:begin-stx item-stx item-args)
                                              #,port-var-stx))
                                (loop (cdr irep) #t)))
                         (else (error 'html-template-irep->write-stx-list
                                      "invalid opcode: ~S"
                                      item-opcode))))
                     item))))))

;;(provide html-template-irep->bytes-list-stx-list)
;;(define (html-template-irep->bytes-list-stx-list error-name entire-stx irep)
;;  ;; TODO: !!! NESTED "html-bytes" IN OUR PLAY EXAMPLE DOESN'T USE DEFAULT OUTPUT PORT PROPERLY
;;  (let loop ((irep irep))
;;    (if (null? irep)
;;        '()
;;        (let ((item (car irep)))
;;          ;; TODO: !!! error-check arguments for each form
;;          (if (bytes? item)
;;              (cons (quasisyntax/loc entire-stx
;;                      #,item)
;;                    (loop (cdr irep)))
;;              (apply (lambda (item-opcode item-stx . item-args)
;;                       (case item-opcode
;;                         ((format/attribute-value)
;;                          (cons (quasisyntax/loc item-stx
;;                                  (%html-template:format/attribute-value/bytes
;;                                   #,(%html-template:begin-stx item-stx item-args)))
;;                                (loop (cdr irep))))
;;                         ((format/content)
;;                          (cons (quasisyntax/loc item-stx
;;                                  (%html-template:format/content/bytes
;;                                   #,(%html-template:begin-stx item-stx item-args)))
;;                                (loop (cdr irep))))
;;                         ((verbatim)
;;                          (cons (quasisyntax/loc item-stx
;;                                  (%html-template:verbatim->bytes
;;                                   #,@item-args))
;;                                (loop (cdr irep))))
;;                         ((void)
;;                          (append item-args (loop (cdr irep))))
;;                         ((write)
;;                          (cons (quasisyntax/loc item-stx
;;                                  (let ((out (open-output-bytes)))
;;                                    (parameterize ((current-output-port out))
;;                                      #,@item-args
;;                                      (get-output-bytes out))))
;;                                (loop (cdr irep))))
;;                         ((write/port)
;;                          (cons (apply (lambda (local-var-stx . body-stxes)
;;                                         (or (identifier? local-var-stx)
;;                                             (raise-syntax-error error-name
;;                                                                 "expected identifier"
;;                                                                 local-var-stx))
;;                                         (quasisyntax/loc item-stx
;;                                           (let ((#,local-var-stx (open-output-bytes)))
;;                                             #,@body-stxes
;;                                             (get-output-bytes #,local-var-stx))))
;;                                       item-args)
;;                                (loop (cdr irep))))
;;                         ;; TODO: Handle xexp/attributes
;;                         ((xexp/attribute-value)
;;                          (cons #''!!!xexp/attribute-value!!!
;;                                (loop (cdr irep))))
;;                         ((xexp/content)
;;                          (cons (quasisyntax/loc item-stx
;;                                  (html->bytes #,(%html-template:begin-stx item-stx item-args)))
;;                                (loop (cdr irep))))
;;                         (else (error '%html-template:flat->bytes-stx-list
;;                                      "invalid opcode: ~S"
;;                                      item-opcode))))
;;                     item))))))