manual-scheme.rkt (11015B)
1 #lang racket/base 2 (require "../decode.rkt" 3 "../struct.rkt" 4 "../scheme.rkt" 5 "../search.rkt" 6 "../basic.rkt" 7 (only-in "../core.rkt" style style-properties) 8 "manual-style.rkt" 9 "manual-utils.rkt" ;; used via datum->syntax 10 "on-demand.rkt" 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 (list #'unsyntax-id 96 `(make-element 97 #f 98 (list (hash-lang) 99 spacer 100 ,(if (identifier? #'lang) 101 `(as-modname-link 102 ',#'lang 103 (to-element ',#'lang) 104 #f) 105 #'(racket lang))))) 106 #'lang)]) 107 (if (syntax-e #'filename) 108 (quasisyntax/loc stx 109 (filebox 110 filename 111 #,(syntax/loc stx (racketblock0 #:escape unsyntax-id modtag rest ...)))) 112 (syntax/loc stx (racketblock0 #:escape unsyntax-id modtag rest ...))))] 113 [(_ #:file filename lang rest ...) 114 (syntax/loc stx (racketmod0 #:file filename #:escape unsyntax lang rest ...))] 115 [(_ lang rest ...) 116 (syntax/loc stx (racketmod0 #:file #f lang rest ...))])) 117 118 (define-syntax-rule (racketmod rest ...) 119 (code-inset (racketmod0 rest ...))) 120 121 (define (to-element/result s) 122 (make-element result-color (list (to-element/no-color s)))) 123 (define (to-element/id s) 124 (make-element symbol-color (list (to-element/no-color s)))) 125 (define (to-element/no-escapes s) 126 (to-element s #:escapes? #f)) 127 128 (define-syntax (keep-s-expr stx) 129 (syntax-case stx (quote) 130 [(_ ctx '#t #(src line col pos 5)) 131 #'(make-long-boolean #t)] 132 [(_ ctx '#f #(src line col pos 6)) 133 #'(make-long-boolean #f)] 134 [(_ ctx s srcloc) 135 (let ([sv (syntax-e 136 (syntax-case #'s (quote) 137 [(quote s) #'s] 138 [_ #'s]))]) 139 (if (or (number? sv) 140 (boolean? sv) 141 (and (pair? sv) 142 (identifier? (car sv)) 143 (or (free-identifier=? #'cons (car sv)) 144 (free-identifier=? #'list (car sv))))) 145 ;; We know that the context is irrelvant 146 #'s 147 ;; Context may be relevant: 148 #'(*keep-s-expr s ctx)))])) 149 (define (*keep-s-expr s ctx) 150 (if (symbol? s) 151 (make-just-context s ctx) 152 s)) 153 154 (define (add-sq-prop s name val) 155 (if (eq? name 'paren-shape) 156 (make-shaped-parens s val) 157 s)) 158 159 (define-code racketblockelem to-element) 160 161 (define-code racket to-element unsyntax keep-s-expr add-sq-prop) 162 (define-code RACKET to-element UNSYNTAX keep-s-expr add-sq-prop) 163 (define-code racketresult to-element/result unsyntax keep-s-expr add-sq-prop) 164 (define-code racketid to-element/id unsyntax keep-s-expr add-sq-prop) 165 (define-code *racketmodname to-element/no-escapes unsyntax keep-s-expr add-sq-prop) 166 167 (define-syntax (**racketmodname stx) 168 (syntax-case stx () 169 [(_ form) 170 (let ([stx #'form]) 171 #`(*racketmodname 172 ;; We want to remove lexical context from identifiers 173 ;; that correspond to module names, but keep context 174 ;; for `lib' or `planet' (which are rarely used) 175 #,(if (identifier? stx) 176 (datum->syntax #f (syntax-e stx) stx stx) 177 (if (and (pair? (syntax-e stx)) 178 (memq (syntax-e (car (syntax-e stx))) '(lib planet file))) 179 (let ([s (car (syntax-e stx))] 180 [rest (let loop ([a (cdr (syntax-e stx))] [head? #f]) 181 (cond 182 [(identifier? a) (datum->syntax #f (syntax-e a) a a)] 183 [(and head? (pair? a) (and (identifier? (car a)) 184 (free-identifier=? #'unsyntax (car a)))) 185 a] 186 [(pair? a) (cons (loop (car a) #t) 187 (loop (cdr a) #f))] 188 [(syntax? a) (datum->syntax a 189 (loop (syntax-e a) head?) 190 a 191 a)] 192 [else a]))]) 193 (datum->syntax stx (cons s rest) stx stx)) 194 stx))))])) 195 196 (define-syntax racketmodname 197 (syntax-rules (unsyntax) 198 [(racketmodname #,n) 199 (let ([sym n]) 200 (as-modname-link sym (to-element sym) #f))] 201 [(racketmodname n) 202 (as-modname-link 'n (**racketmodname n) #f)] 203 [(racketmodname #,n #:indirect) 204 (let ([sym n]) 205 (as-modname-link sym (to-element sym) #t))] 206 [(racketmodname n #:indirect) 207 (as-modname-link 'n (**racketmodname n) #t)])) 208 209 (define-syntax racketmodlink 210 (syntax-rules (unsyntax) 211 [(racketmodlink n content ...) 212 (*as-modname-link 'n (elem #:style #f content ...) #f)])) 213 214 (define (as-modname-link s e indirect?) 215 (if (symbol? s) 216 (*as-modname-link s e indirect?) 217 e)) 218 219 (define-on-demand indirect-module-link-color 220 (struct-copy style module-link-color 221 [properties (cons 'indirect-link 222 (style-properties module-link-color))])) 223 224 (define (*as-modname-link s e indirect?) 225 (make-link-element (if indirect? 226 indirect-module-link-color 227 module-link-color) 228 (list e) 229 `(mod-path ,(datum-intern-literal (format "~s" s))))) 230 231 (define-syntax-rule (indexed-racket x) 232 (add-racket-index 'x (racket x))) 233 234 (define (add-racket-index s e) 235 (let ([k (cond [(and (pair? s) (eq? (car s) 'quote)) (format "~s" (cadr s))] 236 [(string? s) s] 237 [else (format "~s" s)])]) 238 (index* (list k) (list e) e))) 239 240 (define-syntax-rule (define-/form id base) 241 (define-syntax (id stx) 242 (syntax-case stx () 243 [(_ a) 244 ;; Remove the context from any ellipsis in `a`: 245 (with-syntax ([a (strip-ellipsis-context #'a)]) 246 #'(base a))]))) 247 248 (define-for-syntax (strip-ellipsis-context a) 249 (define a-ellipsis (datum->syntax a '...)) 250 (define a-ellipsis+ (datum->syntax a '...+)) 251 (let loop ([a a]) 252 (cond 253 [(identifier? a) 254 (cond 255 [(free-identifier=? a a-ellipsis #f) 256 (datum->syntax #f '... a a)] 257 [(free-identifier=? a a-ellipsis+ #f) 258 (datum->syntax #f '...+ a a)] 259 [else a])] 260 [(syntax? a) 261 (datum->syntax a (loop (syntax-e a)) a a)] 262 [(pair? a) 263 (cons (loop (car a)) 264 (loop (cdr a)))] 265 [(vector? a) 266 (list->vector 267 (map loop (vector->list a)))] 268 [(box? a) 269 (box (loop (unbox a)))] 270 [(prefab-struct-key a) 271 => (lambda (k) 272 (apply make-prefab-struct 273 k 274 (loop (cdr (vector->list (struct->vector a))))))] 275 [else a]))) 276 277 (define-/form racketblock0/form racketblock0) 278 (define-/form racketblock/form racketblock) 279 (define-/form racket/form racket) 280 281 (define (*racketlink stx-id id style . s) 282 (let ([content (decode-content s)]) 283 (make-delayed-element 284 (lambda (r p ri) 285 (make-link-element 286 style 287 content 288 (or (find-racket-tag p ri stx-id #f) 289 `(undef ,(format "--UNDEFINED:~a--" (syntax-e stx-id)))))) 290 (lambda () content) 291 (lambda () content)))) 292 293 (define-syntax racketlink 294 (syntax-rules () 295 [(_ id #:style style . content) 296 (*racketlink (quote-syntax id) 'id style . content)] 297 [(_ id . content) 298 (*racketlink (quote-syntax id) 'id #f . content)]))