From d6908c8732e4659d46597fa6ac39a730d2dbe50c Mon Sep 17 00:00:00 2001 From: Shinmera Date: Wed, 29 Oct 2014 11:05:08 +0100 Subject: [PATCH] Basic support for special reading behaviour on a property-basis. Added property functions and some basic default cases. --- compiler.lisp | 65 +++++++++++++++++++++++++++++---------------- lass.asd | 4 ++- property-funcs.lisp | 54 +++++++++++++++++++++++++++++++++++++ readable-list.lisp | 37 ++++++++++++++++++++++++++ special.lisp | 13 +++++++++ 5 files changed, 149 insertions(+), 24 deletions(-) create mode 100644 property-funcs.lisp create mode 100644 readable-list.lisp diff --git a/compiler.lisp b/compiler.lisp index 408357c..02d8a9b 100644 --- a/compiler.lisp +++ b/compiler.lisp @@ -23,12 +23,13 @@ See the definition of the LET block.") (:documentation "Resolves THING to a value that makes sense for LASS. By default the following types are handled: -NULL: NIL -STRING: the THING itself -ARRAY: the variable stored in *VARS* under THING -KEYWORD: Colon-prefixed, downcased symbol-name of THING -SYMBOL: Downcased symbol-name of THING -T: PRINC-TO-STRING of THING") +NULL: NIL +STRING: the THING itself +ARRAY: the variable stored in *VARS* under THING +KEYWORD: Colon-prefixed, downcased symbol-name of THING +SYMBOL: Downcased symbol-name of THING +PATHNAME: If designating an image, base64 encoded inline image data. +T: PRINC-TO-STRING of THING") (:method ((thing null)) NIL) (:method ((thing string)) @@ -164,6 +165,27 @@ Returns a list with the RESOLVEd SELECTOR.") (:method ((selector T)) (list (resolve selector)))) +(defgeneric consume-item (item readable-list) + (:method (thing readable-list) + (error "Don't know what to do with ~s (not part of a property)." thing)) + (:method ((subblock list) readable-list) + (values + NIL + subblock)) + (:method ((property symbol) readable-list) + (if (keywordp property) + (values + (let ((propvals ())) + (loop for (next fullp) = (multiple-value-list (peek readable-list)) + while fullp + do (etypecase next + (keyword (return)) + (list (return)) + (T (push (consume readable-list) propvals)))) + (cons property (nreverse propvals))) + NIL) + (call-next-method)))) + (defgeneric compile-block (header fields) (:documentation "Compiles the block with given HEADER and FIELDS list. By default, the following case is handled: @@ -186,28 +208,25 @@ Special handling of blocks may occur. See DEFINE-SPECIAL-BLOCK.") (:method (selector fields) (let ((selector (compile-selector selector)) + (readable (make-readable-list fields)) (props ()) - (subblocks ())) - ;; compute props and subblocks + (blocks ())) + ;; compute props and blocks (flet ((add-prop (prop) (when prop - (let ((prop (nreverse prop))) - (dolist (prop (compile-property (car prop) (cdr prop))) - (push prop props)))))) - (loop with prop = () - for field in fields - do (etypecase field - (keyword - (add-prop prop) - (setf prop (list field))) - (list - (dolist (subblock (compile-block (list selector (car field)) (cdr field))) - (push subblock subblocks))) - (T (push field prop))) - finally (add-prop prop))) + (dolist (prop (compile-property (car prop) (cdr prop))) + (push prop props)))) + (add-block (block) + (when block + (dolist (block (compile-block (list selector (car block)) (cdr block))) + (push block blocks))))) + (loop until (empty-p readable) + for (prop block) = (multiple-value-list (consume-item (consume readable) readable)) + do (add-prop prop) + (add-block block))) ;; Returns list of blocks with ours consed to front (cons (make-block selector (nreverse props)) - (nreverse subblocks))))) + (nreverse blocks))))) (defun compile-sheet (&rest blocks) "Compiles a LASS sheet composed of BLOCKS. diff --git a/lass.asd b/lass.asd index c469fde..a3d387d 100644 --- a/lass.asd +++ b/lass.asd @@ -10,7 +10,7 @@ (defsystem lass :name "LASS" - :version "0.2.0" + :version "0.3.0" :license "Artistic" :author "Nicolas Hafner " :maintainer "Nicolas Hafner " @@ -18,7 +18,9 @@ :homepage "https://github.com/Shinmera/LASS" :serial T :components ((:file "package") + (:file "readable-list") (:file "compiler") + (:file "property-funcs") (:file "writer") (:file "lass") (:file "special")) diff --git a/property-funcs.lisp b/property-funcs.lisp new file mode 100644 index 0000000..0b204ec --- /dev/null +++ b/property-funcs.lisp @@ -0,0 +1,54 @@ +#| + This file is a part of LASS + (c) 2014 Shirakumo http://tymoon.eu (shinmera@tymoon.eu) + Author: Nicolas Hafner +|# + +(in-package #:org.tymoonnext.lass) + +(defvar *property-functions* (make-hash-table :test 'equalp)) + +(defun property-function (name) + (gethash (string name) *property-functions*)) + +(defun (setf property-function) (function name) + (setf (gethash (string name) *property-functions*) + function)) + +(defmacro define-property-function (name args &body body) + `(setf (property-function ,(string name)) + #'(lambda ,args ,@body))) + +(defmacro define-simple-property-function (name args) + `(define-property-function ,name ,args + (format NIL ,(format NIL "~(~a~)(~{~*~~a~^,~})" name args) + ,@(loop for arg in args collect `(resolve ,arg))))) + +(defun resolve-function (function &rest args) + (let ((resolver (property-function function))) + (if resolver + (apply resolver args) + (format NIL "~(~a~)(~{~a~^,~})" function args)))) + +(defmethod resolve ((thing list)) + (apply #'resolve-function (car thing) (cdr thing))) + +;; We redefine the method here in order to delegate to property functions +;; if they do actually exist. +(defmethod consume-item ((property symbol) readable-list) + (if (keywordp property) + (values + (let ((propvals ())) + (loop for (next fullp) = (multiple-value-list (peek readable-list)) + while fullp + do (etypecase next + (keyword (return)) + (list + (let ((resolver (property-function (car next)))) + (if resolver + (push (consume readable-list) propvals) + (return)))) + (T (push (consume readable-list) propvals)))) + (cons property (nreverse propvals))) + NIL) + (call-next-method))) diff --git a/readable-list.lisp b/readable-list.lisp new file mode 100644 index 0000000..b6be5b8 --- /dev/null +++ b/readable-list.lisp @@ -0,0 +1,37 @@ +#| + This file is a part of LASS + (c) 2014 Shirakumo http://tymoon.eu (shinmera@tymoon.eu) + Author: Nicolas Hafner +|# + +(in-package #:org.tymoonnext.lass) + +(defclass readable-list () + ((inner :initarg :list :initform () :accessor inner))) + +(defun make-readable-list (&optional list) + (make-instance 'readable-list :list list)) + +(defmacro with-empty-check ((lis) &body body) + `(if (null (inner ,lis)) + (values NIL NIL) + (values (progn ,@body) T))) + +(defun empty-p (readable-list) + (null (inner readable-list))) + +(defun consume (readable-list) + (with-empty-check (readable-list) + (pop (inner readable-list)))) + +(defun peek (readable-list) + (with-empty-check (readable-list) + (first (inner readable-list)))) + +(defun advance (readable-list) + (with-empty-check (readable-list) + (setf (inner readable-list) + (cdr (inner readable-list))))) + +(defun pushback (item readable-list) + (push item (inner readable-list))) diff --git a/special.lisp b/special.lisp index c4f3ec2..6457c30 100644 --- a/special.lisp +++ b/special.lisp @@ -6,6 +6,19 @@ (in-package #:org.tymoonnext.lass) +;;; FUNCS +(macrolet ((define-properties (&rest rest) + `(progn + ,@(loop for (name args) on rest by #'cddr + collect `(define-simple-property-function ,name ,args))))) + (define-properties + url (url) + rgb (red green blue) + rgba (red green blue alpha) + hsv (hue saturation value) + hsva (hue saturation value alpha))) +(define-property-function hex (hex) (format NIL "#~a" hex)) + ;;; BLOCKS (define-special-block charset (charset)