From ae5f6458d8809abc5b0623ecb5ad4be3815db66f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 18 May 2008 20:26:36 +0000 Subject: [PATCH] reformatted and a little improved code, use scheme/base svn: r9881 original commit: 8f8451dc4f17984156a5733c3e313f9b35de5ea1 --- collects/scribble/decode.ss | 420 +-- collects/scribble/manual.ss | 5000 +++++++++++++++++------------------ 2 files changed, 2596 insertions(+), 2824 deletions(-) diff --git a/collects/scribble/decode.ss b/collects/scribble/decode.ss index 68ea5103..f055debe 100644 --- a/collects/scribble/decode.ss +++ b/collects/scribble/decode.ss @@ -1,228 +1,240 @@ +#lang scheme/base +(require "struct.ss" + "decode-struct.ss" + scheme/contract + scheme/class + scheme/list) -(module decode mzscheme - (require "struct.ss" - "decode-struct.ss" - mzlib/contract - mzlib/class) +(provide decode + decode-part + decode-flow + decode-paragraph + decode-content + (rename-out [decode-content decode-elements]) + decode-string + whitespace?) - (provide decode - decode-part - decode-flow - decode-paragraph - decode-content - (rename decode-content decode-elements) - decode-string - whitespace?) +(provide-structs + [title-decl ([tag-prefix (or/c false/c string?)] + [tags (listof tag?)] + [version (or/c string? false/c)] + [style any/c] + [content list?])] + [part-start ([depth integer?] + [tag-prefix (or/c false/c string?)] + [tags (listof tag?)] + [style any/c] + [title list?])] + [splice ([run list?])] + [part-index-decl ([plain-seq (listof string?)] + [entry-seq list?])] + [part-collect-decl ([element (or/c element? part-relative-element?)])] + [part-tag-decl ([tag tag?])]) - (provide-structs - [title-decl ([tag-prefix (or/c false/c string?)] - [tags (listof tag?)] - [version (or/c string? false/c)] - [style any/c] - [content list?])] - [part-start ([depth integer?] - [tag-prefix (or/c false/c string?)] - [tags (listof tag?)] - [style any/c] - [title list?])] - [splice ([run list?])] - [part-index-decl ([plain-seq (listof string?)] - [entry-seq list?])] - [part-collect-decl ([element (or/c element? part-relative-element?)])] - [part-tag-decl ([tag tag?])]) +(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 (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) + (equal? v "\n")) - (define (line-break? v) - (equal? v "\n")) +(define (whitespace? v) + (and (string? v) (regexp-match? #px"^[\\s]*$" v))) - (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-accum-para accum) - (if (andmap whitespace? accum) - null - (list (decode-paragraph (reverse (skip-whitespace accum)))))) +(define (part-version p) + (if (versioned-part? p) + (versioned-part-version p) + #f)) - (define (part-version p) - (if (versioned-part? p) - (versioned-part-version p) - #f)) - - (define (decode-flow* l keys colls tag-prefix tags vers style title part-depth) - (let loop ([l l] [next? #f] [keys keys] [colls colls] [accum null] - [title title] [tag-prefix tag-prefix] [tags tags] [vers vers] - [style style]) - (cond - [(null? l) - (let ([k-tags (map (lambda (k) `(idx ,(make-generated-tag))) keys)] - [tags (if (null? tags) - (list `(part ,(make-generated-tag))) - tags)]) - (make-versioned-part - tag-prefix - (append tags k-tags) - title - style - (let ([l (append - (map (lambda (k tag) - (make-index-element #f null tag - (part-index-decl-plain-seq k) - (part-index-decl-entry-seq k) - #f)) - keys k-tags) +(define (decode-flow* l keys colls tag-prefix tags vers style title part-depth) + (let loop ([l l] [next? #f] [keys keys] [colls colls] [accum null] + [title title] [tag-prefix tag-prefix] [tags tags] [vers vers] + [style style]) + (cond + [(null? l) + (let ([k-tags (map (lambda (k) `(idx ,(make-generated-tag))) keys)] + [tags (if (null? tags) + (list `(part ,(make-generated-tag))) + tags)]) + (make-versioned-part + tag-prefix + (append tags k-tags) + title + style + (let ([l (append + (map (lambda (k tag) + (make-index-element #f null tag + (part-index-decl-plain-seq k) + (part-index-decl-entry-seq k) + #f)) + keys k-tags) colls)]) - (if (and title (not (or (eq? 'hidden style) - (and (list? style) (memq 'hidden style))))) - (cons (make-index-element - #f null (car tags) - (list (regexp-replace - #px"^\\s+(?:(?:A|An|The)\\s)?" (content->string title) "")) - (list (make-element #f title)) - (make-part-index-desc)) - l) - l)) - (make-flow (decode-accum-para accum)) - null - vers))] - [(title-decl? (car l)) - (cond [(not part-depth) (error 'decode "misplaced title: ~e" (car l))] - [title (error 'decode "found extra title: ~v" (car l))] - [else (loop (cdr l) next? keys colls accum - (title-decl-content (car l)) - (title-decl-tag-prefix (car l)) - (title-decl-tags (car l)) - (title-decl-version (car l)) - (title-decl-style (car l)))])] - [(block? (car l)) - (let ([para (decode-accum-para accum)] - [part (decode-flow* (cdr l) keys colls tag-prefix tags vers style - title part-depth)]) - (make-versioned-part - (part-tag-prefix part) - (part-tags part) - (part-title-content part) - (part-style part) - (part-to-collect part) - (make-flow (append para (list (car l)) - (flow-paragraphs (part-flow part)))) - (part-parts part) - (part-version part)))] - [(part? (car l)) - (let ([para (decode-accum-para accum)] - [part (decode-flow* (cdr l) keys colls tag-prefix tags vers style - title part-depth)]) - (make-versioned-part - (part-tag-prefix part) - (part-tags part) - (part-title-content part) - (part-style part) - (part-to-collect part) - (make-flow (append para (flow-paragraphs (part-flow part)))) - (cons (car l) (part-parts part)) - (part-version 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-styled-part (reverse s-accum) - (part-start-tag-prefix s) - (part-start-tags s) - (part-start-style s) - (part-start-title s) - (add1 part-depth))] - [part (decode-flow* l keys colls tag-prefix tags vers style title part-depth)]) - (make-versioned-part (part-tag-prefix part) - (part-tags part) - (part-title-content part) - (part-style part) - (part-to-collect part) - (make-flow para) - (cons s (part-parts part)) - (part-version part))) - (if (splice? (car l)) - (loop (append (splice-run (car l)) (cdr l)) s-accum) - (loop (cdr l) (cons (car l) s-accum))))))] - [(splice? (car l)) - (loop (append (splice-run (car l)) (cdr l)) next? keys colls accum title tag-prefix tags vers style)] - [(null? (cdr l)) (loop null #f keys colls (cons (car l) accum) title tag-prefix tags vers style)] + (if (and title (not (or (eq? 'hidden style) + (and (list? style) (memq 'hidden style))))) + (cons (make-index-element + #f null (car tags) + (list (regexp-replace + #px"^\\s+(?:(?:A|An|The)\\s)?" + (content->string title) "")) + (list (make-element #f title)) + (make-part-index-desc)) + l) + l)) + (make-flow (decode-accum-para accum)) + null + vers))] + [(title-decl? (car l)) + (cond [(not part-depth) (error 'decode "misplaced title: ~e" (car l))] + [title (error 'decode "found extra title: ~v" (car l))] + [else (loop (cdr l) next? keys colls accum + (title-decl-content (car l)) + (title-decl-tag-prefix (car l)) + (title-decl-tags (car l)) + (title-decl-version (car l)) + (title-decl-style (car l)))])] + [(block? (car l)) + (let ([para (decode-accum-para accum)] + [part (decode-flow* (cdr l) keys colls tag-prefix tags vers style + title part-depth)]) + (make-versioned-part + (part-tag-prefix part) + (part-tags part) + (part-title-content part) + (part-style part) + (part-to-collect part) + (make-flow (append para (list (car l)) + (flow-paragraphs (part-flow part)))) + (part-parts part) + (part-version part)))] + [(part? (car l)) + (let ([para (decode-accum-para accum)] + [part (decode-flow* (cdr l) keys colls tag-prefix tags vers style + title part-depth)]) + (make-versioned-part + (part-tag-prefix part) + (part-tags part) + (part-title-content part) + (part-style part) + (part-to-collect part) + (make-flow (append para (flow-paragraphs (part-flow part)))) + (cons (car l) (part-parts part)) + (part-version 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) + (and (part-start? (car l)) + ((part-start-depth (car l)) . <= . part-depth)) + (part? (car l))) + (let ([para (decode-accum-para accum)] + [s (decode-styled-part (reverse s-accum) + (part-start-tag-prefix s) + (part-start-tags s) + (part-start-style s) + (part-start-title s) + (add1 part-depth))] + [part (decode-flow* l keys colls tag-prefix tags vers style + title part-depth)]) + (make-versioned-part (part-tag-prefix part) + (part-tags part) + (part-title-content part) + (part-style part) + (part-to-collect part) + (make-flow para) + (cons s (part-parts part)) + (part-version part))) + (if (splice? (car l)) + (loop (append (splice-run (car l)) (cdr l)) s-accum) + (loop (cdr l) (cons (car l) s-accum))))))] + [(splice? (car l)) + (loop (append (splice-run (car l)) (cdr l)) + next? keys colls accum title tag-prefix tags vers style)] + [(null? (cdr l)) + (loop null #f keys colls (cons (car l) accum) title tag-prefix tags + vers style)] [(part-index-decl? (car l)) - (loop (cdr l) next? (cons (car l) keys) colls accum title tag-prefix tags vers style)] + (loop (cdr l) next? (cons (car l) keys) colls accum title tag-prefix + tags vers style)] [(part-collect-decl? (car l)) - (loop (cdr l) next? keys (cons (part-collect-decl-element (car l)) colls) accum title tag-prefix tags vers style)] + (loop (cdr l) next? keys + (cons (part-collect-decl-element (car l)) colls) + accum title tag-prefix tags vers style)] [(part-tag-decl? (car l)) - (loop (cdr l) next? keys colls accum title tag-prefix (append tags (list (part-tag-decl-tag (car l)))) vers style)] + (loop (cdr l) next? keys colls accum title tag-prefix + (append tags (list (part-tag-decl-tag (car l)))) + vers style)] [(and (pair? (cdr l)) (splice? (cadr l))) - (loop (cons (car l) (append (splice-run (cadr l)) (cddr l))) next? keys colls accum title tag-prefix tags vers style)] + (loop (cons (car l) (append (splice-run (cadr l)) (cddr l))) + next? keys colls accum title tag-prefix tags vers style)] [(line-break? (car l)) (if next? - (loop (cdr l) #t keys colls accum title tag-prefix tags vers style) - (let ([m (match-newline-whitespace (cdr l))]) - (if m - (let ([part (loop m #t keys colls null title tag-prefix tags vers style)]) - (make-versioned-part (part-tag-prefix part) - (part-tags part) - (part-title-content part) - (part-style part) - (part-to-collect part) - (make-flow (append (decode-accum-para accum) - (flow-paragraphs (part-flow part)))) - (part-parts part) - (part-version part))) - (loop (cdr l) #f keys colls (cons (car l) accum) title tag-prefix tags vers style))))] - [else (loop (cdr l) #f keys colls (cons (car l) accum) title tag-prefix tags vers style)]))) + (loop (cdr l) #t keys colls accum title tag-prefix tags vers style) + (let ([m (match-newline-whitespace (cdr l))]) + (if m + (let ([part (loop m #t keys colls null title tag-prefix tags vers + style)]) + (make-versioned-part + (part-tag-prefix part) + (part-tags part) + (part-title-content part) + (part-style part) + (part-to-collect part) + (make-flow (append (decode-accum-para accum) + (flow-paragraphs (part-flow part)))) + (part-parts part) + (part-version part))) + (loop (cdr l) #f keys colls (cons (car l) accum) title tag-prefix + tags vers style))))] + [else (loop (cdr l) #f keys colls (cons (car l) accum) title tag-prefix + tags vers style)]))) - (define (decode-part l tags title depth) - (decode-flow* l null null #f tags #f #f title depth)) +(define (decode-part l tags title depth) + (decode-flow* l null null #f tags #f #f title depth)) - (define (decode-styled-part l tag-prefix tags style title depth) - (decode-flow* l null null tag-prefix tags #f style title depth)) +(define (decode-styled-part l tag-prefix tags style title depth) + (decode-flow* l null null tag-prefix tags #f style title depth)) - (define (decode-flow l) - (part-flow (decode-flow* l null null #f null #f #f #f #f))) +(define (decode-flow l) + (part-flow (decode-flow* l null null #f null #f #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 (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) - (if (or (null? l) (not (whitespace? (car l)))) - l - (skip-whitespace (cdr l)))) +(define (skip-whitespace l) + (if (or (null? l) (not (whitespace? (car l)))) + l + (skip-whitespace (cdr l)))) - (define (decode l) - (decode-part l null #f 0)) +(define (decode l) + (decode-part l null #f 0)) - (define (decode-paragraph l) - (make-paragraph (decode-content l))) +(define (decode-paragraph l) + (make-paragraph (decode-content l))) - (define (decode-content l) - (apply append (map (lambda (s) (if (string? s) (decode-string s) (list s))) - (skip-whitespace l))))) +(define (decode-content l) + (append-map (lambda (s) (if (string? s) (decode-string s) (list s))) + (skip-whitespace l))) diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss index 6ce9586f..33c9b0dd 100644 --- a/collects/scribble/manual.ss +++ b/collects/scribble/manual.ss @@ -1,2693 +1,2453 @@ +#lang scheme/base +(require "decode.ss" + "struct.ss" + "scheme.ss" + "search.ss" + "config.ss" + "basic.ss" + "manual-struct.ss" + scheme/string + scheme/list + scheme/class + scheme/stxparam + scheme/serialize + setup/main-collects + (for-syntax scheme/base) + (for-label scheme/base + scheme/class)) -(module manual scheme/base - (require "decode.ss" - "struct.ss" - "scheme.ss" - "search.ss" - "config.ss" - "basic.ss" - "manual-struct.ss" - mzlib/string - scheme/class - scheme/stxparam - mzlib/serialize - setup/main-collects - (for-syntax scheme/base) - (for-label scheme/base - scheme/class)) +(provide (all-from-out "basic.ss") + unsyntax) - (provide (all-from-out "basic.ss") - unsyntax) +(provide PLaneT) +(define PLaneT "PLaneT") - (provide PLaneT) - (define PLaneT "PLaneT") +(provide etc) +(define etc "etc.") ; so we can fix the latex space, one day - (provide etc) - (define etc "etc.") ; so we can fix the latex space, one day +(define (to-flow e) + (make-flow (list (make-paragraph (list e))))) +(define spacer (hspace 1)) +(define flow-spacer (to-flow spacer)) +(define flow-empty-line (to-flow (tt 'nbsp))) +(define (make-openers n) + (schemeparenfont + (case n [(1) "("] [(0) ""] [(2) "(("] [else (make-string n #\()]))) +(define (make-closers n) + (schemeparenfont + (case n [(1) ")"] [(0) ""] [(2) "))"] [else (make-string n #\()]))) - (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-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) +(define-syntax (schememod stx) + (syntax-case stx () + [(_ lang rest ...) + (with-syntax ([modtag (datum->syntax + #'here + `(unsyntax (make-element + #f + (list (hash-lang) + spacer + (as-modname-link + ',#'lang + (to-element ',#'lang))))) + #'lang)]) + #'(schemeblock modtag 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-syntax (keep-s-expr stx) + (syntax-case stx () + [(_ ctx s srcloc) + (let ([sv (syntax-e #'s)]) + (if (or (number? sv) + (boolean? sv) + (and (pair? sv) + (identifier? (car sv)) + (free-identifier=? #'cons (car sv)))) + ;; We know that the context is irrelvant + #'s + ;; Context may be relevant: + #'(*keep-s-expr s ctx)))])) +(define (*keep-s-expr s ctx) + (if (symbol? s) + (make-just-context s ctx) + s)) + +(define (add-sq-prop s name val) + (if (eq? name 'paren-shape) + (make-shaped-parens s val) + s)) + +(define-code schemeblockelem to-element) + +(define-code scheme to-element unsyntax keep-s-expr add-sq-prop) +(define-code SCHEME to-element UNSYNTAX keep-s-expr add-sq-prop) +(define-code schemeresult to-element/result unsyntax keep-s-expr add-sq-prop) +(define-code schemeid to-element/id unsyntax keep-s-expr add-sq-prop) +(define-code *schememodname to-element unsyntax keep-s-expr add-sq-prop) + +(define-syntax-rule (schememodname n) + (as-modname-link 'n (*schememodname n))) + +(define (as-modname-link s e) + (if (symbol? s) + (make-link-element "schememodlink" + (list e) + `(mod-path ,(symbol->string s))) + e)) + +(define-syntax-rule (defmodule*/no-declare (name ...) . content) + (*defmodule (list (schememodname name) ...) + #f + (list . content))) + +(define-syntax defmodule* + (syntax-rules () + [(_ (name ...) #:use-sources (pname ...) . content) + (begin (declare-exporting name ... #:use-sources (pname ...)) + (defmodule*/no-declare (name ...) . content))] + [(_ (name ...) . content) + (defmodule* (name ...) #:use-sources () . content)])) + +(define-syntax-rule (defmodule name . content) + (defmodule* (name) . content)) + +(define-syntax-rule (defmodulelang*/no-declare (lang ...) . content) + (*defmodule (list (schememodname lang) ...) #t (list . content))) + +(define-syntax defmodulelang* + (syntax-rules () + [(_ (name ...) #:use-sources (pname ...) . content) + (begin (declare-exporting name ... #:use-sources (pname ...)) + (defmodulelang*/no-declare (name ...) . content))] + [(_ (name ...) . content) + (defmodulelang* (name ...) #:use-sources () . content)])) + +(define-syntax-rule (defmodulelang lang . content) + (defmodulelang* (lang) . content)) + +(define (*defmodule names lang? content) + (make-splice + (cons + (make-table + "defmodule" + (map + (lambda (name) + (list + (make-flow + (list + (make-paragraph + (cons + spacer + (if lang? + (list (hash-lang) spacer (make-defschememodname name)) + (list (scheme (require #,(make-defschememodname name))))))))))) + names)) + (append (map (lambda (name) + (make-part-tag-decl `(mod-path ,(element->string name)))) + names) + (flow-paragraphs (decode-flow content)))))) + +(define (make-defschememodname mn) + (let ([name-str (element->string mn)]) + (make-index-element #f + (list mn) + `(mod-path ,name-str) + (list name-str) + (list mn) + (make-module-path-index-desc)))) + +(define (litchar . strs) + (unless (andmap string? strs) + (raise-type-error 'litchar "strings" strs)) + (let ([s (string-append* (map (lambda (s) (regexp-replace* "\n" s " ")) + strs))]) + (if (regexp-match? #rx"^ *$" s) + (make-element "schemeinputbg" (list (hspace (string-length s)))) + (let ([^spaces (car (regexp-match-positions #rx"^ *" s))] + [$spaces (car (regexp-match-positions #rx" *$" s))]) + (make-element + "schemeinputbg" + (list (hspace (cdr ^spaces)) + (make-element "schemeinput" + (list (substring s (cdr ^spaces) (car $spaces)))) + (hspace (- (cdr $spaces) (car $spaces))))))))) + +(define (verbatim #:indent [i 0] s . more) + (define indent + (if (zero? i) + values + (let ([hs (hspace i)]) (lambda (x) (cons hs x))))) + (define strs (regexp-split #rx"\n" (string-append* s more))) + (define (str->elts str) + (let ([spaces (regexp-match-positions #rx"(?:^| ) +" str)]) + (if spaces + (list* (substring str 0 (caar spaces)) + (hspace (- (cdar spaces) (caar spaces))) + (str->elts (substring str (cdar spaces)))) + (list (make-element 'tt (list str)))))) + (define (make-line str) + (let* ([line (indent (str->elts str))] + [line (list (make-element 'tt line))]) + (list (make-flow (list (make-paragraph line)))))) + (make-table #f (map make-line strs))) + +(define-syntax-rule (indexed-scheme x) + (add-scheme-index 'x (scheme x))) + +(define (add-scheme-index s e) + (let ([k (cond [(and (pair? s) (eq? (car s) 'quote)) (format "~s" (cadr s))] + [(string? s) s] + [else (format "~s" s)])]) + (index* (list k) (list e) e))) + +(define-syntax-rule (define-/form id base) + (define-syntax (id stx) (syntax-case stx () - [(_ lang rest ...) - (with-syntax ([modtag (datum->syntax - #'here - `(unsyntax (make-element - #f - (list (hash-lang) - (hspace 1) - (as-modname-link - ',#'lang - (to-element ',#'lang))))) - #'lang)]) - #'(schemeblock modtag rest ...))])) + [(_ a) + (with-syntax ([ellipses (datum->syntax #'a '(... ...))]) + #'(let ([ellipses #f]) + (base a)))]))) - (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-/form schemeblock0/form schemeblock0) +(define-/form schemeblock/form schemeblock) +(define-/form scheme/form scheme) - (define-syntax (keep-s-expr stx) - (syntax-case stx () - [(_ ctx s srcloc) - (let ([sv (syntax-e #'s)]) - (if (or (number? sv) - (boolean? sv) - (and (pair? sv) - (identifier? (car sv)) - (free-identifier=? #'cons (car sv)))) - ;; We know that the context is irrelvant - #'s - ;; Context may be relevant: - #'(*keep-s-expr s ctx)))])) - (define (*keep-s-expr s ctx) - (if (symbol? s) - (make-just-context s ctx) - s)) +(provide schemeblock SCHEMEBLOCK schemeblock/form + schemeblock0 SCHEMEBLOCK0 schemeblock0/form + schemeblockelem + schemeinput + schememod + schemeerror + scheme SCHEME scheme/form schemeresult schemeid schememodname + defmodule defmodule* defmodulelang defmodulelang* + defmodule*/no-declare defmodulelang*/no-declare + indexed-scheme + litchar + verbatim) - (define (add-sq-prop s name val) - (if (eq? name 'paren-shape) - (make-shaped-parens s val) - s)) +(provide image image/plain onscreen menuitem defterm emph + schemefont schemevalfont schemeresultfont schemeidfont schemevarfont + schemeparenfont schemekeywordfont schememetafont schememodfont + filepath exec envvar Flag DFlag PFlag DPFlag + indexed-file indexed-envvar + link procedure + idefterm + inset-flow) - (define-code schemeblockelem to-element) +;; String String *-> Element +;; an in-lined image, relative to the current directory +(define (image #:scale [scale 1.0] filename-relative-to-source . alt) + (make-element (make-image-file filename-relative-to-source scale) + (decode-content alt))) - (define-code scheme to-element unsyntax keep-s-expr add-sq-prop) - (define-code SCHEME to-element UNSYNTAX keep-s-expr add-sq-prop) - (define-code schemeresult to-element/result unsyntax keep-s-expr add-sq-prop) - (define-code schemeid to-element/id unsyntax keep-s-expr add-sq-prop) - (define-code *schememodname to-element unsyntax keep-s-expr add-sq-prop) +(define (image/plain filename-relative-to-source . alt) + (make-element (make-image-file filename-relative-to-source 1.0) + (decode-content alt))) - (define-syntax-rule (schememodname n) - (as-modname-link 'n (*schememodname n))) +(define (onscreen . str) + (make-element 'sf (decode-content str))) +(define (menuitem menu item) + (make-element 'sf (list menu "|" item))) +(define (emph . str) + (make-element 'italic (decode-content str))) +(define (defterm . str) + (make-element 'italic (decode-content str))) +(define (idefterm . str) + (let ([c (decode-content str)]) + (make-element 'italic c))) +(define (schemefont . str) + (apply tt str)) +(define (schemevalfont . str) + (make-element "schemevalue" (decode-content str))) +(define (schemeresultfont . str) + (make-element "schemeresult" (decode-content str))) +(define (schemeidfont . str) + (make-element "schemesymbol" (decode-content str))) +(define (schemevarfont . str) + (make-element "schemevariable" (decode-content str))) +(define (schemeparenfont . str) + (make-element "schemeparen" (decode-content str))) +(define (schememetafont . str) + (make-element "schememeta" (decode-content str))) +(define (schememodfont . str) + (make-element "schememod" (decode-content str))) +(define (schemekeywordfont . str) + (make-element "schemekeyword" (decode-content str))) +(define (filepath . str) + (make-element 'tt (append (list "\"") (decode-content str) (list "\"")))) +(define (indexed-file . str) + (let* ([f (apply filepath str)] + [s (element->string f)]) + (index* (list (substring s 1 (sub1 (string-length s)))) (list f) f))) +(define (exec . str) + (if (andmap string? str) + (make-element 'tt str) + (make-element #f (map (lambda (s) + (if (string? s) + (make-element 'tt (list s)) + s)) + str)))) +(define (Flag . str) + (make-element 'no-break + (list (make-element 'tt (cons "-" (decode-content str)))))) +(define (DFlag . str) + (make-element 'no-break + (list (make-element 'tt (cons "--" (decode-content str)))))) +(define (PFlag . str) + (make-element 'no-break + (list (make-element 'tt (cons "+" (decode-content str)))))) +(define (DPFlag . str) + (make-element 'no-break + (list (make-element 'tt (cons "++" (decode-content str)))))) +(define (envvar . str) + (make-element 'tt (decode-content str))) +(define (indexed-envvar . str) + (let* ([f (apply envvar str)] + [s (element->string f)]) + (index* (list s) (list f) f))) +(define (procedure . str) + (make-element "schemeresult" `("#"))) - (define (as-modname-link s e) - (if (symbol? s) - (make-link-element "schememodlink" - (list e) - `(mod-path ,(symbol->string s))) - e)) +(define (link url #:underline? [underline? #t] . str) + (make-element (make-target-url url (if underline? #f "plainlink")) + (decode-content str))) - (define-syntax-rule (defmodule*/no-declare (name ...) . content) - (*defmodule (list (schememodname name) ...) - #f - (list . content))) +(define (schemeerror . str) + (make-element "schemeerror" (decode-content str))) - (define-syntax defmodule* - (syntax-rules () - [(_ (name ...) #:use-sources (pname ...) . content) - (begin - (declare-exporting name ... #:use-sources (pname ...)) - (defmodule*/no-declare (name ...) . content))] - [(_ (name ...) . content) - (defmodule* (name ...) #:use-sources () . content)])) - +(provide t) +(define (t . str) + (decode-paragraph str)) - (define-syntax-rule (defmodule name . content) - (defmodule* (name) . content)) - - (define-syntax-rule (defmodulelang*/no-declare (lang ...) . content) - (*defmodule (list (schememodname lang) ...) - #t - (list . content))) +(define (inset-flow . c) + (make-blockquote "insetpara" (flow-paragraphs (decode-flow c)))) - (define-syntax defmodulelang* - (syntax-rules () - [(_ (name ...) #:use-sources (pname ...) . content) - (begin - (declare-exporting name ... #:use-sources (pname ...)) - (defmodulelang*/no-declare (name ...) . content))] - [(_ (name ...) . content) - (defmodulelang* (name ...) #:use-sources () . content)])) +;; ---------------------------------------- - (define-syntax-rule (defmodulelang lang . content) - (defmodulelang* (lang) . content)) +(define (gen-absolute-tag) + `(abs ,(make-generated-tag))) - (define (*defmodule names lang? content) - (make-splice - (cons - (make-table - "defmodule" - (map (lambda (name) - (list - (make-flow - (list (make-paragraph - (if lang? - (list (hspace 1) - (hash-lang) - (hspace 1) - (make-defschememodname name)) - (list - (hspace 1) - (scheme (require #,(make-defschememodname name)))))))))) - names)) - (append - (map (lambda (name) - (make-part-tag-decl `(mod-path ,(element->string name)))) - names) - (flow-paragraphs (decode-flow content)))))) - - (define (make-defschememodname mn) - (let ([name-str (element->string mn)]) - (make-index-element #f - (list mn) - `(mod-path ,name-str) - (list name-str) - (list mn) - (make-module-path-index-desc)))) +(define-struct sig (id)) - (define (litchar . strs) - (unless (andmap string? strs) - (raise-type-error 'litchar "strings" strs)) - (let ([s (apply string-append - (map (lambda (s) (regexp-replace* "\n" s " ")) - strs))]) - (if (regexp-match? #rx"^ *$" s) - (make-element "schemeinputbg" (list (hspace (string-length s)))) - (let ([spaces (regexp-match-positions #rx"^ *" s)] - [end-spaces (regexp-match-positions #rx" *$" s)]) - (make-element - "schemeinputbg" - (list (hspace (cdar spaces)) - (make-element "schemeinput" (list (substring s (cdar spaces) (caar end-spaces)))) - (hspace (- (cdar end-spaces) (caar end-spaces))))))))) +(define (definition-site name stx-id form?) + (let ([sig (current-signature)]) + (if sig + (*sig-elem (sig-id sig) name) + (annote-exporting-library + (to-element (make-just-context name stx-id)))))) - (define (verbatim #:indent [i 0] s . more) - (define indent (if (zero? i) - values - (let ([hs (hspace i)]) (lambda (x) (cons hs x))))) - (define strs (regexp-split #rx"\n" (apply string-append s more))) - (define (str->elts str) - (let ([spaces (regexp-match-positions #rx"(?:^| ) +" str)]) - (if spaces - (list* (substring str 0 (caar spaces)) - (hspace (- (cdar spaces) (caar spaces))) - (str->elts (substring str (cdar spaces)))) - (list (make-element 'tt (list str)))))) - (define (make-line str) - (let* ([line (indent (str->elts str))] - [line (list (make-element 'tt line))]) - (list (make-flow (list (make-paragraph line)))))) - (make-table #f (map make-line strs))) +(define checkers (make-hash)) - (define-syntax indexed-scheme - (syntax-rules () - [(_ x) (add-scheme-index 'x (scheme x))])) - - (define (add-scheme-index s e) - (let ([k (cond - [(and (pair? s) - (eq? (car s) 'quote)) - (format "~s" (cadr s))] - [(string? s) s] - [else (format "~s" s)])]) - (index* (list k) (list e) e))) - - (define-syntax define-/form - (syntax-rules () - [(_ id base) - (define-syntax (id stx) - (syntax-case stx () - [(_ a) - (with-syntax ([ellipses (datum->syntax #'a - '(... ...))]) - #'(let ([ellipses #f]) - (base a)))]))])) - - (define-/form schemeblock0/form schemeblock0) - (define-/form schemeblock/form schemeblock) - (define-/form scheme/form scheme) - - (provide schemeblock SCHEMEBLOCK schemeblock/form - schemeblock0 SCHEMEBLOCK0 schemeblock0/form - schemeblockelem - schemeinput - schememod - schemeerror - scheme SCHEME scheme/form schemeresult schemeid schememodname - defmodule defmodule* defmodulelang defmodulelang* - defmodule*/no-declare defmodulelang*/no-declare - indexed-scheme - litchar - verbatim) - - (provide image image/plain onscreen menuitem defterm emph - schemefont schemevalfont schemeresultfont schemeidfont schemevarfont - schemeparenfont schemekeywordfont schememetafont schememodfont - filepath exec envvar Flag DFlag PFlag DPFlag - indexed-file indexed-envvar - link procedure - idefterm - inset-flow) - - ;; String String *-> Element - ;; an in-lined image, relative to the current directory - (define (image #:scale [scale 1.0] filename-relative-to-source . alt) - (make-element - (make-image-file filename-relative-to-source scale) - (decode-content alt))) - - (define (image/plain filename-relative-to-source . alt) - (make-element - (make-image-file filename-relative-to-source 1.0) - (decode-content alt))) - - (define (onscreen . str) - (make-element 'sf (decode-content str))) - (define (menuitem menu item) - (make-element 'sf (list menu "|" item))) - (define (emph . str) - (make-element 'italic (decode-content str))) - (define (defterm . str) - (make-element 'italic (decode-content str))) - (define (idefterm . str) - (let ([c (decode-content str)]) - (make-element 'italic c))) - (define (schemefont . str) - (apply tt str)) - (define (schemevalfont . str) - (make-element "schemevalue" (decode-content str))) - (define (schemeresultfont . str) - (make-element "schemeresult" (decode-content str))) - (define (schemeidfont . str) - (make-element "schemesymbol" (decode-content str))) - (define (schemevarfont . str) - (make-element "schemevariable" (decode-content str))) - (define (schemeparenfont . str) - (make-element "schemeparen" (decode-content str))) - (define (schememetafont . str) - (make-element "schememeta" (decode-content str))) - (define (schememodfont . str) - (make-element "schememod" (decode-content str))) - (define (schemekeywordfont . str) - (make-element "schemekeyword" (decode-content str))) - (define (filepath . str) - (make-element 'tt (append (list "\"") (decode-content str) (list "\"")))) - (define (indexed-file . str) - (let* ([f (apply filepath str)] - [s (element->string f)]) - (index* (list (substring s 1 (sub1 (string-length s)))) (list f) f))) - (define (exec . str) - (if (andmap string? str) - (make-element 'tt str) - (make-element #f (map (lambda (s) - (if (string? s) - (make-element 'tt (list s)) - s)) - str)))) - (define (Flag . str) - (make-element 'no-break (list (make-element 'tt (cons "-" (decode-content str)))))) - (define (DFlag . str) - (make-element 'no-break (list (make-element 'tt (cons "--" (decode-content str)))))) - (define (PFlag . str) - (make-element 'no-break (list (make-element 'tt (cons "+" (decode-content str)))))) - (define (DPFlag . str) - (make-element 'no-break (list (make-element 'tt (cons "++" (decode-content str)))))) - (define (envvar . str) - (make-element 'tt (decode-content str))) - (define (indexed-envvar . str) - (let* ([f (apply envvar str)] - [s (element->string f)]) - (index* (list s) (list f) f))) - (define (procedure . str) - (make-element "schemeresult" (append (list "#")))) - - (define (link url #:underline? [underline? #t] . str) - (make-element (make-target-url url (if underline? - #f - "plainlink")) - (decode-content str))) - - (define (schemeerror . str) - (make-element "schemeerror" (decode-content str))) - - (provide t) - (define (t . str) - (decode-paragraph str)) - - (define (inset-flow . c) - (make-blockquote - "insetpara" - (flow-paragraphs (decode-flow c)))) - - ;; ---------------------------------------- - - (define (gen-absolute-tag) - `(abs ,(make-generated-tag))) - - (define-struct sig (id)) - - (define (definition-site name stx-id form?) - (let ([sig (current-signature)]) - (if sig - (*sig-elem (sig-id sig) name) - (annote-exporting-library - (to-element (make-just-context name stx-id)))))) - - (define checkers (make-hash)) - - (define (libs->taglet id libs source-libs) - (let ([lib - (or (ormap (lambda (lib) - (let ([checker (hash-ref checkers lib - (lambda () - (let ([ns (make-base-empty-namespace)]) - (parameterize ([current-namespace ns]) - (namespace-require `(for-label ,lib))) - (let ([checker - (lambda (id) - (parameterize ([current-namespace ns]) - (let ([new-id (namespace-syntax-introduce - (datum->syntax - #f - (syntax-e id)))]) - (free-label-identifier=? new-id id))))]) - (hash-set! checkers lib checker) - checker))))]) - (and (checker id) - lib))) - (or source-libs - null)) - (and (pair? libs) - (car libs)))]) - (and lib - (let ([p (resolved-module-path-name - (module-path-index-resolve - (module-path-index-join lib #f)))]) - (if (path? p) +(define (libs->taglet id libs source-libs) + (let ([lib + (or (ormap (lambda (lib) + (let ([checker + (hash-ref + checkers lib + (lambda () + (let ([ns (make-base-empty-namespace)]) + (parameterize ([current-namespace ns]) + (namespace-require `(for-label ,lib))) + (let ([checker + (lambda (id) + (parameterize ([current-namespace + ns]) + (free-label-identifier=? + (namespace-syntax-introduce + (datum->syntax + #f + (syntax-e id))) + id)))]) + (hash-set! checkers lib checker) + checker))))]) + (and (checker id) lib))) + (or source-libs null)) + (and (pair? libs) (car libs)))]) + (and lib (let ([p (resolved-module-path-name + (module-path-index-resolve + (module-path-index-join lib #f)))]) + (if (path? p) (intern-taglet (path->main-collects-relative p)) p))))) - (define (id-to-target-maker id dep?) - (*id-to-target-maker 'def id dep?)) - - (define (id-to-form-target-maker id dep?) - (*id-to-target-maker 'form id dep?)) - - (define (*id-to-target-maker sym id dep?) - (let ([sig (current-signature)]) - (lambda (content mk) - (make-part-relative-element - (lambda (ci) - (let ([e (ormap (lambda (p) - (ormap (lambda (e) - (and (exporting-libraries? e) e)) - (part-to-collect p))) - (collect-info-parents ci))]) - (unless e - ;; Call raise-syntax-error to capture error message: - (with-handlers ([exn:fail:syntax? (lambda (exn) - (fprintf (current-error-port) - "~a\n" - (exn-message exn)))]) - (raise-syntax-error 'WARNING - "no declared exporting libraries for definition" - id))) - (if e - (let* ([lib-taglet (libs->taglet (if sig - (sig-id sig) - id) - (exporting-libraries-libs e) - (exporting-libraries-source-libs e))] - [tag (intern-taglet - (list (if sig - (case sym - [(def) 'sig-val] - [(form) 'sig-def]) - sym) - (append - (list lib-taglet) - (if sig (list (syntax-e (sig-id sig))) null) - (list (syntax-e id)))))]) - (if (or sig (not dep?)) - (list (mk tag)) - (list (make-target-element - #f - (list (mk tag)) - (intern-taglet `(dep ,(list lib-taglet (syntax-e id)))))))) - content))) - (lambda () (car content)) - (lambda () (car content)))))) - - - (define (make-binding-redirect-elements mod-path redirects) - (let ([taglet (path->main-collects-relative - (resolved-module-path-name - (module-path-index-resolve - (module-path-index-join mod-path #f))))]) - (make-element - #f - (map - (lambda (redirect) - (let ([id (car redirect)] - [form? (cadr redirect)] - [path (caddr redirect)] - [anchor (cadddr redirect)]) - (let ([make-one - (lambda (kind) - (make-redirect-target-element - #f - null - (intern-taglet (list kind (list taglet id))) - path - anchor))]) - (make-element - #f - (list (make-one (if form? 'form 'def)) - (make-one 'dep) - (make-index-element #f - null - (list (if form? 'form 'def) - (list taglet id)) - (list (symbol->string id)) - (list - (make-element - "schemesymbol" - (list - (make-element - (if form? - "schemesyntaxlink" - "schemevaluelink") - (list (symbol->string id)))))) - ((if form? - make-form-index-desc - make-procedure-index-desc) - id - (list mod-path)))))))) - redirects)))) - - (provide make-binding-redirect-elements) - - (define current-signature (make-parameter #f)) - - (define-syntax-rule (sigelem sig elem) - (*sig-elem (quote-syntax sig) 'elem)) - - (define (*sig-elem sig elem) - (let ([s (to-element/no-color elem)]) - (make-delayed-element - (lambda (renderer sec ri) - (let* ([tag (find-scheme-tag sec ri sig #f)] - [taglet (and tag (append (cadr tag) (list elem)))] - [vtag (and tag `(sig-val ,taglet))] - [stag (and tag `(sig-form ,taglet))] - [sd (and stag (resolve-get/tentative sec ri stag))]) - (list - (make-element - "schemesymbol" - (list - (cond - [sd - (make-link-element "schemesyntaxlink" (list s) stag)] - [vtag - (make-link-element "schemevaluelink" (list s) vtag)] - [else - s])))))) - (lambda () s) - (lambda () s)))) - - (provide sigelem) - - ;; ---------------------------------------- - - (provide method xmethod (rename-out [method ::])) - - (define-syntax method - (syntax-rules () - [(_ a b) - (*method 'b (quote-syntax a))])) - - (define-syntax xmethod - (syntax-rules () - [(_ a b) - (elem (method a b) " in " (scheme a))])) - - (define (*method sym id) - (**method sym id)) - - (define (**method sym id/tag) - (let ([content (list (symbol->string sym))]) - ((if (identifier? id/tag) - (lambda (c mk) - (make-delayed-element - (lambda (ren p ri) - (let ([tag (find-scheme-tag p ri id/tag #f)]) - (if tag - (list (mk tag)) - content))) - (lambda () (car content)) - (lambda () (car content)))) - (lambda (c mk) (mk id/tag))) - content - (lambda (tag) - (make-element - "schemesymbol" - (list (make-link-element - "schemevaluelink" - content - (method-tag tag sym)))))))) - - (define (method-tag vtag sym) - (list 'meth - (list (cadr vtag) sym))) - - ;; ---------------------------------------- - - (provide margin-note) - - (define (margin-note . c) - (make-styled-paragraph (list (make-element "refcolumn" - (list - (make-element "refcontent" - (decode-content c))))) - "refpara")) - - ;; ---------------------------------------- - - (provide deftech tech techlink) - - (define (*tech make-elem style doc s) - (let* ([c (decode-content s)] - [s (regexp-replace* #px"[-\\s]+" - (regexp-replace - #rx"s$" - (regexp-replace - #rx"ies$" - (string-foldcase (content->string c)) - "y") - "") - " ")]) - (make-elem style - c - (list 'tech (doc-prefix doc s))))) - - (define (deftech . s) - (let* ([e (apply defterm s)] - [t (*tech make-target-element #f #f (list e))]) - (make-index-element #f - (list t) - (target-element-tag t) - (list (element->string e)) - (list e) - 'tech))) - - (define (tech #:doc [doc #f] . s) - (*tech make-link-element "techlink" doc s)) - - (define (techlink #:doc [doc #f] . s) - (*tech make-link-element #f doc s)) - - ;; ---------------------------------------- - - (provide declare-exporting - deftogether - defproc defproc* defstruct - defthing defthing* defthing/proc - defparam defparam* defboolparam - defform defform* defform/subs defform*/subs defform/none - defidform - specform specform/subs - specsubform specsubform/subs specspecsubform specspecsubform/subs specsubform/inline - defsubform defsubform* - schemegrammar schemegrammar* - var svar void-const undefined-const) - - (define-syntax (declare-exporting stx) - (syntax-case stx () - [(_ lib ... #:use-sources (plib ...)) - (let ([libs (syntax->list #'(lib ... plib ...))]) - (for-each (lambda (l) - (unless (module-path? (syntax->datum l)) - (raise-syntax-error #f - "not a module path" - stx - l))) - libs) - (when (null? libs) - (raise-syntax-error #f - "need at least one module path" - stx)) - #'(*declare-exporting '(lib ...) '(plib ...)))] - [(_ lib ...) #'(*declare-exporting '(lib ...) '())])) - - (define-struct (exporting-libraries element) (libs source-libs)) - - (define (*declare-exporting libs source-libs) - (make-splice - (list - (make-part-collect-decl - (make-collect-element #f - null - (lambda (ri) - (collect-put! ri '(exporting-libraries #f) - libs)))) - (make-part-collect-decl - (make-exporting-libraries #f null (and (pair? libs) libs) source-libs))))) - - (define-syntax (quote-syntax/loc stx) - (syntax-case stx () - [(_ id) - (with-syntax ([loc - (let ([s #'id]) - (vector (syntax-source s) - (syntax-line s) - (syntax-column s) - (syntax-position s) - (syntax-span s)))]) - #'(let ([s (*quote-syntax/loc id)]) - (datum->syntax s - (syntax-e s) - 'loc - s)))])) - - (define-syntax *quote-syntax/loc - (syntax-rules () - [(_ (sub ...)) (datum->syntax #f (list (quote-syntax/loc sub) ...))] - [(_ id) (quote-syntax id)])) - - (define void-const - (schemeresultfont "#")) - (define undefined-const - (schemeresultfont "#")) - - (define dots0 - (make-element "schememeta" (list "..."))) - (define dots1 - (make-element "schememeta" (list "...+"))) - - (define-syntax (arg-contract stx) - (syntax-case stx (... ...+ _...superclass-args...) - [(_ [id contract]) - (identifier? #'id) - #'(schemeblock0 contract)] - [(_ [id contract val]) - (identifier? #'id) - #'(schemeblock0 contract)] - [(_ [kw id contract]) - (and (keyword? (syntax-e #'kw)) - (identifier? #'id)) - #'(schemeblock0 contract)] - [(_ [kw id contract val]) - (and (keyword? (syntax-e #'kw)) - (identifier? #'id)) - #'(schemeblock0 contract)] - [(_ (... ...)) - #'#f] - [(_ (... ...+)) - #'#f] - [(_ _...superclass-args...) - #'#f] - [(_ arg) - (raise-syntax-error - 'defproc - "bad argument form" - #'arg)])) - - (define-syntax (arg-default stx) - (syntax-case stx (... ...+ _...superclass-args...) - [(_ [id contract]) - (identifier? #'id) - #'#f] - [(_ [id contract val]) - (identifier? #'id) - #'(schemeblock0 val)] - [(_ [kw id contract]) - (keyword? (syntax-e #'kw)) - #'#f] - [(_ [kw id contract val]) - (keyword? (syntax-e #'kw)) - #'(schemeblock0 val)] - [else - #'#f])) - - (define-syntax (extract-proc-id stx) - (syntax-case stx () - [(_ id) - (identifier? #'id) - #`(quote-syntax/loc id)] - [(_ (proto arg ...)) - #'(extract-proc-id proto)] - [(_ thing) - (raise-syntax-error - 'defproc - "bad prototype" - #'thing)])) - - (define-syntax (arg-contracts stx) - (syntax-case stx () - [(_ id arg ...) - (identifier? #'id) - #'(list (lambda () (arg-contract arg)) ...)] - [(_ (proto arg1 ...) arg ...) - #'(arg-contracts proto arg1 ... arg ...)] - [_ - (raise-syntax-error 'defproc "bad prototype" stx)])) - - (define-syntax (arg-defaults stx) - (syntax-case stx () - [(_ id arg ...) - (identifier? #'id) - #'(list (lambda () (arg-default arg)) ...)] - [(_ (proto arg1 ...) arg ...) - #'(arg-defaults proto arg1 ... arg ...)] - [_ - (raise-syntax-error 'defproc "bad prototype" stx)])) - - (define-syntax (result-contract stx) - (syntax-case stx (values) - [(_ (values c ...)) - #'(list (schemeblock0 c) ...)] - [(_ c) - (if (string? (syntax-e #'c)) - (raise-syntax-error - 'defproc - "expected a result contract, found a string" - #'c) - #'(schemeblock0 c))])) - - (define-syntax defproc - (syntax-rules () - [(_ (id arg ...) result desc ...) - (defproc* [[(id arg ...) result]] desc ...)])) - (define-syntax defproc* - (syntax-rules () - [(_ [[proto result] ...] desc ...) - (defproc* #:mode procedure #:within #f [[proto result] ...] desc ...)] - [(_ #:mode m #:within cl [[proto result] ...] desc ...) - (*defproc 'm (quote-syntax/loc cl) - (list (extract-proc-id proto) ...) - '[proto ...] - (list (arg-contracts proto) ...) - (list (arg-defaults proto) ...) - (list (lambda () (result-contract result)) ...) - (lambda () (list desc ...)))])) - (define-syntax defstruct - (syntax-rules () - [(_ name fields #:mutable #:inspector #f desc ...) - (**defstruct name fields #f #t desc ...)] - [(_ name fields #:mutable #:transparent desc ...) - (**defstruct name fields #f #t desc ...)] - [(_ name fields #:mutable desc ...) - (**defstruct name fields #f #f desc ...)] - [(_ name fields #:inspector #f desc ...) - (**defstruct name fields #t #t desc ...)] - [(_ name fields #:transparent desc ...) - (**defstruct name fields #t #t desc ...)] - [(_ name fields desc ...) - (**defstruct name fields #t #f desc ...)])) - (define-syntax **defstruct - (syntax-rules () - [(_ name ([field field-contract] ...) immutable? transparent? desc ...) - (*defstruct (quote-syntax/loc name) 'name - '([field field-contract] ...) (list (lambda () (schemeblock0 field-contract)) ...) - immutable? transparent? (lambda () (list desc ...)))])) - (define-syntax (defform*/subs stx) - (syntax-case stx () - [(_ #:id defined-id #:literals (lit ...) [spec spec1 ...] ([non-term-id non-term-form ...] ...) desc ...) - (with-syntax ([new-spec - (let loop ([spec #'spec]) - (if (and (identifier? spec) - (free-identifier=? spec #'defined-id)) - (datum->syntax #'here - '(unsyntax x) - spec - spec) - (syntax-case spec () - [(a . b) - (datum->syntax spec - (cons (loop #'a) - (loop #'b)) - spec - spec)] - [_ spec])))]) - #'(*defforms (quote-syntax/loc defined-id) '(lit ...) - '(spec spec1 ...) - (list (lambda (x) (schemeblock0/form new-spec)) - (lambda (ignored) (schemeblock0/form spec1)) ...) - '((non-term-id non-term-form ...) ...) - (list (list (lambda () (scheme non-term-id)) - (lambda () (schemeblock0/form non-term-form)) - ...) - ...) - (lambda () (list desc ...))))] - [(fm #:id id [spec spec1 ...] ([non-term-id non-term-form ...] ...) desc ...) - #'(fm #:id id #:literals () [spec spec1 ...] ([non-term-id non-term-form ...] ...) desc ...)] - [(fm #:literals lits [(spec-id . spec-rest) spec1 ...] ([non-term-id non-term-form ...] ...) desc ...) - (with-syntax ([(_ _ _ [spec . _] . _) stx]) - #'(fm #:id spec-id #:literals lits [spec spec1 ...] ([non-term-id non-term-form ...] ...) desc ...))] - [(fm [spec spec1 ...] ([non-term-id non-term-form ...] ...) desc ...) - #'(fm #:literals () [spec spec1 ...] ([non-term-id non-term-form ...] ...) desc ...)])) - (define-syntax (defform* stx) - (syntax-case stx () - [(_ #:id id #:literals lits [spec ...] desc ...) #'(defform*/subs #:id id #:literals lits [spec ...] () desc ...)] - [(_ #:literals lits [spec ...] desc ...) #'(defform*/subs #:literals lits [spec ...] () desc ...)] - [(_ [spec ...] desc ...) #'(defform*/subs [spec ...] () desc ...)])) - (define-syntax (defform stx) - (syntax-case stx () - [(_ #:id id #:literals (lit ...) spec desc ...) #'(defform*/subs #:id id #:literals (lit ...) [spec] () desc ...)] - [(_ #:id id spec desc ...) #'(defform*/subs #:id id #:literals () [spec] () desc ...)] - [(_ #:literals (lit ...) spec desc ...) #'(defform*/subs #:literals (lit ...) [spec] () desc ...)] - [(_ spec desc ...) #'(defform*/subs [spec] () desc ...)])) - (define-syntax (defform/subs stx) - (syntax-case stx () - [(_ #:id id #:literals lits spec subs desc ...) #'(defform*/subs #:id id #:literals lits [spec] subs desc ...)] - [(_ #:id id spec subs desc ...) #'(defform*/subs #:id id #:literals () [spec] subs desc ...)] - [(_ #:literals lits spec subs desc ...) #'(defform*/subs #:literals lits [spec] subs desc ...)] - [(_ spec subs desc ...) #'(defform*/subs [spec] subs desc ...)])) - (define-syntax (defform/none stx) - (syntax-case stx () - [(_ #:literals (lit ...) spec desc ...) - #'(*defforms #f '(lit ...) - '(spec) (list (lambda (ignored) (schemeblock0/form spec))) - null null - (lambda () (list desc ...)))] - [(_ spec desc ...) - #'(defform/none #:literals () spec desc ...)])) - (define-syntax (defidform stx) - (syntax-case stx () - [(_ spec-id desc ...) - #'(*defforms (quote-syntax/loc spec-id) null - '(spec-id) - (list (lambda (x) (make-paragraph (list x)))) - null - null - (lambda () (list desc ...)))])) - (define-syntax (defsubform stx) - (syntax-case stx () - [(_ . rest) #'(into-blockquote (defform . rest))])) - (define-syntax (defsubform* stx) - (syntax-case stx () - [(_ . rest) #'(into-blockquote (defform* . rest))])) - (define-syntax specsubform - (syntax-rules () - [(_ #:literals (lit ...) spec desc ...) - (*specsubform 'spec #f '(lit ...) (lambda () (schemeblock0/form spec)) null null (lambda () (list desc ...)))] - [(_ spec desc ...) - (*specsubform 'spec #f null (lambda () (schemeblock0/form spec)) null null (lambda () (list desc ...)))])) - (define-syntax specsubform/subs - (syntax-rules () - [(_ #:literals (lit ...) spec ([non-term-id non-term-form ...] ...) desc ...) - (*specsubform 'spec #f '(lit ...) (lambda () (schemeblock0/form spec)) - '((non-term-id non-term-form ...) ...) - (list (list (lambda () (scheme non-term-id)) - (lambda () (schemeblock0/form non-term-form)) - ...) - ...) - (lambda () (list desc ...)))] - [(_ spec subs desc ...) - (specsubform/subs #:literals () spec subs desc ...)])) - (define-syntax specspecsubform - (syntax-rules () - [(_ spec desc ...) - (make-blockquote "leftindent" (list (specsubform spec desc ...)))])) - (define-syntax specspecsubform/subs - (syntax-rules () - [(_ spec subs desc ...) - (make-blockquote "leftindent" (list (specsubform/subs spec subs desc ...)))])) - (define-syntax specform - (syntax-rules () - [(_ #:literals (lit ...) spec desc ...) - (*specsubform 'spec #t '(lit ...) (lambda () (schemeblock0/form spec)) null null (lambda () (list desc ...)))] - [(_ spec desc ...) - (*specsubform 'spec #t null (lambda () (schemeblock0/form spec)) null null (lambda () (list desc ...)))])) - (define-syntax specform/subs - (syntax-rules () - [(_ #:literals (lit ...) spec ([non-term-id non-term-form ...] ...) desc ...) - (*specsubform 'spec #t - '(lit ...) - (lambda () (schemeblock0/form spec)) - '((non-term-id non-term-form ...) ...) - (list (list (lambda () (scheme non-term-id)) - (lambda () (schemeblock0/form non-term-form)) - ...) - ...) - (lambda () (list desc ...)))] - [(_ spec ([non-term-id non-term-form ...] ...) desc ...) - (specform/subs #:literals () spec ([non-term-id non-term-form ...] ...) desc ...)])) - (define-syntax specsubform/inline - (syntax-rules () - [(_ spec desc ...) - (*specsubform 'spec #f null #f null null (lambda () (list desc ...)))])) - (define-syntax defthing - (syntax-rules () - [(_ id result desc ...) - (*defthing (list (quote-syntax/loc id)) (list 'id) #f (list (schemeblock0 result)) - (lambda () (list desc ...)))])) - (define-syntax defthing* - (syntax-rules () - [(_ ([id result] ...) desc ...) - (*defthing (list (quote-syntax/loc id) ...) (list 'id ...) #f (list (schemeblock0 result) ...) - (lambda () (list desc ...)))])) - (define-syntax defparam - (syntax-rules () - [(_ id arg contract desc ...) - (defproc* ([(id) contract] [(id [arg contract]) void?]) desc ...)])) - (define-syntax defparam* - (syntax-rules () - [(_ id arg in-contract out-contract desc ...) - (defproc* ([(id) out-contract] [(id [arg in-contract]) void?]) desc ...)])) - (define-syntax defboolparam - (syntax-rules () - [(_ id arg desc ...) - (defproc* ([(id) boolean?] [(id [arg any/c]) void?]) desc ...)])) - (define-syntax schemegrammar - (syntax-rules () - [(_ #:literals (lit ...) id clause ...) (*schemegrammar '(lit ...) - '(id clause ...) - (lambda () (list (list (scheme id) (schemeblock0/form clause) ...))))] - [(_ id clause ...) (schemegrammar #:literals () id clause ...)])) - (define-syntax schemegrammar* - (syntax-rules () - [(_ #:literals (lit ...) [id clause ...] ...) (*schemegrammar '(lit ...) - '(id ... clause ... ...) - (lambda () - (list - (list (scheme id) (schemeblock0/form clause) ...) ...)))] - [(_ [id clause ...] ...) (schemegrammar #:literals () [id clause ...] ...)])) - (define-syntax var - (syntax-rules () - [(_ id) (*var 'id)])) - (define-syntax svar - (syntax-rules () - [(_ id) (*var 'id)])) - - (define (defthing/proc id contract descs) - (*defthing (list id) (list (syntax-e id)) #f (list contract) - (lambda () descs))) - - (define (into-blockquote s) - (cond - [(splice? s) - (make-blockquote "leftindent" (flow-paragraphs (decode-flow (splice-run s))))] - [else - (make-blockquote "leftindent" (list s))])) - - (define (make-table-if-necessary style content) - (if (= 1 (length content)) - (let ([paras (apply append (map flow-paragraphs (car content)))]) - (if (andmap paragraph? paras) - (list (make-paragraph (apply append (map paragraph-content paras)))) - (list (make-table style content)))) - (list (make-table style content)))) - - (define max-proto-width 65) - - (define (name-this-object type-sym) - (to-element - (string->symbol - (regexp-replace - #rx"(%|<%>|-mixin)$" - (format "_a~a-~s" - (if (member - (string-ref (symbol->string type-sym) 0) - '(#\a #\e #\i #\o #\u)) - "n" - "") - type-sym) - "")))) - - (define (annote-exporting-library e) - (make-delayed-element - (lambda (render p ri) - (let ([from (resolve-get/tentative p ri '(exporting-libraries #f))]) - (if (and from - (pair? from)) - (list (make-hover-element - #f - (list e) - (intern-taglet - (string-append - "Provided from: " - (let loop ([from from]) - (if (null? (cdr from)) - (format "~s" (car from)) - (format "~s, ~a" - (car from) - (loop (cdr from))))))))) - (list e)))) - (lambda () e) - (lambda () e))) - - (define (get-exporting-libraries render p ri) - (resolve-get/tentative p ri '(exporting-libraries #f))) - - (define (with-exporting-libraries proc) - (make-delayed-index-desc - (lambda (render part ri) - (proc - (or (get-exporting-libraries render part ri) null))))) - - (define-struct (box-splice splice) (var-list)) - - (define (*deftogether boxes body-thunk) - (make-splice - (cons - (make-table - 'boxed - (map (lambda (box) - (unless (and (box-splice? box) - (= 1 (length (splice-run box))) - (table? (car (splice-run box))) - (eq? 'boxed (table-style (car (splice-run box))))) - (error 'deftogether "element is not a boxing splice containing a single table: ~e" box)) - (list (make-flow (list (make-table "together" (table-flowss (car (splice-run box)))))))) - boxes)) - (parameterize ([current-variable-list - (apply append (map box-splice-var-list boxes))]) - (body-thunk))))) - - (define-syntax-rule (deftogether (box ...) . body) - (*deftogether (list box ...) (lambda () (list . body)))) - - (define-struct arg (special? kw id optional? starts-optional? ends-optional? num-closers)) - - (define (*defproc mode within-id - stx-ids prototypes arg-contractss arg-valss result-contracts content-thunk) - (let ([spacer (hspace 1)] - [has-optional? (lambda (arg) - (and (pair? arg) - ((length arg) . > . (if (keyword? (car arg)) - 3 - 2))))] - [to-flow (lambda (e) - (make-flow (list (make-paragraph (list e)))))] - [arg->elem (lambda (show-opt-start?) - (lambda (arg) - (let* ([e (cond - [(not (arg-special? arg)) - (if (arg-kw arg) - (if (eq? mode 'new) - (make-element #f (list (schemeparenfont "[") - (schemeidfont (keyword->string (arg-kw arg))) - (hspace 1) - (to-element (arg-id arg)) - (schemeparenfont "]"))) - (make-element #f (list (to-element (arg-kw arg)) - (hspace 1) - (to-element (arg-id arg))))) - (to-element (arg-id arg)))] - [(eq? (arg-id arg) '...+) - dots1] - [(eq? (arg-id arg) '...) - dots0] - [else (to-element (arg-id arg))])] - [e (if (arg-ends-optional? arg) - (make-element #f (list e "]")) - e)] - [e (if (zero? (arg-num-closers arg)) - e - (make-element #f - (list e - (schemeparenfont (make-string (arg-num-closers arg) #\))))))]) - (if (and show-opt-start? - (arg-starts-optional? arg)) - (make-element #f (list "[" e)) - e))))] - [prototype-depth (lambda (p) - (let loop ([p (car p)]) - (if (symbol? p) - 0 - (+ 1 (loop (car p))))))] - [prototype-args (lambda (p) - (let ([parse-arg (lambda (v in-optional? depth next-optional? next-special-dots?) - (let* ([id (if (pair? v) - (if (keyword? (car v)) - (cadr v) - (car v)) - v)] - [kw (if (and (pair? v) - (keyword? (car v))) - (car v) - #f)] - [default? (and (pair? v) - (let ([p (if kw - (cdddr v) - (cddr v))]) - (pair? p)))]) - (make-arg (symbol? v) - kw - id - default? - (and default? - (not in-optional?)) - (or (and (not default?) - in-optional?) ; => must be special - (and default? - (not next-optional?) - (not next-special-dots?))) - depth)))]) - (let loop ([p p][last-depth 0]) - (append (if (symbol? (car p)) - null - (loop (car p) (add1 last-depth))) - (let loop ([p (cdr p)][in-optional? #f]) - (cond - [(null? p) null] - [(null? (cdr p)) - (list (parse-arg (car p) - in-optional? - last-depth - #f - #f))] - [else - (let ([a (parse-arg (car p) - in-optional? - 0 - (let ([v (cadr p)]) - (and (pair? v) - (not - (null? - ((if (keyword? (car v)) - cdddr - cddr) - v))))) - (and (not (pair? (cadr p))) - (not (eq? '_...superclass-args... (cadr p)))))]) - (cons a - (loop (cdr p) - (and (arg-optional? a) - (not (arg-ends-optional? a))))))]))))))] - [prototype-size (lambda (args first-combine next-combine special-combine?) - (let loop ([s args][combine first-combine]) - (if (null? s) - 0 - (combine - (loop (cdr s) next-combine) - (let ([a (car s)]) - (+ (arg-num-closers a) - (cond - [(arg-special? a) - (string-length (symbol->string (arg-id a)))] - [else - (+ (if (arg-kw a) - (+ (if (eq? mode 'new) 2 0) - (string-length (keyword->string (arg-kw a))) - 3 - (string-length (symbol->string (arg-id a)))) - (string-length (symbol->string (arg-id a)))) - (if (and special-combine? - (pair? (cdr s)) - (arg-special? (cadr s)) - (not (eq? '_...superclass-args... (arg-id (cadr s))))) - (+ 1 (string-length (symbol->string (arg-id (cadr s))))) - 0))])))))))] - [extract-id (lambda (p) - (let loop ([p p]) - (if (symbol? (car p)) - (car p) - (loop (car p)))))]) - (let* ([all-args (map prototype-args prototypes)] - [var-list (filter values - (map (lambda (a) - (and (not (arg-special? a)) - (arg-id a))) - (apply append all-args)))]) - (parameterize ([current-variable-list var-list]) - (make-box-splice - (cons - (make-table - 'boxed - (apply - append - (map - (lambda (stx-id prototype args arg-contracts arg-vals result-contract first?) - (let*-values ([(tagged) (cond - [(eq? mode 'new) - (make-element #f - (list (scheme new) - (hspace 1) - (to-element within-id)))] - [(eq? mode 'make) - (make-element #f - (list (scheme make-object) - (hspace 1) - (to-element within-id)))] - [(eq? mode 'send) - (make-element #f - (list (scheme send) - (hspace 1) - (name-this-object (syntax-e within-id)) - (hspace 1) - (if first? - (let* ([mname (extract-id prototype)] - [target-maker (id-to-target-maker within-id #f)] - [content (list (*method mname within-id))]) - (if target-maker - (target-maker - content - (lambda (ctag) - (let ([tag (method-tag ctag mname)]) - (make-toc-target-element - #f - (list (make-index-element #f - content - tag - (list (symbol->string mname)) - content - (with-exporting-libraries - (lambda (libs) - (make-method-index-desc - (syntax-e within-id) - libs - mname - ctag))))) - tag)))) - (car content))) - (*method (extract-id prototype) within-id))))] - [else - (if first? - (let ([target-maker (id-to-target-maker stx-id #t)] - [content (list (definition-site (extract-id prototype) stx-id #f))]) - (if target-maker - (target-maker - content - (lambda (tag) - (make-toc-target-element - #f - (list (make-index-element #f - content - tag - (list (symbol->string (extract-id prototype))) - content - (with-exporting-libraries - (lambda (libs) - (make-procedure-index-desc - (extract-id prototype) - libs))))) - tag))) - (car content))) - (annote-exporting-library - (let ([sig (current-signature)]) - (if sig - (*sig-elem (sig-id sig) (extract-id prototype)) - (to-element (make-just-context (extract-id prototype) - stx-id))))))])] - [(flat-size) (+ (prototype-size args + + #f) - (prototype-depth prototype) - (element-width tagged))] - [(short?) (or (flat-size . < . 40) - ((length args) . < . 2))] - [(res) (let ([res (result-contract)]) - (if (list? res) - ;; multiple results - (if (null? res) - 'nbsp - (let ([w (apply + (map block-width res))]) - (if (or (ormap table? res) - (w . > . 40)) - (make-table - #f - (map (lambda (fe) - (list (make-flow (list fe)))) - res)) - (make-table - #f - (list - (let loop ([res res]) - (if (null? (cdr res)) - (list (make-flow (list (car res)))) - (list* (make-flow (list (car res))) - (to-flow (hspace 1)) - (loop (cdr res)))))))))) - res))] - [(tagged+arg-width) (+ (prototype-size args max max #t) - (prototype-depth prototype) - (element-width tagged))] - [(result-next-line?) ((+ (if short? - flat-size - tagged+arg-width) - (block-width res)) - . >= . (- max-proto-width 7))] - [(end) (list (to-flow spacer) - (to-flow 'rarr) - (to-flow spacer) - (make-flow (list res)))]) - (append - (list - (list (make-flow - (if short? - ;; The single-line case: - (make-table-if-necessary - "prototype" - (list - (cons - (to-flow - (make-element - #f - (append - (list - (schemeparenfont (make-string (add1 (prototype-depth prototype)) #\()) - tagged) - (if (null? args) - (list - (schemeparenfont (make-string (prototype-depth prototype) #\)))) - (apply - append - (map - (lambda (arg) - (list - spacer - ((arg->elem #t) arg))) - args))) - (list (schemeparenfont ")"))))) - (if result-next-line? - null - end)))) - ;; The multi-line case: - (let ([not-end - (if result-next-line? - (list (to-flow spacer)) - (list (to-flow spacer) - (to-flow spacer) - (to-flow spacer) - (to-flow spacer)))] - [one-ok? (tagged+arg-width . < . 60)]) - (list - (make-table - "prototype" - (cons - (cons (to-flow (make-element - #f - (list - (schemeparenfont (make-string (add1 (prototype-depth prototype)) #\()) - tagged))) - (if one-ok? - (list* - (cond - [(arg-starts-optional? (car args)) - (to-flow (make-element #f (list spacer "[")))] - [else - (to-flow spacer)]) - (to-flow - ((arg->elem #f) (car args))) - not-end) - (list* 'cont 'cont not-end))) - (let loop ([args (if one-ok? - (cdr args) - args)]) - (if (null? args) - null - (let ([dots-next? (or (and (pair? (cdr args)) - (arg-special? (cadr args)) - (not (eq? '_...superclass-args... (arg-id (cadr args))))))]) - (cons (list* (to-flow spacer) - (if (arg-starts-optional? (car args)) - (to-flow (make-element #f (list spacer "["))) - (to-flow spacer)) - (let ([a ((arg->elem #f) (car args))] - [next (if dots-next? - (make-element #f (list (hspace 1) - ((arg->elem #f) (cadr args)))) - "")]) - (to-flow - (cond - [(null? ((if dots-next? cddr cdr) args)) - (make-element - #f - (list a next (schemeparenfont ")")))] - [(equal? next "") a] - [else - (make-element #f (list a next))]))) - (if (and (null? ((if dots-next? cddr cdr) args)) - (not result-next-line?)) - end - not-end)) - (loop ((if dots-next? cddr cdr) args)))))))))))))) - (if result-next-line? - (list (list (make-flow (make-table-if-necessary - "prototype" - (list end))))) - null) - (apply append - (map (lambda (arg arg-contract arg-val) - (cond - [(not (arg-special? arg)) - (let* ([arg-cont (arg-contract)] - [base-len (+ 5 (string-length (symbol->string (arg-id arg))) - (block-width arg-cont))] - [arg-val (and arg-val (arg-val))] - [def-len (if (arg-optional? arg) - (block-width arg-val) - 0)] - [base-list - (list - (to-flow (hspace 2)) - (to-flow (to-element (arg-id arg))) - (to-flow spacer) - (to-flow ":") - (to-flow spacer) - (make-flow (list arg-cont)))]) - (list - (list - (make-flow - (if (and (arg-optional? arg) - ((+ base-len 3 def-len) . >= . max-proto-width)) - (list - (make-table - "argcontract" - (list - base-list - (list - (to-flow spacer) - (to-flow spacer) - (to-flow spacer) - (to-flow "=") - (to-flow spacer) - (make-flow (list arg-val)))))) - (make-table-if-necessary - "argcontract" - (list - (append - base-list - (if (and (arg-optional? arg) - ((+ base-len 3 def-len) . < . max-proto-width)) - (list (to-flow spacer) - (to-flow "=") - (to-flow spacer) - (make-flow (list arg-val))) - null)))))))))] - [else null])) - args - arg-contracts - arg-vals))))) - stx-ids - prototypes - all-args - arg-contractss - arg-valss - result-contracts - (let loop ([ps prototypes][accum null]) - (cond - [(null? ps) null] - [(ormap (lambda (a) (eq? (extract-id (car ps)) a)) accum) - (cons #f (loop (cdr ps) accum))] - [else - (cons #t (loop (cdr ps) - (cons (extract-id (car ps)) accum)))]))))) - (content-thunk)) - var-list))))) - - (define (make-target-element* inner-make-target-element stx-id content wrappers) - (if (null? wrappers) - content - (make-target-element* - make-target-element - stx-id - (let* ([name - (apply string-append - (map symbol->string (cdar wrappers)))] - [target-maker - (id-to-target-maker - (datum->syntax stx-id - (string->symbol - name)) - #t)]) - (if target-maker - (target-maker - (list content) - (lambda (tag) - (inner-make-target-element - #f - (list - (make-index-element #f - (list content) - tag - (list name) - (list (schemeidfont (make-element "schemevaluelink" (list name)))) - (with-exporting-libraries - (lambda (libs) - (let ([name (string->symbol name)]) - (if (eq? 'info (caar wrappers)) - (make-struct-index-desc name libs) - (make-procedure-index-desc name libs))))))) - tag))) - content)) - (cdr wrappers)))) - - (define (*defstruct stx-id name fields field-contracts immutable? transparent? content-thunk) - (define spacer (hspace 1)) - (define to-flow (lambda (e) (make-flow (list (make-paragraph (list e)))))) - (define (field-name f) (if (pair? (car f)) - (caar f) - (car f))) - (define (field-view f) (if (pair? (car f)) - (make-shaped-parens (car f) #\[) - (car f))) - (make-box-splice - (cons - (make-table - 'boxed - (cons - (list (make-flow - (list - (let* ([the-name - (let ([just-name - (make-target-element* - make-toc-target-element - (if (pair? name) - (car (syntax-e stx-id)) - stx-id) - (annote-exporting-library - (to-element (if (pair? name) - (make-just-context (car name) (car (syntax-e stx-id))) - stx-id))) - (let ([name (if (pair? name) - (car name) - name)]) - (list* (list 'info name) - (list 'type 'struct: name) - (list 'predicate name '?) - (list 'constructor 'make- name) - (append - (map (lambda (f) - (list 'accessor name '- (field-name f))) - fields) - (filter - values - (map (lambda (f) - (if (or (not immutable?) - (and (pair? (car f)) - (memq '#:mutable (car f)))) - (list 'mutator 'set- name '- (field-name f) '!) - #f)) - fields))))))]) - (if (pair? name) - (to-element (list just-name - (make-just-context (cadr name) - (cadr (syntax-e stx-id))))) - just-name))] - [short-width (apply + - (length fields) - 8 - (append - (map (lambda (s) - (string-length (symbol->string s))) - (append (if (pair? name) - name - (list name)) - (map field-name fields))) - (map (lambda (f) - (if (pair? (car f)) - (+ 3 2 (string-length (keyword->string (cadar f)))) - 0)) - fields)))]) - (if (and (short-width . < . max-proto-width) - (not immutable?) - (not transparent?)) - (make-paragraph - (list - (to-element - `(,(schemeparenfont "struct") - ,the-name - ,(map field-view fields))))) - (make-table - #f - (append - (list - (list (to-flow (schemeparenfont "(struct")) - (to-flow spacer) - (to-flow the-name) - (if (or (null? fields) - (short-width . < . max-proto-width)) - (to-flow spacer) - (to-flow (make-element #f - (list spacer - (schemeparenfont "("))))) - (to-flow (if (or (null? fields) - (short-width . < . max-proto-width)) - (make-element #f (list (to-element (map field-view fields)) - (schemeparenfont ")"))) - (to-element (field-view (car fields))))))) - (if (short-width . < . max-proto-width) - null - (let loop ([fields (if (null? fields) fields (cdr fields))]) - (if (null? fields) - null - (cons (let ([fld (car fields)]) - (list (to-flow spacer) - (to-flow spacer) - (to-flow spacer) - (to-flow spacer) - (to-flow - (let ([e (to-element (field-view fld))]) - (if (null? (cdr fields)) - (make-element - #f - (list e - (schemeparenfont - (if (and immutable? - (not transparent?)) - "))" - ")")))) - e))))) - (loop (cdr fields)))))) - (cond - [(and (not immutable?) transparent?) - (list - (list (to-flow spacer) - (to-flow spacer) - (to-flow (to-element '#:mutable)) - 'cont - 'cont) - (list (to-flow spacer) - (to-flow spacer) - (to-flow (make-element - #f - (list (to-element '#:transparent) - (schemeparenfont ")")))) - 'cont - 'cont))] - [(not immutable?) - (list - (list (to-flow spacer) - (to-flow spacer) - (to-flow (make-element - #f - (list (to-element '#:mutable) - (schemeparenfont ")")))) - 'cont - 'cont))] - [transparent? - (list - (list (to-flow spacer) - (to-flow spacer) - (to-flow (make-element - #f - (list (to-element '#:transparent) - (schemeparenfont ")")))) - 'cont - 'cont))] - [else null])))))))) - (map (lambda (v field-contract) - (cond - [(pair? v) - (list - (make-flow - (make-table-if-necessary - "argcontract" - (list - (list (to-flow (hspace 2)) - (to-flow (to-element (field-name v))) - (to-flow spacer) - (to-flow ":") - (to-flow spacer) - (make-flow (list (field-contract))))))))] - [else null])) - fields field-contracts))) - (content-thunk)) - null)) - - (define (*defthing stx-ids names form? result-contracts content-thunk) - (define spacer (hspace 1)) - (make-box-splice - (cons - (make-table - 'boxed - (map (lambda (stx-id name result-contract) - (list - (make-flow - (make-table-if-necessary - "argcontract" - (list - (list (make-flow - (list - (make-paragraph - (list (let ([target-maker ((if form? id-to-form-target-maker id-to-target-maker) stx-id #t)] - [content (list (definition-site name stx-id form?))]) - (if target-maker - (target-maker - content - (lambda (tag) - (make-toc-target-element - #f - (list - (make-index-element #f - content - tag - (list (symbol->string name)) - content - (with-exporting-libraries - (lambda (libs) - (make-thing-index-desc name libs))))) - tag))) - (car content))) - spacer ":" spacer)))) - (make-flow - (list - (if (block? result-contract) - result-contract - (make-paragraph (list result-contract))))))))))) - stx-ids names result-contracts)) - (content-thunk)) - null)) - - (define (meta-symbol? s) (memq s '(... ...+ ?))) - - (define (*defforms kw-id lits forms form-procs subs sub-procs content-thunk) - (let ([var-list - (let loop ([form (cons forms subs)]) - (cond - [(symbol? form) (if (or (meta-symbol? form) - (and kw-id (eq? form (syntax-e kw-id))) - (memq form lits)) - null - (list form))] - [(pair? form) (append (loop (car form)) - (loop (cdr form)))] - [else null]))]) - (parameterize ([current-variable-list var-list] - [current-meta-list '(... ...+)]) - (make-box-splice - (cons - (make-table - 'boxed - (append - (map (lambda (form form-proc) - (list - (make-flow - (list - ((or form-proc - (lambda (x) - (make-paragraph - (list - (to-element - `(,x . ,(cdr form))))))) - (and kw-id - (eq? form (car forms)) - (let ([target-maker (id-to-form-target-maker kw-id #t)] - [content (list (definition-site (syntax-e kw-id) kw-id #t))]) - (if target-maker - (target-maker - content - (lambda (tag) - (make-toc-target-element - #f - (if kw-id - (list (make-index-element #f - content - tag - (list (symbol->string (syntax-e kw-id))) - content - (with-exporting-libraries - (lambda (libs) - (make-form-index-desc (syntax-e kw-id) libs))))) - content) - tag))) - (car content))))))))) - forms form-procs) - (if (null? sub-procs) - null - (list (list (make-flow (list (make-paragraph (list (tt 'nbsp)))))) - (list (make-flow (list (let ([l (map (lambda (sub) - (map (lambda (f) (f)) sub)) - sub-procs)]) - (*schemerawgrammars - "specgrammar" - (map car l) - (map cdr l)))))))))) - (content-thunk)) - var-list)))) - - (define (*specsubform form has-kw? lits form-thunk subs sub-procs content-thunk) - (parameterize ([current-variable-list - (append (let loop ([form (cons (if has-kw? (cdr form) form) - subs)]) - (cond - [(symbol? form) (if (or (meta-symbol? form) - (memq form lits)) - null - (list form))] - [(pair? form) (append (loop (car form)) - (loop (cdr form)))] - [else null])) - (current-variable-list))] - [current-meta-list '(... ...+)]) - (make-blockquote - "leftindent" - (cons - (make-table - 'boxed - (cons - (list - (make-flow - (list - (if form-thunk - (form-thunk) - (make-paragraph (list (to-element form))))))) - (if (null? sub-procs) - null - (list (list (make-flow (list (make-paragraph (list (tt 'nbsp)))))) - (list (make-flow (list (let ([l (map (lambda (sub) - (map (lambda (f) (f)) sub)) - sub-procs)]) - (*schemerawgrammars - "specgrammar" - (map car l) - (map cdr l)))))))))) - (flow-paragraphs (decode-flow (content-thunk))))))) - - (define (*schemerawgrammars style nonterms clauseses) - (make-table - `((valignment baseline baseline baseline baseline baseline) - (alignment right left center left left) - (style ,style)) - (let ([empty-line (make-flow (list (make-paragraph (list (tt 'nbsp)))))] - [to-flow (lambda (i) (make-flow (list (make-paragraph (list i)))))]) - (cdr - (apply append - (map - (lambda (nonterm clauses) - (list* - (list empty-line empty-line empty-line empty-line empty-line) - (list (to-flow nonterm) - empty-line - (to-flow "=") - empty-line - (make-flow (list (car clauses)))) - (map (lambda (clause) - (list empty-line - empty-line - (to-flow "|") - empty-line - (make-flow (list clause)))) - (cdr clauses)))) - nonterms clauseses)))))) - - (define (*schemerawgrammar style nonterm clause1 . clauses) - (*schemerawgrammars style (list nonterm) (list (cons clause1 clauses)))) - - (define (*schemegrammar lits s-expr clauseses-thunk) - (parameterize ([current-variable-list - (let loop ([form s-expr]) - (cond - [(symbol? form) (if (memq form lits) - null - (list form))] - [(pair? form) (append (loop (car form)) - (loop (cdr form)))] - [else null]))]) - (let ([l (clauseses-thunk)]) - (*schemerawgrammars #f - (map (lambda (x) - (make-element #f - (list (hspace 2) - (car x)))) - l) - (map cdr l))))) - - (define (*var id) - (to-element (*var-sym id))) - - (define (*var-sym id) - (string->symbol (format "_~a" id))) - - ;; ---------------------------------------- - - (provide centerline) - (define (centerline . s) - (make-table 'centered (list (list (make-flow (list (decode-paragraph s))))))) - - (provide commandline) - (define (commandline . s) - (make-paragraph (cons (hspace 2) (map (lambda (s) - (if (string? s) - (make-element 'tt (list s)) - s)) - s)))) - - (define (elemtag t . body) - (make-target-element #f (decode-content body) `(elem ,t))) - (define (elemref t . body) - (make-link-element #f (decode-content body) `(elem ,t))) - (provide elemtag elemref) - - (define (doc-prefix doc s) - (if doc - (list (module-path-prefix->string doc) - s) - s)) - - (define (secref s #:underline? [u? #t] #:doc [doc #f]) - (make-link-element (if u? #f "plainlink") null `(part ,(doc-prefix doc s)))) - (define (seclink tag #:underline? [u? #t] #:doc [doc #f] . s) - (make-link-element (if u? #f "plainlink") (decode-content s) `(part ,(doc-prefix doc tag)))) - - (define (other-manual #:underline? [u? #t] doc) - (secref #:doc doc #:underline? u? "top")) - - (define (*schemelink stx-id id . s) - (let ([content (decode-content s)]) - (make-delayed-element - (lambda (r p ri) - (list - (make-link-element #f - content - (or (find-scheme-tag p ri stx-id #f) - `(undef ,(format "--UNDEFINED:~a--" (syntax-e stx-id))))))) - (lambda () content) - (lambda () content)))) - - (define-syntax schemelink - (syntax-rules () - [(_ id . content) (*schemelink (quote-syntax id) 'id . content)])) - (provide secref seclink schemelink other-manual) - - (define (pidefterm . s) - (let ([c (apply defterm s)]) - (index (string-append (content->string (element-content c)) "s") - c))) - (provide pidefterm) - - (provide hash-lang) - (define (hash-lang) (make-link-element - "schememodlink" - (list (schememodfont "#lang")) - `(part ,(doc-prefix '(lib "scribblings/guide/guide.scrbl") - "hash-lang")))) - - ;; ---------------------------------------- - - (provide math) - (define (math . s) - (let ([c (decode-content s)]) - (make-element #f (apply append - (map (lambda (i) - (let loop ([i i]) - (cond - [(string? i) - (cond - [(regexp-match #px"^(.*)_([a-zA-Z0-9]+)(.*)$" i) - => (lambda (m) - (append (loop (cadr m)) - (list (make-element 'subscript - (loop (caddr m)))) - (loop (cadddr m))))] - [(regexp-match #px"^(.*)\\^([a-zA-Z0-9]+)(.*)$" i) - => (lambda (m) - (append (loop (cadr m)) - (list (make-element 'superscript - (loop (caddr m)))) - (loop (cadddr m))))] - [(regexp-match #px"^(.*)([()0-9{}\\[\\]\u03C0])(.*)$" i) - => (lambda (m) - (append (loop (cadr m)) - (list (caddr m)) - (loop (cadddr m))))] - [else - (list (make-element 'italic (list i)))])] - [(eq? i 'rsquo) (list 'prime)] - [else (list i)]))) - c))))) - - ;; ---------------------------------------- - - (provide cite - bib-entry - (rename-out [a-bib-entry? bib-entry?]) - bibliography) - - (define (cite key . keys) +(define (id-to-target-maker id dep?) + (*id-to-target-maker 'def id dep?)) + +(define (id-to-form-target-maker id dep?) + (*id-to-target-maker 'form id dep?)) + +(define (*id-to-target-maker sym id dep?) + (let ([sig (current-signature)]) + (lambda (content mk) + (make-part-relative-element + (lambda (ci) + (let ([e (ormap (lambda (p) + (ormap (lambda (e) + (and (exporting-libraries? e) e)) + (part-to-collect p))) + (collect-info-parents ci))]) + (unless e + ;; Call raise-syntax-error to capture error message: + (with-handlers ([exn:fail:syntax? + (lambda (exn) + (fprintf (current-error-port) + "~a\n" (exn-message exn)))]) + (raise-syntax-error + 'WARNING + "no declared exporting libraries for definition" id))) + (if e + (let* ([lib-taglet (libs->taglet + (if sig (sig-id sig) id) + (exporting-libraries-libs e) + (exporting-libraries-source-libs e))] + [tag (intern-taglet + (list (if sig + (case sym + [(def) 'sig-val] + [(form) 'sig-def]) + sym) + `(,lib-taglet + ,@(if sig (list (syntax-e (sig-id sig))) null) + ,(syntax-e id))))]) + (if (or sig (not dep?)) + (list (mk tag)) + (list (make-target-element + #f + (list (mk tag)) + (intern-taglet + `(dep ,(list lib-taglet (syntax-e id)))))))) + content))) + (lambda () (car content)) + (lambda () (car content)))))) + +(define (make-binding-redirect-elements mod-path redirects) + (let ([taglet (path->main-collects-relative + (resolved-module-path-name + (module-path-index-resolve + (module-path-index-join mod-path #f))))]) (make-element #f - (list "[" - (let loop ([keys (cons key keys)]) - (if (null? (cdr keys)) - (make-link-element - #f - (list (car keys)) - `(cite ,(car keys))) + (map + (lambda (redirect) + (let ([id (car redirect)] + [form? (cadr redirect)] + [path (caddr redirect)] + [anchor (cadddr redirect)]) + (let ([make-one + (lambda (kind) + (make-redirect-target-element + #f + null + (intern-taglet (list kind (list taglet id))) + path + anchor))]) + (make-element + #f + (list (make-one (if form? 'form 'def)) + (make-one 'dep) + (make-index-element #f + null + (list (if form? 'form 'def) + (list taglet id)) + (list (symbol->string id)) + (list + (make-element + "schemesymbol" + (list + (make-element + (if form? + "schemesyntaxlink" + "schemevaluelink") + (list (symbol->string id)))))) + ((if form? + make-form-index-desc + make-procedure-index-desc) + id + (list mod-path)))))))) + redirects)))) + +(provide make-binding-redirect-elements) + +(define current-signature (make-parameter #f)) + +(define-syntax-rule (sigelem sig elem) + (*sig-elem (quote-syntax sig) 'elem)) + +(define (*sig-elem sig elem) + (let ([s (to-element/no-color elem)]) + (make-delayed-element + (lambda (renderer sec ri) + (let* ([tag (find-scheme-tag sec ri sig #f)] + [taglet (and tag (append (cadr tag) (list elem)))] + [vtag (and tag `(sig-val ,taglet))] + [stag (and tag `(sig-form ,taglet))] + [sd (and stag (resolve-get/tentative sec ri stag))]) + (list + (make-element + "schemesymbol" + (list + (cond [sd (make-link-element "schemesyntaxlink" (list s) stag)] + [vtag (make-link-element "schemevaluelink" (list s) vtag)] + [else s])))))) + (lambda () s) + (lambda () s)))) + +(provide sigelem) + +;; ---------------------------------------- + +(provide method xmethod (rename-out [method ::])) + +(define-syntax-rule (method a b) + (*method 'b (quote-syntax a))) + +(define-syntax-rule (xmethod a b) + (elem (method a b) " in " (scheme a))) + +(define (*method sym id) + (**method sym id)) + +(define (**method sym id/tag) + (let ([content (list (symbol->string sym))]) + ((if (identifier? id/tag) + (lambda (c mk) + (make-delayed-element + (lambda (ren p ri) + (let ([tag (find-scheme-tag p ri id/tag #f)]) + (if tag (list (mk tag)) content))) + (lambda () (car content)) + (lambda () (car content)))) + (lambda (c mk) (mk id/tag))) + content + (lambda (tag) + (make-element "schemesymbol" + (list (make-link-element "schemevaluelink" content + (method-tag tag sym)))))))) + +(define (method-tag vtag sym) + (list 'meth (list (cadr vtag) sym))) + +;; ---------------------------------------- + +(provide margin-note) + +(define (margin-note . c) + (make-styled-paragraph + (list (make-element "refcolumn" + (list (make-element "refcontent" (decode-content c))))) + "refpara")) + +;; ---------------------------------------- + +(provide deftech tech techlink) + +(define (*tech make-elem style doc s) + (let* ([c (decode-content s)] + [s (string-foldcase (content->string c))] + [s (regexp-replace #rx"ies$" s "y")] + [s (regexp-replace #rx"s$" s "")] + [s (regexp-replace* #px"[-\\s]+" s " ")]) + (make-elem style c (list 'tech (doc-prefix doc s))))) + +(define (deftech . s) + (let* ([e (apply defterm s)] + [t (*tech make-target-element #f #f (list e))]) + (make-index-element #f + (list t) + (target-element-tag t) + (list (element->string e)) + (list e) + 'tech))) + +(define (tech #:doc [doc #f] . s) + (*tech make-link-element "techlink" doc s)) + +(define (techlink #:doc [doc #f] . s) + (*tech make-link-element #f doc s)) + +;; ---------------------------------------- + +(provide declare-exporting + deftogether + defproc defproc* defstruct + defthing defthing* defthing/proc + defparam defparam* defboolparam + defform defform* defform/subs defform*/subs defform/none + defidform + specform specform/subs + specsubform specsubform/subs specspecsubform specspecsubform/subs + specsubform/inline + defsubform defsubform* + schemegrammar schemegrammar* + var svar void-const undefined-const) + +(define-syntax (declare-exporting stx) + (syntax-case stx () + [(_ lib ... #:use-sources (plib ...)) + (let ([libs (syntax->list #'(lib ... plib ...))]) + (for ([l libs]) + (unless (module-path? (syntax->datum l)) + (raise-syntax-error #f "not a module path" stx l))) + (when (null? libs) + (raise-syntax-error #f "need at least one module path" stx)) + #'(*declare-exporting '(lib ...) '(plib ...)))] + [(_ lib ...) #'(*declare-exporting '(lib ...) '())])) + +(define-struct (exporting-libraries element) (libs source-libs)) + +(define (*declare-exporting libs source-libs) + (make-splice + (list + (make-part-collect-decl + (make-collect-element + #f null + (lambda (ri) (collect-put! ri '(exporting-libraries #f) libs)))) + (make-part-collect-decl + (make-exporting-libraries #f null (and (pair? libs) libs) source-libs))))) + +(define-syntax (quote-syntax/loc stx) + (syntax-case stx () + [(_ id) + (with-syntax ([loc (let ([s #'id]) + (vector (syntax-source s) + (syntax-line s) + (syntax-column s) + (syntax-position s) + (syntax-span s)))]) + #'(let ([s (*quote-syntax/loc id)]) + (datum->syntax s (syntax-e s) 'loc s)))])) + +(define-syntax *quote-syntax/loc + (syntax-rules () + [(_ (sub ...)) (datum->syntax #f (list (quote-syntax/loc sub) ...))] + [(_ id) (quote-syntax id)])) + +(define void-const + (schemeresultfont "#")) +(define undefined-const + (schemeresultfont "#")) + +(define dots0 + (make-element "schememeta" (list "..."))) +(define dots1 + (make-element "schememeta" (list "...+"))) + +(define-syntax (arg-contract stx) + (syntax-case stx (... ...+ _...superclass-args...) + [(_ [id contract]) + (identifier? #'id) + #'(schemeblock0 contract)] + [(_ [id contract val]) + (identifier? #'id) + #'(schemeblock0 contract)] + [(_ [kw id contract]) + (and (keyword? (syntax-e #'kw)) (identifier? #'id)) + #'(schemeblock0 contract)] + [(_ [kw id contract val]) + (and (keyword? (syntax-e #'kw)) (identifier? #'id)) + #'(schemeblock0 contract)] + [(_ (... ...)) #'#f] + [(_ (... ...+)) #'#f] + [(_ _...superclass-args...) #'#f] + [(_ arg) (raise-syntax-error 'defproc "bad argument form" #'arg)])) + +(define-syntax (arg-default stx) + (syntax-case stx (... ...+ _...superclass-args...) + [(_ [id contract]) + (identifier? #'id) + #'#f] + [(_ [id contract val]) + (identifier? #'id) + #'(schemeblock0 val)] + [(_ [kw id contract]) + (keyword? (syntax-e #'kw)) + #'#f] + [(_ [kw id contract val]) + (keyword? (syntax-e #'kw)) + #'(schemeblock0 val)] + [_ #'#f])) + +(define-syntax (extract-proc-id stx) + (syntax-case stx () + [(_ id) + (identifier? #'id) + #`(quote-syntax/loc id)] + [(_ (proto arg ...)) + #'(extract-proc-id proto)] + [(_ thing) (raise-syntax-error 'defproc "bad prototype" #'thing)])) + +(define-syntax (arg-contracts stx) + (syntax-case stx () + [(_ id arg ...) + (identifier? #'id) + #'(list (lambda () (arg-contract arg)) ...)] + [(_ (proto arg1 ...) arg ...) + #'(arg-contracts proto arg1 ... arg ...)] + [_ (raise-syntax-error 'defproc "bad prototype" stx)])) + +(define-syntax (arg-defaults stx) + (syntax-case stx () + [(_ id arg ...) + (identifier? #'id) + #'(list (lambda () (arg-default arg)) ...)] + [(_ (proto arg1 ...) arg ...) + #'(arg-defaults proto arg1 ... arg ...)] + [_ (raise-syntax-error 'defproc "bad prototype" stx)])) + +(define-syntax (result-contract stx) + (syntax-case stx (values) + [(_ (values c ...)) + #'(list (schemeblock0 c) ...)] + [(_ c) + (if (string? (syntax-e #'c)) + (raise-syntax-error 'defproc + "expected a result contract, found a string" #'c) + #'(schemeblock0 c))])) + +(define-syntax-rule (defproc (id arg ...) result desc ...) + (defproc* [[(id arg ...) result]] desc ...)) +(define-syntax defproc* + (syntax-rules () + [(_ [[proto result] ...] desc ...) + (defproc* #:mode procedure #:within #f [[proto result] ...] desc ...)] + [(_ #:mode m #:within cl [[proto result] ...] desc ...) + (*defproc 'm (quote-syntax/loc cl) + (list (extract-proc-id proto) ...) + '[proto ...] + (list (arg-contracts proto) ...) + (list (arg-defaults proto) ...) + (list (lambda () (result-contract result)) ...) + (lambda () (list desc ...)))])) +(define-syntax defstruct + (syntax-rules () + [(_ name fields #:mutable #:inspector #f desc ...) + (**defstruct name fields #f #t desc ...)] + [(_ name fields #:mutable #:transparent desc ...) + (**defstruct name fields #f #t desc ...)] + [(_ name fields #:mutable desc ...) + (**defstruct name fields #f #f desc ...)] + [(_ name fields #:inspector #f desc ...) + (**defstruct name fields #t #t desc ...)] + [(_ name fields #:transparent desc ...) + (**defstruct name fields #t #t desc ...)] + [(_ name fields desc ...) + (**defstruct name fields #t #f desc ...)])) +(define-syntax-rule (**defstruct name ([field field-contract] ...) immutable? + transparent? desc ...) + (*defstruct (quote-syntax/loc name) 'name + '([field field-contract] ...) + (list (lambda () (schemeblock0 field-contract)) ...) + immutable? transparent? (lambda () (list desc ...)))) +(define-syntax (defform*/subs stx) + (syntax-case stx () + [(_ #:id defined-id #:literals (lit ...) [spec spec1 ...] + ([non-term-id non-term-form ...] ...) + desc ...) + (with-syntax ([new-spec + (let loop ([spec #'spec]) + (if (and (identifier? spec) + (free-identifier=? spec #'defined-id)) + (datum->syntax #'here '(unsyntax x) spec spec) + (syntax-case spec () + [(a . b) + (datum->syntax spec + (cons (loop #'a) (loop #'b)) + spec + spec)] + [_ spec])))]) + #'(*defforms (quote-syntax/loc defined-id) '(lit ...) + '(spec spec1 ...) + (list (lambda (x) (schemeblock0/form new-spec)) + (lambda (ignored) (schemeblock0/form spec1)) ...) + '((non-term-id non-term-form ...) ...) + (list (list (lambda () (scheme non-term-id)) + (lambda () (schemeblock0/form non-term-form)) + ...) + ...) + (lambda () (list desc ...))))] + [(fm #:id id [spec spec1 ...] ([non-term-id non-term-form ...] ...) + desc ...) + #'(fm #:id id #:literals () [spec spec1 ...] + ([non-term-id non-term-form ...] ...) + desc ...)] + [(fm #:literals lits [(spec-id . spec-rest) spec1 ...] + ([non-term-id non-term-form ...] ...) + desc ...) + (with-syntax ([(_ _ _ [spec . _] . _) stx]) + #'(fm #:id spec-id #:literals lits [spec spec1 ...] + ([non-term-id non-term-form ...] ...) + desc ...))] + [(fm [spec spec1 ...] ([non-term-id non-term-form ...] ...) desc ...) + #'(fm #:literals () [spec spec1 ...] ([non-term-id non-term-form ...] ...) + desc ...)])) +(define-syntax (defform* stx) + (syntax-case stx () + [(_ #:id id #:literals lits [spec ...] desc ...) + #'(defform*/subs #:id id #:literals lits [spec ...] () desc ...)] + [(_ #:literals lits [spec ...] desc ...) + #'(defform*/subs #:literals lits [spec ...] () desc ...)] + [(_ [spec ...] desc ...) + #'(defform*/subs [spec ...] () desc ...)])) +(define-syntax (defform stx) + (syntax-case stx () + [(_ #:id id #:literals (lit ...) spec desc ...) + #'(defform*/subs #:id id #:literals (lit ...) [spec] () desc ...)] + [(_ #:id id spec desc ...) + #'(defform*/subs #:id id #:literals () [spec] () desc ...)] + [(_ #:literals (lit ...) spec desc ...) + #'(defform*/subs #:literals (lit ...) [spec] () desc ...)] + [(_ spec desc ...) + #'(defform*/subs [spec] () desc ...)])) +(define-syntax (defform/subs stx) + (syntax-case stx () + [(_ #:id id #:literals lits spec subs desc ...) + #'(defform*/subs #:id id #:literals lits [spec] subs desc ...)] + [(_ #:id id spec subs desc ...) + #'(defform*/subs #:id id #:literals () [spec] subs desc ...)] + [(_ #:literals lits spec subs desc ...) + #'(defform*/subs #:literals lits [spec] subs desc ...)] + [(_ spec subs desc ...) + #'(defform*/subs [spec] subs desc ...)])) +(define-syntax (defform/none stx) + (syntax-case stx () + [(_ #:literals (lit ...) spec desc ...) + #'(*defforms #f '(lit ...) + '(spec) (list (lambda (ignored) (schemeblock0/form spec))) + null null + (lambda () (list desc ...)))] + [(_ spec desc ...) + #'(defform/none #:literals () spec desc ...)])) +(define-syntax (defidform stx) + (syntax-case stx () + [(_ spec-id desc ...) + #'(*defforms (quote-syntax/loc spec-id) null + '(spec-id) + (list (lambda (x) (make-paragraph (list x)))) + null + null + (lambda () (list desc ...)))])) +(define-syntax (defsubform stx) + (syntax-case stx () + [(_ . rest) #'(into-blockquote (defform . rest))])) +(define-syntax (defsubform* stx) + (syntax-case stx () + [(_ . rest) #'(into-blockquote (defform* . rest))])) +(define-syntax specsubform + (syntax-rules () + [(_ #:literals (lit ...) spec desc ...) + (*specsubform 'spec #f '(lit ...) (lambda () (schemeblock0/form spec)) + null null (lambda () (list desc ...)))] + [(_ spec desc ...) + (*specsubform 'spec #f null (lambda () (schemeblock0/form spec)) + null null (lambda () (list desc ...)))])) +(define-syntax specsubform/subs + (syntax-rules () + [(_ #:literals (lit ...) spec ([non-term-id non-term-form ...] ...) + desc ...) + (*specsubform 'spec #f '(lit ...) (lambda () (schemeblock0/form spec)) + '((non-term-id non-term-form ...) ...) + (list (list (lambda () (scheme non-term-id)) + (lambda () (schemeblock0/form non-term-form)) + ...) + ...) + (lambda () (list desc ...)))] + [(_ spec subs desc ...) + (specsubform/subs #:literals () spec subs desc ...)])) +(define-syntax-rule (specspecsubform spec desc ...) + (make-blockquote "leftindent" (list (specsubform spec desc ...)))) +(define-syntax-rule (specspecsubform/subs spec subs desc ...) + (make-blockquote "leftindent" (list (specsubform/subs spec subs desc ...)))) +(define-syntax specform + (syntax-rules () + [(_ #:literals (lit ...) spec desc ...) + (*specsubform 'spec #t '(lit ...) (lambda () (schemeblock0/form spec)) + null null (lambda () (list desc ...)))] + [(_ spec desc ...) + (*specsubform 'spec #t null (lambda () (schemeblock0/form spec)) + null null (lambda () (list desc ...)))])) +(define-syntax specform/subs + (syntax-rules () + [(_ #:literals (lit ...) spec ([non-term-id non-term-form ...] ...) + desc ...) + (*specsubform 'spec #t + '(lit ...) + (lambda () (schemeblock0/form spec)) + '((non-term-id non-term-form ...) ...) + (list (list (lambda () (scheme non-term-id)) + (lambda () (schemeblock0/form non-term-form)) + ...) + ...) + (lambda () (list desc ...)))] + [(_ spec ([non-term-id non-term-form ...] ...) desc ...) + (specform/subs #:literals () spec ([non-term-id non-term-form ...] ...) + desc ...)])) +(define-syntax-rule (specsubform/inline spec desc ...) + (*specsubform 'spec #f null #f null null (lambda () (list desc ...)))) +(define-syntax-rule (defthing id result desc ...) + (*defthing (list (quote-syntax/loc id)) (list 'id) #f + (list (schemeblock0 result)) + (lambda () (list desc ...)))) +(define-syntax-rule (defthing* ([id result] ...) desc ...) + (*defthing (list (quote-syntax/loc id) ...) (list 'id ...) #f + (list (schemeblock0 result) ...) + (lambda () (list desc ...)))) +(define-syntax-rule (defparam id arg contract desc ...) + (defproc* ([(id) contract] [(id [arg contract]) void?]) desc ...)) +(define-syntax-rule (defparam* id arg in-contract out-contract desc ...) + (defproc* ([(id) out-contract] [(id [arg in-contract]) void?]) desc ...)) +(define-syntax-rule (defboolparam id arg desc ...) + (defproc* ([(id) boolean?] [(id [arg any/c]) void?]) desc ...)) +(define-syntax schemegrammar + (syntax-rules () + [(_ #:literals (lit ...) id clause ...) + (*schemegrammar '(lit ...) + '(id clause ...) + (lambda () + (list (list (scheme id) + (schemeblock0/form clause) ...))))] + [(_ id clause ...) (schemegrammar #:literals () id clause ...)])) +(define-syntax schemegrammar* + (syntax-rules () + [(_ #:literals (lit ...) [id clause ...] ...) + (*schemegrammar '(lit ...) + '(id ... clause ... ...) + (lambda () + (list (list (scheme id) (schemeblock0/form clause) ...) + ...)))] + [(_ [id clause ...] ...) + (schemegrammar #:literals () [id clause ...] ...)])) +(define-syntax-rule (var id) + (*var 'id)) +(define-syntax-rule (svar id) + (*var 'id)) + +(define (defthing/proc id contract descs) + (*defthing (list id) (list (syntax-e id)) #f (list contract) + (lambda () descs))) + +(define (into-blockquote s) + (make-blockquote "leftindent" + (if (splice? s) + (flow-paragraphs (decode-flow (splice-run s))) + (list s)))) + +(define (make-table-if-necessary style content) + (if (= 1 (length content)) + (let ([paras (append-map flow-paragraphs (car content))]) + (if (andmap paragraph? paras) + (list (make-paragraph (append-map paragraph-content paras))) + (list (make-table style content)))) + (list (make-table style content)))) + +(define max-proto-width 65) + +(define (name-this-object type-sym) + (to-element + (string->symbol + (regexp-replace + #rx"(%|<%>|-mixin)$" + (format "_a~a-~s" + (if (member (string-ref (symbol->string type-sym) 0) + '(#\a #\e #\i #\o #\u)) + "n" + "") + type-sym) + "")))) + +(define (annote-exporting-library e) + (make-delayed-element + (lambda (render p ri) + (let ([from (resolve-get/tentative p ri '(exporting-libraries #f))]) + (if (and from (pair? from)) + (list (make-hover-element + #f + (list e) + (intern-taglet + (string-append + "Provided from: " + (let loop ([from from]) + (if (null? (cdr from)) + (format "~s" (car from)) + (format "~s, ~a" (car from) (loop (cdr from))))))))) + (list e)))) + (lambda () e) + (lambda () e))) + +(define (get-exporting-libraries render p ri) + (resolve-get/tentative p ri '(exporting-libraries #f))) + +(define (with-exporting-libraries proc) + (make-delayed-index-desc + (lambda (render part ri) + (proc (or (get-exporting-libraries render part ri) null))))) + +(define-struct (box-splice splice) (var-list)) + +(define (*deftogether boxes body-thunk) + (make-splice + (cons + (make-table + 'boxed + (map + (lambda (box) + (unless (and (box-splice? box) + (= 1 (length (splice-run box))) + (table? (car (splice-run box))) + (eq? 'boxed (table-style (car (splice-run box))))) + (error 'deftogether + "element is not a boxing splice containing a single table: ~e" + box)) + (list (make-flow (list (make-table + "together" + (table-flowss (car (splice-run box)))))))) + boxes)) + (parameterize ([current-variable-list + (append-map box-splice-var-list boxes)]) + (body-thunk))))) + +(define-syntax-rule (deftogether (box ...) . body) + (*deftogether (list box ...) (lambda () (list . body)))) + +(define-struct arg + (special? kw id optional? starts-optional? ends-optional? num-closers)) + +(define (*defproc mode within-id + stx-ids prototypes arg-contractss arg-valss result-contracts + content-thunk) + (define ((arg->elem show-opt-start?) arg) + (let* ([e (cond [(not (arg-special? arg)) + (if (arg-kw arg) + (if (eq? mode 'new) + (make-element + #f (list (schemeparenfont "[") + (schemeidfont (keyword->string (arg-kw arg))) + spacer + (to-element (arg-id arg)) + (schemeparenfont "]"))) + (make-element + #f (list (to-element (arg-kw arg)) + spacer + (to-element (arg-id arg))))) + (to-element (arg-id arg)))] + [(eq? (arg-id arg) '...+) dots1] + [(eq? (arg-id arg) '...) dots0] + [else (to-element (arg-id arg))])] + [e (if (arg-ends-optional? arg) + (make-element #f (list e "]")) + e)] + [e (if (zero? (arg-num-closers arg)) + e + (make-element + #f (list e (make-closers (arg-num-closers arg)))))]) + (if (and show-opt-start? (arg-starts-optional? arg)) + (make-element #f (list "[" e)) + e))) + (define (prototype-depth p) + (let loop ([p (car p)]) + (if (symbol? p) 0 (+ 1 (loop (car p)))))) + (define (prototype-args p) + (define (parse-arg v in-optional? depth next-optional? next-special-dots?) + (let* ([id (if (pair? v) ((if (keyword? (car v)) cadr car) v) v)] + [kw (and (pair? v) (keyword? (car v)) (car v))] + [default? (and (pair? v) (pair? ((if kw cdddr cddr) v)))]) + (make-arg (symbol? v) kw id default? + (and default? (not in-optional?)) + (or (and (not default?) + in-optional?) ; => must be special + (and default? + (not next-optional?) + (not next-special-dots?))) + depth))) + (let loop ([p p] [last-depth 0]) + (append + (if (symbol? (car p)) + null + (loop (car p) (add1 last-depth))) + (let loop ([p (cdr p)][in-optional? #f]) + (cond + [(null? p) null] + [(null? (cdr p)) + (list (parse-arg (car p) in-optional? last-depth #f #f))] + [else + (let ([a (parse-arg + (car p) + in-optional? + 0 + (let ([v (cadr p)]) + (and (pair? v) + (not + (null? ((if (keyword? (car v)) cdddr cddr) v))))) + (and (not (pair? (cadr p))) + (not (eq? '_...superclass-args... (cadr p)))))]) + (cons a (loop (cdr p) + (and (arg-optional? a) + (not (arg-ends-optional? a))))))]))))) + (define (prototype-size args first-combine next-combine special-combine?) + (let loop ([s args] [combine first-combine]) + (if (null? s) + 0 + (combine + (loop (cdr s) next-combine) + (let ([a (car s)]) + (+ (arg-num-closers a) + (if (arg-special? a) + (string-length (symbol->string (arg-id a))) + (+ (if (arg-kw a) + (+ (if (eq? mode 'new) 2 0) + (string-length (keyword->string (arg-kw a))) + 3 + (string-length (symbol->string (arg-id a)))) + (string-length (symbol->string (arg-id a)))) + (if (and special-combine? + (pair? (cdr s)) + (arg-special? (cadr s)) + (not (eq? '_...superclass-args... + (arg-id (cadr s))))) + (+ 1 (string-length (symbol->string (arg-id (cadr s))))) + 0))))))))) + (define (extract-id p) + (let loop ([p p]) + (if (symbol? (car p)) (car p) (loop (car p))))) + (define (do-one stx-id prototype args arg-contracts arg-vals result-contract + first?) + (define tagged + (cond + [(eq? mode 'new) + (make-element #f (list (scheme new) spacer (to-element within-id)))] + [(eq? mode 'make) + (make-element + #f (list (scheme make-object) spacer (to-element within-id)))] + [(eq? mode 'send) + (make-element + #f + (list (scheme send) spacer + (name-this-object (syntax-e within-id)) spacer + (if first? + (let* ([mname (extract-id prototype)] + [target-maker (id-to-target-maker within-id #f)] + [content (list (*method mname within-id))]) + (if target-maker + (target-maker + content + (lambda (ctag) + (let ([tag (method-tag ctag mname)]) + (make-toc-target-element + #f + (list (make-index-element + #f + content + tag + (list (symbol->string mname)) + content + (with-exporting-libraries + (lambda (libs) + (make-method-index-desc + (syntax-e within-id) + libs mname ctag))))) + tag)))) + (car content))) + (*method (extract-id prototype) within-id))))] + [first? + (let ([target-maker (id-to-target-maker stx-id #t)] + [content (list (definition-site (extract-id prototype) + stx-id #f))]) + (if target-maker + (target-maker + content + (lambda (tag) + (make-toc-target-element + #f + (list (make-index-element + #f content tag + (list (symbol->string (extract-id prototype))) + content + (with-exporting-libraries + (lambda (libs) + (make-procedure-index-desc (extract-id prototype) + libs))))) + tag))) + (car content)))] + [else + (annote-exporting-library + (let ([sig (current-signature)]) + (if sig + (*sig-elem (sig-id sig) (extract-id prototype)) + (to-element (make-just-context (extract-id prototype) + stx-id)))))])) + (define flat-size (+ (prototype-size args + + #f) + (prototype-depth prototype) + (element-width tagged))) + (define short? (or (flat-size . < . 40) ((length args) . < . 2))) + (define res + (let ([res (result-contract)]) + (if (list? res) + ;; multiple results + (if (null? res) + 'nbsp + (let ([w (apply + (map block-width res))]) + (if (or (ormap table? res) (w . > . 40)) + (make-table + #f (map (lambda (fe) (list (make-flow (list fe)))) res)) + (make-table + #f + (list (let loop ([res res]) + (if (null? (cdr res)) + (list (make-flow (list (car res)))) + (list* (make-flow (list (car res))) + flow-spacer + (loop (cdr res)))))))))) + res))) + (define tagged+arg-width (+ (prototype-size args max max #t) + (prototype-depth prototype) + (element-width tagged))) + (define result-next-line? + ((+ (if short? flat-size tagged+arg-width) (block-width res)) + . >= . (- max-proto-width 7))) + (define end (list flow-spacer (to-flow 'rarr) + flow-spacer (make-flow (list res)))) + (append + (list + (list + (make-flow + (if short? + ;; The single-line case: + (make-table-if-necessary + "prototype" + (list + (cons + (to-flow + (make-element + #f + `(,(make-openers (add1 (prototype-depth prototype))) + ,tagged + ,@(if (null? args) + (list (make-closers (prototype-depth prototype))) + (append-map (lambda (arg) + (list spacer ((arg->elem #t) arg))) + args)) + ,(schemeparenfont ")")))) + (if result-next-line? null end)))) + ;; The multi-line case: + (let ([not-end (if result-next-line? + (list flow-spacer) + (list flow-spacer flow-spacer + flow-spacer flow-spacer))] + [one-ok? (tagged+arg-width . < . 60)]) + (list + (make-table + "prototype" + (cons + (cons + (to-flow (make-element #f - (list (loop (list (car keys))) - ", " - (loop (cdr keys)))))) - "]"))) - - (define-struct a-bib-entry (key val)) - - (define (bib-entry #:key key - #:title title - #:is-book? [is-book? #f] - #:author [author #f] - #:location [location #f] - #:date [date #f] - #:url [url #f]) - (make-a-bib-entry - key - (make-element - #f - (append - (if author - (append (decode-content (list author)) - (list ", ")) - null) - (if is-book? - null - (list 'ldquo)) - (if is-book? - (list (italic title)) - (decode-content (list title))) - (list (if location - "," - ".")) - - (if is-book? - null - (list 'rdquo)) - (if location - (cons " " - (append - (decode-content (list location)) (list - (if date - "," - ".")))) - null) - (if date - (cons " " - (append (decode-content (list date)) - (list "."))) - null) - (if url - (list " " - (link url (tt url))) - null))))) - - (define (bibliography #:tag [tag "doc-bibliography"] . citations) - (make-unnumbered-part - #f - (list `(part ,tag)) - (list "Bibliography") - '() - null - (make-flow - (list - (make-table - "bibliography" - (map (lambda (c) - (let ([key (a-bib-entry-key c)] - [val (a-bib-entry-val c)]) - (list - (make-flow - (list - (make-paragraph - (list - (make-target-element - #f - (list "[" key "]") - `(cite ,key)))))) - (make-flow (list (make-paragraph (list (hspace 1))))) - (make-flow (list (make-paragraph (list val))))))) - citations)))) - null)) - - ;; ---------------------------------------- - - (provide defclass - defclass/title - definterface - definterface/title - defmixin - defmixin/title - defconstructor - defconstructor/make - defconstructor*/make - defconstructor/auto-super - defmethod - defmethod* - methspec - methimpl - this-obj) - - (define-syntax-parameter current-class #f) - - (define-struct decl (name super app-mixins intfs ranges mk-head body)) - (define-struct constructor (def)) - (define-struct meth (names mode desc def)) - (define-struct spec (def)) - (define-struct impl (def)) - - (define (id-info id) - (let ([b (identifier-label-binding id)]) - (if b - (list (let ([p (resolved-module-path-name (module-path-index-resolve (caddr b)))]) - (if (path? p) - (intern-taglet (path->main-collects-relative p)) - p)) - (list-ref b 3) - (list-ref b 4) - (list-ref b 5) - (list-ref b 6)) - (error 'scribble "no class/interface/mixin information for identifier: ~e" - id)))) - - (define-serializable-struct cls/intf (name-element app-mixins super intfs methods)) - - (define (make-inherited-table r d ri decl) - (let* ([start (let ([key (find-scheme-tag d ri (decl-name decl) #f)]) - (if key - (list (cons key (lookup-cls/intf d ri key))) - null))] - [supers (if (null? start) - null - (cdr - (let loop ([supers start][accum null]) + (make-openers (add1 (prototype-depth prototype))) + tagged))) + (if one-ok? + (list* + (if (arg-starts-optional? (car args)) + (to-flow (make-element #f (list spacer "["))) + flow-spacer) + (to-flow ((arg->elem #f) (car args))) + not-end) + (list* 'cont 'cont not-end))) + (let loop ([args (if one-ok? (cdr args) args)]) + (if (null? args) + null + (let ([dots-next? + (or (and (pair? (cdr args)) + (arg-special? (cadr args)) + (not (eq? '_...superclass-args... + (arg-id (cadr args))))))]) + (cons + (list* + flow-spacer + (if (arg-starts-optional? (car args)) + (to-flow (make-element #f (list spacer "["))) + flow-spacer) + (let ([a ((arg->elem #f) (car args))] + [next (if dots-next? + (make-element + #f (list spacer + ((arg->elem #f) + (cadr args)))) + "")]) + (to-flow (cond - [(null? supers) (reverse accum)] - [(memq (car supers) accum) - (loop (cdr supers) accum)] - [else - (let ([super (car supers)]) - (loop (append (filter values - (map (lambda (i) - (let ([key (find-scheme-tag d ri i #f)]) - (and key - (cons key (lookup-cls/intf d ri key))))) - (append - (reverse (cls/intf-intfs (cdr super))) - (if (cls/intf-super (cdr super)) - (list (cls/intf-super (cdr super))) - null) - (reverse (cls/intf-app-mixins (cdr super)))))) - (cdr supers)) - (cons super accum)))]))))] - [ht (let ([ht (make-hasheq)]) - (for-each (lambda (i) - (cond - [(meth? i) - (for-each (lambda (name) (hash-set! ht name #t)) - (meth-names i))])) - (decl-body decl)) - ht)] - [inh (apply - append - (map (lambda (super) - (let ([inh (filter - values - (map - (lambda (k) - (if (hash-ref ht k #f) - #f - (begin - (hash-set! ht k #t) - (cons (symbol->string k) - (**method k (car super)))))) - (cls/intf-methods (cdr super))))]) - (if (null? inh) - null - (cons - (make-element #f (list (make-element "inheritedlbl" '("from ")) - (cls/intf-name-element (cdr super)))) - (map cdr (sort inh - (lambda (a b) - (stringstring (syntax-e (decl-name decl)))) - tag))) - (map id-info (decl-app-mixins decl)) - (and (decl-super decl) - (not (free-label-identifier=? (quote-syntax object%) - (decl-super decl))) - (id-info (decl-super decl))) - (map id-info (decl-intfs decl)) - (apply - append - (map (lambda (m) - (let loop ([l (meth-names m)]) - (cond - [(null? l) null] - [(memq (car l) (cdr l)) (loop (cdr l))] - [else (cons (car l) (loop (cdr l)))]))) - (filter meth? (decl-body decl)))))))))))) - - (define (build-body decl body) - (append - (map (lambda (i) - (cond - [(constructor? i) ((constructor-def i))] - [(meth? i) - ((meth-def i) (meth-desc i))] - [else i])) - body) - (list - (make-delayed-block - (lambda (r d ri) - (make-inherited-table r d ri decl)))))) - - (define (*include-class/title decl) - (make-splice - (list* (title #:style 'hidden (to-element (decl-name decl))) - (make-decl-collect decl) - (build-body decl - (append - ((decl-mk-head decl) #t) - (decl-body decl)))))) - - (define (*include-class decl) - (make-splice + [(null? ((if dots-next? cddr cdr) args)) + (make-element + #f + (list a next (schemeparenfont ")")))] + [(equal? next "") a] + [else + (make-element #f (list a next))]))) + (if (and (null? ((if dots-next? cddr cdr) args)) + (not result-next-line?)) + end + not-end)) + (loop ((if dots-next? cddr cdr) + args)))))))))))))) + (if result-next-line? + (list (list (make-flow (make-table-if-necessary "prototype" + (list end))))) + null) + (append-map + (lambda (arg arg-contract arg-val) + (cond + [(not (arg-special? arg)) + (let* ([arg-cont (arg-contract)] + [base-len (+ 5 (string-length (symbol->string (arg-id arg))) + (block-width arg-cont))] + [arg-val (and arg-val (arg-val))] + [def-len (if (arg-optional? arg) (block-width arg-val) 0)] + [base-list + (list (to-flow (hspace 2)) + (to-flow (to-element (arg-id arg))) + flow-spacer + (to-flow ":") + flow-spacer + (make-flow (list arg-cont)))]) + (list + (list + (make-flow + (if (and (arg-optional? arg) + ((+ base-len 3 def-len) . >= . max-proto-width)) + (list + (make-table + "argcontract" + (list base-list (list flow-spacer flow-spacer flow-spacer + (to-flow "=") flow-spacer + (make-flow (list arg-val)))))) + (make-table-if-necessary + "argcontract" + (list + (append + base-list + (if (and (arg-optional? arg) + ((+ base-len 3 def-len) . < . max-proto-width)) + (list flow-spacer (to-flow "=") flow-spacer + (make-flow (list arg-val))) + null)))))))))] + [else null])) + args + arg-contracts + arg-vals))) + (define all-args (map prototype-args prototypes)) + (define var-list + (filter-map (lambda (a) (and (not (arg-special? a)) (arg-id a))) + (append* all-args))) + (parameterize ([current-variable-list var-list]) + (make-box-splice (cons - (make-decl-collect decl) - (append - ((decl-mk-head decl) #f) - (list - (make-blockquote - "leftindent" - (flow-paragraphs - (decode-flow - (build-body decl (decl-body decl)))))))))) + (make-table + 'boxed + (append-map + do-one + stx-ids prototypes all-args arg-contractss arg-valss result-contracts + (let loop ([ps prototypes] [accum null]) + (cond [(null? ps) null] + [(ormap (lambda (a) (eq? (extract-id (car ps)) a)) accum) + (cons #f (loop (cdr ps) accum))] + [else (cons #t (loop (cdr ps) + (cons (extract-id (car ps)) accum)))])))) + (content-thunk)) + var-list))) - (define (*class-doc kind stx-id super intfs ranges whole-page? make-index-desc) - (let ([spacer (hspace 1)]) +(define (make-target-element* inner-make-target-element stx-id content wrappers) + (if (null? wrappers) + content + (make-target-element* + make-target-element + stx-id + (let* ([name (string-append* (map symbol->string (cdar wrappers)))] + [target-maker + (id-to-target-maker (datum->syntax stx-id (string->symbol name)) + #t)]) + (if target-maker + (target-maker + (list content) + (lambda (tag) + (inner-make-target-element + #f + (list + (make-index-element + #f + (list content) + tag + (list name) + (list (schemeidfont (make-element "schemevaluelink" + (list name)))) + (with-exporting-libraries + (lambda (libs) + (let ([name (string->symbol name)]) + (if (eq? 'info (caar wrappers)) + (make-struct-index-desc name libs) + (make-procedure-index-desc name libs))))))) + tag))) + content)) + (cdr wrappers)))) + +(define (*defstruct stx-id name fields field-contracts immutable? transparent? + content-thunk) + (define (field-name f) ((if (pair? (car f)) caar car) f)) + (define (field-view f) + (if (pair? (car f)) (make-shaped-parens (car f) #\[) (car f))) + (make-box-splice + (cons + (make-table + 'boxed + (cons + (list (make-flow + (list + (let* ([the-name + (let ([just-name + (make-target-element* + make-toc-target-element + (if (pair? name) + (car (syntax-e stx-id)) + stx-id) + (annote-exporting-library + (to-element + (if (pair? name) + (make-just-context (car name) + (car (syntax-e stx-id))) + stx-id))) + (let ([name (if (pair? name) (car name) name)]) + (list* (list 'info name) + (list 'type 'struct: name) + (list 'predicate name '?) + (list 'constructor 'make- name) + (append + (map (lambda (f) + (list 'accessor name '- + (field-name f))) + fields) + (filter-map + (lambda (f) + (if (or (not immutable?) + (and (pair? (car f)) + (memq '#:mutable + (car f)))) + (list 'mutator 'set- name '- + (field-name f) '!) + #f)) + fields)))))]) + (if (pair? name) + (to-element (list just-name + (make-just-context + (cadr name) + (cadr (syntax-e stx-id))))) + just-name))] + [short-width + (apply + (length fields) 8 + (append + (map (lambda (s) + (string-length (symbol->string s))) + (append (if (pair? name) name (list name)) + (map field-name fields))) + (map (lambda (f) + (if (pair? (car f)) + (+ 3 2 (string-length (keyword->string + (cadar f)))) + 0)) + fields)))]) + (if (and (short-width . < . max-proto-width) + (not immutable?) + (not transparent?)) + (make-paragraph + (list + (to-element + `(,(schemeparenfont "struct") + ,the-name + ,(map field-view fields))))) + (make-table + #f + (append + (list + (list (to-flow (schemeparenfont "(struct")) + flow-spacer + (to-flow the-name) + (if (or (null? fields) + (short-width . < . max-proto-width)) + flow-spacer + (to-flow (make-element + #f (list spacer (schemeparenfont "("))))) + (to-flow (if (or (null? fields) + (short-width . < . max-proto-width)) + (make-element + #f (list (to-element (map field-view + fields)) + (schemeparenfont ")"))) + (to-element (field-view (car fields))))))) + (if (short-width . < . max-proto-width) + null + (let loop ([fields (if (null? fields) + fields (cdr fields))]) + (if (null? fields) + null + (cons + (let ([fld (car fields)]) + (list flow-spacer flow-spacer + flow-spacer flow-spacer + (to-flow + (let ([e (to-element (field-view fld))]) + (if (null? (cdr fields)) + (make-element + #f + (list e (schemeparenfont + (if (and immutable? + (not transparent?)) + "))" ")")))) + e))))) + (loop (cdr fields)))))) + (cond + [(and (not immutable?) transparent?) + (list + (list flow-spacer flow-spacer + (to-flow (to-element '#:mutable)) + 'cont + 'cont) + (list flow-spacer flow-spacer + (to-flow (make-element + #f + (list (to-element '#:transparent) + (schemeparenfont ")")))) + 'cont + 'cont))] + [(not immutable?) + (list + (list flow-spacer flow-spacer + (to-flow (make-element + #f + (list (to-element '#:mutable) + (schemeparenfont ")")))) + 'cont + 'cont))] + [transparent? + (list + (list flow-spacer flow-spacer + (to-flow (make-element + #f + (list (to-element '#:transparent) + (schemeparenfont ")")))) + 'cont + 'cont))] + [else null])))))))) + (map (lambda (v field-contract) + (cond + [(pair? v) + (list + (make-flow + (make-table-if-necessary + "argcontract" + (list (list (to-flow (hspace 2)) + (to-flow (to-element (field-name v))) + flow-spacer + (to-flow ":") + flow-spacer + (make-flow (list (field-contract))))))))] + [else null])) + fields field-contracts))) + (content-thunk)) + null)) + +(define (*defthing stx-ids names form? result-contracts content-thunk) + (make-box-splice + (cons + (make-table + 'boxed + (map + (lambda (stx-id name result-contract) + (list + (make-flow + (make-table-if-necessary + "argcontract" + (list + (list + (make-flow + (list + (make-paragraph + (list + (let ([target-maker + ((if form? id-to-form-target-maker id-to-target-maker) + stx-id #t)] + [content (list (definition-site name stx-id form?))]) + (if target-maker + (target-maker + content + (lambda (tag) + (make-toc-target-element + #f + (list + (make-index-element + #f + content + tag + (list (symbol->string name)) + content + (with-exporting-libraries + (lambda (libs) (make-thing-index-desc name libs))))) + tag))) + (car content))) + spacer ":" spacer)))) + (make-flow (list (if (block? result-contract) + result-contract + (make-paragraph (list result-contract))))))))))) + stx-ids names result-contracts)) + (content-thunk)) + null)) + +(define (meta-symbol? s) (memq s '(... ...+ ?))) + +(define (*defforms kw-id lits forms form-procs subs sub-procs content-thunk) + (define var-list + (let loop ([form (cons forms subs)]) + (cond [(symbol? form) + (if (or (meta-symbol? form) + (and kw-id (eq? form (syntax-e kw-id))) + (memq form lits)) + null + (list form))] + [(pair? form) (append (loop (car form)) (loop (cdr form)))] + [else null]))) + (parameterize ([current-variable-list var-list] + [current-meta-list '(... ...+)]) + (make-box-splice + (cons (make-table 'boxed (append + (map + (lambda (form form-proc) + (list + (make-flow + (list + ((or form-proc + (lambda (x) + (make-paragraph + (list (to-element `(,x . ,(cdr form))))))) + (and kw-id + (eq? form (car forms)) + (let ([target-maker (id-to-form-target-maker kw-id #t)] + [content (list (definition-site (syntax-e kw-id) + kw-id #t))]) + (if target-maker + (target-maker + content + (lambda (tag) + (make-toc-target-element + #f + (if kw-id + (list (make-index-element + #f content tag + (list (symbol->string (syntax-e kw-id))) + content + (with-exporting-libraries + (lambda (libs) + (make-form-index-desc (syntax-e kw-id) + libs))))) + content) + tag))) + (car content))))))))) + forms form-procs) + (if (null? sub-procs) + null + (list (list flow-empty-line) + (list (make-flow + (list (let ([l (map (lambda (sub) + (map (lambda (f) (f)) sub)) + sub-procs)]) + (*schemerawgrammars "specgrammar" + (map car l) + (map cdr l)))))))))) + (content-thunk)) + var-list))) + +(define (*specsubform form has-kw? lits form-thunk subs sub-procs content-thunk) + (parameterize ([current-variable-list + (append (let loop ([form (cons (if has-kw? (cdr form) form) + subs)]) + (cond + [(symbol? form) (if (or (meta-symbol? form) + (memq form lits)) + null + (list form))] + [(pair? form) (append (loop (car form)) + (loop (cdr form)))] + [else null])) + (current-variable-list))] + [current-meta-list '(... ...+)]) + (make-blockquote + "leftindent" + (cons + (make-table + 'boxed + (cons (list - (list (make-flow - (list - (make-paragraph - (list (let ([target-maker (id-to-target-maker stx-id #t)] - [content (list (annote-exporting-library (to-element stx-id)))]) - (if target-maker - (target-maker - content - (lambda (tag) - ((if whole-page? - make-page-target-element - make-toc-target-element) - #f - (list - (make-index-element #f - content - tag - (list (symbol->string (syntax-e stx-id))) - content - (with-exporting-libraries - (lambda (libs) - (make-index-desc (syntax-e stx-id) libs))))) - tag))) - (car content))) - spacer ":" spacer - (case kind - [(class) (scheme class?)] - [(interface) (scheme interface?)] - [(mixin) (schemeblockelem (class? . -> . class?))]))))))) - (if super + (make-flow + (list + (if form-thunk + (form-thunk) + (make-paragraph (list (to-element form))))))) + (if (null? sub-procs) + null + (list (list flow-empty-line) + (list (make-flow + (list (let ([l (map (lambda (sub) + (map (lambda (f) (f)) sub)) + sub-procs)]) + (*schemerawgrammars "specgrammar" + (map car l) + (map cdr l)))))))))) + (flow-paragraphs (decode-flow (content-thunk))))))) + +(define (*schemerawgrammars style nonterms clauseses) + (make-table + `((valignment baseline baseline baseline baseline baseline) + (alignment right left center left left) + (style ,style)) + (cdr + (append-map + (lambda (nonterm clauses) + (list* + (list flow-empty-line flow-empty-line flow-empty-line + flow-empty-line flow-empty-line) + (list (to-flow nonterm) flow-empty-line (to-flow "=") flow-empty-line + (make-flow (list (car clauses)))) + (map (lambda (clause) + (list flow-empty-line flow-empty-line + (to-flow "|") flow-empty-line + (make-flow (list clause)))) + (cdr clauses)))) + nonterms clauseses)))) + +(define (*schemerawgrammar style nonterm clause1 . clauses) + (*schemerawgrammars style (list nonterm) (list (cons clause1 clauses)))) + +(define (*schemegrammar lits s-expr clauseses-thunk) + (parameterize ([current-variable-list + (let loop ([form s-expr]) + (cond + [(symbol? form) (if (memq form lits) + null + (list form))] + [(pair? form) (append (loop (car form)) + (loop (cdr form)))] + [else null]))]) + (let ([l (clauseses-thunk)]) + (*schemerawgrammars #f + (map (lambda (x) + (make-element #f + (list (hspace 2) + (car x)))) + l) + (map cdr l))))) + +(define (*var id) + (to-element (*var-sym id))) + +(define (*var-sym id) + (string->symbol (format "_~a" id))) + +;; ---------------------------------------- + +(provide centerline) +(define (centerline . s) + (make-table 'centered (list (list (make-flow (list (decode-paragraph s))))))) + +(provide commandline) +(define (commandline . s) + (make-paragraph (cons (hspace 2) (map (lambda (s) + (if (string? s) + (make-element 'tt (list s)) + s)) + s)))) + +(define (elemtag t . body) + (make-target-element #f (decode-content body) `(elem ,t))) +(define (elemref t . body) + (make-link-element #f (decode-content body) `(elem ,t))) +(provide elemtag elemref) + +(define (doc-prefix doc s) + (if doc + (list (module-path-prefix->string doc) + s) + s)) + +(define (secref s #:underline? [u? #t] #:doc [doc #f]) + (make-link-element (if u? #f "plainlink") null `(part ,(doc-prefix doc s)))) +(define (seclink tag #:underline? [u? #t] #:doc [doc #f] . s) + (make-link-element (if u? #f "plainlink") (decode-content s) + `(part ,(doc-prefix doc tag)))) + +(define (other-manual #:underline? [u? #t] doc) + (secref #:doc doc #:underline? u? "top")) + +(define (*schemelink stx-id id . s) + (let ([content (decode-content s)]) + (make-delayed-element + (lambda (r p ri) + (list + (make-link-element + #f + content + (or (find-scheme-tag p ri stx-id #f) + `(undef ,(format "--UNDEFINED:~a--" (syntax-e stx-id))))))) + (lambda () content) + (lambda () content)))) + +(define-syntax-rule (schemelink id . content) + (*schemelink (quote-syntax id) 'id . content)) +(provide secref seclink schemelink other-manual) + +(define (pidefterm . s) + (let ([c (apply defterm s)]) + (index (string-append (content->string (element-content c)) "s") + c))) +(provide pidefterm) + +(provide hash-lang) +(define (hash-lang) + (make-link-element + "schememodlink" + (list (schememodfont "#lang")) + `(part ,(doc-prefix '(lib "scribblings/guide/guide.scrbl") "hash-lang")))) + +;; ---------------------------------------- + +(provide math) +(define (math . s) + (let ([c (decode-content s)]) + (make-element + #f + (append-map + (lambda (i) + (let loop ([i i]) + (cond + [(string? i) + (cond + [(regexp-match #px"^(.*)_([a-zA-Z0-9]+)(.*)$" i) + => (lambda (m) + (append (loop (cadr m)) + (list (make-element 'subscript + (loop (caddr m)))) + (loop (cadddr m))))] + [(regexp-match #px"^(.*)\\^([a-zA-Z0-9]+)(.*)$" i) + => (lambda (m) + (append (loop (cadr m)) + (list (make-element 'superscript + (loop (caddr m)))) + (loop (cadddr m))))] + [(regexp-match #px"^(.*)([()0-9{}\\[\\]\u03C0])(.*)$" i) + => (lambda (m) + (append (loop (cadr m)) + (list (caddr m)) + (loop (cadddr m))))] + [else + (list (make-element 'italic (list i)))])] + [(eq? i 'rsquo) (list 'prime)] + [else (list i)]))) + c)))) + +;; ---------------------------------------- + +(provide cite + bib-entry + (rename-out [a-bib-entry? bib-entry?]) + bibliography) + +(define (cite key . keys) + (make-element + #f + (list "[" + (let loop ([keys (cons key keys)]) + (if (null? (cdr keys)) + (make-link-element + #f + (list (car keys)) + `(cite ,(car keys))) + (make-element + #f + (list (loop (list (car keys))) + ", " + (loop (cdr keys)))))) + "]"))) + +(define-struct a-bib-entry (key val)) + +(define (bib-entry #:key key + #:title title + #:is-book? [is-book? #f] + #:author [author #f] + #:location [location #f] + #:date [date #f] + #:url [url #f]) + (make-a-bib-entry + key + (make-element + #f + (append + (if author `(,@(decode-content (list author)) ", ") null) + (if is-book? null '(ldquo)) + (if is-book? + (list (italic title)) + (decode-content (list title))) + (if location '(",") '(".")) + (if is-book? null '(rdquo)) + (if location + `(" " ,@(decode-content (list location)) ,(if date "," ".")) + null) + (if date `(" " ,@(decode-content (list date)) ".") null) + (if url `(" " ,(link url (tt url))) null))))) + +(define (bibliography #:tag [tag "doc-bibliography"] . citations) + (make-unnumbered-part + #f + `((part ,tag)) + '("Bibliography") + '() + null + (make-flow + (list + (make-table + "bibliography" + (map (lambda (c) + (let ([key (a-bib-entry-key c)] + [val (a-bib-entry-val c)]) + (list + (to-flow (make-target-element #f `("[" ,key "]") `(cite ,key))) + flow-spacer + (to-flow val)))) + citations)))) + null)) + +;; ---------------------------------------- + +(provide defclass + defclass/title + definterface + definterface/title + defmixin + defmixin/title + defconstructor + defconstructor/make + defconstructor*/make + defconstructor/auto-super + defmethod + defmethod* + methspec + methimpl + this-obj) + +(define-syntax-parameter current-class #f) + +(define-struct decl (name super app-mixins intfs ranges mk-head body)) +(define-struct constructor (def)) +(define-struct meth (names mode desc def)) +(define-struct spec (def)) +(define-struct impl (def)) + +(define (id-info id) + (let ([b (identifier-label-binding id)]) + (if b + (list (let ([p (resolved-module-path-name (module-path-index-resolve + (caddr b)))]) + (if (path? p) + (intern-taglet (path->main-collects-relative p)) + p)) + (list-ref b 3) + (list-ref b 4) + (list-ref b 5) + (list-ref b 6)) + (error 'scribble "no class/interface/mixin information for identifier: ~e" + id)))) + +(define-serializable-struct cls/intf + (name-element app-mixins super intfs methods)) + +(define (make-inherited-table r d ri decl) + (define start + (let ([key (find-scheme-tag d ri (decl-name decl) #f)]) + (if key (list (cons key (lookup-cls/intf d ri key))) null))) + (define supers + (if (null? start) + null + (cdr + (let loop ([supers start][accum null]) + (cond + [(null? supers) (reverse accum)] + [(memq (car supers) accum) + (loop (cdr supers) accum)] + [else + (let ([super (car supers)]) + (loop (append (filter-map + (lambda (i) + (let ([key (find-scheme-tag d ri i #f)]) + (and key + (cons key (lookup-cls/intf d ri key))))) + (append + (reverse (cls/intf-intfs (cdr super))) + (if (cls/intf-super (cdr super)) + (list (cls/intf-super (cdr super))) + null) + (reverse (cls/intf-app-mixins (cdr super))))) + (cdr supers)) + (cons super accum)))]))))) + (define ht + (let ([ht (make-hasheq)]) + (for* ([i (decl-body decl)] + #:when (meth? i) + [name (meth-names i)]) + (hash-set! ht name #t)) + ht)) + (define inh + (append-map + (lambda (super) + (let ([inh (filter-map + (lambda (k) + (if (hash-ref ht k #f) + #f + (begin (hash-set! ht k #t) + (cons (symbol->string k) + (**method k (car super)))))) + (cls/intf-methods (cdr super)))]) + (if (null? inh) + null + (cons (make-element #f (list (make-element "inheritedlbl" '("from ")) + (cls/intf-name-element (cdr super)))) + (map cdr (sort inh stringstring (syntax-e (decl-name decl)))) + tag))) + (map id-info (decl-app-mixins decl)) + (and (decl-super decl) + (not (free-label-identifier=? (quote-syntax object%) + (decl-super decl))) + (id-info (decl-super decl))) + (map id-info (decl-intfs decl)) + (append-map (lambda (m) + (let loop ([l (meth-names m)]) + (cond [(null? l) null] + [(memq (car l) (cdr l)) (loop (cdr l))] + [else (cons (car l) (loop (cdr l)))]))) + (filter meth? (decl-body decl))))))))))) + +(define (build-body decl body) + `(,@(map (lambda (i) + (cond [(constructor? i) ((constructor-def i))] + [(meth? i) ((meth-def i) (meth-desc i))] + [else i])) + body) + ,(make-delayed-block (lambda (r d ri) (make-inherited-table r d ri decl))))) + +(define (*include-class/title decl) + (make-splice + (list* (title #:style 'hidden (to-element (decl-name decl))) + (make-decl-collect decl) + (build-body decl (append ((decl-mk-head decl) #t) + (decl-body decl)))))) + +(define (*include-class decl) + (make-splice + (cons + (make-decl-collect decl) + (append + ((decl-mk-head decl) #f) + (list + (make-blockquote + "leftindent" + (flow-paragraphs + (decode-flow (build-body decl (decl-body decl)))))))))) + +(define (*class-doc kind stx-id super intfs ranges whole-page? make-index-desc) + (make-table + 'boxed + (append + (list + (list (make-flow (list - (list (make-flow - (list - (t (hspace 2) "superclass:" spacer (to-element super)))))) - null) - (let ([show-intfs - (lambda (intfs range?) - (if (null? intfs) - null - (list - (list - (make-flow - (list - (make-table #f - (cons - (list (make-flow (list (make-paragraph (list (hspace 2) - (case kind - [(interface) "implements:"] - [(class) "extends:"] - [(mixin) - (if range? - "result implements:" - "argument extends/implements:")]) - spacer)))) - (make-flow (list (make-paragraph (list (to-element (car intfs))))))) - (map (lambda (i) - (list (make-flow (list (make-paragraph (list spacer)))) - (make-flow (list (make-paragraph (list (to-element i))))))) - (cdr intfs))))))))))]) - (append - (show-intfs intfs #f) - (show-intfs ranges #t))))))) + (make-paragraph + (list (let ([target-maker (id-to-target-maker stx-id #t)] + [content (list (annote-exporting-library + (to-element stx-id)))]) + (if target-maker + (target-maker + content + (lambda (tag) + ((if whole-page? + make-page-target-element + make-toc-target-element) + #f + (list + (make-index-element + #f content tag + (list (symbol->string (syntax-e stx-id))) + content + (with-exporting-libraries + (lambda (libs) + (make-index-desc (syntax-e stx-id) libs))))) + tag))) + (car content))) + spacer ":" spacer + (case kind + [(class) (scheme class?)] + [(interface) (scheme interface?)] + [(mixin) (schemeblockelem (class? . -> . class?))]))))))) + (if super + (list + (list (make-flow + (list (t (hspace 2) "superclass:" spacer (to-element super)))))) + null) + (let ([show-intfs + (lambda (intfs range?) + (if (null? intfs) + null + (list + (list + (make-flow + (list + (make-table + #f + (cons + (list (make-flow + (list (make-paragraph + (list (hspace 2) + (case kind + [(interface) "implements:"] + [(class) "extends:"] + [(mixin) + (if range? + "result implements:" + "argument extends/implements:")]) + spacer)))) + (to-flow (to-element (car intfs)))) + (map (lambda (i) + (list flow-spacer (to-flow (to-element i)))) + (cdr intfs))))))))))]) + (append (show-intfs intfs #f) (show-intfs ranges #t)))))) - (define-syntax extract-super - (syntax-rules () - [(_ (mixin base)) - (extract-super base)] - [(_ super) - (quote-syntax/loc super)])) +(define-syntax extract-super + (syntax-rules () + [(_ (mixin base)) (extract-super base)] + [(_ super) (quote-syntax/loc super)])) - (define-syntax extract-app-mixins - (syntax-rules () - [(_ (mixin base)) - (cons (quote-syntax/loc mixin) - (extract-app-mixins base))] - [(_ super) - null])) +(define-syntax extract-app-mixins + (syntax-rules () + [(_ (mixin base)) (cons (quote-syntax/loc mixin) (extract-app-mixins base))] + [(_ super) null])) - (define (flatten-splices l) - (let loop ([l l]) - (cond - [(null? l) null] - [(splice? (car l)) - (append (splice-run (car l)) - (loop (cdr l)))] - [else (cons (car l) (loop (cdr l)))]))) +(define (flatten-splices l) + (let loop ([l l]) + (cond [(null? l) null] + [(splice? (car l)) (append (splice-run (car l)) (loop (cdr l)))] + [else (cons (car l) (loop (cdr l)))]))) - (define-syntax *defclass - (syntax-rules () - [(_ *include-class name super (intf ...) body ...) - (*include-class - (syntax-parameterize ([current-class (quote-syntax name)]) - (make-decl (quote-syntax/loc name) - (extract-super super) - (extract-app-mixins super) - (list (quote-syntax/loc intf) ...) - null - (lambda (whole-page?) - (list - (*class-doc 'class +(define-syntax-rule (*defclass *include-class name super (intf ...) body ...) + (*include-class + (syntax-parameterize ([current-class (quote-syntax name)]) + (make-decl (quote-syntax/loc name) + (extract-super super) + (extract-app-mixins super) + (list (quote-syntax/loc intf) ...) + null + (lambda (whole-page?) + (list (*class-doc 'class (quote-syntax/loc name) (quote-syntax/loc super) (list (quote-syntax intf) ...) null whole-page? make-class-index-desc))) - (flatten-splices (list body ...)))))])) + (flatten-splices (list body ...)))))) - (define-syntax defclass - (syntax-rules () - [(_ name super (intf ...) body ...) - (*defclass *include-class name super (intf ...) body ...)])) +(define-syntax-rule (defclass name super (intf ...) body ...) + (*defclass *include-class name super (intf ...) body ...)) - (define-syntax defclass/title - (syntax-rules () - [(_ name super (intf ...) body ...) - (*defclass *include-class/title name super (intf ...) body ...)])) +(define-syntax-rule (defclass/title name super (intf ...) body ...) + (*defclass *include-class/title name super (intf ...) body ...)) - (define-syntax *definterface - (syntax-rules () - [(_ *include-class name (intf ...) body ...) - (*include-class - (syntax-parameterize ([current-class (quote-syntax name)]) - (make-decl (quote-syntax/loc name) - #f - null - (list (quote-syntax/loc intf) ...) - null - (lambda (whole-page?) +(define-syntax-rule (*definterface *include-class name (intf ...) body ...) + (*include-class + (syntax-parameterize ([current-class (quote-syntax name)]) + (make-decl (quote-syntax/loc name) + #f + null + (list (quote-syntax/loc intf) ...) + null + (lambda (whole-page?) + (list + (*class-doc 'interface + (quote-syntax/loc name) + #f + (list (quote-syntax intf) ...) + null + whole-page? + make-interface-index-desc))) + (list body ...))))) + +(define-syntax-rule (definterface name (intf ...) body ...) + (*definterface *include-class name (intf ...) body ...)) + +(define-syntax-rule (definterface/title name (intf ...) body ...) + (*definterface *include-class/title name (intf ...) body ...)) + +(define-syntax-rule (*defmixin *include-class name (domain ...) (range ...) + body ...) + (*include-class + (syntax-parameterize ([current-class (quote-syntax name)]) + (make-decl (quote-syntax/loc name) + #f + null + (list (quote-syntax/loc domain) ...) + (list (quote-syntax/loc range) ...) + (lambda (whole-page?) + (list + (*class-doc 'mixin + (quote-syntax/loc name) + #f + (list (quote-syntax domain) ...) + (list (quote-syntax range) ...) + whole-page? + make-mixin-index-desc))) + (list body ...))))) + +(define-syntax-rule (defmixin name (domain ...) (range ...) body ...) + (*defmixin *include-class name (domain ...) (range ...) body ...)) + +(define-syntax-rule (defmixin/title name (domain ...) (range ...) body ...) + (*defmixin *include-class/title name (domain ...) (range ...) body ...)) + +(define-syntax (defconstructor*/* stx) + (syntax-case stx () + [(_ mode ((arg ...) ...) desc ...) + (let ([n (syntax-parameter-value #'current-class)]) + (with-syntax ([name n] + [result + (datum->syntax + #f (list - (*class-doc 'interface - (quote-syntax/loc name) - #f - (list (quote-syntax intf) ...) - null - whole-page? - make-interface-index-desc))) - (list body ...))))])) - - (define-syntax definterface - (syntax-rules () - [(_ name (intf ...) body ...) - (*definterface *include-class name (intf ...) body ...)])) + (datum->syntax #'is-a?/c 'is-a?/c (list 'src 1 1 2 1)) + (datum->syntax n (syntax-e n) (list 'src 1 3 4 1))) + (list 'src 1 0 1 5))] + [(((kw ...) ...) ...) + (map (lambda (ids) + (map (lambda (arg) + (if (and (pair? (syntax-e arg)) + (eq? (syntax-e #'mode) 'new)) + (list (string->keyword + (symbol->string + (syntax-e + (car (syntax-e arg)))))) + null)) + (syntax->list ids))) + (syntax->list #'((arg ...) ...)))]) + #'(make-constructor (lambda () + (defproc* #:mode mode #:within name + [[(make [kw ... . arg] ...) result] ...] + desc ...)))))])) - (define-syntax definterface/title - (syntax-rules () - [(_ name (intf ...) body ...) - (*definterface *include-class/title name (intf ...) body ...)])) +(define-syntax (defconstructor stx) + (syntax-case stx () + [(_ ([id . arg-rest] ...) desc ...) + #'(defconstructor*/* new (([id . arg-rest] ...)) desc ...)])) - (define-syntax *defmixin - (syntax-rules () - [(_ *include-class name (domain ...) (range ...) body ...) - (*include-class - (syntax-parameterize ([current-class (quote-syntax name)]) - (make-decl (quote-syntax/loc name) - #f - null - (list (quote-syntax/loc domain) ...) - (list (quote-syntax/loc range) ...) - (lambda (whole-page?) - (list - (*class-doc 'mixin - (quote-syntax/loc name) - #f - (list (quote-syntax domain) ...) - (list (quote-syntax range) ...) - whole-page? - make-mixin-index-desc))) - (list body ...))))])) +(define-syntax (defconstructor/make stx) + (syntax-case stx () + [(_ ([id . arg-rest] ...) desc ...) + #'(defconstructor*/* make (([id . arg-rest] ...)) desc ...)])) - (define-syntax defmixin - (syntax-rules () - [(_ name (domain ...) (range ...) body ...) - (*defmixin *include-class name (domain ...) (range ...) body ...)])) +(define-syntax (defconstructor*/make stx) + (syntax-case stx () + [(_ (([id . arg-rest] ...) ...) desc ...) + #'(defconstructor*/* make (([id . arg-rest] ...) ...) desc ...)])) - (define-syntax defmixin/title - (syntax-rules () - [(_ name (domain ...) (range ...) body ...) - (*defmixin *include-class/title name (domain ...) (range ...) body ...)])) +(define-syntax (defconstructor/auto-super stx) + (syntax-case stx () + [(_ ([id . arg-rest] ...) desc ...) + #'(defconstructor*/* new (([id . arg-rest] ... _...superclass-args...)) + desc ...)])) - (define-syntax (defconstructor*/* stx) - (syntax-case stx () - [(_ mode ((arg ...) ...) desc ...) - (let ([n (syntax-parameter-value #'current-class)]) - (with-syntax ([name n] - [result (datum->syntax #f - (list - (datum->syntax #'is-a?/c - 'is-a?/c - (list 'src 1 1 2 1)) - (datum->syntax n - (syntax-e n) - (list 'src 1 3 4 1))) - (list 'src 1 0 1 5))] - [(((kw ...) ...) ...) (map (lambda (ids) - (map (lambda (arg) - (if (and (pair? (syntax-e arg)) - (eq? (syntax-e #'mode) 'new)) - (list (string->keyword (symbol->string - (syntax-e - (car (syntax-e arg)))))) - null)) - (syntax->list ids))) - (syntax->list #'((arg ...) ...)))]) - #'(make-constructor (lambda () - (defproc* #:mode mode #:within name [[(make [kw ... . arg] ...) result] ...] - desc ...)))))])) +(define-syntax (defmethod* stx) + (syntax-case stx () + [(_ #:mode mode ([(name arg ...) result-type] ...) desc ...) + (with-syntax ([cname (syntax-parameter-value #'current-class)] + [name1 (car (syntax->list #'(name ...)))]) + (with-syntax ([(extra ...) + (case (syntax-e #'mode) + [(pubment) + #'((t "Refine this method with " + (scheme augment) "."))] + [(override extend augment) + #'((t (case (syntax-e #'mode) + [(override) "Overrides "] + [(extend) "Extends "] + [(augment) "Augments "]) + (*xmethod/super (quote-syntax/loc cname) 'name1) + "."))] + [else null])]) + #'(make-meth '(name ...) + 'mode + (lambda () + (make-splice + (append-map (lambda (f) + (cond [(impl? f) ((impl-def f))] + [(spec? f) ((spec-def f))] + [else (list f)])) + (list extra ... desc ...)))) + (lambda (desc-splice) + (defproc* #:mode send #:within cname + ([(name arg ...) result-type] ...) + (desc-splice))))))] + [(_ ([(name arg ...) result-type] ...) desc ...) + #'(defmethod* #:mode public ([(name arg ...) result-type] ...) desc ...)])) - (define-syntax (defconstructor stx) - (syntax-case stx () - [(_ ([id . arg-rest] ...) desc ...) - #'(defconstructor*/* new (([id . arg-rest] ...)) desc ...)])) +(define-syntax defmethod + (syntax-rules () + [(_ #:mode mode (name arg ...) result-type desc ...) + (defmethod* #:mode mode ([(name arg ...) result-type]) desc ...)] + [(_ (name arg ...) result-type desc ...) + (defmethod #:mode public (name arg ...) result-type desc ...)])) - (define-syntax (defconstructor/make stx) - (syntax-case stx () - [(_ ([id . arg-rest] ...) desc ...) - #'(defconstructor*/* make (([id . arg-rest] ...)) desc ...)])) +(define-syntax-rule (methimpl body ...) + (make-impl (lambda () (list (italic "Default implementation:") body ...)))) - (define-syntax (defconstructor*/make stx) - (syntax-case stx () - [(_ (([id . arg-rest] ...) ...) desc ...) - #'(defconstructor*/* make (([id . arg-rest] ...) ...) desc ...)])) +(define-syntax-rule (methspec body ...) + (make-spec (lambda () (list (italic "Specification:") body ...)))) - (define-syntax (defconstructor/auto-super stx) - (syntax-case stx () - [(_ ([id . arg-rest] ...) desc ...) - #'(defconstructor*/* new (([id . arg-rest] ... _...superclass-args...)) desc ...)])) +(define (*this-obj cname) + (name-this-object cname)) - (define-syntax (defmethod* stx) - (syntax-case stx () - [(_ #:mode mode ([(name arg ...) result-type] ...) desc ...) - (with-syntax ([cname (syntax-parameter-value #'current-class)] - [name1 (car (syntax->list #'(name ...)))]) - (with-syntax ([(extra ...) (case (syntax-e #'mode) - [(pubment) - #'((t "Refine this method with " (scheme augment) "."))] - [(override extend augment) - #'((t (case (syntax-e #'mode) - [(override) "Overrides "] - [(extend) "Extends "] - [(augment) "Augments "]) - (*xmethod/super (quote-syntax/loc cname) 'name1) "."))] - [else - null])]) - #'(make-meth '(name ...) - 'mode - (lambda () (make-splice (apply - append - (map (lambda (f) - (cond - [(impl? f) ((impl-def f))] - [(spec? f) ((spec-def f))] - [else (list f)])) - (list extra ... desc ...))))) - (lambda (desc-splice) - (defproc* #:mode send #:within cname ([(name arg ...) result-type] ...) - (desc-splice))))))] - [(_ ([(name arg ...) result-type] ...) desc ...) - #'(defmethod* #:mode public ([(name arg ...) result-type] ...) desc ...)])) +(define-syntax (this-obj stx) + (syntax-case stx () + [(_) + (with-syntax ([cname (syntax-parameter-value #'current-class)]) + #'(*this-obj 'cname))])) - (define-syntax defmethod - (syntax-rules () - [(_ #:mode mode (name arg ...) result-type desc ...) - (defmethod* #:mode mode ([(name arg ...) result-type]) desc ...)] - [(_ (name arg ...) result-type desc ...) - (defmethod #:mode public (name arg ...) result-type desc ...)])) - - (define-syntax methimpl - (syntax-rules () - [(_ body ...) (make-impl (lambda () (list (italic "Default implementation:") body ...)))])) - - (define-syntax methspec - (syntax-rules () - [(_ body ...) (make-spec (lambda () (list (italic "Specification:") body ...)))])) - - (define (*this-obj cname) - (name-this-object cname)) - - (define-syntax (this-obj stx) - (syntax-case stx () - [(_) - (with-syntax ([cname (syntax-parameter-value #'current-class)]) - #'(*this-obj 'cname))])) - - (define (*xmethod/super cname name) - (let ([get - (lambda (d ri key) - (if key - (let ([v (lookup-cls/intf d ri key)]) - (if v - (append (cls/intf-app-mixins v) - (cons (cls/intf-super v) - (cls/intf-intfs v))) - null)) - null))]) - (make-delayed-element - (lambda (r d ri) - (let loop ([search (get d ri (find-scheme-tag d ri cname #f))]) - (cond - [(null? search) - (list (make-element #f '("")))] - [(not (car search)) - (loop (cdr search))] - [else - (let* ([a-key (find-scheme-tag d ri (car search) #f)] - [v (and a-key (lookup-cls/intf d ri a-key))]) +(define (*xmethod/super cname name) + (let ([get + (lambda (d ri key) + (if key + (let ([v (lookup-cls/intf d ri key)]) (if v - (if (member name (cls/intf-methods v)) - (list - (make-element #f - (list (**method name a-key) - " in " - (cls/intf-name-element v)))) - (loop (append (cdr search) (get d ri (find-scheme-tag d ri (car search) #f))))) - (loop (cdr search))))]))) - (lambda () (format "~a in ~a" (syntax-e cname) name)) - (lambda () (format "~a in ~a" (syntax-e cname) name))))) + (append (cls/intf-app-mixins v) + (cons (cls/intf-super v) + (cls/intf-intfs v))) + null)) + null))]) + (make-delayed-element + (lambda (r d ri) + (let loop ([search (get d ri (find-scheme-tag d ri cname #f))]) + (cond + [(null? search) + (list (make-element #f '("")))] + [(not (car search)) + (loop (cdr search))] + [else + (let* ([a-key (find-scheme-tag d ri (car search) #f)] + [v (and a-key (lookup-cls/intf d ri a-key))]) + (if v + (if (member name (cls/intf-methods v)) + (list + (make-element #f + (list (**method name a-key) + " in " + (cls/intf-name-element v)))) + (loop (append (cdr search) + (get d ri (find-scheme-tag d ri (car search) + #f))))) + (loop (cdr search))))]))) + (lambda () (format "~a in ~a" (syntax-e cname) name)) + (lambda () (format "~a in ~a" (syntax-e cname) name))))) - (define (lookup-cls/intf d ri tag) - (let ([v (resolve-get d ri `(cls/intf ,(cadr tag)))]) - (or v - (make-cls/intf "unknown" - null - #f - null - null)))) +(define (lookup-cls/intf d ri tag) + (let ([v (resolve-get d ri `(cls/intf ,(cadr tag)))]) + (or v (make-cls/intf "unknown" null #f null null)))) - ;; ---------------------------------------- +;; ---------------------------------------- - (provide defsignature - defsignature/splice - signature-desc) +(provide defsignature + defsignature/splice + signature-desc) - (define-syntax defsignature - (syntax-rules () - [(_ name (super ...) body ...) - (*defsignature - (quote-syntax name) - (list (quote-syntax super) ...) - (lambda () - (list body ...)) - #t)])) +(define-syntax-rule (defsignature name (super ...) body ...) + (*defsignature (quote-syntax name) + (list (quote-syntax super) ...) + (lambda () (list body ...)) + #t)) - (define-syntax defsignature/splice - (syntax-rules () - [(_ name (super ...) body ...) - (*defsignature - (quote-syntax name) - (list (quote-syntax super) ...) - (lambda () - (list body ...)) - #f)])) +(define-syntax-rule (defsignature/splice name (super ...) body ...) + (*defsignature (quote-syntax name) + (list (quote-syntax super) ...) + (lambda () (list body ...)) + #f)) - (define-struct sig-desc (in)) - (define (signature-desc . l) - (make-sig-desc l)) +(define-struct sig-desc (in)) +(define (signature-desc . l) + (make-sig-desc l)) - (define (*defsignature stx-id supers body-thunk indent?) - (*defthing (list stx-id) - (list (syntax-e stx-id)) - #t - (list (make-element #f '("signature"))) - (lambda () - (let ([in (parameterize ([current-signature (make-sig stx-id)]) - (body-thunk))]) - (if indent? - (let-values ([(pre-body post-body) - (let loop ([in in][pre-accum null]) - (cond - [(null? in) (values (reverse pre-accum) null)] - [(whitespace? (car in)) - (loop (cdr in) (cons (car in) - pre-accum))] - [(sig-desc? (car in)) - (loop (cdr in) (append (reverse (sig-desc-in (car in))) - pre-accum))] - [else - (values (reverse pre-accum) in)]))]) - (append - pre-body - (list - (make-blockquote - "leftindent" - (flow-paragraphs - (decode-flow - post-body)))))) - in))))) - - ;; ---------------------------------------- +(define (*defsignature stx-id supers body-thunk indent?) + (*defthing + (list stx-id) + (list (syntax-e stx-id)) + #t + (list (make-element #f '("signature"))) + (lambda () + (define in + (parameterize ([current-signature (make-sig stx-id)]) (body-thunk))) + (if indent? + (let-values ([(pre-body post-body) + (let loop ([in in][pre-accum null]) + (cond [(null? in) (values (reverse pre-accum) null)] + [(whitespace? (car in)) + (loop (cdr in) (cons (car in) pre-accum))] + [(sig-desc? (car in)) + (loop (cdr in) + (append (reverse (sig-desc-in (car in))) + pre-accum))] + [else (values (reverse pre-accum) in)]))]) + `(,@pre-body + ,(make-blockquote + "leftindent" + (flow-paragraphs (decode-flow post-body))))) + in)))) - ) +;; ----------------------------------------