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
120
121
|
(define-module (html view calendar week)
:use-module (util)
:use-module (srfi srfi-1)
:use-module (srfi srfi-41)
:use-module (datetime)
:use-module (html view calendar shared)
:use-module (html config)
:use-module (html util)
:use-module (vcomponent)
:use-module ((vcomponent datetime)
:select (long-event?
event-length/day
event-zero-length?
events-between))
:use-module ((html vcomponent)
:select (make-block) )
:use-module ((vcomponent group)
:select (group-stream get-groups-between))
)
(define*-public (render-calendar key: events start-date end-date #:allow-other-keys)
(let* ((long-events short-events (partition long-event? (stream->list (events-between start-date end-date events))))
(range (date-range start-date end-date)))
`((script "const VIEW='week';")
(div (@ (class "calendar"))
(div (@ (class "days"))
,@(time-marker-div)
(div (@ (class "longevents event-container")
(data-start ,(date->string start-date) )
(data-end ,(date->string (add-day end-date)) )
(style "grid-column-end: span " ,(days-in-interval start-date end-date)))
,@(lay-out-long-events start-date end-date long-events))
,@(map (lambda (day-date)
`(div (@ (class "meta"))
(span (@ (class "daydate"))
,(date->string day-date "~Y-~m-~d"))
(span (@ (class "dayname"))
,(string-titlecase (date->string day-date "~a")))))
range)
,@(stream->list
(stream-map
lay-out-day
(get-groups-between (group-stream (list->stream short-events))
start-date end-date)))
,@(for event in (stream->list
(events-between start-date end-date events))
((@ (html vcomponent ) popup) event (string-append "popup" (html-id event))))
)))))
(define (time-marker-div)
;; element to make rest of grid align correct.
;; Could be extended to contain something fun.
`((div (@ (style "grid-row: 1 / span 2")))
(div (@ (class "sideclock"))
,@(map (lambda (time)
`(div (@ (class "clock clock-" ,time))
(span (@ (class "clocktext"))
,time ":00")))
(iota 12 0 2)))))
;; Lay out complete day (graphical)
;; (date . (events)) -> sxml
(define (lay-out-day day)
(let* (((day-date . events) day)
(time-obj (datetime date: day-date))
(zero-length-events short-events
(partition event-zero-length? (stream->list events))))
(fix-event-widths! short-events event-length-key:
(lambda (e) (event-length/day day-date e)))
`(div (@ (class "events event-container") (id ,(date-link day-date))
(data-start ,(date->string day-date))
(data-end ,(date->string (add-day day-date)) ))
,@(map (lambda (time)
`(div (@ (class "clock clock-" ,time))))
(iota 12 0 2))
(div (@ (class "zero-width-events"))
,(map make-block zero-length-events))
,@(map (lambda (e) (create-block day-date e)) short-events))))
;; Format single event for graphical display
;; This is extremely simmilar to create-top-block, which currently recides in ./shared
(define (create-block date ev)
;; (define time (date->time-utc day))
(define left (* 100 (x-pos ev)))
(define width* (* 100 (width ev)))
(define top (if (date= date (as-date (prop ev 'DTSTART)))
(* 100/24
(time->decimal-hour
(as-time (prop ev 'DTSTART))))
0))
(define height (* 100/24 (time->decimal-hour (event-length/day date ev))))
(define style
;; The calc's here is to enable an "edit-mode".
;; Setting --editmode ≈ 0.8 gives some whitespace to the right
;; of the events, alowing draging there for creating new events.
(if (edit-mode)
(format #f "left:calc(var(--editmode)*~,3f%);width:calc(var(--editmode)*~,3f%);top:~,3f%;height:~,3f%;"
left width* top height)
(format #f "left:~,3f%;width:~,3f%;top:~,3f%;height:~,3f%;"
left width* top height)))
(make-block
ev `((class
,(when (date<? (as-date (prop ev 'DTSTART)) date)
" continued")
,(when (and (prop ev 'DTEND) (date<? date (as-date (prop ev 'DTEND))))
" continuing"))
(style ,style))))
|
