127 lines
4.7 KiB
Scheme
127 lines
4.7 KiB
Scheme
(use-modules (reactive)
|
|
(ice-9 match)
|
|
(srfi srfi-9)
|
|
(hoot ffi))
|
|
|
|
(define-foreign get-element-by-id
|
|
"document" "getElementById"
|
|
(ref string) -> (ref null extern))
|
|
|
|
(define-foreign document-body
|
|
"document" "body"
|
|
-> (ref null extern))
|
|
|
|
(define-foreign make-text-node
|
|
"document" "createTextNode"
|
|
(ref string) -> (ref null extern))
|
|
|
|
(define-foreign make-element
|
|
"document" "createElement"
|
|
(ref string) -> (ref null extern))
|
|
|
|
(define-foreign element-inner-text
|
|
"element" "innerText"
|
|
(ref null extern) -> (ref string))
|
|
(define-foreign set-element-inner-text!
|
|
"element" "setInnerText"
|
|
(ref null extern) (ref string) -> none)
|
|
|
|
(define-foreign add-event-listener!
|
|
"element" "addEventListener"
|
|
(ref null extern) (ref string) (ref null extern) -> none)
|
|
|
|
(define-foreign append-child!
|
|
"element" "appendChild"
|
|
(ref null extern) (ref null extern) -> (ref null extern))
|
|
|
|
(define-foreign element-parent
|
|
"element" "parentElement"
|
|
(ref null extern) -> (ref null extern))
|
|
|
|
(define-foreign replace-child!
|
|
"element" "replaceChild"
|
|
(ref null extern) (ref null extern) (ref null extern) -> (ref null extern))
|
|
|
|
(define-foreign set-attribute!
|
|
"element" "setAttribute"
|
|
(ref null extern) (ref string) (ref string) -> none)
|
|
|
|
(define-record-type <element-ref>
|
|
(make-element-ref elem deriv children)
|
|
element-ref?
|
|
(elem element-ref-element element-ref-set-element!)
|
|
(deriv element-ref-deriv element-ref-set-deriv!)
|
|
(children element-ref-children element-ref-set-children!))
|
|
|
|
(define (sxml->dom-ref exp)
|
|
(match exp
|
|
((or (? cell?) (? deriv?))
|
|
(let* ((ref (make-element-ref #f #f '()))
|
|
(deriv (~ (let ((old-elem (element-ref-element ref))
|
|
(inner-ref (sxml->dom (! exp)))
|
|
(elem (make-element "deriv")))
|
|
(append-child! elem (element-ref-element inner-ref))
|
|
(when old-elem
|
|
(replace-child! (element-parent old-elem) old-elem elem))
|
|
(element-ref-set-element! ref elem)
|
|
(element-ref-set-children! ref (list inner-ref))))))
|
|
(element-ref-set-deriv! ref deriv)
|
|
ref))
|
|
((? number? num)
|
|
(make-element-ref (make-text-node (number->string num)) #f '()))
|
|
;; The simple case: a string representing a text node.
|
|
((? string? str)
|
|
(make-element-ref (make-text-node str) #f '()))
|
|
;; An element tree. The first item is the HTML tag.
|
|
(((? symbol? tag) . body)
|
|
;; Create a new element with the given tag.
|
|
(let* ((elem (make-element (symbol->string tag)))
|
|
(ref (make-element-ref elem #f '())))
|
|
(define (add-children children)
|
|
;; Recursively call sxml->dom for each child node and
|
|
;; append it to elem.
|
|
(element-ref-set-children!
|
|
ref
|
|
(map (lambda (child)
|
|
(let ((child-ref (sxml->dom child)))
|
|
(append-child! elem (element-ref-element child-ref))
|
|
child-ref))
|
|
children)))
|
|
(match body
|
|
;; '@' denotes an attribute list. Child nodes follow.
|
|
((('@ . attrs) . children)
|
|
;; Set attributes.
|
|
(for-each (lambda (attr)
|
|
(match attr
|
|
;; Attributes are (symbol string) tuples.
|
|
(((? symbol? name) (? string? val))
|
|
(set-attribute! elem
|
|
(symbol->string name)
|
|
val))
|
|
(((? symbol? name) (? procedure? proc))
|
|
(add-event-listener! elem
|
|
(symbol->string name)
|
|
(procedure->external proc)))))
|
|
attrs)
|
|
(add-children children))
|
|
;; No attributes, just a list of child nodes.
|
|
(children (add-children children)))
|
|
ref))))
|
|
|
|
(define counter (make-cell 0))
|
|
(define square (~ (* (! counter) (! counter))))
|
|
|
|
(define root-ref
|
|
(sxml->dom-ref `(div (@ (class "foo"))
|
|
(p "this is a test")
|
|
(button (@ (id "button")
|
|
(type "button")
|
|
(click ,(lambda (e)
|
|
(! counter (1+ (! counter)))
|
|
;; Hacky hack to ensure root-ref isn't GC'd too early...
|
|
(display root-ref))))
|
|
"Counter: "
|
|
,counter)
|
|
(p "The square is: " ,square))))
|
|
|
|
(append-child! (document-body) (element-ref-element root-ref))
|