feat: add task and click app

game.js

@@ -28,11 +28,15 @@ window.addEventListener("load", async () => {
           removeAttribute: (elem, name) => elem.removeAttribute(name),
           remove: (elem) => elem.remove(),
           replaceWith: (oldElem, newElem) => oldElem.replaceWith(newElem),
-          clone: (elem) => elem.cloneNode()
+          clone: (elem) => elem.cloneNode(),
+          checked(elem) { return elem.checked; },
+          setChecked(elem, checked) { elem.checked = (checked == 1); },
+
         },
         event: {
           addEventListener: (target, type, listener) => target.addEventListener(type, listener),
           removeEventListener: (target, type, listener) => target.removeEventListener(type, listener),
+          target(event) { return event.target; },
           preventDefault: (event) => event.preventDefault(),
           keyboardCode: (event) => event.code
         },

game.scm

@@ -18,11 +18,135 @@
 ;;;
 ;;; Code:
 
-(use-modules (dom document)
+(use-modules (scheme base)
+             (dom document)
              (dom element)
+             (dom event)
              (math vector)
              (hoot ffi)
              (hoot hashtables)
              (ice-9 match))
 
-(append-child! (document-body) (make-text-node "Hello, world!"))
+(define (sxml->dom exp)
+  (match exp
+    ;; The simple case: a string representing a text node.
+    ((? string? str)
+     (make-text-node str))
+    ;; 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))))
+       (define (add-children children)
+         ;; Recursively call sxml->dom for each child node and
+         ;; append it to elem.
+         (for-each (lambda (child)
+                     (append-child! elem (sxml->dom child)))
+                   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) (? boolean? 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)))
+       elem))))
+
+(define *clicks* 0)
+(define *template* '())
+
+;; Click
+(define (template-click)
+  `(div
+    (p ,(number->string *clicks*) " clicks")
+    (button (@ (click ,(lambda (event)
+                            (set! *clicks* (+ *clicks* 1))
+                            (render))))
+                "Click me!")))
+
+;; Task
+(define (render)
+  (let ((old (get-element-by-id "container")))
+    (unless (external-null? old) (remove! old))
+  (append-child! (document-body) (sxml->dom (wrap-template *template*)))))
+
+(define-record-type <task>
+  (make-task name done?)
+  task?
+  (name task-name)
+  (done? task-done? set-task-done!))
+
+(define *tasks* '())
+
+(define (add-task! task)
+  (set! *tasks* (cons task *tasks*)))
+
+(define (remove-task! task)
+  (set! *tasks* (delq task *tasks*)))
+
+(define (template-task)
+  (define (task-template task)
+    `(li (input (@ (type "checkbox")
+                   (change ,(lambda (event)
+                              (let* ((checkbox (event-target event))
+                                     (checked? (element-checked? checkbox)))
+                                (set-task-done! task checked?)
+                                (render))))
+                   (checked ,(task-done? task))))
+         (span (@ (style "padding: 0 1em 0 1em;"))
+               ;; Strikethrough if task is done.
+               ,(if (task-done? task)
+                    `(s ,(task-name task))
+                    (task-name task)))
+         (a (@ (href "#")
+               ;; Remove task on click.
+               (click ,(lambda (event)
+                         (remove-task! task)
+                         (render))))
+            "remove")))
+  `(div
+    (h2 "Tasks")
+    ;; Tasks are stored in reverse order.
+    (ul ,@(map task-template (reverse *tasks*)))
+    (input (@ (id "new-task")
+              (placeholder "Write more task")))
+    ;; Add new task on click
+    (button (@ (click ,(lambda (event)
+                         (let* ((input (get-element-by-id "new-task"))
+                                (name (element-value input)))
+                           (unless (string=? name "")
+                             (add-task! (make-task name #f))
+                             (set-element-value! input "")
+                             (render))))))
+            "Add task")))
+
+;; Main
+(define (wrap-template template)
+  `(div (@ (id "container"))
+    (button (@ (click ,(lambda (event)
+                            (set! *template* template-click)
+                            (render))))
+                "Click")
+    (button (@ (click ,(lambda (event)
+                            (set! *template* template-task)
+                            (render))))
+                "Task")
+    (div (@ (id "application")) ,(template))))
+
+(set! *template* template-task)
+(render)

modules/dom/element.scm

@@ -29,7 +29,9 @@
             replace-with!
             set-attribute!
             remove-attribute!
-            clone-element))
+            clone-element
+            element-checked?
+            set-element-checked!))
 
 (define-foreign element-value
   "element" "value"
@@ -58,7 +60,7 @@
 (define-foreign replace-with!
   "element" "replaceWith"
   (ref extern) (ref extern) -> none)
-(define-foreign set-attribute!
+(define-foreign %set-attribute!
   "element" "setAttribute"
   (ref extern) (ref string) (ref string) -> none)
 (define-foreign remove-attribute!
@@ -67,3 +69,17 @@
 (define-foreign clone-element
   "element" "clone"
   (ref extern) -> (ref extern))
+
+(define-foreign %element-checked?
+  "element" "checked"
+  (ref null extern) -> i32)
+(define (element-checked? elem)
+  (= (%element-checked? elem) 1))
+
+(define-foreign set-element-checked!
+  "element" "setChecked"
+  (ref null extern) i32 -> none)
+(define (set-attribute! elem name val)
+  (if (string=? name "checked")
+        (set-element-checked! elem (if val 1 0))
+      (%set-attribute! elem name val)))

modules/dom/event.scm

@@ -22,6 +22,7 @@
   #:use-module (hoot ffi)
   #:export (add-event-listener!
             remove-event-listener!
+            event-target
             prevent-default!
             keyboard-event-code))
 
@@ -32,6 +33,9 @@
 (define-foreign remove-event-listener!
   "event" "removeEventListener"
   (ref extern) (ref string) (ref extern) -> none)
+(define-foreign event-target
+  "event" "target"
+  (ref null extern) -> (ref null extern))
 
 ;; Event
 (define-foreign prevent-default!