suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

doc work, especially ports in reference

Browse Source 
svn: r6795

original commit: 174eb84534009c1e80d82f1cec9591f382a45c76
This commit is contained in:
Matthew Flatt 2007-07-02 08:07:55 +00:00
parent 0ec270b536
commit d7fc3681f5
4 changed files with 70 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
collects/scribble/comment-reader.ss Normal file
View File

@ -0,0 +1,48 @@
(module comment-reader mzscheme
(require (lib "kw.ss"))
(provide (rename *read read)
(rename *read-syntax read-syntax))
(define/kw (*read #:optional [inp (current-input-port)])
(parameterize ([current-readtable (make-comment-readtable)])
(read/recursive inp)))
(define/kw (*read-syntax #:optional src [port (current-input-port)])
(parameterize ([current-readtable (make-comment-readtable)])
(read-syntax/recursive src port)))
(define (make-comment-readtable)
(make-readtable (current-readtable)
#\; 'terminating-macro
(case-lambda
[(char port)
(do-comment port (lambda () (read/recursive port #\@)))]
[(char port src line col pos)
(let ([v (do-comment port (lambda () (read-syntax/recursive src port #\@)))])
(let-values ([(eline ecol epos) (port-next-location port)])
(datum->syntax-object
#f
v
(list src line col pos (and pos epos (- epos pos))))))])))
(define (do-comment port recur)
(let loop ()
(when (equal? #\; (peek-char port))
(read-char port)
(loop)))
`(code:comment
(unsyntax
(t
,@(let loop ()
(let ([c (read-char port)])
(cond
[(or (eof-object? c)
(char=? c #\newline))
null]
[(char=? c #\@)
(cons (recur) (loop))]
[else (cons (string c)
(loop))]))))))))

5
collects/scribble/eval.ss
View File

@ -115,6 +115,8 @@
(syntax-case s (code:comment eval:alts) (syntax-case s (code:comment eval:alts)
[(code:line v (code:comment . rest)) [(code:line v (code:comment . rest))
(do-eval #'v)] (do-eval #'v)]
[(code:comment . rest)
(list (list (void)) "" "")]
[(eval:alts p e) [(eval:alts p e)
(do-eval #'e)] (do-eval #'e)]
[else [else
@ -214,13 +216,14 @@
(eval `(define eval-example-string ,eval-example-string))) (eval `(define eval-example-string ,eval-example-string)))
(define-syntax schemeinput* (define-syntax schemeinput*
(syntax-rules (eval-example-string eval:alts) (syntax-rules (eval-example-string eval:alts code:comment)
[(_ (eval-example-string s)) [(_ (eval-example-string s))
(make-paragraph (make-paragraph
(list (list
(hspace 2) (hspace 2)
(tt "> ") (tt "> ")
(span-class "schemevalue" (schemefont s))))] (span-class "schemevalue" (schemefont s))))]
[(_ (code:comment . rest)) (schemeblock (code:comment . rest))]
[(_ (eval:alts a b)) (schemeinput* a)] [(_ (eval:alts a b)) (schemeinput* a)]
[(_ e) (schemeinput e)])) [(_ e) (schemeinput e)]))

13
collects/scribble/manual.ss
View File

@ -241,10 +241,12 @@
(lambda () (list desc ...)))])) (lambda () (list desc ...)))]))
(define-syntax defstruct (define-syntax defstruct
(syntax-rules () (syntax-rules ()
[(_ name fields #:immutable #:inspector #f desc ...)
(*defstruct (quote-syntax name) 'name 'fields #t #t (lambda () (list desc ...)))]
[(_ name fields #:immutable desc ...) [(_ name fields #:immutable desc ...)
(*defstruct (quote-syntax name) 'name 'fields #t (lambda () (list desc ...)))] (*defstruct (quote-syntax name) 'name 'fields #t #f (lambda () (list desc ...)))]
[(_ name fields desc ...) [(_ name fields desc ...)
(*defstruct (quote-syntax name) 'name 'fields #f (lambda () (list desc ...)))])) (*defstruct (quote-syntax name) 'name 'fields #f #f (lambda () (list desc ...)))]))
(define-syntax (defform*/subs stx) (define-syntax (defform*/subs stx)
(syntax-case stx () (syntax-case stx ()
[(_ #:literals (lit ...) [spec spec1 ...] ([non-term-id non-term-form ...] ...) desc ...) [(_ #:literals (lit ...) [spec spec1 ...] ([non-term-id non-term-form ...] ...) desc ...)
@ -638,7 +640,7 @@
(map symbol->string (car wrappers))))))) (map symbol->string (car wrappers)))))))
(cdr wrappers)))) (cdr wrappers))))
(define (*defstruct stx-id name fields immutable? content-thunk) (define (*defstruct stx-id name fields immutable? transparent? content-thunk)
(define spacer (hspace 1)) (define spacer (hspace 1))
(make-splice (make-splice
(cons (cons
@ -670,7 +672,8 @@
(list 'set- name '- (car f) '!)) (list 'set- name '- (car f) '!))
fields)))))) fields))))))
,(map car fields) ,(map car fields)
,@(if immutable? '(#:immutable) null)))))))) ,@(if immutable? '(#:immutable) null)
,@(if transparent? '(#:inspector #f) null))))))))
(map (lambda (v) (map (lambda (v)
(cond (cond
[(pair? v) [(pair? v)
@ -904,7 +907,7 @@
(cond (cond
[(string? i) [(string? i)
(cond (cond
[(regexp-match #rx"^(.*)([()])(.*)$" i) [(regexp-match #rx"^(.*)([()0-9])(.*)$" i)
=> (lambda (m) => (lambda (m)
(append (loop (cadr m)) (append (loop (cadr m))
(list (caddr m)) (list (caddr m))

14
collects/scribble/scheme.ss
View File

@ -183,6 +183,10 @@
(- (cdar m) (caar m)) (- (cdar m) (caar m))
(literalize-spaces (substring i (cdar m)))) (literalize-spaces (substring i (cdar m))))
i))) i)))
(define (no-fancy-chars s)
(cond
[(eq? s 'rsquo) "'"]
[else s]))
(define (loop init-line! quote-depth) (define (loop init-line! quote-depth)
(lambda (c) (lambda (c)
(cond (cond
@ -194,11 +198,13 @@
(out "; " comment-color) (out "; " comment-color)
(let ([v (syntax-object->datum (cadr (syntax->list c)))]) (let ([v (syntax-object->datum (cadr (syntax->list c)))])
(if (paragraph? v) (if (paragraph? v)
(map (lambda (v) (if (string? v) (map (lambda (v)
(out v comment-color) (let ([v (no-fancy-chars v)])
(out v #f))) (if (string? v)
(out v comment-color)
(out v #f))))
(paragraph-content v)) (paragraph-content v))
(out v comment-color)))] (out (no-fancy-chars v) comment-color)))]
[(and (pair? (syntax-e c)) [(and (pair? (syntax-e c))
(eq? (syntax-e (car (syntax-e c))) 'code:contract)) (eq? (syntax-e (car (syntax-e c))) 'code:contract))
(advance c init-line!) (advance c init-line!)