From 740277522010a739b5927407a207a4cae4f49730 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 6 May 2019 16:16:30 +0200 Subject: Add marker on today in small calendar. --- module/output/html.scm | 15 +++++++++------ module/srfi/srfi-19/util.scm | 4 ++++ module/util.scm | 8 ++++++++ 3 files changed, 21 insertions(+), 6 deletions(-) (limited to 'module') 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)) + -- cgit v1.2.3