Porting to new calendar modules.

src/Makefile

@@ -31,20 +31,20 @@ static: ../hackerbase
 
 CSC=csc
 
-HACKERBASE-DEPS=hackerbase.scm month.import.scm				\
+HACKERBASE-DEPS=hackerbase.scm cal-month.import.scm			\
 	command-line.import.scm mbase.import.scm brmember.import.scm	\
 	configuration.import.scm cards.import.scm			\
 	members-print.import.scm members-payments.import.scm		\
 	web-static.import.scm environment.import.scm			\
 	mailman.import.scm texts.import.scm tests.import.scm		\
 	notifications.import.scm logging.import.scm			\
-	progress.import.scm period.import.scm
+	progress.import.scm cal-period.import.scm
 
-HACKERBASE-OBJS=hackerbase.o testing.o listing.o month.o period.o	\
+HACKERBASE-OBJS=hackerbase.o testing.o listing.o cal-month.o		\
-	 ansi.o util-dict-list.o command-line.o mbase.o primes.o	\
+	 cal-period.o ansi.o util-dict-list.o command-line.o mbase.o	\
-	 brmember.o configuration.o progress.o table.o cards.o		\
+	 primes.o brmember.o configuration.o progress.o table.o		\
-	 members-print.o members-fees.o mbase-dir.o util-csv.o		\
+	 cards.o members-print.o members-fees.o mbase-dir.o		\
-	 bank-account.o bank-fio.o members-payments.o			\
+	 util-csv.o bank-account.o bank-fio.o members-payments.o	\
 	 brmember-parser.o web-static.o environment.o mailman.o		\
 	 util-set-list.o util-time.o util-tag.o util-io.o		\
 	 util-string.o util-io.o util-list.o util-parser.o texts.o	\
@@ -106,17 +106,6 @@ UTIL-DICT-LIST-SOURCES=util-dict-list.scm testing.import.scm	\
 util-dict-list.o: util-dict-list.import.scm
 util-dict-list.import.scm: $(UTIL-DICT-LIST-SOURCES)
 
-MONTH-SOURCES=month.scm testing.import.scm
-
-month.o: month.import.scm
-month.import.scm: $(MONTH-SOURCES)
-
-PERIOD-SOURCES=period.scm testing.import.scm month.import.scm	\
-	configuration.import.scm
-
-period.o: period.import.scm
-period.import.scm: $(PERIOD-SOURCES)
-
 ANSI-SOURCES=ansi.scm testing.import.scm util-list.import.scm
 
 ansi.o: ansi.import.scm
@@ -130,9 +119,10 @@ command-line.import.scm: $(COMMAND-LINE-SOURCES)
 
 MBASE-SOURCES=mbase.scm testing.import.scm util-dict-list.import.scm	\
 	 primes.import.scm brmember.import.scm ansi.import.scm		\
-	 period.import.scm month.import.scm configuration.import.scm	\
+	 cal-period.import.scm cal-month.import.scm				\
-	 progress.import.scm table.import.scm mbase-dir.import.scm	\
+	 configuration.import.scm progress.import.scm			\
-	 util-list.import.scm util-tag.import.scm
+	 table.import.scm mbase-dir.import.scm util-list.import.scm	\
+	 util-tag.import.scm
 
 mbase.o: mbase.import.scm
 mbase.import.scm: $(MBASE-SOURCES)
@@ -148,7 +138,7 @@ primes.o: primes.import.scm
 primes.import.scm: $(PRIMES-SOURCES)
 
 BRMEMBER-SOURCES=brmember.scm util-dict-list.import.scm			\
-	period.import.scm testing.import.scm month.import.scm	\
+	cal-period.import.scm testing.import.scm cal-month.import.scm	\
 	configuration.import.scm primes.import.scm			\
 	bank-account.import.scm util-list.import.scm			\
 	util-tag.import.scm
@@ -156,8 +146,7 @@ BRMEMBER-SOURCES=brmember.scm util-dict-list.import.scm		\
 brmember.o: brmember.import.scm
 brmember.import.scm: $(BRMEMBER-SOURCES)
 
-CONFIGURATION-SOURCES=configuration.scm month.import.scm	\
+CONFIGURATION-SOURCES=configuration.scm util-parser.import.scm
-	util-parser.import.scm
 
 configuration.o: configuration.import.scm
 configuration.import.scm: $(CONFIGURATION-SOURCES)
