pprint-tabular.lsp 5.13 KB
Newer Older
pfdietz's avatar
pfdietz committed
1 2 3 4 5 6 7 8 9 10 11
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sun Jun 27 06:29:39 2004
;;;; Contains: Tests of PPRINT-TABULAR

(in-package :cl-test)

;;; When printing a non-list, the result is the same as calling WRITE."
(deftest pprint-tabular.1
  (my-with-standard-io-syntax
   (let ((*print-pretty* t)
sds's avatar
sds committed
12
         (*print-readably* nil))
pfdietz's avatar
pfdietz committed
13
     (loop for obj in *mini-universe*
sds's avatar
sds committed
14 15 16 17 18 19
           nconc
           (and (not (listp obj))
                (let ((s1 (write-to-string obj))
                      (s2 (with-output-to-string (s) (pprint-tabular s obj))))
                  (unless (equal s1 s2)
                    (list (list obj s1 s2))))))))
pfdietz's avatar
pfdietz committed
20 21 22 23 24
  nil)

(deftest pprint-tabular.2
  (my-with-standard-io-syntax
   (let ((*print-pretty* nil)
sds's avatar
sds committed
25
         (*print-readably* nil))
pfdietz's avatar
pfdietz committed
26
     (loop for obj in *mini-universe*
sds's avatar
sds committed
27 28 29 30 31 32
           nconc
           (and (not (listp obj))
                (let ((s1 (write-to-string obj))
                      (s2 (with-output-to-string (s) (pprint-tabular s obj))))
                  (unless (equal s1 s2)
                    (list (list obj s1 s2))))))))
pfdietz's avatar
pfdietz committed
33 34 35 36 37 38
  nil)

