use lexer-srloc

beautiful-racket-demo/basic-demo/tokenizer.rkt

@@ -5,7 +5,7 @@
 (provide (all-defined-out))
 
 (define basic-lexer
-  (lexer-src-pos
+  (lexer-srcloc
    [(eof) eof]
    [whitespace (token lexeme #:skip? #t)]
    [(from/to "rem" "\n") (token 'REM (string-downcase lexeme))]

brag/brag/codegen/runtime.rkt

@@ -118,6 +118,16 @@
                                  e
                                  (lex:position-token-end-pos a-position-token)))]
 
+        [(lex:srcloc-token t loc)
+         (define a-position-token (loop t))
+         (lex:position-token (lex:position-token-token a-position-token)
+                             (if (no-position? (lex:position-token-start-pos a-position-token))
+                                 (lex:position (srcloc-position loc) (srcloc-line loc) (srcloc-column loc))
+                                 (lex:position-token-start-pos a-position-token))
+                             (if (no-position? (lex:position-token-start-pos a-position-token))
+                                 (lex:position (+ (srcloc-position loc) (srcloc-span loc)) #f #f)
+                                 (lex:position-token-end-pos a-position-token)))]
+        
         [else
          ;; Otherwise, we have no idea how to treat this as a token.
          ((current-tokenizer-error-handler) 'unknown-type (format "~a" next-token)

brag/brag/support.rkt

@@ -35,17 +35,22 @@
 ;; This is intended to be a general token structure constructor that's nice
 ;; to work with.
 ;; It should cooperate with the tokenizers constructed with make-permissive-tokenizer.
-(define token
+(define (token type                 ;; (U symbol string)
-  (lambda (type                 ;; (U symbol string)
+               [val #f]  ;; any
-           [val #f]  ;; any
+               [srcloc #f]
-           #:position [position #f] ;; (U #f number)
+               #:position [position #f] ;; (U #f number)
-           #:line [line #f]     ;; (U #f number)
+               #:line [line #f]     ;; (U #f number)
-           #:column [column #f] ;; (U #f number)
+               #:column [column #f] ;; (U #f number)
-           #:span [span #f]     ;; boolean
+               #:span [span #f]     ;; boolean
-           #:skip? [skip? #f])
+               #:skip? [skip? #f])
-    (token-struct (if (string? type) (string->symbol type) type)
+  (token-struct (if (string? type) (string->symbol type) type)
-                  val
+                val
-                  position line column span skip?)))
+                ;; keyword values take precedence over srcloc values
+                (or position (and srcloc (srcloc-position srcloc)))
+                (or line (and srcloc (srcloc-line srcloc)))
+                (or column (and srcloc (srcloc-column srcloc)))
+                (or span (and srcloc (srcloc-span srcloc)))
+                skip?))
 
 
 ;; When bad things happen, we need to emit errors with source location.
@@ -62,10 +67,14 @@
                          in))
   (define token-producer (tokenize input-port))
   (for/list ([token (in-producer token-producer (λ(tok)
-                                                  ;; position-tokens are produced by lexer-src-pos
+                                                  (eq? eof (cond
-                                                  (eq? eof (if (position-token? tok)
+                                                             ;; position-tokens are produced by lexer-src-pos,
-                                                               (position-token-token tok)
+                                                             [(position-token? tok)
-                                                               tok))))])
+                                                              (position-token-token tok)]
+                                                             ;; and srcloc-tokens by lexer-srcloc
+                                                             [(srcloc-token? tok)
+                                                              (srcloc-token-token tok)]
+                                                             [else tok]))))])
             token))
 
 (provide trim-ends)
@@ -86,7 +95,7 @@
       [(_ . STRS)
        (with-syntax ([(UCSTR ...) (map (compose1 string-upcase syntax->datum) (syntax->list #'STRS))]
                      [(LCSTR ...) (map (compose1 string-downcase syntax->datum) (syntax->list #'STRS))])
-       #'(union (union UCSTR ...) (union LCSTR ...)))])))
+         #'(union (union UCSTR ...) (union LCSTR ...)))])))
 
 ;; change names of lexer abbreviations to be consistent with Racket srcloc conventions