(defpackage :de.bauhh.css (:use :common-lisp)) (in-package :de.bauhh.css) ;;;; -- TODO ---------------------------------------------------------------------------------- ;; - I don't like our units business ;; - [attr] selectors ;; - :nth-xxx ;; - #hhh and #hhhhhh ;; shape-outside: polygon(0 0, 100% 100%, 0 100%) ;; calc(1px + 3px) ;; main { ;; grid: "H H " ;; "A B " ;; "F F " 30px ;; / auto 1fr; ;; } ;; grid-template-columns: 10px [col-start] 250px [col-end] ;; 10px [col-start] 250px [col-end] ;; 10px [col-start] 250px [col-end] ;; 10px [col-start] 250px [col-end] 10px; ;; @media ;; / ;; Hmm (':px 3) ;; Hmm (#':rgb 1 2 3) ;; Floating Point ;;;; ------------------------------------------------------------------------------------------ ;; -------------------------------------------------------------------------------- ;; GRIND-VALUE value &optional stream [Function] ;; ;; Outputs a CSS property value to the stream /stream/. When /stream/ is ;; NIL output goes to a string output stream and the output is returned ;; as a string. ;; ;; The following rules apply: ;; ;; - A real number is rendered as such. ;; ;; - A symbol is rendered as a CSS IDENT token, observing *PRINT-CASE*. ;; Proper CSS escaping is implemented. ;; ;; - (LIST x y z) is rendered as x, y, z ;; ;; - (:@ x y z) is rendered as x y z ;; ;; - (:foo 1 2 3) is rendered as foo(1, 2, 3) ;; ;; - Strings are rendered as CSS strings with proper escaping. ;; ;; - A list of a real number and a keyword are rendered as a value with ;; a unit. E.g. (GRIND-VALUE '(10 :px)) -> "10PX" (defun grind-value (value &optional stream) (cond ((null stream) (with-output-to-string (bag) (grind-value value bag))) (t (cond ((symbolp value) (grind-symbol value stream)) ((stringp value) (princ "'" stream) (grind-escaped value stream :safe-test (lambda (c) (char/= c #\'))) (princ "'" stream)) ((integerp value) (princ value stream)) ((realp value) ;; Don't look! (write-string (let ((s (format nil "~,10F" (* 1d0 value)))) (setq s (string-right-trim "0" s)) (string-right-trim "." s)) stream)) ((atom value) (princ value stream)) ((eq (car value) 'list) (grind-infix ", " #'grind-value (cdr value) stream)) ((eq (car value) ':@) (grind-infix " " #'grind-value (cdr value) stream)) ((keywordp (car value)) (grind-symbol (car value) stream) (princ "(" stream) (grind-infix ", " #'grind-value (cdr value) stream) (princ ")" stream)) ;; units ((and (numberp (car value)) (keywordp (cadr value)) (null (cddr value))) (destructuring-bind (value unit) value (grind-value value stream) (princ unit stream))) (t (error "Bust")))))) (defun grind-escaped (string stream &key (safe-test (constantly t)) (initial-safe-test safe-test)) ;; Any character outside the ASCII printing range is considered ;; unsafe by default. (loop for k from 0 for c across string do (cond ((and (funcall (if (zerop k) initial-safe-test safe-test) c) (<= 32 (char-code c) 126)) ;; safe (write-char c stream)) ((and (<= 32 (char-code c) 126) (not (digit-char-p c 16))) (princ #\\ stream) (write-char c stream)) (t (format stream "\\~X" (char-code c)) (when (and (< (1+ k) (length string)) (or (digit-char-p (char string (1+ k)) 16) (char= #\space (char string (1+ k)))) (princ #\space stream))))))) (defun grind-assignment (assignment &optional stream) (cond ((null stream) (with-output-to-string (bag) (grind-assignment assignment bag))) (t (destructuring-bind (prop &rest values) assignment (grind-symbol prop stream) (princ ": " stream) (grind-infix " " #'grind-value values stream))))) (defun grind-rule (rule &optional stream) (cond ((null stream) (with-output-to-string (bag) (grind-rule rule bag))) (t (assert (string-equal :rule (car rule))) (pprint-logical-block (stream nil) (destructuring-bind (selector &rest assignments) (cdr rule) (grind-selector selector stream) (grind-group #'grind-assignment assignments stream :sep ";")))))) (defun grind-symbol (symbol stream) (let ((i 0) (string (princ-to-string symbol))) (grind-escaped string stream ;; ### #\- being a safe name-start code point is ;; ### questionable, since I cannot find it in the spec ;; ### ;; ### But all the vender specific properties use it! ;; ;; ### And: What about '|-300| Then? :initial-safe-test (lambda (c) (incf i) (or (alpha-char-p c) (find c "_-"))) :safe-test (lambda (c) (incf i) ;; Weird corner case (cond ((and (= i 2) (char= (char string 0) #\-) (digit-char-p c)) nil) (t (or (alphanumericp c) (find c "_-")))))))) (defun grind-selector (selector stream &aux it) (cond ((null stream) (with-output-to-string (bag) (grind-selector selector bag))) ((eql selector 't) (princ "*" stream)) ((setf it (case (car selector) (:gi "") (:class ".") (:id "#") (:pseudo-class ":") (:pseudo-element "::"))) (destructuring-bind (name) (cdr selector) (write-string it stream) (grind-symbol name stream))) ((setf it (case (car selector) (>> " ") (> " > ") (+ " + ") (~ " ~ ") (and "") (or ", "))) (grind-infix it #'grind-selector (cdr selector) stream)) ((member (car selector) '(:has :not :matches)) (destructuring-bind (pred sub) selector (princ ":" stream) (princ pred stream) (princ "(" stream) (grind-selector sub stream) (princ ")" stream))) (t (error "Don't know how to output the ~S selector form." selector)) )) (defun grind-infix (seperator sub-grinder list stream) (loop for c in list for k from 0 do (unless (zerop k) (princ seperator stream)) (funcall sub-grinder c stream))) (defun grind-infix (seperator sub-grinder list stream) (pprint-logical-block (stream nil) (loop for c in list for k from 0 do (unless (zerop k) (princ seperator stream) (pprint-newline :linear stream)) (funcall sub-grinder c stream)))) ;;;; -- @media -------------------------------------------------------------------------------- ;; ;; * ;; ;; | media_query_list ;; | : [media_query [ ',' media_query ]* ]? ;; | ; ;; | media_query ;; | : [ONLY | NOT]? media_type [ AND expression ]* ;; | | expression [ AND expression ]* ;; | ; ;; | media_type ;; | : IDENT ;; | ; ;; | expression ;; | : '(' media_feature [ ':' expr ]? ')' ;; | ; ;; | media_feature ;; | : IDENT ;; | ; ;; * ;; ;; | expr ;; | : term [ operator? term ]* ;; | ; ;; | term ;; | : unary_operator? ;; | [ NUMBER | PERCENTAGE | LENGTH | EMS | EXS | ANGLE | ;; | TIME | FREQ ] ;; | | STRING S* | IDENT | URI | hexcolor | function ;; | ; ;; | function ;; | : FUNCTION S* expr ')' S* ;; | ; ;; | unary_operator ;; | : '-' | '+' ;; | ; ;; | operator ;; | : '/' S* | ',' S* ;; | ; (defun grind-media-query (query stream) (cond ((null stream) (with-output-to-string (bag) (grind-media-query query bag))) ((atom query) (grind-value query stream)) (t (case (car query) ((or) (grind-infix ", " #'grind-media-query (cdr query) stream)) ((and) (grind-infix (format nil " ~A " 'and) #'grind-media-query (cdr query) stream)) ((not only) (destructuring-bind (op sub) query (princ op stream) (princ " " stream) (grind-media-query sub stream))) (t (destructuring-bind (feature &optional expr) query (princ "(" stream) (grind-symbol feature stream) (when expr (princ ": " stream) (grind-expr expr stream)) (princ ")" stream))))))) (defun grind-expr (expr stream) (cond ((atom expr) (grind-value expr stream)) (t (case (car expr) ((/) (grind-infix " / " #'grind-expr (cdr expr) stream)) ((list) (grind-infix ", " #'grind-expr (cdr expr) stream)) ((- +) (destructuring-bind (sub) (cdr expr) (princ (car expr) stream) (grind-value sub stream))) (t (grind-value expr stream)))))) (defun grind-decl (decl &optional stream) (cond ((null stream) (with-output-to-string (bag) (grind-decl decl bag))) (t (ecase (car decl) ((:rule) (grind-rule decl stream)) ((:media) (grind-media decl stream)))))) (defun grind-media (media stream) (destructuring-bind (query &rest rules) (cdr media) (pprint-newline :mandatory stream) (pprint-logical-block (stream nil) (princ "@" stream) (grind-symbol :media stream) (princ " " stream) (grind-media-query query stream) (grind-group #'grind-decl rules stream)))) (defun grind-group (sub-grinder list stream &key (sep nil)) (pprint-newline :mandatory stream) (pprint-logical-block (stream nil :prefix "{ ") (pprint-newline :mandatory stream) (loop for q on list do (funcall sub-grinder (car q) stream) (when sep (princ sep stream)) (when (cdr q) (pprint-newline :mandatory stream)))) (pprint-newline :mandatory stream) (princ "}" stream)) ;; [S* removed] ;;;; -- Example ------------------------------------------------------------------------------- (defun foo () (grind-decl '(:media (or print (and screen (:min-width (300 :px)))) (:rule (or (and (:gi H1) (:class :fancy) (:has (:class blah))) (:gi H2)) (:font-family (list "Helvetica" :sans-serif)) (:color :red) (:color :\#fff) (:border (1 :px) :solid :black) (:margin (1 :em) (1 :ex)) (:shape-outside (:polygon (:@ 0 (100 :%)) (:@ 0 (100 :%)))) (:shape-outside (:polygon (:@ 0 (100 :%)) (:@ 0 (100 :%)) (:@ 0 (100 :%)) (:@ 0 (100 :%)) (:@ 0 (100 :%)) (:@ 0 (100 :%)) (:@ 0 (100 :%)) (:@ 0 (100 :%)) (:@ 0 (100 :%)) (:@ 0 (100 :%)) (:@ 0 (100 :%)) (:@ 0 (100 :%)) (:@ 0 (100 :%)) (:@ 0 (100 :%)) (:@ 0 (100 :%)))) ) (:rule (or (:gi H3) (:gi H4)) (:padding (1 :em) (1 :ex)) (:text-shadow (list (:@ (-1 :px) (-1 :px) 0 :black) (:@ (-1 :px) (1 :px) 0 :black) (:@ (1 :px) (1 :px) 0 :black) (:@ (-1 :px) (-1 :px) 0 :black) (:@ (-1 :px) (1 :px) 0 :black) (:@ (1 :px) (1 :px) 0 :black) (:@ (-1 :px) (-1 :px) 0 :black) (:@ (-1 :px) (1 :px) 0 :black) (:@ (1 :px) (1 :px) 0 :black) (:@ (-1 :px) (-1 :px) 0 :black) (:@ (-1 :px) (1 :px) 0 :black) (:@ (1 :px) (1 :px) 0 :black) )) (:color (:rgb 100 160 200)) )))) #+NIL (defun foo () (grind-decl '(:rule (or (and (:gi H1) (:class :fancy) (:has (:class blah))) (:gi H2)) (:font-family "Helvetica" :sans-serif) (:color :red) (:color :\#fff) (:border (1 :px) :solid :black) (:margin (1 :em) (1 :ex)) (:shape-outside (:polygon (:@ 0 (100 :%)) (:@ 0 (100 :%)))) )))