tjhintz/html-widgets
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Initial commit.

Browse Source
This commit is contained in:
Thomas Hintz
2026-01-20 06:20:35 -08:00
commit 785d307d59
4 changed files with 251 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

140
html-widgets.scm Normal file
View File

@@ -0,0 +1,140 @@
(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))))
)