From a9e5b8205ede340306b0ee993b7fa6644c77263b Mon Sep 17 00:00:00 2001 From: Shinmera Date: Wed, 3 Sep 2014 18:48:37 +0200 Subject: [PATCH] Mostly working now. --- compiler.lisp | 104 +++++++++++++++++++++++++++++++++++++++++ lass.lisp | 125 -------------------------------------------------- writer.lisp | 36 +++++++++++++++ 3 files changed, 140 insertions(+), 125 deletions(-) create mode 100644 compiler.lisp create mode 100644 writer.lisp diff --git a/compiler.lisp b/compiler.lisp new file mode 100644 index 0000000..4abf164 --- /dev/null +++ b/compiler.lisp @@ -0,0 +1,104 @@ +#| + This file is a part of LASS + (c) 2014 TymoonNET/NexT http://tymoon.eu (shinmera@tymoon.eu) + Author: Nicolas Hafner +|# + +(in-package #:org.tymoonnext.lass) + +(defvar *sheet*) + +(defgeneric compile-attribute (key value) + (:method (key (value list)) + (list (list (selective-downcase key) + (format NIL "~{~a~^ ~}" (mapcar #'selective-downcase value))))) + + (:method (key value) + (list (list (selective-downcase key) + (selective-downcase value))))) + +;; THIS IS SOME PRETTY SHODDY MAGIC CODE HERE +;; BEWARE OF DRAGONS AND ALL THAT +;; YOU HAVE BEEN WARNED. +;; +;; Can't wait for bugs about this to hit me down the line. +(defgeneric compile-constraint (func args) + (:method (func args) + (let ((cfunc (cond ((listp func) + (if (symbolp (first func)) + (compile-selector func) + func)) + (T (list (selective-downcase func))))) + (cargs (compile-selector (car args)))) + (loop with result = () + for func in cfunc + do (loop for arg in cargs + do (push (format NIL "~a ~a" func arg) result)) + finally (return (compile-constraint (nreverse result) (cdr args)))))) + (:method ((func null) (args null)) + NIL) + (:method (func (args null)) + func) + (:method ((func (eql :or)) args) + (apply #'append (mapcar #'compile-selector args))) + (:method ((func (eql :and)) args) + (when args + (if (cdr args) + (let ((cfunc (compile-selector (first args))) + (cargs (compile-selector (second args)))) + (loop with result = () + for func in cfunc + do (loop for arg in cargs + do (push (format NIL "~a~a" func arg) result)) + finally (return (compile-constraint :and (append (nreverse result) (cddr args)))))) + args)))) + +(defun compile-selector (selector) + (etypecase selector + (null NIL) + ((or symbol string number) + (list (selective-downcase selector))) + (list + (compile-constraint (car selector) (cdr selector))))) + +(defun process-attrs (selector fields) + (let ((attrs ())) + (flet ((add-attr (attr) + (when attr + (let ((attr (nreverse attr))) + (dolist (attr (compile-attribute (car attr) (cdr attr))) + (push attr attrs)))))) + (loop with attr = () + for field in fields + do (etypecase field + (keyword + (add-attr attr) + (setf attr (list field))) + ((or string symbol) + (push field attr)) + (list + (compile-block (list selector (car field)) (cdr field)))) + finally (add-attr attr))) + (nreverse attrs))) + +(defun compile-block (selector fields) + (let ((selector (compile-selector selector)) + (attrs ()) + (subblocks ())) + (let* ((*sheet* ())) + (setf attrs (process-attrs selector fields)) + (setf subblocks (nreverse *sheet*))) + (push + (cons + selector + attrs) + *sheet*) + (dolist (block subblocks) + (push block *sheet*)) + *sheet*)) + +(defun compile-sheet (&rest blocks) + (let ((*sheet* ())) + (dolist (block blocks) + (compile-block (car block) (cdr block))) + (nreverse *sheet*))) diff --git a/lass.lisp b/lass.lisp index f3c7ec9..6ea616c 100644 --- a/lass.lisp +++ b/lass.lisp @@ -6,130 +6,5 @@ (in-package #:org.tymoonnext.lass) -(defvar *pretty* T) -(defvar *sheet*) -;; SHEET ::= (BLOCK*) -;; BLOCK ::= (SELECTOR ATTRIBUTE*) -;; SELECTOR --- string -;; ATTRIBUTE ::= (NAME VALUE) -;; NAME --- string -;; VALUE --- string -(defun selective-downcase (thing) - (typecase thing - (string thing) - (symbol (string-downcase thing)) - (T (princ-to-string thing)))) - -(defun write-sheet-attribute (stream attribute cp ap) - (declare (ignore cp ap)) - (when attribute - (format stream (format NIL "~~a:~@[~* ~]~~a;" *pretty*) - (first attribute) (second attribute)))) - -(defun write-sheet-block (stream block cp ap) - (declare (ignore cp ap)) - (when (and block (cdr block)) - (format stream (format NIL "~~a~@[~* ~]{~:*~@[~*~%~]~~{~:*~@[~* ~]~~/lass::write-sheet-attribute/~~^~:*~@[~*~%~]~~}~:*~@[~*~%~]}" *pretty*) - (car block) (cdr block)))) - -(defun write-sheet (sheet &key (stream T) (pretty *pretty*)) - (let ((*pretty* pretty)) - (format stream (format NIL "~~{~~/lass::write-sheet-block/~~^~@[~*~%~%~]~~}" pretty) sheet))) - -(defgeneric compile-attribute (key value) - (:method (key (value list)) - (list (selective-downcase key) - (format NIL "~{~a~^ ~}" (mapcar #'selective-downcase value)))) - - (:method (key value) - (list (selective-downcase key) - (selective-downcase value)))) - -(defgeneric compile-constraint (type &rest arg) - (:method ((type (eql 'class))&rest arg) - (format NIL ".~a" (selective-downcase (car arg)))) - - (:method ((type (eql 'id)) &rest arg) - (format NIL "#~a" (selective-downcase (car arg)))) - - (:method ((type (eql 'tag)) &rest arg) - (format NIL "~a" (selective-downcase (car arg)))) - - (:method ((type (eql 'attr=)) &rest arg) - (format NIL "[~a=~s]" (selective-downcase (first arg)) (second arg))) - - (:method ((type (eql 'attr~)) &rest arg) - (format NIL "[~a~~=~s]" (selective-downcase (first arg)) (second arg))) - - (:method ((type (eql 'attr^)) &rest arg) - (format NIL "[~a^=~s]" (selective-downcase (first arg)) (second arg))) - - (:method ((type (eql 'attr$)) &rest arg) - (format NIL "[~a$=~s]" (selective-downcase (first arg)) (second arg))) - - (:method ((type (eql 'attr*)) &rest arg) - (format NIL "[~a*=~s]" (selective-downcase (first arg)) (second arg))) - - (:method ((type (eql 'attr/)) &rest arg) - (format NIL "[~a|=~s]" (selective-downcase (first arg)) (second arg))) - - (:method (type &rest arg) - (format NIL "~{~a~^ ~}" (mapcar #'compile-selector (cons type arg))))) - -(defgeneric compile-selector (selector) - (:method ((selector string)) - selector) - - (:method ((selector symbol)) - (selective-downcase selector)) - - (:method ((selector list)) - (apply #'compile-constraint selector))) - -(defgeneric compile-block (selector body) - (:method (selector body) - (let ((values ())) - (push - (cons - (compile-selector selector) - (let ((body-forms ()) - (attribute NIL)) - (flet ((complete (attribute) - (when attribute - (let ((args (nreverse attribute))) - (setf attribute NIL) - (push (compile-attribute (car args) (cdr args)) - body-forms))))) - (loop for item in body - do (typecase item - (keyword - (complete attribute) - (setf attribute (list item))) - ((or string symbol number) - (push item attribute)) - (list - (setf values - (nconc - (compile-block (list selector (car item)) - (cdr item)) - values)))) - finally (complete attribute))) - (nreverse body-forms))) - values) - values))) - -(defgeneric compile-form (form) - (:method (form) - (error "???")) - (:method ((form list)) - (dolist (block (compile-block - (car form) (cdr form))) - (push block *sheet*)))) - -(defun compile-sheet (&rest forms) - (let ((*sheet* ())) - (dolist (form forms) - (compile-form form)) - (nreverse *sheet*))) diff --git a/writer.lisp b/writer.lisp new file mode 100644 index 0000000..9651156 --- /dev/null +++ b/writer.lisp @@ -0,0 +1,36 @@ +#| + This file is a part of LASS + (c) 2014 TymoonNET/NexT http://tymoon.eu (shinmera@tymoon.eu) + Author: Nicolas Hafner +|# + +(in-package #:org.tymoonnext.lass) + +(defvar *pretty* T) + +;; SHEET ::= (BLOCK*) +;; BLOCK ::= (SELECTOR ATTRIBUTE*) +;; SELECTOR ::= (string*) +;; ATTRIBUTE ::= (string string) + +(defun selective-downcase (thing) + (typecase thing + (string thing) + (symbol (string-downcase thing)) + (T (princ-to-string thing)))) + +(defun write-sheet-attribute (stream attribute cp ap) + (declare (ignore cp ap)) + (when attribute + (format stream (format NIL "~~a:~@[~* ~]~~a;" *pretty*) + (first attribute) (second attribute)))) + +(defun write-sheet-block (stream block cp ap) + (declare (ignore cp ap)) + (when (and block (cdr block)) + (format stream (format NIL "~~{~~a~~^,~@[~* ~]~~}{~:*~@[~*~%~]~~{~:*~@[~* ~]~~/lass::write-sheet-attribute/~~^~:*~@[~*~%~]~~}~:*~@[~*~%~]}" *pretty*) + (car block) (cdr block)))) + +(defun write-sheet (sheet &key (stream T) (pretty *pretty*)) + (let ((*pretty* pretty)) + (format stream (format NIL "~~{~~/lass::write-sheet-block/~~^~@[~*~%~%~]~~}" pretty) sheet)))