diff --git a/brmsaptool.scm b/brmsaptool.scm index 5732ae3..4132a48 100644 --- a/brmsaptool.scm +++ b/brmsaptool.scm @@ -82,6 +82,8 @@ (-fname- fname)) (-month (month) "Specify current month" (*current-month* (string->month month))) + (-print () "Print given member file" + (-action- 'print-member-file)) ) ;; Load the members database (required for everything anyway) @@ -110,4 +112,10 @@ (parameterize ((current-output-port (open-output-file (-fname-)))) (print-members-base-stats (members-base-stats MB)))) + ((print-member-file) + (cond (mr + (newline) + (print-member-source mr)) + (else + (print "No member specified!")))) ) diff --git a/listing.scm b/listing.scm index 2034afc..1fb29bc 100644 --- a/listing.scm +++ b/listing.scm @@ -26,7 +26,11 @@ (declare (unit listing)) (module - listing (print-source-listing listing-tests!) + listing + ( + print-source-listing + listing-tests! + ) (import scheme testing @@ -59,18 +63,34 @@ ;; Returns true if given line is near the target line. (define (line-near-target? line target context) - (or (< context 0) - (<= (abs (- line target)) context))) + (let ((target-line (if (list? target) + (car target) + target))) + (or (< context 0) + (<= (abs (- line target-line)) context)))) ;; Returns true if given line is near one of the target lines given. (define (line-near-targets? line targets context) (let loop ((targets targets)) (if (null? targets) - #f + (< context 0) (if (line-near-target? line (car targets) context) #t (loop (cdr targets)))))) + ;; Returns true if given number is in highlights. + (define (in-highlights? number highlights) + (let loop ((highlights highlights)) + (if (null? highlights) + #f + (let* ((highlight (car highlights)) + (line-number (if (list? highlight) + (car highlight) + highlight))) + (if (= number line-number) + #t + (loop (cdr highlights))))))) + ;; Prints and highlights a selection of source listing lines and ;; their optional context. (define (print-source-listing lines highlights context hl-pre hl-post ctx-pre ctx-post ellipsis) @@ -80,7 +100,7 @@ (printed-something #f) (was-printing #f)) (when (not (null? lines)) - (let* ((content? (if (member number highlights) #t #f)) + (let* ((content? (in-highlights? number highlights)) (context? (and (not content?) (line-near-targets? number highlights context))) (print? (or content? context?))) diff --git a/member-file.scm b/member-file.scm index df6e422..19954f7 100644 --- a/member-file.scm +++ b/member-file.scm @@ -258,14 +258,23 @@ (dict-set m k (string->month v)) m))) - ;; All conversions in one place - (define (convert-member-keys m) - (convert-member-key:month - (convert-member-keys:card - (convert-member-key:credit - (convert-member-keys:markers->periods m 'suspend 'student)) - 'card 'desfire) - 'joined)) + ;; Adds file-name and lines information to the error key. + (define (convert-member-key:error m esym lines file-name) + (dict-set m esym + (cons file-name + (cons lines + (dict-ref m esym '()))))) + + ;; All conversions in one place, including error reporting. + (define (convert-member-keys m lines file-name) + (convert-member-key:error + (convert-member-key:month + (convert-member-keys:card + (convert-member-key:credit + (convert-member-keys:markers->periods m 'suspend 'student)) + 'card 'desfire) + 'joined) + member-file-error-symbol lines file-name)) ;; Fills-in the defaults (define (make-default-member-info) @@ -281,7 +290,7 @@ (r (make-default-member-info)) (line-number 1)) (if (null? ls) - (convert-member-keys r) + (convert-member-keys r lines file-name) (let ((p (split-member-line (car ls) file-name lines line-number))) (loop (cdr ls) (if p diff --git a/member-record.scm b/member-record.scm index c9a2d53..f9d9b6d 100644 --- a/member-record.scm +++ b/member-record.scm @@ -39,6 +39,8 @@ member-existing? member-format member-suspended-months + member-source + print-member-source member-record-tests! ) @@ -50,7 +52,9 @@ period testing month - member-file) + member-file + listing + ansi) ;; Prints human-readable information (define (print-member-record-info mr) @@ -170,6 +174,26 @@ 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 + ))) + ;; Performs module self-tests. (define (member-record-tests!) (run-tests