352 lines
14 KiB
Scheme
352 lines
14 KiB
Scheme
;;; Tests for (gulie engine) — rule filtering, pass control, severity, fix mode
|
|
|
|
(use-modules (srfi srfi-64)
|
|
(srfi srfi-1)
|
|
(ice-9 textual-ports)
|
|
(gulie engine)
|
|
(gulie rule)
|
|
(gulie config)
|
|
(gulie diagnostic)
|
|
(gulie rules surface)
|
|
(gulie rules comments))
|
|
|
|
(test-begin "engine")
|
|
|
|
;;; filter-rules-by-config
|
|
|
|
(test-group "filter-rules-by-config"
|
|
(let ((all-rules (all-rules)))
|
|
;; With empty enable/disable, all rules pass through
|
|
(test-equal "empty config keeps all rules"
|
|
(length all-rules)
|
|
(length ((@@ (gulie engine) filter-rules-by-config)
|
|
all-rules '())))
|
|
|
|
;; Enable only one rule
|
|
(let ((filtered ((@@ (gulie engine) filter-rules-by-config)
|
|
all-rules '((enable trailing-whitespace)))))
|
|
(test-equal "enable filters to one" 1 (length filtered))
|
|
(test-eq "correct rule kept" 'trailing-whitespace
|
|
(rule-name (car filtered))))
|
|
|
|
;; Disable one rule
|
|
(let* ((before (length all-rules))
|
|
(filtered ((@@ (gulie engine) filter-rules-by-config)
|
|
all-rules '((disable trailing-whitespace)))))
|
|
(test-equal "disable removes one" (1- before) (length filtered))
|
|
(test-assert "disabled rule absent"
|
|
(not (find (lambda (r) (eq? (rule-name r) 'trailing-whitespace))
|
|
filtered))))
|
|
|
|
;; Enable + disable
|
|
(let ((filtered ((@@ (gulie engine) filter-rules-by-config)
|
|
all-rules '((enable trailing-whitespace no-tabs)
|
|
(disable no-tabs)))))
|
|
(test-equal "enable then disable" 1 (length filtered))
|
|
(test-eq "only non-disabled remains" 'trailing-whitespace
|
|
(rule-name (car filtered))))))
|
|
|
|
;;; severity filtering
|
|
|
|
(test-group "severity-helpers"
|
|
(test-assert "error >= warning"
|
|
((@@ (gulie engine) severity>=?) 'error 'warning))
|
|
(test-assert "warning >= warning"
|
|
((@@ (gulie engine) severity>=?) 'warning 'warning))
|
|
(test-assert "warning >= info"
|
|
((@@ (gulie engine) severity>=?) 'warning 'info))
|
|
(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"
|
|
;; Create a temp file with issues
|
|
(let ((tmp (tmpnam)))
|
|
(call-with-output-file tmp
|
|
(lambda (p) (display "(define x 42) \n" p))) ;; trailing whitespace
|
|
(let ((diags (lint-file tmp '((%pass . surface)))))
|
|
(test-assert "finds trailing whitespace"
|
|
(any (lambda (d) (eq? (diagnostic-rule d) 'trailing-whitespace))
|
|
diags))
|
|
;; Should NOT have compile-error since semantic pass is skipped
|
|
(test-assert "no compile errors in surface mode"
|
|
(not (any (lambda (d) (eq? (diagnostic-rule d) 'compile-error))
|
|
diags))))
|
|
(delete-file tmp)))
|
|
|
|
(test-group "lint-file-severity-filter"
|
|
(let ((tmp (tmpnam)))
|
|
;; Single ; on own line (info) + trailing whitespace (warning)
|
|
(call-with-output-file tmp
|
|
(lambda (p) (display " ; comment \n" p)))
|
|
(let ((all-diags (lint-file tmp '((%pass . surface))))
|
|
(warn-diags (lint-file tmp '((%pass . surface)
|
|
(%min-severity . warning)))))
|
|
(test-assert "all includes info"
|
|
(any (lambda (d) (eq? (diagnostic-severity d) 'info)) all-diags))
|
|
(test-assert "warning filter excludes info"
|
|
(not (any (lambda (d) (eq? (diagnostic-severity d) 'info))
|
|
warn-diags)))
|
|
(test-assert "warning filter keeps warnings"
|
|
(any (lambda (d) (eq? (diagnostic-severity d) 'warning))
|
|
warn-diags)))
|
|
(delete-file tmp)))
|
|
|
|
(test-group "lint-file-disable-rule"
|
|
(let ((tmp (tmpnam)))
|
|
(call-with-output-file tmp
|
|
(lambda (p) (display "(define x 42) \n" p)))
|
|
(let ((diags (lint-file tmp '((%pass . surface)
|
|
(disable trailing-whitespace)))))
|
|
(test-assert "disabled rule produces no diagnostics"
|
|
(not (any (lambda (d) (eq? (diagnostic-rule d) 'trailing-whitespace))
|
|
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)))
|
|
|
|
(test-group "lint-file-token-aware-no-tabs"
|
|
(let ((tmp (tmpnam)))
|
|
(call-with-output-file tmp
|
|
(lambda (p)
|
|
(display "#| block\tcomment |#\n" p)))
|
|
(let ((diags (lint-file tmp '((%pass . surface)))))
|
|
(test-assert "tab in block comment ignored"
|
|
(not (any (lambda (d) (eq? (diagnostic-rule d) 'no-tabs))
|
|
diags))))
|
|
(delete-file tmp)))
|
|
|
|
(test-group "lint-file-token-aware-comment-semantics"
|
|
(let ((tmp (tmpnam)))
|
|
(call-with-output-file tmp
|
|
(lambda (p)
|
|
(display "(display \"hello\n; not a comment\nworld\")\n" p)))
|
|
(let ((diags (lint-file tmp '((%pass . surface)))))
|
|
(test-assert "semicolon inside multiline string ignored"
|
|
(not (any (lambda (d) (eq? (diagnostic-rule d) 'comment-semicolons))
|
|
diags))))
|
|
(delete-file tmp)))
|
|
|
|
;;; Fix mode
|
|
|
|
(test-group "fix-trailing-whitespace"
|
|
(let ((tmp (tmpnam)))
|
|
(call-with-output-file tmp
|
|
(lambda (p) (display "(define x 42) \n(define y 99)\n" p)))
|
|
(let ((diags (lint-file tmp '((%pass . surface)))))
|
|
((@@ (gulie engine) apply-fixes-to-file) tmp diags))
|
|
(let ((result (call-with-input-file tmp get-string-all)))
|
|
(test-assert "trailing whitespace removed"
|
|
(not (string-contains result "42) ")))
|
|
(test-assert "content preserved"
|
|
(string-contains result "(define x 42)")))
|
|
(delete-file tmp)))
|
|
|
|
(test-group "fix-comment-semicolons"
|
|
(let ((tmp (tmpnam)))
|
|
(call-with-output-file tmp
|
|
(lambda (p) (display " ; bad comment\n ;; good comment\n" p)))
|
|
(let ((diags (lint-file tmp '((%pass . surface)))))
|
|
((@@ (gulie engine) apply-fixes-to-file) tmp diags))
|
|
(let ((result (call-with-input-file tmp get-string-all)))
|
|
(test-assert "single ; fixed to ;;"
|
|
(string-contains result " ;; bad comment"))
|
|
(test-assert "double ;; preserved"
|
|
(string-contains result " ;; good comment")))
|
|
(delete-file tmp)))
|
|
|
|
(test-group "fix-no-tabs"
|
|
(let ((tmp (tmpnam)))
|
|
(call-with-output-file tmp
|
|
(lambda (p) (display "\t(define x 1)\n" p)))
|
|
(let ((diags (lint-file tmp '((%pass . surface)))))
|
|
((@@ (gulie engine) apply-fixes-to-file) tmp diags))
|
|
(let ((result (call-with-input-file tmp get-string-all)))
|
|
(test-assert "tab replaced with spaces"
|
|
(not (string-index result #\tab)))
|
|
(test-assert "8-space expansion"
|
|
(string-prefix? " (define x 1)" result)))
|
|
(delete-file tmp)))
|
|
|
|
(test-group "fix-tabs-with-alignment"
|
|
;; Tab at column 6 should expand to 2 spaces (next tab stop at 8)
|
|
(let ((tmp (tmpnam)))
|
|
(call-with-output-file tmp
|
|
(lambda (p) (display "abcdef\tg\n" p)))
|
|
(let ((diags (lint-file tmp '((%pass . surface)))))
|
|
((@@ (gulie engine) apply-fixes-to-file) tmp diags))
|
|
(let ((result (call-with-input-file tmp get-string-all)))
|
|
(test-assert "tab expanded"
|
|
(not (string-index result #\tab)))
|
|
(test-assert "correct expansion"
|
|
(string-contains result "abcdef g")))
|
|
(delete-file tmp)))
|
|
|
|
(test-group "fix-blank-lines"
|
|
(let ((tmp (tmpnam)))
|
|
(call-with-output-file tmp
|
|
(lambda (p) (display "(define x 1)\n\n\n\n\n(define y 2)\n" p)))
|
|
(let ((diags (lint-file tmp '((%pass . surface)
|
|
(max-blank-lines . 2)))))
|
|
((@@ (gulie engine) apply-fixes-to-file) tmp diags))
|
|
(let* ((result (call-with-input-file tmp get-string-all))
|
|
(lines (string-split result #\newline)))
|
|
;; Should have: (define x 1), 2 blanks, (define y 2) = 5 lines
|
|
;; Original: (define x 1), 4 blanks, (define y 2) = 7 lines (incl final)
|
|
(test-assert "excess blank lines removed"
|
|
(<= (length lines) 5)))
|
|
(delete-file tmp)))
|
|
|
|
(test-group "fix-composition-tabs-and-trailing"
|
|
;; Line with BOTH tabs and trailing whitespace
|
|
;; Should fix both in a single pass
|
|
(let ((tmp (tmpnam)))
|
|
(call-with-output-file tmp
|
|
(lambda (p) (display "\t(define x 1) \n" p)))
|
|
(let ((diags (lint-file tmp '((%pass . surface)))))
|
|
((@@ (gulie engine) apply-fixes-to-file) tmp diags))
|
|
(let ((result (call-with-input-file tmp get-string-all)))
|
|
(test-assert "no tabs remain"
|
|
(not (string-index result #\tab)))
|
|
(test-assert "no trailing whitespace"
|
|
(not (string-suffix? " " (car (string-split result #\newline)))))
|
|
(test-assert "content preserved"
|
|
(string-contains result "(define x 1)")))
|
|
(delete-file tmp)))
|
|
|
|
(test-group "fix-idempotent"
|
|
;; Running fix twice should produce the same result.
|
|
;; Note: when multiple fix types target the same line (tabs + trailing
|
|
;; whitespace + comment semicolons), convergence may take 2 passes.
|
|
;; This test uses a case that converges in one pass.
|
|
(let ((tmp (tmpnam)))
|
|
(call-with-output-file tmp
|
|
(lambda (p) (display "(define x 1) \n\n\n\n\n(define y 2)\n" p)))
|
|
;; First fix
|
|
(let ((diags (lint-file tmp '((%pass . surface)
|
|
(max-blank-lines . 1)))))
|
|
((@@ (gulie engine) apply-fixes-to-file) tmp diags))
|
|
(let ((after-first (call-with-input-file tmp get-string-all)))
|
|
;; Second fix — should change nothing
|
|
(let ((diags (lint-file tmp '((%pass . surface)
|
|
(max-blank-lines . 1)))))
|
|
((@@ (gulie engine) apply-fixes-to-file) tmp diags))
|
|
(let ((after-second (call-with-input-file tmp get-string-all)))
|
|
(test-equal "second fix is idempotent" after-first after-second)))
|
|
(delete-file tmp)))
|
|
|
|
(test-group "fix-multi-pass-convergence"
|
|
;; Line with tabs + trailing whitespace + single semicolon:
|
|
;; may need 2 fix passes since 3 fixes compete for the same line.
|
|
(let ((tmp (tmpnam)))
|
|
(call-with-output-file tmp
|
|
(lambda (p) (display "\t; comment \n" p)))
|
|
;; Pass 1
|
|
(let ((diags (lint-file tmp '((%pass . surface)))))
|
|
((@@ (gulie engine) apply-fixes-to-file) tmp diags))
|
|
;; Pass 2
|
|
(let ((diags (lint-file tmp '((%pass . surface)))))
|
|
((@@ (gulie engine) apply-fixes-to-file) tmp diags))
|
|
(let ((result (call-with-input-file tmp get-string-all)))
|
|
(test-assert "tabs removed after 2 passes"
|
|
(not (string-index result #\tab)))
|
|
(test-assert "trailing whitespace removed"
|
|
(not (string-contains result " \n")))
|
|
(test-assert "semicolon fixed to ;;"
|
|
(string-contains result ";; comment")))
|
|
(delete-file tmp)))
|
|
|
|
;;; Compile-error message formatting
|
|
|
|
(test-group "compile-error-formatting"
|
|
;; Compile a file that references a non-existent module
|
|
(let ((diags ((@@ (gulie compiler) compile-and-capture-warnings)
|
|
"test.scm"
|
|
"(use-modules (nonexistent module))\n(define x 1)\n"
|
|
'())))
|
|
(let ((errors (filter (lambda (d) (eq? (diagnostic-severity d) 'error))
|
|
diags)))
|
|
(test-assert "has compile error" (not (null? errors)))
|
|
(let ((msg (diagnostic-message (car errors))))
|
|
(test-assert "no raw format specifiers in message"
|
|
(not (string-contains msg "~S")))
|
|
(test-assert "no raw format specifiers ~A"
|
|
(not (string-contains msg "~A")))
|
|
(test-assert "contains module name"
|
|
(string-contains msg "nonexistent"))))))
|
|
|
|
;;; 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)))
|
|
(call-with-output-file tmp
|
|
(lambda (p) (display "(define x 42) \n ; comment\n" p)))
|
|
(let ((count (lint-files (list tmp)
|
|
'((%pass . surface) (%fix . #t)))))
|
|
;; After fix, only unfixable diagnostics should be counted
|
|
(test-equal "no unfixable issues" 0 count))
|
|
;; Verify file was actually modified
|
|
(let ((result (call-with-input-file tmp get-string-all)))
|
|
(test-assert "trailing whitespace fixed"
|
|
(not (string-contains result "42) ")))
|
|
(test-assert "comment fixed"
|
|
(string-contains result ";; comment")))
|
|
(delete-file tmp)))
|
|
|
|
(test-end "engine")
|