Basic support for special reading behaviour on a property-basis. Added property functions and some basic default cases.
This commit is contained in:
parent
0a26d30452
commit
d6908c8732
|
@ -23,12 +23,13 @@ See the definition of the LET block.")
|
||||||
(:documentation "Resolves THING to a value that makes sense for LASS.
|
(:documentation "Resolves THING to a value that makes sense for LASS.
|
||||||
|
|
||||||
By default the following types are handled:
|
By default the following types are handled:
|
||||||
NULL: NIL
|
NULL: NIL
|
||||||
STRING: the THING itself
|
STRING: the THING itself
|
||||||
ARRAY: the variable stored in *VARS* under THING
|
ARRAY: the variable stored in *VARS* under THING
|
||||||
KEYWORD: Colon-prefixed, downcased symbol-name of THING
|
KEYWORD: Colon-prefixed, downcased symbol-name of THING
|
||||||
SYMBOL: Downcased symbol-name of THING
|
SYMBOL: Downcased symbol-name of THING
|
||||||
T: PRINC-TO-STRING of THING")
|
PATHNAME: If designating an image, base64 encoded inline image data.
|
||||||
|
T: PRINC-TO-STRING of THING")
|
||||||
(:method ((thing null))
|
(:method ((thing null))
|
||||||
NIL)
|
NIL)
|
||||||
(:method ((thing string))
|
(:method ((thing string))
|
||||||
|
@ -164,6 +165,27 @@ Returns a list with the RESOLVEd SELECTOR.")
|
||||||
(:method ((selector T))
|
(:method ((selector T))
|
||||||
(list (resolve selector))))
|
(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)
|
(defgeneric compile-block (header fields)
|
||||||
(:documentation "Compiles the block with given HEADER and FIELDS list.
|
(:documentation "Compiles the block with given HEADER and FIELDS list.
|
||||||
By default, the following case is handled:
|
By default, the following case is handled:
|
||||||
|
@ -186,28 +208,25 @@ Special handling of blocks may occur.
|
||||||
See DEFINE-SPECIAL-BLOCK.")
|
See DEFINE-SPECIAL-BLOCK.")
|
||||||
(:method (selector fields)
|
(:method (selector fields)
|
||||||
(let ((selector (compile-selector selector))
|
(let ((selector (compile-selector selector))
|
||||||
|
(readable (make-readable-list fields))
|
||||||
(props ())
|
(props ())
|
||||||
(subblocks ()))
|
(blocks ()))
|
||||||
;; compute props and subblocks
|
;; compute props and blocks
|
||||||
(flet ((add-prop (prop)
|
(flet ((add-prop (prop)
|
||||||
(when prop
|
(when prop
|
||||||
(let ((prop (nreverse prop)))
|
(dolist (prop (compile-property (car prop) (cdr prop)))
|
||||||
(dolist (prop (compile-property (car prop) (cdr prop)))
|
(push prop props))))
|
||||||
(push prop props))))))
|
(add-block (block)
|
||||||
(loop with prop = ()
|
(when block
|
||||||
for field in fields
|
(dolist (block (compile-block (list selector (car block)) (cdr block)))
|
||||||
do (etypecase field
|
(push block blocks)))))
|
||||||
(keyword
|
(loop until (empty-p readable)
|
||||||
(add-prop prop)
|
for (prop block) = (multiple-value-list (consume-item (consume readable) readable))
|
||||||
(setf prop (list field)))
|
do (add-prop prop)
|
||||||
(list
|
(add-block block)))
|
||||||
(dolist (subblock (compile-block (list selector (car field)) (cdr field)))
|
|
||||||
(push subblock subblocks)))
|
|
||||||
(T (push field prop)))
|
|
||||||
finally (add-prop prop)))
|
|
||||||
;; Returns list of blocks with ours consed to front
|
;; Returns list of blocks with ours consed to front
|
||||||
(cons (make-block selector (nreverse props))
|
(cons (make-block selector (nreverse props))
|
||||||
(nreverse subblocks)))))
|
(nreverse blocks)))))
|
||||||
|
|
||||||
(defun compile-sheet (&rest blocks)
|
(defun compile-sheet (&rest blocks)
|
||||||
"Compiles a LASS sheet composed of BLOCKS.
|
"Compiles a LASS sheet composed of BLOCKS.
|
||||||
|
|
4
lass.asd
4
lass.asd
|
@ -10,7 +10,7 @@
|
||||||
|
|
||||||
(defsystem lass
|
(defsystem lass
|
||||||
:name "LASS"
|
:name "LASS"
|
||||||
:version "0.2.0"
|
:version "0.3.0"
|
||||||
:license "Artistic"
|
:license "Artistic"
|
||||||
:author "Nicolas Hafner <shinmera@tymoon.eu>"
|
:author "Nicolas Hafner <shinmera@tymoon.eu>"
|
||||||
:maintainer "Nicolas Hafner <shinmera@tymoon.eu>"
|
:maintainer "Nicolas Hafner <shinmera@tymoon.eu>"
|
||||||
|
@ -18,7 +18,9 @@
|
||||||
:homepage "https://github.com/Shinmera/LASS"
|
:homepage "https://github.com/Shinmera/LASS"
|
||||||
:serial T
|
:serial T
|
||||||
:components ((:file "package")
|
:components ((:file "package")
|
||||||
|
(:file "readable-list")
|
||||||
(:file "compiler")
|
(:file "compiler")
|
||||||
|
(:file "property-funcs")
|
||||||
(:file "writer")
|
(:file "writer")
|
||||||
(:file "lass")
|
(:file "lass")
|
||||||
(:file "special"))
|
(:file "special"))
|
||||||
|
|
|
@ -0,0 +1,54 @@
|
||||||
|
#|
|
||||||
|
This file is a part of LASS
|
||||||
|
(c) 2014 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
|
||||||
|
Author: Nicolas Hafner <shinmera@tymoon.eu>
|
||||||
|
|#
|
||||||
|
|
||||||
|
(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)))
|
|
@ -0,0 +1,37 @@
|
||||||
|
#|
|
||||||
|
This file is a part of LASS
|
||||||
|
(c) 2014 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
|
||||||
|
Author: Nicolas Hafner <shinmera@tymoon.eu>
|
||||||
|
|#
|
||||||
|
|
||||||
|
(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)))
|
13
special.lisp
13
special.lisp
|
@ -6,6 +6,19 @@
|
||||||
|
|
||||||
(in-package #:org.tymoonnext.lass)
|
(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
|
;;; BLOCKS
|
||||||
|
|
||||||
(define-special-block charset (charset)
|
(define-special-block charset (charset)
|
||||||
|
|
Loading…
Reference in New Issue