From bd89fb476e501c129197616070b51f5f35459f42 Mon Sep 17 00:00:00 2001 From: Steffen Beyer Date: Sat, 4 Apr 2026 15:54:51 +0200 Subject: [PATCH] Improve diagnostics and Guile corpus handling --- gulie/cli.scm | 7 ++ gulie/compiler.scm | 146 +++++++++++++++++++++++++++++----------- gulie/diagnostic.scm | 119 ++++++++++++++++++++++++++++++-- gulie/engine.scm | 88 ++++++++++++++++++++---- gulie/rules/surface.scm | 138 +++++++++++++++++++++++++++++-------- test/run-tests.scm | 3 +- test/test-cli.scm | 38 +++++++++++ test/test-compiler.scm | 23 ++++++- test/test-engine.scm | 58 +++++++++++++++- test/test-rules.scm | 26 ++++++- 10 files changed, 556 insertions(+), 90 deletions(-) create mode 100644 test/test-cli.scm diff --git a/gulie/cli.scm b/gulie/cli.scm index b6e2ef2..9418492 100644 --- a/gulie/cli.scm +++ b/gulie/cli.scm @@ -121,6 +121,13 @@ (string->symbol cli-severity)) config) config)) + ;; Wire up --output + (cli-output (option-ref options 'output #f)) + (config (if cli-output + (cons (cons '%output + (string->symbol cli-output)) + config) + config)) (paths (if (null? rest) (list ".") rest)) (ignore-pats (config-ignore-patterns config)) (files (discover-scheme-files paths ignore-pats))) diff --git a/gulie/compiler.scm b/gulie/compiler.scm index ac52ea3..d82db7b 100644 --- a/gulie/compiler.scm +++ b/gulie/compiler.scm @@ -17,21 +17,30 @@ (define *warning-re* (make-regexp "^;;; ([^:]+):([0-9]+):([0-9]+): warning: (.+)$")) +(define (same-file? a b) + (or (string=? a b) + (let ((ca (false-if-exception (canonicalize-path a))) + (cb (false-if-exception (canonicalize-path b)))) + (and ca cb (string=? ca cb))))) + (define (parse-warning-line text file) - "Parse a warning line from Guile's compiler output into a ." + "Parse a warning line from Guile's compiler output into a . +Filters out warnings attributed to files other than FILE." (let ((m (regexp-exec *warning-re* text))) (if m - (let ((wfile (match:substring m 1)) - (wline (string->number (match:substring m 2))) - (wcol (string->number (match:substring m 3))) - (wmsg (match:substring m 4))) - (make-diagnostic - (if (string=? wfile "") file wfile) - wline wcol - 'warning - (classify-warning wmsg) - wmsg - #f)) + (let* ((wfile (match:substring m 1)) + (wline (string->number (match:substring m 2))) + (wcol (string->number (match:substring m 3))) + (wmsg (match:substring m 4)) + (resolved-file (if (string=? wfile "") file wfile))) + (and (same-file? resolved-file file) + (make-diagnostic + resolved-file + wline wcol + 'warning + (classify-warning wmsg) + wmsg + #f))) #f))) (define (classify-warning msg) @@ -51,6 +60,80 @@ ((string-contains msg "cannot be meaningfully") 'bad-case-datum) (else 'compiler-warning))) +(define (format-exception-message key args) + "Format compiler exception KEY and ARGS into a readable string." + (call-with-output-string + (lambda (p) + (display key p) + (display ": " p) + (catch #t + (lambda () + (match args + ((subr fmt fmt-args . _) + (when subr + (display subr p) + (display ": " p)) + (if fmt-args + (apply format p fmt (if (list? fmt-args) + fmt-args + (list fmt-args))) + (display fmt p))) + (_ (for-each (lambda (a) + (display a p) (display " " p)) + args)))) + (lambda _ + ;; Fallback: just display the raw args + (for-each (lambda (a) + (display a p) (display " " p)) + args)))))) + +(define (source-location-ref loc key . default) + (let ((pair (and (list? loc) (assq key loc)))) + (if pair + (cdr pair) + (if (null? default) #f (car default))))) + +(define (find-source-location args) + (find (lambda (arg) + (and (list? arg) + (every pair? arg) + (or (assq 'line arg) + (assq 'column arg) + (assq 'filename arg)))) + args)) + +(define (extract-location-from-args args file) + (let ((loc (find-source-location args))) + (and loc + (let* ((loc-file (or (source-location-ref loc 'filename #f) file)) + (loc-line (source-location-ref loc 'line #f)) + (loc-col (source-location-ref loc 'column #f))) + (and (same-file? loc-file file) + (list loc-file + (if (number? loc-line) (1+ loc-line) 1) + (if (number? loc-col) (max 0 loc-col) 0))))))) + +(define (extract-location-from-message msg file) + (let* ((anchor (string-append file ":")) + (pos (string-contains msg anchor))) + (and pos + (let* ((located (substring msg pos)) + (m (regexp-exec (make-regexp "^([^:]+):([0-9]+):([0-9]+): (.+)$") + located))) + (and m + (let* ((loc-file (match:substring m 1)) + (resolved-file (if (string=? loc-file "") + file + loc-file)) + (loc-line (string->number (match:substring m 2))) + (loc-col-1 (string->number (match:substring m 3))) + (clean-msg (match:substring m 4))) + (and (same-file? resolved-file file) + (list resolved-file + loc-line + (max 0 (1- loc-col-1)) + clean-msg)))))))) + (define (compile-and-capture-warnings file text config) "Compile TEXT (as if from FILE) and capture all compiler warnings. Returns a list of records." @@ -68,34 +151,19 @@ Returns a list of records." #:warning-level 3 #:env (make-fresh-user-module)))) (lambda (key . args) - ;; Format the error message properly. - ;; Guile exceptions typically have args: (subr fmt fmt-args data) - (let ((msg (call-with-output-string - (lambda (p) - (display key p) - (display ": " p) - (catch #t - (lambda () - (match args - ((subr fmt fmt-args . _) - (when subr - (display subr p) - (display ": " p)) - (if fmt-args - (apply format p fmt (if (list? fmt-args) - fmt-args - (list fmt-args))) - (display fmt p))) - (_ (for-each (lambda (a) - (display a p) (display " " p)) - args)))) - (lambda _ - ;; Fallback: just display the raw args - (for-each (lambda (a) - (display a p) (display " " p)) - args))))))) + (let* ((raw-msg (format-exception-message key args)) + (located-msg (extract-location-from-message raw-msg file)) + (located-args (extract-location-from-args args file)) + (location (or located-args located-msg)) + (diag-file (if location (car location) file)) + (diag-line (if location (cadr location) 1)) + (diag-col (if location (caddr location) 0)) + (msg (if (and located-msg (= (length located-msg) 4)) + (list-ref located-msg 3) + raw-msg))) (set! diagnostics - (cons (make-diagnostic file 1 0 'error 'compile-error msg #f) + (cons (make-diagnostic diag-file diag-line diag-col + 'error 'compile-error msg #f) diagnostics)))))) ;; Parse captured warnings (let* ((output (get-output-string warning-output)) diff --git a/gulie/diagnostic.scm b/gulie/diagnostic.scm index d15e55f..a5435e1 100644 --- a/gulie/diagnostic.scm +++ b/gulie/diagnostic.scm @@ -83,9 +83,116 @@ (diagnostic-rule diag) (diagnostic-message diag))) -(define (format-diagnostics diags port) - "Write all diagnostics to PORT, sorted by location." - (for-each (lambda (d) - (display (format-diagnostic d) port) - (newline port)) - (sort diags diagnosticinteger ch) 32) + (format port "\\u~4,'0x" (char->integer ch))) + (else (display ch port)))) + str) + (display #\" port)) + +(define (write-json-fix port fix) + (if fix + (begin + (display "{" port) + (display "\"type\":" port) + (write-json-string port (symbol->string (fix-type fix))) + (display ",\"line\":" port) + (display (fix-line fix) port) + (display ",\"column\":" port) + (display (fix-column fix) port) + (display ",\"endLine\":" port) + (display (fix-end-line fix) port) + (display ",\"endColumn\":" port) + (display (fix-end-column fix) port) + (display ",\"replacement\":" port) + (if (fix-replacement fix) + (write-json-string port (fix-replacement fix)) + (display "null" port)) + (display "}" port)) + (display "null" port))) + +(define (write-json-diagnostic port diag) + (display "{" port) + (display "\"file\":" port) + (write-json-string port (diagnostic-file diag)) + (display ",\"line\":" port) + (display (diagnostic-line diag) port) + (display ",\"column\":" port) + (display (diagnostic-column diag) port) + (display ",\"severity\":" port) + (write-json-string port (severity->string (diagnostic-severity diag))) + (display ",\"rule\":" port) + (write-json-string port (symbol->string (diagnostic-rule diag))) + (display ",\"message\":" port) + (write-json-string port (diagnostic-message diag)) + (display ",\"fix\":" port) + (write-json-fix port (diagnostic-fix diag)) + (display "}" port)) + +(define (format-diagnostics diags port . maybe-format) + "Write all diagnostics to PORT. +OUTPUT-FORMAT may be standard, compact, or json." + (let* ((output-format (normalize-output-format + (if (null? maybe-format) + 'standard + (car maybe-format)))) + (sorted (sort diags diagnostic=? sev min-sev) "Is SEV at least as severe as MIN-SEV?" (>= (severity-rank sev) (severity-rank min-sev))) +(define (rule-family-name rule-name) + "Map internal fixup rule names back to their user-facing family name." + (let* ((name (symbol->string rule-name)) + (suffix "-fixup") + (suffix-len (string-length suffix)) + (name-len (string-length name))) + (if (and (>= name-len suffix-len) + (string=? (substring name (- name-len suffix-len)) suffix)) + (string->symbol (substring name 0 (- name-len suffix-len))) + rule-name))) + (define (filter-rules-by-config rules config) "Filter RULES according to enable/disable lists in CONFIG. If enable is non-empty, only those rules are kept. @@ -46,6 +57,46 @@ Then any rules in disable are removed." (filter (lambda (r) (not (memq (rule-name r) disabled))) rules))))) + +(define (filter-diagnostics-by-config diagnostics config) + "Filter DIAGNOSTICS by config enable/disable lists. +This applies to semantic diagnostics as well as surface diagnostics." + (let ((enabled (or (assq-ref config 'enable) '())) + (disabled (or (assq-ref config 'disable) '()))) + (let ((diagnostics (if (null? enabled) + diagnostics + (filter (lambda (d) + (memq (rule-family-name (diagnostic-rule d)) + enabled)) + diagnostics)))) + (if (null? disabled) + diagnostics + (filter (lambda (d) + (not (memq (rule-family-name (diagnostic-rule d)) + disabled))) + diagnostics))))) + +(define (page-break-line? line-text) + "Is LINE-TEXT a form-feed page separator line?" + (and (> (string-length line-text) 0) + (let lp ((i 0) (saw-page? #f)) + (if (= i (string-length line-text)) + saw-page? + (let ((ch (string-ref line-text i))) + (cond + ((char=? ch #\page) + (lp (1+ i) #t)) + ((or (char=? ch #\space) + (char=? ch #\tab)) + (lp (1+ i) saw-page?)) + (else #f))))))) + +(define (surface-blank-line? line-text) + "Should LINE-TEXT count as a blank line for surface rules?" + (and (or (string-null? line-text) + (string-every char-whitespace? line-text)) + (not (page-break-line? line-text)))) + (define (run-line-rules file lines config) "Run all line-type rules against LINES. Returns list of diagnostics." (let ((line-rules (filter-rules-by-config (rules-of-type 'line) config)) @@ -55,8 +106,7 @@ Then any rules in disable are removed." (let lp ((remaining lines) (line-num 1)) (when (not (null? remaining)) (let* ((line-text (car remaining)) - (is-blank (or (string-null? line-text) - (string-every char-whitespace? line-text)))) + (is-blank (surface-blank-line? line-text))) (set! consecutive-blanks (if is-blank (1+ consecutive-blanks) 0)) (let ((augmented-config @@ -118,6 +168,9 @@ and '%min-severity with value 'error, 'warning, or 'info (default)." ;; Filter suppressions (let ((suppressions (parse-suppressions text))) (set! diagnostics (filter-suppressions diagnostics suppressions))) + ;; Filter by enable/disable config at the diagnostic level too, + ;; so semantic diagnostics respect rule selection. + (set! diagnostics (filter-diagnostics-by-config diagnostics config)) ;; Filter by minimum severity (when (not (eq? min-severity 'info)) (set! diagnostics @@ -222,17 +275,27 @@ with the greatest edit distance from the original is chosen." (set! first #f))) (lp (1+ i)))))))) count)))) +(define (parallel-safe-pass? pass) + "Can PASS be linted safely in parallel? +The semantic pass uses compiler state and warning ports that are not +currently thread-safe, so only surface-only runs use parallel workers." + (eq? pass 'surface)) + (define (lint-files files config) - "Lint multiple FILES in parallel. Returns total diagnostic count. -Uses n-par-map to distribute work across threads, then outputs -diagnostics sequentially to maintain deterministic file order. + "Lint multiple FILES. Returns total diagnostic count. +Surface-only runs use n-par-map; semantic runs are processed sequentially +for deterministic compiler diagnostics. When '%fix is #t in config, apply auto-fixes and report unfixed." - (let* ((ncpus (max 1 (total-processor-count))) + (let* ((pass (or (assq-ref config '%pass) 'all)) + (output-format (or (assq-ref config '%output) 'standard)) (fix-mode? (assq-ref config '%fix)) - (results (n-par-map ncpus - (lambda (file) - (cons file (lint-file file config))) - files)) + (lint-one (lambda (file) + (cons file (lint-file file config)))) + (results (if (parallel-safe-pass? pass) + (let ((ncpus (max 1 (total-processor-count)))) + (n-par-map ncpus lint-one files)) + (map lint-one files))) + (reported-diags '()) (total-diags 0) (total-fixed 0)) (for-each @@ -245,12 +308,13 @@ When '%fix is #t in config, apply auto-fixes and report unfixed." (unfixed (filter (lambda (d) (not (diagnostic-fix d))) diags))) (set! total-fixed (+ total-fixed fixed-count)) (set! total-diags (+ total-diags (length unfixed))) - (format-diagnostics unfixed (current-output-port))) + (set! reported-diags (append unfixed reported-diags))) ;; Normal mode: report everything (begin (set! total-diags (+ total-diags (length diags))) - (format-diagnostics diags (current-output-port)))))) + (set! reported-diags (append diags reported-diags)))))) results) + (format-diagnostics reported-diags (current-output-port) output-format) (when (and fix-mode? (> total-fixed 0)) (format (current-error-port) "Fixed ~a issue~a.~%" total-fixed (if (= total-fixed 1) "" "s"))) diff --git a/gulie/rules/surface.scm b/gulie/rules/surface.scm index f6ef75d..60cb187 100644 --- a/gulie/rules/surface.scm +++ b/gulie/rules/surface.scm @@ -7,6 +7,99 @@ #:use-module (gulie rule) #:use-module (gulie diagnostic)) +(define (page-break-line? line-text) + "Is LINE-TEXT a form-feed page separator line?" + (and (> (string-length line-text) 0) + (let lp ((i 0) (saw-page? #f)) + (if (= i (string-length line-text)) + saw-page? + (let ((ch (string-ref line-text i))) + (cond + ((char=? ch #\page) + (lp (1+ i) #t)) + ((or (char=? ch #\space) + (char=? ch #\tab)) + (lp (1+ i) saw-page?)) + (else #f))))))) + +(define (surface-blank-line? line-text) + "Should LINE-TEXT count as a blank line for surface rules?" + (and (or (string-null? line-text) + (string-every char-whitespace? line-text)) + (not (page-break-line? line-text)))) + +(define (advance-column col ch) + (if (char=? ch #\tab) + (+ col (- 8 (modulo col 8))) + (1+ col))) + +(define (find-tab-in-code line-text) + "Return the column of the first tab outside strings and comments, or #f." + (let ((len (string-length line-text))) + (let lp ((i 0) (in-string? #f) (escaped? #f)) + (if (= i len) + #f + (let ((ch (string-ref line-text i))) + (cond + (in-string? + (cond + (escaped? + (lp (1+ i) #t #f)) + ((char=? ch #\\) + (lp (1+ i) #t #t)) + ((char=? ch #\") + (lp (1+ i) #f #f)) + (else + (lp (1+ i) #t #f)))) + ((char=? ch #\;) + #f) + ((char=? ch #\") + (lp (1+ i) #t #f)) + ((char=? ch #\tab) + i) + (else + (lp (1+ i) #f #f)))))))) + +(define (expand-tabs-in-code line-text) + "Expand tabs outside strings and comments, preserving other tabs as-is." + (let ((len (string-length line-text))) + (let lp ((i 0) (col 0) (in-string? #f) (escaped? #f) + (in-comment? #f) (acc '())) + (if (= i len) + (list->string (reverse acc)) + (let ((ch (string-ref line-text i))) + (cond + (in-comment? + (lp (1+ i) (advance-column col ch) #f #f #t + (cons ch acc))) + (in-string? + (cond + (escaped? + (lp (1+ i) (advance-column col ch) #t #f #f + (cons ch acc))) + ((char=? ch #\\) + (lp (1+ i) (advance-column col ch) #t #t #f + (cons ch acc))) + ((char=? ch #\") + (lp (1+ i) (advance-column col ch) #f #f #f + (cons ch acc))) + (else + (lp (1+ i) (advance-column col ch) #t #f #f + (cons ch acc))))) + ((char=? ch #\;) + (lp (1+ i) (advance-column col ch) #f #f #t + (cons ch acc))) + ((char=? ch #\") + (lp (1+ i) (advance-column col ch) #t #f #f + (cons ch acc))) + ((char=? ch #\tab) + (let ((spaces (- 8 (modulo col 8)))) + (lp (1+ i) (+ col spaces) #f #f #f + (append (make-list spaces #\space) acc)))) + (else + (lp (1+ i) (advance-column col ch) #f #f #f + (cons ch acc))))))))) + ;;; trailing-whitespace — trailing spaces or tabs at end of line (register-rule! @@ -15,18 +108,20 @@ "Line has trailing whitespace" 'warning 'format 'line (lambda (file line-num line-text config) - (let ((trimmed (string-trim-right line-text))) - (if (and (not (string=? line-text trimmed)) - (> (string-length line-text) 0)) - (list (make-diagnostic - file line-num - (string-length trimmed) - 'warning 'trailing-whitespace - "trailing whitespace" - (make-fix 'replace-line line-num 0 - line-num (string-length line-text) - trimmed))) - '()))) + (if (page-break-line? line-text) + '() + (let ((trimmed (string-trim-right line-text))) + (if (and (not (string=? line-text trimmed)) + (> (string-length line-text) 0)) + (list (make-diagnostic + file line-num + (string-length trimmed) + 'warning 'trailing-whitespace + "trailing whitespace" + (make-fix 'replace-line line-num 0 + line-num (string-length line-text) + trimmed))) + '())))) #f)) ;;; line-length — line exceeds maximum width @@ -59,20 +154,9 @@ "Tab character found in source" 'warning 'format 'line (lambda (file line-num line-text config) - (let ((pos (string-index line-text #\tab))) + (let ((pos (find-tab-in-code line-text))) (if pos - (let ((fixed (string-trim-right - (let expand ((s line-text) (col 0) (i 0) (acc '())) - (cond - ((= i (string-length s)) - (list->string (reverse acc))) - ((char=? (string-ref s i) #\tab) - (let ((spaces (- 8 (modulo col 8)))) - (expand s (+ col spaces) (1+ i) - (append (make-list spaces #\space) acc)))) - (else - (expand s (1+ col) (1+ i) - (cons (string-ref s i) acc)))))))) + (let ((fixed (string-trim-right (expand-tabs-in-code line-text)))) (list (make-diagnostic file line-num pos 'warning 'no-tabs @@ -98,7 +182,7 @@ (consecutive (or (assq-ref config '%consecutive-blanks) 0))) (cond ;; First excess blank line: emit warning + delete fix - ((and (string-every char-whitespace? line-text) + ((and (surface-blank-line? line-text) (= consecutive (1+ max-blanks))) (list (make-diagnostic file (- line-num max-blanks) 0 @@ -106,7 +190,7 @@ (format #f "more than ~a consecutive blank lines" max-blanks) (make-fix 'delete-line line-num 0 line-num 0 "")))) ;; Subsequent excess blanks: fix-only (not displayed) - ((and (string-every char-whitespace? line-text) + ((and (surface-blank-line? line-text) (> consecutive (1+ max-blanks))) (list (make-diagnostic file line-num 0 diff --git a/test/run-tests.scm b/test/run-tests.scm index e1bf5bf..595d2bb 100644 --- a/test/run-tests.scm +++ b/test/run-tests.scm @@ -33,4 +33,5 @@ (load-test "test-suppression.scm") (load-test "test-compiler.scm") (load-test "test-config.scm") - (load-test "test-engine.scm")) + (load-test "test-engine.scm") + (load-test "test-cli.scm")) diff --git a/test/test-cli.scm b/test/test-cli.scm new file mode 100644 index 0000000..0070077 --- /dev/null +++ b/test/test-cli.scm @@ -0,0 +1,38 @@ +;;; Tests for (gulie cli) + +(use-modules (srfi srfi-64) + (ice-9 textual-ports) + (gulie cli) + (gulie rules surface) + (gulie rules comments)) + +(test-begin "cli") + +(test-group "output-json" + (let ((tmp (string-append (tmpnam) ".scm")) + (cfg (string-append (tmpnam) ".sexp"))) + (call-with-output-file tmp + (lambda (p) (display "(define x 42) \n" p))) + (call-with-output-file cfg + (lambda (p) (display "()\n" p))) + (let* ((code #f) + (output (call-with-output-string + (lambda (port) + (parameterize ((current-output-port port)) + (set! code + (main (list "gulie" + "--pass" "surface" + "--config" cfg + "--output" "json" + tmp)))))))) + (test-equal "exit code reports findings" 1 code) + (test-assert "json array output" + (string-prefix? "[" output)) + (test-assert "contains json rule" + (string-contains output "\"rule\":\"trailing-whitespace\"")) + (test-assert "does not use standard formatter" + (not (string-contains output ": warning: trailing-whitespace:")))) + (delete-file tmp) + (delete-file cfg))) + +(test-end "cli") diff --git a/test/test-compiler.scm b/test/test-compiler.scm index de16361..7bc93ac 100644 --- a/test/test-compiler.scm +++ b/test/test-compiler.scm @@ -47,10 +47,29 @@ (test-group "syntax-error" (let ((diags (compile-and-capture-warnings "test.scm" - "(define (foo x) (+ x" + "(define (foo x)\n (+ x" '()))) (test-assert "catches syntax error" (any (lambda (d) (eq? (diagnostic-severity d) 'error)) - diags)))) + diags)) + (let ((err (find (lambda (d) (eq? (diagnostic-severity d) 'error)) + diags))) + (test-assert "read error has useful line" + (> (diagnostic-line err) 1)) + (test-assert "read error has useful message" + (not (string-contains (diagnostic-message err) "test.scm:")))))) + +(test-group "syntax-error-source-location" + (let* ((diags (compile-and-capture-warnings + "test.scm" + "(define-syntax foo\n (syntax-rules (...)\n ((_ x) x)))\n" + '())) + (err (find (lambda (d) (eq? (diagnostic-severity d) 'error)) + diags))) + (test-assert "has compile error" err) + (test-equal "syntax error line from source props" 2 + (diagnostic-line err)) + (test-equal "syntax error column from source props" 2 + (diagnostic-column err)))) (test-end "compiler") diff --git a/test/test-engine.scm b/test/test-engine.scm index cd9ed6b..a555f8c 100644 --- a/test/test-engine.scm +++ b/test/test-engine.scm @@ -58,6 +58,14 @@ (test-assert "info not >= warning" (not ((@@ (gulie engine) severity>=?) 'info 'warning)))) +(test-group "lint-files-execution-strategy" + (test-assert "surface pass can run in parallel" + ((@@ (gulie engine) parallel-safe-pass?) 'surface)) + (test-assert "semantic pass runs sequentially" + (not ((@@ (gulie engine) parallel-safe-pass?) 'semantic))) + (test-assert "all pass runs sequentially" + (not ((@@ (gulie engine) parallel-safe-pass?) 'all)))) + ;;; lint-file with pass control (test-group "lint-file-pass-surface" @@ -104,6 +112,34 @@ diags)))) (delete-file tmp))) +(test-group "lint-file-disable-semantic-rule" + (let ((tmp (tmpnam))) + (call-with-output-file tmp + (lambda (p) (display "(define x y)\n" p))) + (let ((diags (lint-file tmp '((%pass . semantic) + (disable unbound-variable))))) + (test-assert "disabled semantic rule produces no diagnostics" + (not (any (lambda (d) (eq? (diagnostic-rule d) 'unbound-variable)) + diags)))) + (delete-file tmp))) + +(test-group "lint-file-page-break-separators" + (let ((tmp (tmpnam))) + (call-with-output-file tmp + (lambda (p) + (display "(define x 1)\n\n" p) + (display (string #\page) p) + (display "\n\n(define y 2)\n" p))) + (let ((diags (lint-file tmp '((%pass . surface) + (max-blank-lines . 1))))) + (test-assert "page break does not create blank-lines warning" + (not (any (lambda (d) (eq? (diagnostic-rule d) 'blank-lines)) + diags))) + (test-assert "page break does not trigger trailing-whitespace" + (not (any (lambda (d) (eq? (diagnostic-rule d) 'trailing-whitespace)) + diags)))) + (delete-file tmp))) + ;;; Fix mode (test-group "fix-trailing-whitespace" @@ -252,7 +288,27 @@ (test-assert "contains module name" (string-contains msg "nonexistent")))))) -;;; Integration: lint-files with fix mode +;;; Integration: lint-files output and fix mode + +(test-group "lint-files-json-output" + (let ((tmp (tmpnam)) + (count #f)) + (call-with-output-file tmp + (lambda (p) (display "(define x 42) \n" p))) + (let ((output (call-with-output-string + (lambda (port) + (parameterize ((current-output-port port)) + (set! count + (lint-files (list tmp) + '((%pass . surface) + (%output . json))))))))) + (test-equal "count preserved" 1 count) + (test-assert "json array output" (string-prefix? "[" output)) + (test-assert "contains json rule" + (string-contains output "\"rule\":\"trailing-whitespace\"")) + (test-assert "does not use standard formatter" + (not (string-contains output ": warning: trailing-whitespace:")))) + (delete-file tmp))) (test-group "lint-files-fix-mode" (let ((tmp (tmpnam))) diff --git a/test/test-rules.scm b/test/test-rules.scm index 81c0d8a..262d779 100644 --- a/test/test-rules.scm +++ b/test/test-rules.scm @@ -27,7 +27,11 @@ (test-equal "empty line no diagnostic" '() - ((rule-check-proc rule) "f.scm" 1 "" '())))) + ((rule-check-proc rule) "f.scm" 1 "" '())) + + (test-equal "page-break separator line ok" + '() + ((rule-check-proc rule) "f.scm" 1 (string #\page) '())))) (test-group "line-length" (let ((rule (find-rule 'line-length))) @@ -55,7 +59,25 @@ ((rule-check-proc rule) "f.scm" 1 " (define x 1)" '())) (let ((diags ((rule-check-proc rule) "f.scm" 1 "\t(define x 1)" '()))) - (test-equal "tab detected" 1 (length diags))))) + (test-equal "tab detected" 1 (length diags))) + + (test-equal "tabs in comments ignored" + '() + ((rule-check-proc rule) "f.scm" 1 + (string-append ";;" (string #\tab) " comment") + '())) + + (test-equal "tabs after inline comment ignored" + '() + ((rule-check-proc rule) "f.scm" 1 + (string-append "(define x 1) ;" (string #\tab) " comment") + '())) + + (test-equal "tabs in strings ignored" + '() + ((rule-check-proc rule) "f.scm" 1 + (string-append "(display \"" (string #\tab) "\")") + '())))) (test-group "blank-lines" (let ((rule (find-rule 'blank-lines)))