manual-scheme.rkt (10835B)
1 #lang racket/base 2 (require scribble/decode 3 scribble/struct 4 "racket.rkt";; was: "../scheme.rkt" 5 scribble/search 6 scribble/basic 7 (only-in scribble/core style style-properties) 8 scribble/private/manual-style 9 scribble/private/manual-utils ;; used via datum->syntax 10 scribble/private/on-demand 11 (for-syntax racket/base) 12 (for-label racket/base)) 13 14 (provide racketblock RACKETBLOCK racketblock/form 15 racketblock0 RACKETBLOCK0 racketblock0/form 16 racketresultblock racketresultblock0 17 RACKETRESULTBLOCK RACKETRESULTBLOCK0 18 racketblockelem 19 racketinput RACKETINPUT 20 racketinput0 RACKETINPUT0 21 racketmod 22 racketmod0 23 racket RACKET racket/form racketresult racketid 24 racketmodname 25 racketmodlink indexed-racket 26 racketlink 27 28 (rename-out [racketblock schemeblock] 29 [RACKETBLOCK SCHEMEBLOCK] 30 [racketblock/form schemeblock/form] 31 [racketblock0 schemeblock0] 32 [RACKETBLOCK0 SCHEMEBLOCK0] 33 [racketblock0/form schemeblock0/form] 34 [racketblockelem schemeblockelem] 35 [racketinput schemeinput] 36 [racketmod schememod] 37 [racket scheme] 38 [RACKET SCHEME] 39 [racket/form scheme/form] 40 [racketresult schemeresult] 41 [racketid schemeid] 42 [racketmodname schememodname] 43 [racketmodlink schememodlink] 44 [indexed-racket indexed-scheme] 45 [racketlink schemelink])) 46 47 (define-code racketblock0 to-paragraph) 48 (define-code racketblock to-block-paragraph) 49 (define-code RACKETBLOCK to-block-paragraph UNSYNTAX) 50 (define-code RACKETBLOCK0 to-paragraph UNSYNTAX) 51 52 (define (to-block-paragraph v) 53 (code-inset (to-paragraph v))) 54 55 (define (to-result-paragraph v) 56 (to-paragraph v 57 #:color? #f 58 #:wrap-elem 59 (lambda (e) (make-element result-color e)))) 60 (define (to-result-paragraph/prefix a b c) 61 (let ([to-paragraph (to-paragraph/prefix a b c)]) 62 (lambda (v) 63 (to-paragraph v 64 #:color? #f 65 #:wrap-elem 66 (lambda (e) (make-element result-color e)))))) 67 68 (define-code racketresultblock0 to-result-paragraph) 69 (define-code racketresultblock (to-result-paragraph/prefix (hspace 2) (hspace 2) "")) 70 (define-code RACKETRESULTBLOCK (to-result-paragraph/prefix (hspace 2) (hspace 2) "") 71 UNSYNTAX) 72 (define-code RACKETRESULTBLOCK0 to-result-paragraph UNSYNTAX) 73 74 (define interaction-prompt (make-element 'tt (list "> " ))) 75 (define-code racketinput to-input-paragraph/inset) 76 (define-code RACKETINPUT to-input-paragraph/inset) 77 (define-code racketinput0 to-input-paragraph) 78 (define-code RACKETINPUT0 to-input-paragraph) 79 80 (define to-input-paragraph 81 (to-paragraph/prefix 82 (make-element #f interaction-prompt) 83 (hspace 2) 84 "")) 85 86 (define to-input-paragraph/inset 87 (lambda (v) 88 (code-inset (to-input-paragraph v)))) 89 90 (define-syntax (racketmod0 stx) 91 (syntax-case stx () 92 [(_ #:file filename #:escape unsyntax-id lang rest ...) 93 (with-syntax ([modtag (datum->syntax 94 #'here 95 `(unsyntax (make-element 96 #f 97 (list (hash-lang) 98 spacer 99 ,(if (identifier? #'lang) 100 `(as-modname-link 101 ',#'lang 102 (to-element ',#'lang) 103 #f) 104 #'(racket lang))))) 105 #'lang)]) 106 (if (syntax-e #'filename) 107 (quasisyntax/loc stx 108 (filebox 109 filename 110 #,(syntax/loc stx (racketblock0 #:escape unsyntax-id modtag rest ...)))) 111 (syntax/loc stx (racketblock0 #:escape unsyntax-id modtag rest ...))))] 112 [(_ #:file filename lang rest ...) 113 (syntax/loc stx (racketmod0 #:file filename #:escape unsyntax lang rest ...))] 114 [(_ lang rest ...) 115 (syntax/loc stx (racketmod0 #:file #f lang rest ...))])) 116 117 (define-syntax-rule (racketmod rest ...) 118 (code-inset (racketmod0 rest ...))) 119 120 (define (to-element/result s) 121 (make-element result-color (list (to-element/no-color s)))) 122 (define (to-element/id s) 123 (make-element symbol-color (list (to-element/no-color s)))) 124 125 (define-syntax (keep-s-expr stx) 126 (syntax-case stx (quote) 127 [(_ ctx '#t #(src line col pos 5)) 128 #'(make-long-boolean #t)] 129 [(_ ctx '#f #(src line col pos 6)) 130 #'(make-long-boolean #f)] 131 [(_ ctx s srcloc) 132 (let ([sv (syntax-e 133 (syntax-case #'s (quote) 134 [(quote s) #'s] 135 [_ #'s]))]) 136 (if (or (number? sv) 137 (boolean? sv) 138 (and (pair? sv) 139 (identifier? (car sv)) 140 (or (free-identifier=? #'cons (car sv)) 141 (free-identifier=? #'list (car sv))))) 142 ;; We know that the context is irrelvant 143 #'s 144 ;; Context may be relevant: 145 #'(*keep-s-expr s ctx)))])) 146 (define (*keep-s-expr s ctx) 147 (if (symbol? s) 148 (make-just-context s ctx) 149 s)) 150 151 (define (add-sq-prop s name val) 152 (if (eq? name 'paren-shape) 153 (make-shaped-parens s val) 154 s)) 155 156 (define-code racketblockelem to-element) 157 158 (define-code racket to-element unsyntax keep-s-expr add-sq-prop) 159 (define-code RACKET to-element UNSYNTAX keep-s-expr add-sq-prop) 160 (define-code racketresult to-element/result unsyntax keep-s-expr add-sq-prop) 161 (define-code racketid to-element/id unsyntax keep-s-expr add-sq-prop) 162 (define-code *racketmodname to-element unsyntax keep-s-expr add-sq-prop) 163 164 (define-syntax (**racketmodname stx) 165 (syntax-case stx () 166 [(_ form) 167 (let ([stx #'form]) 168 #`(*racketmodname 169 ;; We want to remove lexical context from identifiers 170 ;; that correspond to module names, but keep context 171 ;; for `lib' or `planet' (which are rarely used) 172 #,(if (identifier? stx) 173 (datum->syntax #f (syntax-e stx) stx stx) 174 (if (and (pair? (syntax-e stx)) 175 (memq (syntax-e (car (syntax-e stx))) '(lib planet file))) 176 (let ([s (car (syntax-e stx))] 177 [rest (let loop ([a (cdr (syntax-e stx))] [head? #f]) 178 (cond 179 [(identifier? a) (datum->syntax #f (syntax-e a) a a)] 180 [(and head? (pair? a) (and (identifier? (car a)) 181 (free-identifier=? #'unsyntax (car a)))) 182 a] 183 [(pair? a) (cons (loop (car a) #t) 184 (loop (cdr a) #f))] 185 [(syntax? a) (datum->syntax a 186 (loop (syntax-e a) head?) 187 a 188 a)] 189 [else a]))]) 190 (datum->syntax stx (cons s rest) stx stx)) 191 stx))))])) 192 193 (define-syntax racketmodname 194 (syntax-rules (unsyntax) 195 [(racketmodname #,n) 196 (let ([sym n]) 197 (as-modname-link sym (to-element sym) #f))] 198 [(racketmodname n) 199 (as-modname-link 'n (**racketmodname n) #f)] 200 [(racketmodname #,n #:indirect) 201 (let ([sym n]) 202 (as-modname-link sym (to-element sym) #t))] 203 [(racketmodname n #:indirect) 204 (as-modname-link 'n (**racketmodname n) #t)])) 205 206 (define-syntax racketmodlink 207 (syntax-rules (unsyntax) 208 [(racketmodlink n content ...) 209 (*as-modname-link 'n (elem #:style #f content ...) #f)])) 210 211 (define (as-modname-link s e indirect?) 212 (if (symbol? s) 213 (*as-modname-link s e indirect?) 214 e)) 215 216 (define-on-demand indirect-module-link-color 217 (struct-copy style module-link-color 218 [properties (cons 'indirect-link 219 (style-properties module-link-color))])) 220 221 (define (*as-modname-link s e indirect?) 222 (make-link-element (if indirect? 223 indirect-module-link-color 224 module-link-color) 225 (list e) 226 `(mod-path ,(datum-intern-literal (format "~s" s))))) 227 228 (define-syntax-rule (indexed-racket x) 229 (add-racket-index 'x (racket x))) 230 231 (define (add-racket-index s e) 232 (let ([k (cond [(and (pair? s) (eq? (car s) 'quote)) (format "~s" (cadr s))] 233 [(string? s) s] 234 [else (format "~s" s)])]) 235 (index* (list k) (list e) e))) 236 237 (define-syntax-rule (define-/form id base) 238 (define-syntax (id stx) 239 (syntax-case stx () 240 [(_ a) 241 ;; Remove the context from any ellipsis in `a`: 242 (with-syntax ([a (strip-ellipsis-context #'a)]) 243 #'(base a))]))) 244 245 (define-for-syntax (strip-ellipsis-context a) 246 (define a-ellipsis (datum->syntax a '...)) 247 (let loop ([a a]) 248 (cond 249 [(identifier? a) 250 (if (free-identifier=? a a-ellipsis #f) 251 (datum->syntax #f '... a a) 252 a)] 253 [(syntax? a) 254 (datum->syntax a (loop (syntax-e a)) a a)] 255 [(pair? a) 256 (cons (loop (car a)) 257 (loop (cdr a)))] 258 [(vector? a) 259 (list->vector 260 (map loop (vector->list a)))] 261 [(box? a) 262 (box (loop (unbox a)))] 263 [(prefab-struct-key a) 264 => (lambda (k) 265 (apply make-prefab-struct 266 k 267 (loop (cdr (vector->list (struct->vector a))))))] 268 [else a]))) 269 270 (define-/form racketblock0/form racketblock0) 271 (define-/form racketblock/form racketblock) 272 (define-/form racket/form racket) 273 274 (define (*racketlink stx-id id style . s) 275 (let ([content (decode-content s)]) 276 (make-delayed-element 277 (lambda (r p ri) 278 (make-link-element 279 style 280 content 281 (or (find-racket-tag p ri stx-id #f) 282 `(undef ,(format "--UNDEFINED:~a--" (syntax-e stx-id)))))) 283 (lambda () content) 284 (lambda () content)))) 285 286 (define-syntax racketlink 287 (syntax-rules () 288 [(_ id #:style style . content) 289 (*racketlink (quote-syntax id) 'id style . content)] 290 [(_ id . content) 291 (*racketlink (quote-syntax id) 'id #f . content)]))