(defmacro def-pprint-tabular-test (name args expected-value &key (margin 100) (circle nil) (pre nil))
  `(deftest ,name
     (my-with-standard-io-syntax
      (let ((*print-pretty* t)
sds's avatar
sds committed
39 40 41 42 43 44 45 46
            (*print-readably* nil)
            (*print-right-margin* ,margin)
            (*package* (find-package :cl-test))
            (*print-circle* ,circle))
        (with-output-to-string
          (s)
          ,@(when pre (list pre))
          (pprint-tabular s ,@args))))
pfdietz's avatar
pfdietz committed
47 48
     ,expected-value))

49 50 51 52 53 54
;;;
;;; Note
;;; The prefix and suffix "(" and ")" are not considered part of the
;;; logical block they enclose (see the spec page for pprint-logical-block.
;;;

pfdietz's avatar
pfdietz committed
55 56 57 58
(def-pprint-tabular-test pprint-tabular.3 ('(|M|)) "(M)")
(def-pprint-tabular-test pprint-tabular.4 ('(|M|) t) "(M)")
(def-pprint-tabular-test pprint-tabular.5 ('(|M|) nil) "M")

59
(def-pprint-tabular-test pprint-tabular.6 ('(|M| |M|)) "(M               M)")
pfdietz's avatar
pfdietz committed
60
(def-pprint-tabular-test pprint-tabular.7 ('(|M| |M|) t nil 1) "(M M)")
61 62 63 64 65
(def-pprint-tabular-test pprint-tabular.8 ('(|M| |M|) t t 3) "(M  M)")
(def-pprint-tabular-test pprint-tabular.9 ('(|M| |M|) t nil 4) "(M   M)")
(def-pprint-tabular-test pprint-tabular.10 ('(|MM| |MM|) t nil 4) "(MM  MM)")
(def-pprint-tabular-test pprint-tabular.11 ('(|MM| |MM|) t nil 5) "(MM   MM)")
(def-pprint-tabular-test pprint-tabular.12 ('(|M| |MM|) t nil 5)  "(M    MM)")
pfdietz's avatar
pfdietz committed
66 67 68 69

(def-pprint-tabular-test pprint-tabular.13 ((let ((x (list '|A|))) (list x x)) t nil 1)
  "(#1=(A) #1#)" :circle t)

70
(def-pprint-tabular-test pprint-tabular.14 ('(|M| |M|) t t 4) "(M   M)")
pfdietz's avatar
pfdietz committed
71 72 73 74

(def-pprint-tabular-test pprint-tabular.15 ('(1 2 3 4) t t 1) "(1 2 3 4)")
(def-pprint-tabular-test pprint-tabular.16 ('(10 20 30 40) t t 1) "(10 20 30 40)")
(def-pprint-tabular-test pprint-tabular.17 ('(10 200 3000 40000) t t 1) "(10 200 3000 40000)")
75 76
(def-pprint-tabular-test pprint-tabular.18 ('(10 20 30 40) t t 2) "(10  20  30  40)")
(def-pprint-tabular-test pprint-tabular.19 ('(10 200 3000 40000) t t 2) "(10  200 3000  40000)")
pfdietz's avatar
pfdietz committed
77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93

(def-pprint-tabular-test pprint-tabular.20 ('(1 2 3) t nil 1)
  "     (1 2 3)"
  :pre (write "     " :stream s :escape nil))

(def-pprint-tabular-test pprint-tabular.21 ('(1 2 3) t nil 1)
  "     (1
      2
      3)"
  :pre (write "     " :stream s :escape nil) :margin 9)


(def-pprint-tabular-test pprint-tabular.22 ('(1 2 3) t nil 1)
  "     (1 2
      3)"
  :pre (write "     " :stream s :escape nil) :margin 10)

94 95 96 97 98
;;; Takes T, NIL as stream designators

(deftest pprint-tabular.23
  (my-with-standard-io-syntax
   (let ((*print-pretty* nil)
sds's avatar
sds committed
99 100
         (*print-readably* nil)
         (*print-right-margin* 100))
101 102
     (with-output-to-string
       (os)
103
       (with-input-from-string
sds's avatar
sds committed
104 105 106
        (is "")
        (with-open-stream (*terminal-io* (make-two-way-stream is os))
                          (pprint-tabular t '(1 2 3) t nil 1))))))
107 108 109 110 111
  "(1 2 3)")

(deftest pprint-tabular.24
  (my-with-standard-io-syntax
   (let ((*print-pretty* t)
sds's avatar
sds committed
112 113
         (*print-readably* nil)
         (*print-right-margin* 100))
114 115
     (with-output-to-string (*standard-output*) (pprint-tabular nil '(1 2 3) t nil 1))))
  "(1 2 3)")
pfdietz's avatar
pfdietz committed
116

pfdietz's avatar
pfdietz committed
117 118
;;; FIXME: add test for colon-p argument of NIL

pfdietz's avatar
pfdietz committed
119 120 121 122 123
;;; Test that pprint-tabular returns NIL

(deftest pprint-tabular.return-values.1
  (my-with-standard-io-syntax
   (let ((*print-pretty* nil)
sds's avatar
sds committed
124
         (*package* (find-package :cl-test)))
pfdietz's avatar
pfdietz committed
125
     (with-open-stream (s (make-broadcast-stream))
sds's avatar
sds committed
126
                       (pprint-tabular s '(a b)))))
pfdietz's avatar
pfdietz committed
127 128 129 130 131
  nil)

(deftest pprint-tabular.return-values.2
  (my-with-standard-io-syntax
   (let ((*print-pretty* nil)
sds's avatar
sds committed
132
         (*package* (find-package :cl-test)))
pfdietz's avatar
pfdietz committed
133
     (with-open-stream (s (make-broadcast-stream))
sds's avatar
sds committed
134
                       (pprint-tabular s 10 nil nil 100))))
pfdietz's avatar
pfdietz committed
135
  nil)
136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153

;;; Error tests

(deftest pprint-tabular.error.1
  (signals-error (pprint-tabular) program-error)
  t)

(deftest pprint-tabular.error.2
  (signals-error (pprint-tabular *standard-output*) program-error)
  t)

(deftest pprint-tabular.error.3
  (signals-error (pprint-tabular *standard-output* nil t nil 1 nil) program-error)
  t)

(deftest pprint-tabular.error.4
  (signals-error (pprint-tabular *standard-output* '(a b c) t t 1 nil) program-error)
  t)