test-suite/tests/print.test

   1 ;;;; -*- coding: utf-8; mode: scheme; -*-
   2 ;;;;
   3 ;;;; Copyright (C) 2010, 2013, 2014  Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 (define-module (test-suite test-print)
  20   #:use-module (ice-9 pretty-print)
  21   #:use-module (test-suite lib))
  22
  23 (define-syntax prints?
  24   ;; #t if EXP prints as RESULT.
  25   (syntax-rules ()
  26     ((_ exp result)
  27      (string=? result
  28                (with-output-to-string
  29                  (lambda ()
  30                    (pretty-print 'exp)))))))
  31
  32 (define (with-print-options opts thunk)
  33   (let ((saved-options (print-options)))
  34     (dynamic-wind
  35         (lambda ()
  36           (print-options opts))
  37         thunk
  38         (lambda ()
  39           (print-options saved-options)))))
  40
  41 (define-syntax-rule (write-with-options opts x)
  42   (with-print-options opts (lambda ()
  43                              (with-output-to-string
  44                                (lambda ()
  45                                  (write x))))))
  46
  47 \f
  48 (with-test-prefix "write"
  49
  50   (with-test-prefix "r7rs-symbols"
  51
  52     (pass-if-equal "basic"
  53         "|foo bar|"
  54       (write-with-options '(r7rs-symbols)
  55                           (string->symbol "foo bar")))
  56
  57     (pass-if-equal "escapes"
  58         "|bar \\| backslash \\x5c; alarm \\a backspace \\b tab \\t newline \\n cr \\r null \\x0; del \\x7f;|"
  59       (write-with-options
  60        '(r7rs-symbols)
  61        (string->symbol
  62         (string-append
  63          "bar | backslash \\ alarm \a backspace \b tab \t newline \n cr \r null \0 del "
  64          (string #\del)))))
  65
  66     (pass-if-equal "brackets"
  67         "|()[]{}|"
  68       (write-with-options '(r7rs-symbols)
  69                           (string->symbol "()[]{}")))
  70
  71     (pass-if-equal "starts with bar"
  72         "|\\|foo|"
  73       (write-with-options '(r7rs-symbols)
  74                           (string->symbol "|foo")))
  75
  76     (pass-if-equal "ends with bar"
  77         "|foo\\||"
  78       (write-with-options '(r7rs-symbols)
  79                           (string->symbol "foo|")))
  80
  81     (pass-if-equal "starts with backslash"
  82         "|\\x5c;foo|"
  83       (write-with-options '(r7rs-symbols)
  84                           (string->symbol "\\foo")))
  85
  86     (pass-if-equal "ends with backslash"
  87         "|foo\\x5c;|"
  88       (write-with-options '(r7rs-symbols)
  89                           (string->symbol "foo\\")))))
  90
  91 \f
  92 (with-test-prefix "pretty-print"
  93
  94   (pass-if "pair"
  95     (prints? (a . b) "(a . b)\n"))
  96
  97   (pass-if "list"
  98     (prints? (a b c) "(a b c)\n"))
  99
 100   (pass-if "dotted list"
 101     (prints? (a b . c) "(a b . c)\n"))
 102
 103   (pass-if "quote"
 104     (prints? 'foo "'foo\n"))
 105
 106   (pass-if "non-starting quote"
 107     (prints? (foo 'bar) "(foo 'bar)\n"))
 108
 109   (pass-if "nested quote"
 110     (prints? (''foo) "(''foo)\n"))
 111
 112   (pass-if "quasiquote & co."
 113     (prints?  (define foo `(bar ,(+ 2 3)))
 114              "(define foo `(bar ,(+ 2 3)))\n")))
 115
 116 \f
 117 (with-test-prefix "truncated-print"
 118   (define exp '(a b #(c d e) f . g))
 119
 120   (define (tprint x width encoding)
 121     (call-with-output-string
 122      (lambda (p)
 123        (set-port-encoding! p encoding)
 124        (truncated-print x p #:width width))))
 125
 126   (pass-if-equal "(a b . #)"
 127       (tprint exp 10 "ISO-8859-1"))
 128
 129   (pass-if-equal "(a b # f . g)"
 130       (tprint exp 15 "ISO-8859-1"))
 131
 132   (pass-if-equal "(a b #(c ...) . #)"
 133       (tprint exp 18 "ISO-8859-1"))
 134
 135   (pass-if-equal "(a b #(c d e) f . g)"
 136       (tprint exp 20 "ISO-8859-1"))
 137
 138   (pass-if-equal "\"The quick brown...\""
 139       (tprint "The quick brown fox" 20 "ISO-8859-1"))
 140
 141   (pass-if-equal "\"The quick brown f…\""
 142       (tprint "The quick brown fox" 20 "UTF-8"))
 143
 144   (pass-if-equal "#<directory (tes...>"
 145       (tprint (current-module) 20 "ISO-8859-1"))
 146
 147   (pass-if-equal "#<directory (test-…>"
 148       (tprint (current-module) 20 "UTF-8")))