thodg/css-parser/css-parser.lisp

Branch - branch -master

• Show log

  Commit

• Hash : 6fa19a61
  Author : Thomas de Grivel
  Date : 2022-11-04T11:10:11
  

  ws
  

Download

• css-parser.lisp

• ;; css-parser - CSS parser for cl-stream
  ;; Copyright 2018,2019,2022 Thomas de Grivel <thoxdg@gmail.com>
  
  (in-package :css-parser)
  
  (defclass css-item (item)
    ((parent :initarg :parent
  	   :accessor item-parent
  	   :type (or null item))))
  
  (defclass named-item (css-item)
    ((name :initarg :name
  	 :accessor item-name
  	 :type string)))
  
  (defclass with-prelude (css-item)
    ((prelude :initarg :prelude
  	    :initform nil
  	    :accessor item-prelude
  	    :type list)))
  
  (defclass with-items (css-item)
    ((items :initarg :items
  	  :initform nil
  	  :accessor item-items
  	  :type list)
     (items-end :initform nil
                :accessor item-items-end
                :type list)))
  
  (defgeneric item-append (with-items item))
  
  (defmethod item-append ((parent with-items) (item item))
    (let ((end (list item)))
      (cond ((endp (item-items parent))
             (setf (item-items parent) end
                   (item-items-end parent) end))
            (t
             (setf (cdr (item-items-end parent)) end
                   (item-items-end parent) end))))
    item)
  
  (defclass stylesheet (with-items) ())
  
  (defclass toplevel-flag (css-item)
    ((toplevel :initarg :toplevel
  	     :initform nil
  	     :accessor item-toplevel
  	     :type boolean)))
  
  (defclass at-rule (named-item with-prelude with-items toplevel-flag) ())
  (defclass qualified-rule (with-prelude with-items toplevel-flag) ())
  
  (defclass values-block (css-item)
    ((values :initarg :values
             :initform nil
  	   :accessor item-values
  	   :type list)))
  
  (defclass css-declaration (named-item values-block)
    ((important-p :initarg :important
  		:initform nil
  		:accessor important-p
  		:type boolean)))
  
  (defclass {}-block (values-block) ())
  (defclass paren-block (values-block) ())
  (defclass []-block (values-block) ())
  (defclass function-block (values-block)
    ((function :initarg :function
  	     :reader item-function
  	     :type function-token)))
  
  (defclass css-parser (parser)
    ((item :initform (make-instance 'stylesheet)
           :accessor parser-item
           :type css-item)))
  
  ;;  Parsing
  
  (defgeneric parser-error (css-parser &rest message))
  (defgeneric parse-at-rule (css-parser &key toplevel))
  (defgeneric parse-qualified-rule (css-parser &key toplevel))
  (defgeneric parse-declaration (css-parser))
  (defgeneric parse-component-value (css-parser))
  (defgeneric parse-component-value* (css-parser))
  (defgeneric parse-{}-block (css-parser))
  (defgeneric parse-paren-block (css-parser))
  (defgeneric parse-[]-block (css-parser))
  (defgeneric parse-function-block (css-parser))
  (defgeneric parse-preserved-token (css-parser))
  
  (defmethod parser-error ((pr css-parser) &rest message)
    (let ((token (parser-token pr 0)))
      (if token
          (error "CSS error ~A:~A ~A"
                 (token-line token)
                 (token-character token)
                 (str message))
          (error "CSS error ~A" (str message)))))
  
  (defmethod parse-component-value ((pr css-parser))
    (or (parse-function-block pr)
        (parse-[]-block pr)
        (parse-paren-block pr)
        (parse-declaration pr)
        (parse-preserved-token pr)))
  
  (defmethod parse-component-value* ((pr css-parser))
    (let ((values ()))
      (loop (or (match pr 'whitespace-token)
                (let ((value (parse-component-value pr)))
                  (when value
                    (push value values)))
                (return)))
      (nreverse values)))
  
  (defmethod parse-{}-block ((pr css-parser))
    (match-sequence pr
      (when (match pr '{-token)
        (let ((values (parse-component-value* pr)))
          (when values
            (if (match pr '}-token)
                (setf (item-items (parser-item pr)) values)
                (parser-error pr "expected '}'")))))))
  
  (defmethod parse-paren-block ((pr css-parser))
    (match-sequence pr
      (when (match pr 'left-paren-token)
        (let ((values (parse-component-value* pr)))
          (if (match pr 'right-paren-token)
              (make-instance 'paren-block :values values)
              (parser-error pr "expected ')'"))))))
  
  (defmethod parse-[]-block ((pr css-parser))
    (match-sequence pr
      (when (match pr '[-token)
        (let ((values (parse-component-value* pr)))
          (if (match pr ']-token)
              (make-instance '[]-block :values values)
              (parser-error pr "expected ']'"))))))
  
  (defmethod parse-function-block ((pr css-parser))
    (match-sequence pr
      (let ((fun (match pr 'function-token)))
        (when fun
          (let ((values (parse-component-value* pr)))
            (if (match pr 'right-paren-token)
                (make-instance 'function-block
                               :function fun
                               :values values)
                (parser-error pr "expected ')'")))))))
  
  (defmethod parse-preserved-token ((pr css-parser))
    (match-not pr (lambda (pr)
                    (match-or pr '({-token }-token
                                   [-token ]-token
                                   left-paren-token right-paren-token
                                   eof-token)))))
  
  (defmethod parse-declaration ((pr css-parser))
    (match-sequence pr
      (match pr 'whitespace-token)
      (let ((name (parse-preserved-token pr)))
        (when name
          (let ((prop (make-instance 'css-declaration
                                     :name (token-string name))))
            (match pr 'whitespace-token)
            (when (match pr 'colon-token)
              (loop
                 (match pr 'whitespace-token)
                 (when (or (match pr 'semicolon-token)
                           (typep (parser-match-token pr 0) '}-token))
                   (return prop))
                 (let ((value (parse-preserved-token pr)))
                   (when value
                     (push value (item-values prop)))))))))))
    
  (defmethod parse-at-rule ((pr css-parser) &key toplevel)
    (parser-push pr)
    (let ((at-keyword (match pr 'at-keyword-token)))
      (when at-keyword
        (let* ((parent (parser-item pr))
               (name (token-string (token-ident at-keyword)))
               (prelude (parse-component-value* pr))
               (item (make-instance 'at-rule
                                    :parent parent
                                    :name name
                                    :prelude prelude
                                    :toplevel toplevel)))
          (setf (parser-item pr) item)
  	(cond ((or (semicolon-token pr)
                     (parse-{}-block pr))
                 (item-append parent item)
                 (setf (parser-item pr) parent)
                 item)
  	      (t
  	       (parser-pop pr)
  	       nil))))))
  
  (defmethod parse-rule-list ((pr css-parser))
    (if (or (parse-at-rule pr)
  	  (parse-qualified-rule pr)
  	  (match pr 'whitespace-token))
        (parse-rule-list pr))
        t)
  
  (defmethod parse-qualified-rule ((pr css-parser) &key toplevel)
    (match-sequence pr
      (let* ((parent (parser-item pr))
             (prelude (parse-component-value* pr))
             (item (make-instance 'qualified-rule
                                  :prelude prelude
                                  :parent parent
                                  :toplevel toplevel)))
        (setf (parser-item pr) item)
        (let ((block (parse-{}-block pr)))
          (when block
            (setf (item-items item) block)
            (item-append parent item))
          (setf (parser-item pr) parent)
          (when block
            item)))))
  
  (defmethod parse-stylesheet ((pr css-parser))
    (let ((stylesheet (make-instance 'stylesheet :parent nil)))
      (setf (parser-item pr) stylesheet)
      (loop
         (unless (or (parse-at-rule pr :toplevel t)
                     (parse-qualified-rule pr :toplevel t)
                     (match pr 'whitespace-token)
                     (match pr 'cdo-token)
                     (match pr 'cdc-token))
           (return)))
      (unless (match pr 'eof-token)
        (parser-error pr "at top level"))
      stylesheet))
  
  (defmethod parser-parse ((pr css-parser))
    (parse-stylesheet pr))
  
  (defun css-parser (stream)
    (make-instance 'css-parser :stream stream))
  
  #+nil
  (untrace
   item-append
   ;match-not
   ;match-or
   parse-stylesheet
   parse-qualified-rule
   parse-rule-list
   parse-at-rule
   parse-preserved-token
   ;parse-function-block
   ;parse-[]-block
   ;parse-paren-block
   parse-{}-block
   parse-component-values*
   parse-component-value
   parse-declaration
   )
  

Download