Rework how attributes and properties are accessed.

Made the fact that properties belong to an attribute shine through to
scheme. This by setting the SCM field in the strbuf:ers in my
vcomponents to a pair of their old SCM value, and a hash table
representing the properties.

This also meant that the primitive set-attribute! could be replaced by a
set-car! on the pair returned by the primitive get-attribute. And that
both set- and get-property now simple works on the hash table returned
by get-attribute.

The major problem with this release was that I for a while missed that
DEEP_COPY(strbuf) now also needed to deep copy the SCM values. Without
that attributes in a copied vcomponent would be shared with the
original. This mainly lead to repeating events all being the same.

4 files changed, 70 insertions, 159 deletions

diff --git a/module/vcalendar.scm b/module/vcalendar.scm
index 12e2d9a5..a4da1527 100644
--- a/module/vcalendar.scm
+++ b/module/vcalendar.scm
@@ -28,41 +28,36 @@
         childs)))
 (export children)
 
-(define (set-attr! component attr value)
-  (%vcomponent-set-attribute!
-   component
-   (as-string attr)
-   value))
-
 (define (get-attr component attr)
   (%vcomponent-get-attribute
    component
    (as-string attr)))
 
-(define (get-property component attr prop)
-  (%vcomponent-get-property
-   component
-   (as-string attr)
-   (as-string prop)))
+(define (set-attr! component attr value)
+  (set-car! (get-attr component (as-string attr))
+            value))
 
-(define (set-property! component attr prop val)
-  (%vcomponent-set-property!
-   component
-   (as-string attr)
-   (as-string prop)
-   val))
+(define-public attr*
+  (make-procedure-with-setter
+   get-attr set-attr!))
 
-(define-public prop
+(define-public attr
   (make-procedure-with-setter
-   get-property
-   set-property!))
+   (compose car get-attr) set-attr!))
 
-(define-public (properties component attr)
-  (%vcomponent-property-list component (as-string attr)))
+;; value
+(define-public v
+  (make-procedure-with-setter car set-car!))
 
