Add Scheme source code highlighting with ANSI colors (#48)
ober
c370011bb957d1bd06a01ec40f9adbcd7e09aca8
new file mode 100644 --- /dev/null +++ b/lib/std/misc/highlight.sls @@ -0,0 +1,392 @@ +#!chezscheme +;;; (std misc highlight) — Syntax highlighting for Scheme source code +;;; +;;; Tokenizes Scheme source and applies ANSI color codes or returns SXML. +;;; +;;; (highlight-scheme "(define x 42)") => colored ANSI string +;;; (highlight-scheme/sxml "(if #t \"yes\")") => SXML with categories +;;; (highlight-to-port code port) +;;; (with-theme my-theme (lambda () (highlight-scheme code))) + +(library (std misc highlight) + (export highlight-scheme + highlight-scheme/sxml + highlight-to-port + make-theme + with-theme + default-theme + token-categories) + (import (chezscheme)) + + ;; ========== Token categories ========== + + (define token-categories + '(keyword string number comment boolean paren symbol char whitespace)) + + ;; ========== ANSI escape helpers ========== + + (define esc "\x1b;") + + (define (ansi . codes) + (string-append esc "[" (apply string-append codes) "m")) + + (define ansi-reset (ansi "0")) + + ;; ========== Themes ========== + + ;; A theme is an alist of (category . ansi-code-string) + (define default-theme + `((keyword . ,(ansi "1;34")) ; bold blue + (string . ,(ansi "32")) ; green + (number . ,(ansi "36")) ; cyan + (comment . ,(ansi "2")) ; dim/gray + (boolean . ,(ansi "35")) ; magenta + (paren . ,(ansi "0")) ; default + (symbol . ,(ansi "0")) ; default + (char . ,(ansi "33")) ; yellow + (whitespace . #f))) ; no styling + + (define current-theme (make-parameter default-theme)) + + (define (make-theme alist) + ;; alist of (category . ansi-string-or-#f) + ;; Fills in defaults for missing categories + (map (lambda (default) + (let ([override (assq (car default) alist)]) + (if override override default))) + default-theme)) + + (define-syntax with-theme + (syntax-rules () + [(_ theme body ...) + (parameterize ([current-theme theme]) + body ...)])) + + ;; ========== Keywords ========== + + (define scheme-keywords + '("define" "define-syntax" "define-record-type" "define-condition-type" + "lambda" "let" "let*" "letrec" "letrec*" "let-values" "let*-values" + "if" "cond" "case" "when" "unless" "and" "or" "not" + "begin" "do" "set!" + "quote" "quasiquote" "unquote" "unquote-splicing" + "syntax-rules" "syntax-case" "with-syntax" + "import" "export" "library" + "define-library" "include" "include-ci" + "guard" "raise" "with-exception-handler" + "call-with-current-continuation" "call/cc" + "call-with-values" "values" "receive" + "dynamic-wind" "parameterize" "make-parameter" + "else" "=>" "..." + "define-macro" "define-structure" "define-record" + "syntax" "datum->syntax" "syntax->datum" + "match" "for-each" "map" "apply")) + + (define keyword-set + (let ([ht (make-hashtable string-hash string=?)]) + (for-each (lambda (kw) (hashtable-set! ht kw #t)) scheme-keywords) + ht)) + + (define (keyword? s) + (hashtable-ref keyword-set s #f)) + + ;; ========== Lexer ========== + + ;; A token is (category . text) + ;; The lexer scans through the string character by character. + + (define (delimiter? c) + (or (char-whitespace? c) + (memv c '(#\( #\) #\[ #\] #\{ #\} #\" #\; #\#)))) + + (define (initial? c) + (or (char-alphabetic? c) + (memv c '(#\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\^ #\_ #\~)))) + + (define (subsequent? c) + (or (initial? c) + (char-numeric? c) + (memv c '(#\+ #\- #\. #\@)))) + + (define (tokenize str) + (let ([len (string-length str)] + [tokens '()]) + + (define (emit! cat text) + (set! tokens (cons (cons cat text) tokens))) + + (define (substring* start end) + (substring str start end)) + + (define (scan-whitespace i) + (let loop ([j i]) + (if (and (< j len) (char-whitespace? (string-ref str j))) + (loop (+ j 1)) + (begin (emit! 'whitespace (substring* i j)) + j)))) + + (define (scan-line-comment i) + ;; i points to the ; + (let loop ([j i]) + (if (or (>= j len) (char=? (string-ref str j) #\newline)) + (begin (emit! 'comment (substring* i j)) + j) + (loop (+ j 1))))) + + (define (scan-block-comment i) + ;; i points to the # before | + (let loop ([j (+ i 2)] [depth 1]) + (cond + [(>= j len) + (emit! 'comment (substring* i j)) + j] + [(and (< (+ j 1) len) + (char=? (string-ref str j) #\|) + (char=? (string-ref str (+ j 1)) #\#)) + (if (= depth 1) + (begin (emit! 'comment (substring* i (+ j 2))) + (+ j 2)) + (loop (+ j 2) (- depth 1)))] + [(and (< (+ j 1) len) + (char=? (string-ref str j) #\#) + (char=? (string-ref str (+ j 1)) #\|)) + (loop (+ j 2) (+ depth 1))] + [else (loop (+ j 1) depth)]))) + + (define (scan-string i) + ;; i points to opening " + (let loop ([j (+ i 1)]) + (cond + [(>= j len) + (emit! 'string (substring* i j)) + j] + [(char=? (string-ref str j) #\\) + ;; skip escaped char + (loop (+ j 2))] + [(char=? (string-ref str j) #\") + (emit! 'string (substring* i (+ j 1))) + (+ j 1)] + [else (loop (+ j 1))]))) + + (define (scan-symbol i) + (let loop ([j i]) + (if (and (< j len) (not (delimiter? (string-ref str j)))) + (loop (+ j 1)) + (let ([text (substring* i j)]) + (cond + [(keyword? text) (emit! 'keyword text)] + [else (emit! 'symbol text)]) + j)))) + + (define (number-text? s) + ;; Check if the text looks like a Scheme number + (let ([len (string-length s)]) + (and (> len 0) + (or + ;; Starts with digit + (char-numeric? (string-ref s 0)) + ;; Starts with + or - followed by digit or . + (and (>= len 2) + (memv (string-ref s 0) '(#\+ #\-)) + (or (char-numeric? (string-ref s 1)) + (char=? (string-ref s 1) #\.))) + ;; Starts with . followed by digit + (and (>= len 2) + (char=? (string-ref s 0) #\.) + (char-numeric? (string-ref s 1))))))) + + (define (scan-number-or-symbol i) + ;; Collect the full token, then decide if it's a number + (let loop ([j i]) + (if (and (< j len) (not (delimiter? (string-ref str j)))) + (loop (+ j 1)) + (let ([text (substring* i j)]) + (cond + [(number-text? text) (emit! 'number text)] + [(keyword? text) (emit! 'keyword text)] + [else (emit! 'symbol text)]) + j)))) + + (define (scan-hash i) + ;; i points to # + (cond + ;; Past end + [(>= (+ i 1) len) + (emit! 'symbol "#") + (+ i 1)] + ;; Block comment #| ... |# + [(char=? (string-ref str (+ i 1)) #\|) + (scan-block-comment i)] + ;; Boolean #t, #f, #true, #false + [(memv (string-ref str (+ i 1)) '(#\t #\f #\T #\F)) + (let loop ([j (+ i 2)]) + (if (and (< j len) (char-alphabetic? (string-ref str j))) + (loop (+ j 1)) + (let ([text (substring* i j)]) + (if (member text '("#t" "#f" "#true" "#false" + "#T" "#F" "#TRUE" "#FALSE")) + (emit! 'boolean text) + ;; Could be something like #test — treat as symbol + (emit! 'symbol text)) + j)))] + ;; Character literal #\x + [(char=? (string-ref str (+ i 1)) #\\) + (cond + ;; #\<name> like #\space, #\newline + [(>= (+ i 2) len) + (emit! 'char (substring* i (+ i 2))) + (+ i 2)] + [else + (let loop ([j (+ i 2)]) + (if (and (< j len) (not (delimiter? (string-ref str j)))) + (loop (+ j 1)) + (let ([end (max (+ i 3) j)]) + ;; At minimum take #\<char> + (let ([actual-end (if (> j (+ i 2)) j (min (+ i 3) len))]) + (emit! 'char (substring* i actual-end)) + actual-end))))])] + ;; Datum comment #; + [(char=? (string-ref str (+ i 1)) #\;) + (emit! 'comment "#;") + (+ i 2)] + ;; Reader directives like #!chezscheme, #!eof, #!r6rs + [(char=? (string-ref str (+ i 1)) #\!) + (let loop ([j (+ i 2)]) + (if (and (< j len) + (not (char-whitespace? (string-ref str j))) + (not (delimiter? (string-ref str j)))) + (loop (+ j 1)) + (begin (emit! 'comment (substring* i j)) + j)))] + ;; Vector #( + [(char=? (string-ref str (+ i 1)) #\() + (emit! 'paren "#(") + (+ i 2)] + ;; Bytevector #vu8( + [(and (>= (+ i 4) len) + (char=? (string-ref str (+ i 1)) #\v)) + ;; scan to ( + (let loop ([j (+ i 1)]) + (cond + [(>= j len) + (emit! 'symbol (substring* i j)) + j] + [(char=? (string-ref str j) #\() + (emit! 'paren (substring* i (+ j 1))) + (+ j 1)] + [else (loop (+ j 1))]))] + ;; Numeric prefix #e, #i, #b, #o, #d, #x + [(memv (string-ref str (+ i 1)) '(#\e #\i #\b #\o #\d #\x + #\E #\I #\B #\O #\D #\X)) + ;; Scan the full number + (let loop ([j (+ i 2)]) + (if (and (< j len) (not (delimiter? (string-ref str j)))) + (loop (+ j 1)) + (begin (emit! 'number (substring* i j)) + j)))] + ;; Fallback + [else + (let loop ([j (+ i 1)]) + (if (and (< j len) (not (delimiter? (string-ref str j)))) + (loop (+ j 1)) + (begin (emit! 'symbol (substring* i j)) + j)))])) + + ;; Main scan loop + (let loop ([i 0]) + (when (< i len) + (let ([c (string-ref str i)]) + (cond + [(char-whitespace? c) + (loop (scan-whitespace i))] + [(char=? c #\;) + (loop (scan-line-comment i))] + [(char=? c #\") + (loop (scan-string i))] + [(or (char=? c #\() (char=? c #\)) + (char=? c #\[) (char=? c #\]) + (char=? c #\{) (char=? c #\})) + (emit! 'paren (string c)) + (loop (+ i 1))] + [(char=? c #\#) + (loop (scan-hash i))] + [(char=? c #\') + (emit! 'keyword "'") + (loop (+ i 1))] + [(char=? c #\`) + (emit! 'keyword "`") + (loop (+ i 1))] + [(and (char=? c #\,) + (< (+ i 1) len) + (char=? (string-ref str (+ i 1)) #\@)) + (emit! 'keyword ",@") + (loop (+ i 2))] + [(char=? c #\,) + (emit! 'keyword ",") + (loop (+ i 1))] + [(or (char-numeric? c) + (and (memv c '(#\+ #\-)) + (< (+ i 1) len) + (or (char-numeric? (string-ref str (+ i 1))) + (char=? (string-ref str (+ i 1)) #\.)))) + (loop (scan-number-or-symbol i))] + [(and (char=? c #\.) + (< (+ i 1) len) + (char-numeric? (string-ref str (+ i 1)))) + (loop (scan-number-or-symbol i))] + [else + (loop (scan-symbol i))])))) + + (reverse tokens))) + + ;; ========== Rendering ========== + + (define (theme-color theme category) + (let ([entry (assq category theme)]) + (if entry (cdr entry) #f))) + + (define (tokens->ansi-string tokens theme) + (let ([port (open-output-string)]) + (for-each + (lambda (tok) + (let ([cat (car tok)] + [text (cdr tok)]) + (let ([color (theme-color theme cat)]) + (when (and color (not (eq? cat 'whitespace))) + (display color port)) + (display text port) + (when (and color (not (eq? cat 'whitespace))) + (display ansi-reset port))))) + tokens) + (get-output-string port))) + + (define (tokens->sxml tokens) + ;; Returns (highlight (span (@ (class "category")) "text") ...) + `(highlight + ,@(map (lambda (tok) + (let ([cat (car tok)] + [text (cdr tok)]) + (if (eq? cat 'whitespace) + text + `(span (@ (class ,(symbol->string cat))) ,text)))) + tokens))) + + ;; ========== Public API ========== + + (define (highlight-scheme code) + (let ([tokens (tokenize code)]) + (tokens->ansi-string tokens (current-theme)))) + + (define (highlight-scheme/sxml code) + (let ([tokens (tokenize code)]) + (tokens->sxml tokens))) + + (define highlight-to-port + (case-lambda + [(code port) + (display (highlight-scheme code) port)] + [(code port theme) + (with-theme theme + (display (highlight-scheme code) port))])) + +) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-highlight.ss @@ -0,0 +1,365 @@ +#!/usr/bin/env scheme-script +#!chezscheme +(import (chezscheme) + (std misc highlight)) + +(define test-count 0) +(define pass-count 0) + +(define (test name thunk) + (set! test-count (+ test-count 1)) + (guard (e [#t (display "FAIL: ") (display name) (newline) + (display " Error: ") (display (condition-message e)) (newline)]) + (thunk) + (set! pass-count (+ pass-count 1)) + (display "PASS: ") (display name) (newline))) + +(define (assert-equal actual expected msg) + (unless (equal? actual expected) + (error 'assert-equal + (string-append msg ": expected " (format "~s" expected) + " got " (format "~s" actual))))) + +(define (assert-true val msg) + (unless val + (error 'assert-true (string-append msg ": expected true")))) + +(define (string-contains haystack needle) + (let ([hlen (string-length haystack)] + [nlen (string-length needle)]) + (let loop ([i 0]) + (cond + [(> (+ i nlen) hlen) #f] + [(string=? (substring haystack i (+ i nlen)) needle) i] + [else (loop (+ i 1))])))) + +(define esc "\x1b;") + +;; ========== Token classification tests ========== + +(test "highlight-scheme returns a string" + (lambda () + (assert-true (string? (highlight-scheme "(+ 1 2)")) + "result should be a string"))) + +(test "highlight-scheme preserves code text" + (lambda () + ;; Stripping ANSI codes should yield the original text + (let* ([code "(define x 42)"] + [highlighted (highlight-scheme code)] + ;; Remove all ANSI escape sequences + [stripped (let loop ([i 0] [acc '()]) + (cond + [(>= i (string-length highlighted)) + (list->string (reverse acc))] + [(and (char=? (string-ref highlighted i) #\x1b) + (< (+ i 1) (string-length highlighted)) + (char=? (string-ref highlighted (+ i 1)) #\[)) + ;; Skip until 'm' + (let skip ([j (+ i 2)]) + (cond + [(>= j (string-length highlighted)) + (list->string (reverse acc))] + [(char=? (string-ref highlighted j) #\m) + (loop (+ j 1) acc)] + [else (skip (+ j 1))]))] + [else (loop (+ i 1) (cons (string-ref highlighted i) acc))]))]) + (assert-equal stripped code "stripped text matches original")))) + +(test "keyword coloring" + (lambda () + (let ([result (highlight-scheme "define")]) + ;; Should contain bold blue ANSI code + (assert-true (string-contains result (string-append esc "[1;34m")) + "keyword should have bold blue")))) + +(test "string coloring" + (lambda () + (let ([result (highlight-scheme "\"hello world\"")]) + (assert-true (string-contains result (string-append esc "[32m")) + "string should have green")))) + +(test "number coloring" + (lambda () + (let ([result (highlight-scheme "42")]) + (assert-true (string-contains result (string-append esc "[36m")) + "number should have cyan")))) + +(test "comment coloring" + (lambda () + (let ([result (highlight-scheme "; a comment")]) + (assert-true (string-contains result (string-append esc "[2m")) + "comment should have dim")))) + +(test "boolean coloring" + (lambda () + (let ([result (highlight-scheme "#t")]) + (assert-true (string-contains result (string-append esc "[35m")) + "boolean should have magenta")))) + +(test "character literal coloring" + (lambda () + (let ([result (highlight-scheme "#\\x")]) + (assert-true (string-contains result (string-append esc "[33m")) + "char should have yellow")))) + +(test "multi-character literal #\\space" + (lambda () + (let ([result (highlight-scheme "#\\space")]) + (assert-true (string-contains result (string-append esc "[33m")) + "named char should have yellow")))) + +;; ========== SXML output tests ========== + +(test "highlight-scheme/sxml returns sxml" + (lambda () + (let ([result (highlight-scheme/sxml "(+ 1 2)")]) + (assert-true (pair? result) "should be a list") + (assert-equal (car result) 'highlight "root should be 'highlight")))) + +(test "sxml keyword classification" + (lambda () + (let ([result (highlight-scheme/sxml "define")]) + ;; Should have (span (@ (class "keyword")) "define") + (let ([spans (filter (lambda (x) (and (pair? x) (eq? (car x) 'span))) + (cdr result))]) + (assert-true (not (null? spans)) "should have span elements") + (let ([span (car spans)]) + (assert-equal (cadr span) '(@ (class "keyword")) + "class should be keyword")))))) + +(test "sxml string classification" + (lambda () + (let ([result (highlight-scheme/sxml "\"hello\"")]) + (let ([spans (filter (lambda (x) (and (pair? x) (eq? (car x) 'span))) + (cdr result))]) + (assert-true (not (null? spans)) "should have span") + (let ([span (car spans)]) + (assert-equal (cadr span) '(@ (class "string")) + "class should be string")))))) + +(test "sxml number classification" + (lambda () + (let ([result (highlight-scheme/sxml "42")]) + (let ([spans (filter (lambda (x) (and (pair? x) (eq? (car x) 'span))) + (cdr result))]) + (let ([span (car spans)]) + (assert-equal (cadr span) '(@ (class "number")) + "class should be number")))))) + +(test "sxml boolean classification" + (lambda () + (let ([result (highlight-scheme/sxml "#f")]) + (let ([spans (filter (lambda (x) (and (pair? x) (eq? (car x) 'span))) + (cdr result))]) + (let ([span (car spans)]) + (assert-equal (cadr span) '(@ (class "boolean")) + "class should be boolean")))))) + +(test "sxml comment classification" + (lambda () + (let ([result (highlight-scheme/sxml "; hello")]) + (let ([spans (filter (lambda (x) (and (pair? x) (eq? (car x) 'span))) + (cdr result))]) + (let ([span (car spans)]) + (assert-equal (cadr span) '(@ (class "comment")) + "class should be comment")))))) + +(test "sxml paren classification" + (lambda () + (let ([result (highlight-scheme/sxml "()")]) + (let ([spans (filter (lambda (x) (and (pair? x) (eq? (car x) 'span))) + (cdr result))]) + (assert-equal (length spans) 2 "should have 2 paren spans") + (assert-equal (cadr (car spans)) '(@ (class "paren")) + "class should be paren"))))) + +(test "sxml char classification" + (lambda () + (let ([result (highlight-scheme/sxml "#\\a")]) + (let ([spans (filter (lambda (x) (and (pair? x) (eq? (car x) 'span))) + (cdr result))]) + (let ([span (car spans)]) + (assert-equal (cadr span) '(@ (class "char")) + "class should be char")))))) + +;; ========== Complex expression tests ========== + +(test "full expression highlighting" + (lambda () + (let ([result (highlight-scheme/sxml "(define (factorial n)\n (if (< n 2) 1\n (* n (factorial (- n 1)))))")]) + (assert-true (pair? result) "should produce sxml") + ;; Check that we have keyword spans for 'define' and 'if' + (let ([spans (filter (lambda (x) (and (pair? x) (eq? (car x) 'span))) + (cdr result))]) + (let ([keyword-spans + (filter (lambda (sp) + (equal? (cadr sp) '(@ (class "keyword")))) + spans)]) + (assert-true (>= (length keyword-spans) 2) + "should have at least 2 keywords")))))) + +(test "block comment #| ... |#" + (lambda () + (let ([result (highlight-scheme/sxml "#| block comment |#")]) + (let ([spans (filter (lambda (x) (and (pair? x) (eq? (car x) 'span))) + (cdr result))]) + (assert-true (not (null? spans)) "should have spans") + (assert-equal (cadr (car spans)) '(@ (class "comment")) + "block comment should be comment"))))) + +(test "nested block comments" + (lambda () + (let ([result (highlight-scheme/sxml "#| outer #| inner |# outer |#")]) + (let ([spans (filter (lambda (x) (and (pair? x) (eq? (car x) 'span))) + (cdr result))]) + (assert-equal (length spans) 1 "should be single comment span") + (assert-equal (caddr (car spans)) "#| outer #| inner |# outer |#" + "should capture full nested comment"))))) + +(test "escaped characters in strings" + (lambda () + (let ([result (highlight-scheme/sxml "\"hello \\\"world\\\"\"")]) + (let ([spans (filter (lambda (x) (and (pair? x) (eq? (car x) 'span))) + (cdr result))]) + (assert-equal (length spans) 1 "should be single string span") + (assert-equal (cadr (car spans)) '(@ (class "string")) + "should be string class"))))) + +(test "negative number" + (lambda () + (let ([result (highlight-scheme/sxml "-42")]) + (let ([spans (filter (lambda (x) (and (pair? x) (eq? (car x) 'span))) + (cdr result))]) + (assert-equal (cadr (car spans)) '(@ (class "number")) + "negative number should be number class"))))) + +(test "hex number prefix" + (lambda () + (let ([result (highlight-scheme/sxml "#xFF")]) + (let ([spans (filter (lambda (x) (and (pair? x) (eq? (car x) 'span))) + (cdr result))]) + (assert-equal (cadr (car spans)) '(@ (class "number")) + "#xFF should be number class"))))) + +(test "reader directive #!chezscheme" + (lambda () + (let ([result (highlight-scheme/sxml "#!chezscheme")]) + (let ([spans (filter (lambda (x) (and (pair? x) (eq? (car x) 'span))) + (cdr result))]) + (assert-equal (cadr (car spans)) '(@ (class "comment")) + "reader directive should be comment class"))))) + +;; ========== highlight-to-port test ========== + +(test "highlight-to-port writes to port" + (lambda () + (let ([port (open-output-string)]) + (highlight-to-port "(+ 1 2)" port) + (let ([result (get-output-string port)]) + (assert-true (> (string-length result) 0) + "should write something") + (assert-true (string-contains result esc) + "should contain ANSI escapes"))))) + +;; ========== Theme tests ========== + +(test "make-theme overrides defaults" + (lambda () + (let ([theme (make-theme `((keyword . ,(string-append esc "[31m"))))]) + ;; keyword should now be red + (let ([keyword-entry (assq 'keyword theme)]) + (assert-equal (cdr keyword-entry) (string-append esc "[31m") + "keyword should be overridden to red")) + ;; string should still be green (default) + (let ([string-entry (assq 'string theme)]) + (assert-equal (cdr string-entry) (string-append esc "[32m") + "string should keep default green"))))) + +(test "with-theme changes highlight colors" + (lambda () + (let ([red-keywords (make-theme `((keyword . ,(string-append esc "[31m"))))]) + (let ([result (with-theme red-keywords (highlight-scheme "define"))]) + (assert-true (string-contains result (string-append esc "[31m")) + "should use red for keywords with custom theme") + (assert-true (not (string-contains result (string-append esc "[1;34m"))) + "should not use default blue"))))) + +(test "with-theme is scoped" + (lambda () + (let ([red-keywords (make-theme `((keyword . ,(string-append esc "[31m"))))]) + (with-theme red-keywords (highlight-scheme "define")) + ;; After with-theme, should be back to default + (let ([result (highlight-scheme "define")]) + (assert-true (string-contains result (string-append esc "[1;34m")) + "should be back to default theme"))))) + +(test "highlight-to-port with custom theme" + (lambda () + (let ([port (open-output-string)] + [theme (make-theme `((keyword . ,(string-append esc "[31m"))))]) + (highlight-to-port "define" port theme) + (let ([result (get-output-string port)]) + (assert-true (string-contains result (string-append esc "[31m")) + "should use custom theme via highlight-to-port"))))) + +;; ========== Edge case tests ========== + +(test "empty string" + (lambda () + (assert-equal (highlight-scheme "") "" "empty input => empty output"))) + +(test "whitespace only" + (lambda () + (assert-equal (highlight-scheme " ") " " "whitespace preserved"))) + +(test "quote shorthand" + (lambda () + (let ([result (highlight-scheme/sxml "'foo")]) + (let ([spans (filter (lambda (x) (and (pair? x) (eq? (car x) 'span))) + (cdr result))]) + (assert-true (>= (length spans) 2) "should have quote and symbol"))))) + +(test "quasiquote and unquote" + (lambda () + (let ([result (highlight-scheme/sxml "`(a ,b ,@c)")]) + (let ([spans (filter (lambda (x) (and (pair? x) (eq? (car x) 'span))) + (cdr result))]) + (assert-true (>= (length spans) 5) "should tokenize quasiquote expression"))))) + +(test "datum comment #;" + (lambda () + (let ([result (highlight-scheme/sxml "#; (foo)")]) + (let ([spans (filter (lambda (x) (and (pair? x) (eq? (car x) 'span))) + (cdr result))]) + (assert-equal (cadr (car spans)) '(@ (class "comment")) + "#; should be comment"))))) + +(test "vector literal #(" + (lambda () + (let ([result (highlight-scheme/sxml "#(1 2 3)")]) + (let ([spans (filter (lambda (x) (and (pair? x) (eq? (car x) 'span))) + (cdr result))]) + (assert-true (not (null? spans)) "should tokenize vector"))))) + +(test "token-categories export" + (lambda () + (assert-true (list? token-categories) "should be a list") + (assert-true (memq 'keyword token-categories) "should contain keyword") + (assert-true (memq 'string token-categories) "should contain string") + (assert-true (memq 'comment token-categories) "should contain comment"))) + +(test "default-theme export" + (lambda () + (assert-true (list? default-theme) "should be a list") + (assert-true (assq 'keyword default-theme) "should have keyword entry") + (assert-true (assq 'string default-theme) "should have string entry"))) + +;; ========== Summary ========== + +(newline) +(display "=========================================") (newline) +(display (format "Results: ~a/~a passed" pass-count test-count)) (newline) +(display "=========================================") (newline) +(when (< pass-count test-count) + (exit 1))