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