diff options
Diffstat (limited to '')
-rw-r--r-- | module/output/html.scm | 10 | ||||
-rw-r--r-- | module/vcomponent.scm | 38 | ||||
-rw-r--r-- | module/vcomponent/output.scm | 7 | ||||
-rw-r--r-- | 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 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, |