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

scribble/srcdoc experiment in net/gifwrite

Browse Source 
svn: r9019

original commit: dba1ddc480956d8a8999e11ba508c2eae990404f
This commit is contained in:
Matthew Flatt 2008-03-18 18:19:25 +00:00
parent 4fe7eea393
commit 6c435c4e12
4 changed files with 112 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/scribble/doclang.ss
View File

@ -42,8 +42,10 @@
(append
(kernel-form-identifier-list)
(syntax->list #'(provide
require))))])
(syntax-case expanded (begin)
require
#%provide
#%require))))])
(syntax-case expanded (begin)
[(begin body1 ...)
#`(doc-begin m-id exprs body1 ... . body)]
[(id . rest)
@ -53,7 +55,9 @@
provide
define-values
define-syntaxes
define-for-syntaxes))))
define-for-syntaxes
#%require
#%provide))))
#`(begin #,expanded (doc-begin m-id exprs . body))]
[_else
#`(doc-begin m-id (#,expanded . exprs) . body)])))]))])))

72
collects/scribble/extract.ss Normal file
View File

@ -0,0 +1,72 @@
#lang scheme/base
(require scribble/manual
scribble/decode
scribble/srcdoc
(for-syntax scheme/base
syntax/path-spec))
(provide include-extracted)
(define-for-syntax (strip-context c)
(cond
[(syntax? c) (datum->syntax
#f
(strip-context (syntax-e c))
c)]
[(pair? c) (cons (strip-context (car c))
(strip-context (cdr c)))]
[else c]))
(define-syntax (include-extracted stx)
(syntax-case stx ()
[(_ orig-path)
(let ([path (resolve-path-spec #'orig-path #'orig-path stx)])
(let ([s-exp
(parameterize ([current-namespace (make-base-namespace)]
[read-accept-reader #t])
(expand
(with-input-from-file path
(lambda ()
(port-count-lines! (current-input-port))
(read-syntax path)))))])
(syntax-case s-exp ()
[(mod name lang
(mod-beg
content ...))
(with-syntax ([(content ...)
(map
strip-context
(apply
append
(map (lambda (c)
(syntax-case c (#%plain-app void quote-syntax provide/doc)
[(#%plain-app void (quote-syntax (provide/doc spec ...)))
(syntax->list #'(spec ...))]
[_ null]))
(syntax->list #'(content ...)))))]
[(req ...)
(map
strip-context
(apply
append
(map (lambda (c)
(syntax-case c (#%require #%plain-app void quote-syntax require/doc)
[(#%require spec ...)
(syntax->list #'((for-label spec) ...))]
[(#%plain-app void (quote-syntax (require/doc spec ...)))
(syntax->list #'(spec ...))]
[_ null]))
(syntax->list #'(content ...)))))])
#`(begin
(#%require (for-label #,(strip-context #'lang))
(for-label #,(strip-context #'orig-path))
req ...)
(def-it content) ...))])))]))
(define-syntax def-it
(syntax-rules ()
[(_ ((rename old-id id) contract desc))
(def-it (id contract desc))]
[(_ (id (-> arg ... result) desc))
(defproc (id arg ...) result . desc)]))

6
collects/scribble/manual.ss
View File

@ -1892,6 +1892,12 @@
(list (make-element 'subscript
(loop (caddr m))))
(loop (cadddr m))))]
[(regexp-match #px"^(.*)\\^([a-zA-Z0-9]+)(.*)$" i)
=> (lambda (m)
(append (loop (cadr m))
(list (make-element 'superscript
(loop (caddr m))))
(loop (cadddr m))))]
[(regexp-match #px"^(.*)([()0-9{}\\[\\]])(.*)$" i)
=> (lambda (m)
(append (loop (cadr m))

27
collects/scribble/srcdoc.ss Normal file
View File

@ -0,0 +1,27 @@
#lang scheme/base
(require scheme/contract)
(provide require/doc
provide/doc)
(define-syntax-rule (require/doc spec ...)
(void (quote-syntax (require/doc spec ...))))
(define-syntax-rule (provide/doc [id contract desc] ...)
(begin
(void (quote-syntax (provide/doc [id contract desc] ...)))
(provide/contracted [id (strip-names contract)]) ...))
(define-syntax provide/contracted
(syntax-rules (->)
[(_ [(rename orig-id new-id) contract])
(provide/contract (rename orig-id new-id contract))]
[(_ [id contract])
(provide/contract [id contract])]))
(define-syntax strip-names
(syntax-rules (->)
[(_ (-> [id contract] ... result))
(-> contract ... result)]
[(_ other) other]))