From f5f363694506edaf50eb1c1f1e1001b94e1d5d1c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= 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 ++++--- src/guile_interface.scm.c | 21 ++++++++++++--------- 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 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, -- cgit v1.2.3