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
|
(define-module (calp html view calendar month)
:use-module (calp util)
:use-module (srfi srfi-1)
:use-module (srfi srfi-41)
:use-module (srfi srfi-41 util)
:use-module (datetime)
:use-module (calp html view calendar shared)
:use-module (calp html config)
:use-module (vcomponent)
:use-module ((vcomponent datetime)
:select (really-long-event?
events-between))
:use-module ((calp html vcomponent)
:select (make-block))
:use-module ((vcomponent group)
:select (group-stream get-groups-between))
)
;; (stream event-group) -> sxml
(define*-public (render-calendar-table key: events start-date end-date pre-start post-end #:allow-other-keys)
(define-values (long-events short-events)
;; TODO should be really-long-event? or event-spanning-midnight
(partition really-long-event? (stream->list (events-between pre-start post-end events))))
(define short-event-groups
(get-groups-between (group-stream (list->stream short-events))
pre-start post-end))
(define long-event-groups
(map (lambda (s)
(define e (date+ s (date day: 6)))
(cons* s e
(stream->list
(events-between s e (list->stream long-events)))))
(date-range pre-start post-end (date day: 7))))
`((script "const VIEW='month';")
(header (@ (class "table-head"))
,(string-titlecase (date->string start-date "~B ~Y")))
(div (@ (class "caltable")
(style "grid-template-rows: 2em"
,(string-concatenate
(map (lambda (long-group)
(format #f " [time] 15pt [long] ~amm [short] 1fr"
(min 10 (* 4 (length (cddr long-group))))))
long-event-groups))))
,@(map (lambda (d) `(div (@ (class "thead")) ,(string-titlecase (week-day-name d))))
(weekday-list))
,@(map (lambda (group i)
(let* (((s e . events) group))
`(div (@ (class "cal-cell longevents event-container")
(style "grid-area: long " ,i ";"
"grid-column: 1 / span 7;")
(data-start ,(date->string s))
(data-end ,(date->string (add-day e))))
,@(lay-out-long-events
s e events))))
long-event-groups
(iota (length long-event-groups) 1))
,@(caltable-time-cells start-date end-date
pre-start post-end)
,@(stream->list
(stream-map
(lambda (group i)
(define day-date (car group))
(define events (cdr group))
`(div (@ (style "grid-area:short " ,i)
(class "cal-cell cal-cell-short event-container")
(data-start ,(date->string day-date))
(data-end ,(date->string (add-day day-date))))
(div (@ (style "overflow-y:auto;"))
,@(map make-small-block (stream->list events)))))
short-event-groups
(repeating-naturals 1 7)
)))
;; These popups are relative the document root. Can thus be placed anywhere in the DOM.
,@(for event in (stream->list
(events-between start-date end-date events))
((@ (calp html vcomponent) popup) event
(string-append "popup" ((@ (calp html util) html-id) event))))
))
;;; Table output
(define (make-small-block event)
(make-block event))
(define (caltable-time-cells start-date end-date
pre-start post-end)
(map (lambda (day-date i)
`(div (@ (style "grid-area:time " ,i)
(class "cal-cell cal-cell-time"))
(a (@ (class "hidelink")
(href "/week/" ,(date->string day-date "~Y-~m-~d")
".html#" ,(date->string day-date "~Y-~m-~d")))
(time (@ (class "date-info "
,(if (or (date< day-date start-date)
(date< end-date day-date))
"non-current"
"current"))
(datetime ,(date->string day-date "~1")))
(span (@ (class "day-number"))
,(date->string day-date "~e"))
,(when (= 1 (day day-date))
`(span (@ (class "month-name"))
,(date->string day-date "~b")))
,(when (= 1 (month day-date) (day day-date))
`(span (@ (class "year-number"))
", " ,(date->string day-date "~Y")))))))
(date-range pre-start post-end)
(map floor (iota (length (date-range pre-start post-end)) 1 1/7))))
|
