diff options
| author | Hugo Hörnquist <hugo@hornquist.se> | 2019-05-06 16:16:30 +0200 |
|---|---|---|
| committer | Hugo Hörnquist <hugo@hornquist.se> | 2019-05-06 17:58:37 +0200 |
| commit | 740277522010a739b5927407a207a4cae4f49730 (patch) | |
| tree | 4b8721c2169af0b2c3a41eb3f0f8265b35f3cbce | |
| parent | Add missing leading zeroes in minical. (diff) | |
| download | calp-740277522010a739b5927407a207a4cae4f49730.tar.gz calp-740277522010a739b5927407a207a4cae4f49730.tar.xz | |
Add marker on today in small calendar.
| -rw-r--r-- | module/output/html.scm | 15 | ||||
| -rw-r--r-- | module/srfi/srfi-19/util.scm | 4 | ||||
| -rw-r--r-- | module/util.scm | 8 | ||||
| -rw-r--r-- | static/style.css | 4 |
4 files changed, 25 insertions, 6 deletions
diff --git a/module/output/html.scm b/module/output/html.scm index 23a7b9ac..1614bc31 100644 --- a/module/output/html.scm +++ b/module/output/html.scm @@ -186,7 +186,7 @@ ;; 22 23 24 25 26 27 28 ;; 29 30 ;; @end example -(define (cal-table date) +(define (cal-table date today) (let ((td (lambda (p) (lambda (d) `(td (@ ,p) ,d))))) `(table (@ (class "small-calendar")) (thead (tr ,@(map (lambda (d) `(td ,d)) '(MÅ TI ON TO FR LÖ SÖ)))) @@ -197,10 +197,12 @@ (month-start (week-day date))) (append (map (td '(class "prev")) (iota month-start (- prev-month-len month-start))) - (map (td '(class "cur")) - (map (lambda (d) `(a (@ (href "#" ,(date->string date "~Y-~m-") - ,(when (< d 10) 0) ,d) - (class "hidelink")) ,d)) + (map (lambda (p) `(td (@ ,@(assq-merge '((class " cur ")) (cdar p))) + ,@(cdr p))) + (map (lambda (d) `((@ (class ,(when (= d (date-day today)) "today"))) + (a (@ (href "#" ,(date->string date "~Y-~m-") + ,(when (< d 10) 0) ,d) + (class "hidelink")) ,d))) (iota month-len 1))) (map (td '(class "next")) (iota (modulo (- (* 7 5) month-len month-start) 7) 1)))))) @@ -248,6 +250,7 @@ ,@(stream->list (stream-map lay-out-day evs)))) (aside (@ (class "sideinfo")) (div (@ (class "about")) - (div ,(cal-table (parse-freeform-date "2019-05-01")))) + (div ,(cal-table (start-of-month start) + (current-date)))) (div (@ (class "eventlist")) ,@(stream->list (stream-map fmt-day evs))))))))) diff --git a/module/srfi/srfi-19/util.scm b/module/srfi/srfi-19/util.scm index 792b46af..29f5450f 100644 --- a/module/srfi/srfi-19/util.scm +++ b/module/srfi/srfi-19/util.scm @@ -37,6 +37,10 @@ attribute set to 0. Can also be seen as \"Start of day\"" ((date-second) 0) ((date-nanosecond) 0))) + +(define-public (start-of-month date) + (set-fields date ((date-day) 1))) + (define-public (start-of-day* time) (date->time-utc (drop-time (time-utc->date time)))) diff --git a/module/util.scm b/module/util.scm index 62dc870a..dd5f3057 100644 --- a/module/util.scm +++ b/module/util.scm @@ -325,3 +325,11 @@ (module-use! (module-public-interface (current-module)) (resolve-interface '(mod ...))) ...)))) + +(define-public (assq-merge a b) + (fold (lambda (entry alist) + (let* (((k . v) entry) + (o (assq-ref alist k))) + (assq-set! alist k (append v (or o '()))))) + (copy-tree a) b)) + diff --git a/static/style.css b/static/style.css index 557aaa69..2d8e24ed 100644 --- a/static/style.css +++ b/static/style.css @@ -27,6 +27,10 @@ color: red; } +.small-calendar .today { + border: 1px solid black; +} + .text-day { border-left: 2px solid black; border-top: 2px solid black; |