You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
141 lines
6.7 KiB
Scheme
141 lines
6.7 KiB
Scheme
(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))))
|
|
)
|