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