Common Lisp CSS Parser & Lexer tailored for Tailwind CSS

lexer.cl

(defpackage :css.lexer
  (:use :cl)
  (:export :lexen :lexen-name :lexen-index
    :make-lexen :lexen? :lexen-portion :lexen-start
    :collect-lexens :or== :first-character))
(in-package :css.lexer)

(defun first-character (seq)
  (loop
  for i from 0 below (length seq)
  for ch = (schar seq i)
  until (not (or (equalp ch #\Space) (equalp ch #\Nul)))
  finally (return (values ch i))))

(defstruct lexen
  (index nil :type fixnum)
  (start nil :type fixnum)
  (name nil :type (or null keyword))
  (portion nil :type string))

(defmacro defparsefn (str body)
  `(let ((hsh (make-hash-table)))
     ,@(loop
         for i from 0 below (length (eval str))
         collect `(setf (gethash ,(schar (eval str) i) hsh) ,(1+ i)))
     (defun ,@body)))

(deftype lexen? ()
  `(or null lexen))

(defparsefn "/*"
  (comment-char-number (seq index)
    (if (> (length seq) index)
      (or (gethash (schar seq index) hsh) 0)
      0)))
(defun comment-p (seq index)
  (declare (optimize (speed 3) (debug 1) (safety 1))
    (simple-string seq) (fixnum index))
  (=
    (+ (comment-char-number seq index) (comment-char-number seq (1+ index)))
    3))

(defun or== (val &rest args)
  (loop
    for arg in args
    for eqls = (equalp val arg)
    until eqls
    finally (return (when eqls arg))))

(defun next-token (seq &key (start 0) (index start) (hsh (make-hash-table)))
  (declare (optimize (speed 3) (debug 1) (safety 1))
    (simple-string seq) (type fixnum index start)
    (hash-table hsh))
  (the lexen?
    (when (> (length seq) index)
      (let* ((ch (schar seq index)) (lookup (gethash ch hsh)) (is-comment (comment-p seq index)))
        (unless (char= ch #\Nul)
          (if (or is-comment lookup)
            (make-lexen :index index :start start
              :name
                (if is-comment (if (char= (elt seq index) #\/) :comment_start :comment_end))
              :portion (subseq seq start index))
            (next-token seq :start start :index (+ (if (char= ch #\\) 2 1) index) :hsh hsh)))))))

(defparameter *state-machine*
  (make-hash-table))

(defmacro with-next-token (value)
  `(let ((ret (next-token seq :start start :index start :hsh hsh)) (name nil))
     (when ret
       (let ((lookup (gethash (elt seq (lexen-index ret)) hsh)))
         (declare (ignorable lookup))
         (setf name (setf (lexen-name ret) (or (lexen-name ret) ,value)))))
     (values ret (gethash name *state-machine*))))

(defun at-rule-p (seq)
  (multiple-value-bind (ch i) (first-character seq)
    (values (equalp ch #\@) i)))

(defun and-subseq (seq start end)
  (and (<= start end (length seq))
    (subseq seq start end)))

(defun prefix-p (seq prefix start)
  (let ((substr (and-subseq seq start (+ (length prefix)))))
    (when substr
      (equalp substr prefix))))

(defun block-p (seq)
  (multiple-value-bind (is-at-rule i) (at-rule-p seq)
    (when is-at-rule
      (or (prefix-p seq "@media" i) (prefix-p seq "@keyframes" i)))))

(defparsefn "/{}"
  (initial-state (seq &key (start 0))
    (with-next-token (case lookup (3 :block_end) (t :block_start)))))
(defparsefn "*"
  (comment-state (seq &key (start 0))
    (multiple-value-bind (ret statefn) (with-next-token :comment_end)
      (values ret statefn))))
(defparsefn ":{}"
  (block-state (seq &key (start 0))
    (multiple-value-bind (ret state)
        (with-next-token (case lookup (1 :colon) (2 :block_start) (3 :block_end)))
      (if (and ret (block-p (subseq seq (lexen-start ret) (lexen-index ret))))
        (initial-state seq :start start)
        (values ret state)))))

(defparsefn ";}"
  (value-state (seq &key (start 0))
    (with-next-token
      (case lookup (1 :semicolon) (2 :block_end)))))

(setf (gethash :comment_start *state-machine*)
  #'comment-state)
(setf (gethash :comment_end *state-machine*)
  #'initial-state)
(setf (gethash :block_start *state-machine*)
  #'block-state)
(setf (gethash :block_end *state-machine*)
  #'initial-state)
(setf (gethash :colon *state-machine*)
  #'value-state)
(setf (gethash :semicolon *state-machine*)
  #'block-state)

(defun collect-lexens (seq &key (start 0))
  (declare (simple-string seq)
    (fixnum start)
    (optimize (speed 3) (debug 1) (safety 1)))
  (loop
    with state = #'initial-state
    with vec = (make-array 0 :element-type 'lexen :fill-pointer t)
    until (null state)
    for x =
    (multiple-value-bind (ret statefn) (apply state `(,seq :start ,start))
      (setf state statefn)
      (when ret
        (subseq seq start (lexen-index ret)))
      ret)
    until (null x)
    do
    (progn
      (setf (lexen-portion x) (subseq seq start (lexen-index x)))
      (vector-push-extend x vec)
      (setf start
        (+ (lexen-index x)
          (if (or== (lexen-name x) :comment_start :comment_end) 2 1))))
    finally (return vec)))

parser.cl

(defpackage :css.parser
  (:use cl :css.lexer)
  (:export :trim-tailwind :get-css-regexp :rebuild-tailwind)
  (:nicknames :acs.css))
(in-package :css.parser)

(defparameter *seq* nil)
(defun set-global-seq ()
  (with-open-file (s "./tailwind.min.css" :direction :input :element-type 'character)
    (setf *seq* (make-array (file-length s) :element-type 'character))
    (read-sequence *seq* s)))
(export 'set-global-seq)
(export '*seq*)
(set-global-seq)
(defvar *lexens* (collect-lexens *seq*))

(defun html-element-p (seq)
  (and (> (length seq) 0) (not (equalp (first-character seq) #\.))))

(defun export-p (seq &optional reg)
  (declare (type (or null (function (simple-string) boolean)) reg))
  (or (html-element-p seq) (and reg (funcall reg seq))))

(defun print-lexen (lexen)
  (write-string (lexen-portion lexen))
  (write-string
    (case (lexen-name lexen)
      (:semicolon ";")
      (:colon ":")
      (:block_start "{")
      (:block_end "}")
      (t ""))))

(defun trim-tailwind (&optional reg)
  (loop
    with nest-block = 0
    with export-block = 0
    for index from 0 below (length *lexens*)
    for lexen = (elt *lexens* index)
    for name = (lexen-name lexen)
    unless (or== name :comment_start :comment_end)
    do
    (progn
      (when (equalp name :block_start)
        (incf nest-block)
        (when (export-p (lexen-portion lexen) reg)
          (incf export-block)))
      (when (and (not (zerop export-block)) (= export-block nest-block))
        (print-lexen lexen)
        (when (equalp name :block_end)
          (decf export-block)))
      (when (and (> nest-block 0) (equalp name :block_end))
        (decf nest-block)))))

(defun rebuild-tailwind (&optional reg)
  (with-open-file (s "./static/tailwind.min.css"
                   :direction :output
                   :if-exists :overwrite
                   :if-does-not-exist :create)
    (let ((*standard-output* s))
      (trim-tailwind reg))))