@@ -180,8 +169,8 @@ cards.o: cards.import.scm
 cards.import.scm: $(CARDS-SOURCES)
 
 BRMEMBER-PARSER-SOURCES=brmember-parser.scm brmember.import.scm		\
-	testing.import.scm util-dict-list.import.scm month.import.scm	\
+	testing.import.scm util-dict-list.import.scm cal-month.import.scm	\
-	period.import.scm configuration.import.scm			\
+	cal-period.import.scm configuration.import.scm			\
 	util-string.import.scm util-list.import.scm			\
 	util-parser.import.scm
 
@@ -189,8 +178,8 @@ brmember-parser.o: brmember-parser.import.scm
 brmember-parser.import.scm: $(BRMEMBER-PARSER-SOURCES)
 
 MEMBERS-PRINT-SOURCES=members-print.scm util-dict-list.import.scm	\
-	brmember.import.scm month.import.scm table.import.scm		\
+	brmember.import.scm cal-month.import.scm table.import.scm		\
-	listing.import.scm ansi.import.scm period.import.scm		\
+	listing.import.scm ansi.import.scm cal-period.import.scm		\
 	primes.import.scm mbase.import.scm configuration.import.scm	\
 	bank-account.import.scm members-fees.import.scm			\
 	members-payments.import.scm util-list.import.scm		\
@@ -200,7 +189,7 @@ members-print.o: members-print.import.scm
 members-print.import.scm: $(MEMBERS-PRINT-SOURCES)
 
 MEMBERS-FEES-SOURCES=members-fees.scm configuration.import.scm	\
-	brmember.import.scm month.import.scm table.import.scm	\
+	brmember.import.scm cal-month.import.scm table.import.scm	\
 	mbase.import.scm specification.import.scm		\
 	util-list.import.scm
 
@@ -233,7 +222,7 @@ bank-fio.import.scm: $(BANK-FIO-SOURCES)
 
 MEMBERS-PAYMENTS-SOURCES=members-payments.scm bank-account.import.scm	\
 	util-dict-list.import.scm members-fees.import.scm		\
-	period.import.scm configuration.import.scm			\
+	cal-period.import.scm configuration.import.scm			\
 	progress.import.scm bank-fio.import.scm util-list.import.scm	\
 	specification.import.scm
 
@@ -354,7 +343,7 @@ LOGGING-SOURCES=logging.scm util-string.import.scm
 logging.o: logging.import.scm
 logging.import.scm: $(LOGGING-SOURCES)
 
-SPECIFICATION-SOURCES=specification.scm period.import.scm
+SPECIFICATION-SOURCES=specification.scm cal-period.import.scm
 
 specification.o: specification.import.scm
 specification.import.scm: $(SPECIFICATION-SOURCES)

src/brmember-parser.scm

@@ -38,8 +38,8 @@
 	 brmember
 	 testing
 	 util-dict-list
-	 month
+	 cal-month
-	 period
+	 cal-period
 	 util-list
 	 configuration
 	 util-string
