;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Mon Feb 23 06:20:00 2004
;;;; Contains: Auxiliary functions and macros for printer tests



(eval-when (:compile-toplevel :load-toplevel :execute)
  (compile-and-load* "random-aux.lsp"))

(defmacro def-print-test (name form result &rest bindings)
  `(deftest ,name
     (if (equalpt
          (my-with-standard-io-syntax
           (let ((*print-readably* nil))
             (let ,bindings
               (with-output-to-string (*standard-output*) (prin1 ,form)))))
          ,result)
         t
       ,result)
     t))

(defmacro def-pprint-test
  (name form expected-value
        &key
        (margin 100)
        (miser nil)
        (circle nil)
        (len nil)
        (pretty t)
        (escape nil)
        (readably nil)
        (package (find-package "CL-TEST")))
  `(deftest ,name
     (with-standard-io-syntax
      (let ((*print-pretty* ,pretty)
            (*print-escape* ,escape)
            (*print-readably* ,readably)
            (*print-right-margin* ,margin)
            (*package* ,package)
            (*print-length* ,len)
            (*print-miser-width* ,miser)
            (*print-circle* ,circle))
        ,form))
     ,expected-value))

(defmacro def-ppblock-test (name form expected-value &rest key-args)
  `(def-pprint-test ,name
     (with-output-to-string
       (*standard-output*)
       (pprint-logical-block (*standard-output* nil) ,form))
     ,expected-value
     ,@key-args))

;;; Function to test readable of printed forms, under random settings
;;; of various printer control variables.
;;;
;;; Return NIL if obj printed and read properly, or a list containing
;;; the object and the printer variable bindings otherwise.  They key
;;; argument TEST is used to compared the reread object and obj.

(defvar *random-read-check-debug* nil
  "When set to true, RANDOMLY-CHECK-READABILITY will dump out parameter
   settings before trying a test.  This is intended for cases where the
   error that occurs is fatal.")

(defun randomly-check-readability (obj &key
                                       (can-fail nil)
                                       (test #'equal)
                                       (readable t)
                                       (circle nil circle-p)
                                       (escape nil escape-p)
                                       (gensym nil gensym-p)
                                       (debug *random-read-check-debug*))
  (declare (type function test))
  ;; Generate random printer-control values
  (my-with-standard-io-syntax
   (let ((*print-array* (coin))
         (*print-base* (+ 2 (random 34)))
         (*print-radix* (coin))
         (*print-case* (random-from-seq #(:upcase :downcase :capitalize)))
         (*print-circle* (if circle-p circle (coin)))
         (*print-escape* (if escape-p escape (coin)))
         (*print-gensym* (if gensym-p gensym (coin)))
         (*print-level* (random 50))
         (*print-length* (if readable (random 50) nil))
         (*print-lines* (if readable (random 50) nil))
         (*print-miser-width* (and (coin) (random 100)))
         (*print-pretty* (coin))
         (*print-right-margin* (and (coin) (random 100)))
         (*print-readably* readable)
         (*read-default-float-format* (rcase (1 'short-float) (1 'single-float)
                                             (1 'double-float) (1 'long-float)
                                             (1 *read-default-float-format*)))
         (*readtable* (copy-readtable))
         (readcase (random-from-seq #(:upcase :downcase :preserve :invert)))
         )
     (flet ((%params ()
                     (list (list '*print-readably* *print-readably*)
                           (list '*print-array* *print-array*)
                           (list '*print-base* *print-base*)
                           (list '*print-radix* *print-radix*)
                           (list '*print-case* *print-case*)
                           (list '*print-circle* *print-circle*)
                           (list '*print-escape* *print-escape*)
                           (list '*print-gensym* *print-gensym*)
                           (list '*print-level* *print-level*)
                           (list '*print-length* *print-length*)
                           (list '*print-lines* *print-lines*)
                           (list '*print-miser-width* *print-miser-width*)
                           (list '*print-pretty* *print-pretty*)
                           (list '*print-right-margin* *print-right-margin*)
                           (list '*read-default-float-format* *read-default-float-format*)
                           (list 'readtable-case readcase))))
       (when debug
         (let ((params (%params)))
           (with-standard-io-syntax (format *debug-io* "~%~A~%" params)))
         (finish-output *debug-io*))

       (setf (readtable-case *readtable*) readcase)
       (let* ((str (handler-case
                    (with-output-to-string (s) (write obj :stream s))
                    (print-not-readable
                     ()
                     (if can-fail
                         (return-from randomly-check-readability nil)
                       ":print-not-readable-error"))))
              (obj2 (let ((*read-base* *print-base*))
                      (handler-case
                       (let ((*readtable* (if *print-readably*
                                              (copy-readtable nil)
                                            *readtable*)))
                         (read-from-string str))
                       (reader-error () :reader-error)
                       (end-of-file () :end-of-file)
                       (stream-error () :stream-error)
                       (file-error () :file-error)
                       ))))
         (unless (funcall test obj obj2)
           (list
            (list* obj str obj2 (%params)
                   ))))))))

(defun parse-escaped-string (string)
  "Parse a string into a list of either characters (representing
   themselves unescaped) or lists (<char> :escape) (representing
   escaped characters.)"
  (assert (stringp string) () "Not a string: ~A" string)
  (let ((result nil)
        (len (length string))
        (index 0))
    (prog
     ()
     normal ; parsing in normal mode
     (when (= index len) (return))
     (let ((c (elt string index)))
       (cond ((eql c #\\)
              (assert (< (incf index) len)
                      ()
                      "End of string after \\")
              (push `(,(elt string index) :escaped) result)
              (incf index)
              (go normal))
             ((eql c #\|)
              (incf index)
              (go multiple-escaped))
             (t (push c result)
                (incf index)
                (go normal))))

     multiple-escaped   ; parsing inside |s
     (assert (< index len) () "End of string inside |")
     (let ((c (elt string index)))
       (cond ((eq c #\|)
              (incf index)
              (go normal))
             (t
              (push `(,c :escaped) result)
              (incf index)
              (go multiple-escaped)))))
    (nreverse result)))

(defun escaped-equal (list1 list2)
  "Determine that everything escaped in list1 is also escaped
   in list2, and that the characters are also the same."
  (and (= (length list1) (length list2))
       (loop for e1 in list1
             for e2 in list2
             for is-escaped1 = (and (consp e1) (eq (cadr e1) :escaped))
             for is-escaped2 = (and (consp e2) (eq (cadr e2) :escaped))
             for c1 = (if is-escaped1 (car e1) e1)
             for c2 = (if is-escaped2 (car e2) e2)
             always
             (and (if is-escaped1 is-escaped2 t)
                  (char= c1 c2)))))

(defun similar-uninterned-symbols (s1 s2)
  (and (symbolp s1)
       (symbolp s2)
       (null (symbol-package s1))
       (null (symbol-package s2))
       (string= (symbol-name s1)
                (symbol-name s2))))

(defun make-random-cons-tree (size)
  (if (<= size 1)
      (rcase
       (5 nil)
       (1 (random 1000))
       (1 (random 1000.0))
       (2 (random-from-seq #(a b c d e f g |1| |2| |.|))))
    (let ((s1 (1+ (random (1- size)))))
      (cons (make-random-cons-tree s1)
            (make-random-cons-tree (- size s1))))))

(defun make-random-vector (size)
  (if (> size 1)
      (let* ((nelems (min (1- size) (1+ (random (max 2 (floor size 4))))))
             (sizes (mapcar #'1+ (random-partition* (- size nelems 1) nelems))))
        (make-array nelems :initial-contents (mapcar #'make-random-vector sizes)))
    (rcase
     (1 (random-from-seq #(a b c d e f g)))
     (1 (- (random 2001) 1000))
     (1 (random 1000.0))
     )))

;;; Random printing test for WRITE and related functions

(defun funcall-with-print-bindings
  (fun &key
       ((:array *print-array*)                     *print-array*)
       ((:base *print-base*)                       *print-base*)
       ((:case *print-case*)                       *print-case*)
       ((:circle *print-circle*)                   *print-circle*)
       ((:escape *print-escape*)                   *print-escape*)
       ((:gensym *print-gensym*)                   *print-gensym*)
       ((:length *print-length*)                   *print-length*)
       ((:level *print-level*)                     *print-level*)
       ((:lines *print-lines*)                     *print-lines*)
       ((:miser-width *print-miser-width*)         *print-miser-width*)
       ((:pprint-dispatch *print-pprint-dispatch*) *print-pprint-dispatch*)
       ((:pretty *print-pretty*)                   *print-pretty*)
       ((:radix *print-radix*)                     *print-radix*)
       ((:readably *print-readably*)               *print-readably*)
       ((:right-margin *print-right-margin*)       *print-right-margin*)
       ((:stream *standard-output*)                *standard-output*))
  (funcall fun))

(defun output-test
  (obj &key
       (fun #'write)
       ((:array *print-array*)                     *print-array*)
       ((:base *print-base*)                       *print-base*)
       ((:case *print-case*)                       *print-case*)
       ((:circle *print-circle*)                   *print-circle*)
       ((:escape *print-escape*)                   *print-escape*)
       ((:gensym *print-gensym*)                   *print-gensym*)
       ((:length *print-length*)                   *print-length*)
       ((:level *print-level*)                     *print-level*)
       ((:lines *print-lines*)                     *print-lines*)
       ((:miser-width *print-miser-width*)         *print-miser-width*)
       ((:pprint-dispatch *print-pprint-dispatch*) *print-pprint-dispatch*)
       ((:pretty *print-pretty*)                   *print-pretty*)
       ((:radix *print-radix*)                     *print-radix*)
       ((:readably *print-readably*)               *print-readably*)
       ((:right-margin *print-right-margin*)       *print-right-margin*)
       ((:stream *standard-output*)                *standard-output*))
  (let ((results (multiple-value-list (funcall fun obj))))
    (assert (= (length results) 1))
    (assert (eql (car results) obj))
    obj))

(defun make-random-key-param (name)
  (rcase (1 nil)
         (1 `(,name nil))
         (1 `(,name t))))

(defun make-random-key-integer-or-nil-param (name bound)
  (rcase (1 nil)
         (1 `(,name nil))
         (1 `(,name ,(random bound)))))

(defun make-random-write-args ()
  (let* ((arg-lists `(,@(mapcar #'make-random-key-param
                                            '(:array :circle :escape :gensym :pretty :radix :readably))
                                    ,(rcase (1 nil)
                                            (1 `(:base ,(+ 2 (random 35)))))
                                    ,(and (coin)
                                          `(:case ,(random-from-seq #(:upcase :downcase :capitalize))))
                                    ,@(mapcar #'make-random-key-integer-or-nil-param
                                              '(:length :level :lines :miser-width :right-margin)
                                              '(100 20 50 200 200)))))
                (reduce #'append (random-permute arg-lists) :from-end t)))

(defun filter-unreadable-forms (string)
  "Find #<...> strings and replace with #<>."
  (let ((len (length string))
        (pos 0))
    (loop while (< pos len)
          do (let ((next (search "#<" string :start2 pos)))
               (unless next (return string))
               (let ((end (position #\> string :start next)))
                 (unless end (return string))
                 (setq string
                       (concatenate 'string
                                    (subseq string 0 next)
                                    "#<>"
                                    (subseq string (1+ end)))
                       pos (+ next 3)
                       len (+ len (- next end) 3)))))))


(defmacro def-random-write-test-fun (name write-args test-fn
                                          &key
                                          (prefix "")
                                          (suffix ""))
  `(defun ,name (n &key (size 10))
     (loop
      for args = (make-random-write-args)
      for package = (find-package (random-from-seq #("CL-TEST" "CL-USER" "KEYWORD")))
      for obj = (let ((*random-readable* t))
                  (declare (special *random-readable*))
                  (random-thing (random size)))
      for s1 = (let ((*package* package))
                 (with-output-to-string (s) (apply #'write obj :stream s ,@write-args args)))
      for s2 = (let ((*package* package))
                 (with-output-to-string
                   (*standard-output*)
                   (apply #'output-test obj :fun ,test-fn args)))
      repeat n
      ;; We filter the contents of #<...> forms since they may change with time
      ;; if they contain object addresses.
      unless (string= (filter-unreadable-forms (concatenate 'string ,prefix s1 ,suffix))
                      (filter-unreadable-forms s2))
      collect (list obj s1 s2 args))))

(def-random-write-test-fun random-write-test nil #'write)
(def-random-write-test-fun random-prin1-test (:escape t) #'prin1)
(def-random-write-test-fun random-princ-test (:escape nil :readably nil) #'princ)
(def-random-write-test-fun random-print-test (:escape t) #'print :prefix (string #\Newline) :suffix " ")
(def-random-write-test-fun random-pprint-test (:escape t :pretty t)
  #'(lambda (obj) (assert (null (multiple-value-list (pprint obj)))) obj)
  :prefix (string #\Newline))

(defmacro def-random-write-to-string-test-fun (name write-args test-fn
                                          &key
                                          (prefix "")
                                          (suffix ""))
  `(defun ,name (n)
     (loop
      for args = (make-random-write-args)
      for package = (find-package (random-from-seq #("CL-TEST" "CL-USER" "KEYWORD")))
      for obj = (let ((*random-readable* t))
                  (declare (special *random-readable*))
                  (random-thing (random 10)))
      for s1 = (let ((*package* package))
                 (with-output-to-string (s) (apply #'write obj :stream s ,@write-args args)))
      for s2 = (let ((*package* package))
                 (apply ,test-fn obj args))
      repeat n
      unless (string= (filter-unreadable-forms (concatenate 'string ,prefix s1 ,suffix))
                      (filter-unreadable-forms s2))
      collect (list obj s1 s2))))

(def-random-write-to-string-test-fun random-write-to-string-test nil #'write-to-string)
(def-random-write-to-string-test-fun random-prin1-to-string-test (:escape t)
  #'(lambda (obj &rest args)
      (apply #'funcall-with-print-bindings #'(lambda () (prin1-to-string obj)) args)))
(def-random-write-to-string-test-fun random-princ-to-string-test (:escape nil :readably nil)
  #'(lambda (obj &rest args)
      (apply #'funcall-with-print-bindings #'(lambda () (princ-to-string obj)) args)))

;;; Routines for testing floating point printing

(defun decode-fixed-decimal-string (s)
  "Return a rational equal to the number represented by a decimal floating
   (without exponent).  Trim off leading/trailing spaces."

  (setq s (string-trim " " s))
  (assert (> (length s) 0))
  (let (neg)
    (when (eql (elt s 0) #\-)
      (setq s (subseq s 1))
      (setq neg t))
    ;; Check it's of the form {digits}.{digits}
    (let ((dot-pos (position #\. s)))
      (assert dot-pos)
      (let ((prefix (subseq s 0 dot-pos))
            (suffix (subseq s (1+ dot-pos))))
        (assert (every #'digit-char-p prefix))
        (assert (every #'digit-char-p suffix))
        (let* ((prefix-len (length prefix))
               (prefix-integer (if (eql prefix-len 0)
                                   0
                                 (parse-integer prefix)))
               (suffix-len (length suffix))
               (suffix-integer (if (eql suffix-len 0)
                                   0
                                 (parse-integer suffix)))
               (magnitude (+ prefix-integer
                             (* suffix-integer (expt 1/10 suffix-len)))))
          (if neg (- magnitude) magnitude))))))


;;; Macro to define both FORMAT and FORMATTER tests

(defmacro def-format-test (name string args expected-output &optional (num-left 0))
  (assert (symbolp name))
  (let* ((s (symbol-name name))
         (expected-prefix (string 'format.))
         (expected-prefix-length (length expected-prefix)))
    (assert (>= (length s) expected-prefix-length))
    (assert (string-equal (subseq s 0 expected-prefix-length)
                          expected-prefix))
    (let* ((formatter-test-name-string
            (concatenate 'string (string 'formatter.)
                         (subseq s expected-prefix-length)))
           (formatter-test-name (intern formatter-test-name-string
                                        (symbol-package name)))
           (formatter-form (if (stringp string)
                               `(formatter ,string)
                             (list 'formatter (eval string)))))
      `(progn
         (deftest ,name
           (with-standard-io-syntax
            (let ((*print-readably* nil)
                  (*package* (symbol-package 'ABC)))
              (format nil ,string ,@args)))
           ,expected-output)
         (deftest ,formatter-test-name
           (let ((fn ,formatter-form)
                 (args (list ,@args)))
             (with-standard-io-syntax
              (let ((*print-readably* nil)
                    (*package* (symbol-package 'ABC)))
                (with-output-to-string
                  (stream)
                  (let ((tail (apply fn stream args)))
                    ;; FIXME -- Need to check that TAIL really is a tail of ARGS
                    (assert (= (length tail) ,num-left) (tail) "Tail is ~A, length should be ~A"
                            tail ,num-left)
                  )))))
           ,expected-output)))))

;;; Macro used for an idiom in testing FORMATTER calls

(defmacro formatter-call-to-string (fn &body args)
  (let ((stream (gensym "S")))
    `(with-output-to-string
       (,stream)
       (assert (equal (funcall ,fn ,stream ,@args 'a) '(a))))))

;;; Function used in checking correct rounding for floating point printing

(defun round-ratio-to-n-digits (ratio n)
  "Returns a string with the first n significant digits of the decimal
representation of ratio."
  (check-type ratio rational)
  (check-type n (integer 1 *))
  (let* ((exp (floor (* (- (integer-length (numerator ratio))
                           (integer-length (denominator ratio)))
                        #.(log 2d0 10))))
         (10^n (expt 10 n))
         ;; We first scale the ratio down to the range
         ;; 10^n <= x < 10^(n+1). This allows us to use integer
         ;; arithmetic to compute the number below satisfying
         ;; below <= x <= below + 10.
         (x (loop with x = (/ ratio (expt 10 (- exp n)))
               until (<= 10^n x (* 10 10^n))
               do (setf x (if (< x 10^n) (* x 10) (/ x 10)))
               finally (return x)))
         (below 10^n))
    (loop with 10^n-i = below
          for i below n
       do (loop until (and (<= below x)
                           (< x (+ below 10^n-i)))
             do (if (> below x)
                    (setf below (- below 10^n-i))
                    (setf below (+ below 10^n-i))))
         (setf 10^n-i (/ 10^n-i 10)))
    (let ((halfway (+ below 5)))
      (cond ((< x halfway)
             (values (write-to-string (/ below 10))))
            ((> x halfway)
             (values (write-to-string (let ((rounded (+ (/ below 10) 1)))
                                        (if (>= rounded 10^n)
                                            (/ rounded 10)
                                            rounded)))))
            (t ;; "When rounding up and rounding down would
             ;; produce printed values equidistant from the
             ;; scaled value of arg, then the implementation is
             ;; free to use either one"
             (values (write-to-string (/ below 10))
                     (write-to-string (let ((rounded (+ (/ below 10) 1)))
                                        (if (>= rounded 10^n)
                                            (/ rounded 10)
                                            rounded)))))))))