diff options
| -rw-r--r-- | module/output/html.scm | 7 | ||||
| -rw-r--r-- | module/srfi/srfi-19/alt.scm | 31 | ||||
| -rw-r--r-- | module/srfi/srfi-19/alt/util.scm | 10 | ||||
| -rwxr-xr-x | tests/run-tests.scm | 2 | ||||
| -rw-r--r-- | tests/srfi-19-alt-compare.scm | 44 | ||||
| -rw-r--r-- | tests/srfi-19-alt.scm | 46 |
6 files changed, 88 insertions, 52 deletions
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))) diff --git a/tests/run-tests.scm b/tests/run-tests.scm index 4ffe6d4e..8d99eef7 100755 --- a/tests/run-tests.scm +++ b/tests/run-tests.scm @@ -57,7 +57,7 @@ (let ((modules (read))) (eval-in-sandbox `(begin ,@(read-multiple)) - #:time-limit 5 ; larger than should be needed + #:time-limit 60 ; larger than should be needed #:module (make-sandbox-module (append modules '(((srfi srfi-64) test-assert test-equal test-error) diff --git a/tests/srfi-19-alt-compare.scm b/tests/srfi-19-alt-compare.scm new file mode 100644 index 00000000..fb88361b --- /dev/null +++ b/tests/srfi-19-alt-compare.scm @@ -0,0 +1,44 @@ +(((srfi srfi-19 alt) + date + date< date<= + date> date>= + )) + +(test-assert "date< empty" + (date<)) + +(test-assert "date< single" + (date< #2020-01-10)) + +(test-assert "date< double" + (date< #2020-01-10 #2020-01-11)) + +(test-assert "date< tripple" + (date< #2020-01-10 #2020-01-11 #2020-01-12)) + +(test-assert "date< tripple negate" + (not (date< #2020-01-10 #2020-01-12 #2020-01-11))) + +(test-assert "date<= empty" + (date<=)) + +(test-assert "date<= single" + (date<= #2020-01-10)) + +(test-assert "date<= double" + (date<= #2020-01-10 #2020-01-11)) + +(test-assert "date<=" + (not (date<= #2020-01-01 #2018-05-15 #2020-01-31))) + +(test-assert "date<= equal" + (date<= #2018-05-15 #2018-05-15)) + +(test-assert "date<" + (not (date< #2020-01-01 #2018-05-15 #2020-01-31))) + +(test-assert "date>" + (not (date> #2020-01-31 #2018-05-15 #2020-01-01 ))) + +(test-assert "date>=" + (not (date>= #2020-01-31 #2018-05-15 #2020-01-01))) diff --git a/tests/srfi-19-alt.scm b/tests/srfi-19-alt.scm index 887af4fa..bebd104d 100644 --- a/tests/srfi-19-alt.scm +++ b/tests/srfi-19-alt.scm @@ -1,7 +1,6 @@ (((srfi srfi-19 alt) date+ date- year month day date time - date< datetime datetime+ datetime- @@ -16,7 +15,7 @@ (test-assert "Test year type" (integer? (year (date year: 2020)))) -(test-assert "Test month type" +(test-assert "Test mmnth type" (integer? (month (date month: 1)))) (test-assert "Test day type" @@ -87,43 +86,14 @@ (date day: 5))) -(test-assert "date< empty" - (date<)) -(test-assert "date< single" - (date< #2020-01-10)) +;; (test-assert +;; (datetime- #2018-01-17T10:00:00 +;; #2018-01-17T08:00:00)) -(test-assert "date< double" - (date< #2020-01-10 #2020-01-11)) -(test-assert "date< tripple" - (date< #2020-01-10 #2020-01-11 #2020-01-12)) - -(test-assert "date< tripple negate" - (not (date< #2020-01-10 #2020-01-12 #2020-01-11))) - -(test-assert "date<=" - (not (date<= #2020-01-01 #2018-05-15 #2020-01-31))) - -(test-assert "date<= equal" - (date<= #2018-05-15 #2020-01-01)) - -(test-assert "date<" - (not (date< #2020-01-01 #2018-05-15 #2020-01-31))) - -(test-assert "date>" - (not (date> #2020-01-31 #2018-05-15 #2020-01-01 ))) - -(test-assert "date>=" - (not (date>= #2020-01-31 #2018-05-15 #2020-01-01))) - -(test-assert - (datetime- #2018-01-17T10:00:00 - #2018-01-17T08:00:00)) - - -(test-assert - (datetime<=? (datetime time: (time hour: 24)) - (datetime- #2018-01-17T10:00:00 - #2018-01-17T08:00:00))) +;; (test-assert +;; (datetime<=? (datetime time: (time hour: 24)) +;; (datetime- #2018-01-17T10:00:00 +;; #2018-01-17T08:00:00))) |