commit 6c435c4e121e83ad8bdfe680392939bf3225715c
parent 4fe7eea393afddfe13e06c9082106ddc69126007
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 18 Mar 2008 18:19:25 +0000
scribble/srcdoc experiment in net/gifwrite
svn: r9019
original commit: dba1ddc480956d8a8999e11ba508c2eae990404f
Diffstat:
4 files changed, 112 insertions(+), 3 deletions(-)
diff --git a/collects/scribble/doclang.ss b/collects/scribble/doclang.ss
@@ -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)])))]))])))
diff --git a/collects/scribble/extract.ss b/collects/scribble/extract.ss
@@ -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)]))
diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss
@@ -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))
diff --git a/collects/scribble/srcdoc.ss b/collects/scribble/srcdoc.ss
@@ -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]))
