(module html-widgets (widgets define-widget widget->sxml-and-css widget->sxml)

(import (chicken base) (chicken string) scheme sxml-transforms matchable scss simple-md5 srfi-1 srfi-69)
(import-for-syntax matchable)


(define widgets (make-parameter '()))

;; example:
;; (define-widget blue-button (((name "") (color "blue")) contents)
;;   `(button (@ (name ,name) (style ((width "100px") (color ,color))))
;;            ,@(map (lambda (x) `(span ,x)) contents)))
;;
;; expands to:
;; (begin
;;   (widgets
;;     (filter (lambda (widget) (not (eq? (car widget) 'blue-button))) (widgets)))
;;   (widgets
;;     (cons (cons 'blue-button
;;                 (cons '*macro*
;;                       (lambda (tag body)
;;                         (match body
;;                                ((('@ attrs ...) content ...)
;;                                 (let ((name (car (alist-ref 'name attrs eqv? (list ""))))
;;                                       (color (car (alist-ref 'color attrs eqv? (list "blue"))))
;;                                       (contents content))
;;                                   `(button
;;                                      (@ (name ,name)
;;                                         (style ((width "100px") (color ,color))))
;;                                      ,@(map (lambda (x) `(span ,x)) contents))))
;;                                ((content ...)
;;                                 (let ((contents content))
;;                                   `(button
;;                                      (@ (name ,name)
;;                                         (style ((width "100px") (color ,color))))
;;                                      ,@(map (lambda (x) `(span ,x)) contents))))))))
;;           (widgets))))
(define-syntax define-widget
  (ir-macro-transformer
   (match-lambda*
     (((_ (widget-name (widget-named-args ...) . widget-contents-arg-list) widget-body ...) i c)
      (let ((widget-contents-arg (and (not (null? widget-contents-arg-list)) (car widget-contents-arg-list))))
        `(begin
           (widgets (filter (lambda (widget) (not (eq? (car widget) ',widget-name))) (widgets)))
           (widgets
            (cons
             (cons
              ',widget-name
              (cons ',(i '*macro*)
                    (lambda (tag body)
                      (match
                          body
                        ((('@ attrs ...) content ...)
                         (let (,@(map (lambda (arg)
                                        `(,(car arg) (car (alist-ref ',(car arg) attrs eqv? (list ,(cadr arg))))))
                                      widget-named-args)
                               ,@(if widget-contents-arg `((,widget-contents-arg content)) '()))
                           ,@widget-body))
                        ((content ...)
                         (let (,@(map (lambda (arg)
                                        `(,(car arg) ,(cadr arg)))
                                      widget-named-args)
                               ,@(if widget-contents-arg `((,widget-contents-arg content)) '()))
                           ,@widget-body))))))
             (widgets))))))
     (((_ (widget-name) widget-body ...) i c)
      `(define-widget (,widget-name ()) ,@widget-body))
     ((x i c)
      (error 'define-widget "Invalid define-widget form. Use: (define-widget (widget-name ((arg1 arg1-default) (arg2 arg2-default) ...) contents) body)")))))

(define (styles->scss class sxml)
  (let* ((query-rules '())
         (filter-rules
          `((*text* . ,(lambda (tag str) str))
			(*default* . ,cons)
			(*TOP* . ,(lambda (tag str) str))
            (@container *preorder* . ,(lambda args
                                      (let ((query (caadr args))
                                            (rules (cdadr args)))
                                        (set! query-rules (cons
                                                           `(@container ,query
                                                                       ,@rules)
                                                           query-rules))
                                        'ignore)))
            (@media *preorder* . ,(lambda args
                                      (let ((query (caadr args))
                                            (rules (cdadr args)))
                                        (set! query-rules (cons
                                                           `(@media ,query
                                                                       ,@rules)
                                                           query-rules))
                                        'ignore))))))
    (let* ((style-rules
            `((*text* . ,(lambda (tag str) str))
			  (*default* . ,cons)
			  (*TOP* . ,(lambda (tag str) str))
              (@container *macro* . ,(lambda args
                                       (let ((query (caadr args))
                                             (rules (cdadr args)))
                                         `(container ,query
                                                     (,class ,@rules)))))
              (@media *macro* . ,(lambda args
                                   (let ((query (caadr args))
                                         (rules (cdadr args)))
                                     `(media ,query
                                             (,class ,@rules))))))))
      (let ((root-scss (pre-post-order* sxml filter-rules)))
        `(css
          (,class ,@(filter (lambda (x) (not (eq? x 'ignore))) root-scss))
          ,@(pre-post-order* query-rules style-rules))))))

(define (widget->sxml-and-css sxml)
  (let* ((styles (make-hash-table #:test string=?))
         (widget-rules
          `((*text* . ,(lambda (tag str) str))
			(*default* . ,cons)
			(*TOP* . ,(lambda (tag str) str))
            (@
             ((style . ,(lambda (x value)
                          (let ((hashed (string->md5sum (->string (car value)))))
                            (when (not (hash-table-exists? styles hashed))
                              (hash-table-set! styles hashed (scss->css (styles->scss (string->symbol (conc ".x" hashed)) (car value)))))
                            (list 'class (conc "x" hashed))))) ;; css classes can't start with a number
              (*default*
               . ,(lambda (attr-key . value) `(,attr-key ,@(car value)))))
             . ,(lambda (trigger . value) (cons '@ (car value))))
            ,@(widgets))))
    (values (pre-post-order* sxml widget-rules)
            (hash-table-values styles))))

;; Does not transform the style tag to CSS classes
;; Probably only useful for testing?
(define (widget->sxml sxml)
  (pre-post-order*
   sxml
   `((*text* . ,(lambda (tag str) str))
	 (*default* . ,cons)
	 (*TOP* . ,(lambda (tag str) str))
     ,@(widgets))))
)