suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add a contract on the interaction between the module-lexer and the

Browse Source 
lexers it defers to

also, remove the checks in color.rkt in the framework (they are not
all covered by the added contract, but they mostly are and when they
aren't, most of those times are using the heavily tested racket-lexer)
This commit is contained in:
Robby Findler 2013-02-23 14:33:08 -06:00
parent 4cc9eb0326
commit b0343aa9f0
2 changed files with 59 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/framework/private/color.rkt
View File

@ -337,16 +337,6 @@ added get-regions
(set-lexer-state-up-to-date?! ls #t)
(re-tokenize-move-to-next-ls start-time #t)]
[else
(unless (exact-positive-integer? new-token-start)
(error 'color:text<%> "expected an exact nonnegative integer for the token start, got ~e" new-token-start))
(unless (exact-positive-integer? new-token-end)
(error 'color:text<%> "expected an exact nonnegative integer for the token end, got ~e" new-token-end))
(unless (exact-nonnegative-integer? backup-delta)
(error 'color:text<%> "expected an exact nonnegative integer for the backup delta, got ~e" backup-delta))
(unless (new-token-start . < . new-token-end)
(error 'color:text<%>
"expected the distance between the start and end position for each token to be positive, but start was ~e and end was ~e"
new-token-start new-token-end))
(unless (<= pos-before new-token-start pos-after)
(error 'color:text<%>
"expected the token start to be between ~s and ~s, got ~s" pos-before pos-after new-token-start))

72
collects/syntax-color/module-lexer.rkt
View File

@ -1,6 +1,7 @@
#lang scheme/base
(require scheme/port
"scheme-lexer.rkt")
#lang racket/base
(require racket/port
"racket-lexer.rkt"
racket/contract)
(provide module-lexer)
#|
@ -22,6 +23,32 @@ to delegate to the scheme-lexer (in the 'no-lang-line mode).
|#
(define lexer/c
(or/c (->i ([in input-port?])
(values [txt any/c]
[type symbol?]
[paren (or/c symbol? #f)]
[start (or/c exact-positive-integer? #f)]
[end (start)
(if start
(and/c exact-positive-integer?
(>=/c start))
#f)]))
(->i ([in input-port?]
[offset exact-nonnegative-integer?]
[mode any/c])
(values [txt any/c]
[type symbol?]
[paren (or/c symbol? #f)]
[start (or/c exact-positive-integer? #f)]
[end (start)
(if start
(and/c exact-positive-integer?
(>=/c start))
#f)]
[backup exact-nonnegative-integer?]
[new-mode any/c]))))
(define (module-lexer in offset mode)
(cond
[(or (not mode) (eq? mode 'before-lang-line))
@ -30,7 +57,7 @@ to delegate to the scheme-lexer (in the 'no-lang-line mode).
(when line
(port-count-lines! lexer-port)))
(set-port-next-location-from in lexer-port)
(define-values (lexeme type data new-token-start new-token-end) (scheme-lexer lexer-port))
(define-values (lexeme type data new-token-start new-token-end) (racket-lexer lexer-port))
(cond
[(or (eq? type 'comment) (eq? type 'white-space))
(define lexer-end (file-position lexer-port))
@ -41,32 +68,51 @@ to delegate to the scheme-lexer (in the 'no-lang-line mode).
[else
;; look for #lang:
(define p (peeking-input-port in #:init-position (+ 1 (file-position in))))
(define name-p (peeking-input-port in #:init-position (+ 1 (file-position in))))
(let-values ([(line col pos) (port-next-location in)])
(when line
(port-count-lines! p)))
(port-count-lines! p)
(port-count-lines! name-p)))
(set-port-next-location-from in p)
(set-port-next-location-from in name-p)
(define-values (_1 _2 start-pos) (port-next-location p))
(define get-info (with-handlers ([exn:fail? values]) (read-language p (λ () 'fail))))
(define-values (_3 _4 end-pos) (port-next-location p))
(cond
[(procedure? get-info)
(define lang-name
(apply string
(filter
char?
(for/list ([i (in-range (file-position in) (file-position p))])
(read-char name-p)))))
;; sync ports
(for ([i (in-range (file-position in) (file-position p))])
(read-byte-or-special in))
(define no-ctc-lexer (or (get-info 'color-lexer #f)
racket-lexer))
;; add the lexer contract
(define the-lexer (contract lexer/c
no-ctc-lexer
lang-name
'syntax-color/module-lexer
(or (object-name no-ctc-lexer)
(format "~a's lexer" lang-name))
#'here))
;; Produce language as first token:
(values
"#lang"
lang-name
'other
#f
start-pos
end-pos
0
(or (let ([v (get-info 'color-lexer #f)])
(and v
(if (procedure-arity-includes? v 3)
(cons v #f)
v)))
scheme-lexer))]
(if (procedure-arity-includes? the-lexer 3)
(cons the-lexer #f)
the-lexer))]
[(and (eq? type 'other)
(string? lexeme)
@ -82,7 +128,7 @@ to delegate to the scheme-lexer (in the 'no-lang-line mode).
(values lexeme type data new-token-start new-token-end 0 'no-lang-line)])])]
[(eq? mode 'no-lang-line)
(let-values ([(lexeme type data new-token-start new-token-end)
(scheme-lexer in)])
(racket-lexer in)])
(values lexeme type data new-token-start new-token-end 0 'no-lang-line))]
[(pair? mode)
;; #lang-selected language consumes and produces a mode: