Mostly working now.
This commit is contained in:
Shinmera
parent
83d4297a47
commit
a9e5b8205e
3 changed files with 140 additions and 125 deletions
104
compiler.lisp
Normal file
104
compiler.lisp
Normal file
|
|
@ -0,0 +1,104 @@
|
|||
#|
|
||||
This file is a part of LASS
|
||||
(c) 2014 TymoonNET/NexT http://tymoon.eu (shinmera@tymoon.eu)
|
||||
Author: Nicolas Hafner <shinmera@tymoon.eu>
|
||||
|#
|
||||
|
||||
(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*)))
|
||||
125
lass.lisp
125
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*)))
|
||||
|
|
|
|||
36
writer.lisp
Normal file
36
writer.lisp
Normal file
|
|
@ -0,0 +1,36 @@
|
|||
#|
|
||||
This file is a part of LASS
|
||||
(c) 2014 TymoonNET/NexT http://tymoon.eu (shinmera@tymoon.eu)
|
||||
Author: Nicolas Hafner <shinmera@tymoon.eu>
|
||||
|#
|
||||
|
||||
(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)))
|
||||
Loading…
Reference in a new issue