1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/clojure/test_clojure/pprint/test_pretty.clj	Sat Aug 21 06:25:44 2010 -0400
     1.3 @@ -0,0 +1,275 @@
     1.4 +;;; test_pretty.clj -- part of the pretty printer for Clojure
     1.5 +
     1.6 +;   Copyright (c) Rich Hickey. All rights reserved.
     1.7 +;   The use and distribution terms for this software are covered by the
     1.8 +;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
     1.9 +;   which can be found in the file epl-v10.html at the root of this distribution.
    1.10 +;   By using this software in any fashion, you are agreeing to be bound by
    1.11 +;   the terms of this license.
    1.12 +;   You must not remove this notice, or any other, from this software.
    1.13 +
    1.14 +;; Author: Tom Faulhaber
    1.15 +;; April 3, 2009
    1.16 +
    1.17 +
    1.18 +(in-ns 'clojure.test-clojure.pprint)
    1.19 +
    1.20 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.21 +;;;
    1.22 +;;; Unit tests for the pretty printer
    1.23 +;;;
    1.24 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.25 +
    1.26 +(simple-tests xp-fill-test
    1.27 +  (binding [*print-pprint-dispatch* simple-dispatch
    1.28 +            *print-right-margin* 38
    1.29 +            *print-miser-width* nil]
    1.30 +    (cl-format nil "(let ~:<~@{~:<~w ~_~w~:>~^ ~:_~}~:>~_ ...)~%"
    1.31 +               '((x 4) (*print-length* nil) (z 2) (list nil))))
    1.32 +  "(let ((x 4) (*print-length* nil)\n      (z 2) (list nil))\n ...)\n"
    1.33 +
    1.34 +  (binding [*print-pprint-dispatch* simple-dispatch
    1.35 +            *print-right-margin* 22]
    1.36 +    (cl-format nil "(let ~:<~@{~:<~w ~_~w~:>~^ ~:_~}~:>~_ ...)~%"
    1.37 +               '((x 4) (*print-length* nil) (z 2) (list nil))))
    1.38 +  "(let ((x 4)\n      (*print-length*\n       nil)\n      (z 2)\n      (list nil))\n ...)\n")
    1.39 +
    1.40 +(simple-tests xp-miser-test
    1.41 +  (binding [*print-pprint-dispatch* simple-dispatch
    1.42 +            *print-right-margin* 10, *print-miser-width* 9]
    1.43 +    (cl-format nil "~:<LIST ~@_~W ~@_~W ~@_~W~:>" '(first second third)))
    1.44 +  "(LIST\n first\n second\n third)"
    1.45 +
    1.46 +  (binding [*print-pprint-dispatch* simple-dispatch
    1.47 +            *print-right-margin* 10, *print-miser-width* 8]
    1.48 +    (cl-format nil "~:<LIST ~@_~W ~@_~W ~@_~W~:>" '(first second third)))
    1.49 +  "(LIST first second third)")
    1.50 +
    1.51 +(simple-tests mandatory-fill-test
    1.52 +  (cl-format nil
    1.53 +             "<pre>~%~<Usage: ~:I~@{*~a*~^~:@_~}~:>~%</pre>~%"
    1.54 +             [ "hello" "gooodbye" ])
    1.55 +  "<pre>
    1.56 +Usage: *hello*
    1.57 +       *gooodbye*
    1.58 +</pre>
    1.59 +")
    1.60 +
    1.61 +(simple-tests prefix-suffix-test
    1.62 +  (binding [*print-pprint-dispatch* simple-dispatch
    1.63 +            *print-right-margin* 10, *print-miser-width* 10]
    1.64 +    (cl-format nil "~<{~;LIST ~@_~W ~@_~W ~@_~W~;}~:>" '(first second third)))
    1.65 +  "{LIST\n first\n second\n third}")
    1.66 +
    1.67 +(simple-tests pprint-test
    1.68 +  (binding [*print-pprint-dispatch* simple-dispatch]
    1.69 +    (write '(defn foo [x y] 
    1.70 +              (let [result (* x y)] 
    1.71 +                (if (> result 400) 
    1.72 +                  (cl-format true "That number is too big")
    1.73 +                  (cl-format true "The  result of ~d x ~d is ~d" x y result))))
    1.74 +           :stream nil))
    1.75 +  "(defn
    1.76 + foo
    1.77 + [x y]
    1.78 + (let
    1.79 +  [result (* x y)]
    1.80 +  (if
    1.81 +   (> result 400)
    1.82 +   (cl-format true \"That number is too big\")
    1.83 +   (cl-format true \"The  result of ~d x ~d is ~d\" x y result))))"
    1.84 +
    1.85 +  (with-pprint-dispatch code-dispatch
    1.86 +    (write '(defn foo [x y] 
    1.87 +              (let [result (* x y)] 
    1.88 +                (if (> result 400) 
    1.89 +                  (cl-format true "That number is too big")
    1.90 +                  (cl-format true "The  result of ~d x ~d is ~d" x y result))))
    1.91 +           :stream nil))
    1.92 +  "(defn foo [x y]
    1.93 +  (let [result (* x y)]
    1.94 +    (if (> result 400)
    1.95 +      (cl-format true \"That number is too big\")
    1.96 +      (cl-format true \"The  result of ~d x ~d is ~d\" x y result))))"
    1.97 +
    1.98 +  (binding [*print-pprint-dispatch* simple-dispatch
    1.99 +            *print-right-margin* 15] 
   1.100 +    (write '(fn (cons (car x) (cdr y))) :stream nil))
   1.101 +  "(fn\n (cons\n  (car x)\n  (cdr y)))"
   1.102 +
   1.103 +  (with-pprint-dispatch code-dispatch
   1.104 +    (binding [*print-right-margin* 52] 
   1.105 +      (write 
   1.106 +       '(add-to-buffer this (make-buffer-blob (str (char c)) nil))
   1.107 +       :stream nil)))
   1.108 +  "(add-to-buffer\n  this\n  (make-buffer-blob (str (char c)) nil))"
   1.109 +  )
   1.110 +
   1.111 +
   1.112 +
   1.113 +(simple-tests pprint-reader-macro-test
   1.114 +  (with-pprint-dispatch code-dispatch
   1.115 +    (write (read-string "(map #(first %) [[1 2 3] [4 5 6] [7]])")
   1.116 +	   :stream nil))
   1.117 +  "(map #(first %) [[1 2 3] [4 5 6] [7]])"
   1.118 +
   1.119 +  (with-pprint-dispatch code-dispatch
   1.120 +    (write (read-string "@@(ref (ref 1))")
   1.121 +	   :stream nil))
   1.122 +  "@@(ref (ref 1))"
   1.123 +
   1.124 +  (with-pprint-dispatch code-dispatch
   1.125 +    (write (read-string "'foo")
   1.126 +	   :stream nil))
   1.127 +  "'foo"
   1.128 +)
   1.129 +
   1.130 +(simple-tests code-block-tests 
   1.131 + (with-out-str
   1.132 +   (with-pprint-dispatch code-dispatch 
   1.133 +     (pprint 
   1.134 +      '(defn cl-format 
   1.135 +         "An implementation of a Common Lisp compatible format function"
   1.136 +         [stream format-in & args]
   1.137 +         (let [compiled-format (if (string? format-in) (compile-format format-in) format-in)
   1.138 +               navigator (init-navigator args)]
   1.139 +           (execute-format stream compiled-format navigator))))))
   1.140 + "(defn cl-format
   1.141 +  \"An implementation of a Common Lisp compatible format function\"
   1.142 +  [stream format-in & args]
   1.143 +  (let [compiled-format (if (string? format-in)
   1.144 +                          (compile-format format-in)
   1.145 +                          format-in)
   1.146 +        navigator (init-navigator args)]
   1.147 +    (execute-format stream compiled-format navigator)))
   1.148 +"
   1.149 +
   1.150 + (with-out-str
   1.151 +   (with-pprint-dispatch code-dispatch 
   1.152 +     (pprint 
   1.153 +      '(defn pprint-defn [writer alis]
   1.154 +         (if (next alis) 
   1.155 +           (let [[defn-sym defn-name & stuff] alis
   1.156 +                 [doc-str stuff] (if (string? (first stuff))
   1.157 +                                   [(first stuff) (next stuff)]
   1.158 +                                   [nil stuff])
   1.159 +                 [attr-map stuff] (if (map? (first stuff))
   1.160 +                                    [(first stuff) (next stuff)]
   1.161 +                                    [nil stuff])]
   1.162 +             (pprint-logical-block writer :prefix "(" :suffix ")"
   1.163 +                                   (cl-format true "~w ~1I~@_~w" defn-sym defn-name)
   1.164 +                                   (if doc-str
   1.165 +                                     (cl-format true " ~_~w" doc-str))
   1.166 +                                   (if attr-map
   1.167 +                                     (cl-format true " ~_~w" attr-map))
   1.168 +                                   ;; Note: the multi-defn case will work OK for malformed defns too
   1.169 +                                   (cond
   1.170 +                                    (vector? (first stuff)) (single-defn stuff (or doc-str attr-map))
   1.171 +                                    :else (multi-defn stuff (or doc-str attr-map)))))
   1.172 +           (pprint-simple-code-list writer alis))))))
   1.173 + "(defn pprint-defn [writer alis]
   1.174 +  (if (next alis)
   1.175 +    (let [[defn-sym defn-name & stuff] alis
   1.176 +          [doc-str stuff] (if (string? (first stuff))
   1.177 +                            [(first stuff) (next stuff)]
   1.178 +                            [nil stuff])
   1.179 +          [attr-map stuff] (if (map? (first stuff))
   1.180 +                             [(first stuff) (next stuff)]
   1.181 +                             [nil stuff])]
   1.182 +      (pprint-logical-block
   1.183 +        writer
   1.184 +        :prefix
   1.185 +        \"(\"
   1.186 +        :suffix
   1.187 +        \")\"
   1.188 +        (cl-format true \"~w ~1I~@_~w\" defn-sym defn-name)
   1.189 +        (if doc-str (cl-format true \" ~_~w\" doc-str))
   1.190 +        (if attr-map (cl-format true \" ~_~w\" attr-map))
   1.191 +        (cond
   1.192 +          (vector? (first stuff)) (single-defn
   1.193 +                                    stuff
   1.194 +                                    (or doc-str attr-map))
   1.195 +          :else (multi-defn stuff (or doc-str attr-map)))))
   1.196 +    (pprint-simple-code-list writer alis)))
   1.197 +")
   1.198 +
   1.199 +
   1.200 +(defn tst-pprint
   1.201 +  "A helper function to pprint to a string with a restricted right margin"
   1.202 +  [right-margin obj]
   1.203 +  (binding [*print-right-margin* right-margin
   1.204 +            *print-pretty* true]
   1.205 +    (write obj :stream nil)))
   1.206 +
   1.207 +;;; A bunch of predefined data to print
   1.208 +(def future-filled (future-call (fn [] 100)))
   1.209 +@future-filled
   1.210 +(def future-unfilled (future-call (fn [] (.acquire (java.util.concurrent.Semaphore. 0)))))
   1.211 +(def promise-filled (promise))
   1.212 +(deliver promise-filled '(first second third))
   1.213 +(def promise-unfilled (promise))
   1.214 +(def basic-agent (agent '(first second third)))
   1.215 +(defn failed-agent
   1.216 +  "must be a fn because you cannot await agents during load"
   1.217 +  []
   1.218 +  (let [a (agent "foo")]
   1.219 +    (send a +)
   1.220 +    (try (await-for 100 failed-agent) (catch RuntimeException re))
   1.221 +    a))
   1.222 +(def basic-atom (atom '(first second third)))
   1.223 +(def basic-ref (ref '(first second third)))
   1.224 +(def delay-forced (delay '(first second third)))
   1.225 +(force delay-forced)
   1.226 +(def delay-unforced (delay '(first second third)))
   1.227 +(defrecord pprint-test-rec [a b c])
   1.228 +
   1.229 +(simple-tests pprint-datastructures-tests
   1.230 + (tst-pprint 20 future-filled) #"#<Future@[0-9a-f]+: \n  100>"
   1.231 + (tst-pprint 20 future-unfilled) #"#<Future@[0-9a-f]+: \n  :pending>"
   1.232 + (tst-pprint 20 promise-filled) #"#<Promise@[0-9a-f]+: \n  \(first\n   second\n   third\)>"
   1.233 + ;; This hangs currently, cause we can't figure out whether a promise is filled
   1.234 + ;;(tst-pprint 20 promise-unfilled) #"#<Promise@[0-9a-f]+: \n  :pending>"
   1.235 + (tst-pprint 20 basic-agent) #"#<Agent@[0-9a-f]+: \n  \(first\n   second\n   third\)>"
   1.236 + (tst-pprint 20 (failed-agent)) #"#<Agent@[0-9a-f]+ FAILED: \n  \"foo\">"
   1.237 + (tst-pprint 20 basic-atom) #"#<Atom@[0-9a-f]+: \n  \(first\n   second\n   third\)>"
   1.238 + (tst-pprint 20 basic-ref) #"#<Ref@[0-9a-f]+: \n  \(first\n   second\n   third\)>"
   1.239 + (tst-pprint 20 delay-forced) #"#<Delay@[0-9a-f]+: \n  \(first\n   second\n   third\)>"
   1.240 + ;; Currently no way not to force the delay
   1.241 + ;;(tst-pprint 20 delay-unforced) #"#<Delay@[0-9a-f]+: \n  :pending>"
   1.242 + (tst-pprint 20 (pprint-test-rec. 'first 'second 'third)) "{:a first,\n :b second,\n :c third}"
   1.243 +
   1.244 + ;; basic java arrays: fails owing to assembla ticket #346
   1.245 + ;;(tst-pprint 10 (int-array (range 7))) "[0,\n 1,\n 2,\n 3,\n 4,\n 5,\n 6]"
   1.246 + (tst-pprint 15 (reduce conj clojure.lang.PersistentQueue/EMPTY (range 10)))
   1.247 + "<-(0\n   1\n   2\n   3\n   4\n   5\n   6\n   7\n   8\n   9)-<"
   1.248 + )
   1.249 +
   1.250 +
   1.251 +;;; Some simple tests of dispatch
   1.252 +
   1.253 +(defmulti 
   1.254 +  test-dispatch
   1.255 +  "A test dispatch method"
   1.256 +  {:added "1.2" :arglists '[[object]]} 
   1.257 +  #(and (seq %) (not (string? %))))
   1.258 +
   1.259 +(defmethod test-dispatch true [avec]
   1.260 +  (pprint-logical-block :prefix "[" :suffix "]"
   1.261 +    (loop [aseq (seq avec)]
   1.262 +      (when aseq
   1.263 +	(write-out (first aseq))
   1.264 +	(when (next aseq)
   1.265 +	  (.write ^java.io.Writer *out* " ")
   1.266 +	  (pprint-newline :linear)
   1.267 +	  (recur (next aseq)))))))
   1.268 +
   1.269 +(defmethod test-dispatch false [aval] (pr aval))
   1.270 +
   1.271 +(simple-tests dispatch-tests
   1.272 +  (with-pprint-dispatch test-dispatch
   1.273 +    (with-out-str 
   1.274 +      (pprint '("hello" "there"))))
   1.275 +  "[\"hello\" \"there\"]\n"
   1.276 +)
   1.277 +
   1.278 +