Commit | Line | Data |
---|---|---|
c5e05a1c | 1 | ;;;; -*- coding: utf-8; mode: scheme; -*- |
87a6a236 | 2 | ;;;; |
c92ee2b3 | 3 | ;;;; Copyright (C) 2010, 2013, 2014 Free Software Foundation, Inc. |
87a6a236 AW |
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. | |
c5e05a1c | 9 | ;;;; |
87a6a236 AW |
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. | |
c5e05a1c | 14 | ;;;; |
87a6a236 AW |
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 | ||
5bae880e LC |
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 | ||
6e504a7b MW |
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 | ||
1fc651e3 MW |
66 | (pass-if-equal "brackets" |
67 | "|()[]{}|" | |
68 | (write-with-options '(r7rs-symbols) | |
69 | (string->symbol "()[]{}"))) | |
70 | ||
6e504a7b MW |
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 | ||
5bae880e LC |
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 | |
87a6a236 AW |
117 | (with-test-prefix "truncated-print" |
118 | (define exp '(a b #(c d e) f . g)) | |
c5e05a1c LC |
119 | |
120 | (define (tprint x width encoding) | |
6dce942c MW |
121 | (call-with-output-string |
122 | (lambda (p) | |
123 | (set-port-encoding! p encoding) | |
124 | (truncated-print x p #:width width)))) | |
c5e05a1c | 125 | |
6dce942c MW |
126 | (pass-if-equal "(a b . #)" |
127 | (tprint exp 10 "ISO-8859-1")) | |
c5e05a1c | 128 | |
6dce942c MW |
129 | (pass-if-equal "(a b # f . g)" |
130 | (tprint exp 15 "ISO-8859-1")) | |
c5e05a1c | 131 | |
6dce942c MW |
132 | (pass-if-equal "(a b #(c ...) . #)" |
133 | (tprint exp 18 "ISO-8859-1")) | |
c5e05a1c | 134 | |
6dce942c MW |
135 | (pass-if-equal "(a b #(c d e) f . g)" |
136 | (tprint exp 20 "ISO-8859-1")) | |
c5e05a1c | 137 | |
6dce942c MW |
138 | (pass-if-equal "\"The quick brown...\"" |
139 | (tprint "The quick brown fox" 20 "ISO-8859-1")) | |
c5e05a1c | 140 | |
6dce942c MW |
141 | (pass-if-equal "\"The quick brown f…\"" |
142 | (tprint "The quick brown fox" 20 "UTF-8")) | |
c5e05a1c | 143 | |
6dce942c MW |
144 | (pass-if-equal "#<directory (tes...>" |
145 | (tprint (current-module) 20 "ISO-8859-1")) | |
c5e05a1c | 146 | |
6dce942c MW |
147 | (pass-if-equal "#<directory (test-…>" |
148 | (tprint (current-module) 20 "UTF-8"))) |