From 9c94e6ec731ce433aadf12eae22d50e8fec7a91b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 23 Jun 2022 23:46:57 +0200 Subject: Remove (add|remove)-day, and month[+-]. Procedures where overly specific, and doing it manually was almost no more work. --- doc/ref/guile/datetime.texi | 10 ---------- module/calp/entry-points/html.scm | 3 ++- module/calp/html/caltable.scm | 4 ++-- module/calp/html/view/calendar/month.scm | 4 ++-- module/calp/html/view/calendar/week.scm | 4 ++-- module/calp/html/view/small-calendar.scm | 9 +++++---- module/calp/server/routes.scm | 6 +++--- module/calp/terminal.scm | 4 ++-- module/datetime.scm | 30 +++++++----------------------- module/vcomponent/datetime.scm | 2 +- tests/test/datetime.scm | 28 ---------------------------- tests/test/html/caltable.scm | 5 ++++- 12 files changed, 30 insertions(+), 79 deletions(-) diff --git a/doc/ref/guile/datetime.texi b/doc/ref/guile/datetime.texi index d49c4ada..037ac8d5 100644 --- a/doc/ref/guile/datetime.texi +++ b/doc/ref/guile/datetime.texi @@ -282,11 +282,6 @@ Returns a stream of each week from @var{start-day} Returns the smaller (or larger) of @var{a} or @var{b}. @end defun -@defun month+ date [change=1] -@defunx month- date [change=1] -Equivalent to @code{(date+ date (date month: change))}. -@end defun - @defun week-day date Returns an integer representing the week day of @var{date}. @ref{sunday} @@ -355,11 +350,6 @@ month-date and end of month. Returns a list of all instances of @var{week-day} in @var{year-date}. @end defun -@defun add-day date -@defunx remove-day date -@code{@var{date} ± (date day: 1)} -@end defun - @defun in-date-range? start-date end-date → date → boolean Returns a predicate procedure, which checks if a given date is between @var{start-date} and @var{end-date}. diff --git a/module/calp/entry-points/html.scm b/module/calp/entry-points/html.scm index a324305b..2aa7e0e2 100644 --- a/module/calp/entry-points/html.scm +++ b/module/calp/entry-points/html.scm @@ -122,7 +122,8 @@ for embedding in a larger page. Currently only applies to the small style next-start: (lambda (d) (date+ d chunk-length)) prev-start: (lambda (d) (date- d chunk-length)) start-date: start-date - end-date: (remove-day (date+ start-date chunk-length)) + end-date: (date- (date+ start-date chunk-length) + (date day: 1)) render-calendar: render-calendar extra-args)))))) (stream-take count (date-stream chunk-length start-date)) diff --git a/module/calp/html/caltable.scm b/module/calp/html/caltable.scm index efaf8871..2c027c35 100644 --- a/module/calp/html/caltable.scm +++ b/module/calp/html/caltable.scm @@ -85,7 +85,7 @@ (lambda (d) (date<= d date (next-start d))) start-date)) "#" ,(date-link date))))) - (date-range pre-start (remove-day start-date))) + (date-range pre-start (date- start-date (date day: 1)))) ,@(map (td (lambda (date) `((href "#" ,(date-link date))))) @@ -101,4 +101,4 @@ (lambda (d) (and (date<= d date) (date< date (next-start d)))) start-date)) "#" ,(date-link date))))) - (date-range (add-day end-date) post-end)))) + (date-range (date+ end-date (date day: 1)) post-end)))) diff --git a/module/calp/html/view/calendar/month.scm b/module/calp/html/view/calendar/month.scm index d7cd24ae..1d151c77 100644 --- a/module/calp/html/view/calendar/month.scm +++ b/module/calp/html/view/calendar/month.scm @@ -59,7 +59,7 @@ (style "grid-area: long " ,i ";" "grid-column: 1 / span 7;") (data-start ,(date->string s)) - (data-end ,(date->string (add-day e)))) + (data-end ,(date->string (date+ e (date day: 1))))) ,@(lay-out-long-events s e events)))) long-event-groups @@ -76,7 +76,7 @@ `(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)))) + (data-end ,(date->string (date+ day-date (date day: 1))))) (div (@ (style "overflow-y:auto;")) ,@(map make-small-block (stream->list events))))) short-event-groups diff --git a/module/calp/html/view/calendar/week.scm b/module/calp/html/view/calendar/week.scm index ef630c36..caad8912 100644 --- a/module/calp/html/view/calendar/week.scm +++ b/module/calp/html/view/calendar/week.scm @@ -43,7 +43,7 @@ ,@(time-marker-div) (div (@ (class "longevents event-container") (data-start ,(date->string start-date) ) - (data-end ,(date->string (add-day end-date)) ) + (data-end ,(date->string (date+ end-date (date day: 1))) ) (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) @@ -139,7 +139,7 @@ `(div (@ (class "events event-container") (id ,(date-link day-date)) (data-start ,(date->string day-date)) - (data-end ,(date->string (add-day day-date)) )) + (data-end ,(date->string (date+ day-date (date day: 1))) )) ,@(map (lambda (time) `(div (@ (class "clock clock-" ,time)))) (iota 12 0 2)) diff --git a/module/calp/html/view/small-calendar.scm b/module/calp/html/view/small-calendar.scm index 4d40c57c..06a3342f 100644 --- a/module/calp/html/view/small-calendar.scm +++ b/module/calp/html/view/small-calendar.scm @@ -1,16 +1,17 @@ (define-module (calp html view small-calendar) :use-module ((calp html components) :select (xhtml-doc include-css)) :use-module ((calp html caltable) :select (cal-table)) - :use-module ((datetime) :select (month- month+ remove-day date->string)) + :use-module ((datetime) :select (date date+ date- date->string)) :export (render-small-calendar) ) (define (render-small-calendar month standalone) (define table (cal-table start-date: month - end-date: (remove-day (month+ month)) - next-start: month+ - prev-start: month- + end-date: (date- (date+ month (date month: 1)) + (date day: 1)) + next-start: (lambda (d) (date+ d (date day: 7))) + prev-start: (lambda (d) (date- d (date day: 7))) )) (if standalone (xhtml-doc diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm index 1fc31333..44fac7e8 100644 --- a/module/calp/server/routes.scm +++ b/module/calp/server/routes.scm @@ -175,10 +175,10 @@ (html-generate calendars: (get-calendars global-event-object) events: (get-event-set global-event-object) start-date: start-date - end-date: (date- (month+ start-date) + end-date: (date- (date+ start-date (date month: 1)) (date day: 1)) - next-start: month+ - prev-start: month- + next-start: (lambda (d) (date+ d (date month: 1))) + prev-start: (lambda (d) (date- d (date month: 1))) render-calendar: (@ (calp html view calendar month) render-calendar-table) pre-start: (start-of-week start-date) diff --git a/module/calp/terminal.scm b/module/calp/terminal.scm index 8f1b7fa9..ee3b7bc4 100644 --- a/module/calp/terminal.scm +++ b/module/calp/terminal.scm @@ -191,12 +191,12 @@ (case char ((#\L #\l right) - (set! (current-page this) = add-day + (set! (current-page this) = (date+ (date day: 1)) (cached-events this) #f (active-element this) 0)) ((#\h #\H left) - (set! (current-page this) = remove-day + (set! (current-page this) = (date- (date day: 1)) (cached-events this) #f (active-element this) 0)) diff --git a/module/datetime.scm b/module/datetime.scm index e3d0a462..de1b3076 100644 --- a/module/datetime.scm +++ b/module/datetime.scm @@ -66,9 +66,6 @@ datetime-min datetime-max - month+ - month- - week-day week-1-start week-number @@ -79,8 +76,6 @@ find-first-week-day all-wday-in-month all-wday-in-year - add-day - remove-day in-date-range? weekday-list @@ -421,12 +416,6 @@ (define (datetime-max a b) (if (datetime< a b) b a)) -(define* (month+ date-object optional: (change 1)) - (date+ date-object (date month: change))) - -(define* (month- date-object optional: (change 1)) - (date- date-object (date month: change))) - ;; https://projecteuclid.org/euclid.acta/1485888738 ;; 1. Begel. ;; J sei die Zahl des Jahrhunderts, @@ -575,11 +564,6 @@ (lambda (d) (= (year d) (year year-date))) (week-stream (find-first-week-day wday year-date))))) -(define (add-day d) - (date+ d (date day: 1))) - -(define (remove-day d) - (date- d (date day: 1))) (define (in-date-range? start-date end-date) (lambda (date) @@ -631,15 +615,15 @@ ;; ; ⇒ (2020-04-01 ... 2020-04-05) ;; @end lisp ;; Ignores day component of @var{date}. -(define* (month-days date optional: (week-start (week-start))) - (let* ((month-len (days-in-month date)) - (prev-month-len (days-in-month (month- date))) - (month-start (modulo (- (week-day date) week-start) 7))) +(define* (month-days date* optional: (week-start (week-start))) + (let* ((month-len (days-in-month date*)) + (prev-month-len (days-in-month (date- date* (date month: 1)))) + (month-start (modulo (- (week-day date*) week-start) 7))) (values - (map (lambda (d) (set (day (month- date)) d)) + (map (lambda (d) (set (day (date- date* (date month: 1))) d)) (iota month-start (1+ (- prev-month-len month-start)))) - (map (lambda (d) (set (day date) d)) (iota month-len 1)) - (map (lambda (d) (set (day (month+ date)) d)) + (map (lambda (d) (set (day date*) d)) (iota month-len 1)) + (map (lambda (d) (set (day (date+ date* (date month: 1))) d)) (iota (modulo (- (* 7 5) month-len month-start) 7) 1))))) diff --git a/module/vcomponent/datetime.scm b/module/vcomponent/datetime.scm index 73d74363..5c83f279 100644 --- a/module/vcomponent/datetime.scm +++ b/module/vcomponent/datetime.scm @@ -59,7 +59,7 @@ Event must have the DTSTART and DTEND protperty set." (define (event-contains? ev date/-time) "Does event overlap the date that contains time." (let* ((start (as-date date/-time)) - (end (add-day start))) + (end (date+ start (date day: 1)))) (event-overlaps? ev start end))) (define (event-zero-length? ev) diff --git a/tests/test/datetime.scm b/tests/test/datetime.scm index b2b97d45..f288bc4c 100644 --- a/tests/test/datetime.scm +++ b/tests/test/datetime.scm @@ -380,34 +380,6 @@ (datetime-max (datetime) (datetime hour: 1))) -;; month± mostly here for coverage, -;; actual tests are for date± -(test-equal "month+ dflt" - (date month: 3 day: 1) - (month+ (date month: 2 day: 1))) - -(test-equal "month+ given change" - (date month: 4 day: 1) - (month+ (date month: 2 day: 1) 2)) - -(test-equal "month- dflt" - (date month: 1 day: 1) - (month- (date month: 2 day: 1))) - -(test-equal "month- given change" - (date month: 2 day: 1) - (month- (date month: 4 day: 1) 2)) - -;; same for {add,remove}-day; mostly here for coverage. - -(test-equal "add-day" - (date month: 1 day: 2) - (add-day (date month: 1 day: 1))) - -(test-equal "remove-day" - (date month: 1 day: 1) - (remove-day (date month: 1 day: 2))) - ;; TODO more week-number tests (test-equal "Week 53" 53 (week-number #2020-12-28 mon)) diff --git a/tests/test/html/caltable.scm b/tests/test/html/caltable.scm index d9eeca3e..f64f8775 100644 --- a/tests/test/html/caltable.scm +++ b/tests/test/html/caltable.scm @@ -101,5 +101,8 @@ (time (@ (datetime "2022-05-01")) 1))) (parameterize ((week-start mon)) - (cal-table start-date: #2022-04-01 end-date: #2022-04-30 next-start: month+ prev-start: month-))) + (cal-table start-date: #2022-04-01 + end-date: #2022-04-30 + next-start: (lambda (d) (date+ d (date month: 1))) + prev-start: (lambda (d) (date- d (date month: 1)))))) -- cgit v1.2.3