fixed bug in provide and scribble (end of stage 1)
This commit is contained in:
Matthias Felleisen
parent
5ea11fc0b4
commit
4aefb18cab
|
|
@ -56,4 +56,4 @@
|
|||
;; procedures:
|
||||
(provide-and-scribble
|
||||
procedures
|
||||
(all-from beginner: (submod "private/beginner-funs.rkt" with-wrapper) procedures))
|
||||
(all-from beginner: (submod lang/private/beginner-funs with-wrapper) procedures))
|
||||
|
|
|
|||
|
|
@ -61,4 +61,4 @@
|
|||
;; procedures:
|
||||
(provide-and-scribble
|
||||
procedures
|
||||
(all-from beginner: (submod "private/beginner-funs.rkt" with-wrapper) procedures))
|
||||
(all-from beginner: (submod lang/private/beginner-funs with-wrapper) procedures))
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@
|
|||
|
||||
(provide-and-scribble
|
||||
procedures
|
||||
(all-from-except beginner: (submod "beginner-funs.rkt" without-wrapper) procedures + * - / append)
|
||||
(all-from-except beginner: (submod lang/private/beginner-funs without-wrapper) procedures + * - / append)
|
||||
|
||||
("Numbers (relaxed conditions)"
|
||||
@defproc[(+ [x number] ...) number]{Adds all given numbers.}
|
||||
|
|
|
|||
|
|
@ -2,6 +2,8 @@
|
|||
|
||||
(require (for-syntax syntax/parse) scribble/manual scribble/eval racket/sandbox)
|
||||
|
||||
(require racket/provide)
|
||||
|
||||
(provide
|
||||
define-module-local-eval
|
||||
provide-and-scribble all-from all-from-except
|
||||
|
|
@ -26,29 +28,34 @@
|
|||
|
||||
(define-syntax (provide-and-scribble stx)
|
||||
(syntax-parse stx #:literals (defproc)
|
||||
[(provide-and-scribble doc-tag:id) #'(void)]
|
||||
[(provide-and-scribble doc-tag:id row rows ...)
|
||||
(define-values (provides add-docs-and-provide)
|
||||
(syntax-parse #'row #:literals (defproc all-from all-from-except)
|
||||
[(all-from-except tag:id path label:id f:id ...)
|
||||
(provide-all-from #'doc-tag #'path #'label #'tag #'(rows ...) #'(f ...))]
|
||||
[(all-from tag:id path label:id)
|
||||
(provide-all-from #'doc-tag #'path #'label #'tag #'(rows ...) #'())]
|
||||
[(title (defproc (name args ...) range w ...) ...)
|
||||
(define name* (syntax->list #'(name ...)))
|
||||
(values #`((provide #,@(optional-rename-out name*))
|
||||
(provide-and-scribble doc-tag rows ...))
|
||||
(lambda () ;; delay the syntax creation until add-sections is set
|
||||
(with-syntax ([(ex ...) (extract-external-name name*)])
|
||||
#`(#,*add title (list (cons #'ex (defproc (ex args ...) range w ...)) ...)))))]))
|
||||
(provide-and-scribble-code #'doc-tag add-docs-and-provide provides)]))
|
||||
[(provide-and-scribble doc-tag:id rows ...)
|
||||
(provide-and-scribble-proc #'doc-tag #'(rows ...))]))
|
||||
|
||||
;; Identifier Path Identifier Identifier [Listof RowSpec] [Listof Identifier] ->* Syntax [-> Syntax]
|
||||
(define-for-syntax (provide-and-scribble-proc doc-tag row*)
|
||||
(define-values (add-docs-and-provide provides)
|
||||
(for/fold ((add-docs-and-provide '()) (provides '())) ((row (syntax->list row*)))
|
||||
(syntax-parse row #:literals (defproc all-from all-from-except)
|
||||
[(all-from-except tag:id path label:id f:id ...)
|
||||
(define-values (a p) (provide-all-from #'path #'label #'tag #'(f ...)))
|
||||
(values (cons a add-docs-and-provide) (append (syntax->list p) provides))]
|
||||
[(all-from tag:id path label:id)
|
||||
(define-values (a p) (provide-all-from #'path #'label #'tag #'()))
|
||||
(values (cons a add-docs-and-provide) (append (syntax->list p) provides))]
|
||||
[(title (defproc (name args ...) range w ...) ...)
|
||||
(define name* (syntax->list #'(name ...)))
|
||||
(values (cons (lambda () ;; delay the syntax creation until add-sections is set
|
||||
(with-syntax ([(ex ...) (extract-external-name name*)])
|
||||
#`(#,*add title (list (cons #'ex (defproc (ex args ...) range w ...)) ...))))
|
||||
add-docs-and-provide)
|
||||
(cons #`(provide #,@(optional-rename-out name*))
|
||||
provides))])))
|
||||
(provide-and-scribble-code doc-tag add-docs-and-provide provides))
|
||||
|
||||
;; Path Identifier Identifier [Listof Identifier] ->* [-> Syntax] Syntax[List]
|
||||
;; create the require and provide clauses AND
|
||||
;; delayed code for merging documentations from path -> label into the 'documentation' doc-tag submod
|
||||
(define-for-syntax (provide-all-from doc-tag path label prefix row* f*)
|
||||
(with-syntax ([doc-tag doc-tag]
|
||||
[path (syntax-case path (submod)
|
||||
(define-for-syntax (provide-all-from path label prefix f*)
|
||||
(with-syntax ([path (syntax-case path (submod)
|
||||
[(submod nested-path nested-tag) #'nested-path]
|
||||
[_ path])]
|
||||
[(nested-tag ...)
|
||||
|
|
@ -58,87 +65,96 @@
|
|||
[label label]
|
||||
[prefix prefix]
|
||||
[(f ...) (syntax->list f*)]
|
||||
[(rows ...) (syntax->list row*)])
|
||||
(values #'((require (rename-in (submod path nested-tag ... label) (docs mydocs)))
|
||||
;; import from path with prefix, exclude f ...
|
||||
[mydocs (gensym 'mydocs)])
|
||||
(values (lambda () ;; delay the syntax creation until add-sections is set
|
||||
;; ******************************************************************
|
||||
;; I was really hoping to make
|
||||
;; (local-require (only-in (submod path nested-tag ... label) (docs mydocs)))
|
||||
;; to work but that gave me problems about 'docs' already required before
|
||||
;; so I went with dynamic-require. Argh.
|
||||
;; ******************************************************************
|
||||
#`(for ((s ((dynamic-require '(submod path nested-tag ... label) 'docs) #'f ...)))
|
||||
(#,*add (car s) (cadr s))))
|
||||
#`(;; import from path with prefix, exclude f ...
|
||||
(require (prefix-in prefix (except-in (submod path nested-tag ...) f ...)))
|
||||
;; export the bindings without prefix
|
||||
(local-require (only-in racket/provide filtered-out))
|
||||
; (local-require (only-in racket/provide filtered-out))
|
||||
(provide (filtered-out (lambda (name)
|
||||
(define prefix (format "^~a" (syntax-e #'prefix)))
|
||||
(and (regexp-match? prefix name)
|
||||
(regexp-replace prefix name "")))
|
||||
(all-from-out (submod path nested-tag ...))))
|
||||
;; on to the rest
|
||||
(provide-and-scribble doc-tag rows ...))
|
||||
(lambda () ;; delay the syntax creation until add-sections is set
|
||||
#`(for ((s (mydocs #'f ...)))
|
||||
(#,*add (car s) (cadr s)))))))
|
||||
(all-from-out (submod path nested-tag ...))))))))
|
||||
|
||||
;; Identifier [-> Syntax] Syntax -> Syntax
|
||||
;; Identifier [Listof [-> Syntax]] [Listof Syntax] -> Syntax
|
||||
;; generate (module+ doc-tag ...) with the documentation in add-docs-and-provide,
|
||||
;; the first time it adds functions to (module+ doc-tag ...) that help render the docs
|
||||
;; export the provides list
|
||||
(define-for-syntax (provide-and-scribble-code doc-tag add-docs-and-provide provides)
|
||||
(cond
|
||||
[*add #`(begin (module+ #,doc-tag #,(add-docs-and-provide))
|
||||
#,@provides)]
|
||||
[else (set! *add (syntax-local-introduce #'add-sections))
|
||||
#`(begin (module+ #,doc-tag
|
||||
;; -----------------------------------------------------------------------
|
||||
;; Section = [Listof (cons Identifier Doc)]
|
||||
;; Sections = [Listof (list Identifier Section)]
|
||||
(provide
|
||||
;; Identfier ... *-> Sections
|
||||
;; retrieve the document without the specified identfiers
|
||||
docs
|
||||
;; Sections String -> [Listof ScribbleBox]
|
||||
;; render the sections as a scribble list of splice-boxes: #:tag-prefix p
|
||||
render-sections)
|
||||
;; -----------------------------------------------------------------------
|
||||
;;
|
||||
(define (render-sections s p)
|
||||
(cond
|
||||
[(null? s) '()]
|
||||
[else
|
||||
(define section1 (car s))
|
||||
(define others (render-sections (cdr s) p))
|
||||
(define-values (section-title stuff) (apply values (car s)))
|
||||
(define sorted (sort-category stuff))
|
||||
(cons @subsection[#:tag-prefix @p]{@section-title}
|
||||
(cons (map cdr sorted) others))]))
|
||||
|
||||
(define (sort-category category)
|
||||
(define (key x) (symbol->string (syntax-e (car x))))
|
||||
(sort category string<=? #:key key))
|
||||
|
||||
;;
|
||||
(define (docs . exceptions)
|
||||
(define s (reverse *sections))
|
||||
(define (is-exception i)
|
||||
(memf (lambda (j) (eq? (syntax-e j) (syntax-e i))) exceptions))
|
||||
(for/fold ((result '())) ((s *sections))
|
||||
(define sectn (second s))
|
||||
(define clean
|
||||
(filter (lambda (i) (not (is-exception (car i)))) sectn))
|
||||
(cons (list (first s) clean) result)))
|
||||
;;
|
||||
;; state variable: Sections
|
||||
(define *sections '())
|
||||
;; String Section -> Void
|
||||
;; add _scontent_ section to *sections in the doc submodule
|
||||
(define (#,*add stitle scontent)
|
||||
(define exists (assoc stitle *sections))
|
||||
(if exists
|
||||
(set! *sections
|
||||
(for/list ((s *sections))
|
||||
(if (string=? (first s) stitle)
|
||||
(list stitle (append scontent (second s)))
|
||||
s)))
|
||||
(set! *sections (cons (list stitle scontent) *sections))))
|
||||
|
||||
#,(add-docs-and-provide))
|
||||
#,@provides)]))
|
||||
(with-syntax ([(p* ...) provides])
|
||||
(cond
|
||||
[*add #`(begin p* ... (module+ #,doc-tag #,@(map (lambda (adp) (adp)) add-docs-and-provide)))]
|
||||
[else
|
||||
(set! *add (syntax-local-introduce #'add-sections))
|
||||
#`(begin (module+ #,doc-tag
|
||||
;; -----------------------------------------------------------------------
|
||||
;; Section = [Listof (cons Identifier Doc)]
|
||||
;; Sections = [Listof (list Title Section)]
|
||||
(provide
|
||||
;; Identfier ... *-> Sections
|
||||
;; retrieve the document without the specified identfiers
|
||||
docs
|
||||
|
||||
;; Sections String -> [Listof ScribbleBox]
|
||||
;; render the sections as a scribble list of splice-boxes: #:tag-prefix p
|
||||
render-sections)
|
||||
;; -----------------------------------------------------------------------
|
||||
;;
|
||||
|
||||
(define (render-sections s c p)
|
||||
(cond
|
||||
[(null? s) '()]
|
||||
[else
|
||||
(define section1 (car s))
|
||||
(define others (render-sections (cdr s) c p))
|
||||
(define-values (section-title stuff) (apply values section1))
|
||||
(define sorted
|
||||
(sort stuff string<=?
|
||||
#:key (lambda (x) (symbol->string (syntax-e (car x))))))
|
||||
(define typed (for/list ((s sorted)) (re-context c (car s) (cdr s))))
|
||||
(cons @section[#:tag-prefix p]{@section-title}
|
||||
(cons typed others))]))
|
||||
|
||||
;; this is not going to work
|
||||
(define (re-context c id defproc)
|
||||
defproc)
|
||||
|
||||
;;
|
||||
(define (docs . exceptions)
|
||||
(define s (reverse *sections))
|
||||
(define (is-exception i)
|
||||
(memf (lambda (j) (eq? (syntax-e j) (syntax-e i))) exceptions))
|
||||
(for/fold ((result '())) ((s *sections))
|
||||
(define sectn (second s))
|
||||
(define clean
|
||||
(filter (lambda (i) (not (is-exception (car i)))) sectn))
|
||||
(cons (list (first s) clean) result)))
|
||||
;;
|
||||
;; state variable: Sections
|
||||
(define *sections '())
|
||||
;; String Section -> Void
|
||||
;; add _scontent_ section to *sections in the doc submodule
|
||||
(define (#,*add stitle scontent)
|
||||
(define exists (assoc stitle *sections))
|
||||
(if exists
|
||||
(set! *sections
|
||||
(for/list ((s *sections))
|
||||
(if (string=? (first s) stitle)
|
||||
(list stitle (append scontent (second s)))
|
||||
s)))
|
||||
(set! *sections (cons (list stitle scontent) *sections))))
|
||||
|
||||
#,@(map (lambda (adp) (adp)) add-docs-and-provide))
|
||||
p* ...)])))
|
||||
|
||||
;; [Listof (u Identifier (Identifier Identifier))] -> [Listof Identifier]
|
||||
(define-for-syntax (extract-external-name lon)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user