From f5f363694506edaf50eb1c1f1e1001b94e1d5d1c Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Wed, 1 May 2019 16:22:17 +0200
Subject: Change how attributes are fetched.

Previous version failed when an attribute contained a list. This fixes
that, by always returning a circular list, delimited with #f when it
loops. Methods for moving through this list is currently lacking.
---
 module/output/html.scm       | 10 +++-------
 module/vcomponent.scm        | 38 +++++++++++++++++++++++++++-----------
 module/vcomponent/output.scm |  7 ++++---
 3 files changed, 34 insertions(+), 21 deletions(-)

(limited to 'module')

diff --git a/module/output/html.scm b/module/output/html.scm
index 1c79ad83..c6ba389c 100644
--- a/module/output/html.scm
+++ b/module/output/html.scm
@@ -82,8 +82,7 @@
 
   `(a (@ (href "#" ,(UID ev))
          (class "hidelink"))
-      (div (@ (class "event CAL_" ,(html-attr (let ((l (attr (parent ev) 'NAME)))
-                                                (if (pair? l) (car l) l)))
+      (div (@ (class "event CAL_" ,(html-attr (attr (parent ev) 'NAME))
                 ,(when (time<? (attr ev 'DTSTART) time)
                    " continued")
                 ,(when (time<? (add-day time) (attr ev 'DTEND))
@@ -137,8 +136,7 @@
 (define (fmt-single-event ev)
   `(article (@ (id ,(UID ev))
                (class "eventtext CAL_bg_"
-                 ,(html-attr (let ((l (attr (parent ev) 'NAME)))
-                               (if (pair? l) (car l) l)))))
+                 ,(html-attr (attr (parent ev) 'NAME))))
             (h3 (a (@ (href "#" ,(time-link (attr ev 'DTSTART)))
                       (class "hidelink"))
                    ,(attr ev 'SUMMARY)))
@@ -235,9 +233,7 @@
            ,(include-css "static/style.css")
            (style ,(format #f "~:{.CAL_~a { background-color: ~a; color: ~a }~%.CAL_bg_~a { border-color: ~a }~%~}"
                            (map (lambda (c)
-                                  (let* ((name (html-attr (if (pair? (attr c 'NAME))
-                                                              (car (attr c 'NAME))
-                                                              (attr c 'NAME))))
+                                  (let* ((name (html-attr (attr c 'NAME)))
                                          (bg-color (attr c 'COLOR))
                                          (fg-color (and=> (attr c 'COLOR)
                                                           calculate-fg-color)))
diff --git a/module/vcomponent.scm b/module/vcomponent.scm
index e2265a7e..c6fe2104 100644
--- a/module/vcomponent.scm
+++ b/module/vcomponent.scm
@@ -4,6 +4,7 @@
   #:use-module (vcomponent recurrence)
   #:use-module (vcomponent timezone)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-17)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-19 util)
   #:use-module (srfi srfi-19 setters)
@@ -65,32 +66,47 @@
    (as-string attr)))
 
 (define (set-attr! component attr value)
-  (set-car! (get-attr component (as-string attr))
-            value))
+  (set! (car (get-attr component (as-string attr)))
+        value))
 
-(define-public attr*
-  (make-procedure-with-setter
-   get-attr set-attr!))
+(define-public value caar)
+(define-public next cdr)
+;; (define-public next! pop!)
+
+(define-public (values-left-count attr-list)
+  (length (take-while identity attr-list)))
+
+(define-public (value-count attr-list)
+  (length (take-while identity (cdr (drop-while identity attr-list)))))
+
+;; (define-public (reset! attr-list)
+;;   (while (not (car attr-list))
+;;     (next! attr-list))
+;;   (next! attr-list))
+
+(define-public attr* get-attr)
 
 (define-public attr
   (make-procedure-with-setter
-   (compose car get-attr) set-attr!))
+   (lambda (c a) (and=> (car (get-attr c a)) car))
+   (lambda (c a v) (and=> (car (get-attr c a))
+                     (lambda (f) (set! (car f) v))))))
 
 ;; value
-(define-public v
-  (make-procedure-with-setter car set-car!))
+;; (define-public v
+;;   (make-procedure-with-setter car set-car!))
 
 (define-public prop
   (make-procedure-with-setter
    (lambda (attr-obj prop-key)
-     (hashq-ref (cdr attr-obj) prop-key))
+     (hashq-ref (cdar attr-obj) prop-key))
    (lambda (attr-obj prop-key val)
-     (hashq-set! (cdr attr-obj) prop-key val))))
+     (hashq-set! (cdar attr-obj) prop-key val))))
 
 ;; Returns the properties of attribute as an assoc list.
 ;; @code{(map car <>)} leads to available properties.
 (define-public (properties attrptr)
-  (hash-map->list cons (cdr attrptr)))
+  (hash-map->list cons (cdar attrptr)))
 
 ;; (define-public type %vcomponent-get-type)
 (define-public type (make-procedure-with-setter
diff --git a/module/vcomponent/output.scm b/module/vcomponent/output.scm
index 6d346230..f55adf3b 100644
--- a/module/vcomponent/output.scm
+++ b/module/vcomponent/output.scm
@@ -21,7 +21,7 @@
             (begin body ...)
             (if pred-value STR-RESET ""))))
 
-(define* (print-vcomponent comp #:optional (port #t) #:key (depth 0))
+(define* (print-vcomponent comp #:optional (port #t) #:key (descend? #t) (depth 0))
   (let ((kvs (map (lambda (key) (cons key (attr* comp key)))
                   (attributes comp))))
     (format port "~a <~a> :: ~:a~%"
@@ -34,8 +34,9 @@
                    key
                    (concatenate (hash-map->list list (cdr at)))
                    (v at))))
-    (for-each (lambda (e) (print-vcomponent e port #:depth (1+ depth)))
-              (children comp))))
+    (if descend?
+     (for-each (lambda (e) (print-vcomponent e port #:descend? #t #:depth (1+ depth)))
+               (children comp)))))
 
 
 
-- 
cgit v1.2.3