Pretty-print a human-readable summary of a Common Lisp Readtable.

pretty-print-readtable.lisp

; All my gist code is licensed under the MIT license.

(defun safe-char-name (char)
  "Return a printable representation of a character."
  (cond ((graphic-char-p char) (format nil "'~C'" char))
        (t (format nil "#\\~A" (char-name char)))))

(defun get-character-range ()
  "Generates a list of characters ASCII characters."
  (loop for code from 0 to 255
        for char = (code-char code)
        when char collect char))

(defun sort-by-char (lst)
  "Sorts case-insensitive by character."
  (sort lst #'char-lessp :key #'car))

(defun pretty-print-readtable (&key ((readtable rt) *readtable*)
                                    (stream *standard-output*))
  "Prints a human-readable summary of a readtable."
  (let* ((terminating-macros '())
        (potential-dispatch-pairs '())
        (dispatch-info '())
        (other-macros '())
        (characters (get-character-range)))
    (loop for char in characters
          do (multiple-value-bind (fn non-terminating-p) (get-macro-character char rt)
               (when fn
                 (if non-terminating-p
                     (push (list char fn) potential-dispatch-pairs)
                     (push (list char fn) terminating-macros)))))
    (loop for (dchar dchar-fn) in potential-dispatch-pairs
          do (let ((sub-entries '())
                   (actually-dispatch nil))
               (loop for sub-char in characters
                     do (let ((sub-fn (get-dispatch-macro-character dchar sub-char rt)))
                          (when sub-fn
                            (setf actually-dispatch t)
                            (push (list sub-char sub-fn) sub-entries))))
               (if actually-dispatch
                   (push (list dchar (nreverse sub-entries)) dispatch-info)
                   (push (list dchar dchar-fn) other-macros))))

    (format stream "Readtable ~A~%" rt)
    (format stream "  Case Sensitivity: ~A~%~%" (readtable-case rt))

    (format stream "  Terminating Macro Characters:~%")
    (if terminating-macros
        (loop for (char fn) in (sort-by-char terminating-macros)
              do (format stream "    ~A => ~A~%" (safe-char-name char) fn))
        (format stream "    (None found in the checked character set)~%"))

    (format stream "~%  Dispatch Macro Characters:~%")
    (let ((sorted-dispatch-info (sort-by-char dispatch-info)))
      (if sorted-dispatch-info
          (loop for (dchar sub-entries) in sorted-dispatch-info
                do (format stream "    ~A :~%" (safe-char-name dchar))
                   (let ((sorted-maps (sort-by-char sub-entries)))
                     (if sorted-maps
                         (loop for (sub-char sub-fn) in sorted-maps
                               do (format stream "      ~A => ~A~%" (safe-char-name sub-char) sub-fn))
                         (format stream "      (No sub-characters found within the checked set, LOL U OK?)~%"))))
          (format stream "    (None found with definitions in the checked character set)~%")))

    (setf other-macros (sort-by-char other-macros))
    (when other-macros
        (format stream "~%  Other Non-Terminating Macro Characters (No sub-chars found in checked set):~%")
        (loop for (char fn) in other-macros
              do (format stream "    ~A => " (safe-char-name char))
                 (let ((*print-readably* nil))
                   (write fn :stream stream :escape t :pretty nil))
                 (format stream "~%")))

    (terpri stream)))

; Sample usage:
;CL-USER> (pretty-print-readtable)
;Readtable #<READTABLE {10000386B3}>
;  Case Sensitivity: UPCASE
;
;  Terminating Macro Characters:
;    '"' => #<FUNCTION SB-IMPL::READ-STRING>
;    ''' => #<FUNCTION SB-IMPL::READ-QUOTE>
;    '(' => READ-LIST
;    ')' => READ-RIGHT-PAREN
;    ',' => COMMA-CHARMACRO
;    ';' => #<FUNCTION SB-IMPL::READ-COMMENT>
;    '`' => BACKQUOTE-CHARMACRO
;
;  Dispatch Macro Characters:
;    '#' :
;      #\Backspace => #<FUNCTION SB-IMPL::SHARP-ILLEGAL>
;      #\Tab => #<FUNCTION SB-IMPL::SHARP-ILLEGAL>
;      #\Newline => #<FUNCTION SB-IMPL::SHARP-ILLEGAL>
;      #\Page => #<FUNCTION SB-IMPL::SHARP-ILLEGAL>
;      #\Return => #<FUNCTION SB-IMPL::SHARP-ILLEGAL>
;      ' ' => #<FUNCTION SB-IMPL::SHARP-ILLEGAL>
;      '#' => #<FUNCTION SB-IMPL::SHARP-SHARP>
;      ''' => #<FUNCTION SB-IMPL::SHARP-QUOTE>
;      '(' => #<FUNCTION SB-IMPL::SHARP-LEFT-PAREN>
;      ')' => #<FUNCTION SB-IMPL::SHARP-ILLEGAL>
;      '*' => #<FUNCTION SB-IMPL::SHARP-STAR>
;      '+' => #<FUNCTION SB-IMPL::SHARP-PLUS-MINUS>
;      '-' => #<FUNCTION SB-IMPL::SHARP-PLUS-MINUS>
;      '.' => #<FUNCTION SB-IMPL::SHARP-DOT>
;      ':' => #<FUNCTION SB-IMPL::SHARP-COLON>
;      '<' => #<FUNCTION SB-IMPL::SHARP-ILLEGAL>
;      '=' => #<FUNCTION SB-IMPL::SHARP-EQUAL>
;      '\' => #<FUNCTION SB-IMPL::SHARP-BACKSLASH>
;      'A' => #<FUNCTION SB-IMPL::SHARP-A>
;      'a' => #<FUNCTION SB-IMPL::SHARP-A>
;      'B' => #<FUNCTION SB-IMPL::SHARP-B>
;      'b' => #<FUNCTION SB-IMPL::SHARP-B>
;      'C' => #<FUNCTION SB-IMPL::SHARP-C>
;      'c' => #<FUNCTION SB-IMPL::SHARP-C>
;      'O' => #<FUNCTION SB-IMPL::SHARP-O>
;      'o' => #<FUNCTION SB-IMPL::SHARP-O>
;      'P' => #<FUNCTION SB-IMPL::SHARP-P>
;      'p' => #<FUNCTION SB-IMPL::SHARP-P>
;      'R' => #<FUNCTION SB-IMPL::SHARP-R>
;      'r' => #<FUNCTION SB-IMPL::SHARP-R>
;      'S' => #<FUNCTION SB-IMPL::SHARP-S>
;      's' => #<FUNCTION SB-IMPL::SHARP-S>
;      'X' => #<FUNCTION SB-IMPL::SHARP-X>
;      'x' => #<FUNCTION SB-IMPL::SHARP-X>
;      '|' => #<FUNCTION SB-IMPL::SHARP-VERTICAL-BAR>