commit 785d307d598b939e5b0e4bdac0c7c8c8a4087344 Author: Thomas Hintz Date: Tue Jan 20 06:20:35 2026 -0800 Initial commit. diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..650c248 --- /dev/null +++ b/.gitignore @@ -0,0 +1,9 @@ +*~ + +html-widgets.build.sh +html-widgets.import.scm +html-widgets.import.so +html-widgets.install.sh +html-widgets.link +html-widgets.so +html-widgets.static.o \ No newline at end of file diff --git a/html-widgets.egg b/html-widgets.egg new file mode 100644 index 0000000..8a2b475 --- /dev/null +++ b/html-widgets.egg @@ -0,0 +1,8 @@ +((author "Thomas Hintz") + (synopsis "An SXML based library for creating html widgets") + (license "GPLv3") + (components (extension html-widgets)) + (version "0.1") + (dependencies sxml-transforms matchable scss simple-md5 srfi-1 srfi-69) + (category web) + (test-dependencies test srfi-13)) diff --git a/html-widgets.scm b/html-widgets.scm new file mode 100644 index 0000000..473b59b --- /dev/null +++ b/html-widgets.scm @@ -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)))) +) diff --git a/tests/run.scm b/tests/run.scm new file mode 100644 index 0000000..db50ba2 --- /dev/null +++ b/tests/run.scm @@ -0,0 +1,94 @@ +(cond-expand + (local + (load-relative "../html-widgets.scm") + (import html-widgets)) + (chicken-5 + (import html-widgets))) + +(import test (chicken sort) srfi-13) + +(test "Ensure (widgets) is initialized correctly" (widgets) '()) + +(test-assert "Define a simple widget" + (define-widget (Simple-Button ()) + `(button "A button"))) + +(test "SXML for simple button" '(button "A button") (widget->sxml-and-css '(Simple-Button))) +(test "CSS for simple button" '() (receive (_ css) (widget->sxml-and-css '(Simple-Button)) css)) + +(test-assert "Define a more complex widget" + (define-widget (Fancy-Button ((color "blue"))) + `(button (@ (style ((background-color ,color)))) "A Fancy button"))) + +(test "SXML for fancy button using default color arg" '(button (@ (class "x6a6e56dd4762d830ee54fc65cecabd58")) "A Fancy button") (widget->sxml-and-css '(Fancy-Button))) +(test "CSS for fancy button using default color arg" '(".x6a6e56dd4762d830ee54fc65cecabd58 { background-color: blue }") (receive (_ css) (widget->sxml-and-css '(Fancy-Button)) css)) +(test "SXML for fancy button passing in color arg" '(button (@ (class "xa3ed2da9387d3e404378fa00f4560b41")) "A Fancy button") (widget->sxml-and-css '(Fancy-Button (@ (color "red"))))) +(test "CSS for fancy button passing in color arg" '(".xa3ed2da9387d3e404378fa00f4560b41 { background-color: red }") (receive (_ css) (widget->sxml-and-css '(Fancy-Button (@ (color "red")))) css)) +(test "In SXML: CSS class being re-used" '(div (button (@ (class "x6a6e56dd4762d830ee54fc65cecabd58")) "A Fancy button") + (button (@ (class "x6a6e56dd4762d830ee54fc65cecabd58")) "A Fancy button")) + (widget->sxml-and-css '(div (Fancy-Button) (Fancy-Button)))) +(test "In CSS: CSS class being re-used" '(".x6a6e56dd4762d830ee54fc65cecabd58 { background-color: blue }") (receive (_ css) (widget->sxml-and-css '(div (Fancy-Button) (Fancy-Button))) css)) + +(test-assert "Define a widget that returns another widget" + (define-widget (Trans-Button) + `(Simple-Button))) + +(test "SXML for widget that returns another widget" '(button "A button") (widget->sxml-and-css '(Trans-Button))) +(test "CSS for widget that returns another widget" '() (receive (_ css) (widget->sxml-and-css '(Trans-Button)) css)) + +(test-assert "Define a widget that specifies a content var" + (define-widget (Box () contents) + `(div ,@contents))) + +(test "SXML for widget with contents" '(div (span "body")) (widget->sxml-and-css '(Box (span "body")))) +(test "CSS for widget with contents" '() (receive (_ css) (widget->sxml-and-css '(Box (span "body"))) css)) + +(test-assert "Define a widget that specifies args and content var" + (define-widget (Box2 ((use-article #f)) contents) + (if use-article + `(article ,@contents) + `(div ,@contents)))) + +(test "SXML for widget with args and contents (use default)" '(div (span "body")) (widget->sxml-and-css '(Box2 (span "body")))) +(test "SXML for widget with args and contents (pass arg)" '(article (span "body")) (widget->sxml-and-css '(Box2 (@ (use-article #t)) (span "body")))) + +(test "SXML for complex widgets with re-used classes" + '(div (span "body") + (button (@ (class "x6a6e56dd4762d830ee54fc65cecabd58")) "A Fancy button") + (button (@ (class "x6a6e56dd4762d830ee54fc65cecabd58")) "A Fancy button") + (button (@ (class "xa3ed2da9387d3e404378fa00f4560b41")) "A Fancy button")) + (widget->sxml-and-css + '(Box + (span "body") + (Fancy-Button) + (Fancy-Button) + (Fancy-Button (@ (color "red")))))) + +(test "CSS for complex widgets with re-used classes" + '(".x6a6e56dd4762d830ee54fc65cecabd58 { background-color: blue }" + ".xa3ed2da9387d3e404378fa00f4560b41 { background-color: red }") + (receive (_ css) + (widget->sxml-and-css + '(Box + (span "body") + (Fancy-Button) + (Fancy-Button) + (Fancy-Button (@ (color "red"))))) + (sort css string<))) ;; the classes can be returned in any order so sort them to make it easier to test + +(test-assert "Define a widget with root and query styles" + (define-widget (Styles () contents) + `(div (@ (style ((color "red") + (@container "(max-width: 400px)" + (color "blue"))))) + ,@contents))) + +(test "CSS for widget with root and query styles" + '(".x73706d193dfd4d1d9bba528027060dfc { color: red } @container (max-width: 400px) { .x73706d193dfd4d1d9bba528027060dfc { color: blue } }") + (receive (_ css) + (widget->sxml-and-css + '(Styles "contents")) + (sort css string<))) + + +(test-exit)