mbutterick
/
pollen
3
3
Fork 0
Code Issues 1 Pull Requests Projects Releases Wiki Activity

customize lexer for pollen/mode

Browse Source
pull/160/head
Matthew Butterick 7 years ago
parent e61263552a
commit 7e4e35594e
2 changed files with 669 additions and 668 deletions
Show Stats Download Patch File Download Diff File

187
pollen/mode.rkt
Unescape Escape View File

@ -91,22 +91,23 @@ Intractable problem; unavoidable limitation.
(fallback)))
(case key
[(color-lexer)
(try-dynamic-require 'syntax-color/scribble-lexer 'scribble-lexer)]
(define lexer-maker (try-dynamic-require 'syntax-color/scribble-lexer 'make-scribble-lexer))
(lexer-maker #:command-char #\◊)]
[(drracket:indentation)
(dynamic-require 'pollen/private/mode-indentation 'determine-spaces)]
[else (fallback)]))))))
(module at-reader racket/base
;; ============================================================================
;; Implements the @-reader macro for embedding text in Racket code.
;; ============================================================================
;; Implements the @-reader macro for embedding text in Racket code.
(require syntax/readerr)
(require syntax/readerr)
;; ----------------------------------------------------------------------------
;; utilities for syntax specifications below
;; ----------------------------------------------------------------------------
;; utilities for syntax specifications below
;; regexps
(define (px . args)
;; regexps
(define (px . args)
(let* ([args (let loop ([xs args])
(if (list? xs) (apply append (map loop xs)) (list xs)))]
[args (map (lambda (x)
@ -117,10 +118,10 @@ Intractable problem; unavoidable limitation.
[else (internal-error 'px)]))
args)])
(byte-pregexp (apply bytes-append args))))
(define (^px . args) (px #"^" args))
(define (^px . args) (px #"^" args))
;; reverses a byte string visually
(define reverse-bytes
;; reverses a byte string visually
(define reverse-bytes
(let ([pairs (let ([xs (bytes->list #"([{<")]
[ys (bytes->list #")]}>")])
(append (map cons xs ys) (map cons ys xs)))])
@ -129,66 +130,66 @@ Intractable problem; unavoidable limitation.
[else b]))
(lambda (bs) (list->bytes (map rev-byte (reverse (bytes->list bs)))))))
;; ----------------------------------------------------------------------------
;; syntax
;; basic syntax customization
(define ch:command #\@)
(define ch:comment #\;)
(define ch:expr-escape #\|)
(define ch:datums-begin #\[)
(define ch:datums-end #\])
(define ch:lines-begin #\{)
(define ch:lines-end #\})
(define str:lines-begin* #"(\\|[^a-zA-Z0-9 \t\r\n\f@\\\177-\377{]*)\\{")
(define str:end-of-line "[ \t]*\r?\n[ \t]*") ; eat spaces on the next line
;; regexps based on the above (more in make-dispatcher)
(define re:whitespaces (^px "\\s+"))
(define re:comment-start (^px ch:comment))
(define re:comment-line (^px "[^\n]*(?:\n|$)[ \t]*")) ; like tex's `%'
(define re:expr-escape (^px ch:expr-escape))
(define re:datums-begin (^px ch:datums-begin))
(define re:datums-end (^px ch:datums-end))
(define re:lines-begin (^px ch:lines-begin))
(define re:lines-begin* (^px str:lines-begin*))
(define re:lines-end (^px ch:lines-end))
(define re:end-of-line (^px str:end-of-line))
;; ----------------------------------------------------------------------------
;; utilities
(define (internal-error label)
;; ----------------------------------------------------------------------------
;; syntax
;; basic syntax customization
(define ch:command #\@)
(define ch:comment #\;)
(define ch:expr-escape #\|)
(define ch:datums-begin #\[)
(define ch:datums-end #\])
(define ch:lines-begin #\{)
(define ch:lines-end #\})
(define str:lines-begin* #"(\\|[^a-zA-Z0-9 \t\r\n\f@\\\177-\377{]*)\\{")
(define str:end-of-line "[ \t]*\r?\n[ \t]*") ; eat spaces on the next line
;; regexps based on the above (more in make-dispatcher)
(define re:whitespaces (^px "\\s+"))
(define re:comment-start (^px ch:comment))
(define re:comment-line (^px "[^\n]*(?:\n|$)[ \t]*")) ; like tex's `%'
(define re:expr-escape (^px ch:expr-escape))
(define re:datums-begin (^px ch:datums-begin))
(define re:datums-end (^px ch:datums-end))
(define re:lines-begin (^px ch:lines-begin))
(define re:lines-begin* (^px str:lines-begin*))
(define re:lines-end (^px ch:lines-end))
(define re:end-of-line (^px str:end-of-line))
;; ----------------------------------------------------------------------------
;; utilities
(define (internal-error label)
(error 'scribble-reader "internal error [~a]" label))
;; like `regexp-try-match', without extras; the regexp that is used
;; must be anchored -- nothing is dropped
(define (*regexp-match-peek-positions pattern input-port)
;; like `regexp-try-match', without extras; the regexp that is used
;; must be anchored -- nothing is dropped
(define (*regexp-match-peek-positions pattern input-port)
#; ; sanity checks, not needed unless this file is edited
(unless (and (byte-regexp? pattern)
(regexp-match? #rx#"^\\^" (object-name pattern)))
(internal-error 'invalid-bregexp))
(regexp-match-peek-positions pattern input-port))
;; the following doesn't work -- must peek first
;; (define (*regexp-match-positions pattern input-port)
;; #; ; sanity checks, not needed unless this file is edited
;; (unless (and (byte-regexp? pattern)
;; (regexp-match? #rx#"^\\^" (object-name pattern)))
;; (internal-error 'invalid-bregexp))
;; (regexp-match-peek-positions pattern input-port))
(define (*regexp-match pattern input-port)
;; the following doesn't work -- must peek first
;; (define (*regexp-match-positions pattern input-port)
;; #; ; sanity checks, not needed unless this file is edited
;; (unless (and (byte-regexp? pattern)
;; (regexp-match? #rx#"^\\^" (object-name pattern)))
;; (internal-error 'invalid-bregexp))
;; (regexp-match-peek-positions pattern input-port))
(define (*regexp-match pattern input-port)
(let ([m (*regexp-match-peek-positions pattern input-port)])
(and m (let ([s (read-bytes (cdar m) input-port)])
(cons s (map (lambda (p) (and p (subbytes s (car p) (cdr p))))
(cdr m)))))))
;; like regexp-match, but returns the whole match
(define (*regexp-match1 pattern input-port)
;; like regexp-match, but returns the whole match
(define (*regexp-match1 pattern input-port)
(let ([m (*regexp-match-peek-positions pattern input-port)])
(and m (read-bytes (cdar m) input-port))))
;; Utility for readtable-based caches
(define (readtable-cached fun)
;; Utility for readtable-based caches
(define (readtable-cached fun)
(let ([cache (make-weak-hasheq)])
(letrec ([readtable-cached
(case-lambda
@ -200,9 +201,9 @@ Intractable problem; unavoidable limitation.
[() (readtable-cached (current-readtable))])])
readtable-cached)))
;; Skips whitespace characters, sensitive to the current readtable's
;; definition of whitespace; optimizes common spaces when possible
(define skip-whitespace
;; Skips whitespace characters, sensitive to the current readtable's
;; definition of whitespace; optimizes common spaces when possible
(define skip-whitespace
(let* ([plain-readtables (make-weak-hasheq)]
[plain-spaces " \t\n\r\f"]
[plain-spaces-list (string->list " \t\n\r\f")]
@ -231,8 +232,8 @@ Intractable problem; unavoidable limitation.
(unless (eof-object? ch)
(when (whitespace? ch rt) (read-char port) (loop)))))))))
;; make n spaces, cached for n
(define make-spaces
;; make n spaces, cached for n
(define make-spaces
(let ([t (make-hasheq)])
(lambda (n)
(hash-ref t n
@ -240,7 +241,7 @@ Intractable problem; unavoidable limitation.
(let ([s (make-string n #\space)])
(hash-set! t n s) s))))))
(define (bytes-width bs start)
(define (bytes-width bs start)
(let ([len (bytes-length bs)])
(if (regexp-match? #rx"^ *$" bs start)
(- (bytes-length bs) start)
@ -250,13 +251,13 @@ Intractable problem; unavoidable limitation.
(loop (add1 i)
(+ w (if (eq? 9 (bytes-ref bs i)) (- 8 (modulo w 8)) 1))))))))
;; A syntax object that has the "original?" property:
(define orig-stx (read-syntax #f (open-input-string "dummy")))
;; A syntax object that has the "original?" property:
(define orig-stx (read-syntax #f (open-input-string "dummy")))
;; ----------------------------------------------------------------------------
;; main reader function for @ constructs
;; ----------------------------------------------------------------------------
;; main reader function for @ constructs
(define (dispatcher char inp source-name line-num col-num position
(define (dispatcher char inp source-name line-num col-num position
start-inside? command-readtable ch:command
re:command re:line-item* re:line-item
re:line-item-no-nests datum-readtable
@ -598,7 +599,7 @@ Intractable problem; unavoidable limitation.
(span-from position))
orig-stx))]))
(define (make-dispatcher start-inside? ch:command
(define (make-dispatcher start-inside? ch:command
get-command-readtable get-datum-readtable
syntax-post-processor)
(define re:command (^px ch:command
@ -616,22 +617,22 @@ Intractable problem; unavoidable limitation.
re:command re:line-item* re:line-item re:line-item-no-nests
(get-datum-readtable) syntax-post-processor)))
;; ----------------------------------------------------------------------------
;; minor utilities for the below
;; ----------------------------------------------------------------------------
;; minor utilities for the below
(define default-src (gensym 'scribble-reader))
(define (src-name src port)
(define default-src (gensym 'scribble-reader))
(define (src-name src port)
(if (eq? src default-src) (object-name port) src))
(define-syntax-rule (named-lambda (name . args) . body)
(define-syntax-rule (named-lambda (name . args) . body)
(let ([name (lambda args . body)]) name))
;; ----------------------------------------------------------------------------
;; readtable and reader
;; ----------------------------------------------------------------------------
;; readtable and reader
(provide make-at-readtable make-at-reader)
(provide make-at-readtable make-at-reader)
(define ((make-at-readtable-or-inside-reader inside-reader?)
(define ((make-at-readtable-or-inside-reader inside-reader?)
readtable command-char command-readtable datum-readtable syntax-post-processor)
(define (get-cmd-rt)
(if (readtable? cmd-rt)
@ -688,7 +689,7 @@ Intractable problem; unavoidable limitation.
"bad datum-readtable: ~e" datum-readtable)]))
(if inside-reader? (make-inside-reader) at-rt))
(define (make-at-readtable
(define (make-at-readtable
#:readtable [readtable (current-readtable)]
#:command-char [command-char ch:command]
#:command-readtable [command-readtable readtable]
@ -697,7 +698,7 @@ Intractable problem; unavoidable limitation.
((make-at-readtable-or-inside-reader #f)
readtable command-char command-readtable datum-readtable syntax-post-processor))
(define (make-at-reader
(define (make-at-reader
#:readtable [readtable (current-readtable)]
#:command-char [command-char ch:command]
#:datum-readtable [datum-readtable #t]
@ -729,40 +730,40 @@ Intractable problem; unavoidable limitation.
;; it might be eof
(if (syntax? r) (syntax->datum r) r))))))))
(provide use-at-readtable)
(define use-at-readtable
(provide use-at-readtable)
(define use-at-readtable
(make-keyword-procedure
(lambda (kws kw-args . rest)
(port-count-lines! (current-input-port))
(current-readtable
(keyword-apply make-at-readtable kws kw-args rest)))))
;; utilities for below
(define make-default-at-readtable
;; utilities for below
(define make-default-at-readtable
(readtable-cached (lambda (rt) (make-at-readtable #:readtable rt
#:command-readtable 'dynamic
#:datum-readtable 'dynamic))))
(define make-default-at-reader/inside
(define make-default-at-reader/inside
(readtable-cached
(lambda (rt) (make-at-reader #:inside? #t #:readtable rt
#:command-readtable 'dynamic
#:datum-readtable 'dynamic))))
;; ----------------------------------------------------------------------------
;; readers
;; ----------------------------------------------------------------------------
;; readers
(provide (rename-out [*read read] [*read-syntax read-syntax]))
(define (*read [inp (current-input-port)])
(provide (rename-out [*read read] [*read-syntax read-syntax]))
(define (*read [inp (current-input-port)])
(parameterize ([current-readtable (make-default-at-readtable)])
(read inp)))
(define (*read-syntax [src default-src] [inp (current-input-port)])
(define (*read-syntax [src default-src] [inp (current-input-port)])
(parameterize ([current-readtable (make-default-at-readtable)])
(read-syntax (src-name src inp) inp)))
(provide read-inside read-syntax-inside)
(define (read-inside [inp (current-input-port)])
(provide read-inside read-syntax-inside)
(define (read-inside [inp (current-input-port)])
(syntax->datum ((make-default-at-reader/inside) default-src inp)))
(define (read-syntax-inside [src default-src] [inp (current-input-port)]
(define (read-syntax-inside [src default-src] [inp (current-input-port)]
#:command-char [command-char ch:command])
(((readtable-cached
(lambda (rt) (make-at-reader #:inside? #t #:command-char command-char #:readtable rt))))

2
pollen/private/ts.rktd
Unescape Escape View File

@ -1 +1 @@
1511198469
1511201538

Write Preview
Loading…
Cancel
Save