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

13
collects/scribble/manual.ss
View File

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

14
collects/scribble/scheme.ss
View File

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