From 033cf78ee6102ca104b04460abfbbfa84cf22cbf Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@hornquist.se>
Date: Mon, 3 Feb 2020 19:15:27 +0100
Subject: Fix date<=.

---
 module/output/html.scm           |  7 +++++--
 module/srfi/srfi-19/alt.scm      | 31 +++++++++++++++++++++++++------
 module/srfi/srfi-19/alt/util.scm | 10 +++++-----
 3 files changed, 35 insertions(+), 13 deletions(-)

(limited to 'module')

diff --git a/module/output/html.scm b/module/output/html.scm
index d64c7aa1..cf70b583 100644
--- a/module/output/html.scm
+++ b/module/output/html.scm
@@ -122,6 +122,9 @@
                                                                (attr ev 'DTSTART)))))
                                  (stream->list events))))
     ;; (format (current-error-port) "lay-out-day: ~a~%" (date->string date))
+    (format (current-error-port) "long=~a, short=~a~%"
+            (length long-events)
+            (length short-events))
     (fix-event-widths! time-obj short-events)
     (fix-event-widths! time-obj long-events)
     `(div (@ (class "day"))
@@ -184,7 +187,7 @@
 
 ;; For sidebar, just text
 (define (fmt-single-event ev)
-  (format (current-error-port) "fmt-single-event: ~a~%" (attr ev 'X-HNH-FILENAME))
+  ;; (format (current-error-port) "fmt-single-event: ~a~%" (attr ev 'X-HNH-FILENAME))
   `(article (@ (id ,(UID ev))
                (class "eventtext CAL_bg_"
                  ,(html-attr (attr (parent ev) 'NAME))))
@@ -201,7 +204,7 @@
 ;; Single event in side bar (text objects)
 (define (fmt-day day)
   (let* (((date . events) day))
-    (format (current-error-port) "fmt-day: ~a~%" (date->string date))
+    ;; (format (current-error-port) "fmt-day: ~a~%" (date->string date))
     `(section (@ (class "text-day"))
               (header (h2 ,(let ((s (date->string date "~Y-~m-~d")))
                              `(a (@ (href "#" ,s)
diff --git a/module/srfi/srfi-19/alt.scm b/module/srfi/srfi-19/alt.scm
index a9359a32..0d70a4f9 100644
--- a/module/srfi/srfi-19/alt.scm
+++ b/module/srfi/srfi-19/alt.scm
@@ -174,6 +174,17 @@
      (and (date<% first second)
           (apply date< second rest))]))
 
+(define (date<=% a b)
+  (or (date= a b)
+      (date< a b)))
+
+(define-public date<=
+  (match-lambda*
+    [() #t]
+    [(_) #t]
+    [(first second . rest)
+     (and (date<=% first second)
+          (apply date<= second rest))]))
 
 (define-public (time< a b)
   (let ((ah (hour a))
@@ -186,12 +197,20 @@
               (< am bm)))
         (< ah bh))))
 
+(define-public (time<= a b)
+  (or (time= a b)
+      (time< a b)))
 
 (define-public (datetime< a b)
   (if (date= (get-date a) (get-date b))
       (time< (get-time a) (get-time b))
       (date< (get-date a) (get-date b))))
 
+(define-public (datetime<= a b)
+  (if (date= (get-date a) (get-date b))
+      (time<= (get-time a) (get-time b))
+      (date<= (get-date a) (get-date b))))
+
 (define-public (date/-time< a b)
   (if (date< (as-date a) (as-date b))
       #t
@@ -200,18 +219,18 @@
 (define-many define-public
   (date<?) date<
   (date> date>?) (swap date<)
-  (date<= date<=?) (negate date>)
-  (date>= date>=?) (negate date<)
+  (date<=?) date<=
+  (date>= date>=?) (swap date<=)
 
   (time<?) time<
   (time> time>?) (swap time<)
-  (time<= time<=?) (negate time>)
-  (time>= time>=?) (negate time<)
+  (time<=?) time<=
+  (time>= time>=?) (swap time<=)
 
   (datetime<?) datetime<
   (datetime> datetime>?) (swap datetime<)
-  (datetime<= datetime<=?) (negate datetime>)
-  (datetime>= datetime>=?) (negate datetime<)
+  (datetime<=?) datetime<=
+  (datetime>= datetime>=?) (swap datetime<=)
 
   (date/-time<?) date/-time<
   (date/-time> date/-time>?) (swap date/-time<)
diff --git a/module/srfi/srfi-19/alt/util.scm b/module/srfi/srfi-19/alt/util.scm
index ba1d8dd8..8299c6cb 100644
--- a/module/srfi/srfi-19/alt/util.scm
+++ b/module/srfi/srfi-19/alt/util.scm
@@ -163,9 +163,9 @@
 
 (define-public (in-date-range? start-date end-date)
   (lambda (date)
-    (format (current-error-port) "in-date-range? ~a < ~a < ~a = ~a~%"
-            (date->string start-date)
-            (date->string date)
-            (date->string end-date)
-            (date<= start-date date end-date) )
+    ;; (format (current-error-port) "in-date-range? ~a < ~a < ~a = ~a~%"
+    ;;         (date->string start-date)
+    ;;         (date->string date)
+    ;;         (date->string end-date)
+    ;;         (date<= start-date date end-date) )
     (date<= start-date date end-date)))
-- 
cgit v1.2.3