You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
132 lines
4.0 KiB
Racket
132 lines
4.0 KiB
Racket
#lang racket/base
|
|
(require (for-syntax racket/base "parser.rkt"))
|
|
(require br-parser-tools/lex
|
|
(prefix-in : br-parser-tools/lex-sre)
|
|
"parser.rkt"
|
|
"rule-structs.rkt"
|
|
racket/string)
|
|
|
|
(provide lex/1 tokenize)
|
|
|
|
;; A newline can be any one of the following.
|
|
(define-lex-abbrev NL (:or "\r\n" "\r" "\n"))
|
|
|
|
;; chars used for quantifiers & parse-tree filtering
|
|
(define-for-syntax quantifiers "+:*") ; colon is reserved to separate rules and productions
|
|
(define-lex-trans reserved-chars
|
|
(λ(stx) #`(char-set #,(format "~a~a~a" quantifiers hide-char splice-char))))
|
|
|
|
(define-lex-trans hide-char-trans (λ(stx) #`(char-set #,(format "~a" hide-char))))
|
|
(define-lex-trans splice-char-trans (λ(stx) #`(char-set #,(format "~a" splice-char))))
|
|
|
|
(define-lex-abbrevs
|
|
[letter (:or (:/ "a" "z") (:/ #\A #\Z))]
|
|
[digit (:/ #\0 #\9)]
|
|
[id-char (:or letter digit (:& (char-set "+:*@!-.$%&/=?^_~<>") (char-complement (reserved-chars))))]
|
|
[hide-char (hide-char-trans)]
|
|
[splice-char (splice-char-trans)]
|
|
)
|
|
|
|
(define-lex-abbrev id (:& (complement (:+ digit)) (:+ id-char)))
|
|
|
|
(define lex/1
|
|
(lexer-src-pos
|
|
;; handle whitespace chars within quotes as literal tokens: "\n" "\t" '\n' '\t'
|
|
;; by matching the escaped version, and then unescaping them before they become token-LITs
|
|
[(:: "'"
|
|
(:* (:or "\\'" "\\n" "\\t" (:~ "'" "\\")))
|
|
"'")
|
|
(token-LIT (case lexeme
|
|
[("'\\n'") "'\n'"]
|
|
[("'\\t'") "'\t'"]
|
|
[else lexeme]))]
|
|
[(:: "\""
|
|
(:* (:or "\\\"" "\\n" "\\t" (:~ "\"" "\\")))
|
|
"\"")
|
|
(token-LIT (case lexeme
|
|
[("\"\\n\"") "\"\n\""]
|
|
[("\"\\t\"") "\"\t\""]
|
|
[else lexeme]))]
|
|
["("
|
|
(token-LPAREN lexeme)]
|
|
["["
|
|
(token-LBRACKET lexeme)]
|
|
[")"
|
|
(token-RPAREN lexeme)]
|
|
["]"
|
|
(token-RBRACKET lexeme)]
|
|
[hide-char
|
|
(token-HIDE lexeme)]
|
|
[splice-char
|
|
(token-SPLICE lexeme)]
|
|
["|"
|
|
(token-PIPE lexeme)]
|
|
[(:or "+" "*")
|
|
(token-REPEAT lexeme)]
|
|
[whitespace
|
|
;; Skip whitespace
|
|
(return-without-pos (lex/1 input-port))]
|
|
;; Skip comments up to end of line
|
|
;; but detect possble kwargs.
|
|
[(:: (:or "#" ";") ; remove # as comment char
|
|
(complement (:: (:* any-char) NL (:* any-char)))
|
|
(:or NL ""))
|
|
(let ([maybe-kwarg-match (regexp-match #px"^#:(.*?)\\s*(.*?)$" lexeme)])
|
|
(when maybe-kwarg-match
|
|
(let* ([parts (map string->symbol (string-split (string-trim lexeme "#:" #:right? #f)))]
|
|
[kw (car parts)][val (cadr parts)])
|
|
(case kw
|
|
[(prefix-out) (current-prefix-out val)]
|
|
[else (error 'lexer (format "got unknown keyword ~a" kw))])))
|
|
(return-without-pos (lex/1 input-port)))]
|
|
[(eof)
|
|
(token-EOF lexeme)]
|
|
[(:: id (:* whitespace) ":")
|
|
(token-RULE_HEAD lexeme)]
|
|
[(:: hide-char id (:* whitespace) ":")
|
|
(token-RULE_HEAD_HIDDEN lexeme)]
|
|
[(:: splice-char id (:* whitespace) ":")
|
|
(token-RULE_HEAD_SPLICED lexeme)]
|
|
[id
|
|
(token-ID lexeme)]
|
|
|
|
;; We call the error handler for everything else:
|
|
[(:: any-char)
|
|
(let-values ([(rest-of-text end-pos-2)
|
|
(lex-nonwhitespace input-port)])
|
|
((current-parser-error-handler)
|
|
#f
|
|
'error
|
|
(string-append lexeme rest-of-text)
|
|
(position->pos start-pos)
|
|
(position->pos end-pos-2)))]))
|
|
|
|
|
|
;; This is the helper for the error production.
|
|
(define lex-nonwhitespace
|
|
(lexer
|
|
[(:+ (char-complement whitespace))
|
|
(values lexeme end-pos)]
|
|
[any-char
|
|
(values lexeme end-pos)]
|
|
[(eof)
|
|
(values "" end-pos)]))
|
|
|
|
|
|
|
|
;; position->pos: position -> pos
|
|
;; Coerses position structures from br-parser-tools/lex to our own pos structures.
|
|
(define (position->pos a-pos)
|
|
(pos (position-offset a-pos)
|
|
(position-line a-pos)
|
|
(position-col a-pos)))
|
|
|
|
|
|
|
|
;; tokenize: input-port -> (-> token)
|
|
(define (tokenize ip
|
|
#:source [source (object-name ip)])
|
|
(lambda ()
|
|
(parameterize ([file-path source])
|
|
(lex/1 ip))))
|