blob: 60a27f943035bf363dd469543a0a4d911d8a5787 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
|
(define-module (vcomponent base)
:use-module (util)
:use-module (srfi srfi-1)
:use-module (srfi srfi-17)
:use-module (vcomponent parse)
:use-module (ice-9 hash-table)
:use-module ((ice-9 optargs) :select (define*-public))
:re-export (add-child! make-vcomponent))
(define-public (parse-cal-path path)
(let ((parent (make-vcomponent)))
(for-each (lambda (child) (add-child! parent child))
(read-vcalendar path))
(set-attribute!
parent 'X-HNH-SOURCETYPE
(if (null? (get-component-children parent))
"vdir"
(get-attribute-value (car (get-component-children parent))
'X-HNH-SOURCETYPE "vdir")))
parent))
;; vline → value
(define-public value
(make-procedure-with-setter
get-vline-value set-vline-value!))
;; vcomponent x (or str symb) → vline
(define-public (attr* component attr)
(hashq-ref (get-component-attributes component)
(as-symb attr)))
;; vcomponent x (or str symb) → value
(define (get-attr component key)
(get-attribute-value component (as-symb key) #f))
(define (set-attr! component key value)
(set-attribute! component (as-symb key) value))
(define-public attr
(make-procedure-with-setter
get-attr
set-attr!))
(define-public prop
(make-procedure-with-setter
(lambda (attr-obj prop-key)
;; TODO `list' is a hack since a bit to much code depends
;; on prop always returning a list of values.
(and=> (hashq-ref (get-vline-parameters attr-obj)
(as-symb prop-key))
list))
(lambda (attr-obj prop-key val)
(hashq-set! (get-vline-parameters attr-obj)
(as-symb 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 (get-attribute-parameters attrptr)))
(define-public type (make-procedure-with-setter
(lambda (c) (component-type c))
(lambda (c v) ; struct-set! c 0 v
(format (current-error-port)
"This method is a deprecated NOOP"))))
(define-public parent get-component-parent)
(define-public (attributes component)
(map car (hash-map->list cons (get-component-attributes component))))
(define*-public children get-component-children)
(define (copy-vline vline)
(make-vline (get-vline-value vline)
;; TODO deep-copy on properties?
(get-vline-parameters vline)))
(define-public (copy-vcomponent component)
(make-vcomponent% (component-type component)
(get-component-children component)
(get-component-parent component)
;; attributes
(alist->hashq-table
(hash-map->list (lambda (key value) (cons key (copy-vline value)))
(get-component-attributes component)))))
(define-public (extract field)
(lambda (e) (attr e field)))
(define-public (extract* field)
(lambda (e) (attr* e field)))
(define-public (key=? k1 k2)
(eq? (as-symb k1)
(as-symb k2)))
|
