lisp/batchcolor.lisp @ e27888136324

(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload '(:adopt :cl-ppcre ) :silent t))

(defpackage :batchcolor
  (:use :cl)
  (:export :toplevel :*ui*))

(in-package :batchcolor)

;;;; Configuration ------------------------------------------------------------
(defparameter *version* "0.0.1")
(defparameter *colors* (make-hash-table :test #'equal))


;;;; Functionality ------------------------------------------------------------
(defun rgb-code (color)
  (destructuring-bind (r g b) color
    ;; The 256 color mode color values are essentially r/g/b in base 6, but
    ;; shifted 16 higher to account for the intiial 8+8 colors.
    (+ (* r 36)
       (* g 6)
       (* b 1)
       16)))

(defun random-color ()
  (loop :for color = (list (random 6) (random 6) (random 6))
        :while (<= (apply #'+ color) 3)
        :finally (return color)))

(defun find-color (string)
  (let ((current (gethash string *colors*)))
    (if current
      current
      (setf (gethash string *colors*) (random-color)))))

(defun ansi-color-start (color)
  (format nil "~C[38;5;~Dm" #\Escape (rgb-code color)))

(defun ansi-color-end ()
  (format nil "~C[0m" #\Escape))

(defun colorize-line (scanner line &aux (start 0))
  (ppcre:do-scans (ms me rs re scanner line)
    (setf rs (remove nil rs)
          re (remove nil re))
    (when (/= 1 (length rs))
      (error "Regex must contain exactly 1 register group, e.g. 'x (fo+) y'."))
    (let* ((word-start (aref rs 0))
           (word-end (aref re 0))
           (word (subseq line word-start word-end))
           (color (find-color word)))
      (write-string line *standard-output* :start start :end word-start)
      (format t "~A~A~A" (ansi-color-start color) word (ansi-color-end))
      (setf start word-end)))
  (write-line line *standard-output* :start start)
  (values))


;;;; Run ----------------------------------------------------------------------
(defun run (pattern)
  (loop
    :with scanner = (ppcre:create-scanner pattern)
    :for line = (read-line *standard-input* nil)
    :while line :do (colorize-line scanner line)))


;;;; User Interface -----------------------------------------------------------
(defparameter *examples*
  '(("Colorize IRC nicknames in a chat log:"
     . "cat channel.log | batchcolor '<(\\\\w+)>'")
    ("Colorize UUIDs in a request log:"
     . "tail -f /var/log/foo | batchcolor '([a-f0-9]{8}-[a-f0-9]{4}-[a-f0-9]{4}-[a-f0-9]{4}-[a-f0-9]{12})'")))


(defparameter *option-help*
  (adopt:make-option 'help
    :help "Display help and exit."
    :long "help"
    :short #\h
    :reduce (constantly t)))

(defparameter *option-version*
  (adopt:make-option 'version
    :help "Display version information and exit."
    :long "version"
    :reduce (constantly t)))


(adopt:define-string *help-text*
  "batchcolor takes a regular expression and matches it against standard ~
   input one line at a time.  Each unique match is highlighted in a random ~
   color.")

(defparameter *ui*
  (adopt:make-interface
    :name "batchcolor"
    :usage "[OPTIONS] REGEX"
    :summary "colorize regex matches in batches"
    :help *help-text*
    :examples *examples*
    :contents (list *option-help*
                    *option-version*)))


(defun toplevel ()
  #+sbcl (sb-ext:disable-debugger)
  (handler-case
      (multiple-value-bind (arguments options) (adopt:parse-options *ui*)
        (when (gethash 'help options)
          (adopt:print-help-and-exit *ui*))
        (when (gethash 'version options)
          (write-line *version*)
          (adopt:exit))
        (if (/= 1 (length arguments))
          (adopt:print-help-and-exit *ui*)
          (destructuring-bind (pattern) arguments
            (run pattern))))
    (error (c) (adopt:print-error-and-exit c))
    #+sbcl (sb-sys:interactive-interrupt (c)
             (declare (ignore c))
             (adopt:exit))))