diff --git a/collects/scribble/base-render.ss b/collects/scribble/base-render.ss new file mode 100644 index 00000000..38deb5fb --- /dev/null +++ b/collects/scribble/base-render.ss @@ -0,0 +1,265 @@ + +(module base-render mzscheme + (require "struct.ss" + (lib "class.ss") + (lib "serialize.ss") + (lib "file.ss")) + + (provide render%) + + (define render% + (class object% + + (init-field dest-dir) + + (define/public (get-dest-directory) + dest-dir) + + (define/public (get-substitutions) null) + + (define/public (get-suffix) #".txt") + + (define/public (format-number number sep) + (if (or (null? number) + (andmap not number)) + null + (cons + (apply + string-append + (map (lambda (n) + (if n + (format "~s." n) + "")) + (reverse number))) + sep))) + + ;; ---------------------------------------- + ;; global-info collection + + (define/public (save-info fn info) + (let ([s (serialize info)]) + (with-output-to-file fn + (lambda () + (write s)) + 'truncate/replace))) + + (define/public (load-info fn info) + (let ([ht (deserialize (with-input-from-file fn read))]) + (hash-table-for-each ht (lambda (k v) + (hash-table-put! info k v)))) + info) + + (define/public (collect ds fns) + (let ([ht (make-hash-table 'equal)]) + (map (lambda (d) + (collect-part d #f ht null)) + ds) + ht)) + + (define/public (collect-part d parent ht number) + (let ([p-ht (make-hash-table 'equal)]) + (when (part-title-content d) + (collect-content (part-title-content d) p-ht)) + (when (part-tag d) + (collect-part-tag d p-ht)) + (collect-flow (part-flow d) p-ht) + (let loop ([parts (part-parts d)] + [pos 1]) + (unless (null? parts) + (let ([s (car parts)]) + (collect-part s d p-ht + (cons (if (unnumbered-part? s) + #f + pos) + number)) + (loop (cdr parts) + (if (unnumbered-part? s) pos (add1 pos)))))) + (set-part-collected-info! d (make-collected-info + number + parent + p-ht)) + (hash-table-for-each p-ht + (lambda (k v) + (hash-table-put! ht k v))))) + + (define/public (collect-part-tag d ht) + (hash-table-put! ht `(part ,(part-tag d)) (part-title-content d))) + + (define/public (collect-content c ht) + (for-each (lambda (i) + (collect-element i ht)) + c)) + + (define/public (collect-paragraph p ht) + (collect-content (paragraph-content p) ht)) + + (define/public (collect-flow p ht) + (for-each (lambda (p) + (collect-flow-element p ht)) + (flow-paragraphs p))) + + (define/public (collect-flow-element p ht) + (cond + [(table? p) (collect-table p ht)] + [(itemization? p) (collect-itemization p ht)] + [(delayed-flow-element? p) (void)] + [else (collect-paragraph p ht)])) + + (define/public (collect-table i ht) + (for-each (lambda (d) (collect-flow d ht)) + (apply append (table-flowss i)))) + + (define/public (collect-itemization i ht) + (for-each (lambda (d) (collect-flow d ht)) + (itemization-flows i))) + + (define/public (collect-element i ht) + (when (target-element? i) + (collect-target-element i ht)) + (when (index-element? i) + (collect-index-element i ht)) + (when (element? i) + (for-each (lambda (e) + (collect-element e ht)) + (element-content i)))) + + (define/public (collect-target-element i ht) + (hash-table-put! ht (target-element-tag i) i)) + + (define/public (collect-index-element i ht) + (hash-table-put! ht `(index-entry ,(index-element-tag i)) + (list (index-element-plain-seq i) + (index-element-entry-seq i)))) + + ;; ---------------------------------------- + ;; render methods + + (define/public (render ds fns ht) + (map (lambda (d fn) + (printf " [Output to ~a]\n" fn) + (with-output-to-file fn + (lambda () + (render-one d ht fn)) + 'truncate/replace)) + + ds + fns)) + + (define/public (render-one d ht fn) + (render-part d ht)) + + (define/public (render-part d ht) + (list + (when (part-title-content d) + (render-content (part-title-content d) d ht)) + (render-flow (part-flow d) d ht) + (map (lambda (s) (render-part s ht)) + (part-parts d)))) + + (define/public (render-content c part ht) + (apply append + (map (lambda (i) + (render-element i part ht)) + c))) + + (define/public (render-paragraph p part ht) + (render-content (paragraph-content p) part ht)) + + (define/public (render-flow p part ht) + (apply append + (map (lambda (p) + (render-flow-element p part ht)) + (flow-paragraphs p)))) + + (define/public (render-flow-element p part ht) + (cond + [(table? p) (render-table p part ht)] + [(itemization? p) (render-itemization p part ht)] + [(delayed-flow-element? p) (render-flow-element + ((delayed-flow-element-render p) this part ht) + part ht)] + [else (render-paragraph p part ht)])) + + (define/public (render-table i part ht) + (map (lambda (d) (render-flow d part ht)) + (apply append (table-flowss i)))) + + (define/public (render-itemization i part ht) + (map (lambda (d) (render-flow d part ht)) + (itemization-flows i))) + + (define/public (render-element i part ht) + (cond + [(and (link-element? i) + (null? (element-content i))) + (let ([v (hash-table-get ht (link-element-tag i) #f)]) + (if v + (render-content v part ht) + (render-content (list "[missing]") part ht)))] + [(element? i) + (render-content (element-content i) part ht)] + [(delayed-element? i) + (render-content (force-delayed-element i this part ht) part ht)] + [else + (render-other i part ht)])) + + (define/public (render-other i part ht) + (list i)) + + ;; ---------------------------------------- + + (define/public (install-file fn) + (let ([src-dir (path-only fn)] + [dest-dir (get-dest-directory)] + [fn (file-name-from-path fn)]) + (let ([src-file (build-path (or src-dir (current-directory)) + fn)] + [dest-file (build-path (or dest-dir (current-directory)) + fn)]) + (unless (and (file-exists? dest-file) + (call-with-input-file* + src-file + (lambda (src) + (call-with-input-file* + dest-file + (lambda (dest) + (or (equal? (port-file-identity src) + (port-file-identity dest)) + (let loop () + (let ([s (read-bytes 4096 src)] + [d (read-bytes 4096 dest)]) + (and (equal? s d) + (if (eof-object? s) + #t + (loop))))))))))) + (when (file-exists? dest-file) (delete-file dest-file)) + (copy-file src-file dest-file)) + (path->string fn)))) + + ;; ---------------------------------------- + + (define/public (table-of-contents part ht) + (make-table #f (cdr (render-toc part)))) + + (define/private (render-toc part) + (let ([number (collected-info-number (part-collected-info part))]) + (cons + (list (make-flow + (list + (make-paragraph + (list + (make-element 'hspace (list (make-string (* 2 (length number)) #\space))) + (make-link-element "toclink" + (append + (format-number number + (list + (make-element 'hspace '(" ")))) + (part-title-content part)) + `(part ,(part-tag part)))))))) + (apply + append + (map (lambda (p) (render-toc p)) (part-parts part)))))) + + ;; ---------------------------------------- + + (super-new)))) diff --git a/collects/scribble/basic.ss b/collects/scribble/basic.ss new file mode 100644 index 00000000..5fac4c40 --- /dev/null +++ b/collects/scribble/basic.ss @@ -0,0 +1,189 @@ + +(module basic mzscheme + (require "decode.ss" + "struct.ss" + "config.ss" + (lib "kw.ss") + (lib "list.ss") + (lib "class.ss")) + + (provide title + section + subsection + subsubsection + subsubsub*section + include-section) + + (define (gen-tag content) + (regexp-replace* "[^-a-zA-Z0-9_=]" + (content->string content) + "_")) + + (define/kw (title #:key [tag #f] #:body str) + (let ([content (decode-content str)]) + (make-title-decl (or tag (gen-tag content)) content))) + + (define/kw (section #:key [tag #f] #:body str) + (let ([content (decode-content str)]) + (make-part-start 0 (or tag (gen-tag content)) content))) + + (define/kw (subsection #:key [tag #f] #:body str) + (let ([content (decode-content str)]) + (make-part-start 1 (or tag (gen-tag content)) content))) + + (define/kw (subsubsection #:key [tag #f] #:body str) + (let ([content (decode-content str)]) + (make-part-start 2 (or tag (gen-tag content)) content))) + + (define/kw (subsubsub*section #:key [tag #f] #:body str) + (let ([content (decode-content str)]) + (make-paragraph (list (make-element 'bold content))))) + + (define-syntax include-section + (syntax-rules () + [(_ mod) + (begin + (require (only mod doc)) + doc)])) + + ;; ---------------------------------------- + + (provide itemize item item?) + + (define/kw (itemize #:body items) + (let ([items (filter (lambda (v) (not (whitespace? v))) items)]) + (for-each (lambda (v) + (unless (an-item? v) + (error 'itemize + "expected an item, found something else: ~e" + v))) + items) + (make-itemization (map an-item-flow items)))) + + (define-struct an-item (flow)) + (define (item? x) (an-item? x)) + + (define/kw (item #:body str) + (make-an-item (decode-flow str))) + + ;; ---------------------------------------- + + (provide hspace + elem + italic bold + tt span-class + subscript superscript) + + (define (hspace n) + (make-element 'hspace (list (make-string n #\space)))) + + (define/kw (elem #:body str) + (make-element #f (decode-content str))) + + (define/kw (italic #:body str) + (make-element 'italic (decode-content str))) + + (define/kw (bold #:body str) + (make-element 'bold (decode-content str))) + + (define/kw (tt #:body str) + (make-element 'tt (decode-content str))) + + (define/kw (span-class classname #:body str) + (make-element classname (decode-content str))) + + (define/kw (subscript #:body str) + (make-element 'subscript (decode-content str))) + + (define/kw (superscript #:body str) + (make-element superscript (decode-content str))) + + ;; ---------------------------------------- + + (provide index index* as-index index-section) + + (define (gen-target) + (format "index:~s:~s" (current-seconds) (gensym))) + + (define (record-index word-seq element-seq tag content) + (make-index-element + #f + (list (make-target-element #f content tag)) + tag + word-seq + element-seq)) + + (define/kw (index* word-seq content-seq #:body s) + (let ([key (gen-target)]) + (record-index word-seq + content-seq + key + (decode-content s)))) + + (define/kw (index word-seq #:body s) + (let ([word-seq (if (string? word-seq) + (list word-seq) + word-seq)]) + (apply index* word-seq word-seq s))) + + (define/kw (as-index #:body s) + (let ([key (gen-target)] + [content (decode-content s)]) + (record-index (list (content->string content)) + (list (make-element #f content)) + key + content))) + + (define (index-section tag) + (make-unnumbered-part + tag + (list "Index") + #f + (make-flow (list (make-delayed-flow-element + (lambda (renderer sec ht) + (let ([l null]) + (hash-table-for-each + (collected-info-info + (part-collected-info + (collected-info-parent + (part-collected-info sec)))) + (lambda (k v) + (if (and (pair? k) + (eq? 'index-entry (car k))) + (set! l (cons (cons (cadr k) v) l))))) + (let ([l (sort + l + (lambda (a b) + (let loop ([a (cadr a)][b (cadr b)]) + (cond + [(null? a) #t] + [(null? b) #f] + [(string-ci=? (car a) (car b)) + (loop (cdr a) (cdr b))] + [else + (string-ci")))) + + (define/kw (optional #:body s) + (make-element #f (append (list "[") (decode-content s) (list "]")))) + + (define/kw (BNF-group #:body s) + (make-element #f (append (list "{") + (list (apply BNF-seq (decode-content s))) + (list "}")))) + + (define/kw (kleenestar #:body s) + (make-element #f (append (decode-content s) (list "*")))) + + (define/kw (kleeneplus #:body s) + (make-element #f (append (decode-content s) (list (make-element 'superscript (list "+")))))) + + (define/kw (kleenerange a b #:body s) + (make-element #f (append (decode-content s) + (list (make-element 'superscript + (list (format "{~a,~a}" a b)))))))) diff --git a/collects/scribble/config.ss b/collects/scribble/config.ss new file mode 100644 index 00000000..9907cd0a --- /dev/null +++ b/collects/scribble/config.ss @@ -0,0 +1,6 @@ + +(module config mzscheme + + (provide value-color) + + (define value-color "DarkBlue")) diff --git a/collects/scribble/decode.ss b/collects/scribble/decode.ss new file mode 100644 index 00000000..b245e7ad --- /dev/null +++ b/collects/scribble/decode.ss @@ -0,0 +1,178 @@ + +(module decode mzscheme + (require "struct.ss" + (lib "contract.ss") + (lib "class.ss")) + + (provide decode + decode-part + decode-flow + decode-paragraph + decode-content + decode-string + whitespace?) + + (provide-structs + [title-decl ([tag any/c] + [content list?])] + [part-start ([depth integer?] + [tag (or/c false/c string?)] + [title list?])] + [splice ([run list?])]) + + (define (decode-string s) + (let loop ([l '((#rx"---" mdash) + (#rx"--" ndash) + (#rx"``" ldquo) + (#rx"''" rdquo) + (#rx"'" rsquo))]) + (cond + [(null? l) (list s)] + [(regexp-match-positions (caar l) s) + => (lambda (m) + (append (decode-string (substring s 0 (caar m))) + (cdar l) + (decode-string (substring s (cdar m)))))] + [else (loop (cdr l))]))) + + (define (line-break? v) + (and (string? v) + (equal? v "\n"))) + + (define (whitespace? v) + (and (string? v) + (regexp-match #px"^[\\s]*$" v))) + + (define (decode-accum-para accum) + (if (andmap whitespace? accum) + null + (list (decode-paragraph (reverse (skip-whitespace accum)))))) + + (define (decode-flow* l tag title part-depth) + (let loop ([l l][next? #f][accum null][title title][tag tag]) + (cond + [(null? l) (make-part tag + title + #f + (make-flow (decode-accum-para accum)) + null)] + [(title-decl? (car l)) + (unless part-depth + (error 'decode + "misplaced title: ~e" + (car l))) + (when title + (error 'decode + "found extra title: ~v" + (car l))) + (loop (cdr l) next? accum (title-decl-content (car l)) (title-decl-tag (car l)))] + [(or (paragraph? (car l)) + (table? (car l)) + (itemization? (car l)) + (delayed-flow-element? (car l))) + (let ([para (decode-accum-para accum)] + [part (decode-flow* (cdr l) tag title part-depth)]) + (make-part (part-tag part) + (part-title-content part) + (part-collected-info part) + (make-flow (append para + (list (car l)) + (flow-paragraphs (part-flow part)))) + (part-parts part)))] + [(part? (car l)) + (let ([para (decode-accum-para accum)] + [part (decode-part (cdr l) tag title part-depth)]) + (make-part (part-tag part) + (part-title-content part) + (part-collected-info part) + (make-flow (append para + (flow-paragraphs + (part-flow part)))) + (cons (car l) (part-parts part))))] + [(and (part-start? (car l)) + (or (not part-depth) + ((part-start-depth (car l)) . <= . part-depth))) + (unless part-depth + (error 'decode + "misplaced part: ~e" + (car l))) + (let ([s (car l)]) + (let loop ([l (cdr l)] + [s-accum null]) + (if (or (null? l) + (or (and (part-start? (car l)) + ((part-start-depth (car l)) . <= . part-depth)) + (part? (car l)))) + (let ([para (decode-accum-para accum)] + [s (decode-part (reverse s-accum) + (part-start-tag s) + (part-start-title s) + (add1 part-depth))] + [part (decode-part l tag title part-depth)]) + (make-part (part-tag part) + (part-title-content part) + (part-collected-info part) + (make-flow para) + (cons s (part-parts part)))) + (loop (cdr l) (cons (car l) s-accum)))))] + [(splice? (car l)) + (loop (append (splice-run (car l)) (cdr l)) next? accum title tag)] + [(null? (cdr l)) (loop null #f (cons (car l) accum) title tag)] + [(and (pair? (cdr l)) + (splice? (cadr l))) + (loop (cons (car l) (append (splice-run (cadr l)) (cddr l))) next? accum title tag)] + [(line-break? (car l)) + (if next? + (loop (cdr l) #t accum title tag) + (let ([m (match-newline-whitespace (cdr l))]) + (if m + (let ([part (loop m #t null title tag)]) + (make-part (part-tag part) + (part-title-content part) + (part-collected-info part) + (make-flow (append (decode-accum-para accum) + (flow-paragraphs (part-flow part)))) + (part-parts part))) + (loop (cdr l) #f (cons (car l) accum) title tag))))] + [else (loop (cdr l) #f (cons (car l) accum) title tag)]))) + + (define (decode-part l tag title depth) + (decode-flow* l tag title depth)) + + (define (decode-flow l) + (part-flow (decode-flow* l #f #f #f))) + + (define (match-newline-whitespace l) + (cond + [(null? l) #f] + [(line-break? (car l)) + (skip-whitespace l)] + [(splice? (car l)) + (match-newline-whitespace (append (splice-run (car l)) + (cdr l)))] + [(whitespace? (car l)) + (match-newline-whitespace (cdr l))] + [else #f])) + + (define (skip-whitespace l) + (let loop ([l l]) + (if (or (null? l) + (not (whitespace? (car l)))) + l + (loop (cdr l))))) + + (define (decode l) + (decode-part l #f #f 0)) + + (define (decode-paragraph l) + (make-paragraph + (decode-content l))) + + (define (decode-content l) + (apply append + (map (lambda (s) + (cond + [(string? s) + (decode-string s)] + [else (list s)])) + (skip-whitespace l))))) diff --git a/collects/scribble/doclang.ss b/collects/scribble/doclang.ss new file mode 100644 index 00000000..ad6ee794 --- /dev/null +++ b/collects/scribble/doclang.ss @@ -0,0 +1,61 @@ + +(module doclang mzscheme + (require "struct.ss" + "decode.ss" + (lib "kw.ss")) + (require-for-syntax (lib "kerncase.ss" "syntax")) + + (provide (all-from-except mzscheme #%module-begin) + (rename *module-begin #%module-begin)) + + ;; Module wrapper ---------------------------------------- + + (define-syntax (*module-begin stx) + (syntax-case stx () + [(_ id exprs . body) + #'(#%plain-module-begin + (doc-begin id exprs . body))])) + + (define-syntax (doc-begin stx) + (syntax-case stx () + [(_ m-id (expr ...)) + #`(begin + (define m-id (decode (list . #,(reverse (syntax->list #'(expr ...)))))) + (provide m-id))] + [(_ m-id exprs . body) + ;; `body' probably starts with lots of string constants; + ;; it's slow to trampoline on every string, so do them + ;; in a batch here: + (let loop ([body #'body] + [accum null]) + (syntax-case body () + [(s . rest) + (string? (syntax-e #'s)) + (loop #'rest (cons #'s accum))] + [() + (with-syntax ([(accum ...) accum]) + #`(doc-begin m-id (accum ... . exprs)))] + [(body1 . body) + (with-syntax ([exprs (append accum #'exprs)]) + (let ([expanded (local-expand #'body1 + 'module + (append + (kernel-form-identifier-list #'here) + (syntax->list #'(provide + require + require-for-syntax))))]) + (syntax-case expanded (begin) + [(begin body1 ...) + #`(doc-begin m-id exprs body1 ... . body)] + [(id . rest) + (and (identifier? #'id) + (ormap (lambda (kw) (module-identifier=? #'id kw)) + (syntax->list #'(require + provide + require-for-syntax + define-values + define-syntaxes + define-for-syntaxes)))) + #`(begin #,expanded (doc-begin m-id exprs . body))] + [_else + #`(doc-begin m-id (#,expanded . exprs) . body)])))]))]))) diff --git a/collects/scribble/docreader.ss b/collects/scribble/docreader.ss new file mode 100644 index 00000000..8329a325 --- /dev/null +++ b/collects/scribble/docreader.ss @@ -0,0 +1,34 @@ + +(module docreader mzscheme + (require (prefix scribble: "reader.ss") + (lib "kw.ss")) + + (provide (rename *read read) + (rename *read-syntax read-syntax)) + + (define (call-with-scribble-params t) + (parameterize ([scribble:read-accept-=-keyword #f] + [scribble:read-insert-indents #f]) + (t))) + + (define/kw (*read #:optional [inp (current-input-port)]) + (call-with-scribble-params + (lambda () + (wrap inp (scribble:read-inside inp))))) + + (define/kw (*read-syntax #:optional src [port (current-input-port)]) + (call-with-scribble-params + (lambda () + (wrap port (scribble:read-inside-syntax src port))))) + + (define (wrap port body) + (let* ([p-name (object-name port)] + [name (if (path? p-name) + (let-values ([(base name dir?) (split-path p-name)]) + (string->symbol (path->string (path-replace-suffix name #"")))) + 'page)] + [id 'doc]) + `(module ,name (lib "doclang.ss" "scribble") + (#%module-begin + ,id () + . ,body))))) diff --git a/collects/scribble/eval.ss b/collects/scribble/eval.ss new file mode 100644 index 00000000..866d7ce2 --- /dev/null +++ b/collects/scribble/eval.ss @@ -0,0 +1,227 @@ + +(module eval mzscheme + (require "manual.ss" + "struct.ss" + "scheme.ss" + "decode.ss" + (lib "class.ss") + (lib "file.ss") + (lib "string.ss")) + + (provide interaction + interaction-eval + interaction-eval-show + schemeblock+eval + schememod+eval + def+int + defs+int + examples + defexamples + + current-int-namespace + eval-example-string + + scribble-eval-handler) + + (define current-int-namespace (make-parameter (make-namespace))) + (define scribble-eval-handler (make-parameter (lambda (c? x) (eval x)))) + + (define image-counter 0) + + (define (interleave title expr-paras val-list+outputs) + (make-table + #f + (append + (if title (list (list title)) null) + (let loop ([expr-paras expr-paras] + [val-list+outputs val-list+outputs] + [first? #t]) + (if (null? expr-paras) + null + (append + (list (list (let ([p (car expr-paras)]) + (if (flow? p) + p + (make-flow (list p)))))) + (append + (if (string? (car val-list+outputs)) + (list + (list (make-flow (list (make-paragraph + (list + (hspace 2) + (span-class "schemeerror" + (italic (car val-list+outputs))))))))) + (append + (if (string=? "" (cdar val-list+outputs)) + null + (list + (list + (make-flow + (list + (let ([s (regexp-split #rx"\n" + (regexp-replace #rx"\n$" + (cdar val-list+outputs) + ""))]) + (if (= 1 (length s)) + (make-paragraph + (list + (hspace 2) + (span-class "schemestdout" (car s)))) + (make-table + #f + (map (lambda (s) + (list (make-flow (list (make-paragraph + (list + (hspace 2) + (span-class "schemestdout" s))))))) + s))))))))) + (let ([val-list (caar val-list+outputs)]) + (if (equal? val-list (list (void))) + null + (map (lambda (v) + (list (make-flow (list (make-paragraph + (list + (hspace 2) + (span-class "schemeresult" + (to-element/no-color v)))))))) + val-list))))) + (loop (cdr expr-paras) + (cdr val-list+outputs) + #f)))))))) + + (define (do-eval s) + (cond + [(and (list? s) + (eq? 'code:line (car s)) + (= (length s) 3) + (list? (caddr s)) + (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 + (let ([o (open-output-string)]) + (parameterize ([current-output-port o]) + (with-handlers ([exn? (lambda (e) + (exn-message e))]) + (cons (do-plain-eval s #t) + (get-output-string o)))))])) + + (define (strip-comments s) + (cond + [(and (pair? s) + (pair? (car s)) + (eq? (caar s) 'code:comment)) + (strip-comments (cdr s))] + [(pair? s) + (cons (strip-comments (car s)) + (strip-comments (cdr s)))] + [(eq? s 'code:blank) (void)] + [else s])) + + + (define (do-plain-eval s catching-exns?) + (parameterize ([current-namespace (current-int-namespace)]) + (call-with-values (lambda () ((scribble-eval-handler) catching-exns? (strip-comments s))) list))) + + (define-syntax interaction-eval + (syntax-rules () + [(_ e) (#%expression + (begin (parameterize ([current-command-line-arguments #()]) + (do-plain-eval (quote e) #f)) + ""))])) + + + (define (show-val v) + (span-class "schemeresult" + (to-element/no-color v))) + + (define-syntax interaction-eval-show + (syntax-rules () + [(_ e) (#%expression + (parameterize ([current-command-line-arguments #()]) + (show-val (car (do-plain-eval (quote e) #f)))))])) + + (define (eval-example-string s) + (eval (read (open-input-string s)))) + + (parameterize ([current-namespace (current-int-namespace)]) + (eval `(define eval-example-string ,eval-example-string))) + + (define-syntax schemeinput* + (syntax-rules (eval-example-string eval:alts) + [(_ (eval-example-string s)) + (make-paragraph + (list + (hspace 2) + (tt "> ") + (span-class "schemevalue" (schemefont s))))] + [(_ (eval:alts a b)) (schemeinput* a)] + [(_ e) (schemeinput e)])) + + (define (defspace p) + (make-flow (list p + (make-paragraph null)))) + + (define-syntax (schemedefinput* stx) + (syntax-case stx (eval-example-string define) + [(_ (eval-example-string s)) + #'(schemeinput* (eval-example-string s))] + [(_ (define . rest)) + (syntax-case stx () + [(_ e) #'(defspace (schemeblock e))])] + [(_ (code:line (define . rest) . rest2)) + (syntax-case stx () + [(_ e) #'(defspace (schemeblock e))])] + [(_ e) #'(schemeinput e)])) + + (define-syntax titled-interaction + (syntax-rules () + [(_ t schemeinput* e ...) + (interleave t + (list (schemeinput* e) ...) + (map do-eval (list (quote e) ...)))])) + + (define-syntax interaction + (syntax-rules () + [(_ e ...) (titled-interaction #f schemeinput* e ...)])) + + (define-syntax schemeblock+eval + (syntax-rules () + [(_ e ...) + (#%expression + (begin (interaction-eval e) ... + (schemeblock e ...)))])) + + (define-syntax schememod+eval + (syntax-rules () + [(_ name e ...) + (#%expression + (begin (interaction-eval e) ... + (schememod name e ...)))])) + + (define-syntax def+int + (syntax-rules () + [(_ def e ...) + (make-splice (list (schemeblock+eval def) + (interaction e ...)))])) + + (define-syntax defs+int + (syntax-rules () + [(_ [def ...] e ...) + (make-splice (list (schemeblock+eval def ...) + (interaction e ...)))])) + + (define example-title + (make-flow (list (make-paragraph (list "Examples:"))))) + (define-syntax examples + (syntax-rules () + [(_ e ...) + (titled-interaction example-title schemeinput* e ...)])) + (define-syntax defexamples + (syntax-rules () + [(_ e ...) + (titled-interaction example-title schemedefinput* e ...)]))) + diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss new file mode 100644 index 00000000..eccc0e81 --- /dev/null +++ b/collects/scribble/html-render.ss @@ -0,0 +1,324 @@ + +(module html-render mzscheme + (require "struct.ss" + (lib "class.ss") + (lib "file.ss") + (lib "runtime-path.ss") + (prefix xml: (lib "xml.ss" "xml"))) + (provide render-mixin + render-multi-mixin) + + (xml:empty-tag-shorthand xml:html-empty-tags) + + (define-runtime-path scribble-css "scribble.css") + + (define current-subdirectory (make-parameter #f)) + (define current-output-file (make-parameter #f)) + (define on-separate-page (make-parameter #f)) + (define collecting-sub (make-parameter 0)) + + ;; ---------------------------------------- + ;; main mixin + + (define (render-mixin %) + (class % + (inherit render-content + render-flow-element + collect-part + install-file + get-dest-directory + format-number) + + (define/override (get-suffix) #".html") + + ;; ---------------------------------------- + + (define/override (collect ds fns) + (let ([ht (make-hash-table 'equal)]) + (map (lambda (d fn) + (parameterize ([current-output-file fn]) + (collect-part d #f ht null))) + ds + fns) + ht)) + + (define/override (collect-part-tag d ht) + (hash-table-put! ht + `(part ,(part-tag d)) + (list (current-output-file) + (part-title-content d)))) + + (define/override (collect-target-element i ht) + (hash-table-put! ht + (target-element-tag i) + (list (current-output-file) #f))) + + ;; ---------------------------------------- + + (define/public (render-one-part d ht fn number) + (parameterize ([current-output-file fn]) + (let ([xpr `(html () + (head + (meta ((http-equiv "content-type") + (content "text-html; charset=utf-8"))) + ,@(let ([c (part-title-content d)]) + (if c + `((title ,@(render-content c d ht))) + null)) + (link ((rel "stylesheet") + (type "text/css") + (href "scribble.css") + (title "default")))) + (body ,@(render-part d ht)))]) + (install-file scribble-css) + (xml:write-xml/content (xml:xexpr->xml xpr))))) + + (define/override (render-one d ht fn) + (render-one-part d ht fn null)) + + (define/override (render-part d ht) + (let ([number (collected-info-number (part-collected-info d))]) + `(,@(if (and (not (part-title-content d)) + (null? number)) + null + `((,(case (length number) + [(0) 'h2] + [(1) 'h3] + [else 'h4]) + ,@(format-number number '((tt nbsp))) + ,@(if (part-tag d) + `((a ((name ,(format "~a" `(part ,(part-tag d))))))) + null) + ,@(if (part-title-content d) + (render-content (part-title-content d) d ht) + null)))) + ,@(render-flow* (part-flow d) d ht #f) + ,@(let loop ([pos 1] + [secs (part-parts d)]) + (if (null? secs) + null + (append + (render-part (car secs) ht) + (loop (add1 pos) (cdr secs)))))))) + + (define/private (render-flow* p part ht special-last?) + ;; Wrap each table with

, except for a trailing table + ;; when `special-last?' is #t + (let loop ([f (flow-paragraphs p)]) + (cond + [(null? f) null] + [(and (table? (car f)) + (or (not special-last?) + (not (null? (cdr f))))) + (cons `(p ,@(render-flow-element (car f) part ht)) + (loop (cdr f)))] + [else + (append (render-flow-element (car f) part ht) + (loop (cdr f)))]))) + + (define/override (render-flow p part ht) + (render-flow* p part ht #t)) + + (define/override (render-paragraph p part ht) + `((p ,@(super render-paragraph p part ht)))) + + (define/override (render-element e part ht) + (cond + [(target-element? e) + `((a ((name ,(target-element-tag e))) ,@(render-plain-element e part ht)))] + [(link-element? e) + (let ([dest (hash-table-get ht (link-element-tag e) #f)]) + (if dest + `((a ((href ,(format "~a#~a" + (from-root (car dest) + (get-dest-directory)) + (link-element-tag e))) + ,@(if (string? (element-style e)) + `((class ,(element-style e))) + null)) + ,@(if (null? (element-content e)) + (render-content (cadr dest) part ht) + (render-content (element-content e) part ht)))) + `((font ((class "badlink")) + ,@(if (null? (element-content e)) + `(,(format "~s" (link-element-tag e))) + (render-plain-element e part ht))))))] + [else (render-plain-element e part ht)])) + + (define/private (render-plain-element e part ht) + (let ([style (and (element? e) + (element-style e))]) + (cond + [(symbol? style) + (case style + [(italic) `((i ,@(super render-element e part ht)))] + [(bold) `((b ,@(super render-element e part ht)))] + [(tt) `((tt ,@(super render-element e part ht)))] + [(sf) `((b (font ([size "-1"][face "Helvetica"]) ,@(super render-element e part ht))))] + [(subscript) `((sub ,@(super render-element e part ht)))] + [(superscript) `((sup ,@(super render-element e part ht)))] + [(hspace) `((tt ,@(map (lambda (c) 'nbsp) (string->list (content->string (element-content e))))))] + [else (error 'html-render "unrecognized style symbol: ~e" style)])] + [(string? style) + `((span ([class ,style]) ,@(super render-element e part ht)))] + [(target-url? style) + `((a ((href ,(target-url-addr style))) ,@(super render-element e part ht)))] + [(image-file? style) `((img ((src ,(install-file (image-file-path style))))))] + [else (super render-element e part ht)]))) + + (define/override (render-table t part ht) + `((table ((cellspacing "0") ,@(case (table-style t) + [(boxed) '((width "100%") (bgcolor "lightgray"))] + [(centered) '((align "center"))] + [else null])) + ,@(map (lambda (flows) + `(tr ,@(map (lambda (d a) + `(td ,@(case a + [(#f) null] + [(right) '(((align "right")))] + [(left) '(((align "left")))]) + ,@(render-flow d part ht))) + flows + (cdr (or (and (list? (table-style t)) + (assoc 'alignment (or (table-style t) null))) + (cons #f (map (lambda (x) #f) flows))))))) + (table-flowss t))))) + + (define/override (render-itemization t part ht) + `((ul + ,@(map (lambda (flow) + `(li ,@(render-flow flow part ht))) + (itemization-flows t))))) + + (define/override (render-other i part ht) + (list (cond + [(string? i) i] + [(eq? i 'mdash) `(span " " ndash " ")] + [(symbol? i) i] + [else (format "~s" i)]))) + + ;; ---------------------------------------- + + (super-new))) + + ;; ---------------------------------------- + ;; multi-file output + + (define (render-multi-mixin %) + (class % + (inherit render-one + render-one-part + render-content) + + (define/override (get-suffix) #"") + + (define/override (get-dest-directory) + (or (build-path (or (super get-dest-directory) (current-directory)) + (current-subdirectory)) + (super get-dest-directory))) + + (define/private (derive-filename d) + (format "~a.html" (regexp-replace* + "[^-a-zA-Z0-9_=]" + (or (format "~a" (part-tag d)) + (content->string (part-title-content d))) + "_"))) + + (define/override (collect ds fns) + (super collect ds (map (lambda (fn) + (build-path fn "index.html")) + fns))) + + (define/override (collect-part d parent ht number) + (let ([prev-sub (collecting-sub)]) + (parameterize ([collecting-sub (add1 prev-sub)]) + (if (= 1 prev-sub) + (let ([filename (derive-filename d)]) + (parameterize ([current-output-file (build-path (path-only (current-output-file)) + filename)]) + (super collect-part d parent ht number))) + (super collect-part d parent ht number))))) + + (define/override (render ds fns ht) + (map (lambda (d fn) + (printf " [Output to ~a/index.html]\n" fn) + (unless (directory-exists? fn) + (make-directory fn)) + (parameterize ([current-subdirectory (file-name-from-path fn)]) + (let ([fn (build-path fn "index.html")]) + (with-output-to-file fn + (lambda () + (render-one d ht fn)) + 'truncate/replace)))) + ds + fns)) + + (define/override (render-part d ht) + (let ([number (collected-info-number (part-collected-info d))]) + (cond + [(and (not (on-separate-page)) + (= 1 (length number))) + ;; Render as just a link, and put the actual + ;; content in a new file: + (let* ([filename (derive-filename d)] + [full-path (build-path (path-only (current-output-file)) + filename)]) + (parameterize ([on-separate-page #t]) + (with-output-to-file full-path + (lambda () + (render-one-part d ht full-path number)) + 'truncate/replace) + null + #; + `((table + ((width "90%") (cellspacing "0") (align "center")) + ,@(render-toc-entry d filename ht number)))))] + [else + ;; Normal section render + (super render-part d ht)]))) + + (super-new))) + + ;; ---------------------------------------- + ;; utils + + (define (from-root p d) + (if d + (let ([e-d (explode (path->complete-path d (current-directory)))] + [e-p (explode (path->complete-path p (current-directory)))]) + (let loop ([e-d e-d] + [e-p e-p]) + (cond + [(null? e-d) (let loop ([e-p e-p]) + (cond + [(null? e-p) "/"] + [(null? (cdr e-p)) (car e-p)] + [(eq? 'same (car e-p)) (loop (cdr e-p))] + [(eq? 'up (car e-p)) + (string-append "../" (loop (cdr e-p)))] + [else (string-append (car e-p) + "/" + (loop (cdr e-p)))]))] + [(equal? (car e-d) (car e-p)) + (loop (cdr e-d) (cdr e-p))] + [(eq? 'same (car e-d)) + (loop (cdr e-d) e-p)] + [(eq? 'same (car e-p)) + (loop e-d (cdr e-p))] + [else + (string-append + (apply string-append (map (lambda (x) "../") e-d)) + (loop null e-p))]))) + p)) + + (define (explode p) + (reverse (let loop ([p p]) + (let-values ([(base name dir?) (split-path p)]) + (let ([name (if base + (if (path? name) + (path-element->string name) + name) + name)]) + (if (path? base) + (cons name (loop base)) + (list name)))))))) diff --git a/collects/scribble/latex-render.ss b/collects/scribble/latex-render.ss new file mode 100644 index 00000000..c61c3b20 --- /dev/null +++ b/collects/scribble/latex-render.ss @@ -0,0 +1,208 @@ + +(module latex-render mzscheme + (require "struct.ss" + (lib "class.ss")) + (provide render-mixin) + + (define current-table-depth (make-parameter 0)) + + (define-struct (toc-paragraph paragraph) ()) + + (define (render-mixin %) + (class % + (define/override (get-suffix) #".tex") + + (inherit render-flow + render-content + install-file) + + (define (define-color s s2) + (printf "\\newcommand{\\~a}[1]{{\\texttt{\\color{~a}{#1}}}}\n" s s2)) + + (define/override (render-one d ht fn) + (printf "\\documentclass{article}\n") + (printf "\\parskip=10pt%\n") + (printf "\\parindent=0pt%\n") + (printf "\\usepackage{graphicx}\n") + (printf "\\usepackage{fullpage}\n") + (printf "\\usepackage{longtable}\n") + (printf "\\usepackage[usenames,dvipsnames]{color}\n") + (define-color "schemeplain" "black") + (printf "\\newcommand{\\schemekeyword}[1]{{\\color{black}{\\texttt{\\textbf{#1}}}}}\n") + (printf "\\newcommand{\\schemesyntaxlink}[1]{\\schemekeyword{#1}}\n") + (define-color "schemecomment" "Brown") + (define-color "schemeparen" "BrickRed") + (define-color "schemeinputcol" "BrickRed") + (define-color "schemesymbol" "NavyBlue") + (define-color "schemevalue" "ForestGreen") + (define-color "schemevaluelink" "blue") + (define-color "schemeresult" "blue") + (define-color "schemestdout" "Purple") + (define-color "schemevariablecol" "NavyBlue") + (printf "\\newcommand{\\schemevariable}[1]{{\\schemevariablecol{\\textsl{#1}}}}\n") + (define-color "schemeerrorcol" "red") + (printf "\\newcommand{\\schemeerror}[1]{{\\schemeerrorcol{\\textit{#1}}}}\n") + (printf "\\newcommand{\\schemeopt}[1]{#1}\n") + (printf "\\newcommand{\\textsub}[1]{$_{#1}$}\n") + (printf "\\newcommand{\\textsuper}[1]{$^{#1}$}\n") + (printf "\\definecolor{LightGray}{rgb}{0.85,0.85,0.85}\n") + (printf "\\newcommand{\\schemeinput}[1]{\\colorbox{LightGray}{\\schemeinputcol{#1}}}\n") + (printf "\\begin{document}\n") + (when (part-title-content d) + (printf "\\title{") + (render-content (part-title-content d) d ht) + (printf "}\\maketitle\n")) + (render-part d ht) + (printf "\\end{document}\n")) + + (define/override (render-part d ht) + (let ([number (collected-info-number (part-collected-info d))]) + (when (and (part-title-content d) + (pair? number)) + (printf "\\~a~a{" + (case (length number) + [(0 1) "section"] + [(2) "subsection"] + [(3) "subsubsection"] + [else "subsubsection*"]) + (if (and (pair? number) + (not (car number))) + "*" + "")) + (render-content (part-title-content d) d ht) + (printf "}")) + (when (part-tag d) + (printf "\\label{section:~a}" (part-tag d))) + (render-flow (part-flow d) d ht) + (for-each (lambda (sec) (render-part sec ht)) + (part-parts d)) + null)) + + (define/override (render-paragraph p part ht) + (printf "\n\n") + (if (toc-paragraph? p) + (printf "\\tableofcontents") + (super render-paragraph p part ht)) + (printf "\n\n") + null) + + (define/override (render-element e part ht) + (when (and (link-element? e) + (pair? (link-element-tag e)) + (eq? 'part (car (link-element-tag e)))) + (printf "\\S\\ref{section:~a} " (cadr (link-element-tag e)))) + (let ([style (and (element? e) + (element-style e))] + [wrap (lambda (e s) + (printf "{\\~a{" s) + (super render-element e part ht) + (printf "}}"))]) + (cond + [(symbol? style) + (case style + [(italic) (wrap e "textit")] + [(bold) (wrap e "textbf")] + [(tt) (wrap e "texttt")] + [(sf) (wrap e "textsf")] + [(subscript) (wrap e "textsub")] + [(superscript) (wrap e "textsuper")] + [(hspace) (let ([s (content->string (element-content e))]) + (unless (zero? (string-length s)) + (printf "{\\texttt ~a}" + (regexp-replace* #rx"." s "~"))))] + [else (error 'latex-render "unrecognzied style symbol: ~s" style)])] + [(string? style) + (wrap e style)] + [(image-file? style) + (let ([fn (install-file (image-file-path style))]) + (printf "\\includegraphics{~a}" fn))] + [else (super render-element e part ht)])) + null) + + (define/override (render-table t part ht) + (let* ([boxed? (eq? 'boxed (table-style t))] + [index? (eq? 'index (table-style t))] + [tableform (cond + [index? "theindex"] + [(zero? (current-table-depth)) + "longtable"] + [else "tabular"])] + [opt (if (zero? (current-table-depth)) + "[l]" + "")]) + (unless (null? (table-flowss t)) + (parameterize ([current-table-depth (add1 (current-table-depth))]) + (if index? + (printf "\n\n\\begin{theindex}\n") + (printf "\n\n~a\\begin{~a}~a{@{}~a@{}}\n" + (if boxed? "\\vspace{4ex}\\hrule\n\\vspace{-2ex}\n" "") + tableform + opt + (make-string (length (car (table-flowss t))) #\l))) + (for-each (lambda (flows) + (let loop ([flows flows]) + (unless (null? flows) + (render-flow (car flows) part ht) + (unless (null? (cdr flows)) + (printf " &\n") + (loop (cdr flows))))) + (unless index? + (printf " \\\\\n"))) + (table-flowss t)) + (printf "\n\n\\end{~a}\n" tableform)))) + null) + + (define/override (render-itemization t part ht) + (printf "\n\n\\begin{itemize}\n") + (for-each (lambda (flow) + (printf "\n\n\\item ") + (render-flow flow part ht)) + (itemization-flows t)) + (printf "\n\n\\end{itemize}\n") + null) + + (define/override (render-other i part ht) + (cond + [(string? i) (display-protected i)] + [(symbol? i) (display + (case i + [(nbsp) "~"] + [(mdash) "---"] + [(ndash) "--"] + [(ldquo) "``"] + [(rdquo) "''"] + [(rsquo) "'"] + [(rarr) "$\\rightarrow$"]))] + [else (display-protected (format "~s" i))]) + null) + + (define/private (display-protected s) + (let ([len (string-length s)]) + (let loop ([i 0]) + (unless (= i len) + (let ([c (string-ref s i)]) + (case c + [(#\\) (display "$\\backslash$")] + [(#\_) (display "$\\_$")] + [(#\>) (display "$>$")] + [(#\<) (display "$<$")] + [(#\~) (display "$\\sim$")] + [(#\{ #\} #\# #\% #\&) (display "\\") (display c)] + [(#\uDF) (display "{\\ss}")] + [(#\u039A #\u0391 #\u039F #\u03A3 + #\u03BA #\u03b1 #\u03BF #\u03C3) + (printf "$\\backslash$u~a" + (let ([s (format "0000~x" (char->integer c))]) + (substring s (- (string-length s) 4))))] + [else (display c)])) + (loop (add1 i)))))) + + ;; ---------------------------------------- + + (define/override (table-of-contents sec ht) + ;; FIXME: isn't local to the section + (make-toc-paragraph null)) + + ;; ---------------------------------------- + + (super-new)))) diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss new file mode 100644 index 00000000..70e50f6b --- /dev/null +++ b/collects/scribble/manual.ss @@ -0,0 +1,467 @@ + +(module manual mzscheme + (require "decode.ss" + "struct.ss" + "scheme.ss" + "config.ss" + "basic.ss" + (lib "string.ss") + (lib "kw.ss") + (lib "list.ss") + (lib "class.ss")) + + (provide (all-from "basic.ss")) + + (provide PLaneT) + (define PLaneT "PLaneT") + + (define-code schemeblock0 to-paragraph) + (define-code schemeblock (to-paragraph/prefix (hspace 2) + (hspace 2))) + (define-code SCHEMEBLOCK (to-paragraph/prefix (hspace 2) + (hspace 2)) + UNSYNTAX) + (define-code SCHEMEBLOCK0 to-paragraph UNSYNTAX) + (define-code schemeinput (to-paragraph/prefix (make-element + #f + (list + (hspace 2) + (make-element 'tt (list "> " )))) + (hspace 4))) + + (define-syntax (schememod stx) + (syntax-case stx () + [(_ lang rest ...) + (with-syntax ([modtag (datum->syntax-object + #'here + '(unsyntax (schemefont "#module ")) + #'lang)]) + #'(schemeblock modtag lang rest ...))])) + + (define (to-element/result s) + (make-element "schemeresult" (list (to-element/no-color s)))) + (define (to-element/id s) + (make-element "schemesymbol" (list (to-element/no-color s)))) + + (define-code scheme to-element unsyntax (lambda (ctx s v) s)) + (define-code schemeresult to-element/result unsyntax (lambda (ctx s v) s)) + (define-code schemeid to-element/id unsyntax (lambda (ctx s v) s)) + (define-code schememodname to-element unsyntax (lambda (ctx s v) s)) + + (define (litchar . strs) + (unless (andmap string? strs) + (raise-type-error 'litchar "strings" strs)) + (let ([s (apply string-append + (map (lambda (s) (if (string=? s "\n") " " s)) + strs))]) + (let ([spaces (regexp-match-positions #rx"^ *" s)]) + (make-element "schemeinput" + (list (hspace (cdar spaces)) + (make-element 'tt (list (substring s (cdar spaces))))))))) + + (define (verbatim s) + (let ([strs (regexp-split #rx"\n" s)]) + (make-table + #f + (map (lambda (s) + (list (make-flow (list (make-paragraph + (let ([spaces (cdar (regexp-match-positions #rx"^ *" s))]) + (list + (hspace spaces) + (make-element 'tt (list (substring s spaces)))))))))) + strs)))) + + (provide schemeblock SCHEMEBLOCK + schemeblock0 SCHEMEBLOCK0 + schemeinput + schememod + scheme schemeresult schemeid schememodname + litchar + verbatim) + + (provide onscreen menuitem defterm + schemefont schemevalfont schemeresultfont schemeidfont + schemeparenfont schemekeywordfont + file exec + link procedure + idefterm) + + (define/kw (onscreen #:body str) + (make-element 'sf (decode-content str))) + (define (menuitem menu item) + (make-element 'sf (list menu "|" item))) + (define/kw (defterm #:body str) + (make-element 'italic (decode-content str))) + (define/kw (idefterm #:body str) + (let ([c (decode-content str)]) + (make-element 'italic c))) + (define/kw (schemefont #:body str) + (apply tt str)) + (define/kw (schemevalfont #:body str) + (make-element "schemevalue" (decode-content str))) + (define/kw (schemeresultfont #:body str) + (make-element "schemeresult" (decode-content str))) + (define/kw (schemeidfont #:body str) + (make-element "schemesymbol" (decode-content str))) + (define/kw (schemeparenfont #:body str) + (make-element "schemeparen" (decode-content str))) + (define/kw (schemekeywordfont #:body str) + (make-element "schemekeyword" (decode-content str))) + (define/kw (file #:body str) + (make-element 'tt (append (list "\"") (decode-content str) (list "\"")))) + (define/kw (exec #:body str) + (make-element 'tt (decode-content str))) + (define/kw (procedure #:body str) + (make-element 'tt (append (list "#")))) + + (define/kw (link url #:body str) + (make-element (make-target-url url) (decode-content str))) + + (provide t) + (define/kw (t #:body str) + (decode-paragraph str)) + + (provide schememodule) + (define-syntax (schememodule stx) + (syntax-rules () + [(_ body ...) + (code body ...)])) + + ;; ---------------------------------------- + + (provide defproc defproc* defstruct defthing defform + specsubform specsubform/inline + var svar void-const) + + (define (void-const) + "void") + + (define dots0 + (make-element #f (list "..."))) + (define dots1 + (make-element #f (list "..." (superscript "+")))) + + (define-syntax defproc + (syntax-rules () + [(_ s-exp result desc ...) + (*defproc '[s-exp] '[result] (lambda () (list desc ...)))])) + (define-syntax defproc* + (syntax-rules () + [(_ [[s-exp result] ...] desc ...) + (*defproc '[s-exp ...] '[result ...] (lambda () (list desc ...)))])) + (define-syntax defstruct + (syntax-rules () + [(_ name fields desc ...) + (*defstruct 'name 'fields (lambda () (list desc ...)))])) + (define-syntax (defform stx) + (syntax-case stx () + [(_ spec desc ...) + (with-syntax ([new-spec + (syntax-case #'spec () + [(name . rest) + (datum->syntax-object #'spec + (cons + (datum->syntax-object #'here + '(unsyntax x) + #'name) + #'rest) + #'spec)])]) + #'(*defform 'spec (lambda (x) (schemeblock0 new-spec)) (lambda () (list desc ...))))])) + (define-syntax specsubform + (syntax-rules () + [(_ spec desc ...) + (*specsubform 'spec (lambda () (schemeblock0 spec)) (lambda () (list desc ...)))])) + (define-syntax specsubform/inline + (syntax-rules () + [(_ spec desc ...) + (*specsubform 'spec #f (lambda () (list desc ...)))])) + (define-syntax defthing + (syntax-rules () + [(_ id result desc ...) + (*defthing 'id 'result (lambda () (list desc ...)))])) + (define-syntax var + (syntax-rules () + [(_ id) (*var 'id)])) + (define-syntax svar + (syntax-rules () + [(_ id) (*var 'id)])) + + (define (*defproc prototypes results content-thunk) + (let ([spacer (hspace 1)] + [has-optional? (lambda (arg) + (and (pair? arg) + ((length arg) . > . (if (keyword? (car arg)) + 2 + 3))))] + [arg->elem (lambda (v) + (cond + [(pair? v) + (if (keyword? (car v)) + (make-element #f (list (to-element (car v)) + (hspace 1) + (to-element (cadr v)))) + (to-element (car v)))] + [(eq? v '...1) + dots1] + [(eq? v '...0) + dots0] + [else v]))]) + (parameterize ([current-variable-list + (map (lambda (i) + (and (pair? i) + (car i))) + (apply append (map cdr prototypes)))]) + (make-splice + (cons + (make-table + 'boxed + (apply + append + (map + (lambda (prototype result first?) + (append + (list + (list (make-flow + (list + (make-paragraph + (list + (let-values ([(required optional more-required) + (let loop ([a (cdr prototype)][r-accum null]) + (if (or (null? a) + (and (has-optional? (car a)))) + (let ([req (reverse r-accum)]) + (let loop ([a a][o-accum null]) + (if (or (null? a) + (not (has-optional? (car a)))) + (values req (reverse o-accum) a) + (loop (cdr a) (cons (car a) o-accum))))) + (loop (cdr a) (cons (car a) r-accum))))]) + (to-element (append + (list (if first? + (make-target-element + #f + (list (to-element (car prototype))) + (register-scheme-definition (car prototype))) + (to-element (car prototype)))) + (map arg->elem required) + (if (null? optional) + null + (list + (to-element + (syntax-property + (syntax-ize (map arg->elem optional) 0) + 'paren-shape + #\?)))) + (map arg->elem more-required)))) + (hspace 2) + 'rarr + (hspace 2) + (to-element result))))))) + (apply append + (map (lambda (v) + (cond + [(pair? v) + (list + (list + (make-flow + (list + (let ([v (if (keyword? (car v)) + (cdr v) + v)]) + (make-paragraph (append + (list + (hspace 2) + (arg->elem v)) + (list + spacer + ":" + spacer + (to-element (cadr v))) + (if (has-optional? v) + (list spacer + "=" + spacer + (to-element (caddr v))) + null))))))))] + [else null])) + (cdr prototype))))) + prototypes + results + (cons #t (map (lambda (x) #f) (cdr prototypes)))))) + (content-thunk)))))) + + (define (make-target-element* content wrappers) + (if (null? wrappers) + content + (make-target-element* + (make-target-element + #f + (list content) + (register-scheme-definition (string->symbol + (apply string-append + (map symbol->string (car wrappers)))))) + (cdr wrappers)))) + + (define (*defstruct name fields content-thunk) + (define spacer (hspace 1)) + (make-splice + (cons + (make-table + 'boxed + (cons + (list (make-flow + (list + (make-paragraph + (list + (to-element + `(struct ,(make-target-element* + (to-element name) + (let ([name (if (pair? name) + (car name) + name)]) + (list* (list name) + (list name '?) + (list 'make- name) + (append + (map (lambda (f) + (list name '- (car f))) + fields) + (map (lambda (f) + (list 'set- name '- (car f) '!)) + fields))))) + ,(map car fields)))))))) + (map (lambda (v) + (cond + [(pair? v) + (list + (make-flow + (list + (make-paragraph (append + (list + (hspace 2) + (to-element (car v))) + (list + spacer + ":" + spacer + (to-element (cadr v))))))))] + [else null])) + fields))) + (content-thunk)))) + + (define (*defthing name result-contract content-thunk) + (define spacer (hspace 1)) + (make-splice + (cons + (make-table + 'boxed + (list + (list (make-flow + (list + (make-paragraph + (list (make-target-element + #f + (list (to-element name)) + (register-scheme-definition name)) + spacer ":" spacer + (to-element result-contract)))))))) + (content-thunk)))) + + (define (*defform form form-proc content-thunk) + (parameterize ([current-variable-list + (let loop ([form (cdr form)]) + (cond + [(symbol? form) (list form)] + [(pair? form) (append (loop (car form)) + (loop (cdr form)))] + [else null]))]) + (make-splice + (cons + (make-table + 'boxed + (list + (list (make-flow + (list + ((or form-proc + (lambda (x) + (make-paragraph + (list + (to-element + `(,x + . ,(cdr form))))))) + (make-target-element + #f + (list (to-element (car form))) + (register-scheme-form-definition (car form))))))))) + (content-thunk))))) + + (define (*specsubform form form-thunk content-thunk) + (parameterize ([current-variable-list + (let loop ([form form]) + (cond + [(symbol? form) (list form)] + [(pair? form) (append (loop (car form)) + (loop (cdr form)))] + [else null]))]) + (make-splice + (cons + (if form-thunk + (form-thunk) + (to-element form)) + (content-thunk))))) + + (define (*var id) + (to-element (*var-sym id))) + + (define (*var-sym id) + (string->symbol (format "_~a" id))) + + ;; ---------------------------------------- + + (provide centerline) + (define/kw (centerline #:body s) + (make-table 'centered (list (list (make-flow (list (decode-paragraph s))))))) + + (provide commandline) + (define/kw (commandline #:body s) + (make-paragraph (list (hspace 2) (apply tt s)))) + + + (define (secref s) + (make-link-element #f null `(part ,s))) + (define/kw (seclink tag #:body s) + (make-link-element #f (decode-content s) `(part ,tag))) + (define/kw (*schemelink id #:body s) + (make-link-element #f (decode-content s) (register-scheme-definition id))) + (define-syntax schemelink + (syntax-rules () + [(_ id . content) (*schemelink 'id . content)])) + (provide secref seclink schemelink) + + (define/kw (pidefterm #:body s) + (let ([c (apply defterm s)]) + (index (string-append (content->string (element-content c)) "s") + c))) + (provide pidefterm) + + ;; ---------------------------------------- + + (provide math) + (define/kw (math #:body s) + (let ([c (decode-content s)]) + (make-element #f (apply append + (map (lambda (i) + (let loop ([i i]) + (cond + [(string? i) + (let ([m (regexp-match #rx"^(.*)([()])(.*)$" i)]) + (if m + (append (loop (cadr m)) + (list (caddr m)) + (loop (cadddr m))) + (list (make-element 'italic (list i)))))] + [else (list i)]))) + c))))) + + ;; ---------------------------------------- + ) diff --git a/collects/scribble/run.ss b/collects/scribble/run.ss new file mode 100644 index 00000000..2c0cde96 --- /dev/null +++ b/collects/scribble/run.ss @@ -0,0 +1,89 @@ + +(module run mzscheme + (require "struct.ss" + "base-render.ss" + (lib "cmdline.ss") + (lib "class.ss") + (lib "file.ss") + (prefix text: "text-render.ss") + (prefix html: "html-render.ss") + (prefix latex: "latex-render.ss")) + + (provide (all-defined) + html:render-mixin + latex:render-mixin + text:render-mixin) + + (define multi-html:render-mixin + (lambda (%) + (html:render-multi-mixin + (html:render-mixin %)))) + + (define current-render-mixin + (make-parameter text:render-mixin)) + (define current-dest-directory + (make-parameter #f)) + (define current-dest-name + (make-parameter #f)) + (define current-info-output-file + (make-parameter #f)) + (define current-info-input-files + (make-parameter null)) + + (define (get-command-line-files argv) + (command-line + "scribble" + argv + [once-any + [("--text") "generate text-format output (the default)" + (void)] + [("--html") "generate HTML-format output file" + (current-render-mixin html:render-mixin)] + [("--htmls") "generate HTML-format output directory" + (current-render-mixin multi-html:render-mixin)] + [("--latex") "generate LaTeX-format output" + (current-render-mixin latex:render-mixin)]] + [once-each + [("--dest") dir "write output in

" + (current-dest-directory dir)] + [("--dest-name") name "write output as " + (current-dest-name name)] + [("--info-out") file "write format-specific link information to " + (current-info-output-file file)]] + [multi + [("++info-in") file "load format-specific link information form " + (current-info-input-files + (cons file (current-info-input-files)))]] + [args file file])) + + (define (build-docs-files files) + (build-docs (map (lambda (file) + (dynamic-require file 'doc)) + files) + files)) + + (define (build-docs docs files) + (let ([dir (current-dest-directory)]) + (when dir + (make-directory* dir)) + + (let ([renderer (new ((current-render-mixin) render% ) + [dest-dir dir])]) + (let* ([fns (map (lambda (fn) + (let-values ([(base name dir?) (split-path fn)]) + (let ([fn (path-replace-suffix (or (current-dest-name) name) + (send renderer get-suffix))]) + (if dir + (build-path dir fn) + fn)))) + files)] + [info (send renderer collect docs fns)]) + (let ([info (let loop ([info info] + [files (reverse (current-info-input-files))]) + (if (null? files) + info + (loop (send renderer load-info (car files) info) + (cdr files))))]) + (send renderer render docs fns info)) + (when (current-info-output-file) + (send renderer save-info (current-info-output-file) info))))))) diff --git a/collects/scribble/scheme.ss b/collects/scribble/scheme.ss new file mode 100644 index 00000000..712474cd --- /dev/null +++ b/collects/scribble/scheme.ss @@ -0,0 +1,386 @@ +(module scheme mzscheme + (require "struct.ss" + "basic.ss" + (lib "class.ss")) + + (provide define-code + to-element + to-element/no-color + to-paragraph + to-paragraph/prefix + register-scheme-definition + register-scheme-form-definition + syntax-ize + syntax-ize-hook + current-keyword-list + current-variable-list) + + (define no-color "schemeplain") + (define meta-color "schemeplain") + (define keyword-color "schemekeyword") + (define comment-color "schemecomment") + (define paren-color "schemeparen") + (define value-color "schemevalue") + (define symbol-color "schemesymbol") + (define variable-color "schemevariable") + (define opt-color "schemeopt") + + (define current-keyword-list + (make-parameter '(define let let* letrec require provide + lambda new send if cond begin else and or + define-syntax syntax-rules define-struct + quote quasiquote unquote unquote-splicing + syntax quasisyntax unsyntax unsyntax-splicing + fold-for list-for list-for* for))) + (define current-variable-list + (make-parameter null)) + + (define defined-names (make-hash-table)) + + (define (typeset c multi-line? prefix1 prefix color?) + (let* ([c (syntax-ize c 0)] + [content null] + [docs null] + [first (syntax-case c (code:line) + [(code:line e . rest) #'e] + [else c])] + [init-col (or (syntax-column first) 0)] + [src-col init-col] + [dest-col 0] + [col-map (make-hash-table 'equal)] + [line (or (syntax-line first) 0)]) + (define (finish-line!) + (when multi-line? + (set! docs (cons (make-flow (list (make-paragraph (reverse content)))) + docs)) + (set! content null))) + (define (out v cls) + (unless (equal? v "") + (if (equal? v "\n") + (if multi-line? + (begin + (finish-line!) + (out prefix cls)) + (out " " cls)) + (begin + (set! content (cons (if color? + (make-element cls (list v)) + (make-element 'tt (list v))) + content)) + (set! dest-col (+ dest-col (if (string? v) (string-length v) 1))))))) + (define (advance c init-line!) + (let ([c (syntax-column c)] + [l (syntax-line c)] + [span (syntax-span c)]) + (when (and l (l . > . line)) + (out "\n" no-color) + (set! line l) + (init-line!)) + (when c + (let ([d-col (hash-table-get col-map src-col src-col)]) + (let ([amt (+ (- c src-col) (- d-col dest-col))]) + (when (positive? amt) + (let ([old-dest-col dest-col]) + (out (make-element 'hspace (list (make-string amt #\space))) no-color) + (set! dest-col (+ old-dest-col amt)))))) + (set! src-col (+ c (or span 1)))))) + (define (convert-infix c quote-depth) + (let ([l (syntax->list c)]) + (and l + ((length l) . >= . 3) + ((or (syntax-position (car l)) -inf.0) + . > . + (or (syntax-position (cadr l)) +inf.0)) + (let ([a (car l)]) + (let loop ([l (cdr l)] + [prev null]) + (cond + [(null? l) #f] ; couldn't unwind + [else (let ([p2 (syntax-position (car l))]) + (if (and p2 + (p2 . > . (syntax-position a))) + (datum->syntax-object c + (append + (reverse prev) + (list + (datum->syntax-object + a + (let ([val? (positive? quote-depth)]) + (make-element + (if val? value-color #f) + (list + (make-element (if val? value-color paren-color) '(". ")) + (typeset a #f "" "" (not val?)) + (make-element (if val? value-color paren-color) '(" ."))))) + (list (syntax-source a) + (syntax-line a) + (- (syntax-column a) 2) + (- (syntax-position a) 2) + (+ (syntax-span a) 4)) + a)) + l) + c + c) + (loop (cdr l) + (cons (car l) prev))))])))))) + (define (loop init-line! quote-depth) + (lambda (c) + (cond + [(eq? 'code:blank (syntax-e c)) + (advance c init-line!)] + [(and (pair? (syntax-e c)) + (eq? (syntax-e (car (syntax-e c))) 'code:comment)) + (advance c init-line!) + (out "; " comment-color) + (let ([v (syntax-object->datum (cadr (syntax->list c)))]) + (if (paragraph? v) + (map (lambda (v) (out v comment-color)) (paragraph-content v)) + (out v comment-color)))] + [(and (pair? (syntax-e c)) + (eq? (syntax-e (car (syntax-e c))) 'code:contract)) + (advance c init-line!) + (out "; " comment-color) + (let* ([l (cdr (syntax->list c))] + [s-col (or (syntax-column (car l)) src-col)]) + (set! src-col s-col) + (for-each (loop (lambda () + (set! src-col s-col) + (set! dest-col 0) + (out "; " comment-color)) + 0) + l))] + [(and (pair? (syntax-e c)) + (eq? (syntax-e (car (syntax-e c))) 'code:line)) + (for-each (loop init-line! quote-depth) + (cdr (syntax->list c)))] + [(and (pair? (syntax-e c)) + (eq? (syntax-e (car (syntax-e c))) 'code:quote)) + (advance c init-line!) + (out "(" (if (positive? quote-depth) value-color paren-color)) + (set! src-col (+ src-col 1)) + (hash-table-put! col-map src-col dest-col) + ((loop init-line! quote-depth) + (datum->syntax-object #'here 'quote (car (syntax-e c)))) + (for-each (loop init-line! (add1 quote-depth)) + (cdr (syntax->list c))) + (out ")" (if (positive? quote-depth) value-color paren-color)) + (set! src-col (+ src-col 1)) + (hash-table-put! col-map src-col dest-col)] + [(and (pair? (syntax-e c)) + (memq (syntax-e (car (syntax-e c))) + '(quote quasiquote unquote unquote-splicing + syntax unsyntax))) + (advance c init-line!) + (let-values ([(str quote-delta) + (case (syntax-e (car (syntax-e c))) + [(quote) (values "'" +inf.0)] + [(unquote) (values "," -1)] + [(unquote-splicing) (values ",@" -1)] + [(quasiquote) (values "`" +1)] + [(syntax) (values "#'" 0)] + [(unsyntax) (values "#," 0)])]) + (out str (if (positive? (+ quote-depth quote-delta)) + value-color + meta-color)) + (let ([i (cadr (syntax->list c))]) + (set! src-col (or (syntax-column i) src-col)) + (hash-table-put! col-map src-col dest-col) + ((loop init-line! (+ quote-depth quote-delta)) i)))] + [(and (pair? (syntax-e c)) + (convert-infix c quote-depth)) + => (lambda (converted) + ((loop init-line! quote-depth) converted))] + [(pair? (syntax-e c)) + (let* ([sh (or (syntax-property c 'paren-shape) + #\()] + [p-color (if (positive? quote-depth) + value-color + (if (eq? sh #\?) + opt-color + paren-color))]) + (advance c init-line!) + (out (case sh + [(#\[ #\?) "["] + [(#\{) "{"] + [else "("]) + p-color) + (set! src-col (+ src-col 1)) + (hash-table-put! col-map src-col dest-col) + (let lloop ([l c]) + (cond + [(and (syntax? l) + (pair? (syntax-e l))) + (lloop (syntax-e l))] + [(or (null? l) + (and (syntax? l) + (null? (syntax-e l)))) + (void)] + [(pair? l) + ((loop init-line! quote-depth) (car l)) + (lloop (cdr l))] + [else + (out " . " (if (positive? quote-depth) value-color paren-color)) + (set! src-col (+ src-col 3)) + (hash-table-put! col-map src-col dest-col) + ((loop init-line! quote-depth) l)])) + (out (case sh + [(#\[ #\?) "]"] + [(#\{) "}"] + [else ")"]) + p-color) + (set! src-col (+ src-col 1)) + (hash-table-put! col-map src-col dest-col))] + [else + (advance c init-line!) + (let-values ([(s it? sub?) + (let ([c (syntax-e c)]) + (let ([s (format "~s" c)]) + (if (and (symbol? c) + (char=? (string-ref s 0) #\_)) + (values (substring s 1) #t #f) + (values s #f #f))))]) + (if (element? (syntax-e c)) + (out (syntax-e c) no-color) + (out (if (and (identifier? c) + color? + (quote-depth . <= . 0) + (not it?)) + (make-delayed-element + (lambda (renderer sec ht) + (let* ([vtag (register-scheme-definition (syntax-e c))] + [stag (register-scheme-form-definition (syntax-e c))] + [vd (hash-table-get ht vtag #f)] + [sd (hash-table-get ht stag #f)]) + (list + (cond + [sd + (make-link-element "schemesyntaxlink" (list s) stag)] + [vd + (make-link-element "schemevaluelink" (list s) vtag)] + [else s]))))) + s) + (cond + [(positive? quote-depth) value-color] + [(or (number? (syntax-e c)) + (string? (syntax-e c)) + (bytes? (syntax-e c)) + (char? (syntax-e c)) + (boolean? (syntax-e c))) + value-color] + [(identifier? c) + (cond + [(memq (syntax-e c) (current-keyword-list)) + keyword-color] + [(memq (syntax-e c) (current-variable-list)) + variable-color] + [it? variable-color] + [else symbol-color])] + [else paren-color]))) + (hash-table-put! col-map src-col dest-col))]))) + (hash-table-put! col-map src-col dest-col) + (out prefix1 no-color) + ((loop (lambda () (set! src-col init-col) (set! dest-col 0)) 0) c) + (unless (null? content) + (finish-line!)) + (if multi-line? + (make-table #f (map list (reverse docs))) + (make-element #f (reverse content))))) + + (define (to-element c) + (typeset c #f "" "" #t)) + + (define (to-element/no-color c) + (typeset c #f "" "" #f)) + + (define (to-paragraph c) + (typeset c #t "" "" #t)) + + (define ((to-paragraph/prefix pfx1 pfx) c) + (typeset c #t pfx1 pfx #t)) + + (define-syntax (define-code stx) + (syntax-case stx () + [(_ code typeset-code uncode d->s) + (syntax/loc stx + (define-syntax (code stx) + (define (stx->loc-s-expr v) + (cond + [(syntax? v) + (let ([mk `(d->s + #f + ,(syntax-case v (uncode) + [(uncode e) #'e] + [else (stx->loc-s-expr (syntax-e v))]) + (list 'code + ,(syntax-line v) + ,(syntax-column v) + ,(syntax-position v) + ,(syntax-span v)))]) + (let ([prop (syntax-property v 'paren-shape)]) + (if prop + `(syntax-property ,mk 'paren-shape ,prop) + mk)))] + [(pair? v) `(cons ,(stx->loc-s-expr (car v)) + ,(stx->loc-s-expr (cdr v)))] + [(vector? v) `(vector ,@(map + stx->loc-s-expr + (vector->list v)))] + [(box? v) `(box ,(stx->loc-s-expr (unbox v)))] + [(null? v) 'null] + [else `(quote ,v)])) + (define (cvt s) + (d->s #'here (stx->loc-s-expr s) #f)) + (syntax-case stx () + [(_ expr) #`(typeset-code #,(cvt #'expr))] + [(_ expr (... ...)) + #`(typeset-code #,(cvt #'(code:line expr (... ...))))])))] + [(_ code typeset-code uncode) + #'(define-code code typeset-code uncode datum->syntax-object)] + [(_ code typeset-code) #'(define-code code typeset-code unsyntax)])) + + + (define (register-scheme-definition sym) + (format "definition:~s" sym)) + + (define (register-scheme-form-definition sym) + (format "formdefinition:~s" sym)) + + (define syntax-ize-hook (make-parameter (lambda (v col) #f))) + + (define (syntax-ize v col) + (cond + [((syntax-ize-hook) v col) + => (lambda (r) r)] + [(and (list? v) + (pair? v) + (memq (car v) '(quote unquote unquote-splicing))) + (let ([c (syntax-ize (cadr v) (+ col 1))]) + (datum->syntax-object #f + (list (syntax-ize (car v) col) + c) + (list #f 1 col (+ 1 col) + (+ 1 (syntax-span c)))))] + [(list? v) + (let ([l (let loop ([col (+ col 1)] + [v v]) + (if (null? v) + null + (let ([i (syntax-ize (car v) col)]) + (cons i + (loop (+ col 1 (syntax-span i)) (cdr v))))))]) + (datum->syntax-object #f + l + (list #f 1 col (+ 1 col) + (+ 2 + (sub1 (length l)) + (apply + (map syntax-span l))))))] + [(pair? v) + (let* ([a (syntax-ize (car v) (+ col 1))] + [sep (if (pair? (cdr v)) 0 3)] + [b (syntax-ize (cdr v) (+ col 1 (syntax-span a) sep))]) + (datum->syntax-object #f + (cons a b) + (list #f 1 col (+ 1 col) + (+ 2 sep (syntax-span a) (syntax-span b)))))] + [else + (datum->syntax-object #f v (list #f 1 col (+ 1 col) 1))]))) diff --git a/collects/scribble/scribble.css b/collects/scribble/scribble.css new file mode 100644 index 00000000..a6a4341b --- /dev/null +++ b/collects/scribble/scribble.css @@ -0,0 +1,241 @@ + + body { + color: black; + /* background-color: #e5e5e5;*/ + background-color: #ffffff; + /*background-color: beige;*/ + margin-top: 2em; + margin-left: 8%; + margin-right: 8%; + } + + h1,h2,h3,h4,h5,h6 { + margin-top: .5em; + } + + .toclink { + text-decoration: none; + color: blue; + } + + .title { + font-size: 200%; + font-weight: normal; + margin-top: 2.8em; + text-align: center; + } + + .partheading { + font-size: 100%; + } + + .chapterheading { + font-size: 100%; + } + + .beginsection { + font-size: 110%; + } + + .tiny { + font-size: 40%; + } + + .scriptsize { + font-size: 60%; + } + + .footnotesize { + font-size: 75%; + } + + .small { + font-size: 90%; + } + + .normalsize { + font-size: 100%; + } + + .large { + font-size: 120%; + } + + .largecap { + font-size: 150%; + } + + .largeup { + font-size: 200%; + } + + .huge { + font-size: 300%; + } + + .hugecap { + font-size: 350%; + } + + pre { + margin-left: 2em; + } + + blockquote { + margin-left: 2em; + } + + ol { + list-style-type: decimal; + } + + ol ol { + list-style-type: lower-alpha; + } + + ol ol ol { + list-style-type: lower-roman; + } + + ol ol ol ol { + list-style-type: upper-alpha; + } + + tt i { + font-family: serif; + } + + .verbatim em { + font-family: serif; + } + + /* + .verbatim { + color: #4d0000; + } + */ + + .scheme em { + color: black; + font-family: serif; + } + + .schemeinput { + color: brown; + background-color: #eeeeee; + font-family: monospace; + } + + .schemeparen { + color: brown; + font-family: monospace; + } + + .schemeopt { + color: black; + } + + .schemekeyword { + color: black; + font-weight: bold; + font-family: monospace; + } + + .schemeerror { + color: red; + font-style: italic; + } + + .schemevariable { + color: navy; + font-style: italic; + font-family: monospace; + } + + .schemesymbol { + color: navy; + font-family: monospace; + } + + .schemevaluelink { + text-decoration: none; + color: blue; + font-family: monospace; + } + + .schemesyntaxlink { + text-decoration: none; + color: black; + font-weight: bold; + font-family: monospace; + } + + .badlink { + text-decoration: underline; + color: red; + } + + .schemeresult { + color: navy; + font-family: monospace; + } + + .schemestdout { + color: purple; + font-family: monospace; + } + + .schemecomment { + color: teal; + font-family: monospace; + } + + .schemevalue { + color: green; + font-family: monospace; + } + + .navigation { + color: red; + text-align: right; + font-size: medium; + font-style: italic; + } + + .disable { + /* color: #e5e5e5; */ + color: gray; + } + + .smallcaps { + font-size: 75%; + } + + .smallprint { + color: gray; + font-size: 75%; + text-align: right; + } + + /* + .smallprint hr { + text-align: left; + width: 40%; + } + */ + + .footnoterule { + text-align: left; + width: 40%; + } + + .colophon { + color: gray; + font-size: 80%; + font-style: italic; + text-align: right; + } + + .colophon a { + color: gray; + } diff --git a/collects/scribble/struct.ss b/collects/scribble/struct.ss new file mode 100644 index 00000000..7a3b09d9 --- /dev/null +++ b/collects/scribble/struct.ss @@ -0,0 +1,148 @@ + +(module struct mzscheme + (require (lib "contract.ss") + (lib "serialize.ss")) + + (provide provide-structs) + + (define-syntax (provide-structs stx) + (syntax-case stx () + [(_ (id ([field ct] ...)) ...) + #`(begin + (define-serializable-struct id (field ...)) ... + (provide/contract + #,@(let ([ids (syntax->list #'(id ...))] + [fields+cts (syntax->list #'(([field ct] ...) ...))]) + (letrec ([get-fields (lambda (super-id) + (ormap (lambda (id fields+cts) + (if (identifier? id) + (and (module-identifier=? id super-id) + fields+cts) + (syntax-case id () + [(my-id next-id) + (module-identifier=? #'my-id super-id) + #`[#,@(get-fields #'next-id) + #,@fields+cts]] + [_else #f]))) + ids fields+cts))]) + (map (lambda (id fields+cts) + (if (identifier? id) + #`[struct #,id #,fields+cts] + (syntax-case id () + [(id super) + #`[struct id (#,@(get-fields #'super) + #,@fields+cts)]]))) + ids + fields+cts)))))])) + + (provide tag?) + (define (tag? s) (or (string? s) + (and (pair? s) + (symbol? (car s)) + (pair? (cdr s)) + (string? (cadr s)) + (null? (cddr s))))) + + (provide flow-element?) + (define (flow-element? p) + (or (paragraph? p) + (table? p) + (itemization? p) + (delayed-flow-element? p))) + + (provide-structs + [part ([tag (or/c false/c tag?)] + [title-content (or/c false/c list?)] + [collected-info (or/c false/c collected-info?)] + [flow flow?] + [parts (listof part?)])] + [(unnumbered-part part) ()] + [flow ([paragraphs (listof flow-element?)])] + [paragraph ([content list?])] + [table ([style any/c] + [flowss (listof (listof flow?))])] + [delayed-flow-element ([render (any/c part? any/c . -> . flow-element?)])] + [itemization ([flows (listof flow?)])] + ;; content = list of elements + [element ([style any/c] + [content list?])] + [(target-element element) ([tag tag?])] + [(link-element element) ([tag tag?])] + [(index-element element) ([tag tag?] + [plain-seq (listof string?)] + [entry-seq list?])] + ;; specific renders support other elements, especially strings + + [collected-info ([number (listof (or/c false/c integer?))] + [parent (or/c false/c part?)] + [info any/c])] + + [target-url ([addr string?])] + [image-file ([path path-string?])]) + + ;; ---------------------------------------- + + ;; Delayed element has special serialization support: + (define-values (struct:delayed-element + make-delayed-element + delayed-element? + delayed-element-ref + delayed-element-set!) + (make-struct-type 'delayed-element #f + 1 1 #f + (list (cons prop:serializable + (make-serialize-info + (lambda (d) + (unless (delayed-element-ref d 1) + (error 'serialize-delayed-element + "cannot serialize a delayed element that was not resolved: ~e" + d)) + (vector (delayed-element-ref d 1))) + #'deserialize-delayed-element + #f + (or (current-load-relative-directory) (current-directory))))))) + (define-syntax delayed-element (list-immutable #'struct:delayed-element + #'make-delayed-element + #'delayed-element? + (list-immutable #'delayed-element-render) + (list-immutable #'set-delayed-element-render!) + #t)) + (define delayed-element-render (make-struct-field-accessor delayed-element-ref 0)) + (define set-delayed-element-render! (make-struct-field-mutator delayed-element-set! 0)) + (provide/contract + (struct delayed-element ([render (any/c part? any/c . -> . list?)]))) + + (provide deserialize-delayed-element) + (define deserialize-delayed-element + (make-deserialize-info values values)) + + (provide force-delayed-element) + (define (force-delayed-element d renderer sec ht) + (or (delayed-element-ref d 1) + (let ([v ((delayed-element-ref d 0) renderer sec ht)]) + (delayed-element-set! d 1 v) + v))) + + ;; ---------------------------------------- + + (provide content->string) + + (define (content->string c) + (apply string-append + (map (lambda (e) + (element->string e)) + c))) + + (define (element->string c) + (cond + [(element? c) (content->string (element-content c))] + [(string? c) c] + [else (case c + [(ndash) "--"] + [(ldquo rdquo) "\""] + [(rsquo) "'"] + [(rarr) "->"] + [else (format "~s" c)])])) + + ) + diff --git a/collects/scribble/text-render.ss b/collects/scribble/text-render.ss new file mode 100644 index 00000000..5d306a84 --- /dev/null +++ b/collects/scribble/text-render.ss @@ -0,0 +1,97 @@ + +(module text-render mzscheme + (require "struct.ss" + (lib "class.ss")) + (provide render-mixin) + + (define (render-mixin %) + (class % + (define/override (get-substitutions) + '((#rx"---" "\U2014") + (#rx"--" "\U2013") + (#rx"``" "\U201C") + (#rx"''" "\U201D") + (#rx"'" "\U2019"))) + + (inherit render-content + render-paragraph + render-flow-element) + + (define/override (render-part d ht) + (let ([number (collected-info-number (part-collected-info d))]) + (when (or (ormap values number) + (part-title-content d)) + (newline)) + (for-each (lambda (n) + (when n + (printf "~s." n))) + (reverse number)) + (when (part-title-content d) + (when (ormap values number) + (printf " ")) + (render-content (part-title-content d) d ht)) + (when (or (ormap values number) + (part-title-content d)) + (newline)) + (newline) + (render-flow (part-flow d) d ht) + (let loop ([pos 1] + [secs (part-parts d)]) + (unless (null? secs) + (newline) + (render-part (car secs) ht) + (loop (add1 pos) (cdr secs)))))) + + (define/override (render-flow f part ht) + (let ([f (flow-paragraphs f)]) + (if (null? f) + null + (apply + append + (render-flow-element (car f) part ht) + (map (lambda (p) + (newline) (newline) + (render-flow-element p part ht)) + (cdr f)))))) + + (define/override (render-table i part ht) + (let ([flowss (table-flowss i)]) + (if (null? flowss) + null + (apply + append + (map (lambda (d) (render-flow d part ht)) (car flowss)) + (map (lambda (flows) + (newline) + (map (lambda (d) (render-flow d part ht)) flows)) + (cdr flowss)))))) + + (define/override (render-itemization i part ht) + (let ([flows (itemization-flows i)]) + (if (null? flows) + null + (apply append + (begin + (printf "* ") + (render-flow (car flows) part ht)) + (map (lambda (d) + (printf "\n\n* ") + (render-flow d part ht)) + (cdr flows)))))) + + (define/override (render-other i part ht) + (cond + [(symbol? i) + (display (case i + [(mdash) "\U2014"] + [(ndash) "\U2013"] + [(ldquo) "\U201C"] + [(rdquo) "\U201D"] + [(rsquo) "\U2019"] + [(rarr) "->"] + [else (error 'text-render "unknown element symbol: ~e" i)]))] + [(string? i) (display i)] + [else (write i)]) + null) + + (super-new)))) diff --git a/collects/scribble/urls.ss b/collects/scribble/urls.ss new file mode 100644 index 00000000..ba8f0538 --- /dev/null +++ b/collects/scribble/urls.ss @@ -0,0 +1,8 @@ + +(module urls mzscheme + (provide (all-defined)) + + (define url:drscheme "http://www.drscheme.org/") + (define url:download-drscheme "http://download.plt-scheme.org/drscheme/") + + (define url:planet "http://planet.plt-scheme.org/"))