ee5e65b4a5b14484aa6af4e723570e2bb599b689
[mes.git] / module / mes / display.mes
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016 Jan 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 (display x . rest)
28   (let* ((port (if (null? rest) (current-output-port) (car rest)))
29          (write? (and (pair? rest) (pair? (cdr rest)))))
30
31     (define-macro (cut f slot n1)
32       `(lambda (slot) (,f slot ,n1)))
33
34     (define-macro (cut2 f slot n1 n2)
35       `(lambda (slot) (,f slot ,n1 ,n2)))
36
37     (define (display-char x write? port)
38       (cond ((and write? (or (eq? x #\") (eq? x #\\)))
39              (write-char #\\ port)
40              (write-char x port))
41             ((and write? (eq? x #\newline))
42              (write-char #\\ port)
43              (write-char #\n port))
44             (#t (write-char x port))))
45
46     (define (d x cont? sep)
47       (for-each (cut write-char <> port) (string->list sep))
48       (cond
49        ((char? x)
50         (if (not write?) (write-char x port)
51             (let ((name (and=> (assq x '((#\*eof* . *eof*)
52                                          (#\nul . nul)
53                                          (#\alarm . alarm)
54                                          (#\backspace . backspace)
55                                          (#\tab . tab)
56                                          (#\newline . newline)
57                                          (#\vtab . vtab)
58                                          (#\page . page)
59                                          (#\return . return)
60                                          (#\space . space)))
61                                cdr)))
62               (write-char #\# port)
63               (write-char #\\ port)
64               (if name (display name)
65                   (write-char x port)))))
66        ((closure? x)
67         (display "#<procedure #f " port)
68         (display (cadr (core:cdr x)) port)
69         (display ">" port))
70        ((macro? x)
71         (display "#<macro " port)
72         (display (core:cdr x) port)
73         (display ">" port))
74        ((number? x) (display (number->string x) port))
75        ((pair? x)
76         (if (not cont?) (write-char #\( port))
77         (cond ((eq? (car x) '*circular*)
78                (display "(*circ* . #-1#)" port))
79               ((eq? (car x) '*closure*)
80                (display "(*closure* . #-1#)" port))
81               (#t
82                (display (car x) port write?)
83                (if (pair? (cdr x)) (d (cdr x) #t " ")
84                    (if (and (cdr x) (not (null? (cdr x))))
85                        (begin
86                          (display " . " port)
87                          (display (cdr x) port write?))))
88                (if (not cont?) (write-char #\) port)))))
89        ((or (keyword? x) (special? x) (string? x) (symbol? x))
90         (if (and (string? x) write?) (write-char #\" port))
91         (if (keyword? x) (display "#:" port))
92         (for-each (cut2 display-char <> write? port) (string->list x))
93         (if (and (string? x) write?) (write-char #\" port)))
94        ((vector? x)
95         (display "#(" port)
96         (for-each (lambda (i)
97                     (let ((x (vector-ref x i)))
98                       (if (vector? x)
99                           (begin
100                             (display (if (= i 0) "" " ") port)
101                             (display "#(...)" port))
102                           (d x #f (if (= i 0) "" " ")))))
103                   (iota (vector-length x)))
104         (display ")" port))
105        ((function? x)
106         (display "#<procedure " port)
107         (display (core:car x) port)
108         (display " " port)
109         (display
110          (case (core:arity x)
111            ((-1) "_")
112            ((0) "()")
113            ((1) "(_)")
114            ((2) "(_ _)")
115            ((3) "(_ _ _)"))
116          port)
117         (display ">" port))
118        ((broken-heart? x)
119         (display "<3" port))
120        (#t
121         (display "TODO type=") (display (cell:type-name x)) (newline)))
122       *unspecified*)
123     (d x #f "")))
124
125 (define (write-char x . rest)
126   (apply write-byte (cons (char->integer x) rest)))
127
128 (define (write x . rest)
129   (let ((port (if (null? rest) (current-output-port) (car rest))))
130     (display x port #t)))
131
132 (define (newline . rest)
133   (apply display (cons "\n" rest)))
134
135 (define (with-output-to-string thunk)
136   (define save-write-byte write-byte)
137   (let ((stdout '()))
138     (set! write-byte
139           (lambda (x . rest)
140             (let ((out? (or (null? rest) (eq? (car rest) (current-output-port)))))
141               (if (not out?) (apply save-write-byte (cons x rest))
142                   (begin
143                     (set! stdout (append stdout (list (integer->char x))))
144                     x)))))
145     (thunk)
146     (let ((r (apply string stdout)))
147       (set! write-byte save-write-byte)
148       r)))