blob: 076558e4fce9f1e6187a5073f577c5c2b126da34 (
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
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
|
#!/usr/bin/guile \
-e main -s
!#
(add-to-load-path (string-append (dirname (dirname (current-filename))) "/module"))
(use-modules (vcomponent)
((vcomponent recurrence parse) :select (parse-recurrence-rule))
((vcomponent formats xcal output) :select (vcomponent->sxcal ns-wrap))
((vcomponent formats ical output) :select (component->ical-string))
(vcomponent datetime)
(datetime)
((datetime instance) :select (zoneinfo))
(hnh util)
(hnh util uuid)
(ice-9 format)
(ice-9 popen)
(ice-9 threads)
((srfi srfi-88) :select (keyword->string))
(sxml simple)
)
(define (vevent . rest)
(define v (make-vcomponent 'VEVENT))
(let loop ((rem rest))
(unless (null? rem)
(let ((symb (-> (car rem)
keyword->string
string-upcase
string->symbol)))
(set! (prop v symb)
(case symb
;; [(DTSTART EXDATE) (parse-ics-datetime (cadr rem))]
[(RRULE) (parse-recurrence-rule (cadr rem))]
[else (cadr rem)]))
;; hack for multi valued fields
(when (eq? symb 'EXDATE)
(set! (prop* v symb) = list)))
(loop (cddr rem))))
v)
(define ev
(vevent
summary: "Test Event #1"
uid: (uuid)
dtstart: #2021-12-21T10:30:00
dtend: #2021-12-21T11:45:00
dtstamp: (current-datetime)
))
(set!
(param (prop* ev 'DTSTART) 'TZID) "Europe/Stockholm"
(param (prop* ev 'DTEND) 'TZID) "Europe/Stockholm")
(define zoneinfo
(zoneinfo->vtimezone (zoneinfo '("tzdata/europe"))
"Europe/Stockholm" ev))
(define cal (make-vcomponent 'VCALENDAR))
(set!
(prop cal 'PRODID) "-//hugo//calp TEST//EN"
(prop cal 'VERSION) "2.0")
(add-child! cal zoneinfo)
(add-child! cal ev)
(define sxcal
`(*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"")
,(ns-wrap (vcomponent->sxcal cal))))
(define (main args)
(for-each (lambda (fmt)
(define parts (map string->symbol (string-split fmt #\:)))
(case (car parts)
((sxcal)
(if (memv 'pretty (cdr parts))
(format #t "~y" sxcal)
(begin (write sxcal) (newline))))
((ical) (component->ical-string cal))
((xml)
(let ((pipe (open-output-pipe
(string-join
(append '("cat")
(if (memv 'pretty (cdr parts)) '("xmllint --format -") '())
(if (memv 'color (cdr parts)) '("highlight -Oansi --syntax=xml") '()))
"|"))))
(sxml->xml sxcal pipe)
(close-pipe pipe)
(newline)))
((newline) (newline))
(else (format #t "Unknown mode [~a]~%" (car parts)))))
(cdr args)))
;; (write sxcal)
;;
;; (newline)
;; (newline)
;;
;; (format #t "~y" sxcal)
;;
;; (newline)
;;
;; (let ((pipe (open-pipe* OPEN_WRITE "highlight" "-Oansi" "--syntax=xml")))
;; ((@ (sxml simple) sxml->xml) sxcal pipe)
;; (close-pipe pipe))
;; (newline)
;;
;; (let ((pipe (open-pipe "xmllint --format - | highlight -Oansi --syntax=xml"
;; OPEN_WRITE
;; )))
;; (sxml->xml sxcal pipe)
;; (close-pipe pipe))
;; (newline)
;;
;;
;; (newline)
;; (component->ical-string cal)
|
