Add new token API

Eventually this will replace the other ones, hopefully.
remotes/jackfirth/master
Jack Firth 3 years ago
parent d33149d20b
commit e18a3399fe

@ -0,0 +1,128 @@
#lang racket/base
(require (for-syntax racket/base
syntax/parse)
racket/contract/base
racket/match
racket/symbol
rebellion/private/printer-markup)
(provide
token
(contract-out
[token? predicate/c]
[token-type (-> token? (and/c symbol? symbol-interned?))]
[token-value (-> token? any/c)]
[token-location (-> token? (or/c srcloc? #false))]
[token-skip? (-> token? boolean?)]
[source-location
(->* ()
(#:source any/c
#:position (or/c exact-positive-integer? #false)
#:line (or/c exact-positive-integer? #false)
#:column (or/c exact-nonnegative-integer? #false)
#:span (or/c exact-nonnegative-integer? #false))
srcloc?)]
[token-position (-> token? (or/c exact-positive-integer? #false))]
[token-end-position (-> token? (or/c exact-positive-integer? #false))]))
;@----------------------------------------------------------------------------------------------------
(struct token (type value location skip?)
#:constructor-name constructor:token
#:transparent
#:omit-define-syntaxes
#:property prop:custom-print-quotable 'never
#:methods gen:custom-write
[(define write-proc
(make-constructor-style-printer-with-markup
'token
(λ (this)
(append (list (token-type this))
(if (token-value this) (list (token-value this)) (list))
(if (token-location this)
(list
(sequence-markup
(list (unquoted-printing-string "#:location") (token-location this))))
(list))
(if (token-skip? this)
(list
(sequence-markup (list (unquoted-printing-string "#:skip?") (token-skip? this))))
(list))))))])
(define (source-location #:source [source #false]
#:position [position #false]
#:span [span #false]
#:line [line #false]
#:column [column #false])
(srcloc source line column position span))
(define (unchecked:token type
[value #false]
#:location [location #false]
#:skip? [skip? #false])
(let ([type
(cond [(string? type) (string->symbol type)]
[(not (symbol-interned? type)) (string->symbol (symbol->immutable-string type))]
[else type])])
(constructor:token type value location skip?)))
(define-module-boundary-contract contracted:token unchecked:token
(->* ((or/c symbol? string?)) (any/c #:location (or/c srcloc? #false) #:skip? boolean?)
token?)
#:name-for-blame token)
(define-match-expander token
(syntax-parser
[(_
(~alt
(~once value-pattern:expr)
(~optional (~seq #:type type-pattern:expr) #:defaults ([type-pattern #'_]))
(~optional (~seq #:location location-pattern:expr) #:defaults ([location-pattern #'_]))
(~optional (~seq #:skip? skip-pattern:expr) #:defaults ([skip-pattern #'_])))
...)
#'(? token?
(app token-value value-pattern)
(app token-type type-pattern)
(app token-location location-pattern)
(app token-skip? skip-pattern))])
(make-rename-transformer #'contracted:token))
(define (token-position t)
(define loc (token-location t))
(and loc (srcloc-position loc)))
(define (token-end-position t)
(define loc (token-location t))
(define start (and loc (srcloc-position loc)))
(define span (and loc (srcloc-span loc)))
(and start span (+ start span)))
#|
;; yaragg/support
(struct token-struct (type val offset line column span skip?)
#:auto-value #f
#:transparent)
;; yaragg/parser-tools/cfg-parser
(struct tok (name orig-name val start end))
;; yaragg/parser-tools/private-lex/token
(struct token (name value) #:transparent)
(struct position-token (token start-pos end-pos) #:inspector #f)
(struct srcloc-token (token srcloc) #:inspector #f)
|#
Loading…
Cancel
Save