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.

4 files changed, 46 insertions, 30 deletions

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)))))
 
 
 
diff --git a/src/guile_interface.scm.c b/src/guile_interface.scm.c
index b8830be4..01ec7fab 100644
--- a/src/guile_interface.scm.c
+++ b/src/guile_interface.scm.c
@@ -54,18 +54,23 @@ SCM_DEFINE (vcomponent_get_attribute, "%vcomponent-get-attribute", 2, 0, 0,
 
 	free(key);
 
-	SCM val, proplist, attrlist = SCM_EOL;
+	SCM val, proplist;
+	SCM attrroot = scm_list_1(SCM_BOOL_F);
+	SCM attrlist = attrroot;
 	LLIST(strbuf) *triekeys, *trievals;
+
 	/* For every instance of a line */
 	FOR (LLIST, content_set, v, c) {
 		val = scm_from_strbuf(&v->key);
+
 		if (! scm_is_pair(val)) {
 			// TODO look into using a weak hash table instead
 
 			// TODO why is it an error to unprotect the object here?
 			// scm_from_strbuf should already have protected it...
 			// scm_gc_unprotect_object(v->key.scm);
-			val = scm_cons(val, SCM_MAKE_HASH_TABLE());
+			SCM htable = SCM_MAKE_HASH_TABLE();
+			val = scm_cons(val, htable);
 			v->key.scm = val;
 			scm_gc_protect_object(v->key.scm);
 
@@ -80,7 +85,7 @@ SCM_DEFINE (vcomponent_get_attribute, "%vcomponent-get-attribute", 2, 0, 0,
 					proplist = scm_cons(scm_from_strbuf(s), proplist);
 				}
 
-				scm_hashq_set_x(scm_cdr(val), scm_from_strbuf_symbol(k),
+				scm_hashq_set_x(htable, scm_from_strbuf_symbol(k),
 						scm_reverse(proplist));
 			}
 		}
@@ -88,12 +93,10 @@ SCM_DEFINE (vcomponent_get_attribute, "%vcomponent-get-attribute", 2, 0, 0,
 		attrlist = scm_cons(val, attrlist);
 	}
 
-	/* returns the car of list if list is one long. */
-	if (scm_to_int(scm_length(attrlist)) == 1) {
-		return SCM_CAR(attrlist);
-	} else {
-		return attrlist;
-	}
+	/* create circular list */
+	scm_set_cdr_x (attrroot, attrlist);
+
+	return attrlist;
 }
 
 SCM_DEFINE (vcomponent_child_count, "%vcomponent-child-count", 1, 0, 0,