From 4aefb18cab2bfa9d9fe81e53af2ba472491d1a67 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Mon, 25 Jun 2012 19:12:48 -0400 Subject: [PATCH] fixed bug in provide and scribble (end of stage 1) --- collects/lang/htdp-beginner-abbr.rkt | 2 +- collects/lang/htdp-beginner.rkt | 2 +- collects/lang/private/intermediate-funs.rkt | 2 +- .../lang/private/provide-and-scribble.rkt | 196 ++++++++++-------- 4 files changed, 109 insertions(+), 93 deletions(-) diff --git a/collects/lang/htdp-beginner-abbr.rkt b/collects/lang/htdp-beginner-abbr.rkt index 21a282f4c6..7285fd1b33 100644 --- a/collects/lang/htdp-beginner-abbr.rkt +++ b/collects/lang/htdp-beginner-abbr.rkt @@ -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)) diff --git a/collects/lang/htdp-beginner.rkt b/collects/lang/htdp-beginner.rkt index 903675c868..64537ce9ee 100644 --- a/collects/lang/htdp-beginner.rkt +++ b/collects/lang/htdp-beginner.rkt @@ -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)) diff --git a/collects/lang/private/intermediate-funs.rkt b/collects/lang/private/intermediate-funs.rkt index 869feab3c0..7535eb929b 100644 --- a/collects/lang/private/intermediate-funs.rkt +++ b/collects/lang/private/intermediate-funs.rkt @@ -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.} diff --git a/collects/lang/private/provide-and-scribble.rkt b/collects/lang/private/provide-and-scribble.rkt index 29600583e8..32705f3fdf 100644 --- a/collects/lang/private/provide-and-scribble.rkt +++ b/collects/lang/private/provide-and-scribble.rkt @@ -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)