Controlling the printing of special cons forms (e.g printing (function +) as #'+ etc)

Question

I want some reader macros to print as as shortened expression that the macro understands. Lets say I want to extend the #' macro to take #'~[rest-of-symbol] and turn that into (complement #'rest-of-symbol).

What controls how that is printed? On SBCL, for instance, '(function +) prints as #'+. How do i make '(complement #'listp) print as #~listp?

My first thought was

(defmethod print-object :around ((obj cons) stream)
  ;; if #'~fn-name / (complement (function fn-name))
  ;; => fn-name otherwise NIL  
  (let ((fn-name
         (ignore-errors
           (destructuring-bind (complement (function fn-name)) 
               obj
             (when (and (eq complement 'complement)
                        (eq function   'function))
               fn-name)))))
    (if fn-name
        (format stream "#'~~~S" fn-name)
      (call-next-method))))

This works insofar as (print-object '(complement #'evenp) *standard-output*) prints it the way I want, but the REPL doesn't. Also (print-object '#'+ *standard-output*) prints it as (function +) so the REPL isn't using print-object. With defining the print-object method for user defined classes the REPL always picks up on the new definition.

This is my first post and I'm sorry I can't get the code to format properly. If someone can put a link on how to do that I would appreciate it.

Answer 1

To do this you need to understand the pretty printer. I have understood it in the past but no longer do completely. It dispatches on type and the trick for things like this is that you can specify very specific types for trees of conses, although doing so is verbose.

Here is an example which is almost certainly not completely correct, but does achieve what you want in this case:

(defparameter *ppd* (copy-pprint-dispatch))

(defun pprint-complement-function (s form)
  ;; This is the thing that the pretty printer will call.  It can
  ;; assume that the form it wants to print is already correct.
  (destructuring-bind (complement (function name)) form
    (declare (ignore complement function))
    (format s "#'~~~W" name)))

;;; Now set this in the table with a suitable hairy type specification
;;;
(set-pprint-dispatch '(cons (eql complement)
                            (cons (cons (eql function)
                                        (cons t null))
                                  null))
                     'pprint-complement-function
                     0
                     *ppd*)

And now

> (let ((*print-pprint-dispatch* *ppd*))
    (pprint '(complement (function foo)))
    (pprint '((complement (function foo)) (function foo))))

#'~foo
(#'~foo #'foo)

---

You can make the awful nested cons type specifier easier by defining this (which, perhaps, should be the compound type specifier for list except you can't do that):

(deftype list-of-types (&rest types)
  (labels ((lot (tt)
             (if (null tt)
                 'null
               `(cons ,(first tt) ,(lot (rest tt))))))
    (lot types)))

And then

(set-pprint-dispatch '(list-of-types (eql complement)
                                     (list-of-types (eql function)
                                                    *))
                     'pprint-complement-function
                     0
                     *ppd*)

is perhaps easier to read.

Answer 2

Evaluation time

You are mixing code with data in your example:

(function +)

Is a special form that evaluates to a function object, which admits a shorter syntax:

#'+

But when you are writing:

'(function +)

or

'(complement fn)

Then in both cases you are writing quoted, literal lists, which evaluates to themselves (namely a list starting with symbol function or complement, followed respectively by symbol + and fn).

However, you want the code to be evaluated at runtime to actual function objects; if you type this in the REPL:

(complement #'alpha-char-p)

The result is a value that is printed as follows:

#<FUNCTION (LAMBDA (&REST SB-IMPL::ARGUMENTS) :IN COMPLEMENT) {101AAC8D9B}>

You have an actual function object that you can funcall. In other words, by the time you reach print-object, you no longer have access to source code, you are manipulating data at runtime which happens to be functions. So you cannot use destructuring-bind to get the complement symbol that was present in the source code.

What you need to do instead is to attach metadata to your function. There is a way to do that in Common Lisp by defining a new type of function, thanks to the Meta-Object Protocol.

Funcallable objects

I'm relying on Closer-MOP for all the symbols prefixed with c2cl: below. I define a new class of functions, annotated-fn, which is a function with additional data:

(defclass annotated-fn (c2cl:funcallable-standard-object) 
  ((data :initform :data :initarg :data :reader annotated-fn-data))
  (:metaclass c2cl:funcallable-standard-class))

Notice that this class is a funcallable-standard-object (like the usual functions), and its metaclass is funcallable-standard-class. Such an object has an additional implicit slot that is a function to call.

More precisely, you have to call c2cl:set-funcallable-instance-function to set a function associated with the object, and when later you use funcall or apply with the object, then the wrapped function is called instead. So you can transparently use this class of functions wherever you usually use a function. It just has additional slots (here data).

For example, here is how I instantiate it, with a function to wrap additional data:

(defun annotate-fn (function data)
  (let ((object (make-instance 'annotated-fn :data data)))
    (prog1 object
      (c2cl:set-funcallable-instance-function object function))))

Let's try it:

(describe
 (annotate-fn (constantly 3)
              '(:category :constantly)))

#<ANNOTATED-FN {1006275C7B}>
  [funcallable-instance]


Lambda-list: UNKNOWN
Derived type: FUNCTION
Documentation:
  T
Source file: SYS:SRC;CODE;FUNUTILS.LISP

Slots with :INSTANCE allocation:
  DATA                           = (:CATEGORY :CONSTANTLY)

You can also use this object like any other function.

Now, your reader macros can expand into calls to annotate-fn, and add any kind of additional metadata you need to the function.

Reader macro

For our example, imagine you define a reader macros for constant functions:

(set-macro-character #\[ 'read-constantly t)
(set-macro-character #\] (get-macro-character #\) nil))        

(defun read-constantly (stream char)
  (declare (ignore char))
  (let* ((list (read-delimited-list #\] stream t))
         (value (if (rest list) list (first list)))
         (var (gensym)))
    `(let ((,var ,value))
       (annotate-fn (constantly ,var)
                    (list :category :constantly 
                          :constant ,var)))))

For example:

> [(+ 8 5)]
=> #<ANNOTATED-FN ...>

By the way, the syntax I defined also allows the following:

> [+ 8 5]

Pretty-printing

Let's define a generic function that prints an annotated function given its :category field:

(defgeneric print-for-category (category data object stream))

(defmethod print-object ((o annotated-fn) s)
  (let* ((data (annotated-fn-data o))
         (category (getf data :category)))
    (print-for-category category data o s)))

Then, we can specialize it for :constantly, and here we assume also that the data associated with the function contains a :constant field:

(defmethod print-for-category ((_ (eql :constantly)) data o s)
  (format s "[~s]" (getf data :constant)))

For example:

(let ((value (+ 8 6)))
  (annotate-fn (constantly value)
               `(:constant ,value
                 :category :constantly)))

This above is printed as:

[14]

Which is the same as what the reader macro expects.