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

change scribble to use new-lambda and new-struct, and correlate definitions and uses via lexical binding

Browse Source 
svn: r6714

original commit: 7de23b6373ac5d88c54350a847a41bedd3516a2d
This commit is contained in:
Matthew Flatt 2007-06-22 05:59:42 +00:00
parent 33d0774fea
commit 8de414b74f
9 changed files with 265 additions and 191 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
collects/scribble/basic.ss
View File

@ -1,9 +1,8 @@
(module basic mzscheme (module basic (lib "new-lambda.ss" "scribblings")
(require "decode.ss" (require "decode.ss"
"struct.ss" "struct.ss"
"config.ss" "config.ss"
(lib "kw.ss")
(lib "list.ss") (lib "list.ss")
(lib "class.ss")) (lib "class.ss"))
@ -19,23 +18,23 @@
(content->string content) (content->string content)
"_")) "_"))
(define/kw (title #:key [tag #f] [style #f] #:body str) (define (title #:tag [tag #f] #:style [style #f] . str)
(let ([content (decode-content str)]) (let ([content (decode-content str)])
(make-title-decl (or tag (gen-tag content)) style content))) (make-title-decl (or tag (gen-tag content)) style content)))
(define/kw (section #:key [tag #f] #:body str) (define (section #:tag [tag #f] . str)
(let ([content (decode-content str)]) (let ([content (decode-content str)])
(make-part-start 0 (or tag (gen-tag content)) content))) (make-part-start 0 (or tag (gen-tag content)) content)))
(define/kw (subsection #:key [tag #f] #:body str) (define (subsection #:tag [tag #f] . str)
(let ([content (decode-content str)]) (let ([content (decode-content str)])
(make-part-start 1 (or tag (gen-tag content)) content))) (make-part-start 1 (or tag (gen-tag content)) content)))
(define/kw (subsubsection #:key [tag #f] #:body str) (define (subsubsection #:tag [tag #f] . str)
(let ([content (decode-content str)]) (let ([content (decode-content str)])
(make-part-start 2 (or tag (gen-tag content)) content))) (make-part-start 2 (or tag (gen-tag content)) content)))
(define/kw (subsubsub*section #:key [tag #f] #:body str) (define (subsubsub*section #:tag [tag #f] . str)
(let ([content (decode-content str)]) (let ([content (decode-content str)])
(make-paragraph (list (make-element 'bold content))))) (make-paragraph (list (make-element 'bold content)))))
@ -50,7 +49,7 @@
(provide itemize item item?) (provide itemize item item?)
(define/kw (itemize #:body items) (define (itemize . items)
(let ([items (filter (lambda (v) (not (whitespace? v))) items)]) (let ([items (filter (lambda (v) (not (whitespace? v))) items)])
(for-each (lambda (v) (for-each (lambda (v)
(unless (an-item? v) (unless (an-item? v)
@ -63,7 +62,7 @@
(define-struct an-item (flow)) (define-struct an-item (flow))
(define (item? x) (an-item? x)) (define (item? x) (an-item? x))
(define/kw (item #:body str) (define (item . str)
(make-an-item (decode-flow str))) (make-an-item (decode-flow str)))
;; ---------------------------------------- ;; ----------------------------------------
@ -77,28 +76,28 @@
(define (hspace n) (define (hspace n)
(make-element 'hspace (list (make-string n #\space)))) (make-element 'hspace (list (make-string n #\space))))
(define/kw (elem #:body str) (define (elem . str)
(make-element #f (decode-content str))) (make-element #f (decode-content str)))
(define/kw (aux-elem #:body s) (define (aux-elem . s)
(make-aux-element #f (decode-content s))) (make-aux-element #f (decode-content s)))
(define/kw (italic #:body str) (define (italic . str)
(make-element 'italic (decode-content str))) (make-element 'italic (decode-content str)))
(define/kw (bold #:body str) (define (bold . str)
(make-element 'bold (decode-content str))) (make-element 'bold (decode-content str)))
(define/kw (tt #:body str) (define (tt . str)
(make-element 'tt (decode-content str))) (make-element 'tt (decode-content str)))
(define/kw (span-class classname #:body str) (define (span-class classname . str)
(make-element classname (decode-content str))) (make-element classname (decode-content str)))
(define/kw (subscript #:body str) (define (subscript . str)
(make-element 'subscript (decode-content str))) (make-element 'subscript (decode-content str)))
(define/kw (superscript #:body str) (define (superscript . str)
(make-element 'superscript (decode-content str))) (make-element 'superscript (decode-content str)))
;; ---------------------------------------- ;; ----------------------------------------
@ -116,20 +115,20 @@
word-seq word-seq
element-seq)) element-seq))
(define/kw (index* word-seq content-seq #:body s) (define (index* word-seq content-seq . s)
(let ([key (gen-target)]) (let ([key (gen-target)])
(record-index word-seq (record-index word-seq
content-seq content-seq
key key
(decode-content s)))) (decode-content s))))
(define/kw (index word-seq #:body s) (define (index word-seq . s)
(let ([word-seq (if (string? word-seq) (let ([word-seq (if (string? word-seq)
(list word-seq) (list word-seq)
word-seq)]) word-seq)])
(apply index* word-seq word-seq s))) (apply index* word-seq word-seq s)))
(define/kw (as-index #:body s) (define (as-index . s)
(let ([key (gen-target)] (let ([key (gen-target)]
[content (decode-content s)]) [content (decode-content s)])
(record-index (list (content->string content)) (record-index (list (content->string content))

4
collects/scribble/doclang.ss
View File

@ -1,11 +1,11 @@
(module doclang mzscheme (module doclang (lib "new-lambda.ss" "scribblings") ; <--- temporary
(require "struct.ss" (require "struct.ss"
"decode.ss" "decode.ss"
(lib "kw.ss")) (lib "kw.ss"))
(require-for-syntax (lib "kerncase.ss" "syntax")) (require-for-syntax (lib "kerncase.ss" "syntax"))
(provide (all-from-except mzscheme #%module-begin) (provide (all-from-except (lib "new-lambda.ss" "scribblings") #%module-begin)
(rename *module-begin #%module-begin)) (rename *module-begin #%module-begin))
;; Module wrapper ---------------------------------------- ;; Module wrapper ----------------------------------------

48
collects/scribble/eval.ss
View File

@ -26,7 +26,7 @@
scribble-eval-handler) scribble-eval-handler)
(define current-int-namespace (make-parameter (make-namespace))) (define current-int-namespace (make-parameter (current-namespace)))
(define scribble-eval-handler (make-parameter (lambda (c? x) (eval x)))) (define scribble-eval-handler (make-parameter (lambda (c? x) (eval x))))
(define image-counter 0) (define image-counter 0)
@ -108,17 +108,11 @@
#f))))))) #f)))))))
(define (do-eval s) (define (do-eval s)
(cond (syntax-case s (code:comment eval:alts)
[(and (list? s) [(code:line v (code:comment . rest))
(eq? 'code:line (car s)) (do-eval #'v)]
(= (length s) 3) [(eval:alts p e)
(list? (caddr s)) (do-eval #'e)]
(eq? 'code:comment (caaddr s)))
(do-eval (cadr s))]
[(and (list? s)
(eq? 'eval:alts (car s))
(= (length s) 3))
(do-eval (caddr s))]
[else [else
(let ([o (open-output-string)]) (let ([o (open-output-string)])
(parameterize ([current-output-port o]) (parameterize ([current-output-port o])
@ -160,17 +154,19 @@
v2)] v2)]
[else v])) [else v]))
(define (strip-comments s) (define (strip-comments stx)
(cond (syntax-case stx (code:comment code:blank)
[(and (pair? s) [((code:comment . _) . rest)
(pair? (car s)) (strip-comments #'rest)]
(eq? (caar s) 'code:comment)) [(a . b)
(strip-comments (cdr s))] (datum->syntax-object stx
[(pair? s) (cons (strip-comments #'a)
(cons (strip-comments (car s)) (strip-comments #'b))
(strip-comments (cdr s)))] stx
[(eq? s 'code:blank) (void)] stx
[else s])) stx)]
[code:blank #'(void)]
[else stx]))
(define (do-plain-eval s catching-exns?) (define (do-plain-eval s catching-exns?)
@ -181,7 +177,7 @@
(syntax-rules () (syntax-rules ()
[(_ e) (#%expression [(_ e) (#%expression
(begin (parameterize ([current-command-line-arguments #()]) (begin (parameterize ([current-command-line-arguments #()])
(do-plain-eval (quote e) #f)) (do-plain-eval (quote-syntax e) #f))
""))])) ""))]))
@ -193,7 +189,7 @@
(syntax-rules () (syntax-rules ()
[(_ e) (#%expression [(_ e) (#%expression
(parameterize ([current-command-line-arguments #()]) (parameterize ([current-command-line-arguments #()])
(show-val (car (do-plain-eval (quote e) #f)))))])) (show-val (car (do-plain-eval (quote-syntax e) #f)))))]))
(define (eval-example-string s) (define (eval-example-string s)
(eval (read (open-input-string s)))) (eval (read (open-input-string s))))
@ -239,7 +235,7 @@
[(_ t schemeinput* e ...) [(_ t schemeinput* e ...)
(interleave t (interleave t
(list (schemeinput* e) ...) (list (schemeinput* e) ...)
(map do-eval (list (quote e) ...)))])) (map do-eval (list (quote-syntax e) ...)))]))
(define-syntax interaction (define-syntax interaction
(syntax-rules () (syntax-rules ()

5
collects/scribble/html-render.ss
View File

@ -200,6 +200,11 @@
[(at-right) '((align "right"))] [(at-right) '((align "right"))]
[(at-left) '((align "left"))] [(at-left) '((align "left"))]
[else null]) [else null])
,@(let ([a (and (list? (table-style t))
(assoc 'style (table-style t)))])
(if (and a (string? (cadr a)))
`((class ,(cadr a)))
null))
,@(if (string? (table-style t)) ,@(if (string? (table-style t))
`((class ,(table-style t))) `((class ,(table-style t)))
null)) null))

203
collects/scribble/manual.ss
View File

@ -1,12 +1,11 @@
(module manual mzscheme (module manual (lib "new-lambda.ss" "scribblings")
(require "decode.ss" (require "decode.ss"
"struct.ss" "struct.ss"
"scheme.ss" "scheme.ss"
"config.ss" "config.ss"
"basic.ss" "basic.ss"
(lib "string.ss") (lib "string.ss")
(lib "kw.ss")
(lib "list.ss") (lib "list.ss")
(lib "class.ss")) (lib "class.ss"))
@ -46,7 +45,10 @@
(define (to-element/id s) (define (to-element/id s)
(make-element "schemesymbol" (list (to-element/no-color s)))) (make-element "schemesymbol" (list (to-element/no-color s))))
(define (keep-s-expr ctx s v) s) (define (keep-s-expr ctx s v)
(if (symbol? s)
(make-just-context s ctx)
s))
(define (add-sq-prop s name val) (define (add-sq-prop s name val)
(if (eq? name 'paren-shape) (if (eq? name 'paren-shape)
(make-shaped-parens s val) (make-shaped-parens s val)
@ -97,41 +99,41 @@
link procedure link procedure
idefterm) idefterm)
(define/kw (onscreen #:body str) (define (onscreen . str)
(make-element 'sf (decode-content str))) (make-element 'sf (decode-content str)))
(define (menuitem menu item) (define (menuitem menu item)
(make-element 'sf (list menu "|" item))) (make-element 'sf (list menu "|" item)))
(define/kw (defterm #:body str) (define (defterm . str)
(make-element 'italic (decode-content str))) (make-element 'italic (decode-content str)))
(define/kw (idefterm #:body str) (define (idefterm . str)
(let ([c (decode-content str)]) (let ([c (decode-content str)])
(make-element 'italic c))) (make-element 'italic c)))
(define/kw (schemefont #:body str) (define (schemefont . str)
(apply tt str)) (apply tt str))
(define/kw (schemevalfont #:body str) (define (schemevalfont . str)
(make-element "schemevalue" (decode-content str))) (make-element "schemevalue" (decode-content str)))
(define/kw (schemeresultfont #:body str) (define (schemeresultfont . str)
(make-element "schemeresult" (decode-content str))) (make-element "schemeresult" (decode-content str)))
(define/kw (schemeidfont #:body str) (define (schemeidfont . str)
(make-element "schemesymbol" (decode-content str))) (make-element "schemesymbol" (decode-content str)))
(define/kw (schemeparenfont #:body str) (define (schemeparenfont . str)
(make-element "schemeparen" (decode-content str))) (make-element "schemeparen" (decode-content str)))
(define/kw (schememetafont #:body str) (define (schememetafont . str)
(make-element "schememeta" (decode-content str))) (make-element "schememeta" (decode-content str)))
(define/kw (schemekeywordfont #:body str) (define (schemekeywordfont . str)
(make-element "schemekeyword" (decode-content str))) (make-element "schemekeyword" (decode-content str)))
(define/kw (file #:body str) (define (file . str)
(make-element 'tt (append (list "\"") (decode-content str) (list "\"")))) (make-element 'tt (append (list "\"") (decode-content str) (list "\""))))
(define/kw (exec #:body str) (define (exec . str)
(make-element 'tt (decode-content str))) (make-element 'tt (decode-content str)))
(define/kw (procedure #:body str) (define (procedure . str)
(make-element "schemeresult" (append (list "#<procedure:") (decode-content str) (list ">")))) (make-element "schemeresult" (append (list "#<procedure:") (decode-content str) (list ">"))))
(define/kw (link url #:body str) (define (link url . str)
(make-element (make-target-url url) (decode-content str))) (make-element (make-target-url url) (decode-content str)))
(provide t) (provide t)
(define/kw (t #:body str) (define (t . str)
(decode-paragraph str)) (decode-paragraph str))
(provide schememodule) (provide schememodule)
@ -151,7 +153,7 @@
;; ---------------------------------------- ;; ----------------------------------------
(provide deftech tech) (provide deftech tech techlink)
(define (*tech make-elem style s) (define (*tech make-elem style s)
(let* ([c (decode-content s)] (let* ([c (decode-content s)]
@ -165,12 +167,15 @@
c c
(format "tech-term:~a" s)))) (format "tech-term:~a" s))))
(define/kw (deftech #:body s) (define (deftech . s)
(*tech make-target-element #f (list (apply defterm s)))) (*tech make-target-element #f (list (apply defterm s))))
(define/kw (tech #:body s) (define (tech . s)
(*tech make-link-element "techlink" s)) (*tech make-link-element "techlink" s))
(define (techlink . s)
(*tech make-link-element #f s))
;; ---------------------------------------- ;; ----------------------------------------
(provide defproc defproc* defstruct defthing defform defform* defform/subs defform*/subs defform/none (provide defproc defproc* defstruct defthing defform defform* defform/subs defform*/subs defform/none
@ -218,21 +223,23 @@
(define-syntax defproc (define-syntax defproc
(syntax-rules () (syntax-rules ()
[(_ (id arg ...) result desc ...) [(_ (id arg ...) result desc ...)
(*defproc '[(id arg ...)] (*defproc (list (quote-syntax id))
'[(id arg ...)]
(list (list (lambda () (arg-contract arg)) ...)) (list (list (lambda () (arg-contract arg)) ...))
(list (lambda () (schemeblock0 result))) (list (lambda () (schemeblock0 result)))
(lambda () (list desc ...)))])) (lambda () (list desc ...)))]))
(define-syntax defproc* (define-syntax defproc*
(syntax-rules () (syntax-rules ()
[(_ [[(id arg ...) result] ...] desc ...) [(_ [[(id arg ...) result] ...] desc ...)
(*defproc '[(id arg ...) ...] (*defproc (list (quote-syntax id) ...)
'[(id arg ...) ...]
(list (list (lambda () (arg-contract arg)) ...) ...) (list (list (lambda () (arg-contract arg)) ...) ...)
(list (lambda () (schemeblock0 result)) ...) (list (lambda () (schemeblock0 result)) ...)
(lambda () (list desc ...)))])) (lambda () (list desc ...)))]))
(define-syntax defstruct (define-syntax defstruct
(syntax-rules () (syntax-rules ()
[(_ name fields desc ...) [(_ name fields desc ...)
(*defstruct 'name 'fields (lambda () (list desc ...)))])) (*defstruct (quote-syntax name) 'name 'fields (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 ...)
@ -245,8 +252,11 @@
'(unsyntax x) '(unsyntax x)
#'name) #'name)
#'rest) #'rest)
#'spec)])]) #'spec)])]
#'(*defforms #t '(lit ...) [spec-id
(syntax-case #'spec ()
[(name . rest) #'name])])
#'(*defforms (quote-syntax spec-id) '(lit ...)
'(spec spec1 ...) '(spec spec1 ...)
(list (lambda (x) (schemeblock0 new-spec)) (list (lambda (x) (schemeblock0 new-spec))
(lambda (ignored) (schemeblock0 spec1)) ...) (lambda (ignored) (schemeblock0 spec1)) ...)
@ -260,6 +270,7 @@
#'(fm #:literals () [spec spec1 ...] ([non-term-id non-term-form ...] ...) desc ...)])) #'(fm #:literals () [spec spec1 ...] ([non-term-id non-term-form ...] ...) desc ...)]))
(define-syntax (defform* stx) (define-syntax (defform* stx)
(syntax-case stx () (syntax-case stx ()
[(_ #:literals lits [spec ...] desc ...) #'(defform*/subs #:literals lits [spec ...] () desc ...)]
[(_ [spec ...] desc ...) #'(defform*/subs [spec ...] () desc ...)])) [(_ [spec ...] desc ...) #'(defform*/subs [spec ...] () desc ...)]))
(define-syntax (defform stx) (define-syntax (defform stx)
(syntax-case stx () (syntax-case stx ()
@ -312,7 +323,7 @@
(define-syntax defthing (define-syntax defthing
(syntax-rules () (syntax-rules ()
[(_ id result desc ...) [(_ id result desc ...)
(*defthing 'id 'result (lambda () (list desc ...)))])) (*defthing (quote-syntax id) 'id 'result (lambda () (list desc ...)))]))
(define-syntax schemegrammar (define-syntax schemegrammar
(syntax-rules () (syntax-rules ()
[(_ #:literals (lit ...) id clause ...) (*schemegrammar '(lit ...) [(_ #:literals (lit ...) id clause ...) (*schemegrammar '(lit ...)
@ -342,7 +353,7 @@
(list (make-table style content)))) (list (make-table style content))))
(list (make-table style content)))) (list (make-table style content))))
(define (*defproc prototypes arg-contractss result-contracts content-thunk) (define (*defproc stx-ids prototypes arg-contractss result-contracts content-thunk)
(let ([spacer (hspace 1)] (let ([spacer (hspace 1)]
[has-optional? (lambda (arg) [has-optional? (lambda (arg)
(and (pair? arg) (and (pair? arg)
@ -378,7 +389,7 @@
(apply (apply
append append
(map (map
(lambda (prototype arg-contracts result-contract first?) (lambda (stx-id prototype arg-contracts result-contract first?)
(append (append
(list (list
(list (make-flow (list (make-flow
@ -403,7 +414,7 @@
(make-target-element (make-target-element
#f #f
(list (to-element (car prototype))) (list (to-element (car prototype)))
(register-scheme-definition (car prototype))) (register-scheme-definition stx-id))
(to-element (car prototype)))) (to-element (car prototype))))
(map arg->elem required) (map arg->elem required)
(if (null? optional) (if (null? optional)
@ -449,25 +460,29 @@
[else null])) [else null]))
(cdr prototype) (cdr prototype)
arg-contracts)))) arg-contracts))))
stx-ids
prototypes prototypes
arg-contractss arg-contractss
result-contracts result-contracts
(cons #t (map (lambda (x) #f) (cdr prototypes)))))) (cons #t (map (lambda (x) #f) (cdr prototypes))))))
(content-thunk)))))) (content-thunk))))))
(define (make-target-element* content wrappers) (define (make-target-element* stx-id content wrappers)
(if (null? wrappers) (if (null? wrappers)
content content
(make-target-element* (make-target-element*
stx-id
(make-target-element (make-target-element
#f #f
(list content) (list content)
(register-scheme-definition (string->symbol (register-scheme-definition
(apply string-append (datum->syntax-object stx-id
(map symbol->string (car wrappers)))))) (string->symbol
(apply string-append
(map symbol->string (car wrappers)))))))
(cdr wrappers)))) (cdr wrappers))))
(define (*defstruct name fields content-thunk) (define (*defstruct stx-id name fields content-thunk)
(define spacer (hspace 1)) (define spacer (hspace 1))
(make-splice (make-splice
(cons (cons
@ -481,6 +496,7 @@
(to-element (to-element
`(,(schemeparenfont "struct") `(,(schemeparenfont "struct")
,(make-target-element* ,(make-target-element*
stx-id
(to-element name) (to-element name)
(let ([name (if (pair? name) (let ([name (if (pair? name)
(car name) (car name)
@ -515,7 +531,7 @@
fields))) fields)))
(content-thunk)))) (content-thunk))))
(define (*defthing name result-contract content-thunk) (define (*defthing stx-id name result-contract content-thunk)
(define spacer (hspace 1)) (define spacer (hspace 1))
(make-splice (make-splice
(cons (cons
@ -528,19 +544,19 @@
(list (make-target-element (list (make-target-element
#f #f
(list (to-element name)) (list (to-element name))
(register-scheme-definition name)) (register-scheme-definition stx-id))
spacer ":" spacer spacer ":" spacer
(to-element result-contract)))))))) (to-element result-contract))))))))
(content-thunk)))) (content-thunk))))
(define (meta-symbol? s) (memq s '(... ...+ ?))) (define (meta-symbol? s) (memq s '(... ...+ ?)))
(define (*defforms kw? lits forms form-procs subs sub-procs content-thunk) (define (*defforms kw-id lits forms form-procs subs sub-procs content-thunk)
(parameterize ([current-variable-list (parameterize ([current-variable-list
(apply (apply
append append
(map (lambda (form) (map (lambda (form)
(let loop ([form (cons (if kw? (cdr form) form) (let loop ([form (cons (if kw-id (cdr form) form)
subs)]) subs)])
(cond (cond
[(symbol? form) (if (or (meta-symbol? form) [(symbol? form) (if (or (meta-symbol? form)
@ -568,22 +584,25 @@
(to-element (to-element
`(,x `(,x
. ,(cdr form))))))) . ,(cdr form)))))))
(and kw? (and kw-id
(eq? form (car forms)) (eq? form (car forms))
(make-target-element (make-target-element
#f #f
(list (to-element (car form))) (list (to-element (make-just-context (car form) kw-id)))
(register-scheme-form-definition (car form))))))))) (register-scheme-form-definition kw-id))))))))
forms form-procs) forms form-procs)
(apply (if (null? sub-procs)
append null
(map (lambda (sub) (list (list (make-flow (list (make-paragraph (list (tt 'nbsp))))))
(list (list (make-flow (list (make-paragraph (list (tt 'nbsp)))))) (list (make-flow (list (let ([l (map (lambda (sub)
(list (make-flow (list (apply *schemerawgrammar (map (lambda (f) (f)) sub))
(map (lambda (f) (f)) sub))))))) sub-procs)])
sub-procs)))) (*schemerawgrammars
"specgrammar"
(map car l)
(map cdr l))))))))))
(content-thunk))))) (content-thunk)))))
(define (*specsubform form has-kw? lits form-thunk subs sub-procs content-thunk) (define (*specsubform form has-kw? lits form-thunk subs sub-procs content-thunk)
(parameterize ([current-variable-list (parameterize ([current-variable-list
(append (let loop ([form (cons (if has-kw? (cdr form) form) (append (let loop ([form (cons (if has-kw? (cdr form) form)
@ -610,41 +629,47 @@
(if form-thunk (if form-thunk
(form-thunk) (form-thunk)
(make-paragraph (list (to-element form))))))) (make-paragraph (list (to-element form)))))))
(apply (if (null? sub-procs)
append null
(map (lambda (sub) (list (list (make-flow (list (make-paragraph (list (tt 'nbsp))))))
(list (list (make-flow (list (make-paragraph (list (tt 'nbsp)))))) (list (make-flow (list (let ([l (map (lambda (sub)
(list (make-flow (list (apply *schemerawgrammar (map (lambda (f) (f)) sub))
(map (lambda (f) (f)) sub))))))) sub-procs)])
sub-procs)))) (*schemerawgrammars
"specgrammar"
(map car l)
(map cdr l))))))))))
(flow-paragraphs (decode-flow (content-thunk))))))) (flow-paragraphs (decode-flow (content-thunk)))))))
(define (*schemerawgrammars nonterms clauseses) (define (*schemerawgrammars style nonterms clauseses)
(make-table (make-table
'((valignment baseline baseline baseline baseline baseline) `((valignment baseline baseline baseline baseline baseline)
(alignment right left center left left)) (alignment right left center left left)
(style ,style))
(let ([empty-line (make-flow (list (make-paragraph (list (tt 'nbsp)))))] (let ([empty-line (make-flow (list (make-paragraph (list (tt 'nbsp)))))]
[to-flow (lambda (i) (make-flow (list (make-paragraph (list i)))))]) [to-flow (lambda (i) (make-flow (list (make-paragraph (list i)))))])
(apply append (cdr
(map (apply append
(lambda (nonterm clauses) (map
(cons (lambda (nonterm clauses)
(list (to-flow nonterm) (list*
empty-line (list empty-line empty-line empty-line empty-line empty-line)
(to-flow "=") (list (to-flow nonterm)
empty-line empty-line
(make-flow (list (car clauses)))) (to-flow "=")
(map (lambda (clause) empty-line
(list empty-line (make-flow (list (car clauses))))
empty-line (map (lambda (clause)
(to-flow "|") (list empty-line
empty-line empty-line
(make-flow (list clause)))) (to-flow "|")
(cdr clauses)))) empty-line
nonterms clauseses))))) (make-flow (list clause))))
(cdr clauses))))
nonterms clauseses))))))
(define (*schemerawgrammar nonterm clause1 . clauses) (define (*schemerawgrammar style nonterm clause1 . clauses)
(*schemerawgrammars (list nonterm) (list (cons clause1 clauses)))) (*schemerawgrammars style (list nonterm) (list (cons clause1 clauses))))
(define (*schemegrammar lits s-expr clauseses-thunk) (define (*schemegrammar lits s-expr clauseses-thunk)
(parameterize ([current-variable-list (parameterize ([current-variable-list
@ -657,7 +682,7 @@
(loop (cdr form)))] (loop (cdr form)))]
[else null]))]) [else null]))])
(let ([l (clauseses-thunk)]) (let ([l (clauseses-thunk)])
(*schemerawgrammars (map car l) (map cdr l))))) (*schemerawgrammars #f (map car l) (map cdr l)))))
(define (*var id) (define (*var id)
(to-element (*var-sym id))) (to-element (*var-sym id)))
@ -668,26 +693,26 @@
;; ---------------------------------------- ;; ----------------------------------------
(provide centerline) (provide centerline)
(define/kw (centerline #:body s) (define (centerline . s)
(make-table 'centered (list (list (make-flow (list (decode-paragraph s))))))) (make-table 'centered (list (list (make-flow (list (decode-paragraph s)))))))
(provide commandline) (provide commandline)
(define/kw (commandline #:body s) (define (commandline . s)
(make-paragraph (list (hspace 2) (apply tt s)))) (make-paragraph (list (hspace 2) (apply tt s))))
(define (secref s) (define (secref s)
(make-link-element #f null `(part ,s))) (make-link-element #f null `(part ,s)))
(define/kw (seclink tag #:body s) (define (seclink tag . s)
(make-link-element #f (decode-content s) `(part ,tag))) (make-link-element #f (decode-content s) `(part ,tag)))
(define/kw (*schemelink id #:body s) (define (*schemelink stx-id id . s)
(make-link-element #f (decode-content s) (register-scheme-definition id))) (make-link-element #f (decode-content s) (register-scheme-definition stx-id)))
(define-syntax schemelink (define-syntax schemelink
(syntax-rules () (syntax-rules ()
[(_ id . content) (*schemelink 'id . content)])) [(_ id . content) (*schemelink (quote-syntax id) 'id . content)]))
(provide secref seclink schemelink) (provide secref seclink schemelink)
(define/kw (pidefterm #:body s) (define (pidefterm . s)
(let ([c (apply defterm s)]) (let ([c (apply defterm s)])
(index (string-append (content->string (element-content c)) "s") (index (string-append (content->string (element-content c)) "s")
c))) c)))
@ -707,7 +732,7 @@
;; ---------------------------------------- ;; ----------------------------------------
(provide math) (provide math)
(define/kw (math #:body s) (define (math . s)
(let ([c (decode-content s)]) (let ([c (decode-content s)])
(make-element #f (apply append (make-element #f (apply append
(map (lambda (i) (map (lambda (i)
@ -727,7 +752,7 @@
(provide cite) (provide cite)
(define/kw (cite #:key key title author location date) (define (cite #:key key #:title title #:author author #:location location #:date date)
"[...]" "[...]"
#; #;
(make-bibliography-element (make-bibliography-element

46
collects/scribble/scheme.ss
View File

@ -2,7 +2,8 @@
(require "struct.ss" (require "struct.ss"
"basic.ss" "basic.ss"
(lib "class.ss") (lib "class.ss")
(lib "for.ss")) (lib "for.ss")
(lib "modcollapse.ss" "syntax"))
(provide define-code (provide define-code
to-element to-element
@ -17,7 +18,8 @@
current-variable-list current-variable-list
current-meta-list current-meta-list
(struct shaped-parens (val shape))) (struct shaped-parens (val shape))
(struct just-context (val ctx)))
(define no-color "schemeplain") (define no-color "schemeplain")
(define reader-color "schemeplain") (define reader-color "schemeplain")
@ -32,13 +34,12 @@
(define current-keyword-list (define current-keyword-list
;; This is temporary, until the MzScheme manual is filled in... ;; This is temporary, until the MzScheme manual is filled in...
(make-parameter '(require (make-parameter null #;'(require
provide provide
new send else => and or new send else => and or
define-syntax syntax-rules define-struct define-syntax syntax-rules define-struct
quote quasiquote unquote unquote-splicing quasiquote unquote unquote-splicing
syntax quasisyntax unsyntax unsyntax-splicing syntax quasisyntax unsyntax unsyntax-splicing)))
set! set!-values)))
(define current-variable-list (define current-variable-list
(make-parameter null)) (make-parameter null))
(define current-meta-list (define current-meta-list
@ -353,8 +354,8 @@
(not (or it? is-var?))) (not (or it? is-var?)))
(make-delayed-element (make-delayed-element
(lambda (renderer sec ht) (lambda (renderer sec ht)
(let* ([vtag (register-scheme-definition (syntax-e c))] (let* ([vtag (register-scheme-definition c)]
[stag (register-scheme-form-definition (syntax-e c))] [stag (register-scheme-form-definition c)]
[vd (hash-table-get ht vtag #f)] [vd (hash-table-get ht vtag #f)]
[sd (hash-table-get ht stag #f)]) [sd (hash-table-get ht stag #f)])
(list (list
@ -431,7 +432,7 @@
(cond (cond
[(syntax? v) [(syntax? v)
(let ([mk `(,#'d->s (let ([mk `(,#'d->s
#f (quote-syntax ,v)
,(syntax-case v (uncode) ,(syntax-case v (uncode)
[(uncode e) #'e] [(uncode e) #'e]
[else (stx->loc-s-expr (syntax-e v))]) [else (stx->loc-s-expr (syntax-e v))])
@ -463,11 +464,22 @@
[(_ code typeset-code) #'(define-code code typeset-code unsyntax)])) [(_ code typeset-code) #'(define-code code typeset-code unsyntax)]))
(define (register-scheme-definition sym) (define (register-scheme-definition stx)
(format "definition:~s" sym)) (unless (identifier? stx)
(error 'register-scheme-definition "not an identifier: ~e" (syntax-object->datum stx)))
(format "definition:~s"
(let ([b (identifier-binding stx)])
(cond
[(not b) (format "top:~a" (syntax-e stx))]
[(eq? b 'lexical) (format "lexical:~a" (syntax-e stx))]
[else (format "module:~a:~a"
(if (module-path-index? (car b))
(collapse-module-path-index (car b) '(lib "ack.ss" "scribble"))
(car b))
(cadr b))]))))
(define (register-scheme-form-definition sym) (define (register-scheme-form-definition stx)
(format "formdefinition:~s" sym)) (format "form~s" (register-scheme-definition stx)))
(define syntax-ize-hook (make-parameter (lambda (v col) #f))) (define syntax-ize-hook (make-parameter (lambda (v col) #f)))
@ -495,6 +507,7 @@
l)))) l))))
(define-struct shaped-parens (val shape)) (define-struct shaped-parens (val shape))
(define-struct just-context (val ctx))
(define (syntax-ize v col) (define (syntax-ize v col)
(cond (cond
@ -504,6 +517,13 @@
(syntax-property (syntax-ize (shaped-parens-val v) col) (syntax-property (syntax-ize (shaped-parens-val v) col)
'paren-shape 'paren-shape
(shaped-parens-shape v))] (shaped-parens-shape v))]
[(just-context? v)
(let ([s (syntax-ize (just-context-val v) col)])
(datum->syntax-object (just-context-ctx v)
(syntax-e s)
s
s
(just-context-ctx v)))]
[(and (list? v) [(and (list? v)
(pair? v) (pair? v)
(memq (car v) '(quote unquote unquote-splicing))) (memq (car v) '(quote unquote unquote-splicing)))

4
collects/scribble/scribble.css
View File

@ -184,6 +184,10 @@
background-color: #ddddff; background-color: #ddddff;
} }
.specgrammar {
float: right;
}
.hspace { .hspace {
font-family: Courier; font-size: 80%; font-family: Courier; font-size: 80%;
} }

14
collects/scribblings/scribble/eval.scrbl
View File

@ -10,24 +10,24 @@ especially to show example uses of defined procedures and syntax.
@defform[(interaction datum ...)]{Like @scheme[schemeinput], except @defform[(interaction datum ...)]{Like @scheme[schemeinput], except
that the result for each input @scheme[datum] is shown on the next that the result for each input @scheme[datum] is shown on the next
line. The result is determined by evaluating the quoted form of the line. The result is determined by evaluating the syntax-quoted form of
datum. the @scheme[datum].
Uses of @scheme[code:comment] and @schemeidfont{code:blank} are Uses of @scheme[code:comment] and @schemeidfont{code:blank} are
stipped from each @scheme[datum] before evaluation. stipped from each @scheme[datum] before evaluation.
If a datum has the form @scheme[(#,(scheme code:line) #,(svar datum) If a @scheme[datum] has the form @scheme[(#,(scheme code:line)
(#,(scheme code:comment) ...))], then only the @svar[datum] is _code-datum (#,(scheme code:comment) ...))], then only
evaluated. @scheme[_code-datum] is evaluated.
If a datum has the form @scheme[(eval:alts #,(svar show-datum) #,(svar If a datum has the form @scheme[(eval:alts #,(svar show-datum) #,(svar
eval-datum))], then @svar[show-datum] is typeset, while eval-datum))], then @svar[show-datum] is typeset, while
@svar[eval-datum] is evaluated.} @svar[eval-datum] is evaluated.}
@defform[(interaction-eval datum)]{Evaluates the quoted form of @defform[(interaction-eval datum)]{Evaluates the syntax-quoted form of
each @scheme[datum] via @scheme[do-eval] and returns the empty string.} each @scheme[datum] via @scheme[do-eval] and returns the empty string.}
@defform[(interaction-eval-show datum)]{Evaluates the quoted form of @defform[(interaction-eval-show datum)]{Evaluates the syntax-quoted form of
@scheme[datum] and produces an element represeting the printed form of @scheme[datum] and produces an element represeting the printed form of
the result.} the result.}

93
collects/scribblings/scribble/manual.scrbl
View File

@ -14,7 +14,7 @@ more...
@defform[(schemeblock datum ...)]{ @defform[(schemeblock datum ...)]{
Typesets the @scheme[datum] sequence as a table of Scheme code inset Typesets the @scheme[datum] sequence as a table of Scheme code inset
by two spaces. The source locations of the @scheme[datum]s determines by two spaces. The source locations of the @scheme[datum]s determine
the generated layout. For example, the generated layout. For example,
@schemeblock[ @schemeblock[
@ -32,10 +32,13 @@ produces the output
with the @scheme[(loop (not x))] indented under @scheme[define], with the @scheme[(loop (not x))] indented under @scheme[define],
because that's the way it is idented the use of @scheme[schemeblock]. because that's the way it is idented the use of @scheme[schemeblock].
Furthermore, @scheme[define] is typeset as a keyword (bold and black) Furthermore, @scheme[define] is typeset as a keyword (bold and black)
and as a hyperlink to @scheme[define]'s definition in the reference and as a hyperlink to @scheme[define]'s definition in the reference
manual, because this document was built using information about the manual, because this document was built using information about the
MzScheme manual. Similarly, @scheme[not] is a hyperlink to the its reference manual, and because the lexical binding of @scheme[define]
(in the source) matches the lexical binding of the definition in the
reference manual. Similarly, @scheme[not] is a hyperlink to the its
definition in the reference manual. definition in the reference manual.
Use @scheme[unsyntax] to escape back to an expression that produces an Use @scheme[unsyntax] to escape back to an expression that produces an
@ -127,7 +130,7 @@ useful with @scheme[verbatim].}
@defproc[(schemefont [pre-content any/c] ...) element?]{Typesets the given @defproc[(schemefont [pre-content any/c] ...) element?]{Typesets the given
content as uncolored, unhyperlinked Scheme. This procedure is useful content as uncolored, unhyperlinked Scheme. This procedure is useful
for typesetting thngs like @scheme{#module}, which are not for typesetting things like @scheme{#module}, which are not
@scheme[read]able by themselves.} @scheme[read]able by themselves.}
@defproc[(schemevalfont [pre-content any/c] ...) element?]{Like @defproc[(schemevalfont [pre-content any/c] ...) element?]{Like
@ -143,7 +146,7 @@ for typesetting thngs like @scheme{#module}, which are not
@scheme[schemefont], but colored as a syntactic form name.} @scheme[schemefont], but colored as a syntactic form name.}
@defproc[(procedure [pre-content any/c] ...) element?]{Typesets the given @defproc[(procedure [pre-content any/c] ...) element?]{Typesets the given
content as a procedure name in a REPL result (e.g., in typewrite font content as a procedure name in a REPL result (e.g., in typewriter font
with a @schemefont{#<procedure:} prefix and @schemefont{>} suffix.).} with a @schemefont{#<procedure:} prefix and @schemefont{>} suffix.).}
@defform[(var datum)]{Typesets @scheme[var] as an identifier that is @defform[(var datum)]{Typesets @scheme[var] as an identifier that is
@ -164,9 +167,9 @@ in a form definition.}
pre-flow ...)]{ pre-flow ...)]{
Produces a sequence of flow elements (encaptured in a @scheme[splice]) Produces a sequence of flow elements (encaptured in a @scheme[splice])
to document a procedure named @scheme[id]. The to document a procedure named @scheme[id]. The @scheme[id] is
@scheme[id] is registered so that @scheme[scheme]-typeset uses registered so that @scheme[scheme]-typeset uses of the identifier
of the identifier are hyperlinked to this documentation. (with the same lexical binding) are hyperlinked to this documentation.
Each @scheme[arg-spec] must have one of the following forms: Each @scheme[arg-spec] must have one of the following forms:
@ -213,39 +216,54 @@ Like @scheme[defproc], but for multiple cases with the same
@scheme[id]. } @scheme[id]. }
@defform[(defform (id . datum) pre-flow ...)]{Produces a @defform/subs[(defform maybe-literals (id . datum) pre-flow ...)
a sequence of flow elements (encaptured in a @scheme[splice]) to ([maybe-literals code:blank
document a syntatic form named by @scheme[id]. The (code:line #:literals (literal-id ...))])]{
@scheme[id] is registered so that @scheme[scheme]-typeset uses
of the identifier are hyperlinked to this documentation. Produces a a sequence of flow elements (encaptured in a
@scheme[splice]) to document a syntatic form named by @scheme[id]. The
@scheme[id] is registered so that @scheme[scheme]-typeset uses of the
identifier (with the same lexical binding) are hyperlinked to this
documentation.
The @scheme[pre-flow]s list is parsed as a flow that documents the The @scheme[pre-flow]s list is parsed as a flow that documents the
procedure. In this description, a reference to any identifier in procedure. In this description, a reference to any identifier in
@scheme[datum] is typeset as a sub-form non-terminal. @scheme[datum] is typeset as a sub-form non-terminal. If
@scheme[#:literals] clause is provided, however, instances of the
@scheme[literal-id]s are typeset normally.
The typesetting of @scheme[(id . datum)] preserves the source The typesetting of @scheme[(id . datum)] preserves the source
layout, like @scheme[schemeblock], and unlike @scheme[defproc].} layout, like @scheme[schemeblock], and unlike @scheme[defproc].}
@defform[(defform* [(id . datum) ..+] pre-flow ...)]{Like @scheme[defform], @defform[(defform* maybe-literals [(id . datum) ..+] pre-flow ...)]{
but for multiple forms using the same @scheme[id].}
@defform[(defform/subs (id . datum) Like @scheme[defform], but for multiple forms using the same
([nonterm-id clause-datum ...+] ...) @scheme[id].}
pre-flow ...)]{
@defform/subs[(defform/subs maybe-literals (id . datum)
([nonterm-id clause-datum ...+] ...)
pre-flow ...)
([maybe-literals code:blank
(code:line #:literals (literal-id ...))])]{
Like @scheme[defform], but including an auxiliary grammar of Like @scheme[defform], but including an auxiliary grammar of
non-terminals shown with the @scheme[id] form. Each non-terminals shown with the @scheme[id] form. Each
@scheme[nonterm-id] is specified as being any of the corresponding @scheme[nonterm-id] is specified as being any of the corresponding
@scheme[clause-datum]s, where the formatting of each @scheme[clause-datum]s, where the formatting of each
@scheme[clause-datum] is preserved.} @scheme[clause-datum] is preserved.}
@defform[(specform (id . datum) pre-flow ...)]{Like @scheme[defform], @defform/subs[(specform maybe-literals (id . datum) pre-flow ...)
with without registering a definition, and with indenting on the left ([maybe-literals code:blank
for both the specification and the @scheme[pre-flow]s.} (code:line #:literals (literal-id ...))])]{
@defform[(specsubform datum pre-flow ...)]{Similar to Like @scheme[defform], with without registering a definition, and with
@scheme[defform], but without any specific identifier being defined, indenting on the left for both the specification and the
and the table and flow are typeset indented. This form is intended for @scheme[pre-flow]s.}
use when refining the syntax of a non-terminal used in a
@defform[(specsubform maybe-literals datum pre-flow ...)]{
Similar to @scheme[defform], but without any specific identifier being
defined, and the table and flow are typeset indented. This form is
intended for use when refining the syntax of a non-terminal used in a
@scheme[defform] or other @scheme[specsubform]. For example, it is @scheme[defform] or other @scheme[specsubform]. For example, it is
used in the documentation for @scheme[defproc] in the itemization of used in the documentation for @scheme[defproc] in the itemization of
possible shapes for @svar[arg-spec]. possible shapes for @svar[arg-spec].
@ -254,8 +272,9 @@ The @scheme[pre-flow]s list is parsed as a flow that documents the
procedure. In this description, a reference to any identifier in procedure. In this description, a reference to any identifier in
@scheme[datum] is typeset as a sub-form non-terminal.} @scheme[datum] is typeset as a sub-form non-terminal.}
@defform[(defthing id contract-expr-datum pre-flow ...)]{Like @defform[(defthing id contract-expr-datum pre-flow ...)]{
@scheme[defproc], but for a non-procedure binding.}
Like @scheme[defproc], but for a non-procedure binding.}
@defform/subs[(defstruct struct-name ([field-name contract-expr-datum] ...) @defform/subs[(defstruct struct-name ([field-name contract-expr-datum] ...)
pre-flow ...) pre-flow ...)
@ -265,13 +284,19 @@ procedure. In this description, a reference to any identifier in
Similar to @scheme[defform] or @scheme[defproc], but for a structure Similar to @scheme[defform] or @scheme[defproc], but for a structure
definition.} definition.}
@defform/subs[(schemegrammar literals ? id clause-datum ...+) @defform/subs[(schemegrammar maybe-literals id clause-datum ...+)
([literals (code:line #:literals (literal-id ...))])]{ ([maybe-literals code:blank
Creates a table to define the grammar of @scheme[id]. Each identifier mentioned (code:line #:literals (literal-id ...))])]{
in a @scheme[clause-datum] is typeset as a non-terminal, except for the
identifiers listed as @scheme[literal-id]s, which are typeset as with Creates a table to define the grammar of @scheme[id]. Each identifier
@scheme[scheme]. mentioned in a @scheme[clause-datum] is typeset as a non-terminal,
} except for the identifiers listed as @scheme[literal-id]s, which are
typeset as with @scheme[scheme].}
@defform[(schemegrammar* maybe-literals [id clause-datum ...+] ...)]{
Like @scheme[schemegrammar], but for typesetting multiple productions
at once, aligned around the @litchar{=} and @litchar{|}.}
@; ------------------------------------------------------------------------ @; ------------------------------------------------------------------------
@section{Various String Forms} @section{Various String Forms}