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

added a scribble/text language for preprocessing

Browse Source 
svn: r8818
This commit is contained in:
Eli Barzilay 2008-02-27 21:34:33 +00:00
parent c9a326111d
commit 2aa9e5fade
3 changed files with 613 additions and 554 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
collects/scribble/reader.ss
View File

@ -1,11 +1,11 @@
;; ============================================================================
;; Implements the @-reader macro for embedding text in Scheme code.
(module reader scheme/base
#lang scheme/base
(require mzlib/string syntax/readerr)
;; --------------------------------------------------------------------------
;; ----------------------------------------------------------------------------
;; utilities for syntax specifications below
;; regexps
@ -13,8 +13,7 @@
(let* ([args (let loop ([xs args])
(if (list? xs) (apply append (map loop xs)) (list xs)))]
[args (map (lambda (x)
(cond
[(bytes? x) x]
(cond [(bytes? x) x]
[(string? x) (string->bytes/utf-8 x)]
[(char? x) (regexp-quote (bytes (char->integer x)))]
[(not x) #""]
@ -33,7 +32,7 @@
[else b]))
(lambda (bs) (list->bytes (map rev-byte (reverse (bytes->list bs)))))))
;; --------------------------------------------------------------------------
;; ----------------------------------------------------------------------------
;; syntax
;; basic syntax customization
@ -60,7 +59,7 @@
(define re:lines-end (^px ch:lines-end))
(define re:end-of-line (^px str:end-of-line))
;; --------------------------------------------------------------------------
;; ----------------------------------------------------------------------------
;; utilities
(define (internal-error label)
@ -76,6 +75,7 @@
(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))
@ -150,9 +150,8 @@
(let loop ([i start] [w 0])
(if (= i len)
w
(loop (add1 i) (+ w (if (eq? 9 (bytes-ref bs i))
(- 8 (modulo w 8))
1))))))))
(loop (add1 i)
(+ w (if (eq? 9 (bytes-ref bs i)) (- 8 (modulo w 8)) 1))))))))
;; a unique eol string
(define eol-token "\n")
@ -161,7 +160,7 @@
(unless (eol-syntax? (datum->syntax #f eol-token))
(internal-error 'invalid-assumption))
;; --------------------------------------------------------------------------
;; ----------------------------------------------------------------------------
;; main reader function for @ constructs
(define (dispatcher char inp source-name line-num col-num position
@ -187,7 +186,7 @@
(define (*match rx) (*regexp-match rx inp))
(define (*match1 rx) (*regexp-match1 rx inp))
;; (define (*skip rx) (*regexp-match-positions rx inp)) <- see above
;; (define (*skip rx) (*regexp-match-positions rx inp)) ; <- see above
(define (*skip rx) (*regexp-match1 rx inp))
(define (*peek rx) (*regexp-match-peek-positions rx inp))
@ -212,13 +211,12 @@
;; needed)
(define (done-items xs)
;; a column marker is either a non-negative integer N (saying the the
;; following code came from at column N), or a negative integer -N
;; (saying that the following code came from column N but no need to add
;; following code came from at column N), or a negative integer -N (saying
;; that the following code came from column N but no need to add
;; indentation at this point because it is at the openning of a {...});
;; `get-lines*' is careful not to include column markers before a newline
;; or the end of the text, and a -N marker can only come from the
;; beginning of the text (and it's never there if the text began with a
;; newline)
;; or the end of the text, and a -N marker can only come from the beginning
;; of the text (and it's never there if the text began with a newline)
(if (andmap eol-syntax? xs)
;; nothing to do
(reverse xs)
@ -277,8 +275,8 @@
(cdr stxs))
(cons stx stxs))))
;; helper for `get-lines*' drop a column marker if the previous item was
;; also a newline (or the beginning)
;; helper for `get-lines*' drop a column marker if the previous item was also
;; a newline (or the beginning)
(define (maybe-drop-marker r)
(if (and (pair? r) (integer? (car r))
(or (null? (cdr r)) (eol-syntax? (cadr r))))
@ -325,9 +323,9 @@
=> (lambda (m)
(let ([x (cond
[(cadr m)
;; the command is a string escape, use `read-stx*'
;; to not get a placeholder, so we can merge the
;; string to others
;; the command is a string escape, use `read-stx*' to
;; not get a placeholder, so we can merge the string
;; to others
(read-stx*)]
[(caddr m)
;; it's an expression escape, get multiple
@ -377,8 +375,8 @@
(read-delimited-list re:datums-begin re:datums-end ch:datums-end)))
(define (get-escape-expr single?)
;; single? means expect just one expression (or none, which is returned
;; as a special-comment)
;; single? means expect just one expression (or none, which is returned as
;; a special-comment)
(let ([get (lambda ()
(parameterize ([current-readtable command-readtable])
(read-delimited-list re:expr-escape re:expr-escape
@ -405,11 +403,9 @@
(define (get-rprefixes) ; return punctuation prefixes in reverse
(let loop ([r '()])
(let-values ([(line col pos) (port-next-location inp)])
(cond
[(*match1 #rx#"^(?:'|`|,@?)")
(cond [(*match1 #rx#"^(?:'|`|,@?)")
=> (lambda (m)
(let ([sym (cond
[(assoc m '([#"'" quote]
(let ([sym (cond [(assoc m '([#"'" quote]
[#"`" quasiquote]
[#"," unquote]
[#",@" unquote-splicing]))
@ -437,8 +433,8 @@
([(rpfxs) (get-rprefixes)]
[(cmd datums lines)
(cond [(get-lines)
;; try get-lines first -- so @|{...}| is not used as a
;; simple expression escape, same for get-datums
;; try get-lines first -- so @|{...}| is not used as a simple
;; expression escape, same for get-datums
=> (lambda (lines) (values #f #f lines))]
[(get-datums)
=> (lambda (datums) (values #f datums (get-lines)))]
@ -470,8 +466,7 @@
(if (null? rpfxs)
stx
(loop (cdr rpfxs) (list (car rpfxs) stx))))])
(datum->syntax #f stx
(list source-name line-num col-num position
(datum->syntax #f stx (list source-name line-num col-num position
(span-from position))))]))
(define (make-dispatcher start-inside? ch:command
@ -492,7 +487,7 @@
re:command re:line-item* re:line-item re:line-item-no-nests
(get-datum-readtable) syntax-post-processor)))
;; --------------------------------------------------------------------------
;; ----------------------------------------------------------------------------
;; readtable
(provide make-at-readtable)
@ -555,7 +550,7 @@
ch:command)])
disp))))
;; --------------------------------------------------------------------------
;; ----------------------------------------------------------------------------
;; readers
(define default-src (gensym 'scribble-reader))
@ -592,5 +587,3 @@
(provide (rename-out [*read read]
[*read-syntax read-syntax])
read-inside read-inside-syntax)
)

34
collects/scribble/text.ss Normal file
View File

@ -0,0 +1,34 @@
#lang scheme/base
(require scheme/promise)
(provide (all-from-out scheme/base scheme/promise))
(define (show x p)
(let show ([x x])
(cond [(or (void? x) (not x) (null? x)) (void)]
[(pair? x) (show (car x)) (show (cdr x))]
[(promise? x) (show (force x))]
[(keyword? x) (show (keyword->string x))]
[(and (procedure? x) (procedure-arity-includes? x 0)) (show (x))]
;; display won't work, since it calls us back
;; [else (display x p)]
;; things that are printed directly
[(bytes? x) (write-bytes x p)]
[(string? x) (write-string x p)]
[(char? x) (write-char x p)]
[(number? x) (write x p)]
;; generic fallback
[else (show (format "~a" x))])))
;; this is too much -- it also changes error messages
;; (global-port-print-handler show)
(port-display-handler (current-output-port) show)
;; the default prints a newline too, avoid that
(current-print display)
;; make it possible to use this language through a repl
;; --> won't work: need an `inside' reader that reads a single expression
;; (require (prefix-in * "text/lang/reader.ss"))
;; (current-prompt-read
;; (lambda () (parameterize ([read-accept-reader #t]) (*read-syntax))))

32
collects/scribble/text/lang/reader.ss Normal file
View File

@ -0,0 +1,32 @@
#lang scheme/base
(require (prefix-in s: "../../reader.ss"))
(provide (rename-out [*read read])
(rename-out [*read-syntax read-syntax]))
(define (*read [inp (current-input-port)])
(wrap inp (s:read-inside inp)))
(define (*read-syntax [src #f] [port (current-input-port)])
(wrap port (s:read-inside-syntax src port)))
(define (wrap port body)
(define (strip-leading-newlines stxs)
(if (null? stxs)
stxs
(let ([p (syntax-property (car stxs) 'scribble)])
(if (and (pair? p) (eq? (car p) 'newline))
(strip-leading-newlines (cdr stxs))
stxs))))
(let* ([p-name (object-name port)]
[name (if (path? p-name)
(let-values ([(base name dir?) (split-path p-name)])
(string->symbol (path->string (path-replace-suffix
name #""))))
'page)]
[id 'doc]
[body (if (syntax? body)
(strip-leading-newlines (syntax->list body))
body)])
`(module ,name scribble/text (#%module-begin . ,body))))