From f821ccd218ab89449adc634e72f0197afec7f64e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sun, 16 Aug 2020 13:08:09 +0200 Subject: Work on small-calendar. --- module/html/caltable.scm | 89 +++++++++++++++++++++++++++++++++++++++++++ module/html/view/calendar.scm | 64 +------------------------------ 2 files changed, 90 insertions(+), 63 deletions(-) create mode 100644 module/html/caltable.scm diff --git a/module/html/caltable.scm b/module/html/caltable.scm new file mode 100644 index 00000000..fb2cbe02 --- /dev/null +++ b/module/html/caltable.scm @@ -0,0 +1,89 @@ +(define-module (html caltable) + :use-module (util) + :use-module (html util) + :use-module (datetime) + :use-module (srfi srfi-41) + ) + +;; Small calendar similar to the one below. +;; TODO highlight days depending on which events they contain +;; TODO run this standalone, for embedding in other websites. +;; @example +;; må ti on to fr lö sö +;; 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 +;; @end example +;; +;; start-date : +;; end-date : +;; next-start : → +;; prev-start : → +(define*-public (cal-table key: start-date end-date next-start prev-start) + + (define (->link date) + (date->string date "~Y-~m-~d.html")) + + ;; ( → sxml-attributes) → → sxml + (define (td attr) + (lambda (date) + `(a (@ ,@(attr date)) + ;; NOTE This time object is the correct place to show the existance + ;; of an event on a given day in this small calendar. For example + ;; making the text red for all holidays, or creating a yellow background + ;; for events from a specific source. + (time (@ (datetime ,(date->string date "~Y-~m-~d"))) + ,(day date))))) + + (define month-start (start-of-month start-date)) + (define pre-start (start-of-week month-start)) + (define month-end (end-of-month start-date)) + (define post-end (end-of-week month-end)) + + `(div (@ (class "small-calendar")) + + ;; Cell 0, 0. The letter v. for week number + (div (@ (class "column-head row-head")) "v.") + + ;; top row, names of week days + ,@(map (lambda (d) `(div (@ (class "column-head")) + ,(string-titlecase (week-day-name d 2)))) + (weekday-list)) + + ;; left columun, week numbers + ,@(map (lambda (v) `(div (@ (class "row-head")) ,v)) + (map week-number + (stream->list + (stream-take-while (lambda (s) (date<= s post-end)) + (week-stream pre-start))))) + + ;; actual days + + ,@(map (td (lambda (date) + `((class "prev") + (href ,(->link + ;; (prev-start date) + (iterate + prev-start + (lambda (d) (date<= d date (next-start d))) + start-date)) + "#" ,(date-link date))))) + (date-range pre-start (remove-day start-date))) + + + ,@(map (td (lambda (date) `((href "#" ,(date-link date))))) + (date-range start-date end-date)) + + + ,@(map (td (lambda (date) + `((class "next") + (href ,(->link + ;; (next-start date) + (iterate + next-start + (lambda (d) (and (date<= d date) + (date< date (next-start d)))) + start-date)) "#" ,(date-link date))))) + (date-range (add-day end-date) post-end)))) diff --git a/module/html/view/calendar.scm b/module/html/view/calendar.scm index db0debda..ac5bf77a 100644 --- a/module/html/view/calendar.scm +++ b/module/html/view/calendar.scm @@ -16,6 +16,7 @@ )) :use-module (html config) :use-module (html util) + :use-module ((html caltable) :select (cal-table)) :use-module (util config) @@ -31,69 +32,6 @@ ) -;; Small calendar similar to the one below. -;; TODO highlight days depending on which events they contain -;; TODO run this standalone, for embedding in other websites. -;; @example -;; må ti on to fr lö sö -;; 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 -;; @end example -;; date - The start date of the month to display -(define* (cal-table key: start-date end-date next-start prev-start) - - (define (td date) - `(a (@ ,@(cond - ;; We are before our time interval - [(date< date start-date) - ;; TODO find a prettier way to generate links to previous and next time intervals - `((class "prev") - (href ,(date->string - (stream-find (lambda (d) (date<= d date (next-start d))) - (stream-iterate prev-start start-date)) - "~Y-~m-~d.html") - "#" ,(date-link date)))] - ;; We are after our time interval - [(date< end-date date) - `((class "next") - (href ,(date->string - (stream-find (lambda (d) (and (date<= d date) - (date< date (next-start d)))) - (stream-iterate next-start start-date)) - "~Y-~m-~d.html") - "#" ,(date-link date)))] - ;; We are in our time interval - [else `((href "#" ,(date-link date)))])) - ;; NOTE This time object is the correct place to show the existance - ;; of an event on a given day in this small calendar. For example - ;; making the text red for all holidays, or creating a yellow background - ;; for events from a specific source. - (time (@ (datetime ,(date->string date "~Y-~m-~d"))) ,(day date)))) - - (let* ((last-months current next - (month-days (start-of-month start-date))) - (events (append last-months current next))) - `(div (@ (class "small-calendar")) - (div (@ (class "column-head row-head")) "v.") - ,@(map (lambda (d) `(div (@ (class "column-head")) - ,(string-titlecase (week-day-name d 2)))) - (weekday-list)) - ,@(let ((first (start-of-week (car events))) - (last (start-of-week (last events)))) - (map (lambda (v) `(div (@ (class "row-head")) ,v)) - (map (lambda (d) (week-number d)) - (stream->list - (stream-take-while (lambda (s) (date<= s last)) - (week-stream first)))))) - ,@(map td events - )))) - - - - ;;; Main-stuff -- cgit v1.2.3