2528 lines
114 KiB
Scheme
2528 lines
114 KiB
Scheme
|
|
(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 PLaneT)
|
|
(define PLaneT "PLaneT")
|
|
|
|
(provide etc)
|
|
(define etc "etc.") ; so we can fix the latex space, one day
|
|
|
|
(define-code schemeblock0 to-paragraph)
|
|
(define-code schemeblock (to-paragraph/prefix (hspace 2)
|
|
(hspace 2)
|
|
""))
|
|
(define-code SCHEMEBLOCK (to-paragraph/prefix (hspace 2)
|
|
(hspace 2)
|
|
"")
|
|
UNSYNTAX)
|
|
(define-code SCHEMEBLOCK0 to-paragraph UNSYNTAX)
|
|
(define-code schemeinput (to-paragraph/prefix (make-element
|
|
#f
|
|
(list
|
|
(hspace 2)
|
|
(make-element 'tt (list "> " ))))
|
|
(hspace 4)
|
|
""))
|
|
|
|
(define-syntax (schememod stx)
|
|
(syntax-case stx ()
|
|
[(_ lang rest ...)
|
|
(with-syntax ([modtag (datum->syntax
|
|
#'here
|
|
`(unsyntax (make-element
|
|
#f
|
|
(list (hash-lang)
|
|
(hspace 1)
|
|
(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
|
|
(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 (litchar . strs)
|
|
(unless (andmap string? strs)
|
|
(raise-type-error 'litchar "strings" strs))
|
|
(let ([s (apply string-append
|
|
(map (lambda (s) (if (string=? s "\n") " " s))
|
|
strs))])
|
|
(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 (verbatim s)
|
|
(let ([strs (regexp-split #rx"\n" s)])
|
|
(make-table
|
|
#f
|
|
(map (lambda (s)
|
|
(list (make-flow (list (make-paragraph
|
|
(let loop ([s s])
|
|
(let ([spaces (regexp-match-positions #rx"(?:^| ) +" s)])
|
|
(if spaces
|
|
(append
|
|
(loop (substring s 0 (caar spaces)))
|
|
(list (hspace (- (cdar spaces) (caar spaces))))
|
|
(loop (substring s (cdar spaces))))
|
|
(list (make-element 'tt (list s)))))))))))
|
|
strs))))
|
|
|
|
(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 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 filename-relative-to-source . alt)
|
|
(centerline ;; this doesn't do anything?
|
|
(make-element
|
|
(make-image-file filename-relative-to-source)
|
|
(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)
|
|
(make-element 'tt (decode-content 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 "#<procedure:") (decode-content str) (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-table 'equal))
|
|
|
|
(define (libs->taglet id libs source-libs)
|
|
(let ([lib
|
|
(or (ormap (lambda (lib)
|
|
(let ([checker (hash-table-get 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-table-put! checkers lib checker)
|
|
checker))))])
|
|
(and (checker id)
|
|
lib)))
|
|
source-libs)
|
|
(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 (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))
|
|
`(dep ,(list lib-taglet (syntax-e id)))))))
|
|
content)))
|
|
(lambda () (car content))
|
|
(lambda () (car content))))))
|
|
|
|
(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 'for-label)]
|
|
[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 'for-label)])
|
|
(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
|
|
schemegrammar schemegrammar*
|
|
var svar void-const undefined-const)
|
|
|
|
(define-syntax declare-exporting
|
|
(syntax-rules ()
|
|
[(_ lib ... #:use-sources (plib ...)) (*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 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 "#<void>"))
|
|
(define undefined-const
|
|
(schemeresultfont "#<undefined>"))
|
|
|
|
(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 ()
|
|
[(_ 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 ()
|
|
[(_ #:literals (lit ...) [spec spec1 ...] ([non-term-id non-term-form ...] ...) desc ...)
|
|
(with-syntax ([new-spec
|
|
(syntax-case #'spec ()
|
|
[(name . rest)
|
|
(datum->syntax #'spec
|
|
(cons
|
|
(datum->syntax #'here
|
|
'(unsyntax x)
|
|
#'name)
|
|
#'rest)
|
|
#'spec)])]
|
|
[spec-id
|
|
(syntax-case #'spec ()
|
|
[(name . rest) #'name])])
|
|
#'(*defforms (quote-syntax/loc spec-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 [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 ()
|
|
[(_ #:literals lits [spec ...] desc ...) #'(defform*/subs #:literals lits [spec ...] () desc ...)]
|
|
[(_ [spec ...] desc ...) #'(defform*/subs [spec ...] () desc ...)]))
|
|
(define-syntax (defform stx)
|
|
(syntax-case stx ()
|
|
[(_ #:literals (lit ...) spec desc ...) #'(defform*/subs #:literals (lit ...) [spec] () desc ...)]
|
|
[(_ spec desc ...) #'(defform*/subs [spec] () desc ...)]))
|
|
(define-syntax (defform/subs stx)
|
|
(syntax-case stx ()
|
|
[(_ #: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 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)
|
|
(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?)
|
|
(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?)))
|
|
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)))))
|
|
(not (pair? (cadr p))))])
|
|
(cons a
|
|
(loop (cdr p)
|
|
(and (arg-optional? a)
|
|
(not (arg-ends-optional? a))))))]))))))]
|
|
[prototype-size (lambda (args first-combine next-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)))))])))))))]
|
|
[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 + +)
|
|
(prototype-depth prototype)
|
|
(element-width tagged))]
|
|
[(short?) (or (flat-size . < . 40)
|
|
((length args) . < . 2))]
|
|
[(res) (result-contract)]
|
|
[(result-next-line?) ((+ (if short?
|
|
flat-size
|
|
(+ (prototype-size args max max)
|
|
(prototype-depth prototype)
|
|
(element-width tagged)))
|
|
(flow-element-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?
|
|
(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))))
|
|
(let ([not-end
|
|
(if result-next-line?
|
|
(list (to-flow spacer))
|
|
(list (to-flow spacer)
|
|
(to-flow spacer)
|
|
(to-flow spacer)
|
|
(to-flow spacer)))])
|
|
(list
|
|
(make-table
|
|
"prototype"
|
|
(cons
|
|
(list* (to-flow (make-element
|
|
#f
|
|
(list
|
|
(schemeparenfont (make-string (add1 (prototype-depth prototype)) #\())
|
|
tagged)))
|
|
(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)
|
|
(let loop ([args (cdr args)])
|
|
(if (null? args)
|
|
null
|
|
(let ([dots-next? (or (and (pair? (cdr args))
|
|
(arg-special? (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)))
|
|
(flow-element-width arg-cont))]
|
|
[arg-val (and arg-val (arg-val))]
|
|
[def-len (if (arg-optional? arg)
|
|
(flow-element-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 (flow-element? 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
|
|
(apply
|
|
append
|
|
(map (lambda (form)
|
|
(let loop ([form (cons (if kw-id
|
|
(if (pair? form)
|
|
(cdr form)
|
|
null)
|
|
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])))
|
|
forms))])
|
|
(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 (if (pair? form)
|
|
(car form)
|
|
form)
|
|
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 (list (hspace 2) (apply tt 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 'for-label)
|
|
(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"^(.*)([()0-9{}\\[\\]])(.*)$" 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
|
|
#: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)
|
|
(list 'ldquo)
|
|
(decode-content (list title))
|
|
(list (if location
|
|
","
|
|
".")
|
|
'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 (name 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))
|
|
(cadddr b)
|
|
(list-ref b 5))
|
|
(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) 'for-label)])
|
|
(if key
|
|
(list (cons key (lookup-cls/intf d ri key)))
|
|
null))]
|
|
[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 values
|
|
(map (lambda (i)
|
|
(let ([key (find-scheme-tag d ri i 'for-label)])
|
|
(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-hash-table)])
|
|
(for-each (lambda (i)
|
|
(when (meth? i)
|
|
(hash-table-put! ht (meth-name i) #t)))
|
|
(decl-body decl))
|
|
ht)]
|
|
[inh (apply
|
|
append
|
|
(map (lambda (super)
|
|
(let ([inh (filter
|
|
values
|
|
(map
|
|
(lambda (k)
|
|
(if (hash-table-get ht k #f)
|
|
#f
|
|
(begin
|
|
(hash-table-put! 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)
|
|
(string<? (car a) (car b)))))))))
|
|
supers))])
|
|
(if (null? inh)
|
|
(make-auxiliary-table "inherited" null)
|
|
(make-auxiliary-table
|
|
"inherited"
|
|
(map (lambda (i)
|
|
(list (make-flow (list (make-paragraph (list i))))))
|
|
(cons (make-element "inheritedlbl" '("Inherited methods:")) inh))))))
|
|
|
|
(define (make-decl-collect decl)
|
|
(make-part-collect-decl
|
|
((id-to-target-maker (decl-name decl) #f)
|
|
(list "ignored")
|
|
(lambda (tag)
|
|
(make-collect-element
|
|
#f null
|
|
(lambda (ci)
|
|
(collect-put! ci
|
|
`(cls/intf ,(cadr tag))
|
|
(make-cls/intf
|
|
(make-element
|
|
"schemesymbol"
|
|
(list (make-link-element
|
|
"schemevaluelink"
|
|
(list (symbol->string (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))
|
|
(map (lambda (m)
|
|
(meth-name m))
|
|
(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-flow-element
|
|
(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)
|
|
(let ([spacer (hspace 1)])
|
|
(make-table
|
|
'boxed
|
|
(append
|
|
(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
|
|
(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)))))))
|
|
|
|
(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 *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
|
|
(quote-syntax/loc name)
|
|
(quote-syntax/loc super)
|
|
(list (quote-syntax intf) ...)
|
|
null
|
|
whole-page?
|
|
make-class-index-desc)))
|
|
(list body ...))))]))
|
|
|
|
(define-syntax defclass
|
|
(syntax-rules ()
|
|
[(_ 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 *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?)
|
|
(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 ...)]))
|
|
|
|
(define-syntax definterface/title
|
|
(syntax-rules ()
|
|
[(_ name (intf ...) body ...)
|
|
(*definterface *include-class/title name (intf ...) body ...)]))
|
|
|
|
(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 defmixin
|
|
(syntax-rules ()
|
|
[(_ name (domain ...) (range ...) body ...)
|
|
(*defmixin *include-class name (domain ...) (range ...) body ...)]))
|
|
|
|
(define-syntax defmixin/title
|
|
(syntax-rules ()
|
|
[(_ 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
|
|
(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 (defconstructor stx)
|
|
(syntax-case stx ()
|
|
[(_ ([id . arg-rest] ...) desc ...)
|
|
#'(defconstructor*/* new (([id . arg-rest] ...)) desc ...)]))
|
|
|
|
(define-syntax (defconstructor/make stx)
|
|
(syntax-case stx ()
|
|
[(_ ([id . arg-rest] ...) desc ...)
|
|
#'(defconstructor*/* make (([id . arg-rest] ...)) desc ...)]))
|
|
|
|
(define-syntax (defconstructor*/make stx)
|
|
(syntax-case stx ()
|
|
[(_ (([id . arg-rest] ...) ...) desc ...)
|
|
#'(defconstructor*/* make (([id . arg-rest] ...) ...) desc ...)]))
|
|
|
|
(define-syntax (defconstructor/auto-super stx)
|
|
(syntax-case stx ()
|
|
[(_ ([id . arg-rest] ...) desc ...)
|
|
#'(defconstructor*/* new (([id . arg-rest] ... _...superclass-args...)) 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 'name1
|
|
'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 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 'for-label))])
|
|
(cond
|
|
[(null? search)
|
|
(list (make-element #f '("<method not found>")))]
|
|
[(not (car search))
|
|
(loop (cdr search))]
|
|
[else
|
|
(let* ([a-key (find-scheme-tag d ri (car search) 'for-label)]
|
|
[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) 'for-label)))))
|
|
(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))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(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 defsignature/splice
|
|
(syntax-rules ()
|
|
[(_ 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 (*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)))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
)
|