Start replacing member record.

member-record-old.scm

@@ -0,0 +1,291 @@
+;;
+;; member-record.scm
+;;
+;; Procedures working with complete member record (as loaded by the
+;; members-base).
+;;
+;; 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 member-record))
+
+(module
+ member-record
+ (
+  print-member-record-info
+  print-member-record-table
+  member-destroyed?
+  member-suspended?
+  member-active?
+  member-student?
+  member-nick
+  member-id
+  member-existing?
+  member-format
+  member-suspended-months
+  member-source
+  print-member-source
+  member<?
+  member-record-tests!
+  )
+
+ (import scheme
+	 (chicken base)
+	 (chicken string)
+	 (chicken sort)
+	 (chicken format)
+	 dictionary
+	 period
+	 testing
+	 month
+	 member-file
+	 listing
+	 ansi
+	 configuration
+	 table
+	 utils)
+
+ ;; Prints human-readable information
+ (define (print-member-record-info mr)
+   (let* ((id (dict-ref mr 'id))
+	  (aliases (dict-ref mr 'symlinks))
+	  (info (dict-ref mr 'info))
+	  (sinfo (sort info
+		       (lambda (a b)
+			 (string<?
+			  (symbol->string (car a))
+			  (symbol->string (car b)))))))
+     (print "User " id " alias(es): "
+	    (string-intersperse
+	     (map symbol->string aliases)
+	     ", "))
+     (when (member-suspended? mr)
+       (print "  Suspended for " (member-suspended-months mr) " months."))
+     (newline)
+     (let loop ((sinfo sinfo))
+       (when (not (null? sinfo))
+	 (let* ((kv (car sinfo))
+		(k (car kv))
+		(v (cdr kv)))
+	   (when (not (eq? k member-file-error-symbol))
+	     (print "  " k ":\t"
+		    (if (member k '(student suspend))
+			(periods->string v)
+			v)))
+	   (loop (cdr sinfo)))))))
+
+ ;; Prints nicely formatted table
+ (define (print-member-record-table mr)
+   (let* ((aliases (mr-ref mr 'symlinks))
+	  (head (list (list "ID:" (mr-ref mr 'id))
+		      (list (sprintf "Alias~A:" (if (> (length aliases) 1) "es" ""))
+			    (string-intersperse (map symbol->string aliases) ", "))
+		      (if (member-suspended? mr)
+			  (list "Suspended for:"
+				(let ((msm (member-suspended-months mr)))
+				  (sprintf "~A month~A" msm
+					   (if (> msm 1) "s" ""))))
+			  #f)))
+	  (info (dict-ref mr 'info))
+	  (sikeys (sort (dict-keys info)
+			(lambda (a b)
+			  (string<?
+			   (symbol->string a)
+			   (symbol->string b)))))
+	  (body (map (lambda (k)
+		       (if (eq? k member-file-error-symbol)
+			   #f
+			   (let ((v (dict-ref info k)))
+			     (case k
+			       ((joined)
+				(list k (month->string v)))
+			       ((card desfire credit)
+				(list k
+				      (table->string
+				       (map
+					(lambda (c)
+					  (list (car c) (cdr c)))
+					v)
+				       #:col-border #t)))
+			       ((suspend student)
+				(list k
+				      (table->string
+				       (cons (list "Since" "Until")
+					     (map
+					      (lambda (p)
+						(list
+						 (month->string (car p))
+						 (month->string (cdr p))))
+					      v))
+				       #:col-border #t)))
+			       (else
+				(list k v))))))
+		     sikeys))
+	  (result (filter identity (append head body))))
+     (print (table->string result #:table-border #t #:row-border #t #:col-border #t))))
+
+ ;; Returns key from the top-level (members-base) record if it exists,
+ ;; queries the 'info key otherwise. Optional default argument works
+ ;; like with dict-ref.
+ (define (mr-ref mr key . dfl)
+   (if (dict-has-key? mr key)
+       (dict-ref mr key)
+       (if (null? dfl)
+	   (dict-ref (dict-ref mr 'info (make-dict)) key)
+	   (dict-ref (dict-ref mr 'info (make-dict)) key (car dfl)))))
+
+ ;; Returns true if the member record represents destroyed member. The
+ ;; *current-month* is a global parameter from period module.
+ (define (member-destroyed? mr)
+   (let ((destroyed (mr-ref mr 'destroyed #f)))
+     (and destroyed
+	  (month<? (string->month destroyed)
+		   (*current-month*)))))
+
+ ;; Generic period-based predicate
+ (define ((member-period-predicate? key) mr)
+   (let ((periods (mr-ref mr key #f)))
+     (and periods
+	  (month-in-periods? periods))))
+
+ ;; Returns true if the member is now suspended
+ (define member-is-suspended?
+   (member-period-predicate? 'suspend))
+
+ ;; Suspended must not be destroyed
+ (define (member-suspended? mr)
+   (and (member-is-suspended? mr)
+	(not (member-destroyed? mr))))
+
+ ;; True if the member is student
+ (define member-is-student?
+   (member-period-predicate? 'student))
+
+ ;; Only active members can be students.
+ (define (member-student? mr)
+   (and (member-active? mr)
+	(member-is-student? mr)))
+
+ ;; Returns true if the member is active (not suspended or destroyed).
+ (define (member-active? mr)
+   (and (not (member-destroyed? mr))
+	(not (member-suspended? mr))))
+
+ ;; Nickname as string
+ (define (member-nick mr)
+   (mr-ref mr 'nick))
+
+ ;; Returns member id
+ (define (member-id mr)
+   (mr-ref mr 'id))
+
+ ;; Returns true if the member has joined.
+ (define (member-existing? mr)
+   (let ((joined (mr-ref mr 'joined)))
+     (and joined
+	  (month<=? joined (*current-month*)))))
+
+ ;; Member formatting function for general use.
+ (define (member-format fmt mr)
+   (let loop ((fmtl (string->list fmt))
+	      (resl '()))
+     (if (null? fmtl)
+	 (string-intersperse (reverse resl) "")
+	 (let ((ch (car fmtl)))
+	   (if (eq? ch #\~)
+	       (loop (cddr fmtl)
+		     (cons (case (cadr fmtl)
+			     ((#\N) (mr-ref mr 'nick))
+			     ((#\I) (number->string (mr-ref mr 'id)))
+			     ((#\S) (number->string (member-suspended-months mr)))
+			     ((#\E)
+			      (let ((n (length (mr-ref mr member-file-error-symbol '()))))
+				(if (<= n 2)
+				    ""
+				    (sprintf "[~A]" (- n 2)))))
+			     ((#\~) "~"))
+			   resl))
+	       (loop (cdr fmtl)
+		     (cons (make-string 1 (car fmtl)) resl)))))))
+
+ ;; Returns the number of months the user is suspended. Zero if not
+ ;; suspended.
+ (define (member-suspended-months mr)
+   (if (member-suspended? mr)
+       (let ((period (periods-match (mr-ref mr 'suspend))))
+	 (if period
+	     (month-diff (car period) (*current-month*))
+	     0))
+       0))
+
+ ;; Returns source (including error) information
+ (define (member-source mr)
+   (mr-ref mr member-file-error-symbol))
+
+ ;; Nicely prints the member source with any errors recorded.
+ (define (print-member-source mr)
+   (let* ((ms (member-source mr))
+	  (file-name (car ms))
+	  (lines (cadr ms))
+	  (hls (cddr ms)))
+     (print file-name ":")
+     (print-source-listing
+      lines
+      hls
+      -1
+      a:error a:default
+      "" "" ; Not used
+      "..." ; Not used
+      )))
+
+ ;; Comparator of member records based on nickname.
+ (define (member<? a b)
+   (string-ci<? (member-nick a)
+		(member-nick b)))
+
+ ;; Performs module self-tests.
+ (define (member-record-tests!)
+   (run-tests
+    member-record
+    (test-true member-destroyed?
+	       (parameterize ((*current-month* (list 2023 2)))
+		 (member-destroyed? '((info . ((destroyed . "2010-05")))))))
+    (test-false member-destroyed?
+		(parameterize ((*current-month* (list 2009 2)))
+		  (member-destroyed? '((info . ((destroyed . "2010-05")))))))
+    (test-false member-destroyed?
+		(member-destroyed? '((info . ()))))
+    (test-false member-suspended?
+		(member-suspended? '((info . ()))))
+    (test-true member-suspended?
+	       (parameterize ((*current-month* (list 2015 2)))
+		 (member-suspended? '((info . ((suspend ((2010 1) 2022 4))))))))
+    (test-true member-suspended?
+	       (parameterize ((*current-month* (list 2015 2)))
+		 (member-suspended? '((info . ((suspend ((2010 1) . #f))))))))
+    (test-false member-suspended?
+		(parameterize ((*current-month* (list 2023 2)))
+		  (member-suspended? '((info . ((suspend ((2010 1) 2022 4))))))))
+    (test-true member-active?
+		(parameterize ((*current-month* (list 2023 2)))
+		  (member-active? '((info . ((suspend ((2010 1) 2022 4))))))))
+    ))
+
+ )

member-record.scm

@@ -1,5 +1,5 @@
 ;;
-;; member-record.scm
+;; member2-record.scm
 ;;
 ;; Procedures working with complete member record (as loaded by the
 ;; members-base).
@@ -24,144 +24,155 @@
 ;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 ;;
 
-(declare (unit member-record))
+(declare (unit member2-record))
 
 (module
- member-record
+ member2-record
  (
-  print-member-record-info
+  make-member-record
-  print-member-record-table
+
+  member-record-input-file
+
+  member-record-set
+  member-record-add-highlight
+  member-record-sub-ref
+  member-record-sub-set
+  member-record-sub-prepend
+
+  member-record-info
+
   member-destroyed?
   member-suspended?
   member-active?
   member-student?
+  member-existing?
+
   member-nick
   member-id
-  member-existing?
-  member-format
   member-suspended-months
-  member-source
+
-  print-member-source
+  member-format
-  member<?
+
   member-record-tests!
   )
 
  (import scheme
 	 (chicken base)
+	 (chicken keyword)
+	 (chicken irregex)
 	 (chicken string)
-	 (chicken sort)
 	 (chicken format)
 	 dictionary
-	 period
 	 testing
 	 month
-	 member-file
+	 period
-	 listing
+	 configuration)
-	 ansi
-	 configuration
-	 table
-	 utils)
 
- ;; Prints human-readable information
+ ;; Checks whether given string is a 4-digit decimal number.
- (define (print-member-record-info mr)
+ (define (is-4digit-string? s)
-   (let* ((id (dict-ref mr 'id))
+   (if (irregex-search (irregex "^[0-9]{4}$") s)
-	  (aliases (dict-ref mr 'symlinks))
+       #t
-	  (info (dict-ref mr 'info))
+       #f))
-	  (sinfo (sort info
-		       (lambda (a b)
-			 (string<?
-			  (symbol->string (car a))
-			  (symbol->string (car b)))))))
-     (print "User " id " alias(es): "
-	    (string-intersperse
-	     (map symbol->string aliases)
-	     ", "))
-     (when (member-suspended? mr)
-       (print "  Suspended for " (member-suspended-months mr) " months."))
-     (newline)
-     (let loop ((sinfo sinfo))
-       (when (not (null? sinfo))
-	 (let* ((kv (car sinfo))
-		(k (car kv))
-		(v (cdr kv)))
-	   (when (not (eq? k member-file-error-symbol))
-	     (print "  " k ":\t"
-		    (if (member k '(student suspend))
-			(periods->string v)
-			v)))
-	   (loop (cdr sinfo)))))))
 
- ;; Prints nicely formatted table
+ ;; checks whether given symbol is a 4-digit one.
- (define (print-member-record-table mr)
+ (define (is-4digit-symbol? s)
-   (let* ((aliases (mr-ref mr 'symlinks))
+   (is-4digit-string?
-	  (head (list (list "ID:" (mr-ref mr 'id))
+    (symbol->string s)))
-		      (list (sprintf "Alias~A:" (if (> (length aliases) 1) "es" ""))
-			    (string-intersperse (map symbol->string aliases) ", "))
-		      (if (member-suspended? mr)
-			  (list "Suspended for:"
-				(let ((msm (member-suspended-months mr)))
-				  (sprintf "~A month~A" msm
-					   (if (> msm 1) "s" ""))))
-			  #f)))
-	  (info (dict-ref mr 'info))
-	  (sikeys (sort (dict-keys info)
-			(lambda (a b)
-			  (string<?
-			   (symbol->string a)
-			   (symbol->string b)))))
-	  (body (map (lambda (k)
-		       (if (eq? k member-file-error-symbol)
-			   #f
-			   (let ((v (dict-ref info k)))
-			     (case k
-			       ((joined)
-				(list k (month->string v)))
-			       ((card desfire credit)
-				(list k
-				      (table->string
-				       (map
-					(lambda (c)
-					  (list (car c) (cdr c)))
-					v)
-				       #:col-border #t)))
-			       ((suspend student)
-				(list k
-				      (table->string
-				       (cons (list "Since" "Until")
-					     (map
-					      (lambda (p)
-						(list
-						 (month->string (car p))
-						 (month->string (cdr p))))
-					      v))
-				       #:col-border #t)))
-			       (else
-				(list k v))))))
-		     sikeys))
-	  (result (filter identity (append head body))))
-     (print (table->string result #:table-border #t #:row-border #t #:col-border #t))))
 
- ;; Returns key from the top-level (members-base) record if it exists,
+ ;; Returns the first 4-digit symbol from the list.
- ;; queries the 'info key otherwise. Optional default argument works
+ (define (get-4digit-symbol-from-list lst)
- ;; like with dict-ref.
+   (let loop ((lst lst))
- (define (mr-ref mr key . dfl)
+     (if (null? lst)
-   (if (dict-has-key? mr key)
+	 #f
-       (dict-ref mr key)
+	 (if (is-4digit-symbol? (car lst))
-       (if (null? dfl)
+	     (car lst)
-	   (dict-ref (dict-ref mr 'info (make-dict)) key)
+	     (loop (cdr lst))))))
-	   (dict-ref (dict-ref mr 'info (make-dict)) key (car dfl)))))
+
+ ;; Creates new member record based on the file and symlinks
+ ;; information received from the members directory. Any keyword
+ ;; arguments are converted to respective symbols in the dictionary.
+ (define (make-member-record file-name file-path symlinks . args)
+   (let loop ((args args)
+	      (pairs `((file-name . ,file-name)
+		       (file-path . ,file-path)
+		       (symlinks . ,symlinks)
+		       (id . ,(string->number
+			       (symbol->string
+				(get-4digit-symbol-from-list (cons file-name symlinks))))))))
+     (if (null? args)
+	 (make-dict pairs)
+	 (if (not (keyword? (car args)))
+	     (error 'make-member-record "Optional arguments must be keywords" (car args))
+	     (if (null? (cdr args))
+		 (error 'make-member-record "Each optional keyword argument must have a value" (car args))
+		 (loop (cddr args)
+		       (cons (cons (string->symbol (keyword->string (car args)))
+				   (cadr args))
+			     pairs)))))))
+
+ ;; Returns opened input file for this record (used by parser).
+ (define (member-record-input-file mr)
+   (open-input-file
+    (dict-ref mr 'file-path)))
+
+ ;; Sets pairs of keys/values for given member record.
+ (define (member-record-set mr . args)
+   (let loop ((args args)
+	      (mr mr))
+     (if (null? args)
+	 mr
+	 (if (not (keyword? (car args)))
+	     (error 'member-record-set "Needs argument keyword" (car args))
+	     (if (null? (cdr args))
+		 (error 'member-record-set "Argument needs value" (car args))
+		 (loop (cddr args)
+		       (dict-set mr (string->symbol (keyword->string (car args)))
+				 (cadr args))))))))
+
+ ;; Adds highlight identified by line number, message, pass number and
+ ;; type (error, warning, info).
+ (define (member-record-add-highlight mr line-number message pass type)
+   (dict-set mr 'highlights
+	     (cons (list line-number message pass type)
+		   (dict-ref mr 'highlights '()))))
+
+ ;; Returns a key from particular section
+ (define (member-record-sub-ref mr sec key . defaults)
+   (let ((sec-dict (dict-ref mr sec)))
+     (if (null? defaults)
+	 (dict-ref sec-dict key)
+	 (dict-ref sec-dict key (car defaults)))))
+
+ ;; Sets a key in particular section
+ (define (member-record-sub-set mr sec key val)
+   (let ((sec-dict (dict-ref mr sec)))
+     (dict-set mr sec
+	       (dict-set sec-dict key val))))
+
+ ;; Prepends value to given subkey
+ (define (member-record-sub-prepend mr sec key val)
+   (member-record-sub-set mr sec key
+			  (cons val
+				(member-record-sub-ref mr sec key '()))))
+
+ ;; Returns member info key value
+ (define (member-record-info mr key . defaults)
+   (let ((info (dict-ref mr 'info)))
+     (if (null? defaults)
+	 (dict-ref info key)
+	 (dict-ref info key (car defaults)))))
 
  ;; Returns true if the member record represents destroyed member. The
  ;; *current-month* is a global parameter from period module.
  (define (member-destroyed? mr)
-   (let ((destroyed (mr-ref mr 'destroyed #f)))
+   (let ((destroyed (member-record-info mr 'destroyed #f)))
      (and destroyed
 	  (month<? (string->month destroyed)
 		   (*current-month*)))))
 
  ;; Generic period-based predicate
  (define ((member-period-predicate? key) mr)
-   (let ((periods (mr-ref mr key #f)))
+   (let ((periods (member-record-info mr key #f)))
      (and periods
 	  (month-in-periods? periods))))
 
@@ -188,19 +199,29 @@
    (and (not (member-destroyed? mr))
 	(not (member-suspended? mr))))
 
+ ;; Returns true if the member has joined.
+ (define (member-existing? mr)
+   (let ((joined (member-record-info mr 'joined)))
+     (and joined
+	  (month<=? joined (*current-month*)))))
+
  ;; Nickname as string
  (define (member-nick mr)
-   (mr-ref mr 'nick))
+   (member-record-info mr 'nick))
 
  ;; Returns member id
  (define (member-id mr)
-   (mr-ref mr 'id))
+   (dict-ref mr 'id))
 
- ;; Returns true if the member has joined.
+ ;; Returns the number of months the user is suspended. Zero if not
- (define (member-existing? mr)
+ ;; suspended.
-   (let ((joined (mr-ref mr 'joined)))
+ (define (member-suspended-months mr)
-     (and joined
+   (if (member-suspended? mr)
-	  (month<=? joined (*current-month*)))))
+       (let ((period (periods-match (member-record-info mr 'suspend))))
+	 (if period
+	     (month-diff (car period) (*current-month*))
+	     0))
+       0))
 
  ;; Member formatting function for general use.
  (define (member-format fmt mr)
@@ -212,11 +233,11 @@
 	   (if (eq? ch #\~)
 	       (loop (cddr fmtl)
 		     (cons (case (cadr fmtl)
-			     ((#\N) (mr-ref mr 'nick))
+			     ((#\N) (member-record-info mr 'nick))
-			     ((#\I) (number->string (mr-ref mr 'id)))
+			     ((#\I) (number->string (member-record-info mr 'id)))
 			     ((#\S) (number->string (member-suspended-months mr)))
 			     ((#\E)
-			      (let ((n (length (mr-ref mr member-file-error-symbol '()))))
+			      (let ((n (length (member-record-info mr 'highlights '()))))
 				(if (<= n 2)
 				    ""
 				    (sprintf "[~A]" (- n 2)))))
@@ -224,46 +245,29 @@
 			   resl))
 	       (loop (cdr fmtl)
 		     (cons (make-string 1 (car fmtl)) resl)))))))
-
+ ;; Self-tests
- ;; Returns the number of months the user is suspended. Zero if not
- ;; suspended.
- (define (member-suspended-months mr)
-   (if (member-suspended? mr)
-       (let ((period (periods-match (mr-ref mr 'suspend))))
-	 (if period
-	     (month-diff (car period) (*current-month*))
-	     0))
-       0))
-
- ;; Returns source (including error) information
- (define (member-source mr)
-   (mr-ref mr member-file-error-symbol))
-
- ;; Nicely prints the member source with any errors recorded.
- (define (print-member-source mr)
-   (let* ((ms (member-source mr))
-	  (file-name (car ms))
-	  (lines (cadr ms))
-	  (hls (cddr ms)))
-     (print file-name ":")
-     (print-source-listing
-      lines
-      hls
-      -1
-      a:error a:default
-      "" "" ; Not used
-      "..." ; Not used
-      )))
-
- ;; Comparator of member records based on nickname.
- (define (member<? a b)
-   (string-ci<? (member-nick a)
-		(member-nick b)))
-
- ;; Performs module self-tests.
  (define (member-record-tests!)
    (run-tests
     member-record
+    (test-equal? make-member-record
+		 (make-member-record '|1234| "members/1234" '(|member|))
+		 '((file-name . |1234|)
+		   (file-path . "members/1234")
+		   (symlinks |member|)
+		   (id . 1234)))
+    (test-equal? make-member-record
+		 (make-member-record '|1234| "members/1234" '(|member|) #:msg "msg")
+		 '((msg . "msg")
+		   (file-name . |1234|)
+		   (file-path . "members/1234")
+		   (symlinks |member|)
+		   (id . 1234)))
+    (test-equal? member-record-set
+		 (member-record-set '() #:id 1234)
+		 '((id . 1234)))
+    (test-equal? member-record-add-highlight
+		 (member-record-add-highlight '() 123 "Interesting..." 0 'info)
+		 '((highlights . ((123 "Interesting..." 0 info)))))
     (test-true member-destroyed?
 	       (parameterize ((*current-month* (list 2023 2)))
 		 (member-destroyed? '((info . ((destroyed . "2010-05")))))))
@@ -289,3 +293,7 @@
     ))
 
  )
+
+(import member2-record)
+
+(member-record-tests!)

member2-record.scm

@@ -1,299 +0,0 @@
-;;
-;; member2-record.scm
-;;
-;; Procedures working with complete member record (as loaded by the
-;; members-base).
-;;
-;; 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 member2-record))
-
-(module
- member2-record
- (
-  make-member-record
-
-  member-record-input-file
-
-  member-record-set
-  member-record-add-highlight
-  member-record-sub-ref
-  member-record-sub-set
-  member-record-sub-prepend
-
-  member-record-info
-
-  member-destroyed?
-  member-suspended?
-  member-active?
-  member-student?
-  member-existing?
-
-  member-nick
-  member-id
-  member-suspended-months
-
-  member-format
-
-  member-record-tests!
-  )
-
- (import scheme
-	 (chicken base)
-	 (chicken keyword)
-	 (chicken irregex)
-	 (chicken string)
-	 (chicken format)
-	 dictionary
-	 testing
-	 month
-	 period
-	 configuration)
-
- ;; Checks whether given string is a 4-digit decimal number.
- (define (is-4digit-string? s)
-   (if (irregex-search (irregex "^[0-9]{4}$") s)
-       #t
-       #f))
-
- ;; checks whether given symbol is a 4-digit one.
- (define (is-4digit-symbol? s)
-   (is-4digit-string?
-    (symbol->string s)))
-
- ;; Returns the first 4-digit symbol from the list.
- (define (get-4digit-symbol-from-list lst)
-   (let loop ((lst lst))
-     (if (null? lst)
-	 #f
-	 (if (is-4digit-symbol? (car lst))
-	     (car lst)
-	     (loop (cdr lst))))))
-
- ;; Creates new member record based on the file and symlinks
- ;; information received from the members directory. Any keyword
- ;; arguments are converted to respective symbols in the dictionary.
- (define (make-member-record file-name file-path symlinks . args)
-   (let loop ((args args)
-	      (pairs `((file-name . ,file-name)
-		       (file-path . ,file-path)
-		       (symlinks . ,symlinks)
-		       (id . ,(string->number
-			       (symbol->string
-				(get-4digit-symbol-from-list (cons file-name symlinks))))))))
-     (if (null? args)
-	 (make-dict pairs)
-	 (if (not (keyword? (car args)))
-	     (error 'make-member-record "Optional arguments must be keywords" (car args))
-	     (if (null? (cdr args))
-		 (error 'make-member-record "Each optional keyword argument must have a value" (car args))
-		 (loop (cddr args)
-		       (cons (cons (string->symbol (keyword->string (car args)))
-				   (cadr args))
-			     pairs)))))))
-
- ;; Returns opened input file for this record (used by parser).
- (define (member-record-input-file mr)
-   (open-input-file
-    (dict-ref mr 'file-path)))
-
- ;; Sets pairs of keys/values for given member record.
- (define (member-record-set mr . args)
-   (let loop ((args args)
-	      (mr mr))
-     (if (null? args)
-	 mr
-	 (if (not (keyword? (car args)))
-	     (error 'member-record-set "Needs argument keyword" (car args))
-	     (if (null? (cdr args))
-		 (error 'member-record-set "Argument needs value" (car args))
-		 (loop (cddr args)
-		       (dict-set mr (string->symbol (keyword->string (car args)))
-				 (cadr args))))))))
-
- ;; Adds highlight identified by line number, message, pass number and
- ;; type (error, warning, info).
- (define (member-record-add-highlight mr line-number message pass type)
-   (dict-set mr 'highlights
-	     (cons (list line-number message pass type)
-		   (dict-ref mr 'highlights '()))))
-
- ;; Returns a key from particular section
- (define (member-record-sub-ref mr sec key . defaults)
-   (let ((sec-dict (dict-ref mr sec)))
-     (if (null? defaults)
-	 (dict-ref sec-dict key)
-	 (dict-ref sec-dict key (car defaults)))))
-
- ;; Sets a key in particular section
- (define (member-record-sub-set mr sec key val)
-   (let ((sec-dict (dict-ref mr sec)))
-     (dict-set mr sec
-	       (dict-set sec-dict key val))))
-
- ;; Prepends value to given subkey
- (define (member-record-sub-prepend mr sec key val)
-   (member-record-sub-set mr sec key
-			  (cons val
-				(member-record-sub-ref mr sec key '()))))
-
- ;; Returns member info key value
- (define (member-record-info mr key . defaults)
-   (let ((info (dict-ref mr 'info)))
-     (if (null? defaults)
-	 (dict-ref info key)
-	 (dict-ref info key (car defaults)))))
-
- ;; Returns true if the member record represents destroyed member. The
- ;; *current-month* is a global parameter from period module.
- (define (member-destroyed? mr)
-   (let ((destroyed (member-record-info mr 'destroyed #f)))
-     (and destroyed
-	  (month<? (string->month destroyed)
-		   (*current-month*)))))
-
- ;; Generic period-based predicate
- (define ((member-period-predicate? key) mr)
-   (let ((periods (member-record-info mr key #f)))
-     (and periods
-	  (month-in-periods? periods))))
-
- ;; Returns true if the member is now suspended
- (define member-is-suspended?
-   (member-period-predicate? 'suspend))
-
- ;; Suspended must not be destroyed
- (define (member-suspended? mr)
-   (and (member-is-suspended? mr)
-	(not (member-destroyed? mr))))
-
- ;; True if the member is student
- (define member-is-student?
-   (member-period-predicate? 'student))
-
- ;; Only active members can be students.
- (define (member-student? mr)
-   (and (member-active? mr)
-	(member-is-student? mr)))
-
- ;; Returns true if the member is active (not suspended or destroyed).
- (define (member-active? mr)
-   (and (not (member-destroyed? mr))
-	(not (member-suspended? mr))))
-
- ;; Returns true if the member has joined.
- (define (member-existing? mr)
-   (let ((joined (member-record-info mr 'joined)))
-     (and joined
-	  (month<=? joined (*current-month*)))))
-
- ;; Nickname as string
- (define (member-nick mr)
-   (member-record-info mr 'nick))
-
- ;; Returns member id
- (define (member-id mr)
-   (dict-ref mr 'id))
-
- ;; Returns the number of months the user is suspended. Zero if not
- ;; suspended.
- (define (member-suspended-months mr)
-   (if (member-suspended? mr)
-       (let ((period (periods-match (member-record-info mr 'suspend))))
-	 (if period
-	     (month-diff (car period) (*current-month*))
-	     0))
-       0))
-
- ;; Member formatting function for general use.
- (define (member-format fmt mr)
-   (let loop ((fmtl (string->list fmt))
-	      (resl '()))
-     (if (null? fmtl)
-	 (string-intersperse (reverse resl) "")
-	 (let ((ch (car fmtl)))
-	   (if (eq? ch #\~)
-	       (loop (cddr fmtl)
-		     (cons (case (cadr fmtl)
-			     ((#\N) (member-record-info mr 'nick))
-			     ((#\I) (number->string (member-record-info mr 'id)))
-			     ((#\S) (number->string (member-suspended-months mr)))
-			     ((#\E)
-			      (let ((n (length (member-record-info mr 'highlights '()))))
-				(if (<= n 2)
-				    ""
-				    (sprintf "[~A]" (- n 2)))))
-			     ((#\~) "~"))
-			   resl))
-	       (loop (cdr fmtl)
-		     (cons (make-string 1 (car fmtl)) resl)))))))
- ;; Self-tests
- (define (member-record-tests!)
-   (run-tests
-    member-record
-    (test-equal? make-member-record
-		 (make-member-record '|1234| "members/1234" '(|member|))
-		 '((file-name . |1234|)
-		   (file-path . "members/1234")
-		   (symlinks |member|)
-		   (id . 1234)))
-    (test-equal? make-member-record
-		 (make-member-record '|1234| "members/1234" '(|member|) #:msg "msg")
-		 '((msg . "msg")
-		   (file-name . |1234|)
-		   (file-path . "members/1234")
-		   (symlinks |member|)
-		   (id . 1234)))
-    (test-equal? member-record-set
-		 (member-record-set '() #:id 1234)
-		 '((id . 1234)))
-    (test-equal? member-record-add-highlight
-		 (member-record-add-highlight '() 123 "Interesting..." 0 'info)
-		 '((highlights . ((123 "Interesting..." 0 info)))))
-    (test-true member-destroyed?
-	       (parameterize ((*current-month* (list 2023 2)))
-		 (member-destroyed? '((info . ((destroyed . "2010-05")))))))
-    (test-false member-destroyed?
-		(parameterize ((*current-month* (list 2009 2)))
-		  (member-destroyed? '((info . ((destroyed . "2010-05")))))))
-    (test-false member-destroyed?
-		(member-destroyed? '((info . ()))))
-    (test-false member-suspended?
-		(member-suspended? '((info . ()))))
-    (test-true member-suspended?
-	       (parameterize ((*current-month* (list 2015 2)))
-		 (member-suspended? '((info . ((suspend ((2010 1) 2022 4))))))))
-    (test-true member-suspended?
-	       (parameterize ((*current-month* (list 2015 2)))
-		 (member-suspended? '((info . ((suspend ((2010 1) . #f))))))))
-    (test-false member-suspended?
-		(parameterize ((*current-month* (list 2023 2)))
-		  (member-suspended? '((info . ((suspend ((2010 1) 2022 4))))))))
-    (test-true member-active?
-		(parameterize ((*current-month* (list 2023 2)))
-		  (member-active? '((info . ((suspend ((2010 1) 2022 4))))))))
-    ))
-
- )
-
-(import member2-record)
-
-(member-record-tests!)