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 ;;(mes-use-module (mes srfi srfi-1))
  27
  28 (define (srfi-1:member x lst eq)
  29   (if (null? lst) #f
  30       (if (eq x (car lst)) lst
  31           (srfi-1:member x (cdr lst) eq))))
  32
  33 (define (next-xassq x a)
  34   (and=> (srfi-1:member x a (lambda (x e) (eq? x (cdr e))))
  35          (lambda (a) (xassq x (cdr a)))))
  36
  37 (define (next-xassq2 x a)
  38   (and=> (srfi-1:member x a (lambda (x e) (eq? x (cdr e))))
  39          (lambda (a)
  40            (and=> (srfi-1:member x (cdr a) (lambda (x e) (eq? x (cdr e))))
  41                   (lambda (a) (xassq x (cdr a)))))))
  42
  43 (define-macro (display-cut f slot n1)
  44   `(lambda (slot) (,f slot ,n1)))
  45
  46 (define-macro (display-cut2 f slot n1 n2)
  47   `(lambda (slot) (,f slot ,n1 ,n2)))
  48
  49 (define (display x . rest)
  50   (let* ((port (if (null? rest) (current-output-port) (car rest)))
  51          (write? (and (pair? rest) (pair? (cdr rest)) (cadr rest))))
  52
  53     (define (display-char x port write?)
  54       (cond ((and write? (or (eq? x #\") (eq? x #\\)))
  55              (write-char #\\ port)
  56              (write-char x port))
  57             ((and write? (eq? x #\newline))
  58              (write-char #\\ port)
  59              (write-char #\n port))
  60             (#t (write-char x port))))
  61
  62     (define (d x cont? sep)
  63       (for-each (display-cut write-char <> port) (string->list sep))
  64       (cond
  65        ((eof-object? x)
  66         (display "#<eof>" port))
  67        ((char? x)
  68         (if (not write?) (write-char x port)
  69             (let ((name (and=> (assq x '((#\nul . nul)
  70                                          (#\alarm . alarm)
  71                                          (#\backspace . backspace)
  72                                          (#\tab . tab)
  73                                          (#\newline . newline)
  74                                          (#\vtab . vtab)
  75                                          (#\page . page)
  76                                          (#\return . return)
  77                                          (#\space . space)))
  78                                cdr)))
  79               (write-char #\# port)
  80               (write-char #\\ port)
  81               (if name (display name port)
  82                   (write-char x port)))))
  83        ((closure? x)
  84         (display "#<procedure " port)
  85         (let ((name (and=> (next-xassq2 x (current-module)) car)))
  86           (display name port))
  87         (display " " port)
  88         (display (cadr (core:cdr x)) port)
  89         (display ">" port))
  90        ((continuation? x)
  91         (display "#<continuation " port)
  92         (display (core:car x) port)
  93         (display ">" port))
  94        ((macro? x)
  95         (display "#<macro " port)
  96         (display (core:cdr x) port)
  97         (display ">" port))
  98        ((variable? x)
  99         (display "#<variable " port)
 100         (display (car (core:car x)) port)
 101         (display ">" port))
 102        ((number? x)
 103         (display (number->string x) port))
 104        ((pair? x)
 105         (if (not cont?) (write-char #\( port))
 106         (cond ((eq? (car x) '*circular*)
 107                (display "*circ* . #-1#)" port))
 108               ((eq? (car x) '*closure*)
 109                (display "*closure* . #-1#)" port))
 110               (#t
 111                (display (car x) port write?)
 112                (if (pair? (cdr x)) (d (cdr x) #t " ")
 113                    (if (and (cdr x) (not (null? (cdr x))))
 114                        (begin
 115                          (display " . " port)
 116                          (display (cdr x) port write?))))))
 117         (if (not cont?) (write-char #\) port)))
 118        ((or (keyword? x) (special? x) (string? x) (symbol? x))
 119         (if (and (string? x) write?) (write-char #\" port))
 120         (if (keyword? x) (display "#:" port))
 121         (for-each (display-cut2 display-char <> port write?) (string->list x))
 122         (if (and (string? x) write?) (write-char #\" port)))
 123        ((vector? x)
 124         (display "#(" port)
 125         (for-each (lambda (i)
 126                     (let ((x (vector-ref x i)))
 127                       (if (vector? x)
 128                           (begin
 129                             (display (if (= i 0) "" " ") port)
 130                             (display "#(...)" port))
 131                           (d x #f (if (= i 0) "" " ")))))
 132                   (iota (vector-length x)))
 133         (display ")" port))
 134        ((function? x)
 135         (display "#<procedure " port)
 136         (display (core:car x) port)
 137         (display " " port)
 138         (display
 139          (case (core:arity x)
 140            ((-1) "_")
 141            ((0) "()")
 142            ((1) "(_)")
 143            ((2) "(_ _)")
 144            ((3) "(_ _ _)"))
 145          port)
 146         (display ">" port))
 147        ((broken-heart? x)
 148         (display "<3" port))
 149        (#t
 150         (display "TODO type=") (display (cell:type-name x)) (newline)))
 151       *unspecified*)
 152     (d x #f "")))
 153
 154 (define (write-char x . rest)
 155   (apply write-byte (cons (char->integer x) rest)))
 156
 157 (define (write x . rest)
 158   (let ((port (if (null? rest) (current-output-port) (car rest))))
 159     (display x port #t)))
 160
 161 (define (newline . rest)
 162   (apply display (cons "\n" rest)))
 163
 164 (define (with-output-to-string thunk)
 165   (define save-write-byte write-byte)
 166   (let ((stdout '()))
 167     (set! write-byte
 168           (lambda (x . rest)
 169             (let ((out? (or (null? rest) (eq? (car rest) (current-output-port)))))
 170               (if (not out?) (apply save-write-byte (cons x rest))
 171                   (begin
 172                     (set! stdout (append stdout (list (integer->char x))))
 173                     x)))))
 174     (thunk)
 175     (let ((r (apply string stdout)))
 176       (set! write-byte save-write-byte)
 177       r)))
 178
 179 (define (simple-format destination format . rest)
 180   (let ((port (if (boolean? destination) (current-output-port) destination))
 181         (lst (string->list format)))
 182     (define (simple-format lst args)
 183       (if (pair? lst)
 184           (let ((c (car lst)))
 185             (if (not (eq? c #\~)) (begin (write-char (car lst) port)
 186                                          (simple-format (cdr lst) args))
 187                 (let ((c (cadr lst)))
 188                   (case c
 189                     ((#\A) (display (car args) port))
 190                     ((#\a) (display (car args) port))
 191                     ((#\S) (write (car args) port))
 192                     ((#\s) (write (car args) port))
 193                     (else (display (car args) port)))
 194                   (simple-format (cddr lst) (cdr args)))))))
 195
 196     (if destination (simple-format lst rest)
 197         (with-output-to-string
 198           (lambda () (simple-format lst rest))))))
 199
 200 (define format simple-format)