output.rkt (14521B)
1 #lang racket/base 2 (require racket/promise 3 racket/contract/base) 4 5 (provide 6 special? 7 outputable/c 8 (contract-out 9 [output (->* (outputable/c) (output-port?) void?)])) 10 ;; See also `provide-special` below 11 12 ;; Outputs values for the `scribble/text' language: 13 ;; - several atomic values are printed as in `display', 14 ;; - promises, thunks, and boxes are indirections for the value they contain 15 ;; (useful in various cases), 16 ;; - some "special" values are used for controlling output (eg, flushing, 17 ;; prefix changes, etc), 18 ;; - specifically, `block's delimit indentation levels, `splice's do not, 19 ;; - lists (more generally, pairs) are like either one depending on the context 20 ;; (same as blocks/splices when inside a `block'/`splice'), at the toplevel 21 ;; they default to blocks. 22 ;; 23 ;; Uses global state because `output' is wrapped around each expression in a 24 ;; scribble/text file so this is much more convenient than wrapping the whole 25 ;; module's body in a `list' (which will be difficult with definitions etc). 26 ;; The state is a pair of prefixes -- one that is the prefix for the current 27 ;; value (which gets extended with nested blocks), and the other is the prefix 28 ;; for the current "line" (which is reset after a newline). The line-prefix is 29 ;; needed because a line can hold a block, which means that the line-prefix 30 ;; will apply for the contents of the block including newlines in it. This 31 ;; state is associated with a port via a hash table. Another state that is 32 ;; used is the port's column position, which is maintained by the system (when 33 ;; line counts are enabled) -- this is used to tell what part of a prefix is 34 ;; already displayed. 35 ;; 36 ;; Each prefix is either an integer (for a number of spaces) or a string. The 37 ;; prefix mechanism can be disabled by using #f for the global prefix, and in 38 ;; this case the line prefix can have (cons pfx lpfx) so it can be restored -- 39 ;; used by `disable-prefix' and `restore-prefix' resp. (This is different from 40 ;; a 0 prefix -- #f means that no prefix will be accumulated). 41 ;; 42 (define (output x [p (current-output-port)]) 43 ;; these are the global prefix and the one that is local to the current line 44 (define pfxs (port->state p)) 45 ;; the current mode for lists 46 (define list=block? #t) 47 ;; the low-level string output function (can change with `with-writer') 48 (define write write-string) 49 ;; to get the output column 50 (define (getcol) (let-values ([(line col pos) (port-next-location p)]) col)) 51 ;; total size of the two prefixes 52 (define (2pfx-length pfx1 pfx2) 53 (if (and pfx1 pfx2) 54 (+ (if (number? pfx1) pfx1 (string-length pfx1)) 55 (if (number? pfx2) pfx2 (string-length pfx2))) 56 0)) 57 ;; combines a prefix with a target column to get to 58 (define (pfx+col pfx) 59 (and pfx (let ([col (getcol)]) 60 (cond [(number? pfx) (max pfx col)] 61 [(>= (string-length pfx) col) pfx] 62 [else (string-append 63 pfx (make-spaces (- col (string-length pfx))))])))) 64 ;; adds two prefixes 65 (define (pfx+ pfx1 pfx2) 66 (and pfx1 pfx2 67 (if (and (number? pfx1) (number? pfx2)) (+ pfx1 pfx2) 68 (string-append (if (number? pfx1) (make-spaces pfx1) pfx1) 69 (if (number? pfx2) (make-spaces pfx2) pfx2))))) 70 ;; prints two prefixes 71 (define (output-pfx col pfx1 pfx2) 72 (define-syntax-rule (->str pfx) (if (number? pfx) (make-spaces pfx) pfx)) 73 (define-syntax-rule (show pfx) ; optimize when not needed 74 (unless (eq? pfx 0) (write (->str pfx) p))) 75 (when (and pfx1 pfx2) 76 (if (eq? 0 col) 77 (begin (show pfx1) (show pfx2)) 78 (let ([len1 (if (number? pfx1) pfx1 (string-length pfx1))]) 79 (cond [(< col len1) (write (->str pfx1) p col) (show pfx2)] 80 [(= col len1) (show pfx2)] 81 [(eq? 0 pfx2)] 82 [else 83 (let ([col (- col len1)] 84 [len2 (if (number? pfx2) pfx2 (string-length pfx2))]) 85 (when (< col len2) (write (->str pfx2) p col)))]))))) 86 ;; the basic printing unit: strings 87 (define (output-string x) 88 (define pfx (mcar pfxs)) 89 (if (not pfx) ; prefix disabled? 90 (write x p) 91 (let ([len (string-length x)] 92 [nls (regexp-match-positions* #rx"\n" x)]) 93 (let loop ([start 0] [nls nls] [lpfx (mcdr pfxs)] [col (getcol)]) 94 (cond [(pair? nls) 95 (define nl (car nls)) 96 (if (regexp-match? #rx"^ *$" x start (car nl)) 97 (newline p) ; only spaces before the end of the line 98 (begin (output-pfx col pfx lpfx) 99 (write x p start (cdr nl)))) 100 (loop (cdr nl) (cdr nls) 0 0)] 101 ;; last substring from here (always set lpfx state when done) 102 [(start . = . len) 103 (set-mcdr! pfxs lpfx)] 104 [(col . > . (2pfx-length pfx lpfx)) 105 (set-mcdr! pfxs lpfx) 106 ;; the prefix was already shown, no accumulation needed 107 (write x p start)] 108 [else 109 (define m (regexp-match-positions #rx"^ +" x start)) 110 ;; accumulate spaces to lpfx, display if it's not all spaces 111 (define lpfx* (if m (pfx+ lpfx (- (cdar m) (caar m))) lpfx)) 112 (set-mcdr! pfxs lpfx*) 113 (unless (and m (= len (cdar m))) 114 (output-pfx col pfx lpfx*) 115 ;; the spaces were already added to lpfx 116 (write x p (if m (cdar m) start)))]))))) 117 ;; blocks and splices 118 (define (output-block c) 119 (define pfx (mcar pfxs)) 120 (define lpfx (mcdr pfxs)) 121 (define npfx (pfx+col (pfx+ pfx lpfx))) 122 (set-mcar! pfxs npfx) (set-mcdr! pfxs 0) 123 (if (list? c) 124 (for ([c (in-list c)]) (loop c)) 125 (begin (loop (car c)) (loop (cdr c)))) 126 (set-mcar! pfxs pfx) (set-mcdr! pfxs lpfx)) 127 (define (output-splice c) 128 (for-each loop c)) 129 ;; main loop 130 (define (loop x) 131 (cond 132 ;; no output for these 133 [(or (void? x) (not x) (null? x)) (void)] 134 ;; for lists and pairs the current line prefix is added to the global 135 ;; one, then output the contents recursively (no need to change the 136 ;; state, since we pass the values in the loop, and we'd need to restore 137 ;; it afterwards anyway) 138 [(pair? x) (if list=block? (output-block x) (output-splice x))] 139 ;; delayed values 140 [(and (procedure? x) (procedure-arity-includes? x 0)) (loop (x))] 141 [(promise? x) (loop (force x))] 142 [(box? x) (loop (unbox x))] 143 ;; special output wrappers 144 [(special? x) 145 (define c (special-contents x)) 146 (case (special-flag x) 147 ;; preserve tailness & avoid `set!' for blocks/splices if possible 148 [(block) (if list=block? 149 (output-block c) 150 (begin (set! list=block? #t) 151 (output-block c) 152 (set! list=block? #f)))] 153 [(splice) (if list=block? 154 (begin (set! list=block? #f) 155 (output-splice c) 156 (set! list=block? #t)) 157 (output-splice c))] 158 [(flush) ; useful before `disable-prefix' 159 (output-pfx (getcol) (mcar pfxs) (mcdr pfxs))] 160 [(disable-prefix) ; save the previous pfxs 161 (define pfx (mcar pfxs)) 162 (define lpfx (mcdr pfxs)) 163 (set-mcar! pfxs #f) (set-mcdr! pfxs (cons pfx lpfx)) 164 (for-each loop c) 165 (set-mcar! pfxs pfx) (set-mcdr! pfxs lpfx)] 166 [(restore-prefix) ; restore the previous pfxs 167 (define pfx (mcar pfxs)) 168 (define lpfx (mcdr pfxs)) 169 (define npfx (pfx+col (if (and (not pfx) (pair? lpfx)) 170 (pfx+ (car lpfx) (cdr lpfx)) 171 (pfx+ pfx lpfx)))) 172 (set-mcar! pfxs npfx) (set-mcdr! pfxs 0) 173 (for-each loop c) 174 (set-mcar! pfxs pfx) (set-mcdr! pfxs lpfx)] 175 [(add-prefix) ; add to the current prefix (unless it's #f) 176 (define pfx (mcar pfxs)) 177 (define lpfx (mcdr pfxs)) 178 (define npfx (pfx+ (pfx+col (pfx+ pfx lpfx)) (car c))) 179 (set-mcar! pfxs npfx) (set-mcdr! pfxs 0) 180 (for-each loop (cdr c)) 181 (set-mcar! pfxs pfx) (set-mcdr! pfxs lpfx)] 182 [(set-prefix) 183 (define pfx (mcar pfxs)) 184 (define lpfx (mcdr pfxs)) 185 (set-mcar! pfxs (car c)) (set-mcdr! pfxs 0) 186 (for-each loop (cdr c)) 187 (set-mcar! pfxs pfx) (set-mcdr! pfxs lpfx)] 188 [(with-writer) 189 (define old write) 190 (set! write (or (car c) write-string)) 191 (for-each loop (cdr c)) 192 (set! write old)] 193 #; ; no need for this hack yet 194 [(with-writer-change) 195 ;; The function gets the old writer and return a new one (useful to 196 ;; save the current writer and restore it inside). Could also be 197 ;; used to extend a writer, but that shows why a customizable writer 198 ;; is a bad choice: instead, it should be a list of substitutions 199 ;; that can be extended more conveniently. A simple implementation 200 ;; would be to chain functions that do substitutions. But that runs 201 ;; into problems when functions want to substitute the same thing, 202 ;; and worse: when the output of one function would get substituted 203 ;; again by another. Another approach would be to join matcher 204 ;; regexps with "|" after wrapping each one with parens, then find 205 ;; out which one matched by looking at the result and applying its 206 ;; substitution, but the problem with that is that is that it forbids 207 ;; having parens in the regexps -- this could be fixed by not 208 ;; parenthesizing each expression, and instead running the found 209 ;; match against each of the input regexps to find the matching one, 210 ;; but that can be very inefficient. Yet another issue is that in 211 ;; some cases we might *want* the "worse" feature mentioned earlier: 212 ;; for example, when we want to do some massaging of the input texts 213 ;; yet still have the result encoded for HTML output -- so perhaps 214 ;; the simple approach is still better. The only difference from the 215 ;; current `with-writer' is using a substituting function, so it can 216 ;; be composed with the current one instead of replacing it 217 ;; completely. 218 (define old write) 219 (set! write ((car c) write)) 220 (for-each loop (cdr c)) 221 (set! write old)] 222 [else (error 'output "unknown special value flag: ~e" 223 (special-flag x))])] 224 [else 225 (output-string 226 (cond [(string? x) x] 227 [(bytes? x) (bytes->string/utf-8 x)] 228 [(symbol? x) (symbol->string x)] 229 [(path? x) (path->string x)] 230 [(keyword? x) (keyword->string x)] 231 [(number? x) (number->string x)] 232 [(char? x) (string x)] 233 ;; generic fallback: throw an error (could use `display' so new 234 ;; values can define how they're shown, but the same 235 ;; functionality can be achieved with thunks and prop:procedure) 236 [else (error 'output "don't know how to render value: ~v" x)]))])) 237 ;; 238 (port-count-lines! p) 239 (loop x) 240 (void)) 241 242 (define port->state 243 (let ([t (make-weak-hasheq)] 244 [last '(#f #f)]) ; cache for the last port, to avoid a hash lookup 245 (λ (p) 246 (if (eq? p (car last)) (cdr last) 247 (let ([s (or (hash-ref t p #f) 248 (let ([s (mcons 0 0)]) (hash-set! t p s) s))]) 249 (set! last (cons p s)) 250 s))))) 251 252 ;; special constructs 253 254 (define-struct special (flag contents)) 255 256 (define-syntax define/provide-special 257 (syntax-rules () 258 [(_ (name)) 259 (begin (provide (contract-out [name (->* () () #:rest (listof outputable/c) any/c)])) 260 (define (name . contents) 261 (make-special 'name contents)))] 262 [(_ (name [x ctc] ...)) 263 (begin (provide (contract-out [name (->* (ctc ...) () #:rest (listof outputable/c) any/c)])) 264 (define (name x ... . contents) 265 (make-special 'name (list* x ... contents))))] 266 [(_ name) 267 (begin (provide name) 268 (define name (make-special 'name #f)))])) 269 270 (define/provide-special (block)) 271 (define/provide-special (splice)) 272 (define/provide-special flush) 273 (define/provide-special (disable-prefix)) 274 (define/provide-special (restore-prefix)) 275 (define/provide-special (add-prefix [pfx (or/c string? exact-nonnegative-integer?)])) 276 (define/provide-special (set-prefix [pfx (or/c string? exact-nonnegative-integer?)])) 277 (define/provide-special (with-writer [writer (or/c #f (->* (string? output-port?) (exact-nonnegative-integer? exact-nonnegative-integer?) any/c))])) 278 #; ; no need for this hack yet 279 (define/provide-special (with-writer-change writer)) 280 281 (define make-spaces ; (efficiently) 282 (let ([t (make-hasheq)] [v (make-vector 200 #f)]) 283 (λ (n) 284 (or (if (< n 200) (vector-ref v n) (hash-ref t n #f)) 285 (let ([spaces (make-string n #\space)]) 286 (if (< n 200) (vector-set! v n spaces) (hash-set! t n spaces)) 287 spaces))))) 288 289 ;; Convenient utilities 290 291 (provide add-newlines) 292 (define (add-newlines list #:sep [sep "\n"]) 293 (define r 294 (let loop ([list list]) 295 (if (null? list) 296 null 297 (let ([1st (car list)]) 298 (if (or (not 1st) (void? 1st)) 299 (loop (cdr list)) 300 (list* sep 1st (loop (cdr list)))))))) 301 (if (null? r) r (cdr r))) 302 303 (provide split-lines) 304 (define (split-lines list) 305 (let loop ([list list] [cur '()] [r '()]) 306 (cond 307 [(null? list) (reverse (cons (reverse cur) r))] 308 [(equal? "\n" (car list)) (loop (cdr list) '() (cons (reverse cur) r))] 309 [else (loop (cdr list) (cons (car list) cur) r)]))) 310 311 (define outputable/c 312 (lambda (v) #t) 313 ;; too expensive: 314 #; 315 (recursive-contract 316 (or/c void? 317 #f 318 null? 319 (cons/c outputable/c outputable/c) 320 (-> outputable/c) 321 promise? 322 (box/c outputable/c) 323 special? 324 string? 325 bytes? 326 symbol? 327 path? 328 keyword? 329 number? 330 char?)))