|
rlm@10
|
1 ;;; test_pretty.clj -- part of the pretty printer for Clojure
|
|
rlm@10
|
2
|
|
rlm@10
|
3 ; Copyright (c) Rich Hickey. All rights reserved.
|
|
rlm@10
|
4 ; The use and distribution terms for this software are covered by the
|
|
rlm@10
|
5 ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
|
|
rlm@10
|
6 ; which can be found in the file epl-v10.html at the root of this distribution.
|
|
rlm@10
|
7 ; By using this software in any fashion, you are agreeing to be bound by
|
|
rlm@10
|
8 ; the terms of this license.
|
|
rlm@10
|
9 ; You must not remove this notice, or any other, from this software.
|
|
rlm@10
|
10
|
|
rlm@10
|
11 ;; Author: Tom Faulhaber
|
|
rlm@10
|
12 ;; April 3, 2009
|
|
rlm@10
|
13
|
|
rlm@10
|
14
|
|
rlm@10
|
15 (in-ns 'clojure.test-clojure.pprint)
|
|
rlm@10
|
16
|
|
rlm@10
|
17 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
rlm@10
|
18 ;;;
|
|
rlm@10
|
19 ;;; Unit tests for the pretty printer
|
|
rlm@10
|
20 ;;;
|
|
rlm@10
|
21 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
rlm@10
|
22
|
|
rlm@10
|
23 (simple-tests xp-fill-test
|
|
rlm@10
|
24 (binding [*print-pprint-dispatch* simple-dispatch
|
|
rlm@10
|
25 *print-right-margin* 38
|
|
rlm@10
|
26 *print-miser-width* nil]
|
|
rlm@10
|
27 (cl-format nil "(let ~:<~@{~:<~w ~_~w~:>~^ ~:_~}~:>~_ ...)~%"
|
|
rlm@10
|
28 '((x 4) (*print-length* nil) (z 2) (list nil))))
|
|
rlm@10
|
29 "(let ((x 4) (*print-length* nil)\n (z 2) (list nil))\n ...)\n"
|
|
rlm@10
|
30
|
|
rlm@10
|
31 (binding [*print-pprint-dispatch* simple-dispatch
|
|
rlm@10
|
32 *print-right-margin* 22]
|
|
rlm@10
|
33 (cl-format nil "(let ~:<~@{~:<~w ~_~w~:>~^ ~:_~}~:>~_ ...)~%"
|
|
rlm@10
|
34 '((x 4) (*print-length* nil) (z 2) (list nil))))
|
|
rlm@10
|
35 "(let ((x 4)\n (*print-length*\n nil)\n (z 2)\n (list nil))\n ...)\n")
|
|
rlm@10
|
36
|
|
rlm@10
|
37 (simple-tests xp-miser-test
|
|
rlm@10
|
38 (binding [*print-pprint-dispatch* simple-dispatch
|
|
rlm@10
|
39 *print-right-margin* 10, *print-miser-width* 9]
|
|
rlm@10
|
40 (cl-format nil "~:<LIST ~@_~W ~@_~W ~@_~W~:>" '(first second third)))
|
|
rlm@10
|
41 "(LIST\n first\n second\n third)"
|
|
rlm@10
|
42
|
|
rlm@10
|
43 (binding [*print-pprint-dispatch* simple-dispatch
|
|
rlm@10
|
44 *print-right-margin* 10, *print-miser-width* 8]
|
|
rlm@10
|
45 (cl-format nil "~:<LIST ~@_~W ~@_~W ~@_~W~:>" '(first second third)))
|
|
rlm@10
|
46 "(LIST first second third)")
|
|
rlm@10
|
47
|
|
rlm@10
|
48 (simple-tests mandatory-fill-test
|
|
rlm@10
|
49 (cl-format nil
|
|
rlm@10
|
50 "<pre>~%~<Usage: ~:I~@{*~a*~^~:@_~}~:>~%</pre>~%"
|
|
rlm@10
|
51 [ "hello" "gooodbye" ])
|
|
rlm@10
|
52 "<pre>
|
|
rlm@10
|
53 Usage: *hello*
|
|
rlm@10
|
54 *gooodbye*
|
|
rlm@10
|
55 </pre>
|
|
rlm@10
|
56 ")
|
|
rlm@10
|
57
|
|
rlm@10
|
58 (simple-tests prefix-suffix-test
|
|
rlm@10
|
59 (binding [*print-pprint-dispatch* simple-dispatch
|
|
rlm@10
|
60 *print-right-margin* 10, *print-miser-width* 10]
|
|
rlm@10
|
61 (cl-format nil "~<{~;LIST ~@_~W ~@_~W ~@_~W~;}~:>" '(first second third)))
|
|
rlm@10
|
62 "{LIST\n first\n second\n third}")
|
|
rlm@10
|
63
|
|
rlm@10
|
64 (simple-tests pprint-test
|
|
rlm@10
|
65 (binding [*print-pprint-dispatch* simple-dispatch]
|
|
rlm@10
|
66 (write '(defn foo [x y]
|
|
rlm@10
|
67 (let [result (* x y)]
|
|
rlm@10
|
68 (if (> result 400)
|
|
rlm@10
|
69 (cl-format true "That number is too big")
|
|
rlm@10
|
70 (cl-format true "The result of ~d x ~d is ~d" x y result))))
|
|
rlm@10
|
71 :stream nil))
|
|
rlm@10
|
72 "(defn
|
|
rlm@10
|
73 foo
|
|
rlm@10
|
74 [x y]
|
|
rlm@10
|
75 (let
|
|
rlm@10
|
76 [result (* x y)]
|
|
rlm@10
|
77 (if
|
|
rlm@10
|
78 (> result 400)
|
|
rlm@10
|
79 (cl-format true \"That number is too big\")
|
|
rlm@10
|
80 (cl-format true \"The result of ~d x ~d is ~d\" x y result))))"
|
|
rlm@10
|
81
|
|
rlm@10
|
82 (with-pprint-dispatch code-dispatch
|
|
rlm@10
|
83 (write '(defn foo [x y]
|
|
rlm@10
|
84 (let [result (* x y)]
|
|
rlm@10
|
85 (if (> result 400)
|
|
rlm@10
|
86 (cl-format true "That number is too big")
|
|
rlm@10
|
87 (cl-format true "The result of ~d x ~d is ~d" x y result))))
|
|
rlm@10
|
88 :stream nil))
|
|
rlm@10
|
89 "(defn foo [x y]
|
|
rlm@10
|
90 (let [result (* x y)]
|
|
rlm@10
|
91 (if (> result 400)
|
|
rlm@10
|
92 (cl-format true \"That number is too big\")
|
|
rlm@10
|
93 (cl-format true \"The result of ~d x ~d is ~d\" x y result))))"
|
|
rlm@10
|
94
|
|
rlm@10
|
95 (binding [*print-pprint-dispatch* simple-dispatch
|
|
rlm@10
|
96 *print-right-margin* 15]
|
|
rlm@10
|
97 (write '(fn (cons (car x) (cdr y))) :stream nil))
|
|
rlm@10
|
98 "(fn\n (cons\n (car x)\n (cdr y)))"
|
|
rlm@10
|
99
|
|
rlm@10
|
100 (with-pprint-dispatch code-dispatch
|
|
rlm@10
|
101 (binding [*print-right-margin* 52]
|
|
rlm@10
|
102 (write
|
|
rlm@10
|
103 '(add-to-buffer this (make-buffer-blob (str (char c)) nil))
|
|
rlm@10
|
104 :stream nil)))
|
|
rlm@10
|
105 "(add-to-buffer\n this\n (make-buffer-blob (str (char c)) nil))"
|
|
rlm@10
|
106 )
|
|
rlm@10
|
107
|
|
rlm@10
|
108
|
|
rlm@10
|
109
|
|
rlm@10
|
110 (simple-tests pprint-reader-macro-test
|
|
rlm@10
|
111 (with-pprint-dispatch code-dispatch
|
|
rlm@10
|
112 (write (read-string "(map #(first %) [[1 2 3] [4 5 6] [7]])")
|
|
rlm@10
|
113 :stream nil))
|
|
rlm@10
|
114 "(map #(first %) [[1 2 3] [4 5 6] [7]])"
|
|
rlm@10
|
115
|
|
rlm@10
|
116 (with-pprint-dispatch code-dispatch
|
|
rlm@10
|
117 (write (read-string "@@(ref (ref 1))")
|
|
rlm@10
|
118 :stream nil))
|
|
rlm@10
|
119 "@@(ref (ref 1))"
|
|
rlm@10
|
120
|
|
rlm@10
|
121 (with-pprint-dispatch code-dispatch
|
|
rlm@10
|
122 (write (read-string "'foo")
|
|
rlm@10
|
123 :stream nil))
|
|
rlm@10
|
124 "'foo"
|
|
rlm@10
|
125 )
|
|
rlm@10
|
126
|
|
rlm@10
|
127 (simple-tests code-block-tests
|
|
rlm@10
|
128 (with-out-str
|
|
rlm@10
|
129 (with-pprint-dispatch code-dispatch
|
|
rlm@10
|
130 (pprint
|
|
rlm@10
|
131 '(defn cl-format
|
|
rlm@10
|
132 "An implementation of a Common Lisp compatible format function"
|
|
rlm@10
|
133 [stream format-in & args]
|
|
rlm@10
|
134 (let [compiled-format (if (string? format-in) (compile-format format-in) format-in)
|
|
rlm@10
|
135 navigator (init-navigator args)]
|
|
rlm@10
|
136 (execute-format stream compiled-format navigator))))))
|
|
rlm@10
|
137 "(defn cl-format
|
|
rlm@10
|
138 \"An implementation of a Common Lisp compatible format function\"
|
|
rlm@10
|
139 [stream format-in & args]
|
|
rlm@10
|
140 (let [compiled-format (if (string? format-in)
|
|
rlm@10
|
141 (compile-format format-in)
|
|
rlm@10
|
142 format-in)
|
|
rlm@10
|
143 navigator (init-navigator args)]
|
|
rlm@10
|
144 (execute-format stream compiled-format navigator)))
|
|
rlm@10
|
145 "
|
|
rlm@10
|
146
|
|
rlm@10
|
147 (with-out-str
|
|
rlm@10
|
148 (with-pprint-dispatch code-dispatch
|
|
rlm@10
|
149 (pprint
|
|
rlm@10
|
150 '(defn pprint-defn [writer alis]
|
|
rlm@10
|
151 (if (next alis)
|
|
rlm@10
|
152 (let [[defn-sym defn-name & stuff] alis
|
|
rlm@10
|
153 [doc-str stuff] (if (string? (first stuff))
|
|
rlm@10
|
154 [(first stuff) (next stuff)]
|
|
rlm@10
|
155 [nil stuff])
|
|
rlm@10
|
156 [attr-map stuff] (if (map? (first stuff))
|
|
rlm@10
|
157 [(first stuff) (next stuff)]
|
|
rlm@10
|
158 [nil stuff])]
|
|
rlm@10
|
159 (pprint-logical-block writer :prefix "(" :suffix ")"
|
|
rlm@10
|
160 (cl-format true "~w ~1I~@_~w" defn-sym defn-name)
|
|
rlm@10
|
161 (if doc-str
|
|
rlm@10
|
162 (cl-format true " ~_~w" doc-str))
|
|
rlm@10
|
163 (if attr-map
|
|
rlm@10
|
164 (cl-format true " ~_~w" attr-map))
|
|
rlm@10
|
165 ;; Note: the multi-defn case will work OK for malformed defns too
|
|
rlm@10
|
166 (cond
|
|
rlm@10
|
167 (vector? (first stuff)) (single-defn stuff (or doc-str attr-map))
|
|
rlm@10
|
168 :else (multi-defn stuff (or doc-str attr-map)))))
|
|
rlm@10
|
169 (pprint-simple-code-list writer alis))))))
|
|
rlm@10
|
170 "(defn pprint-defn [writer alis]
|
|
rlm@10
|
171 (if (next alis)
|
|
rlm@10
|
172 (let [[defn-sym defn-name & stuff] alis
|
|
rlm@10
|
173 [doc-str stuff] (if (string? (first stuff))
|
|
rlm@10
|
174 [(first stuff) (next stuff)]
|
|
rlm@10
|
175 [nil stuff])
|
|
rlm@10
|
176 [attr-map stuff] (if (map? (first stuff))
|
|
rlm@10
|
177 [(first stuff) (next stuff)]
|
|
rlm@10
|
178 [nil stuff])]
|
|
rlm@10
|
179 (pprint-logical-block
|
|
rlm@10
|
180 writer
|
|
rlm@10
|
181 :prefix
|
|
rlm@10
|
182 \"(\"
|
|
rlm@10
|
183 :suffix
|
|
rlm@10
|
184 \")\"
|
|
rlm@10
|
185 (cl-format true \"~w ~1I~@_~w\" defn-sym defn-name)
|
|
rlm@10
|
186 (if doc-str (cl-format true \" ~_~w\" doc-str))
|
|
rlm@10
|
187 (if attr-map (cl-format true \" ~_~w\" attr-map))
|
|
rlm@10
|
188 (cond
|
|
rlm@10
|
189 (vector? (first stuff)) (single-defn
|
|
rlm@10
|
190 stuff
|
|
rlm@10
|
191 (or doc-str attr-map))
|
|
rlm@10
|
192 :else (multi-defn stuff (or doc-str attr-map)))))
|
|
rlm@10
|
193 (pprint-simple-code-list writer alis)))
|
|
rlm@10
|
194 ")
|
|
rlm@10
|
195
|
|
rlm@10
|
196
|
|
rlm@10
|
197 (defn tst-pprint
|
|
rlm@10
|
198 "A helper function to pprint to a string with a restricted right margin"
|
|
rlm@10
|
199 [right-margin obj]
|
|
rlm@10
|
200 (binding [*print-right-margin* right-margin
|
|
rlm@10
|
201 *print-pretty* true]
|
|
rlm@10
|
202 (write obj :stream nil)))
|
|
rlm@10
|
203
|
|
rlm@10
|
204 ;;; A bunch of predefined data to print
|
|
rlm@10
|
205 (def future-filled (future-call (fn [] 100)))
|
|
rlm@10
|
206 @future-filled
|
|
rlm@10
|
207 (def future-unfilled (future-call (fn [] (.acquire (java.util.concurrent.Semaphore. 0)))))
|
|
rlm@10
|
208 (def promise-filled (promise))
|
|
rlm@10
|
209 (deliver promise-filled '(first second third))
|
|
rlm@10
|
210 (def promise-unfilled (promise))
|
|
rlm@10
|
211 (def basic-agent (agent '(first second third)))
|
|
rlm@10
|
212 (defn failed-agent
|
|
rlm@10
|
213 "must be a fn because you cannot await agents during load"
|
|
rlm@10
|
214 []
|
|
rlm@10
|
215 (let [a (agent "foo")]
|
|
rlm@10
|
216 (send a +)
|
|
rlm@10
|
217 (try (await-for 100 failed-agent) (catch RuntimeException re))
|
|
rlm@10
|
218 a))
|
|
rlm@10
|
219 (def basic-atom (atom '(first second third)))
|
|
rlm@10
|
220 (def basic-ref (ref '(first second third)))
|
|
rlm@10
|
221 (def delay-forced (delay '(first second third)))
|
|
rlm@10
|
222 (force delay-forced)
|
|
rlm@10
|
223 (def delay-unforced (delay '(first second third)))
|
|
rlm@10
|
224 (defrecord pprint-test-rec [a b c])
|
|
rlm@10
|
225
|
|
rlm@10
|
226 (simple-tests pprint-datastructures-tests
|
|
rlm@10
|
227 (tst-pprint 20 future-filled) #"#<Future@[0-9a-f]+: \n 100>"
|
|
rlm@10
|
228 (tst-pprint 20 future-unfilled) #"#<Future@[0-9a-f]+: \n :pending>"
|
|
rlm@10
|
229 (tst-pprint 20 promise-filled) #"#<Promise@[0-9a-f]+: \n \(first\n second\n third\)>"
|
|
rlm@10
|
230 ;; This hangs currently, cause we can't figure out whether a promise is filled
|
|
rlm@10
|
231 ;;(tst-pprint 20 promise-unfilled) #"#<Promise@[0-9a-f]+: \n :pending>"
|
|
rlm@10
|
232 (tst-pprint 20 basic-agent) #"#<Agent@[0-9a-f]+: \n \(first\n second\n third\)>"
|
|
rlm@10
|
233 (tst-pprint 20 (failed-agent)) #"#<Agent@[0-9a-f]+ FAILED: \n \"foo\">"
|
|
rlm@10
|
234 (tst-pprint 20 basic-atom) #"#<Atom@[0-9a-f]+: \n \(first\n second\n third\)>"
|
|
rlm@10
|
235 (tst-pprint 20 basic-ref) #"#<Ref@[0-9a-f]+: \n \(first\n second\n third\)>"
|
|
rlm@10
|
236 (tst-pprint 20 delay-forced) #"#<Delay@[0-9a-f]+: \n \(first\n second\n third\)>"
|
|
rlm@10
|
237 ;; Currently no way not to force the delay
|
|
rlm@10
|
238 ;;(tst-pprint 20 delay-unforced) #"#<Delay@[0-9a-f]+: \n :pending>"
|
|
rlm@10
|
239 (tst-pprint 20 (pprint-test-rec. 'first 'second 'third)) "{:a first,\n :b second,\n :c third}"
|
|
rlm@10
|
240
|
|
rlm@10
|
241 ;; basic java arrays: fails owing to assembla ticket #346
|
|
rlm@10
|
242 ;;(tst-pprint 10 (int-array (range 7))) "[0,\n 1,\n 2,\n 3,\n 4,\n 5,\n 6]"
|
|
rlm@10
|
243 (tst-pprint 15 (reduce conj clojure.lang.PersistentQueue/EMPTY (range 10)))
|
|
rlm@10
|
244 "<-(0\n 1\n 2\n 3\n 4\n 5\n 6\n 7\n 8\n 9)-<"
|
|
rlm@10
|
245 )
|
|
rlm@10
|
246
|
|
rlm@10
|
247
|
|
rlm@10
|
248 ;;; Some simple tests of dispatch
|
|
rlm@10
|
249
|
|
rlm@10
|
250 (defmulti
|
|
rlm@10
|
251 test-dispatch
|
|
rlm@10
|
252 "A test dispatch method"
|
|
rlm@10
|
253 {:added "1.2" :arglists '[[object]]}
|
|
rlm@10
|
254 #(and (seq %) (not (string? %))))
|
|
rlm@10
|
255
|
|
rlm@10
|
256 (defmethod test-dispatch true [avec]
|
|
rlm@10
|
257 (pprint-logical-block :prefix "[" :suffix "]"
|
|
rlm@10
|
258 (loop [aseq (seq avec)]
|
|
rlm@10
|
259 (when aseq
|
|
rlm@10
|
260 (write-out (first aseq))
|
|
rlm@10
|
261 (when (next aseq)
|
|
rlm@10
|
262 (.write ^java.io.Writer *out* " ")
|
|
rlm@10
|
263 (pprint-newline :linear)
|
|
rlm@10
|
264 (recur (next aseq)))))))
|
|
rlm@10
|
265
|
|
rlm@10
|
266 (defmethod test-dispatch false [aval] (pr aval))
|
|
rlm@10
|
267
|
|
rlm@10
|
268 (simple-tests dispatch-tests
|
|
rlm@10
|
269 (with-pprint-dispatch test-dispatch
|
|
rlm@10
|
270 (with-out-str
|
|
rlm@10
|
271 (pprint '("hello" "there"))))
|
|
rlm@10
|
272 "[\"hello\" \"there\"]\n"
|
|
rlm@10
|
273 )
|
|
rlm@10
|
274
|
|
rlm@10
|
275
|
