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 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 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 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")) 149 150 ;; bitvectors 151 152 (let ((testv (bitvector #t #f #f #t #t #f #t #t))) 153 (pass-if-equal "#*10011011" 154 (tprint testv 11 "UTF-8")) 155 156 (pass-if-equal "#*10011011" 157 (tprint testv 11 "ISO-8859-1")) 158 159 (pass-if-equal "#*10011…" 160 (tprint testv 8 "UTF-8")) 161 162 (pass-if-equal "#*100..." 163 (tprint testv 8 "ISO-8859-1")) 164 165 (pass-if-equal "#*10…" 166 (tprint testv 5 "UTF-8")) 167 168 (pass-if-equal "#*..." 169 (tprint testv 5 "ISO-8859-1")) 170 171 (pass-if-equal "#*1…" 172 (tprint testv 4 "UTF-8")) 173 174 (pass-if-equal "#" 175 (tprint testv 4 "ISO-8859-1"))) 176 177 ;; rank 0 arrays 178 179 (pass-if-equal "#0(#)" 180 (tprint (make-typed-array #t 9.0) 6 "UTF-8")) 181 182 (pass-if-equal "#0(9.0)" 183 (tprint (make-typed-array #t 9.0) 7 "UTF-8")) 184 185 (pass-if-equal "#0f64(#)" 186 (tprint (make-typed-array 'f64 9.0) 8 "UTF-8")) 187 188 (pass-if-equal "#0f64(9.0)" 189 (tprint (make-typed-array 'f64 9.0) 10 "UTF-8")) 190 191 (pass-if-equal "#" 192 (tprint (make-typed-array 's32 0 20 20) 7 "UTF-8")) 193 194 ;; higher dimensional arrays 195 196 (let ((testa (make-typed-array 's32 0 20 20))) 197 (pass-if-equal "#2s32(…)" 198 (tprint testa 8 "UTF-8")) 199 200 (pass-if-equal "#2s32(# …)" 201 (tprint testa 10 "UTF-8")) 202 203 (pass-if-equal "#2s32((…) …)" 204 (tprint testa 12 "UTF-8")) 205 206 (pass-if-equal "#2s32((0 …) …)" 207 (tprint testa 14 "UTF-8"))) 208 209 ;; check that bounds are printed correctly 210 211 (pass-if-equal "#2@-1@0((foo foo foo foo …) …)" 212 (tprint (make-array 'foo '(-1 3) 5) 30 "UTF-8")) 213 214 (pass-if-equal "#3@-1:5@0:0@0:5(() () () # #)" 215 (tprint (make-array 'foo '(-1 3) 0 5) 30 "UTF-8")) 216 217 ;; nested objects including arrays 218 219 (pass-if-equal "#2((#(9 9) #(9 9)) (#(9 9) #(9 9)))" 220 (tprint (make-typed-array #t (make-typed-array #t 9 2) 2 2) 40 "UTF-8")) 221 222 (pass-if-equal "#(#2((9 9) (9 9)) #2((9 9) (9 9)))" 223 (tprint (make-vector 2 (make-typed-array #t 9 2 2)) 40 "UTF-8")) 224 225 (pass-if-equal "(#2((9 9) (9 9)) #2((9 9) (9 9)))" 226 (tprint (make-list 2 (make-typed-array #t 9 2 2)) 40 "UTF-8")) 227 228 (pass-if-equal "(#0(9) #0(9))" 229 (tprint (make-list 2 (make-typed-array #t 9)) 20 "UTF-8")) 230 231 (pass-if-equal "(#0(9) #)" 232 (tprint (make-list 2 (make-typed-array #t 9)) 10 "UTF-8"))) 233