;;;; pretty printer stuff which has to be defined early (e.g. DEFMACROs)

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(in-package "SB!PRETTY")

;;;; utilities

(defmacro with-pretty-stream ((stream-var
                               &optional (stream-expression stream-var))
                              &body body)
  (let ((flet-name (gensym "WITH-PRETTY-STREAM-")))
    `(flet ((,flet-name (,stream-var)
              ,@body))
       (let ((stream ,stream-expression))
         (if (pretty-stream-p stream)
             (,flet-name stream)
             (catch 'line-limit-abbreviation-happened
               (let ((stream (make-pretty-stream stream)))
                 (,flet-name stream)
                 (force-pretty-output stream)))))
       nil)))

;;;; user interface to the pretty printer

(defmacro pprint-logical-block ((stream-symbol
                                 object
                                 &key
                                 (prefix nil prefixp)
                                 (per-line-prefix nil per-line-prefix-p)
                                 (suffix "" suffixp))
                                &body body
                                &environment env)
  #!+sb-doc
  "Group some output into a logical block. STREAM-SYMBOL should be either a
   stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*). The printer
   control variable *PRINT-LEVEL* is automatically handled."
  (when (and prefixp per-line-prefix-p)
    (error "cannot specify values for both PREFIX and PER-LINE-PREFIX."))
  (multiple-value-bind (stream-var stream-expression)
      (case stream-symbol
        ((nil)
         (values '*standard-output* '*standard-output*))
        ((t)
         (values '*terminal-io* '*terminal-io*))
        (t
         (values stream-symbol
                 (once-only ((stream stream-symbol))
                   `(case ,stream
                      ((nil) *standard-output*)
                      ((t) *terminal-io*)
                      (t ,stream))))))
    (let* ((object-var (if object (gensym) nil))
           (block-name (gensym "PPRINT-LOGICAL-BLOCK-"))
           (count-name (gensym "PPRINT-LOGICAL-BLOCK-LENGTH-"))
           (pp-pop-name (gensym "PPRINT-POP-"))
           (body
            ;; FIXME: It looks as though PPRINT-LOGICAL-BLOCK might
            ;; expand into a boatload of code, since DESCEND-INTO is a
            ;; macro too. It might be worth looking at this to make
            ;; sure it's not too bloated, since PPRINT-LOGICAL-BLOCK
            ;; is called many times from system pretty-printing code.
            ;;
            ;; FIXME: I think pprint-logical-block is broken wrt
            ;; argument order, multiple evaluation, etc. of its
            ;; keyword (:PREFIX, :PER-LINE-PREFIX and :SUFFIX)
            ;; arguments.  Dunno if that's legal.
            `(descend-into (,stream-var)
               (let ((,count-name 0))
                 (declare (type index ,count-name) (ignorable ,count-name))
                 ,@(when (and (or prefixp per-line-prefix-p)
                              (not (sb!int:constant-typep
                                    (or prefix per-line-prefix)
                                    'string
                                    env)))
                     `((unless (typep ,(or prefix per-line-prefix) 'string)
                         (error 'type-error
                                :datum ,(or prefix per-line-prefix)
                                :expected-type 'string))))
                 ,@(when (and suffixp
                              (not (sb!int:constant-typep suffix 'string env)))
                     `((unless (typep ,suffix 'string)
                         (error 'type-error
                                :datum ,suffix
                                :expected-type 'string))))
                 (start-logical-block ,stream-var
                                      ,(if (or prefixp per-line-prefix-p)
                                           (or prefix per-line-prefix)
                                           nil)
                                      ,(if per-line-prefix-p t nil)
                                      ,suffix)
                 (block ,block-name
                   (flet ((,pp-pop-name ()
                            ,@(when object
                                `((unless (listp ,object-var)
                                    (write-string ". " ,stream-var)
                                    (output-object ,object-var ,stream-var)
                                    (return-from ,block-name nil))))
                            (when (and (not *print-readably*)
                                       (eql ,count-name *print-length*))
                              (write-string "..." ,stream-var)
                              (return-from ,block-name nil))
                            ,@(when object
                                `((when (and ,object-var
                                             (plusp ,count-name)
                                             (check-for-circularity
                                              ,object-var
                                              nil
                                              :logical-block))
                                    (write-string ". " ,stream-var)
                                    (output-object ,object-var ,stream-var)
                                    (return-from ,block-name nil))))
                            (incf ,count-name)
                            ,@(if object
                                  `((pop ,object-var))
                                  `(nil))))
                     (declare (ignorable (function ,pp-pop-name)))
                     (locally
                         (declare (disable-package-locks
                                   pprint-pop pprint-exit-if-list-exhausted))
                       (macrolet ((pprint-pop ()
                                    '(,pp-pop-name))
                                  (pprint-exit-if-list-exhausted ()
                                    ,(if object
                                         `'(when (null ,object-var)
                                            (return-from ,block-name nil))
                                         `'(return-from ,block-name nil))))
                         (declare (enable-package-locks
                                   pprint-pop pprint-exit-if-list-exhausted))
                         ,@body))))
                 ;; FIXME: Don't we need UNWIND-PROTECT to ensure this
                 ;; always gets executed?
                 (end-logical-block ,stream-var)))))
      (when object
        (setf body
              `(let ((,object-var ,object))
                 (if (listp ,object-var)
                     (with-circularity-detection (,object-var ,stream-var)
                       ,body)
                     (output-object ,object-var ,stream-var)))))
      `(with-pretty-stream (,stream-var ,stream-expression)
         ,body))))

(defmacro pprint-exit-if-list-exhausted ()
  #!+sb-doc
  "Cause the closest enclosing use of PPRINT-LOGICAL-BLOCK to return
   if its list argument is exhausted. Can only be used inside
   PPRINT-LOGICAL-BLOCK, and only when the LIST argument to
   PPRINT-LOGICAL-BLOCK is supplied."
  (error "PPRINT-EXIT-IF-LIST-EXHAUSTED must be lexically inside ~
          PPRINT-LOGICAL-BLOCK."))

(defmacro pprint-pop ()
  #!+sb-doc
  "Return the next element from LIST argument to the closest enclosing
   use of PPRINT-LOGICAL-BLOCK, automatically handling *PRINT-LENGTH*
   and *PRINT-CIRCLE*. Can only be used inside PPRINT-LOGICAL-BLOCK.
   If the LIST argument to PPRINT-LOGICAL-BLOCK was NIL, then nothing
   is popped, but the *PRINT-LENGTH* testing still happens."
  (error "PPRINT-POP must be lexically inside PPRINT-LOGICAL-BLOCK."))
