diff --git a/member-record-old.scm b/member-record-old.scm new file mode 100644 index 0000000..7d13ea3 --- /dev/null +++ b/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 +;; +;; 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 + memberstring (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) + (stringstring 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 + (monthmonth 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 (memberstring (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))))))) + ;; 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)) - ;; 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) - (stringstring 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)))) + ;; checks whether given symbol is a 4-digit one. + (define (is-4digit-symbol? s) + (is-4digit-string? + (symbol->string s))) - ;; 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 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 (mr-ref mr 'destroyed #f))) + (let ((destroyed (member-record-info mr 'destroyed #f))) (and destroyed (monthmonth 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. - (define (member-existing? mr) - (let ((joined (mr-ref mr 'joined))) - (and joined - (month<=? joined (*current-month*))))) + ;; 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) @@ -212,11 +233,11 @@ (if (eq? ch #\~) (loop (cddr fmtl) (cons (case (cadr fmtl) - ((#\N) (mr-ref mr 'nick)) - ((#\I) (number->string (mr-ref mr 'id))) + ((#\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 (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))))))) - - ;; 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 -;; -;; 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 - (monthmonth 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!)