suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

Langify scribble modules

Browse Source
This commit is contained in:
Jack Firth 2019-10-09 21:57:16 -07:00 committed by Matthew Flatt
parent fb7106bc50
commit 3c62d4cd5d
5 changed files with 1511 additions and 1508 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
scribble-lib/scribble/bnf.rkt
View File

@ -1,5 +1,6 @@
(module bnf racket
(require scribble/decode
#lang racket
(require scribble/decode
(except-in scribble/struct
element?)
(only-in scribble/core
@ -9,7 +10,7 @@
make-table-columns)
)
(provide (contract-out
(provide (contract-out
[BNF (-> (cons/c (or/c block? content?)
(non-empty-listof (or/c block? content?)))
...
@ -40,18 +41,18 @@
))
(define spacer (make-element 'hspace (list " ")))
(define equals (make-element 'tt (list spacer "::=" spacer)))
(define alt (make-element 'tt (list spacer spacer "|" spacer spacer)))
(define spacer (make-element 'hspace (list " ")))
(define equals (make-element 'tt (list spacer "::=" spacer)))
(define alt (make-element 'tt (list spacer spacer "|" spacer spacer)))
(define (as-flow i) (make-flow (list (if (block? i)
(define (as-flow i) (make-flow (list (if (block? i)
i
(make-paragraph (list i))))))
(define baseline (make-style #f '(baseline)))
(define baseline (make-style #f '(baseline)))
(define (BNF . defns)
(define (BNF . defns)
(make-table
(make-style #f
(list
@ -68,54 +69,54 @@
more-rhs))])
defns))))
;; interleave : (listof content?) element? -> element?
(define (interleave l spacer)
;; interleave : (listof content?) element? -> element?
(define (interleave l spacer)
(make-element #f (cons (car l)
(apply append
(map (lambda (i)
(list spacer i))
(cdr l))))))
(define (BNF-seq . l)
(define (BNF-seq . l)
(if (null? l)
""
(interleave l spacer)))
(define (BNF-seq-lines . l)
(define (BNF-seq-lines . l)
(make-table #f (map (lambda (row) (list (as-flow (apply BNF-seq row))))
l)))
(define (BNF-alt . l)
(define (BNF-alt . l)
(interleave l alt))
(define (BNF-alt/close . l)
(define (BNF-alt/close . l)
(interleave l (make-element 'roman " | ")))
(define BNF-etc (make-element 'roman "..."))
(define BNF-etc (make-element 'roman "..."))
(define (nonterm . s)
(define (nonterm . s)
(make-element 'roman (append (list 'lang)
(list (make-element 'italic (decode-content s)))
(list 'rang))))
(define (optional . s)
(define (optional . s)
(make-element #f (append (list (make-element 'roman "["))
(decode-content s)
(list (make-element 'roman "]")))))
(define (BNF-group . s)
(define (BNF-group . s)
(make-element #f (append (list (make-element 'roman "{"))
(list (apply BNF-seq (decode-content s)))
(list (make-element 'roman "}")))))
(define (kleenestar . s)
(define (kleenestar . s)
(make-element #f (append (decode-content s) (list (make-element 'roman "*")))))
(define (kleeneplus . s)
(define (kleeneplus . s)
(make-element #f (append (decode-content s) (list (make-element 'superscript (list "+"))))))
(define (kleenerange a b . s)
(define (kleenerange a b . s)
(make-element #f (append (decode-content s)
(list (make-element 'roman
(make-element 'superscript
(list (format "{~a,~a}" a b)))))))))
(list (format "{~a,~a}" a b))))))))

25
scribble-lib/scribble/comment-reader.rkt
View File

@ -1,29 +1,30 @@
(module comment-reader scheme/base
(require (only-in racket/port peeking-input-port))
#lang scheme/base
(provide (rename-out [*read read]
(require (only-in racket/port peeking-input-port))
(provide (rename-out [*read read]
[*read-syntax read-syntax])
make-comment-readtable)
(define unsyntaxer (make-parameter 'unsyntax))
(define unsyntaxer (make-parameter 'unsyntax))
(define (*read [inp (current-input-port)])
(define (*read [inp (current-input-port)])
(parameterize ([unsyntaxer (read-unsyntaxer inp)]
[current-readtable (make-comment-readtable)])
(read/recursive inp)))
(define (*read-syntax src [port (current-input-port)])
(define (*read-syntax src [port (current-input-port)])
(parameterize ([unsyntaxer (read-unsyntaxer port)]
[current-readtable (make-comment-readtable)])
(read-syntax/recursive src port)))
(define (read-unsyntaxer port)
(define (read-unsyntaxer port)
(let ([p (peeking-input-port port)])
(if (eq? (read p) '#:escape-id)
(begin (read port) (read port))
'unsyntax)))
(define (make-comment-readtable #:readtable [rt (current-readtable)])
(define (make-comment-readtable #:readtable [rt (current-readtable)])
(make-readtable rt
#\; 'terminating-macro
(case-lambda
@ -37,7 +38,7 @@
v
(list src line col pos (and pos epos (- epos pos))))))])))
(define (do-comment port recur)
(define (do-comment port recur)
(let loop ()
(when (equal? #\; (peek-char port))
(read-char port)
@ -60,7 +61,7 @@
(cons (string c)
(loop))]))))))))
(define (append-strings l)
(define (append-strings l)
(let loop ([l l][s null])
(cond
[(null? l) (if (null? s)
@ -74,10 +75,10 @@
(car l)
(loop (cdr l) null)))])))
(define (preserve-space s)
(define (preserve-space s)
(let ([m (regexp-match-positions #rx" +" s)])
(if m
(append (preserve-space (substring s 0 (caar m)))
(list `(hspace ,(- (cdar m) (caar m))))
(preserve-space (substring s (cdar m))))
(list s)))))
(list s))))

7
scribble-lib/scribble/config.rkt
View File

@ -1,6 +1,5 @@
#lang mzscheme
(module config mzscheme
(provide value-color)
(provide value-color)
(define value-color "schemevalue"))
(define value-color "schemevalue")

163
scribble-lib/scribble/racket.rkt
View File

@ -1,5 +1,6 @@
(module racket racket/base
(require "core.rkt"
#lang racket/base
(require "core.rkt"
"basic.rkt"
"search.rkt"
"private/manual-sprop.rkt"
@ -9,7 +10,7 @@
racket/extflonum
(for-syntax racket/base))
(provide define-code
(provide define-code
to-element
to-element/no-color
to-paragraph
@ -55,7 +56,7 @@
make-element-id-transformer
element-id-transformer?))
(define (make-racket-style s
(define (make-racket-style s
#:tt? [tt? #t]
#:extras [extras null])
(make-style s (if tt?
@ -65,51 +66,51 @@
(append extras
scheme-properties))))
(define-on-demand output-color (make-racket-style "RktOut"))
(define-on-demand input-color (make-racket-style "RktIn"))
(define-on-demand input-background-color (make-racket-style "RktInBG"))
(define-on-demand no-color (make-racket-style "RktPlain"))
(define-on-demand reader-color (make-racket-style "RktRdr"))
(define-on-demand result-color (make-racket-style "RktRes"))
(define-on-demand keyword-color (make-racket-style "RktKw"))
(define-on-demand comment-color (make-racket-style "RktCmt"))
(define-on-demand paren-color (make-racket-style "RktPn"))
(define-on-demand meta-color (make-racket-style "RktMeta"))
(define-on-demand value-color (make-racket-style "RktVal"))
(define-on-demand symbol-color (make-racket-style "RktSym"))
(define-on-demand symbol-def-color (make-racket-style "RktSymDef"
(define-on-demand output-color (make-racket-style "RktOut"))
(define-on-demand input-color (make-racket-style "RktIn"))
(define-on-demand input-background-color (make-racket-style "RktInBG"))
(define-on-demand no-color (make-racket-style "RktPlain"))
(define-on-demand reader-color (make-racket-style "RktRdr"))
(define-on-demand result-color (make-racket-style "RktRes"))
(define-on-demand keyword-color (make-racket-style "RktKw"))
(define-on-demand comment-color (make-racket-style "RktCmt"))
(define-on-demand paren-color (make-racket-style "RktPn"))
(define-on-demand meta-color (make-racket-style "RktMeta"))
(define-on-demand value-color (make-racket-style "RktVal"))
(define-on-demand symbol-color (make-racket-style "RktSym"))
(define-on-demand symbol-def-color (make-racket-style "RktSymDef"
#:extras (list (attributes '((class . "RktSym"))))))
(define-on-demand variable-color (make-racket-style "RktVar"))
(define-on-demand opt-color (make-racket-style "RktOpt"))
(define-on-demand error-color (make-racket-style "RktErr" #:tt? #f))
(define-on-demand syntax-link-color (make-racket-style "RktStxLink"))
(define-on-demand value-link-color (make-racket-style "RktValLink"))
(define-on-demand syntax-def-color (make-racket-style "RktStxDef"
(define-on-demand variable-color (make-racket-style "RktVar"))
(define-on-demand opt-color (make-racket-style "RktOpt"))
(define-on-demand error-color (make-racket-style "RktErr" #:tt? #f))
(define-on-demand syntax-link-color (make-racket-style "RktStxLink"))
(define-on-demand value-link-color (make-racket-style "RktValLink"))
(define-on-demand syntax-def-color (make-racket-style "RktStxDef"
#:extras (list (attributes '((class . "RktStxLink"))))))
(define-on-demand value-def-color (make-racket-style "RktValDef"
(define-on-demand value-def-color (make-racket-style "RktValDef"
#:extras (list (attributes '((class . "RktValLink"))))))
(define-on-demand module-color (make-racket-style "RktMod"))
(define-on-demand module-link-color (make-racket-style "RktModLink"))
(define-on-demand block-color (make-racket-style "RktBlk"))
(define-on-demand highlighted-color (make-racket-style "highlighted" #:tt? #f))
(define-on-demand module-color (make-racket-style "RktMod"))
(define-on-demand module-link-color (make-racket-style "RktModLink"))
(define-on-demand block-color (make-racket-style "RktBlk"))
(define-on-demand highlighted-color (make-racket-style "highlighted" #:tt? #f))
(define current-keyword-list
(define current-keyword-list
(make-parameter null))
(define current-variable-list
(define current-variable-list
(make-parameter null))
(define current-meta-list
(define current-meta-list
(make-parameter null))
(define defined-names (make-hasheq))
(define defined-names (make-hasheq))
(define-struct (sized-element element) (length))
(define-struct (sized-element element) (length))
(define-struct (spaces element) (cnt))
(define-struct (spaces element) (cnt))
;; We really don't want leading hypens (or minus signs) to
;; create a line break after the hyphen. For interior hyphens,
;; line breaking is usually fine.
(define (nonbreak-leading-hyphens s)
;; We really don't want leading hypens (or minus signs) to
;; create a line break after the hyphen. For interior hyphens,
;; line breaking is usually fine.
(define (nonbreak-leading-hyphens s)
(let ([m (regexp-match-positions #rx"^-+" s)])
(if m
(if (= (cdar m) (string-length s))
@ -119,7 +120,7 @@
(substring s len)))))
s)))
(define (literalize-spaces i [leading? #f])
(define (literalize-spaces i [leading? #f])
(let ([m (regexp-match-positions #rx" +" i)])
(if m
(let ([cnt (- (cdar m) (caar m))])
@ -134,21 +135,21 @@
i))))
(define line-breakable-space (make-element 'tt " "))
(define line-breakable-space (make-element 'tt " "))
;; These caches intentionally record a key with the value.
;; That way, when the value is no longer used, the key
;; goes away, and the entry is gone.
;; These caches intentionally record a key with the value.
;; That way, when the value is no longer used, the key
;; goes away, and the entry is gone.
(define id-element-cache (make-weak-hash))
(define element-cache (make-weak-hash))
(define id-element-cache (make-weak-hash))
(define element-cache (make-weak-hash))
(define-struct (cached-delayed-element delayed-element) (cache-key))
(define-struct (cached-element element) (cache-key))
(define-struct (cached-delayed-element delayed-element) (cache-key))
(define-struct (cached-element element) (cache-key))
(define qq-ellipses (string->uninterned-symbol "..."))
(define qq-ellipses (string->uninterned-symbol "..."))
(define (make-id-element c s defn?)
(define (make-id-element c s defn?)
(let* ([key (and id-element-cache
(let ([b (identifier-label-binding c)])
(vector (syntax-e c)
@ -190,7 +191,7 @@
(hash-set! id-element-cache key (make-weak-box e)))
e))))
(define (make-element/cache style content)
(define (make-element/cache style content)
(if (and element-cache
(string? content))
(let ([key (vector style content)])
@ -201,7 +202,7 @@
e))))
(make-element style content)))
(define (to-quoted obj expr? quote-depth out color? inc!)
(define (to-quoted obj expr? quote-depth out color? inc!)
(if (and expr?
(zero? quote-depth)
(quotable? obj))
@ -211,7 +212,7 @@
(add1 quote-depth))
quote-depth))
(define (to-unquoted expr? quote-depth out color? inc!)
(define (to-unquoted expr? quote-depth out color? inc!)
(if (or (not expr?) (zero? quote-depth))
quote-depth
(begin
@ -219,12 +220,12 @@
(inc!)
(to-unquoted expr? (sub1 quote-depth) out color? inc!))))
(define iformat
(define iformat
(case-lambda
[(str val) (datum-intern-literal (format str val))]
[(str . vals) (datum-intern-literal (apply format str vals))]))
(define (typeset-atom c out color? quote-depth expr? escapes? defn?)
(define (typeset-atom c out color? quote-depth expr? escapes? defn?)
(if (and (var-id? (syntax-e c))
(zero? quote-depth))
(out (iformat "~s" (let ([v (var-id-sym (syntax-e c))])
@ -317,9 +318,9 @@
[else paren-color])
(string-length s)))))))
(define omitable (make-style #f '(omitable)))
(define omitable (make-style #f '(omitable)))
(define (gen-typeset c multi-line? prefix1 prefix suffix color? expr? escapes? defn? elem-wrap)
(define (gen-typeset c multi-line? prefix1 prefix suffix color? expr? escapes? defn? elem-wrap)
(let* ([c (syntax-ize c 0 #:expr? expr?)]
[content null]
[docs null]
@ -895,7 +896,7 @@
(make-table block-color (map list (reverse docs))))
(make-sized-element #f (reverse content) dest-col))))
(define (typeset c multi-line? prefix1 prefix suffix color? expr? escapes? defn? elem-wrap)
(define (typeset c multi-line? prefix1 prefix suffix color? expr? escapes? defn? elem-wrap)
(let* ([c (syntax-ize c 0 #:expr? expr?)]
[s (syntax-e c)])
(if (or multi-line?
@ -927,32 +928,32 @@
mk)
color? 0 expr? escapes? defn?))))
(define (to-element c
(define (to-element c
#:expr? [expr? #f]
#:escapes? [escapes? #t]
#:defn? [defn? #f])
(typeset c #f "" "" "" #t expr? escapes? defn? values))
(define (to-element/no-color c
(define (to-element/no-color c
#:expr? [expr? #f]
#:escapes? [escapes? #t])
(typeset c #f "" "" "" #f expr? escapes? #f values))
(define (to-paragraph c
(define (to-paragraph c
#:expr? [expr? #f]
#:escapes? [escapes? #t]
#:color? [color? #t]
#:wrap-elem [elem-wrap (lambda (e) e)])
(typeset c #t "" "" "" color? expr? escapes? #f elem-wrap))
(define ((to-paragraph/prefix pfx1 pfx sfx) c
(define ((to-paragraph/prefix pfx1 pfx sfx) c
#:expr? [expr? #f]
#:escapes? [escapes? #t]
#:color? [color? #t]
#:wrap-elem [elem-wrap (lambda (e) e)])
(typeset c #t pfx1 pfx sfx color? expr? escapes? #f elem-wrap))
(begin-for-syntax
(begin-for-syntax
(define-struct variable-id (sym)
#:omit-define-syntaxes
#:property prop:procedure (lambda (self stx)
@ -972,7 +973,7 @@
" bound as an code-typesetting element transformer")
stx))))
(define-syntax (define-code stx)
(define-syntax (define-code stx)
(syntax-case stx ()
[(_ code typeset-code uncode d->s stx-prop)
(syntax/loc stx
@ -1052,9 +1053,9 @@
[(_ code typeset-code) #'(define-code code typeset-code unsyntax)]))
(define syntax-ize-hook (make-parameter (lambda (v col) #f)))
(define syntax-ize-hook (make-parameter (lambda (v col) #f)))
(define (vector->short-list v extract)
(define (vector->short-list v extract)
(vector->list v)
#;
(let ([l (vector->list v)])
@ -1069,7 +1070,7 @@
(loop (sub1 i))]
[else (add1 i)])))))))
(define (short-list->vector v l)
(define (short-list->vector v l)
(list->vector
(let ([n (length l)])
(if (n . < . (vector-length v))
@ -1079,29 +1080,29 @@
(loop (cons (car r) r) (sub1 i)))))
l))))
(define-struct var-id (sym))
(define-struct shaped-parens (val shape))
(define-struct long-boolean (val))
(define-struct just-context (val ctx))
(define-struct alternate-display (id string))
(define-struct literal-syntax (stx))
(define-struct struct-proxy (name content))
(define-struct var-id (sym))
(define-struct shaped-parens (val shape))
(define-struct long-boolean (val))
(define-struct just-context (val ctx))
(define-struct alternate-display (id string))
(define-struct literal-syntax (stx))
(define-struct struct-proxy (name content))
(define-struct graph-reference (bx))
(define-struct graph-defn (r bx))
(define-struct graph-reference (bx))
(define-struct graph-defn (r bx))
(define (syntax-ize v col [line 1] #:expr? [expr? #f])
(define (syntax-ize v col [line 1] #:expr? [expr? #f])
(do-syntax-ize v col line (box #hasheq()) #f (and expr? 0) #f))
(define (graph-count ht graph?)
(define (graph-count ht graph?)
(and graph?
(let ([n (hash-ref (unbox ht) '#%graph-count 0)])
(set-box! ht (hash-set (unbox ht) '#%graph-count (add1 n)))
n)))
(define-struct forced-pair (car cdr))
(define-struct forced-pair (car cdr))
(define (quotable? v)
(define (quotable? v)
(define graph (make-hasheq))
(let quotable? ([v v])
(if (hash-ref graph v #f)
@ -1133,7 +1134,7 @@
[(mpair? v) #f]
[else #t])))))
(define (do-syntax-ize v col line ht graph? qq no-cons?)
(define (do-syntax-ize v col line ht graph? qq no-cons?)
(cond
[((syntax-ize-hook) v col)
=> (lambda (r) r)]
@ -1379,4 +1380,4 @@
(max 1 (- (syntax-position pairs) undelta))
(+ (syntax-span pairs) undelta))))]
[else
(datum->syntax #f v (vector #f line col (+ 1 col) 1))])))
(datum->syntax #f v (vector #f line col (+ 1 col) 1))]))

17
scribble-lib/scribble/search.rkt
View File

@ -1,14 +1,15 @@
(module search racket/base
(require "struct.rkt"
#lang racket/base
(require "struct.rkt"
"basic.rkt"
syntax/modcode)
(provide find-racket-tag
(provide find-racket-tag
(rename-out [find-racket-tag find-scheme-tag]))
(define module-info-cache (make-hasheq))
(define module-info-cache (make-hasheq))
(define (module-path-index-rejoin mpi rel-to)
(define (module-path-index-rejoin mpi rel-to)
(let-values ([(name base) (module-path-index-split mpi)])
(cond
[(not name) rel-to]
@ -17,11 +18,11 @@
(module-path-index-join name
(module-path-index-rejoin base rel-to))])))
(define (try thunk fail-thunk)
(define (try thunk fail-thunk)
(with-handlers* ([exn:fail? (lambda (exn) (fail-thunk))])
(thunk)))
(define (find-racket-tag part ri stx/binding phase-level)
(define (find-racket-tag part ri stx/binding phase-level)
;; The phase-level argument is used only when `stx/binding'
;; is an identifier.
;;
@ -184,4 +185,4 @@
;; Can't get the module source, so continue with queue:
(loop queue rqueue need-result?)))])
(or here-result
nest-result))))))])))))))
nest-result))))))]))))))