From b0343aa9f02f0024cba7a61db3bcf4165696dd85 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 23 Feb 2013 14:33:08 -0600 Subject: [PATCH] add a contract on the interaction between the module-lexer and the 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) --- collects/framework/private/color.rkt | 10 ---- collects/syntax-color/module-lexer.rkt | 72 +++++++++++++++++++++----- 2 files changed, 59 insertions(+), 23 deletions(-) diff --git a/collects/framework/private/color.rkt b/collects/framework/private/color.rkt index b6ff4a2ceb..39e57b1c88 100644 --- a/collects/framework/private/color.rkt +++ b/collects/framework/private/color.rkt @@ -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)) diff --git a/collects/syntax-color/module-lexer.rkt b/collects/syntax-color/module-lexer.rkt index b666f43837..d00dd74225 100644 --- a/collects/syntax-color/module-lexer.rkt +++ b/collects/syntax-color/module-lexer.rkt @@ -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: