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

Initial commit.

Browse Source
main
Thomas Hintz 1 week ago
commit 785d307d59
4 changed files with 251 additions and 0 deletions
Show Stats Download Patch File Download Diff File

9
.gitignore vendored
Unescape Escape View File

@ -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

8
html-widgets.egg
Unescape Escape View File

@ -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))

140
html-widgets.scm
Unescape Escape 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))))
)

94
tests/run.scm
Unescape Escape View File

@ -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)
Write Preview
Loading…
Cancel
Save