243 lines
8.5 KiB
Scheme
243 lines
8.5 KiB
Scheme
#lang scheme/base
|
|
(require "../decode.ss"
|
|
"../struct.ss"
|
|
"../basic.ss"
|
|
scheme/list
|
|
scheme/string)
|
|
|
|
(provide PLaneT etc
|
|
litchar verbatim
|
|
image image/plain onscreen menuitem defterm emph
|
|
schemefont schemevalfont schemeresultfont schemeidfont schemevarfont
|
|
schemeparenfont schemekeywordfont schememetafont schememodfont
|
|
schemeerror
|
|
filepath exec envvar Flag DFlag PFlag DPFlag
|
|
indexed-file indexed-envvar
|
|
link procedure
|
|
idefterm
|
|
t inset-flow
|
|
pidefterm
|
|
hash-lang
|
|
centerline
|
|
commandline
|
|
elemtag elemref
|
|
secref seclink other-manual
|
|
margin-note
|
|
void-const undefined-const
|
|
math)
|
|
|
|
(define PLaneT "PLaneT")
|
|
|
|
(define etc "etc.") ; so we can fix the latex space, one day
|
|
|
|
(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-omitable-paragraph line))))))
|
|
(make-table #f (map make-line strs)))
|
|
|
|
;; 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 (clean-up-index-string
|
|
(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" `("#<procedure:" ,@(decode-content str) ">")))
|
|
|
|
(define (link url
|
|
#:underline? [underline? #t]
|
|
#:style [style (if underline? #f "plainlink")]
|
|
. str)
|
|
(make-element (make-target-url url style)
|
|
(decode-content str)))
|
|
|
|
(define (schemeerror . str)
|
|
(make-element "schemeerror" (decode-content str)))
|
|
|
|
(define (t . str)
|
|
(decode-paragraph str))
|
|
|
|
(define (inset-flow . c)
|
|
(make-blockquote "insetpara" (flow-paragraphs (decode-flow c))))
|
|
|
|
|
|
|
|
(define (centerline . s)
|
|
(make-table 'centered (list (list (make-flow (list (decode-paragraph s)))))))
|
|
|
|
(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)))
|
|
|
|
(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 (pidefterm . s)
|
|
(let ([c (apply defterm s)])
|
|
(index (string-append (content->string (element-content c)) "s")
|
|
c)))
|
|
|
|
(define (hash-lang)
|
|
(make-link-element
|
|
"schememodlink"
|
|
(list (schememodfont "#lang"))
|
|
`(part ,(doc-prefix '(lib "scribblings/guide/guide.scrbl") "hash-lang"))))
|
|
|
|
(define (margin-note . c)
|
|
(make-styled-paragraph
|
|
(list (make-element "refcolumn"
|
|
(list (make-element "refcontent" (decode-content c)))))
|
|
"refpara"))
|
|
|
|
(define void-const
|
|
(schemeresultfont "#<void>"))
|
|
(define undefined-const
|
|
(schemeresultfont "#<undefined>"))
|
|
|
|
(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)))) |