146 lines
4.8 KiB
Scheme
146 lines
4.8 KiB
Scheme
#lang scheme/base
|
|
(require "../decode.ss"
|
|
"../struct.ss"
|
|
"../scheme.ss"
|
|
"../search.ss"
|
|
"../basic.ss"
|
|
scheme/list
|
|
"manual-utils.ss"
|
|
"manual-style.ss"
|
|
(for-syntax scheme/base)
|
|
(for-label scheme/base))
|
|
|
|
(provide schemeblock SCHEMEBLOCK schemeblock/form
|
|
schemeblock0 SCHEMEBLOCK0 schemeblock0/form
|
|
schemeblockelem
|
|
schemeinput
|
|
schememod
|
|
scheme SCHEME scheme/form schemeresult schemeid schememodname
|
|
indexed-scheme
|
|
schemelink)
|
|
|
|
(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 interaction-prompt (make-element 'tt (list "> " )))
|
|
(define-code schemeinput
|
|
(to-paragraph/prefix
|
|
(make-element #f (list (hspace 2) interaction-prompt))
|
|
(hspace 4)
|
|
""))
|
|
|
|
(define-syntax (schememod stx)
|
|
(syntax-case stx ()
|
|
[(_ #:file filename lang rest ...)
|
|
(with-syntax ([modtag (datum->syntax
|
|
#'here
|
|
`(unsyntax (make-element
|
|
#f
|
|
(list (hash-lang)
|
|
spacer
|
|
(as-modname-link
|
|
',#'lang
|
|
(to-element ',#'lang)))))
|
|
#'lang)]
|
|
[(file ...)
|
|
(if (syntax-e #'filename)
|
|
(list
|
|
(datum->syntax
|
|
#'filename
|
|
`(code:comment (unsyntax (t "In \"" ,(syntax-e #'filename) "\":")))
|
|
#'filename))
|
|
null)])
|
|
(syntax/loc stx (schemeblock file ... modtag rest ...)))]
|
|
[(_ lang rest ...)
|
|
(syntax/loc stx (schememod #:file #f lang rest ...))]))
|
|
|
|
(define (to-element/result s)
|
|
(make-element "schemeresult" (list (to-element/no-color s))))
|
|
(define (to-element/id s)
|
|
(make-element "schemesymbol" (list (to-element/no-color s))))
|
|
|
|
(define-syntax (keep-s-expr stx)
|
|
(syntax-case stx ()
|
|
[(_ ctx s srcloc)
|
|
(let ([sv (syntax-e
|
|
(syntax-case #'s (quote)
|
|
[(quote s) #'s]
|
|
[_ #'s]))])
|
|
(if (or (number? sv)
|
|
(boolean? sv)
|
|
(and (pair? sv)
|
|
(identifier? (car sv))
|
|
(or (free-identifier=? #'cons (car sv))
|
|
(free-identifier=? #'list (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 (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 ()
|
|
[(_ 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)
|
|
|
|
(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))
|
|
|