build: Separate Mes and Guile modules.
[mes.git] / mes / module / mes / display.mes
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
5 ;;;
6 ;;; This file is part of Mes.
7 ;;;
8 ;;; Mes is free software; you can redistribute it and/or modify it
9 ;;; under the terms of the GNU General Public License as published by
10 ;;; the Free Software Foundation; either version 3 of the License, or (at
11 ;;; your option) any later version.
12 ;;;
13 ;;; Mes is distributed in the hope that it will be useful, but
14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 ;;; GNU General Public License for more details.
17 ;;;
18 ;;; You should have received a copy of the GNU General Public License
19 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
20
21 ;;; Commentary:
22
23 ;;; Code:
24
25 (mes-use-module (mes scm))
26
27 (define (srfi-1:member x lst eq)
28   (if (null? lst) #f
29       (if (eq x (car lst)) lst
30           (srfi-1:member x (cdr lst) eq))))
31
32 (define (next-xassq x a)
33   (and=> (srfi-1:member x a (lambda (x e) (eq? x (cdr e))))
34          (lambda (a) (xassq x (cdr a)))))
35
36 (define (next-xassq2 x a)
37   (and=> (srfi-1:member x a (lambda (x e) (eq? x (cdr e))))
38          (lambda (a)
39            (and=> (srfi-1:member x (cdr a) (lambda (x e) (eq? x (cdr e))))
40                   (lambda (a) (xassq x (cdr a)))))))
41
42 (define-macro (display-cut f slot n1)
43   `(lambda (slot) (,f slot ,n1)))
44
45 (define-macro (display-cut2 f slot n1 n2)
46   `(lambda (slot) (,f slot ,n1 ,n2)))
47
48 (define (display x . rest)
49   (let* ((port (if (null? rest) (current-output-port) (car rest)))
50          (write? (and (pair? rest) (pair? (cdr rest)) (cadr rest))))
51
52     (define (display-char x port write?)
53       (cond ((and write? (or (eq? x #\") (eq? x #\\)))
54              (write-char #\\ port)
55              (write-char x port))
56             ((and write? (eq? x #\nul))
57              (write-char #\\ port)
58              (write-char #\0 port))
59             ((and write? (eq? x #\alarm))
60              (write-char #\\ port)
61              (write-char #\a port))
62             ((and write? (eq? x #\backspace))
63              (write-char #\\ port)
64              (write-char #\b port))
65             ((and write? (eq? x #\tab))
66              (write-char #\\ port)
67              (write-char #\t port))
68             ((and write? (eq? x #\newline))
69              (write-char #\\ port)
70              (write-char #\n port))
71             ((and write? (eq? x #\vtab))
72              (write-char #\\ port)
73              (write-char #\v port))
74             ((and write? (eq? x #\page))
75              (write-char #\\ port)
76              (write-char #\f port))
77             (#t (write-char x port))))
78
79     (define (d x cont? sep)
80       (for-each (display-cut write-char <> port) (string->list sep))
81       (cond
82        ((eof-object? x)
83         (display "#<eof>" port))
84        ((char? x)
85         (if (not write?) (write-char x port)
86             (let ((name (and=> (assq x '((#\nul . nul)
87                                          (#\alarm . alarm)
88                                          (#\backspace . backspace)
89                                          (#\tab . tab)
90                                          (#\newline . newline)
91                                          (#\vtab . vtab)
92                                          (#\page . page)
93                                          (#\return . return)
94                                          (#\space . space)))
95                                cdr)))
96               (write-char #\# port)
97               (write-char #\\ port)
98               (if name (display name port)
99                   (write-char x port)))))
100        ((closure? x)
101         (display "#<procedure " port)
102         (let ((name (and=> (next-xassq2 x (current-module)) car)))
103           (display name port))
104         (display " " port)
105         (display (cadr (core:cdr x)) port)
106         (display ">" port))
107        ((continuation? x)
108         (display "#<continuation " port)
109         (display (core:car x) port)
110         (display ">" port))
111        ((macro? x)
112         (display "#<macro " port)
113         (display (core:cdr x) port)
114         (display ">" port))
115        ((port? x)
116         (display "#<port " port)
117         (display (core:cdr x) port)
118         (display (core:car x) port)
119         (display ">" port))
120        ((variable? x)
121         (display "#<variable " port)
122         (write (list->string (car (core:car x))) port)
123         (display ">" port))
124        ((number? x)
125         (display (number->string x) port))
126        ((pair? x)
127         (if (not cont?) (write-char #\( port))
128         (cond ((eq? (car x) '*circular*)
129                (display "*circ* . #-1#)" port))
130               ((eq? (car x) '*closure*)
131                (display "*closure* . #-1#)" port))
132               (#t
133                (display (car x) port write?)
134                (if (pair? (cdr x)) (d (cdr x) #t " ")
135                    (if (and (cdr x) (not (null? (cdr x))))
136                        (begin
137                          (display " . " port)
138                          (display (cdr x) port write?))))))
139         (if (not cont?) (write-char #\) port)))
140        ((or (keyword? x) (special? x) (string? x) (symbol? x))
141         (if (and (string? x) write?) (write-char #\" port))
142         (if (keyword? x) (display "#:" port))
143         (for-each (display-cut2 display-char <> port write?) (string->list x))
144         (if (and (string? x) write?) (write-char #\" port)))
145        ((vector? x)
146         (display "#(" port)
147         (for-each (lambda (i)
148                     (let ((x (vector-ref x i)))
149                       (if (vector? x)
150                           (begin
151                             (display (if (= i 0) "" " ") port)
152                             (display "#(...)" port))
153                           (d x #f (if (= i 0) "" " ")))))
154                   (iota (vector-length x)))
155         (display ")" port))
156        ((function? x)
157         (display "#<procedure " port)
158         (display (core:car x) port)
159         (display " " port)
160         (display
161          (case (core:arity x)
162            ((-1) "_")
163            ((0) "()")
164            ((1) "(_)")
165            ((2) "(_ _)")
166            ((3) "(_ _ _)"))
167          port)
168         (display ">" port))
169        ((broken-heart? x)
170         (display "<3" port))
171        (#t
172         (display "TODO type=") (display (cell:type-name x)) (newline)))
173       *unspecified*)
174     (d x #f "")))
175
176 (define (write-char x . rest)
177   (apply write-byte (cons (char->integer x) rest)))
178
179 (define (write x . rest)
180   (let ((port (if (null? rest) (current-output-port) (car rest))))
181     (display x port #t)))
182
183 (define (newline . rest)
184   (apply display (cons "\n" rest)))
185
186 (define (with-output-to-string thunk)
187   (define save-write-byte write-byte)
188   (let ((stdout '()))
189     (set! write-byte
190           (lambda (x . rest)
191             (let ((out? (or (null? rest) (eq? (car rest) (current-output-port)))))
192               (if (not out?) (apply save-write-byte (cons x rest))
193                   (begin
194                     (set! stdout (append stdout (list (integer->char x))))
195                     x)))))
196     (thunk)
197     (let ((r (apply string stdout)))
198       (set! write-byte save-write-byte)
199       r)))
200
201 (define (simple-format destination format . rest)
202   (let ((port (if (boolean? destination) (current-output-port) destination))
203         (lst (string->list format)))
204     (define (simple-format lst args)
205       (if (pair? lst)
206           (let ((c (car lst)))
207             (if (not (eq? c #\~)) (begin (write-char (car lst) port)
208                                          (simple-format (cdr lst) args))
209                 (let ((c (cadr lst)))
210                   (case c
211                     ((#\A) (display (car args) port))
212                     ((#\a) (display (car args) port))
213                     ((#\S) (write (car args) port))
214                     ((#\s) (write (car args) port))
215                     (else (display (car args) port)))
216                   (simple-format (cddr lst) (cdr args)))))))
217     
218     (if destination (simple-format lst rest)
219         (with-output-to-string
220           (lambda () (simple-format lst rest))))))
221
222 (define format simple-format)