1;; base.scm - base formatting monad 2;; Copyright (c) 2013 Alex Shinn. All rights reserved. 3;; BSD-style license: http://synthcode.com/license.txt 4 5;;> The minimal base formatting combinators and show interface. 6 7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 8 9;;> The environment monad with some pre-defined fields for combinator 10;;> formatting. 11 12(define-environment-monad Show-Env 13 (sequence: sequence) 14 (bind: %fn) 15 (bind-fork: forked) 16 (local: %with) 17 (local!: with!) 18 (return: return) 19 (run: run) 20 (fields: 21 (port env-port env-port-set!) 22 (row env-row env-row-set!) 23 (col env-col env-col-set!) 24 (width env-width env-width-set!) 25 (radix env-radix env-radix-set!) 26 (precision env-precision env-precision-set!) 27 (pad-char env-pad-char env-pad-char-set!) 28 (decimal-sep env-decimal-sep env-decimal-sep-set!) 29 (decimal-align env-decimal-align env-decimal-align-set!) 30 (string-width env-string-width env-string-width-set!) 31 (ellipsis env-ellipsis env-ellipsis-set!) 32 (writer env-writer env-writer-set!) 33 (output env-output env-output-set!))) 34 35(define-syntax fn 36 (syntax-rules () 37 ((fn vars expr ... fmt) 38 (%fn vars expr ... (displayed fmt))))) 39 40;; The base formatting handles outputting raw strings and a simple, 41;; configurable handler for formatting objects. 42 43;; Utility - default value of string-width. 44(define (substring-length str . o) 45 (let ((start (if (pair? o) (car o) 0)) 46 (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) 47 (- end start))) 48 49(define (call-with-output-string proc) 50 (let ((out (open-output-string))) 51 (proc out) 52 (let ((res (get-output-string out))) 53 (close-output-port out) 54 res))) 55 56;; Raw output. All primitive output should go through this operation. 57;; Overridable, defaulting to output-default. 58(define (output str) 59 (fn (output) ((or output output-default) str))) 60 61;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 62 63;;> \procedure{(show out [args ...])} 64;;> 65;;> Run the combinators \var{args}, accumulating the output to 66;;> \var{out}, which is either an output port or a boolean, with 67;;> \scheme{#t} indicating \scheme{current-output-port} and 68;;> \scheme{#f} to collect the output as a string. 69(define (show out . args) 70 (let ((proc (each-in-list args))) 71 (cond 72 ((output-port? out) 73 (show-run out proc)) 74 ((eq? #t out) 75 (show-run (current-output-port) proc)) 76 ((eq? #f out) 77 (let ((out (open-output-string))) 78 (show-run out proc) 79 (get-output-string out))) 80 (else 81 (error "unknown output to show" out))))) 82 83;; Run with an output port with initial default values. 84(define (show-run out proc) 85 (run (sequence (with! (port out) 86 (col 0) 87 (row 0) 88 (width 78) 89 (radix 10) 90 (pad-char #\space) 91 (output output-default) 92 (string-width substring-length)) 93 proc))) 94 95;;> Temporarily bind the parameters in the body \var{x}. 96 97(define-syntax with 98 (syntax-rules () 99 ((with params x ... y) 100 (%with params (each x ... y))))) 101 102;;> The noop formatter. Generates no output and leaves the state 103;;> unmodified. 104(define nothing (fn () (with!))) 105 106;;> Formats a displayed version of x - if a string or char, outputs the 107;;> raw characters (as with `display'), if x is already a formatter 108;;> defers to that, otherwise outputs a written version of x. 109(define (displayed x) 110 (cond 111 ((procedure? x) x) 112 ((string? x) (output x)) 113 ((char? x) (output (string x))) 114 (else (written x)))) 115 116;;> Formats a written version of x, as with `write'. The formatting 117;;> can be updated with the \scheme{'writer} field. 118(define (written x) 119 (fn (writer) ((or writer written-default) x))) 120 121;;> Takes a single list of formatters, combined in sequence with 122;;> \scheme{each}. 123(define (each-in-list args) 124 (if (pair? args) 125 (sequence (displayed (car args)) (each-in-list (cdr args))) 126 nothing)) 127 128;;> Combines each of the formatters in a sequence using 129;;> \scheme{displayed}, so that strings and chars will be output 130;;> directly and other objects will be \scheme{written}. 131(define (each . args) 132 (each-in-list args)) 133 134;;> Raw output - displays str to the formatter output port and updates 135;;> row and col. 136(define (output-default str) 137 (fn (port (r row) (c col) string-width) 138 (let ((nl-index (string-index-right str #\newline))) 139 (write-string str port) 140 (if (string-cursor>? nl-index (string-cursor-start str)) 141 (with! (row (+ r (string-count str (lambda (ch) (eqv? ch #\newline))))) 142 (col (string-width str (string-cursor->index str nl-index)))) 143 (with! (col (+ c (string-width str)))))))) 144 145;;> Captures the output of \var{producer} and formats the result with 146;;> \var{consumer}. 147(define (call-with-output producer consumer) 148 (let ((out (open-output-string))) 149 (forked (with ((port out) (output output-default)) producer) 150 (fn () (consumer (get-output-string out)))))) 151