colored symbols

col.lisp

(defpackage :col (:use :cl))
(in-package :col)

(ql:quickload :cl-ansi-text)

(defparameter *print-color* t)

;; Attach a color attribute to symbols

(defun color (symbol)
  (get symbol 'color))

(defun (setf color) (color symbol)
  (assert (find color cl-ansi-text::+term-colors+))
  (setf (get symbol 'color) color))

;; Defining a COLORED-SYMBOL type

(defun colored-symbol-p (symbol)
  (and *print-color* (symbolp symbol) (color symbol)))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (deftype colored-symbol ()
    '(and symbol (satisfies colored-symbol-p))))

;; Compute ansi string for a given symbol and a color

(defun colored-symbol-as-string (symbol &aux (color (color symbol)))
  (with-output-to-string (s)
    (cl-ansi-text:with-color (color :stream s)
      (let ((*print-color* nil))
        (princ symbol s)))))

;; Dedicated pretty-printer for COLORED-SYMBOL type

(set-pprint-dispatch 'colored-symbol
                     (lambda (stream symbol)
                       (princ (colored-symbol-as-string symbol)
                              stream)))

(setf (color 'stream) :red)
(setf (color 'block) :blue)
(setf (color 'lambda) :yellow)

;; Example

(defun read-one-line (file)
  (with-open-file (stream file)
    (read-line stream)))

;; Print it to a terminal (tested with SBCL)

(function-lambda-expression #'read-one-line)