Mercurial > lasercutter

     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
author	Robert McIntyre <rlm@mit.edu>
date	Sat, 21 Aug 2010 06:25:44 -0400
parents
children