-;; Enables symmetric get and set:
-;; (set! (attr ev "KEY") 10)
-(define-public attr (make-procedure-with-setter get-attr set-attr!))
+(define-public prop
+  (make-procedure-with-setter
+   (lambda (attr-obj prop-key)
+     (hashq-ref (cdr attr-obj) prop-key))
+   (lambda (attr-obj prop-key val)
+     (hashq-set! (cdr attr-obj) prop-key val))))
+
+(define-public (properties component attr-key)
+  (hash-map->list cons (cdr (attr component (as-string attr-key)))))
 
 ;; (define-public type %vcomponent-get-type)
 (define-public type (make-procedure-with-setter
@@ -76,17 +71,20 @@
 
 (define-public filter-children! %vcomponent-filter-children!)
 
+(define-public (extract field)
+  (lambda (e) (attr e field)))
+
+(define-public (extract* field)
+  (lambda (e) (attr* e field)))
+
 (define-public (search cal term)
   (cdr (let ((events (filter (lambda (ev) (eq? 'VEVENT (type ev)))
                              (children cal))))
          (find (lambda (ev) (string-contains-ci (car ev) term))
-               (map cons (map (cut get-attr <> "SUMMARY")
+               (map cons (map (extract "SUMMARY")
                               events)
                     events)))))
 
-(define-public (extract field)
-  (cut get-attr <> field))
-
 (define-public (key=? k1 k2)
   (eq? (as-symb k1)
        (as-symb k2)))
diff --git a/module/vcalendar/primitive.scm b/module/vcalendar/primitive.scm
index 400750c9..27ae6e17 100644
--- a/module/vcalendar/primitive.scm
+++ b/module/vcalendar/primitive.scm
@@ -11,13 +11,7 @@
             %vcomponent-get-type
             %vcomponent-set-type!
 
-            %vcomponent-set-attribute!
             %vcomponent-get-attribute
-
-            %vcomponent-get-property
-            %vcomponent-set-property!
-            %vcomponent-property-list
-
             %vcomponent-attribute-list
 
             %vcomponent-shallow-copy))
diff --git a/src/guile_interface.scm.c b/src/guile_interface.scm.c
index 036e9e9c..0f795d44 100644
--- a/src/guile_interface.scm.c
+++ b/src/guile_interface.scm.c
@@ -45,109 +45,54 @@ SCM_DEFINE (vcomponent_get_attribute, "%vcomponent-get-attribute", 2, 0, 0,
 
 	char* key = scm_to_utf8_stringn(scm_string_upcase(attr), NULL);
 	content_line* c = get_attributes (cal, key);
-	free(key);
-
-	if (c == NULL) return SCM_BOOL_F;
-
-	SCM llist = SCM_EOL;
-	FOR (LLIST, content_set, v, c) {
-		llist = scm_cons(scm_from_strbuf(&v->key), llist);
-	}
 
-	/* returns the car of list if list is one long. */
-	if (scm_to_int(scm_length(llist)) == 1) {
-		return SCM_CAR(llist);
-	} else {
-		return llist;
+	if (c == NULL) {
+		vcomponent_push_val(cal, key, "");
+		c = get_attributes (cal, key);
+		c->cval->key.scm = SCM_BOOL_F;
 	}
-}
-
-SCM_DEFINE (vcomponent_get_property, "%vcomponent-get-property", 3, 0, 0,
-            (SCM component, SCM attr, SCM prop),
-            "")
-{
-	scm_assert_foreign_object_type (vcomponent_type, component);
-	vcomponent* comp = scm_foreign_object_ref (component, 0);
 
-	char* key      = scm_to_utf8_stringn(scm_string_upcase(attr), NULL);
-	char* prop_key = scm_to_utf8_stringn(scm_string_upcase(prop), NULL);
-	content_line* cl = get_attributes (comp, key);
 	free(key);
 
-	if (cl == NULL) return SCM_BOOL_F;
-
-	SCM llist = SCM_EOL;
-	FOR (LLIST, content_set, cs, cl) {
-		LLIST(strbuf)* strs = GET(TRIE(param_set))(&cs->val, prop_key);
-		if (strs == NULL) continue;
-		SCM subl = SCM_EOL;
-		FOR (LLIST, strbuf, s, strs) {
-			subl = scm_cons(scm_from_strbuf(s), subl);
+	SCM val, attrlist = SCM_EOL, proplist;
+	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());
+			v->key.scm = val;
+			scm_gc_protect_object(v->key.scm);
 		}
-		llist = scm_cons(subl, llist);
-	}
-
-	return llist;
-}
 
-SCM_DEFINE (vcomponent_set_property_x, "%vcomponent-set-property!", 4, 0, 0,
-            (SCM component, SCM attr, SCM prop, SCM val),
-            "")
-{
-	scm_assert_foreign_object_type (vcomponent_type, component);
-	vcomponent* comp = scm_foreign_object_ref (component, 0);
+		triekeys = KEYS(TRIE(param_set))(&v->val);
+		/* For every property key bound to the current attribute */
+		FOR (LLIST, strbuf, k, triekeys) {
+			proplist = SCM_EOL;
 
-	char* key      = scm_to_utf8_stringn(scm_string_upcase(attr), NULL);
-	char* prop_key = scm_to_utf8_stringn(scm_string_upcase(prop), NULL);
-	content_line* cl = get_attributes (comp, key);
-	free(key);
-
-	TRIE(param_set)* tt = &cl->cval->val;
-	LLIST(strbuf)* vals = GET(TRIE(param_set))(tt, prop_key);
-	vals->cval->scm = val;
-
-	return SCM_UNSPECIFIED;
-}
-
-SCM_DEFINE (vcomponent_set_attr_x, "%vcomponent-set-attribute!", 3, 0, 0,
-		(SCM component, SCM attr, SCM new_value),
-		"")
-{
-	scm_assert_foreign_object_type (vcomponent_type, component);
-	vcomponent* com = scm_foreign_object_ref (component, 0);
-
-	char* key = scm_to_utf8_stringn(scm_string_upcase(attr), NULL);
-	content_line* c = get_attributes (com, key);
+			trievals = GET(TRIE(param_set))(&v->val, k->mem);
+			/* For every value bound to the current property */
+			FOR (LLIST, strbuf, s, trievals) {
+				proplist = scm_cons(scm_from_strbuf(s), proplist);
+			}
 
-	/* Create the position in the TRIE if it doesn't already exist */
-	if (c == NULL) {
-		/* Insert empty key since this allows me to use the helper
-		 * function */
-		vcomponent_push_val(com, key, "");
-		c = get_attributes (com, key);
-	} else {
-		/*
-		 * The SCM representation of an object is usually initialized
-		 * when an attribute is first accessed from guile. If we
-		 * however try to set it before accessing it then that field
-		 * will still be NULL.
-		 *
-		 * If the object, and its SCM instance exist, unprotect it.
-		 * Otherwise we know that it's NULL and safe to write a new
-		 * SCM value there.
-		 */
-		if (c->cval->key.scm != NULL) {
-			scm_gc_unprotect_object(c->cval->key.scm);
+			scm_hashq_set_x(scm_cdr(val), scm_from_strbuf_symbol(k),
+			                scm_reverse(proplist));
 		}
+		attrlist = scm_cons(val, attrlist);
 	}
 
-	free(key);
-
-	strbuf* target = &c->cval->key;
-	target->scm = new_value;
-	scm_gc_protect_object(target->scm);
-
-	return SCM_UNSPECIFIED;
+	/* 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;
+	}
 }
 
 SCM_DEFINE (vcomponent_child_count, "%vcomponent-child-count", 1, 0, 0,
@@ -274,37 +219,6 @@ SCM_DEFINE(vcomponent_attr_list, "%vcomponent-attribute-list", 1, 0, 0,
 	return llist;
 }
 
-SCM_DEFINE(vcomponent_prop_list, "%vcomponent-property-list", 2, 0, 0,
-           (SCM component, SCM attr),
-           "")
-{
-	scm_assert_foreign_object_type (vcomponent_type, component);
-	vcomponent* comp = scm_foreign_object_ref (component, 0);
-
-	char* key      = scm_to_utf8_stringn(scm_string_upcase(attr), NULL);
-	content_line* cl = get_attributes (comp, key);
-	free(key);
-
-	if (cl == NULL) return SCM_BOOL_F;
-
-	SCM llist = SCM_EOL;
-	FOR (LLIST, content_set, cs, cl) {
-		LLIST(strbuf)* keys = KEYS(TRIE(param_set))(&cs->val);
-		if (keys == NULL) continue;
-
-		FOR (LLIST, strbuf, s, keys) {
-			SCM symb = scm_string_to_symbol(scm_from_strbuf(s));
-			if ( scm_is_false(scm_memv (symb, llist)) ) {
-				llist = scm_cons(symb, llist);
-			}
-		}
-
-		FFREE(LLIST(strbuf), keys);
-	}
-
-	return llist;
-}
-
 SCM_DEFINE(vcomponent_shallow_copy, "%vcomponent-shallow-copy", 1, 0, 0,
            (SCM component),
            "Creates a shallow copy of the given component.")
diff --git a/src/strbuf.c b/src/strbuf.c
index c7e3f2b5..66fe2989 100644
--- a/src/strbuf.c
+++ b/src/strbuf.c
@@ -70,8 +70,13 @@ int DEEP_COPY(strbuf)(strbuf* dest, strbuf* src) {
 	}
 
 	if (src->scm != NULL) {
-		/* The magic SCM type is copied when reassigned. */
-		dest->scm = src->scm;
+		/*
+		 * Upon Vcomponent binding into scheme I place all
+		 * strings inside cons cells. This leads to a deep
+		 * copy being required. copy-tree however returns
+		 * the same object for atoms and scheme strings.
+		 */
+		dest->scm = scm_copy_tree(src->scm);
 		/* NOTE This is a bit of a leaky abstraction.  */
 		scm_gc_protect_object(dest->scm);
 	}