|
|
|
|
@ -1,5 +1,5 @@
|
|
|
|
|
#lang racket/base
|
|
|
|
|
(require brag/support (submod brag/rules/lexer lex-abbrevs) brag/support racket/match)
|
|
|
|
|
(require brag/support (submod brag/rules/lexer lex-abbrevs) racket/match)
|
|
|
|
|
(provide color-brag)
|
|
|
|
|
|
|
|
|
|
(define brag-syntax-lexer
|
|
|
|
|
@ -8,32 +8,22 @@
|
|
|
|
|
[whitespace (return-without-srcloc (brag-syntax-lexer input-port))]
|
|
|
|
|
[(:or (from/to "'" "'") (from/to "\"" "\"")) (token 'LIT lexeme)]
|
|
|
|
|
[(:or (char-set "()[]|+*:") hide-char splice-char) (token 'MISC lexeme)]
|
|
|
|
|
[(:seq (:or "#" ";")
|
|
|
|
|
(complement (:seq (:* any-char) NL (:* any-char)))
|
|
|
|
|
(:or NL ""))
|
|
|
|
|
(token 'COMMENT lexeme)]
|
|
|
|
|
[(:seq (:or "#" ";") (complement (:seq (:* any-char) NL (:* any-char))) (:or NL "")) (token 'COMMENT lexeme)]
|
|
|
|
|
[id (token 'ID lexeme)]
|
|
|
|
|
[any-char (token 'OTHER lexeme)]))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define (color-brag port)
|
|
|
|
|
(define srcloc-tok
|
|
|
|
|
(with-handlers
|
|
|
|
|
([exn:fail:read?
|
|
|
|
|
(λ (exn) (srcloc-token (token 'ERROR) (car (exn:fail:read-srclocs exn))))])
|
|
|
|
|
(brag-syntax-lexer port)))
|
|
|
|
|
(define srcloc-tok (brag-syntax-lexer port))
|
|
|
|
|
(if (eof-object? srcloc-tok)
|
|
|
|
|
(values srcloc-tok 'eof #f #f #f)
|
|
|
|
|
(match-let* ([(srcloc-token
|
|
|
|
|
(token-struct type val _ _ _ _ _)
|
|
|
|
|
(srcloc _ _ _ posn span)) srcloc-tok]
|
|
|
|
|
(match-let* ([(srcloc-token (token-struct type val _ _ _ _ _) (srcloc _ _ _ posn span)) srcloc-tok]
|
|
|
|
|
[(cons start end) (cons posn (+ posn span))]
|
|
|
|
|
[(cons _ cat) (or (assq type
|
|
|
|
|
'((ID . symbol)
|
|
|
|
|
(LIT . string)
|
|
|
|
|
(MISC . parenthesis)
|
|
|
|
|
(COMMENT . comment)
|
|
|
|
|
(ERROR . error)))
|
|
|
|
|
(COMMENT . comment)))
|
|
|
|
|
(cons 'OTHER 'no-color))])
|
|
|
|
|
(values val cat #f start end))))
|
|
|
|
|
|
|
|
|
|
|