@@ -81,7 +81,7 @@
 		    (kind (cadr mk)))
 	       (foldl (lambda (mr value)
 			(let* ((mspec (string-first+rest (car value)))
-			       (month (string->month (car mspec)))
+			       (month (string->cal-month (car mspec)))
 			       (comment (cdr mspec)))
 			  (if month
 			      (brmember-sub-prepend
@@ -95,7 +95,7 @@
       ,(lambda (mr output key value)
 	 (case key
 	   ((student suspend member)
-	    (let* ((res (period-markers->periods value))
+	    (let* ((res (period-markers->cal-periods value))
 		   (ok? (car res))
 		   (periods (cadr res))
 		   (msg (caddr res))

src/brmember.scm

@@ -84,8 +84,8 @@
 	 (chicken format)
 	 util-dict-list
 	 testing
-	 month
+	 cal-month
-	 period
+	 cal-period
 	 configuration
 	 primes
 	 util-list
@@ -273,14 +273,14 @@
 	(let ((member (brmember-info mr 'member)))
 	  (if (null? member)
 	      #f
-	      (month>=? (*current-month*)
+	      (cal-month>=? (*current-month*)
-			(period-since (car member)))))))
+			    (cal-period-since (car member)))))))
 
  ;; Generic period-based predicate
  (define ((member-period-predicate? key) mr)
    (let ((periods (brmember-info mr key #f)))
      (and periods
-	  (month-in-periods? periods))))
+	  (cal-month-in-periods? periods))))
 
  ;; Returns true if the member is now suspended
  (define member-is-suspended?
@@ -302,12 +302,12 @@
 
  ;; Returns true if the member is active (not suspended or destroyed).
  (define (brmember-active? mr)
-   (and (month-in-periods? (brmember-info mr 'member))
+   (and (cal-month-in-periods? (brmember-info mr 'member))
 	(not (brmember-suspended? mr))))
 
  ;; Returns true if the member is currently a member
  (define (brmember-existing? mr)
-   (month-in-periods?
+   (cal-month-in-periods?
     (brmember-info mr 'member)))
 
  ;; Returns a list of flags of given member record.
@@ -331,9 +331,9 @@
  ;; suspended.
  (define (brmember-suspended-months mr)
    (if (brmember-suspended? mr)
-       (let ((period (periods-match (brmember-info mr 'suspend))))
+       (let ((period (cal-periods-match (brmember-info mr 'suspend))))
 	 (if period
-	     (month-diff (car period) (*current-month*))
+	     (cal-month-diff (cal-period-since period) (*current-month*))
 	     0))
        0))
 
@@ -352,8 +352,8 @@
  (define (brmember-payments mr)
    (filter (lambda (tr)
 	     (let* ((isodate (bank-transaction-date tr))
-			 (month (iso-date->month isodate)))
+		    (month (iso-date->cal-month isodate)))
-		    (month<=? month (*current-month*))))
+		    (cal-month<=? month (*current-month*))))
 	   (ldict-ref mr 'payments '())))
 
  ;; Returns a list of MLs this member is subscribed to

src/configuration.scm

@@ -46,7 +46,6 @@
 	 (chicken time posix)
 	 (chicken file)
 	 (chicken io)
-	 month
 	 util-parser)
 
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

src/mbase.scm

@@ -73,8 +73,8 @@
 	 primes
 	 brmember
 	 ansi
-	 period
+	 cal-period
-	 month
+	 cal-month
 	 configuration
 	 progress
 	 mbase-dir
@@ -224,7 +224,7 @@
      di7))
 
  (define (members-base-oldest-month mb)
-   (make-month 2015 1))
+   (make-cal-month 2015 1))
 
  ;; Returns a list two lists: keys, data.
  ;; Each data record contains values for all keys.
@@ -232,14 +232,14 @@
    (let ((keys '(month total active suspended students destroyed invalid)))
      (let mloop ((data '())
 		 (month (members-base-oldest-month mb)))
-       (if (month<? month (*current-month*))
+       (if (cal-month<? month (*current-month*))
 	   (let ((bi (parameterize ((*current-month* month))
 		       (mbase-info mb))))
 	     (let kloop ((row (list (ldict-ref bi 'month)))
 			 (keys (cdr keys)))
 	       (if (null? keys)
 		   (mloop (cons (reverse row) data)
-			  (month-add month 1))
+			  (cal-month-add month 1))
 		   (kloop (cons (length (ldict-ref bi (car keys))) row)
 			  (cdr keys)))))
 	   (list keys (reverse data))))))

src/members-fees.scm

@@ -47,17 +47,17 @@
 	 (chicken sort)
 	 configuration
 	 brmember
-	 month
+	 cal-month
 	 ansi
 	 table
 	 mbase
-	 period
+	 cal-period
 	 specification
 	 util-list)
 
  ;; Returns a matching list of (list regular student)
  (define (lookup-member-fees)
-   (lookup-by-period member-fees-lookup-table))
+   (lookup-by-cal-period member-fees-lookup-table))
 
  ;; Returns time-based fee for given type
  (define (lookup-member-fee type)
@@ -74,12 +74,12 @@
    (let ((last-month (if (null? args)
 			 (*current-month*)
 			 (car args)))
-	 (first-month (period-since (car (brmember-info mr 'member)))))
+	 (first-month (cal-period-since (car (brmember-info mr 'member)))))
      (let loop ((cm first-month)
 		(cal '()))
-       (if (month>? cm last-month)
+       (if (cal-month>? cm last-month)
 	   (reverse cal)
-	   (loop (month-add cm)
+	   (loop (cal-month-add cm)
 		 (cons (list cm
 			     (parameterize ((*current-month* cm))
 			       (brmember-flags mr)))
@@ -134,8 +134,8 @@
        '()
        (let* ((fm (member-calendar-first-month mc))
 	      (lm (member-calendar-last-month mc))
-	      (fy (month-year fm))
+	      (fy (cal-month-year fm))
-	      (ly (month-year lm)))
+	      (ly (cal-month-year lm)))
 	 (let loop ((y fy)
 		    (rows '()))
 	   (if (> y ly)
@@ -147,7 +147,7 @@
 				 (reverse row)
 				 (mloop (add1 m)
 					(cons (member-calendar-entry->string
-					       (member-calendar-query mc (make-month y m)))
+					       (member-calendar-query mc (make-cal-month y m)))
 					      row))))
 			   rows)))))))
 

src/members-payments.scm

@@ -52,7 +52,7 @@
 	 bank-fio
 	 util-dict-list
 	 members-fees
-	 period
+	 cal-period
 	 configuration
 	 util-list
 	 progress
@@ -64,7 +64,7 @@
 
  ;; Lookup CZK/EUR
  (define (lookup-eur-rate)
-   (car (lookup-by-period exchange-rates-lookup-table)))
+   (car (lookup-by-cal-period exchange-rates-lookup-table)))
 
  ;; Extract probable member-id from transaction
  (define (transaction-extract-member-id transaction)

src/month.scm

@@ -1,192 +0,0 @@
-;;
-;; month.scm
-;;
-;; Month processing support.
-;;
-;; ISC License
-;;
-;; Copyright 2023 Brmlab, z.s.
-;; Dominik Pantůček <dominik.pantucek@trustica.cz>
-;;
-;; Permission to use, copy, modify, and/or distribute this software
-;; for any purpose with or without fee is hereby granted, provided
-;; that the above copyright notice and this permission notice appear
-;; in all copies.
-;; 
-;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
-;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
-;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
-;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
-;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
-;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
-;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
-;;
-
-(declare (unit month))
-
-(module
- month
- (
-  make-month
-  month-year
-  month-month
-  month-valid?
-  string->month
-  month->string
-  month=?
-  month<?
-  month<=?
-  month>=?
-  month>?
-  month-diff
-  month-add
-  iso-date->month
-  month-tests!
-  )
-
- (import scheme
-	 (chicken base)
-	 (chicken string)
-	 (chicken format)
-	 testing)
-
- ;; Simple wrapper for creating month representation as a list.
- (define (make-month y m)
-   (list y m))
-
- ;; Accessors
- (define month-year car)
- (define month-month cadr)
-
- ;; Returns true if this is a valid month representation - a list with
- ;; two integer elements within the allowed range.
- (define (month-valid? m)
-   (and (list? m)
-	(car m)
-	(cdr m)
-	(cadr m)
-	(null? (cddr m))
-	(integer? (car m))
-	(integer? (cadr m))
-	(>= (car m) 1000)
-	(<= (car m) 9999)
-	(>= (cadr m) 1)
-	(<= (cadr m) 12)))
-
- ;; Converts string in a format YYYY-MM to valid month. Returns #f if
- ;; the conversion fails.
- (define (string->month s)
-   (let ((l (string-split s "-")))
-     (if (or (not l)
-	     (null? l)
-	     (null? (cdr l))
-	     (not (null? (cddr l))))
-	 #f
-	 (let ((y (string->number (car l)))
-	       (m (string->number (cadr l))))
-	   (if (and y m)
-	       (let ((M (list y m)))
-		 (if (month-valid? M)
-		     M
-		     #f))
-	       #f)))))
-
- ;; Formats (valid) month as YYYY-MM string
- (define (month->string M)
-   (if M
-       (if (month-valid? M)
-	   (let ((y (car M))
-		 (m (cadr M)))
-	     (sprintf "~A-~A~A"
-		      y
-		      (if (< m 10) "0" "")
-		      m))
-	   (error 'string->month "Invalid month" M))
-       "____-__"))
-
- ;; Returns true if both arguments are a valid month and are equal
- (define (month=? m n)
-   (and (month-valid? m)
-	(month-valid? n)
-	(equal? m n)))
-
- ;; Returns true if the first argument is a month in the past of the
- ;; second argument month
- (define (month<? m n)
-   (and (month-valid? m)
-	(month-valid? n)
-	(or (< (car m) (car n))
-	    (and (= (car m) (car n))
-		 (< (cadr m) (cadr n))))))
-
- ;; Returns true if m is less than or equal n
- (define (month<=? m n)
-   (or (month<? m n)
-       (month=? m n)))
-
- ;; Returns true if m is greater than or equal to n
- (define (month>=? m n)
-   (not (month<? m n)))
-
- ;; Returns true if m is greater than n
- (define (month>? m n)
-   (not (month<=? m n)))
-
- ;; Returns the number of months between from f and to t. The first
- ;; month is included in the count, the last month is not.
- (define (month-diff f t)
-   (if (month-valid? f)
-       (if (month-valid? t)
-	   (let ((F (+ (* (car f) 12) (cadr f) -1))
-		 (T (+ (* (car t) 12) (cadr t) -1)))
-	     (- T F))
-	   (error 'month-diff "Second argument is not a valid month" t))
-       (error 'month-diff "First argument is not a valid month" f)))
-
- ;; Returns a month n months after the month m. The number n defaults
- ;; to 1.
- (define (month-add m . ns)
-   (let* ((n (if (null? ns)
-		 1
-		 (car ns)))
-	  (mi (+ (* 12 (car m)) (cadr m) n -1)))
-     (list (quotient mi 12)
-	   (+ (remainder mi 12) 1))))
-
- ;; Converts ISO date to single month
- (define (iso-date->month str)
-   (let* ((lst (string-split str "-"))
-	  (year (car lst))
-	  (mon (cadr lst)))
-     (make-month (string->number year)
-		 (string->number mon))))
-
- ;; Performs self-tests of the month module.
- (define (month-tests!)
-   (run-tests
-    month
-    (test-true month-valid? (month-valid? '(2023 5)))
-    (test-false month-valid? (month-valid? '(999 8)))
-    (test-false month-valid? (month-valid? '(2023 -5)))
-    (test-equal? string->month (string->month "2023-01") '(2023 1))
-    (test-false string->month (string->month "2023-13"))
-    (test-false string->month (string->month "YYYY-01"))
-    (test-false string->month (string->month "2023-MMM"))
-    (test-equal? month->string (month->string '(2023 1)) "2023-01")
-    (test-exn month->string (month->string '(999 12)))
-    (test-exn month->string (month->string '(2023 13)))
-    (test-true month<? (month<? '(2023 5) '(2023 6)))
-    (test-true month<? (month<? '(2022 12) '(2023 1)))
-    (test-false month<? (month<? '(2023 1) '(2023 1)))
-    (test-false month<? (month<? '(2023 1) '(2023 1)))
-    (test-true month=? (month=? '(2023 4) '(2023 4)))
-    (test-false month=? (month=? '(2023 4) '(2023 5)))
-    (test-eq? month-diff (month-diff '(2023 1) '(2023 2)) 1)
-    (test-eq? month-diff (month-diff '(2023 1) '(2023 12)) 11)
-    (test-eq? month-diff (month-diff '(2023 1) '(2022 2)) -11)
-    (test-eq? month-add (month-add '(2023 1) 2) '(2023 3))
-    (test-equal? iso-date->month (iso-date->month "2023-04-03") '(2023 4))
-    ))
-
- )

src/period.scm

@@ -1,284 +0,0 @@
-;;
-;; period.scm
-;;
-;; Month periods.
-;;
-;; ISC License
-;;
-;; Copyright 2023 Brmlab, z.s.
-;; Dominik Pantůček <dominik.pantucek@trustica.cz>
-;;
-;; Permission to use, copy, modify, and/or distribute this software
-;; for any purpose with or without fee is hereby granted, provided
-;; that the above copyright notice and this permission notice appear
-;; in all copies.
-;; 
-;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
-;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
-;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
-;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
-;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
-;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
-;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
-;;
-
-(declare (unit period))
-
-(module
- period
- (
-  *current-month*
-  
-  make-period
-
-  period-since
-  period-before
-  period-scomment
-  period-bcomment
-  
-  period-markers->periods
-  
-  periods-duration
-  
-  month-in-period?
-  month-in-periods?
-  
-  periods->string
-  periods-match
-  
-  make-period-lookup-table
-  lookup-by-period
-  
-  period-tests!
-  )
-
- (import scheme
-	 (chicken base)
-	 (chicken sort)
-	 (chicken time)
-	 (chicken time posix)
-	 (chicken format)
-	 (chicken string)
-	 month
-	 testing
-	 configuration)
-
- ;; Current month - if changed, we get the actual state for given month.
- (define *current-month*
-   (make-parameter
-    (let ((d (seconds->local-time (current-seconds))))
-      (list (+ 1900 (vector-ref d 5))
-	    (+ (vector-ref d 4) 1)))))
-
- ;; Creates a new period value with optional since and before
- ;; comments.
- (define (make-period since before . args)
-   (let ((scomment (if (not (null? args)) (car args) #f))
-	 (bcomment (if (and (not (null? args))
-			    (not (null? (cdr args))))
-		       (cadr args)
-		       #f)))
-     (list since before scomment bcomment)))
-
- ;; Simple accessors
- (define period-since car)
- (define period-before cadr)
- (define period-scomment caddr)
- (define period-bcomment cadddr)
-
- ;; Sorts period markers (be it start or end) chronologically and
- ;; returns the sorted list.
- (define (sort-period-markers l)
-   (sort l
-	 (lambda (a b)
-	   (month<? (cadr a) (cadr b)))))
-
- ;; Converts list of start/stop markers to list of pairs of months -
- ;; periods.
- (define (period-markers->periods l)
-   (let loop ((l (sort-period-markers l))
-	      (ps '())
-	      (cb #f))
-     (if (null? l)
-	 (list #t
-	       (if cb
-		   (reverse (cons (make-period (car cb) #f (cadr cb)) ps))
-		   (reverse ps))
-	       ""
-	       -1)
-	 (let* ((marker (car l))
-		(rmt (if cb 'stop 'start))
-		(mtype (car marker))
-		(month (cadr marker))
-		(line-number (if (null? (cddr marker))
-				 #f
-				 (caddr marker)))
-		(comment (if (and line-number
-				  (not (null? (cdddr marker))))
-			     (cadddr marker)
-			     #f)))
-	   (if (eq? mtype rmt)
-	       (if cb
-		   (loop (cdr l)
-			 (cons (make-period (car cb) month (cadr cb) comment) ps)
-			 #f)
-		   (loop (cdr l)
-			 ps
-			 (list month comment)))
-	       (list #f
-		     (reverse ps)
-		     (sprintf "Invalid start/stop sequence marker ~A" marker)
-		     line-number))))))
-
- ;; Returns duration of period in months. Start is included, end is
- ;; not. The period contains the month just before the specified end.
- (define (period->duration p)
-   (let* ((b (period-since p))
-	  (e (period-before p))
-	  (e- (if e e (*current-month*))))
-     (month-diff b e-)))
-
- ;; Returns sum of periods lengths.
- (define (periods-duration l)
-   (apply + (map period->duration l)))
-
- ;; True if month belongs to given month period - start inclusive, end
- ;; exclusive.
- (define (month-in-period? p . ml)
-   (let ((m (if (null? ml)
-		(*current-month*)
-		(car ml))))
-     (and (or (not (period-before p))
-	      (month<? m (period-before p)))
-	  (not (month<? m (period-since p))))))
-
- ;; Returns true if given month is in at least one of the periods
- ;; given. Defaults to current month.
- (define (month-in-periods? ps . ml)
-   (let ((m (if (null? ml)
-		(*current-month*)
-		(car ml))))
-     (let loop ((ps ps))
-       (if (null? ps)
-	   #f
-	   (if (month-in-period? (car ps) m)
-	       #t
-	       (loop (cdr ps)))))))
-
- ;; Returns string representing a month period with possibly open end.
- (define (period->string p)
-   (sprintf "~A..~A"
-	    (month->string (period-since p))
-	    (month->string (period-before p))))
-
- ;; Returns a string representing a list of periods.
- (define (periods->string ps)
-   (string-intersperse
-    (map period->string ps)
-    ", "))
-
- ;; Finds a period the month matches and returns it. If no period
- ;; matches, it returns #f.
- (define (periods-match ps .  ml)
-   (let ((m (if (null? ml) (*current-month*) (car ml))))
-     (let loop ((ps ps))
-       (if (null? ps)
-	   #f
-	   (if (month-in-period? (car ps) m)
-	       (car ps)
-	       (loop (cdr ps)))))))
-
- ;; Creates lookup table from definition source
- (define (make-period-lookup-table source)
-   (let loop ((lst source)
-	      (res '())
-	      (prev #f))
-     (if (null? lst)
-	 (reverse
-	  (cons (cons (make-period (car prev) #f)
-		      (cdr prev))
-		res))
-	 (loop (cdr lst)
-	       (if prev
-		   (cons (cons (make-period (car prev) (caar lst))
-			       (cdr prev))
-			 res)
-		   res)
-	       (car lst)))))
-
- ;; Looks up current month and returns associated definitions
- (define (lookup-by-period table)
-   (let loop ((lst table))
-     (if (null? lst)
-	 #f
-	 (if (month-in-period? (caar lst))
-	     (cdar lst)
-	     (loop (cdr lst))))))
-
- ;; Performs self-tests of the period module.
- (define (period-tests!)
-   (run-tests
-    period
-    (test-equal? sort-period-markers
-		 (sort-period-markers '((start (2023 1)) (stop (2022 10)) (start (2022 3))))
-		 '((start (2022 3)) (stop (2022 10)) (start (2023 1))))
-    (test-equal? period-markers->periods
-	         (period-markers->periods
-		  '((start (2022 3)) (stop (2022 10)) (start (2023 1)) (stop (2023 4))))
-		 '(#t
-		   (((2022 3) (2022 10) #f #f)
-		    ((2023 1) (2023 4) #f #f))
-		   ""
-		   -1))
-    (test-equal? period-markers->periods-open
-	         (period-markers->periods
-		  '((start (2022 3)) (stop (2022 10)) (start (2023 1)) (stop (2023 4)) (start (2023 5))))
-		 '(#t
-		   (((2022 3) (2022 10) #f #f)
-		    ((2023 1) (2023 4) #f #f)
-		    ((2023 5) #f #f #f))
-		   ""
-		   -1))
-    (test-eq? period-duration
-	      (period->duration '((2023 1) (2023 4) #f #f)) 3)
-    (parameterize ((*current-month* (list 2023 4)))
-      (test-eq? period-duration
-		(period->duration '((2023 1) #f #f #f)) 3))
-    (test-eq? periods-duration
-	      (periods-duration '(((2022 3) (2022 10) #f #f)
-				  ((2023 1) (2023 4) #f #f)))
-	      10)
-    (test-true month-in-period?
-	       (month-in-period? '((2022 1) (2022 4) #f #f) '(2022 3)))
-    (test-false month-in-period?
-		(month-in-period? '((2022 1) (2022 4) #f #f) '(2022 5)))
-    (test-true month-in-periods?
-	       (month-in-periods? '(((2022 1) (2022 4) #f #f)
-				    ((2023 5) (2023 10) #f #f))
-				  '(2022 3)))
-    (test-true month-in-periods?
-	       (month-in-periods? '(((2022 1) (2022 4) #f #f)
-				    ((2023 5) (2023 10) #f #f))
-				  '(2023 7)))
-    (test-false month-in-periods?
-		(month-in-periods? '(((2022 1) (2022 4) #f #f)
-				     ((2023 5) (2023 10) #f #f))
-				   '(2022 10)))
-    (test-equal? period->string
-		 (period->string '((2022 1) (2022 4) #f #f))
-		 "2022-01..2022-04")
-    (test-equal? periods->string
-	         (periods->string '(((2022 1) (2022 4) #f #f)
-				    ((2022 12) (2023 2) #f #f)))
-		 "2022-01..2022-04, 2022-12..2023-02")
-    (test-false periods-match (periods-match '(((2022 1) (2022 4) #f #f)
-					       ((2022 12) (2023 2) #f #f))
-					     '(2022 5)))
-    (test-equal? periods-match (periods-match '(((2022 1) (2022 4) #f #f)
-						((2022 12) (2023 2) #f #f))
-					      '(2022 2))
-		 '((2022 1) (2022 4) #f #f))
-    ))
-
- )

src/specification.scm

@@ -34,16 +34,16 @@
   )
 
  (import scheme
-	 period)
+	 cal-period)
 
  ;; Convert into lookups - a list of (list period regular student)
  (define member-fees-lookup-table
-   (make-period-lookup-table
+   (make-cal-period-lookup-table
     '(((2010 1) 500 250))))
 
  ;; Exchange rates
  (define exchange-rates-lookup-table
-   (make-period-lookup-table
+   (make-cal-period-lookup-table
     '(((2010 1) 25))))
 
  ;; How long the member can be suspended without any action required?