├── src ├── ucw │ ├── lol-tags-test.lisp │ ├── lol-components.lisp │ ├── packages.lisp │ ├── standard-components.lisp │ ├── contextl-components.lisp │ ├── ucw-test.lisp │ ├── html-description.lisp │ └── lol-tags.lisp ├── mao │ ├── description-protocol.lisp │ ├── display │ │ ├── display-attribute.lisp │ │ ├── display-description.lisp │ │ └── define-description-compat.lisp │ ├── mao-tests.lisp │ ├── attribute.lisp │ ├── description.lisp │ ├── simple-plist-attribute.lisp │ └── description-class.lisp ├── packages-test.lisp ├── standard-descriptions │ ├── null.lisp │ ├── symbol.lisp │ ├── edit-test.lisp │ ├── inline.lisp │ ├── list.lisp │ ├── validate.lisp │ ├── edit.lisp │ ├── t.lisp │ └── clos.lisp ├── display-test.lisp ├── packages.lisp ├── utilities.lisp ├── contextl-hacks.lisp ├── attribute-test.lisp ├── display.lisp ├── description-test.lisp ├── description.lisp ├── rofl-test.lisp ├── description-class.lisp ├── attribute.lisp └── rofl.lisp ├── lisp-on-lines-ucw.asd ├── tests └── bug │ └── 0.lisp ├── lisp-on-lines.asd └── doc ├── tutorial.txt ├── manual.org └── manual.html /src/ucw/lol-tags-test.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lol-test) 2 | 3 | 4 | -------------------------------------------------------------------------------- /src/mao/description-protocol.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lisp-on-lines) 2 | 3 | -------------------------------------------------------------------------------- /src/packages-test.lisp: -------------------------------------------------------------------------------- 1 | 2 | (cl:defpackage #:lol-test 3 | (:use #:cl #:lisp-on-lines #:lisp-on-lines-ucw #:stefil #:contextl)) -------------------------------------------------------------------------------- /src/standard-descriptions/null.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lisp-on-lines) 2 | 3 | (define-description null (symbol list) 4 | ()) 5 | 6 | (define-layered-method description-of ((object null)) 7 | (find-description 'null)) 8 | -------------------------------------------------------------------------------- /src/ucw/lol-components.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lol-ucw) 2 | 3 | ;;; Not sure what the intent of this is, unused in maxclaims --clinton 4 | 5 | (defclass lol-component () 6 | () 7 | (:metaclass standard-component-class)) 8 | 9 | (defmethod output-component ((self lol-component)) 10 | self) 11 | 12 | (defmethod render ((self lol-component)) 13 | (display (output-component self) self)) 14 | 15 | 16 | 17 | 18 | -------------------------------------------------------------------------------- /src/display-test.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lol-test) 2 | 3 | (in-suite lisp-on-lines) 4 | 5 | (deftest (test-define-display :compile-before-run t) () 6 | 7 | (define-description test-display ()) 8 | 9 | (define-display ((description test-display)) 10 | t "BRILLANT!") 11 | 12 | #+nil(is (equalp "BRILLANT!" (display-using-description 13 | (find-description 'test-display) 14 | nil :foo)))) 15 | 16 | (deftest test-symbol-display () 17 | (is (stringp (display nil nil)))) 18 | 19 | 20 | -------------------------------------------------------------------------------- /src/ucw/packages.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defpackage lisp-on-lines-ucw 3 | (:documentation "An LoL Layer over ucw.basic") 4 | (:nicknames #:lol-ucw) 5 | (:use #:lisp-on-lines #:ucw :ucw-core :common-lisp :arnesi :contextl) 6 | (:shadowing-import-from :js 7 | #:new) 8 | (:shadowing-import-from :ucw-core 9 | #:parent) 10 | (:import-from :ucw-standard 11 | #:call #:answer #:defaction #:*source-component*) 12 | (:export #:dlambda 13 | #:described-component-class 14 | #:lisp-on-lines-application 15 | #:lisp-on-lines-component 16 | #:lisp-on-lines-component-class 17 | #:lol-component)) -------------------------------------------------------------------------------- /src/standard-descriptions/symbol.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lisp-on-lines) 2 | 3 | (define-layered-method description-of ((symbol symbol)) 4 | (find-description 'symbol)) 5 | 6 | (define-description symbol () 7 | ((identity :label nil) 8 | (name 9 | :function #'symbol-name 10 | :label "Name") 11 | (value 12 | :label "Value" 13 | :function 14 | (lambda (symbol) 15 | (if (boundp symbol) 16 | (symbol-value symbol) 17 | ""))) 18 | (package :function #'symbol-package 19 | :label "Package") 20 | (function :label "Function" 21 | :function 22 | (lambda (symbol) 23 | (if (fboundp symbol) 24 | (symbol-function symbol) 25 | ""))))) -------------------------------------------------------------------------------- /src/standard-descriptions/edit-test.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lol-test) 2 | 3 | (deftest test-edit-simple () 4 | (eval `(defclass edit-test () 5 | (string number) 6 | (:metaclass described-standard-class))) 7 | (eval `(define-description edit-test (description-for-edit-test) 8 | ((string :input (:type string)) 9 | (number :input (:type number))))) 10 | 11 | #+nil(is (string= (display nil (make-instance 'lol-test::edit-test)) 12 | "String # 13 | Number #")) 14 | 15 | #+nil(progn (let ((i (make-instance 'lol-test::edit-test))) 16 | (with-input-from-string (*standard-input* 17 | "drew 18 | 1 19 | ") 20 | (with-active-descriptions (editable) 21 | (display t i)) 22 | (is (equal (display nil i) 23 | "String drew 24 | Number 1")))))) -------------------------------------------------------------------------------- /lisp-on-lines-ucw.asd: -------------------------------------------------------------------------------- 1 | (eval-when (:compile-toplevel :load-toplevel :execute) 2 | (unless (find-package :coop.tech.systems) 3 | (defpackage :coop.tech.systems 4 | (:documentation "ASDF System package for meta-model.") 5 | (:use :common-lisp :asdf)))) 6 | 7 | (in-package :coop.tech.systems) 8 | 9 | (defsystem :lisp-on-lines-ucw 10 | :components ((:module :src 11 | :components 12 | ((:module :ucw 13 | :components ((:file "packages") 14 | 15 | (:file "standard-components") 16 | (:file "contextl-components") 17 | (:file "html-description") 18 | (:file "lol-components") 19 | ) 20 | 21 | :serial t)))) 22 | :serial t 23 | 24 | 25 | :depends-on (:lisp-on-lines :ucw :puri :parenscript-classic)) -------------------------------------------------------------------------------- /tests/bug/0.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lol-test) 2 | (in-suite lisp-on-lines) 3 | 4 | ;; Bug 0: 5 | 6 | ;; Redefining a superclass causes subclasses to remain uninitialized, 7 | ;; which would break DISPLAY-USING-DESCRIPTION 8 | 9 | (deftest bug-0 () 10 | 11 | (eval '(progn 12 | 13 | (define-description bug-0-test-superclass () 14 | ((bug-0-attribute :label "bug" :value 0))) 15 | 16 | (define-description bug-0-test-subclass (bug-0-test-superclass) 17 | ((bug-0-attribute-2 :label "subclass" :value 2))) 18 | 19 | (is (lol::display-using-description (find-description 'bug-0-test-subclass) nil nil)) 20 | 21 | (define-description bug-0-test-superclass () 22 | ((bug-0-attribute :label "bug" :value 0))) 23 | ;;; Breaks because redefinition of superclass occurred 24 | (is (lol::display-using-description (find-description 'bug-0-test-subclass) nil nil))))) -------------------------------------------------------------------------------- /src/standard-descriptions/inline.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lisp-on-lines) 2 | 3 | (define-description inline ()) 4 | 5 | (define-description t () 6 | ((identity :label nil) 7 | (active-attributes :value '(identity)) 8 | (attribute-delimiter :value ", ") 9 | (label-formatter :value (curry #'format nil "~A: ")) 10 | (value-formatter :value (curry #'format nil "~A"))) 11 | (:in-description inline)) 12 | 13 | (define-layered-class standard-attribute 14 | :in-layer #.(defining-description 'inline) 15 | () 16 | ()) 17 | 18 | (defun display-inline (object &rest args) 19 | (with-active-descriptions (inline) 20 | (apply #'display *display* object args))) 21 | 22 | (defun display-inline-attribute (attribute value) 23 | (if (ignore-errors (lol::attribute-active-attributes attribute)) 24 | (handler-case (display-inline value :attributes (lol::attribute-active-attributes attribute)) 25 | (error () 26 | (display-inline value))) 27 | (display-inline value))) 28 | 29 | 30 | 31 | -------------------------------------------------------------------------------- /src/mao/display/display-attribute.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lisp-on-lines) 2 | 3 | (define-layered-class display-attribute (standard-attribute) 4 | ((label 5 | :layered-accessor attribute-label 6 | :initarg :label 7 | :initform nil 8 | :layered t 9 | :special t) 10 | (label-formatter 11 | :layered-accessor attribute-label-formatter 12 | :initarg :label-formatter 13 | :initform nil 14 | :layered t 15 | :special t) 16 | (value-formatter 17 | :layered-accessor attribute-value-formatter 18 | :initarg :value-formatter 19 | :initform nil 20 | :layered t 21 | :special t) 22 | 23 | )) 24 | 25 | (define-layered-method attribute-label-formatter :around (attribute) 26 | (or (slot-value attribute 'label-formatter) 27 | (attribute-value (find-attribute (attribute-description attribute) 'label-formatter)) 28 | (error "No Formatter .. fool!"))) 29 | 30 | (define-layered-method attribute-value-formatter :around (attribute) 31 | 32 | (or (slot-value attribute 'value-formatter) 33 | (attribute-value (find-attribute (attribute-description attribute) 'value-formatter)) 34 | (error "No Formatter .. fool!"))) -------------------------------------------------------------------------------- /src/standard-descriptions/list.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lisp-on-lines) 2 | 3 | 4 | (define-layered-class list-attribute (define-description-attribute) 5 | ((item-args :initform nil :initarg :item :layered t :special t))) 6 | 7 | (define-layered-method display-attribute-value 8 | ((attribute list-attribute)) 9 | (generic-format *display* "(") 10 | (let ((list (attribute-value attribute))) 11 | 12 | (loop 13 | :for cons :on list 14 | :do (let ((item (first cons 15 | ))) 16 | (dletf (((attribute-object attribute) item)) 17 | (apply #'display *display* item (slot-value attribute 'item-args)) 18 | (unless (endp (cdr cons)) 19 | (generic-format *display* " ")))))) 20 | (generic-format *display* ")")) 21 | 22 | 23 | 24 | 25 | 26 | 27 | (define-description list () 28 | ((list :attribute-class list-attribute 29 | :function #'identity 30 | :attributes nil))) 31 | 32 | (define-description cons (list) 33 | ((car :label "First" :function #'car) 34 | (cdr :label "Rest" :function #'cdr) 35 | )) 36 | 37 | (define-description cons () 38 | ((editp :value t :editp nil) 39 | (car :setter #'rplaca) 40 | (cdr :setter #'rplacd)) 41 | (:in-description editable)) 42 | 43 | (define-description cons () 44 | ((active-attributes :value '(list))) 45 | (:in-description inline)) 46 | 47 | (define-layered-method description-of ((c cons)) 48 | (find-description 'cons)) 49 | 50 | 51 | 52 | 53 | 54 | 55 | -------------------------------------------------------------------------------- /src/mao/mao-tests.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lol-test) 2 | 3 | (defsuite :mao) 4 | (in-suite :mao) 5 | 6 | (defdescription test-empty-description ()) 7 | 8 | (defdescription property-speed-test () 9 | ((attribute :value t))) 10 | 11 | (defdescription property-speed-test () 12 | ((attribute :value t)) 13 | (:in-description test-empty-description)) 14 | 15 | (defdescription property-speed-test-many-attributes () 16 | ((attribute :value t) 17 | (attribute2 :value t) 18 | (attribute3 :value t) 19 | (attribute4 :value t) 20 | (attribute5 :value t) 21 | (attribute6 :value t) 22 | (attribute7 :value t) 23 | (attribute8 :value t) 24 | (attribute9 :value t) 25 | (attributea :value t) 26 | (attributeb :value t) 27 | (attributec :value t) 28 | (attributed :value t) 29 | (attributee :value t) 30 | (attributef :value t) 31 | (attributeg :value t) 32 | (attributeh :value t) 33 | (attributei :value t) 34 | (attributej :value t) 35 | (attributek :value t) 36 | (attributel :value t) 37 | (attributem :value t) 38 | (attributen :value t) 39 | (attributeo :value t) 40 | ) 41 | ) 42 | 43 | 44 | 45 | 46 | (defun attribute-property-speed-test (n &optional (description 'property-speed-test) (attribute 'attribute)) 47 | (with-described-object (nil (find-description description)) 48 | (let ((attribute (find-attribute (current-description) 'attributeo))) 49 | 50 | (loop repeat n do (attribute-value attribute))))) 51 | 52 | -------------------------------------------------------------------------------- /src/packages.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:lisp-on-lines 2 | (:use 3 | #:contextl 4 | #:closer-common-lisp 5 | 6 | #:alexandria) 7 | (:nicknames #:lol) 8 | (:export 9 | 10 | 11 | ;; Descriptions 12 | #:*description* 13 | #:description 14 | #:defdescription 15 | #:find-description 16 | #:current-description 17 | #:description-of 18 | #:define-description 19 | #:defining-description 20 | #:described-object 21 | #:with-described-object 22 | #:funcall-with-described-object 23 | #:described-class 24 | #:described-standard-class 25 | #:with-active-descriptions 26 | #:with-inactive-descriptions 27 | 28 | 29 | ;; Displays 30 | #:define-display 31 | #:display 32 | #:display-using-description 33 | #:display-attribute-label 34 | #:*display* 35 | #:*object* 36 | 37 | ;; Attributes 38 | #:find-attribute 39 | #:attribute 40 | #:attributes 41 | #:attribute-object 42 | #:attribute-label 43 | #:attribute-delimiter 44 | #:attribute-setter 45 | #:attribute-slot-name 46 | #:label 47 | #:attribute-active-p 48 | #:attribute-function 49 | #:attribute-value 50 | #:display-attribute-value 51 | #:active-attributes 52 | #:attribute-delimiter 53 | #:standard-attribute 54 | #:funcall-with-attribute-context 55 | #:with-attribute-context 56 | 57 | ;; Standard Library 58 | 59 | ;; editing 60 | #:editable 61 | #:attribute-editor 62 | #:string-attribute-editor 63 | #:number-attribute-editor 64 | #:password-attribute-editor 65 | #:password 66 | 67 | ;; :validation 68 | #:validation 69 | #:validate 70 | #:validp 71 | 72 | ;; CLOS 73 | #:slot-definition-attribute 74 | 75 | ;; html 76 | #:display-html-attribute-editor 77 | #:make-attribute-value-writer)) 78 | 79 | 80 | -------------------------------------------------------------------------------- /src/mao/display/display-description.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lisp-on-lines) 2 | 3 | (defclass display-description-class (standard-description-class) 4 | ()) 5 | 6 | (defmethod description-class-attribute-class ((class display-description-class)) 7 | 'display-attribute) 8 | 9 | (defun label-for-object (object) 10 | (format nil "~@(~A~)" 11 | (substitute #\Space #\- 12 | (symbol-name 13 | (class-name (class-of 14 | object)))))) 15 | #+nil(defdescription t () 16 | ((label :label nil 17 | :function label-for-object) 18 | (identity :label nil :function identity) 19 | (type :label "Type" :function type-of) 20 | (class :label "Class" :function class-of) 21 | (attribute-delimiter :label "Attribute Delimiter" 22 | :value "~%" 23 | :activep nil 24 | :keyword :delimter) 25 | 26 | (label-formatter :value princ-to-string 27 | :activep nil) 28 | (value-formatter :value princ-to-string 29 | :activep nil)) 30 | (:metaclass standard-description-class)) 31 | 32 | #+nil(defmethod initialize-instance :around ((class display-description-class) &rest initargs &key (direct-superclasses '())) 33 | (declare (dynamic-extent initargs)) 34 | (prog1 35 | (if (loop for direct-superclass in direct-superclasses 36 | thereis (ignore-errors (subtypep direct-superclass (class-of (find-description t))))) 37 | (call-next-method) 38 | (apply #'call-next-method 39 | class 40 | :direct-superclasses 41 | (append direct-superclasses 42 | (list (class-of (find-description 't)))) 43 | initargs)))) 44 | 45 | 46 | #+nil(defmethod reinitialize-instance :around ((class display-description-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p)) 47 | (declare (dynamic-extent initargs)) 48 | ; (warn "CLASS ~A ARGS ~A:" class initargs) 49 | (prog1 50 | (if (or (not direct-superclasses-p) 51 | (loop for direct-superclass in direct-superclasses 52 | thereis (ignore-errors (subtypep direct-superclass (class-of (find-description t)))))) 53 | (call-next-method) 54 | (apply #'call-next-method 55 | class 56 | :direct-superclasses 57 | (append direct-superclasses 58 | (list (class-of (find-description 't)))) 59 | initargs)))) -------------------------------------------------------------------------------- /src/mao/display/define-description-compat.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lol) 2 | 3 | (defclass define-description-class (display-description-class) 4 | ()) 5 | 6 | (define-layered-class define-description-attribute (display-attribute) ()) 7 | 8 | (define-layered-method attribute-function ((attribute define-description-attribute)) 9 | (call-next-method) 10 | ) 11 | 12 | (defgeneric eval-property-initarg (att initarg) 13 | (:method ((attribute standard-attribute) initarg) 14 | nil) 15 | (:method ((attribute standard-attribute) (initarg (eql :function))) 16 | t) 17 | (:method ((attribute standard-attribute) (initarg (eql :value))) 18 | t)) 19 | 20 | (defun prepare-initargs (att args) 21 | (loop 22 | :for (key arg) 23 | :on args :by #'cddr 24 | :nconc (list key 25 | (if (eval-property-initarg att key) 26 | (eval arg) 27 | arg)))) 28 | 29 | (defmethod initialize-attribute-for-description :around (description (attribute define-description-attribute) layer &rest args) 30 | (apply #'call-next-method description attribute layer (prepare-initargs attribute args))) 31 | 32 | (defmethod description-class-attribute-class ((class display-description-class)) 33 | 'define-description-attribute) 34 | 35 | (defmacro define-description (name &optional superdescriptions &body options) 36 | (destructuring-bind (&optional slots &rest options) options 37 | `(let ((%dn ',name)) 38 | (declare (special %dn)) 39 | (defdescription ,name ,superdescriptions 40 | ,(if slots slots '()) 41 | ,@options 42 | ,@(unless (assoc :metaclass options) 43 | '((:metaclass define-description-class))))))) 44 | 45 | (defmethod initialize-instance :around ((class display-description-class) &rest initargs &key (direct-superclasses '())) 46 | (declare (dynamic-extent initargs) 47 | (special %dn)) 48 | (prog1 49 | (if (or (and (boundp '%dn) (eql %dn t)) 50 | (loop for direct-superclass in direct-superclasses 51 | thereis (ignore-errors (subtypep direct-superclass (class-of (find-description t)))))) 52 | (call-next-method) 53 | (apply #'call-next-method 54 | class 55 | :direct-superclasses 56 | (append direct-superclasses 57 | (list (class-of (find-description 't)))) 58 | initargs)))) 59 | 60 | 61 | (defmethod reinitialize-instance :around ((class display-description-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p)) 62 | (declare (dynamic-extent initargs) 63 | (special %dn)) 64 | ; (warn "CLASS ~A ARGS ~A:" class initargs) 65 | (prog1 66 | (if (or (not direct-superclasses-p) 67 | (and (boundp '%dn) (eql %dn t)) 68 | (loop for direct-superclass in direct-superclasses 69 | thereis (ignore-errors (subtypep direct-superclass (class-of (find-description t)))))) 70 | (call-next-method) 71 | (apply #'call-next-method 72 | class 73 | :direct-superclasses 74 | (append direct-superclasses 75 | (list (class-of (find-description 't)))) 76 | initargs)))) 77 | -------------------------------------------------------------------------------- /src/utilities.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lisp-on-lines) 2 | 3 | (defgeneric generic-format (stream string &rest args) 4 | (:method (stream string &rest args) 5 | (apply #'format stream string args))) 6 | 7 | 8 | 9 | 10 | (defun make-enclosing-package (name) 11 | (make-package name :use '())) 12 | 13 | (defgeneric enclose-symbol (symbol package) 14 | (:method ((symbol symbol) 15 | (package package)) 16 | (if (symbol-package symbol) 17 | (intern (format nil "~A::~A" 18 | (package-name (symbol-package symbol)) 19 | (symbol-name symbol)) 20 | package) 21 | (or (get symbol package) 22 | (setf (get symbol package) (gensym)))))) 23 | 24 | (defmacro with-active-descriptions (descriptions &body body) 25 | `(with-active-layers ,(mapcar #'defining-description descriptions) 26 | 27 | ,@body)) 28 | 29 | (defmacro with-inactive-descriptions (descriptions &body body) 30 | `(with-inactive-layers ,(mapcar #'defining-description descriptions) 31 | 32 | ,@body)) 33 | 34 | #| 35 | Descriptoons are represented as ContextL classes and layers. To avoid nameclashes with other classes or layers, the name of a description is actually mappend to an internal unambiguous name which is used instead of the regular name. 36 | |# 37 | 38 | 39 | (defvar *description-definers* 40 | (make-enclosing-package "DESCRIPTION-DEFINERS")) 41 | 42 | (defun defining-description (name) 43 | "Takes the name of a description and returns its internal name." 44 | (case name 45 | ((nil) (error "NIL is not a valid description name.")) 46 | (otherwise (enclose-symbol name *description-definers*)))) 47 | 48 | (defmethod initargs.slots (class) 49 | "Returns ALIST of (initargs) . slot." 50 | (mapcar #'(lambda (slot) 51 | (cons (closer-mop:slot-definition-initargs slot) 52 | slot)) 53 | (closer-mop:class-slots class))) 54 | 55 | (defun find-slot-using-initarg (class initarg) 56 | (cdr (assoc-if #'(lambda (x) (member initarg x)) 57 | (initargs.slots class)))) 58 | 59 | (defun ensure-class-finalized (class) 60 | (unless (class-finalized-p class) 61 | (finalize-inheritance class))) 62 | 63 | (defun superclasses (class) 64 | (ensure-class-finalized class) 65 | (rest (class-precedence-list class))) 66 | 67 | 68 | 69 | ;;;!-- TODO: this has been so mangled that, while working, it's ooogly! 70 | ;;;!-- do we still use this? 71 | 72 | (defun initargs-plist->special-slot-bindings (class initargs-plist) 73 | "returns a list of (slot-name value) Given a plist of initargs such as one would pass to :DEFAULT-INITARGS." 74 | (let ((initargs.slot-names-alist (initargs.slot-names class))) 75 | (loop for (initarg value) on initargs-plist 76 | nconc (let ((slot-name 77 | )) 78 | (when slot-name ;ignore invalid initargs. (good idea/bad idea?) 79 | (list slot-name value)))))) 80 | 81 | (defun dprint (format-string &rest args) 82 | (apply #'format t (concatenate 'string format-string "~%") args)) 83 | 84 | 85 | 86 | 87 | -------------------------------------------------------------------------------- /lisp-on-lines.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- lisp -*- 2 | 3 | (eval-when (:compile-toplevel :load-toplevel :execute) 4 | (unless (find-package :coop.tech.systems) 5 | (defpackage :coop.tech.systems 6 | (:documentation "ASDF System package for Lisp On Lines") 7 | (:use :common-lisp :asdf)))) 8 | 9 | (in-package :coop.tech.systems) 10 | 11 | (defsystem :lisp-on-lines 12 | :license 13 | "Copyright (c) 2004-2007 Drew Crampsie 14 | 15 | Contains portions of ContextL: 16 | Copyright (c) 2005 - 2007 Pascal Costanza 17 | 18 | Permission is hereby granted, free of charge, to any person 19 | obtaining a copy of this software and associated documentation 20 | files (the \"Software\"), to deal in the Software without 21 | restriction, including without limitation the rights to use, 22 | copy, modify, merge, publish, distribute, sublicense, and/or 23 | sell copies of the Software, and to permit persons to whom the 24 | Software is furnished to do so, subject to the following 25 | conditions: 26 | 27 | The above copyright notice and this permission notice shall be 28 | included in all copies or substantial portions of the Software. 29 | 30 | THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, 31 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 32 | OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 33 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 34 | HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 35 | WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 36 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 37 | OTHER DEALINGS IN THE SOFTWARE." 38 | :components ((:static-file "lisp-on-lines.asd") 39 | (:module :src 40 | :components ((:file "packages") 41 | (:file "utilities") 42 | (:module :mao 43 | :components ((:file "simple-plist-attribute") 44 | (:file "attribute") 45 | (:file "description-class") 46 | (:file "description") 47 | (:module :display 48 | :components ((:file "display-attribute") 49 | (:file "display-description") 50 | (:file "define-description-compat")) 51 | :serial t)) 52 | :serial t) 53 | (:file "display") 54 | (:module :standard-descriptions 55 | :components ((:file "t") 56 | (:file "inline") 57 | (:file "edit") 58 | (:file "symbol") 59 | (:file "list") 60 | (:file "null") 61 | (:file "clos") 62 | (:file "validate") 63 | ) 64 | 65 | :serial t)) 66 | 67 | :serial t)) 68 | :serial t 69 | :depends-on (:contextl :arnesi :alexandria :parse-number :yaclml :trivial-garbage 70 | )) 71 | 72 | 73 | (defsystem :lisp-on-lines.test 74 | :components ((:module :src 75 | :components ((:file "packages-test") 76 | (:file "description-test") 77 | (:file "attribute-test") 78 | (:file "display-test") 79 | (:module :standard-descriptions 80 | :components ((:file "edit-test")) 81 | :serial t) 82 | (:module :ucw 83 | :components ((:file "ucw-test")) 84 | :serial t)) 85 | :serial t) 86 | (:module :tests 87 | :components ((:module :bug 88 | :components ((:file "0")))))) 89 | :serial t 90 | 91 | 92 | :depends-on (:lisp-on-lines :lisp-on-lines-ucw :stefil)) 93 | 94 | 95 | 96 | -------------------------------------------------------------------------------- /src/standard-descriptions/validate.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lisp-on-lines) 2 | 3 | (define-description validate () 4 | ((invalid-object-condition-map :layered t :special t ))) 5 | 6 | (define-layered-class standard-attribute 7 | :in-layer #.(defining-description 'validate) 8 | () 9 | ((validators 10 | :initform nil 11 | :layered-accessor attribute-validators 12 | :initarg :validate 13 | :layered t 14 | :special t))) 15 | 16 | (define-condition validation-condition () 17 | ((format-string :accessor validation-condition-format-string 18 | :initarg :format-string) 19 | (format-args :accessor validation-condition-format-args 20 | :initarg :format-args) 21 | (object :accessor validation-condition-object 22 | :initarg :object) 23 | (attribute :accessor validation-condition-attribute 24 | :initarg :attribute))) 25 | 26 | (define-layered-method (setf attribute-value) 27 | :in-layer #.(defining-description 'validate) 28 | :around (value attribute) 29 | (prog1 value (when (validate-attribute-value attribute value) 30 | (call-next-method)))) 31 | 32 | (defun validate-attribute-value (attribute value) 33 | (every #'identity (mapcar (lambda (validator-name) 34 | (let ((validator (find-validator validator-name))) 35 | 36 | (if validator 37 | (funcall validator attribute value) 38 | (prog1 t (warn "Unkown Validator ~A" validator-name))))) 39 | (attribute-validators attribute)))) 40 | 41 | 42 | (defstruct validation-info (invalid-objects)) 43 | 44 | (defvar *invalid-objects*) 45 | 46 | (defvar *validators* (make-hash-table)) 47 | 48 | (defun register-validator (name fn) 49 | (setf (gethash name *validators*) fn)) 50 | 51 | (defun find-validator (name) 52 | (gethash name *validators*)) 53 | 54 | (register-validator 'boundp 55 | (lambda (a v) 56 | (if (unbound-slot-value-p v) 57 | (prog1 nil 58 | (signal (make-condition 'validation-condition 59 | :format-string "You must provide a value for ~A" 60 | :format-args (list (attribute-label a)) 61 | :attribute a 62 | :object (attribute-object a)))) 63 | t))) 64 | 65 | 66 | (defun validp (object) 67 | (with-described-object (object nil) 68 | (every #'identity (mapcar (lambda (attribute) 69 | (validate-attribute-value attribute (attribute-value attribute))) 70 | (attributes (description-of object)))))) 71 | 72 | (define-layered-method lol::display-attribute-editor 73 | :in-layer #.(defining-description 'validate) 74 | :after (attribute) 75 | (let ((conditions (remove-if-not 76 | (lambda (a) 77 | (eq a attribute)) 78 | (gethash 79 | (attribute-object attribute) 80 | lol::*invalid-objects*) 81 | :key #'car))) 82 | (setf 83 | conditions 84 | (loop with string for c in conditions 85 | :unless (find (validation-condition-format-string (cdr c)) string 86 | :test #'string-equal) 87 | :collect c 88 | :do (push (validation-condition-format-string (cdr c)) string))) 89 | (dolist (c conditions) 90 | (<:div :style "color:red" 91 | (<:as-html 92 | (apply #'format nil (validation-condition-format-string (cdr c)) 93 | (validation-condition-format-args (cdr c)))))))) 94 | 95 | 96 | 97 | (defmethod validate-object ((description standard-description-object) object) 98 | (let (invalid-object?) 99 | (handler-bind ((validation-condition 100 | (setf invalid-object? t)))))) 101 | 102 | 103 | 104 | -------------------------------------------------------------------------------- /src/contextl-hacks.lisp: -------------------------------------------------------------------------------- 1 | (in-package :contextl) 2 | 3 | 4 | (defmethod contextl:layer-name :around (layer) 5 | (or (call-next-method) layer)) 6 | 7 | ;;; HACK: 8 | ;;; Since i'm not using deflayer, ensure-layer etc, 9 | ;;; There are a few places where contextl gets confused 10 | ;;; trying to locate my description layers. 11 | 12 | ;;; TODO: investigate switching to deflayer! 13 | 14 | (defun contextl::prepare-layer (layer) 15 | (if (symbolp layer) 16 | (if (eq (symbol-package layer) 17 | (find-package :description-definers)) 18 | layer 19 | (contextl::defining-layer layer)) 20 | 21 | layer)) 22 | 23 | (defmethod find-layer-class :around ((layer symbol) &optional errorp environment) 24 | (if (eq (symbol-package layer) 25 | (find-package :description-definers)) 26 | (find-class layer) 27 | (call-next-method))) 28 | 29 | 30 | ;;; HACK: There are classes named NIL (partial classes) in the superclass list. 31 | ;;; These cannot be given the special object superclass when re-initializing 32 | ;;; is it will be in the subclasses superclasses AFTER this class, causing 33 | ;;; a confict. 34 | ;;; Since we don't care about these classes (?) this might work (?) 35 | 36 | (defmethod initialize-instance :around 37 | ((class special-class) &rest initargs 38 | &key direct-superclasses) 39 | (declare (dynamic-extent initargs)) 40 | (if (or 41 | ;; HACK begins 42 | (not (ignore-errors (class-name class))) 43 | ;; ENDHACK 44 | (loop for superclass in direct-superclasses 45 | thereis (ignore-errors (subtypep superclass 'special-object)))) 46 | (call-next-method) 47 | (progn (apply #'call-next-method class 48 | :direct-superclasses 49 | (append direct-superclasses 50 | (list (find-class 'special-object))) 51 | initargs)))) 52 | 53 | (defmethod reinitialize-instance :around 54 | ((class special-class) &rest initargs 55 | &key (direct-superclasses () direct-superclasses-p)) 56 | (declare (dynamic-extent initargs)) 57 | (if direct-superclasses-p 58 | (if (or ; Here comes the hack 59 | (not (class-name class)) 60 | ;endhack 61 | (loop for superclass in direct-superclasses 62 | thereis (ignore-errors (subtypep superclass 'special-object)))) 63 | (call-next-method) 64 | (apply #'call-next-method class 65 | :direct-superclasses 66 | (append direct-superclasses 67 | (list 68 | (find-class 'special-object))) 69 | initargs))) 70 | (call-next-method)) 71 | 72 | 73 | 74 | (defun funcall-with-special-initargs (bindings thunk) 75 | (let ((arg-count 0)) 76 | (special-symbol-progv 77 | (loop for (object . initargs) in bindings 78 | for initarg-keys = (loop for key in initargs by #'cddr 79 | collect key into keys 80 | count t into count 81 | finally (incf arg-count count) 82 | (return keys)) 83 | nconc (loop for slot in (class-slots (class-of object)) 84 | when (and (slot-definition-specialp slot) 85 | (intersection initarg-keys (slot-definition-initargs slot))) 86 | collect (with-symbol-access 87 | (slot-value object (slot-definition-name slot))))) 88 | (make-list arg-count :initial-element nil) 89 | (loop for (object . initargs) in bindings 90 | do (apply #'shared-initialize object nil :allow-other-keys t initargs)) 91 | (funcall thunk)))) -------------------------------------------------------------------------------- /src/mao/attribute.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :lisp-on-lines) 3 | 4 | (define-layered-class attribute () 5 | ()) 6 | 7 | (define-layered-class standard-attribute (simple-plist-attribute) 8 | ((attribute-layers :accessor attribute-layers :initform nil) 9 | (name 10 | :layered-accessor attribute-name 11 | :initarg :name) 12 | (effective-attribute-definition 13 | :initarg effective-attribute 14 | :accessor attribute-effective-attribute-definition) 15 | #+nil (attribute-class 16 | :accessor attribute-class 17 | :initarg :attribute-class 18 | :initform 'standard-attribute) 19 | (keyword 20 | :layered-accessor attribute-keyword 21 | :initarg :keyword 22 | :initform nil 23 | :layered t) 24 | (activep 25 | :layered-accessor attribute-active-p 26 | :initarg :activep ;deprecated 27 | :initarg :active 28 | :initform t 29 | :layered t 30 | :special t 31 | :documentation 32 | "Can be T, NIL or :WHEN. In the latter case, attribute is only active if the attribute value is non-null.") 33 | (value 34 | :layered-accessor attribute-value 35 | :initarg :value 36 | :layered t 37 | :special t) 38 | (function 39 | :initarg :function 40 | :layered-accessor attribute-function 41 | :layered t 42 | :special t) 43 | (active-attributes :layered-accessor attribute-active-attributes 44 | :initarg :attributes 45 | :layered t 46 | :special t) 47 | (active-descriptions :layered-accessor attribute-active-descriptions 48 | :initarg :activate 49 | :initform nil 50 | :layered t 51 | :special t) 52 | (inactive-descriptions :layered-accessor attribute-inactive-descriptions 53 | :initarg :deactivate 54 | :initform nil 55 | :layered t 56 | :special t) 57 | )) 58 | 59 | (defmethod attribute-description ((attribute standard-attribute)) 60 | (find-layer (attribute-description-class attribute))) 61 | 62 | (define-layered-function attribute-object (attribute)) 63 | (define-layered-method attribute-active-p :around (attribute) 64 | (let ((active? (call-next-method))) 65 | (if (eq :when active?) 66 | (not (null (attribute-value attribute))) 67 | active?))) 68 | 69 | 70 | (define-layered-method attribute-object ((attribute standard-attribute)) 71 | (described-object (dynamic description))) 72 | 73 | (define-layered-function attribute-value-using-object (object attribute)) 74 | (define-layered-function (setf attribute-value-using-object) (value object attribute)) 75 | 76 | (define-layered-method attribute-value ((attribute standard-attribute)) 77 | (attribute-value-using-object (attribute-object attribute) attribute)) 78 | 79 | (define-layered-method attribute-value-using-object (object attribute) 80 | (let ((fn (handler-case (attribute-function attribute) 81 | (unbound-slot () nil)))) 82 | (if fn 83 | (funcall fn object) 84 | (slot-value attribute 'value)))) 85 | 86 | (define-layered-method (setf attribute-value) (value (attribute standard-attribute)) 87 | (setf (attribute-value-using-object (attribute-object attribute) attribute) value)) 88 | 89 | (define-layered-method (setf attribute-value-using-object) (value object attribute) 90 | (error "No (SETF ATTRIBUTE-VALUE-USING-OBJECT) for ~A ~A and we are not editable" 91 | object attribute)) 92 | 93 | (defmethod print-object ((object standard-attribute) stream) 94 | (print-unreadable-object (object stream :type nil :identity t) 95 | (format stream "ATTRIBUTE ~A" (or (ignore-errors (attribute-name object)) "+unnamed-attribute+")))) -------------------------------------------------------------------------------- /src/attribute-test.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lol-test) 2 | 3 | (in-suite lisp-on-lines) 4 | 5 | (deftest test-attribute-value () 6 | (eval 7 | '(progn 8 | (define-description attribute-test-description () 9 | ((attribute-1 :value "VALUE") 10 | (attribute-2 :function (constantly "VALUE")))) 11 | 12 | (define-description attribute-test) 13 | 14 | (define-description attribute-test-description () 15 | ((attribute-1 :value "VALUE2") 16 | (attribute-2 :function (constantly "VALUE2"))) 17 | (:in-description attribute-test)))) 18 | 19 | (funcall-with-described-object 20 | (lambda (&aux 21 | (a1 (find-attribute *description* 'attribute-1)) 22 | (a2 (find-attribute *description* 'attribute-2)) 23 | ) 24 | (is (equalp "VALUE" (attribute-value a1))) 25 | (is (equalp "VALUE" (attribute-value a2))) 26 | (with-active-descriptions (attribute-test) 27 | (is (equalp "VALUE2" (attribute-value a1))) 28 | (is (equalp "VALUE2" (attribute-value a2))))) 29 | nil 30 | (find-description 'attribute-test-description))) 31 | 32 | (deftest test-attribute-property-inheriting () 33 | (test-attribute-value) 34 | (eval '(progn 35 | (define-description attribute-property-test) 36 | (define-description attribute-test-description () 37 | ((attribute-1 :label "attribute1") 38 | (attribute-2 :label "attribute2")) 39 | (:in-description attribute-property-test)))) 40 | 41 | (with-active-descriptions (attribute-property-test) 42 | (with-described-object (nil (find-description 'attribute-test-description)) 43 | (let ((d (dynamic description))) 44 | (is (equalp "VALUE" (slot-value (find-attribute d 'attribute-1) 'lol::value))) 45 | 46 | (is (equalp "attribute1" (attribute-label (find-attribute d 'attribute-1)))) 47 | (is (equalp "attribute2" (attribute-label (find-attribute d 'attribute-2)))) 48 | 49 | 50 | (with-active-descriptions (attribute-test) 51 | (is (equalp (attribute-value (find-attribute d 'attribute-1)) 52 | (attribute-value (find-attribute d 'attribute-2)))) 53 | (is (equalp "VALUE2" (attribute-value (find-attribute d 'attribute-1))))))) 54 | )) 55 | 56 | (deftest (test-attribute-with-different-class :compile-before-run t) () 57 | (eval '(progn 58 | (define-layered-class 59 | test-attribute-class (standard-attribute) 60 | ((some-slot :initarg :some-slot 61 | :layered t 62 | :special t 63 | :layered-accessor some-slot))) 64 | 65 | (define-description test-attribute-with-different-class-description () 66 | ((attribute-with-different-class :attribute-class test-attribute-class :some-slot "BRILLANT!"))))) 67 | 68 | (let* ((d (find-description 'test-attribute-with-different-class-description)) 69 | 70 | (a (find-attribute d 'attribute-with-different-class))) 71 | (is (eq (class-of a) 72 | (find-class 'test-attribute-class))) 73 | (is (equalp "BRILLANT!" (some-slot a))))) 74 | 75 | (deftest (test-attribute-with-different-class-and-subclassed-description :compile-before-run t) () 76 | (test-attribute-with-different-class) 77 | (eval '(progn 78 | (define-description test-attribute-with-different-class-description-sub 79 | (test-attribute-with-different-class-description) 80 | ()))) 81 | 82 | (let* ((d (find-description 'test-attribute-with-different-class-description-sub)) 83 | 84 | (a (find-attribute d 'attribute-with-different-class))) 85 | (is (eq (class-of a) 86 | (find-class 'test-attribute-class))) 87 | (is (equalp "BRILLANT!" (some-slot a))))) 88 | 89 | 90 | 91 | 92 | 93 | 94 | -------------------------------------------------------------------------------- /src/ucw/standard-components.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lisp-on-lines-ucw) 2 | 3 | (defclass lisp-on-lines-application (contextl-application) 4 | () 5 | (:default-initargs :action-class 'lisp-on-lines-action)) 6 | 7 | (defclass lisp-on-lines-action (action-with-isolation-support contextl-action ) 8 | () 9 | (:metaclass closer-mop:funcallable-standard-class)) 10 | 11 | (defclass lisp-on-lines-component (contextl-component) 12 | () 13 | (:metaclass standard-component-class)) 14 | 15 | (defclass lisp-on-lines-component-class (standard-component-class) 16 | ()) 17 | 18 | 19 | (defmethod initialize-instance :around ((class lisp-on-lines-component-class) 20 | &rest initargs &key (direct-superclasses '())) 21 | (declare (dynamic-extent initargs)) 22 | (if (loop for direct-superclass in direct-superclasses 23 | thereis (ignore-errors (subtypep direct-superclass 'lisp-on-lines-component))) 24 | (call-next-method) 25 | (apply #'call-next-method 26 | class 27 | :direct-superclasses 28 | (append direct-superclasses 29 | (list (find-class 'lisp-on-lines-component))) 30 | initargs))) 31 | 32 | 33 | (defmethod reinitialize-instance :around ((class lisp-on-lines-component-class) 34 | &rest initargs &key (direct-superclasses '() direct-superclasses-p)) 35 | (declare (dynamic-extent initargs)) 36 | (if (or (not direct-superclasses-p) 37 | (loop for direct-superclass in direct-superclasses 38 | thereis (ignore-errors (subtypep direct-superclass 'lisp-on-lines-component)))) 39 | (call-next-method) 40 | (apply #'call-next-method 41 | class 42 | :direct-superclasses 43 | (append direct-superclasses 44 | (list (find-class 'lisp-on-lines-component))) 45 | initargs))) 46 | 47 | (defmethod ucw-core:handle-action :wrap-around ((action lisp-on-lines-action) application session frame) 48 | (let ((lol::*invalid-objects* (make-hash-table))) 49 | (handler-bind ((lol::validation-condition 50 | (lambda (c) 51 | (let ((object (lol::validation-condition-object c)) 52 | (attribute (lol::validation-condition-attribute c))) 53 | 54 | 55 | (setf (gethash object lol::*invalid-objects*) 56 | (cons (cons attribute c) 57 | (gethash object lol::*invalid-objects*))))))) 58 | (call-next-method)))) 59 | 60 | (defclass described-component-class (described-class standard-component-class) 61 | ()) 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | ;; (defcomponent standard-window-component 75 | ;; (ucw-standard::basic-window-component) 76 | ;; ((body 77 | ;; :initform nil 78 | ;; :accessor window-body 79 | ;; :component t 80 | ;; :initarg :body))) 81 | 82 | ;; (defmethod render-html-head ((window standard-window-component)) 83 | ;; (let* ((app (context.application *context*)) 84 | ;; (url-prefix (application.url-prefix app))) 85 | ;; (<:meta :http-equiv "Content-Type" :content (window-component.content-type window)) 86 | ;; (awhen (window-component.title window) 87 | ;; (<:title (if (functionp it) 88 | ;; (funcall it window) 89 | ;; (<:as-html it)))) 90 | ;; (awhen (window-component.icon window) 91 | ;; (<:link :rel "icon" 92 | ;; :type "image/x-icon" 93 | ;; :href (concatenate 'string url-prefix it))) 94 | ;; (dolist (stylesheet (effective-window-stylesheets window)) 95 | ;; (<:link :rel "stylesheet" 96 | ;; :href stylesheet 97 | ;; :type "text/css")))) 98 | 99 | ;; (defmethod render-html-body ((window standard-window-component)) 100 | ;; (render (window-body window))) 101 | 102 | ;; (defcomponent info-message () 103 | ;; ((message :accessor message :initarg :message))) 104 | 105 | ;; (defmethod render ((m info-message)) 106 | ;; (<:div 107 | ;; :class "info-mssage" 108 | ;; (<:as-html (message m))) 109 | ;; ({#}} 19 | 20 | A description is really just a collection of attributes. Each attribute describes a part of an object, and any number of attributes may or may not be active. The ATTRIBUTES function is used to find a the list attributes that are both active and applicable in the current context. 21 | 22 | \code{ (attributes (find-description t) ) 23 | 24 | \=>{(# 25 | # 26 | #)}} 27 | 28 | When a description is associated with an object, these attributes have properties, for example ATTRIBUTE-LABEL and ATTRIBUTE-VALUE. By simply iterating through the attributes of a described object, we can create a generic display for any lisp object. This is very similar to the technique outlined by (foo) in MEWA: A meta-blah blah. 29 | 30 | MAO adds to MEWA the concept of dynamic context. By changing the context in which an object is described, we combine and specialize the generic displays, ultimately creating different views of our objects. LoL uses ContextL extensively. Descriptions are contextl layers, and attributes themselves are layered classes. Most of the exported functions are layered methods, and the idea of dynamic context-sensitivity is used throughout LoL. If you're not familiar with contextl, don't worry, LoL mostly stands on its own. Still, reading through the material won't hurt. 31 | 32 | The functions DESCRIPTION-ATTRIBUTES, DESCRIPTION-ACTIVE-ATTRIBUTES and DESCRIPTION-CURRENT-ATTRIBUTES return all the descriptions attributes, Attributes that are currently active regardless of context, and attributes that exist in the current context but may or may not be active, respectively. 33 | 34 | To access the properties of an attribute, it is neccessary to create the proper context. For the most part, LoL does this for you, but for demonstration purposes we'll do it manually. The function FUNCALL-WITH-DESCRIBED-OBJECT takes care of setting up the proper context. There is some syntax for it in the form of WITH-DESCRIBED-OBJECT. 35 | 36 | \code{ 37 | (let ((description (find-description t)) 38 | (object "Hello World")) 39 | (with-described-object (object description) 40 | (dolist (a (attributes description)) 41 | (format t "~@[~A: ~]~A~%" 42 | (attribute-label a) 43 | (attribute-value a))))) 44 | 45 | \outputs{Hello World 46 | Type: (SIMPLE-ARRAY CHARACTER (11)) 47 | Class: #}} 48 | 49 | FUNCALL-WITH-DESCRIBED-OBJECT binds two specials, *description* and *object*, to its arguments. Knowing this, we can shorten our code somewhat. Later on we'll be far away from the lexical bindings of description and object, so these special variables are essential. 50 | 51 | \code{ 52 | (with-described-object ("Hello World" (find-description t)) 53 | (dolist (a (attributes *description*)) 54 | (format t "~@[~A: ~]~A~%" 55 | (attribute-label a) 56 | (attribute-value a))))} 57 | 58 | Lets wrap that up in a function that we can re-use 59 | 60 | \code {(defun present (object description) 61 | (with-described-object (object description) 62 | (dolist (a (attributes *description*)) 63 | (format t "~@[~A: ~]~A~%" 64 | (attribute-label a) 65 | (attribute-value a)))))} 66 | 67 | ** Defining description contexts 68 | 69 | The basics of MAO should now be clear, so lets start using it. First, lets create our very own description. 70 | 71 | \code{(define-description hello-world () 72 | ((title :value "Lisp on Lines Demo") 73 | (identity :label "Message") 74 | (length :label "Length" :function #'length) 75 | (active-attributes :value '(title identity length))))} 76 | 77 | Descriptions are very much like CLOS classes, and are in fact implemented that way, so normal inheritance rules apply. Attributes can have any number of properties, (see the class STANDARD-ATTRIBUTE), but the three most important are ATTRIBUTE-LABEL, ATTRIBUTE-VALUE and ATTRIBUTE-FUNCTION, named by the :label, :value, and :function keywords. ATTRIBUTE-LABEL is simply a textual label that describes the attribute. ATTRIBUTE-VALUE is defined to return the result of calling ATTRIBUTE-FUNCTION with the object. If ATTRIBUTE-FUNCTION is NIL, the value :value property is returned directly. 78 | 79 | In the example above, the IDENTITY and ACTIVE-ATTRIBUTES attribures are inherited from T, and we are simply overriding the default properties for our description. LENGTH and TITLE are specific to this description. A look at src/standard-descriptions/t.lisp may be instructive at this point. 80 | 81 | Now, we can present our object using our new description. LoL include a DISPLAY function, but for now we'll use our PRESENT function, as it's a little more transparent. 82 | 83 | \code{(present "Hello World" (find-description 'hello-world)) 84 | \outputs {Lisp on Lines Demo 85 | Message: Hello World 86 | Length: 11}) 87 | 88 | When an object is being described, the description context is also made active. One can also activate/deactivate individual description contexts, without using them to describe an object. One can also define partial descriptions that are only active when other description contexts have been activated. This is easier to show than to tell. 89 | 90 | \code{(define-description one-line ()) 91 | 92 | (define-description hello-world () 93 | ((identity :label nil) 94 | (active-attributes :value '(identity)) 95 | (attribute-delimiter :value ", ") 96 | (label-formatter :value (curry #'format nil "~A: ")) 97 | (value-formatter :value (curry #'format nil "~A"))) 98 | (:in-description one-line))} 99 | 100 | Here we've defined a new description, ONE-LINE, and a context-sensitive extension to our HELLO-WORLD description. This partial desription will be active only when in the context of a one-line description. One can have attributes that only exist in certain description contexts, and attributes can have different properties. 101 | 102 | \code{ 103 | (let ((message "Hello World!") 104 | (description (find-description 'hello-world))) 105 | (print :normal)(terpri) 106 | (present message description) 107 | (print :one-line)(terpri) 108 | (with-active-descriptions (one-line) 109 | (present message description))) 110 | \outputs{:NORMAL 111 | Lisp on Lines Demo 112 | Message: Hello World! 113 | Length: 12 114 | 115 | :ONE-LINE 116 | Hello World!} 117 | 118 | 119 | By activating the description ONE-LINE, we've changed the context in which our object is displayed. We can create any number of descriptions and contexts and activate/deactivate them in any order. 120 | 121 | Because all descriptions inherit from T, we can describe contexts for T and they will apply to every description. LoL includes a standard description, INLINE, which is almost exactly like our ONE-LINE definition above. It can be found in standard-descriptions/inline.lisp, and should look something like the following: 122 | 123 | \code{;; Defined by LoL: 124 | (define-description t () 125 | ((identity :label nil) 126 | (active-attributes :value '(identity)) 127 | (attribute-delimiter :value ", ") 128 | (label-formatter :value (curry #'format nil "~A: ")) 129 | (value-formatter :value (curry #'format nil "~A"))) 130 | (:in-description inline))} 131 | 132 | 133 | The DISPLAY protocol using this internally to display attribute values. This allows infinitely deep nesting of descriptions and contexts, so that one can describe how one object looks when displayed within another, and it's turtles all the way down. We can demonstrate this by modifying our PRESENT function. 134 | 135 | \code{ 136 | (defun present (object description) 137 | (with-described-object (object description) 138 | (dolist (a (attributes *description*)) 139 | (format t (concatenate 140 | 'string "~@[~A: ~]~A" 141 | (attribute-value 142 | (FIND-ATTRIBUTE *description* 'attribute-delimiter))) 143 | (attribute-label a) 144 | (let ((value (attribute-value a))) 145 | ;; prevent circles 146 | (if (eq object value) 147 | value 148 | (with-output-to-string (*standard-output*) 149 | (with-active-descriptions (inline) 150 | (present value (DESCRIPTION-OF value)))))))))) 151 | 152 | \outputs } 153 | 154 | This is not perfect, but it serves to demonstrate the idea. 155 | 156 | 157 | 158 | 159 | 160 | 161 | 162 | 163 | 164 | 165 | 166 | 167 | 168 | 169 | -------------------------------------------------------------------------------- /src/attribute.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lisp-on-lines) 2 | 3 | (define-layered-class direct-attribute-definition-class 4 | (special-layered-direct-slot-definition 5 | contextl::singleton-direct-slot-definition) 6 | ((attribute-properties 7 | :accessor direct-attribute-properties 8 | :documentation "This is an plist to hold the values of 9 | the attribute's properties as described by this direct 10 | attribute definition."))) 11 | 12 | (defmethod initialize-instance 13 | :after ((attribute direct-attribute-definition-class) 14 | &rest initargs) 15 | (setf (direct-attribute-properties attribute) initargs)) 16 | 17 | (define-layered-class effective-attribute-definition-class 18 | (special-layered-effective-slot-definition) 19 | ((direct-attributes 20 | :accessor attribute-direct-attributes) 21 | (attribute-object 22 | :accessor slot-definition-attribute-object) 23 | (attribute-object-initargs 24 | :accessor attribute-object-initargs))) 25 | 26 | (defvar *function-access* nil 27 | "set/get a place's property function instead of its symbol value 28 | when this is set to a non-nil value") 29 | 30 | (defmacro with-function-access (&body body) 31 | "executes body in an environment with *function-access* set to t" 32 | `(let ((*function-access* t)) 33 | ,@body)) 34 | 35 | (defmacro without-function-access (&body body) 36 | "executes body in an environment with *function-access* set to nil" 37 | `(let ((*function-access* nil)) 38 | ,@body)) 39 | 40 | (define-layered-function property-access-function (description attribute-name property-name) 41 | (:method (description attribute-name property-name) 42 | (ensure-layered-function 43 | (defining-description 44 | (intern (format nil "=PROPERTY-ACCESS-FUNCTION-FOR-~A->~A.~A=" 45 | (description-print-name description) 46 | attribute-name 47 | property-name))) 48 | :lambda-list '(description)))) 49 | 50 | 51 | (defvar *init-time-description* nil) 52 | 53 | (defmethod attribute-description :around (attribute) 54 | (handler-case (call-next-method) 55 | (unbound-slot () 56 | (or 57 | *init-time-description* 58 | (call-next-method))))) 59 | 60 | (define-layered-class attribute () 61 | ((description :initarg :description 62 | :accessor attribute-description) 63 | (name 64 | :layered-accessor attribute-name 65 | :initarg :name) 66 | (effective-attribute-definition 67 | :initarg effective-attribute 68 | :accessor attribute-effective-attribute-definition) 69 | (attribute-class 70 | :accessor attribute-class 71 | :initarg :attribute-class 72 | :initform 'standard-attribute) 73 | (keyword 74 | :layered-accessor attribute-keyword 75 | :initarg :keyword 76 | :initform nil 77 | :layered t) 78 | (object 79 | :layered-accessor attribute-object 80 | :accessor described-object 81 | :special t))) 82 | 83 | 84 | (define-layered-class standard-attribute (attribute) 85 | ((label 86 | :layered-accessor attribute-label 87 | :initarg :label 88 | :initform nil 89 | :layered t 90 | :special t) 91 | (label-formatter 92 | :layered-accessor attribute-label-formatter 93 | :initarg :label-formatter 94 | :initform nil 95 | :layered t 96 | :special t) 97 | (function 98 | :initarg :function 99 | :layered-accessor attribute-function 100 | :layered t 101 | :special t) 102 | (value 103 | :layered-accessor attribute-value 104 | :initarg :value 105 | :layered t 106 | :special t) 107 | (value-formatter 108 | :layered-accessor attribute-value-formatter 109 | :initarg :value-formatter 110 | :initform nil 111 | :layered t 112 | :special t) 113 | (activep 114 | :layered-accessor attribute-active-p 115 | :initarg :activep ;depreciated 116 | :initarg :active 117 | :initform t 118 | :layered t 119 | :special t 120 | :documentation 121 | "Can be T, NIL or :WHEN. In the latter case, attribute is only active if the attribute value is non-null.") 122 | (active-attributes :layered-accessor attribute-active-attributes 123 | :initarg :attributes 124 | :layered t 125 | :special t) 126 | (active-descriptions :layered-accessor attribute-active-descriptions 127 | :initarg :activate 128 | :initform nil 129 | :layered t 130 | :special t) 131 | (inactive-descriptions :layered-accessor attribute-inactive-descriptions 132 | :initarg :deactivate 133 | :initform nil 134 | :layered t 135 | :special t))) 136 | 137 | (define-layered-method attribute-active-p :around (attribute) 138 | (let ((active? (call-next-method))) 139 | (if (eq :when active?) 140 | (not (null (attribute-value attribute))) 141 | active?))) 142 | 143 | (define-layered-method attribute-label-formatter :around (attribute) 144 | (or (slot-value attribute 'label-formatter) 145 | (attribute-value (find-attribute (attribute-description attribute) 'label-formatter)) 146 | (error "No Formatter .. fool!"))) 147 | 148 | (define-layered-method attribute-value-formatter :around (attribute) 149 | 150 | (or (slot-value attribute 'value-formatter) 151 | (attribute-value (find-attribute (attribute-description attribute) 'value-formatter)) 152 | (error "No Formatter .. fool!"))) 153 | 154 | 155 | 156 | (define-layered-method attribute-object ((attribute standard-attribute)) 157 | (if (slot-boundp attribute 'object) 158 | (call-next-method) 159 | (described-object (attribute-description attribute)))) 160 | 161 | 162 | (define-layered-function attribute-value-using-object (object attribute)) 163 | (define-layered-function (setf attribute-value-using-object) (value object attribute)) 164 | 165 | (define-layered-method attribute-value ((attribute standard-attribute)) 166 | (attribute-value-using-object (attribute-object attribute) attribute)) 167 | 168 | (define-layered-method attribute-value-using-object (object attribute) 169 | (let ((fn (handler-case (attribute-function attribute) 170 | (unbound-slot () nil)))) 171 | (if fn 172 | (funcall fn object) 173 | (slot-value attribute 'value)))) 174 | 175 | (define-layered-method (setf attribute-value) (value (attribute standard-attribute)) 176 | (setf (attribute-value-using-object (attribute-object attribute) attribute) value)) 177 | 178 | (define-layered-method (setf attribute-value-using-object) (value object attribute) 179 | (error "No (SETF ATTRIBUTE-VALUE-USING-OBJECT) for ~A ~A and we are not editable" 180 | object attribute)) 181 | 182 | 183 | (defun ensure-access-function (class attribute property) 184 | (with-function-access 185 | (if (slot-definition-specialp property) 186 | (let ((slot-symbol 187 | (with-symbol-access 188 | (slot-value-using-class 189 | class attribute property)))) 190 | (if (fboundp slot-symbol) 191 | (symbol-function slot-symbol) 192 | (setf (symbol-function slot-symbol) 193 | (property-access-function 194 | (attribute-description attribute) 195 | (attribute-name attribute) 196 | (slot-definition-name property))))) 197 | (if (slot-boundp-using-class class attribute property) 198 | (slot-value-using-class class attribute property) 199 | (setf (slot-value-using-class class attribute property) 200 | (property-access-function 201 | (attribute-description attribute) 202 | (attribute-name attribute) 203 | (slot-definition-name property))))))) 204 | 205 | (define-layered-method slot-boundp-using-layer 206 | :in-layer (layer t) 207 | :around (class (attribute standard-attribute) property reader) 208 | 209 | ; (dprint "Checking boundp ~A ~A" (attribute-name attribute) 210 | ; (slot-definition-name property)) 211 | 212 | (if (or *symbol-access* *function-access*) 213 | (call-next-method) 214 | (or (when (slot-definition-specialp property) 215 | (with-function-access 216 | (slot-boundp-using-class class attribute property))) 217 | (if (generic-function-methods 218 | (ensure-access-function class attribute property)) 219 | T 220 | NIL)))) 221 | 222 | (define-layered-method (setf slot-value-using-layer) 223 | :in-layer (context t) 224 | :around 225 | (new-value class (attribute standard-attribute) property writer) 226 | 227 | ;; (dprint "Setting ~A ~A to : ~A" attribute property new-value) 228 | 229 | (if (or *symbol-access* *function-access*) 230 | (call-next-method) 231 | 232 | (if (and (slot-definition-specialp property) 233 | (with-function-access 234 | (without-symbol-access (slot-boundp-using-class class attribute property)))) 235 | (with-function-access 236 | (call-next-method)) 237 | (let ((layer 238 | ;;FIXME: this is wrong for so many reasons 239 | (find-layer (first (remove nil (closer-mop::class-precedence-list (class-of context)) 240 | :key #'class-name)))) 241 | (boundp (slot-boundp-using-class class attribute property)) 242 | (fn (ensure-access-function class attribute property))) 243 | 244 | (when (not boundp) 245 | ;; * This slot has never been set before. 246 | ;; create a method on property-accessor-function 247 | ;; so subclasses can see this new property. 248 | (ensure-layered-method 249 | (layered-function-definer 'property-access-function) 250 | `(lambda (description attribute property) 251 | (declare (ignore description attribute property)) 252 | ,fn) 253 | :in-layer layer 254 | :specializers 255 | (list (class-of 256 | (attribute-description attribute)) 257 | (closer-mop:intern-eql-specializer 258 | (attribute-name attribute)) 259 | (closer-mop:intern-eql-specializer 260 | (closer-mop:slot-definition-name property))))) 261 | 262 | ;; specialize this property to this description. 263 | ;;(dprint "actrually specializering") 264 | (ensure-layered-method 265 | fn 266 | `(lambda (description) 267 | (funcall ,(lambda() 268 | new-value))) 269 | :in-layer layer 270 | :specializers (list (class-of (attribute-description attribute)))) 271 | 272 | ;; and return the set value as is custom 273 | new-value)))) 274 | 275 | (define-layered-method slot-value-using-layer 276 | :in-layer (layer t) 277 | :around (class (attribute standard-attribute) property reader) 278 | 279 | ; ;(dprint "Getting the slot value of ~A" property) 280 | (if (or *symbol-access* *function-access*) 281 | (call-next-method) 282 | (let ((fn (ensure-access-function class attribute property))) 283 | 284 | (unless (slot-boundp-using-class class attribute property) 285 | (slot-unbound class attribute (slot-definition-name property))) 286 | 287 | (if (slot-definition-specialp property) 288 | (if (with-function-access 289 | (slot-boundp-using-class class attribute property)) 290 | (with-function-access 291 | (slot-value-using-class class attribute property)) 292 | (funcall fn layer (attribute-description attribute))) 293 | (handler-case (funcall fn layer (attribute-description attribute)) 294 | (error () 295 | (warn "Error calling ~A" fn))))))) 296 | 297 | 298 | 299 | 300 | 301 | 302 | (defmethod print-object ((object standard-attribute) stream) 303 | (print-unreadable-object (object stream :type nil :identity t) 304 | (format stream "ATTRIBUTE ~A" (or (ignore-errors (attribute-name object)) "+unnamed-attribute+")))) 305 | 306 | (defgeneric eval-property-initarg (att initarg) 307 | (:method ((attribute standard-attribute) initarg) 308 | nil) 309 | (:method ((attribute standard-attribute) (initarg (eql :function))) 310 | t) 311 | (:method ((attribute standard-attribute) (initarg (eql :value))) 312 | t)) 313 | 314 | (defun prepare-initargs (att args) 315 | (loop 316 | :for (key arg) 317 | :on args :by #'cddr 318 | :nconc (list key 319 | (if (eval-property-initarg att key) 320 | (eval arg) 321 | arg)))) 322 | 323 | 324 | (defun attribute-value* (attribute) 325 | (attribute-value *object* attribute)) 326 | 327 | (defmacro with-attributes (names description &body body) 328 | `(let ,(loop for name in names collect 329 | (list name `(find-attribute ,description ',name))) 330 | ,@body)) 331 | 332 | 333 | 334 | 335 | 336 | 337 | 338 | 339 | 340 | 341 | 342 | 343 | 344 | -------------------------------------------------------------------------------- /doc/manual.org: -------------------------------------------------------------------------------- 1 | Lisp on Lines : The Missing Manual. 2 | 3 | /Abstract/: Lisp on Lines is a Common Lisp based framework for rapid 4 | development of data-driven applications. It is particularly useful 5 | for producing Web based applications, but is also useful elsewhere. 6 | 7 | 8 | * Introduction 9 | 10 | Lisp on Lines (LoL) is a framework for rapid development of data-driven 11 | applications, with a particular focus on web-based applications. It 12 | builds on the UncommonWeb engine and Contextl, and uses CLOS and the 13 | MOP extensively. Most of LoL can be used both at the REPL and through 14 | the browser, offering many options for development and testing. 15 | 16 | While the target audience for LoL is developers experienced with both 17 | web technologies and common lisp, a good programmer with a little 18 | experience in either should be able to pick things up fairly quickly. 19 | 20 | * Installation 21 | 22 | LoL has a load of dependencies, which themselves depend on others, 23 | etc. The best way to deal with this is to use [[http://common-lisp.net/project/clbuild/][clbuild]], a library 24 | management tool. 25 | 26 | If you'd prefer to manage your libraries manually, the dependencies, 27 | according to clbuild, are : 28 | 29 | alexandria arnesi bordeaux-threads cl-base64 cl-fad cl-mime cl-ppcre 30 | cl-qprint closer-mop contextl iterate lift local-time lw-compat 31 | net-telent-date parenscript parse-number portable-threads puri rfc2109 32 | slime split-sequence trivial-garbage ucw usocket yaclml 33 | 34 | All libraries should be installed from version control where available. 35 | 36 | * Describing the domain with the MAO protocol. 37 | 38 | LoL uses a protocol it calls Meta-Attributed Objects, or MAO, as the 39 | basis of its display mechanism. In MAO, we create context-aware 40 | DESCRIPTIONs of objects, and those descriptions are used to generate 41 | the display of the object itself. By having these external 42 | descriptions change based on the context in which they are used, a few 43 | generic components can come together to create complex interfaces. 44 | 45 | ** Descriptions 46 | Descriptions are a similar conceptually to classes. Every Lisp object 47 | has one, and the root description that all descriptions inherit from 48 | is known as T. FIND-DESCRIPTION is used to, well, find descriptions. 49 | 50 | #+BEGIN_SRC lisp 51 | (find-description t) 52 | => # 53 | #+END_SRC 54 | 55 | ** Attributes and Properties 56 | A description is a collection of ATTRIBUTEs, among other things. Each 57 | attribute describes a part of an object, and any number of attributes 58 | may or may not be active. The ATTRIBUTES function is used to find a 59 | the list attributes that are both active and applicable in the current 60 | context. 61 | 62 | #+BEGIN_SRC lisp 63 | (attributes (find-description t)) 64 | =>(# 65 | # 66 | #) 67 | #+END_SRC 68 | 69 | The functions DESCRIPTION-ATTRIBUTES, DESCRIPTION-ACTIVE-ATTRIBUTES 70 | and DESCRIPTION-CURRENT-ATTRIBUTES return all the descriptions 71 | attributes, Attributes that are currently active regardless of 72 | context, and attributes that exist in the current context but may or 73 | may not be active, respectively. 74 | 75 | Attributes have properties, for example ATTRIBUTE-LABEL and 76 | ATTRIBUTE-VALUE. By simply iterating through the attributes of a 77 | described object, we can create a generic display for any lisp 78 | object. This is very similar, and was inspired by the technique 79 | outlined by Adrian Lienhard in [[http://www.adrian-lienhard.ch/files/mewa.pdf][MEWA: A Meta-level Architecture for 80 | Generic Web-Application Construction_]]. 81 | 82 | 83 | For attribute properties to be useful, the description must be 84 | associated with the object it is meant to describe. 85 | 86 | The function FUNCALL-WITH-DESCRIBED-OBJECT takes care of setting up 87 | the proper context. There is some syntax for it in the form of 88 | WITH-DESCRIBED-OBJECT : 89 | 90 | #+BEGIN_SRC lisp 91 | 92 | (let ((description (find-description t)) 93 | (object "Hello World")) 94 | (with-described-object (object description) 95 | (dolist (a (attributes description)) 96 | (format t "~@[~A: ~]~A~%" 97 | (attribute-label a) 98 | (attribute-value a))))) 99 | => 100 | Hello World 101 | Type: (SIMPLE-ARRAY CHARACTER (11)) 102 | Class: # 103 | 104 | NIL 105 | #+END_SRC 106 | 107 | FUNCALL-WITH-DESCRIBED-OBJECT binds two specials, *DESCRIPTION* and 108 | *OBJECT*, to its arguments. Knowing this, we can shorten our code 109 | somewhat. Later on we'll be far away from the lexical bindings of 110 | description and object, so these special variables are essential. 111 | 112 | Another reason for the *description* variable is that 113 | WITH-DESCRIBED-OBJECT will use DESCRIPTION-OF to determine the 114 | description if the DESCRIPTION argument is NIL 115 | 116 | #+BEGIN_SRC lisp 117 | (with-described-object ("Hello World" nil) 118 | (dolist (a (attributes *description*)) 119 | (format t "~@[~A: ~]~A~%" 120 | (attribute-label a) 121 | (attribute-value a)))) 122 | 123 | Lets wrap that up in a function that we can re-use. LoL includes an 124 | entire DISPLAY mechanism that is slightly more involved, but this 125 | serves as an excellent example with not bogging us down in details. 126 | 127 | #+BEGIN_SRC lisp 128 | (defun present (object &optional description) 129 | (with-described-object (object description) 130 | (dolist (a (attributes *description*)) 131 | (format t "~@[~A: ~]~A~%" 132 | (attribute-label a) 133 | (attribute-value a))))) 134 | #+END_SRC 135 | 136 | ** Contexts 137 | 138 | MAO adds to MEWA the concept of dynamic context. By changing the 139 | context in which an object is described, we combine and specialize the 140 | generic displays, ultimately creating different views of our 141 | objects. LoL uses ContextL extensively. Descriptions are contextl 142 | layers, and attributes themselves are layered classes. Most of the 143 | exported functions are layered methods, and the idea of dynamic 144 | context-sensitivity is used throughout LoL. If you're not familiar 145 | with contextl, don't worry, LoL mostly stands on its own. Still, 146 | reading through the material on contextl won't hurt. 147 | 148 | Descriptions may have different attributes dependant on what 149 | description contexts (or layers) are currently active. Attributes 150 | themselves might have different properties. 151 | 152 | When an object is being described (using WITH-DESCRIBED-OBJECT), it is 153 | also activated as a layer context. One can also activate/deactivate 154 | contexts manually, using WITH-ACTIVE-DESCRIPTIONS and 155 | WITH-INACTIVE-DESCRIPTIONS. 156 | 157 | Hopefully a little code will make this more clear : 158 | 159 | #+BEGIN_SRC lisp 160 | (present "Hello World") 161 | => 162 | Hello World 163 | Type: (SIMPLE-ARRAY CHARACTER (11)) 164 | Class: # 165 | Simple character string 166 | 167 | ;; Now we'll activate a built-in description, INLINE. 168 | 169 | (with-active-descriptions (inline) 170 | (present "Hello World")) 171 | => 172 | Hello World 173 | #+END_SRC 174 | 175 | You can see that the behavior of PRESENT changed when the INLINE 176 | context was activated. This is the key innovation that makes LoL so 177 | useful. In the next chapter we'll create our own descriptions and 178 | demonstrate this further. 179 | 180 | * Defining and Using Descriptions 181 | 182 | ** Defining a simple description 183 | The basics of the MAO should now (hopefully) be clear, so lets start 184 | using it. First, we'll create our very own description. 185 | 186 | #+BEGIN_SRC lisp 187 | (define-description hello-world () 188 | ((title :value "Lisp on Lines Demo") 189 | (identity :label "Message") 190 | (length :label "Length" :function #'length) 191 | (active-attributes :value '(title identity length)))) 192 | #+END_SRC 193 | 194 | Descriptions are defined very much like CLOS classes, and are in fact 195 | implemented that way, inheritance rules apply. The object returned 196 | from FIND-DESCRIPTION is best described as a prototype-based 197 | singleton. In other words, there is only one instance, and it inherits 198 | attributes and properties from further up its hierarchy unless 199 | specifically overridden. 200 | 201 | Attributes can have any number of properties, (see the class 202 | STANDARD-ATTRIBUTE), but the three most important are accessed via the 203 | methods ATTRIBUTE-LABEL, ATTRIBUTE-VALUE and ATTRIBUTE-FUNCTION,and 204 | named (in DEFINE-DESCRIPTION forms and elsewhere) 205 | by the :label, :value, and :function keywords. 206 | 207 | ATTRIBUTE-LABEL is simply a textual label that describes the 208 | attribute. ATTRIBUTE-VALUE is defined to return the result of calling 209 | ATTRIBUTE-FUNCTION with the object as its argument. If 210 | ATTRIBUTE-FUNCTION is NIL, the value of the :value property is returned 211 | directly. 212 | 213 | In the example above, the IDENTITY and ACTIVE-ATTRIBUTES attributes 214 | are inherited from T, and we are simply overriding the default 215 | properties for our description. LENGTH and TITLE are specific to this 216 | description. A look at src/standard-descriptions/t.lisp may be 217 | instructive at this point. 218 | 219 | Now, we can present our object using our new description. 220 | 221 | #+BEGIN_SRC lisp 222 | (present "Hello World" (find-description 'hello-world)) 223 | => 224 | Lisp on Lines Demo 225 | Message: Hello World 226 | Length: 11 227 | 228 | NIL 229 | #+END_SRC 230 | 231 | ** Using descriptions as and with contexts. 232 | 233 | A we mentioned earlier, when an object is being described, the 234 | 'description context' is also made active. On top of that, one can 235 | define partial descriptions that are only active when other 236 | description contexts have been activated. 237 | 238 | We'll make a ONE-LINE description similar to the INLINE description 239 | demonstrated earlier. 240 | 241 | #+BEGIN_SRC lisp 242 | (define-description one-line ()) 243 | 244 | (define-description hello-world () 245 | ((identity :label nil) 246 | (active-attributes :value '(identity))) 247 | (:in-description one-line)) 248 | 249 | #+END_SRC 250 | 251 | Here we've defined a new description, ONE-LINE, and a 252 | context-sensitive extension to our HELLO-WORLD description. This 253 | partial desription will be active only when in the context of a 254 | one-line description. One can have attributes that only exist in 255 | certain description contexts, and attributes can have different 256 | properties. 257 | 258 | #+BEGIN_SRC lisp 259 | (let ((message "Hello World!") 260 | (description (find-description 'hello-world))) 261 | (print :normal)(terpri) 262 | (present message description) 263 | (print :one-line)(terpri) 264 | (with-active-descriptions (one-line) 265 | (present message description))) 266 | => 267 | :NORMAL 268 | Lisp on Lines Demo 269 | Message: Hello World! 270 | Length: 12 271 | 272 | :ONE-LINE 273 | Hello World! 274 | 275 | NIL 276 | #+END_SRC 277 | 278 | By activating the description ONE-LINE, we've changed the context in 279 | which our object is displayed. We can create any number of 280 | descriptions and contexts and activate/deactivate them in any order. 281 | 282 | Descriptions are implemented as ContextL 'layers', so if all 283 | this seems weird, reading the ContextL papers might help. 284 | 285 | ** T : The root of all descriptions. 286 | 287 | Because all descriptions inherit from T, we can define contexts for T 288 | and they will apply to every description. The INLINE description can 289 | be found in standard-descriptions/inline.lisp, where we define 290 | a desription for T in the context of the INLINE description : 291 | 292 | #+BEGIN_SRC lisp 293 | ;; Defined by LoL in inline.lisp : 294 | (define-description t () 295 | ((identity :label nil) 296 | (active-attributes :value '(identity)) 297 | (attribute-delimiter :value ", ") 298 | (label-formatter :value (curry #'format nil "~A: ")) 299 | (value-formatter :value (curry #'format nil "~A"))) 300 | (:in-description inline))} 301 | 302 | #+END_SRC 303 | 304 | The does for the LoL DISPLAY mechanism what ONE-LINE did for PRESENT, 305 | only with more magic. By exetending T in this way, it's easy to create 306 | contexts the redefine the behavior of LoL while still reusing the basics. 307 | 308 | ** DESCRIPTION-OF : Permanently Associate a description with a class. 309 | 310 | The LAYERED-FUNCTION DESCRIPTION-OF will return the description 311 | associated with an object. 312 | 313 | #+BEGIN_SRC lisp 314 | 315 | (description-of nil) 316 | => 317 | # 318 | 319 | (description-of t) 320 | => 321 | # 322 | 323 | (description-of '(1 2 3)) 324 | => 325 | # 326 | 327 | ;;etc 328 | 329 | #+END_SRC 330 | 331 | * The DISPLAY Protocol 332 | 333 | Our function, PRESENT, is very basic, though pretty powerful when 334 | combined with descriptions and contexts. LoL includes a superset of 335 | such functionality built-in. 336 | 337 | The main entry point into this protocol is the DISPLAY 338 | function. The signature for this functions is : 339 | 340 | #+BEGIN_SRC lisp 341 | (display DISPLAY OBJECT &REST ARGS &KEY DEACTIVATE ACTIVATE &ALLOW-OTHER-KEYS) 342 | #+END_SRC 343 | 344 | The first argument, DISPLAY, is the place where we will display 345 | to/on/in/with. It could be a stream, a UCW component, a CLIM gadget, 346 | or anything else you might want to use. 347 | 348 | One can specialize on this argument (though it's better to specialize 349 | DISPLAY-USING-DESCRIPTION... more on that later) to use generic 350 | descriptions to display objects in different environments. 351 | 352 | The second argument is simply the object to be displayed. Here's a 353 | simple example : 354 | 355 | #+BEGIN_SRC lisp 356 | (display t t) 357 | => 358 | T 359 | Type:BOOLEAN 360 | Class:# 361 | Symbol 362 | Name:T 363 | Value:T 364 | Package:# 365 | Function: 366 | ; No value 367 | #+END_SRC 368 | 369 | The two arguments specified in the lambda-list, ACTIVATE and 370 | DEACTIVATE, are used to activate and deactivate description contexts in 371 | the scope of the display function. 372 | 373 | #+BEGIN_SRC lisp 374 | 375 | (display nil t :activate '(inline)) 376 | => 377 | "t" 378 | (with-active-descriptions (inline) 379 | (display nil t :deactivate '(inline))) 380 | => 381 | "T 382 | Type:BOOLEAN 383 | Class:# 384 | Symbol 385 | Name:T 386 | Value:T 387 | Package:# 388 | Function:" 389 | 390 | #+END_SRC 391 | 392 | Any other keyword arguments passed will be used to set the value of an 393 | attribute with a :keyword property, in the dynamic context of the 394 | DISPLAY function call. Once such attribute, and a very useful one is 395 | ACTIVE-ATTRIBUTES with its :attributes keyword : 396 | 397 | #+BEGIN_SRC lisp 398 | 399 | (display t t :attributes '(class package)) 400 | => 401 | Class:# 402 | Package:# 403 | 404 | #+END_SRC 405 | 406 | The properties of attributes that do not have a :keyword property can 407 | also be set dynamically. Since :attributes is the :keyword property of 408 | the ACTIVE-ATTRIBUTES attribute, the following form is equivalent to 409 | the previous : 410 | 411 | #+BEGIN_SRC lisp 412 | (display t t :attributes '((active-attributes 413 | :value (class package)))) 414 | => 415 | Class:# 416 | Package:# 417 | #+END_SRC 418 | 419 | Setting the attributes this way is almost like creating an anonymous 420 | description context... you can express just about anything you would 421 | in a DEFINE-DESCRIPTION. Here's a more involved example : 422 | 423 | #+BEGIN_SRC lisp 424 | (display t t :attributes `((identity :label "The Object") 425 | (class :label "CLOS Class") 426 | (package :value "COMMON LISP" :function nil) 427 | (type :value-formatter 428 | ,(lambda (a) 429 | (format nil "Got a value? ~A" a))))) 430 | => 431 | 432 | The Object:T 433 | CLOS Class:# 434 | Package:COMMON LISP 435 | Type:Got a value? BOOLEAN 436 | 437 | #+END_SRC 438 | 439 | I hope that serves well to demonstrate the concepts behind LoL, as 440 | there is no API documentation available at the moment... use the 441 | source luke! 442 | 443 | 444 | * Automatic Descriptions for CLOS classes. 445 | 446 | Lisp-on-Lines includes a compose-able metaclass, DESCRIBED-CLASS. It 447 | can be combined with _any_ other metaclass without affecting the 448 | behavior of that class. DESCRIBED-CLASS has been used with the 449 | metaclasses provided by CLSQL, ROFL, Rucksack and UCW simply by 450 | defining a class that inherits from both metaclasses. 451 | 452 | DESCRIBED-CLASS creates a base description for the class, named 453 | DESCRIPTION-FOR-, and another description with the same name 454 | as the class that has the previous description as a superclass. The 455 | then defines a method on DESCRIPTION-OF that returns the second 456 | description. 457 | 458 | LoL includes DESCRIBED-STANDARD-CLASS, which is subclass of 459 | STANDARD-CLASS and DESCRIBED-CLASS. We'll use this to create a class 460 | and its description. 461 | 462 | #+BEGIN_SRC lisp 463 | 464 | (defclass person () 465 | (first-name last-name company-name 466 | date-of-birth phone fax email 467 | address city province postal-code) 468 | (:metaclass described-standard-class)) 469 | => 470 | # 471 | 472 | (display t (make-instance 'person)) 473 | => 474 | First name:# 475 | Last name:# 476 | Company name:# 477 | Date of birth:# 478 | Phone:# 479 | Fax:# 480 | Email:# 481 | Address:# 482 | City:# 483 | Province:# 484 | Postal code:# 485 | 486 | #+END_SRC 487 | 488 | ** Described CLOS objects an the EDITABLE description 489 | 490 | The slots of an object are SETF'able places, and LoL takes 491 | advantage of that to provide EDITABLE descriptions 492 | automatically. When the EDITABLE description is active, and editor 493 | will be presented. The REPL based editor is pretty basic, but still 494 | useful. The HTML based editor will be described later. 495 | 496 | 497 | #+BEGIN_SRC lisp 498 | (defun edit-object (object &rest args) 499 | (with-active-descriptions (editable) 500 | (apply #'display t object args))) 501 | 502 | (let ((object (make-instance 'person))) 503 | (edit-object object) 504 | (terpri) 505 | (display t object)) 506 | 507 | ;; What follows are prompts and the information i entered 508 | 509 | First name:Drew 510 | 511 | Last name:Crampsie 512 | 513 | Company name:The Tech Co-op 514 | 515 | Date of birth:1978-07-31 516 | 517 | Phone:555-5555 518 | 519 | Fax:555-5555 520 | 521 | Email:drewc@tech.coop 522 | 523 | Address:s/v Kanu, Lower Fraser River 524 | 525 | City:Richmond 526 | 527 | Province:BC 528 | 529 | Postal code:V1V3T6 530 | 531 | ;; And this is what was displayed. 532 | 533 | First name:Drew 534 | Last name:Crampsie 535 | Company name:The Tech Co-op 536 | Date of birth:1978-07-31 537 | Phone:555-5555 538 | Fax:555-5555 539 | Email:drewc@tech.coop 540 | Address:s/v Kanu, Lower Fraser River 541 | City:Richmond 542 | Province:BC 543 | Postal code:V1V3T6 544 | #+END_SRC 545 | 546 | ** Extending the generated description 547 | 548 | We mentioned earlier that DESCRIBED-CLASS creates two descriptions : 549 | 550 | #+BEGIN_SRC lisp 551 | 552 | (find-description 'description-for-person) 553 | => 554 | # 555 | 556 | (find-description 'person) 557 | => 558 | # 559 | 560 | (description-of (make-instance 'person)) 561 | => 562 | # 563 | 564 | #+END_SRC 565 | 566 | 567 | The reason for this is so we can redefine the description PERSON while 568 | keeping all the generated information from DESCRIPTION-FOR-PERSON. 569 | 570 | In this case, we will add an attribute, PERSON-AGE, that calculates 571 | a persons age based on the data in the date-of-birth slot. 572 | 573 | 574 | 575 | 576 | 577 | 578 | 579 | 580 | 581 | 582 | 583 | 584 | 585 | * Using Lisp-on-Lines for the Web. 586 | 587 | LoL was developed, and is primarily used, for implementing 588 | data-driven web applications. As such, it comes with a host of 589 | features for doing just that. 590 | 591 | LoL, by default, implements its web portion on top of the wonderful 592 | UnCommon Web meta-framework. The LISP-ON-LINES-UCW ASDF system 593 | should be loaded, as it provides the features we're going to 594 | discuss. 595 | 596 | 597 | 598 | 599 | 600 | 601 | 602 | 603 | 604 | 605 | 606 | 607 | 608 | 609 | 610 | -------------------------------------------------------------------------------- /src/rofl.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lisp-on-lines) 2 | 3 | ;;;; NB: These could really be in upstream 4 | 5 | ;;;; * A PLIST reader for postmodern. 6 | (postmodern::def-row-reader symbol-plist-row-reader (fields) 7 | (let ((symbols (map 'list (lambda (desc) 8 | (postmodern::from-sql-name (postmodern::field-name desc))) fields))) 9 | (loop :while (postmodern::next-row) 10 | :collect (loop :for field :across fields 11 | :for symbol :in symbols 12 | :nconc (list symbol (postmodern::next-field field)))))) 13 | 14 | (s-sql::def-sql-op :between (n start end) 15 | `(,@(s-sql::sql-expand n) " BETWEEN " ,@(s-sql::sql-expand start) " AND " ,@(s-sql::sql-expand end))) 16 | 17 | (s-sql::def-sql-op :case (&rest clauses) 18 | `("CASE " ,@(loop for (test expr) in clauses collect (format nil "WHEN ~A THEN ~A " (s-sql::sql-expand test) (s-sql::sql-expand expr))) "END")) 19 | 20 | 21 | ;;;; now the rofl code itself 22 | 23 | (defvar *row-reader* 'symbol-plist-row-reader) 24 | 25 | (defun %query (query) 26 | (cl-postgres:exec-query *database* (sql-compile query) *row-reader*)) 27 | 28 | (defun select (&rest query) 29 | (%query (cons :select query))) 30 | 31 | (defun prepare (&rest query) 32 | (cl-postgres:prepare-query *database* "test2" (sql-compile (cons :select query)))) 33 | 34 | 35 | (defun select-only (num &rest query) 36 | (let ((results (%query `(:limit ,(cons :select query) ,num)))) 37 | (if (eql 1 num) 38 | (first results) 39 | results))) 40 | 41 | (defun insert-into (table &rest values-plist) 42 | (postmodern:execute 43 | (postmodern:sql-compile `(:insert-into ,table :set ,@values-plist)))) 44 | 45 | (defun update (table &rest query) 46 | (postmodern:execute 47 | (postmodern:sql-compile `(:update ,table ,@query)))) 48 | 49 | 50 | (defclass db-access-slot-definition () 51 | ((column-name :initform nil 52 | :initarg :db-name 53 | :initarg :column 54 | :accessor slot-definition-column-name 55 | :documentation 56 | "If non-NIL, contains the name of the column this slot is representing.") 57 | (primary-key :initform nil 58 | :initarg :primary-key 59 | :accessor slot-definition-primary-key-p) 60 | (transient :initform nil :initarg :transient :accessor slot-definition-transient-p 61 | :documentation 62 | "If non-NIL, this slot should be treated as transient and 63 | ignored in all database related operations.") 64 | (not-null :initform nil :initarg :not-null :accessor slot-definition-not-null-p 65 | :documentation "If non-NIL, a NON NULL database 66 | constrained will be introduced.") 67 | (foreign-type 68 | :initform nil 69 | :initarg :foreign-type 70 | :initarg :references 71 | :accessor slot-definition-foreign-type) 72 | (foreign-relation 73 | :initform nil 74 | :initarg :referenced-from 75 | :initarg :referenced-by 76 | :accessor slot-definition-foreign-relation) 77 | (foreign-join-spec 78 | :initform nil 79 | :initarg :on 80 | :initarg :using 81 | :accessor slot-definition-foreign-join-spec) 82 | (unique :initform nil :initarg :unique :accessor slot-definition-unique) 83 | 84 | 85 | (on-delete :initform :cascade :initarg :on-delete :accessor slot-definition-on-delete 86 | :documentation "Action to be performed for this slot 87 | when the refering row in the database ceases to exist. Possible 88 | values: :CASCADE, :RESTRICT, :SET-NULL, :SET-DEFAULT. If this slot is 89 | not a foreign key, it does nothing.") 90 | (delayed-constraint :initform nil :accessor slot-definition-delayed-constraint 91 | :documentation "Closures adding constraints 92 | that, for some reason, could not be executed. If there's a slot with 93 | this attribute not-NIL in a class definition, then there's something 94 | wrong with its SQL counterpart."))) 95 | 96 | 97 | (defclass db-access-class (standard-class) 98 | ((table-name :initarg :table-name :initform nil :accessor class-table-name) 99 | (indices :initarg :indices :initform () :reader class-indices) 100 | (unique :initarg :unique :initform () :reader class-unique) 101 | #+not!(connection-spec :initarg :connection-spec :initform nil :reader db-class-connection-spec) 102 | 103 | (unfinished-classes :initform nil :allocation :class :accessor class-unfinished-classes 104 | :documentation "A class allocated slot 105 | containing classes for whom not all the constraints could be 106 | applied.") 107 | (foreign-keys :initform nil :accessor class-foreign-keys 108 | :documentation "List of foreign-key slots.") 109 | (unique-keys :initform nil :accessor class-unique-keys 110 | :documentation "List of slots whose value should be unique.")) 111 | (:documentation "Metaclass for PostgreSQL aware classes. It takes 112 | two additional arguments in DEFTABLE: :INDICES (which slots are used 113 | as indices) and :CONNECTION-SPEC, which specifies how the class should 114 | connect to the database (its format is the same as in 115 | POSTMODERN:CONNECT-TOPLEVEL). If :CONNECTION-SPEC is not provided, 116 | SUBMARINE assumes it is a class created just for the sake of 117 | inheritance and does not create any tables for it.")) 118 | 119 | (defmethod validate-superclass 120 | ((class db-access-class) 121 | (superclass standard-class)) 122 | t) 123 | 124 | 125 | (defclass db-access-direct-slot-definition (standard-direct-slot-definition 126 | db-access-slot-definition) 127 | ()) 128 | 129 | (defmethod direct-slot-definition-class 130 | ((class db-access-class) &key &allow-other-keys) 131 | (find-class 'db-access-direct-slot-definition)) 132 | 133 | (defclass db-access-effective-slot-definition 134 | (standard-effective-slot-definition 135 | db-access-slot-definition) 136 | ()) 137 | 138 | (defmethod effective-slot-definition-class 139 | ((class db-access-class) &key &allow-other-keys) 140 | (find-class 'db-access-effective-slot-definition)) 141 | 142 | (defmethod compute-effective-slot-definition 143 | ((class db-access-class) name direct-slot-definitions) 144 | (declare (ignore name)) 145 | (let ((slotd (call-next-method))) 146 | (setf (slot-definition-primary-key-p slotd) 147 | (some #'slot-definition-primary-key-p direct-slot-definitions) 148 | (slot-definition-column-name slotd) 149 | (or (let ((slot (find-if #'slot-definition-column-name direct-slot-definitions))) 150 | (when slot 151 | (slot-definition-column-name slot))) 152 | name) 153 | (slot-definition-transient-p slotd) 154 | (every #'slot-definition-transient-p direct-slot-definitions) 155 | (slot-definition-foreign-type slotd) 156 | (slot-definition-foreign-type (car direct-slot-definitions)) 157 | (slot-definition-foreign-relation slotd) 158 | (slot-definition-foreign-relation (car direct-slot-definitions)) 159 | (slot-definition-foreign-join-spec slotd) 160 | (slot-definition-foreign-join-spec (car direct-slot-definitions)) 161 | (slot-definition-not-null-p slotd) 162 | (slot-definition-not-null-p (car direct-slot-definitions)) 163 | (slot-definition-unique slotd) (slot-definition-unique (car direct-slot-definitions)) 164 | (slot-definition-type slotd) (slot-definition-type (car direct-slot-definitions))) 165 | slotd)) 166 | 167 | (defun class-id-slot-definition (class) 168 | (find-if #'slot-definition-primary-key-p 169 | (class-slots class))) 170 | 171 | (defmethod class-table-name :around (class) 172 | (or (call-next-method) 173 | (class-name class))) 174 | 175 | (defclass standard-db-access-class (db-access-class) 176 | ()) 177 | 178 | (defun find-foreign-relations (class object slotd) 179 | (when (slot-boundp object (dao-id-column-name class)) 180 | (select-objects (slot-definition-foreign-relation slotd) 181 | :where `(:= ,(or (slot-definition-foreign-join-spec slotd) 182 | (dao-id-column-name class)) 183 | ,(slot-value object (dao-id-column-name class)))))) 184 | 185 | (defmethod slot-boundp-using-class :around 186 | ((class standard-db-access-class) object slotd) 187 | (let ((bound? (call-next-method))) 188 | (when (and (not bound?) (slot-definition-foreign-relation slotd)) 189 | (setf (slot-value-using-class class object slotd) 190 | (find-foreign-relations class object slotd))) 191 | 192 | (call-next-method))) 193 | 194 | (defmethod slot-value-using-class :around 195 | ((class standard-db-access-class) object slotd) 196 | (if (slot-definition-foreign-relation slotd) 197 | (if (slot-boundp-using-class class object slotd) 198 | (call-next-method) 199 | (setf (slot-value-using-class class object slotd) 200 | (find-foreign-relations class object slotd))) 201 | (call-next-method))) 202 | 203 | (defun set-fkey-from-slotd (value object slotd) 204 | (when (slot-boundp value (dao-id-column-name (class-of value))) 205 | (setf (slot-value object (slot-definition-column-name slotd)) 206 | (slot-value value (dao-id-column-name (class-of value)))))) 207 | 208 | (defmethod (setf slot-value-using-class) :after 209 | (value (class standard-db-access-class) object slotd) 210 | (when (and value 211 | (typep value 'standard-db-access-object) 212 | (slot-definition-foreign-type slotd) 213 | (primary-key-boundp value)) 214 | 215 | (set-fkey-from-slotd value object slotd))) 216 | 217 | (defun find-foreign-objects (db-object) 218 | (let* ((class (class-of db-object)) 219 | (foreign-objects )) 220 | (mapcar (lambda (x) 221 | (and (slot-value-using-class class db-object x) 222 | (slot-value-using-class class db-object x))) 223 | (remove-if-not #'lol::slot-definition-foreign-type 224 | (lol::class-slots class))))) 225 | 226 | 227 | (defun dao-id-column-name (class) 228 | (slot-definition-column-name 229 | (or (class-id-slot-definition class) 230 | (error "No ID slot (primary key) for ~A" class)))) 231 | 232 | (defun db-access-object-p (thing) 233 | (typep thing 'standard-db-access-object)) 234 | 235 | (defun primary-key-boundp (object) 236 | (check-type object standard-db-access-object) 237 | (slot-boundp object (dao-id-column-name (class-of object)))) 238 | 239 | (defclass described-db-access-class (described-class standard-db-access-class) 240 | ()) 241 | 242 | (defmethod initialize-instance :around ((class standard-db-access-class) &rest initargs &key name (direct-superclasses '()) direct-slots) 243 | (declare (dynamic-extent initargs)) 244 | (let ((direct-slots (loop for slot in direct-slots 245 | collect (let* ((sname (getf slot :name)) 246 | (readers (getf slot :readers)) 247 | (writers (getf slot :writers))) 248 | (setf (getf slot :readers) 249 | (cons (intern (format nil "~A.~A" 250 | name sname)) readers)) 251 | (setf (getf slot :writers) 252 | (cons `(setf ,(intern (format nil "~A.~A" 253 | name sname))) writers)) 254 | slot)))) 255 | 256 | 257 | 258 | (if (loop for direct-superclass in direct-superclasses 259 | thereis (ignore-errors (subtypep direct-superclass 'standard-db-access-object))) 260 | (call-next-method) 261 | (apply #'call-next-method 262 | class 263 | :direct-superclasses 264 | (append direct-superclasses 265 | (list (find-class 'standard-db-access-object))) 266 | :direct-slots direct-slots 267 | initargs)))) 268 | 269 | (defmethod reinitialize-instance :around ((class standard-db-access-class) 270 | &rest initargs 271 | &key (name (class-name class)) 272 | (direct-superclasses '() direct-superclasses-p) direct-slots) 273 | (declare (dynamic-extent initargs)) 274 | (let ((direct-slots (loop for slot in direct-slots 275 | collect (let* ((sname (getf slot :name)) 276 | (readers (getf slot :readers)) 277 | (writers (getf slot :writers))) 278 | (setf (getf slot :readers) 279 | (cons (intern (format nil "~A.~A" 280 | name sname)) readers)) 281 | (setf (getf slot :writers) 282 | (cons `(setf ,(intern (format nil "~A.~A" 283 | name sname))) writers)) 284 | slot)))) 285 | 286 | 287 | 288 | (if (loop for direct-superclass in direct-superclasses 289 | thereis (ignore-errors (subtypep direct-superclass 'standard-db-access-object))) 290 | (call-next-method) 291 | (apply #'call-next-method 292 | class 293 | :direct-superclasses 294 | (append direct-superclasses 295 | (list (find-class 'standard-db-access-object))) 296 | :direct-slots direct-slots 297 | initargs)))) 298 | 299 | (defclass standard-db-access-object (standard-object) 300 | ()) 301 | 302 | (defun %select-objects (type select-fn query) 303 | (mapcar (curry 'make-object-from-plist type) 304 | (apply select-fn (intern (format nil "*")) 305 | (if (string-equal (first query) :from) 306 | query 307 | (append `(:from ,type) query))))) 308 | 309 | (defun select-objects (type &rest query) 310 | (%select-objects type #'select query)) 311 | 312 | (defun select-only-n-objects (n type &rest query) 313 | (let ((fields (if (eq :fields (car query)) 314 | (loop 315 | :for cons :on (cdr query) 316 | :if (not (keywordp (car cons))) 317 | :collect (car cons) into fields 318 | :else :do 319 | (setf query cons) 320 | (return (nreverse (print fields))) 321 | :finally 322 | (setf query cons) 323 | (return (nreverse (print fields)))) 324 | 325 | (list (intern "*"))))) 326 | (let ((results 327 | (%query 328 | (print `(:limit (:select 329 | ,@fields 330 | ,@(if (string-equal (first query) :from) 331 | (print query) 332 | (append `(:from ,type) query))) 333 | ,n))))) 334 | (if (eql 1 n) 335 | (make-object-from-plist type (first results)) 336 | (mapcar (curry 'make-object-from-plist type) results))))) 337 | 338 | (defun make-object-from-plist (type plist) 339 | (let* ((class (find-class type)) 340 | (object (make-instance class)) 341 | (slotds (class-slots class))) 342 | 343 | (loop 344 | :for (key val) :on plist :by #'cddr 345 | :do 346 | (dolist (slotd (remove key slotds 347 | :key #'slot-definition-column-name 348 | :test-not #'string-equal)) 349 | 350 | (setf (slot-value-using-class class object slotd) val)) 351 | :finally (return (reinitialize-instance object))))) 352 | 353 | (defun make-object (type &rest plist) 354 | (make-object-from-plist type plist)) 355 | 356 | (defun insert-object (object) 357 | (let ((class (class-of object)) 358 | insert-query 359 | delayed) 360 | (flet ((ins (slotd &optional (val (slot-value-using-class class object slotd))) 361 | (push (lambda () (push (slot-definition-column-name slotd) insert-query) 362 | (push val insert-query)) 363 | delayed))) 364 | (loop :for slotd in (class-slots class) 365 | :do (cond ((slot-boundp-using-class class object slotd) 366 | (cond ((or (slot-definition-foreign-relation slotd) 367 | ) 368 | ) 369 | ((slot-definition-foreign-type slotd) 370 | (set-fkey-from-slotd 371 | (slot-value-using-class class object slotd) 372 | object slotd 373 | ) 374 | ) 375 | (t 376 | (ins slotd)) )) 377 | ((slot-definition-primary-key-p slotd) 378 | (setf (slot-value-using-class class object slotd) (get-default-value (class-table-name class) 379 | (slot-definition-column-name slotd))) 380 | (ins slotd )))) 381 | (map nil #'funcall delayed) 382 | (apply #'insert-into (class-table-name class) (nreverse insert-query)))) 383 | object) 384 | 385 | 386 | (defun update-object (object) 387 | (let ((class (class-of object)) 388 | update-query 389 | delayed) 390 | (flet ((ins (slotd &optional (val (slot-value-using-class class object slotd))) 391 | (push (lambda () (push (slot-definition-column-name slotd) update-query) 392 | (push val update-query)) 393 | delayed))) 394 | (loop :for slotd in (class-slots class) 395 | :do (cond ((slot-boundp-using-class class object slotd) 396 | (cond ((or (slot-definition-foreign-relation slotd) 397 | ) 398 | ) 399 | ((slot-definition-foreign-type slotd) 400 | (set-fkey-from-slotd 401 | (slot-value-using-class class object slotd) 402 | object slotd 403 | ) 404 | ) 405 | (t 406 | (ins slotd)) )) 407 | ((slot-definition-primary-key-p slotd) 408 | (setf (slot-value-using-class class object slotd) (get-default-value (class-table-name class) 409 | (slot-definition-column-name slotd))) 410 | (ins slotd )))) 411 | (map nil #'funcall delayed) 412 | (apply #'update (class-table-name class) :set (nconc (nreverse update-query) 413 | (list :where `(:= ,(dao-id-column-name class) 414 | ,(slot-value object (dao-id-column-name class)) 415 | )))))) 416 | object) 417 | 418 | (defun select-using-object (object &key (combinator :and)) 419 | (let ((class (class-of object)) 420 | select-query) 421 | (flet ((sel (slotd &optional (val (slot-value-using-class class object slotd))) 422 | (push `(:ilike ,(slot-definition-column-name slotd) ,(if (stringp val) 423 | (format nil "~A%" val) val)) select-query))) 424 | (loop :for slotd in (class-slots class) 425 | :do (cond ((slot-boundp-using-class class object slotd) 426 | (unless (or (slot-definition-foreign-relation slotd) 427 | (slot-definition-foreign-type slotd)) 428 | (sel slotd))))) 429 | (if select-query 430 | (select-objects (class-table-name class) 431 | :where (print `(,combinator ,@(nreverse select-query)))) 432 | nil)))) 433 | 434 | 435 | (defun get-default-value-query (table column) 436 | (format nil "select ~A " 437 | (second (select-only 1 ':adsrc 438 | :from 'pg_attribute 'pg_attrdef 439 | :where `(:and (:= adnum attnum) 440 | (:= attname ,(s-sql::to-sql-name column)) 441 | (:= adrelid attrelid) 442 | (:= attrelid 443 | (:select oid 444 | :from pg_class 445 | :where (:= relname ,(s-sql::to-sql-name table))))))))) 446 | 447 | (defun get-default-value (table column) 448 | (caar (query (get-default-value-query table column)))) 449 | 450 | (defun find-dao (type id 451 | &key (table (class-table-name (find-class type))) 452 | id-column-name) 453 | 454 | "Get the dao corresponding to the given primary key, 455 | or return nil if it does not exist." 456 | (let ((plist 457 | (select-only 1 '* 458 | :from table 459 | :where (list ':= id (or id-column-name 460 | (dao-id-column-name 461 | (find-class type))))))) 462 | (make-object-from-plist type plist))) 463 | 464 | (defmethod shared-initialize :after ((dao standard-db-access-object) 465 | slots &rest initargs) 466 | (let ((class (class-of dao)) 467 | (foreign-key)) 468 | (dolist (slotd (class-slots class)) 469 | (with-slots (foreign-type) slotd 470 | (when foreign-type 471 | (when (consp foreign-type) 472 | (setf foreign-key (cdr foreign-type) 473 | foreign-type (car foreign-type))) 474 | (if (slot-boundp-using-class class dao slotd) 475 | (let ((value (slot-value-using-class class dao slotd))) (unless (typep value foreign-type) 476 | (if (connected-p *database*) 477 | (setf (slot-value-using-class class dao slotd) 478 | (find-dao foreign-type value)) 479 | (let ((obj (make-instance foreign-type))) 480 | (break "here") 481 | (setf (slot-value-using-class 482 | (class-of obj) 483 | obj 484 | (class-id-slot-definition (class-of obj))) 485 | value))))))))))) 486 | 487 | (defgeneric dao-id (dao) 488 | (:method ((dao standard-db-access-object)) 489 | (let ((class (class-of dao))) 490 | 491 | (slot-value-using-class class dao (class-id-slot-definition class))))) 492 | 493 | (defun make-dao-from-row (type row &key slots) 494 | (let* ((class (find-class type)) 495 | (dao (make-instance class)) 496 | (slotds (class-slots class))) 497 | (loop 498 | :for val :in row 499 | :for slotd 500 | :in (or 501 | (loop 502 | :for slot :in slots 503 | :collect (find slot slotds 504 | :key #'slot-definition-name)) 505 | slotds) 506 | :do (setf (slot-value-using-class class dao slotd) val) 507 | :finally (return (reinitialize-instance dao))))) 508 | 509 | ;(defgeneric make-dao (type &rest initargs) 510 | #+nil(defun make-dao (type initargs) 511 | "Create a DAO of the given `TYPE' and initialize it according 512 | to the values of the alist `INITARGS'. `Initargs' may contain 513 | additional values, not used in the initialization proccess." 514 | (let ((instance (make-instance type))) 515 | (iter (for slot in (slots-of instance)) 516 | (setf (slot-value instance (slot-definition-name slot)) 517 | (let ((the-value (cdr (assoc (intern (symbol-name (slot-definition-name slot)) 'keyword) initargs)))) 518 | (if (foreign-type-p slot) 519 | (make-instance (sb-pcl:slot-definition-type slot) :id the-value) 520 | the-value)))) 521 | instance)) 522 | 523 | 524 | 525 | 526 | 527 | -------------------------------------------------------------------------------- /doc/manual.html: -------------------------------------------------------------------------------- 1 | 3 | 5 | 6 | Lisp on Lines : The Missing Manual. 7 | 8 | 9 | 10 | 11 | 37 | 38 |

Lisp on Lines : The Missing Manual.

39 | Abstract: Lisp on Lines is a Common Lisp based framework for rapid 40 | development of data-driven applications. It is particularly useful 41 | for producing Web based applications, but is also useful elsewhere. 42 | 43 | 44 | 45 | 77 | 78 |
79 |

1 Introduction

80 |
81 | 82 | 83 |

84 | Lisp on Lines (LoL) is a framework for rapid development of data-driven 85 | applications, with a particular focus on web-based applications. It 86 | builds on the UncommonWeb engine and Contextl, and uses CLOS and the 87 | MOP extensively. Most of LoL can be used both at the REPL and through 88 | the browser, offering many options for development and testing. 89 |

90 |

91 | While the target audience for LoL is developers experienced with both 92 | web technologies and common lisp, a good programmer with a little 93 | experience in either should be able to pick things up fairly quickly. 94 |

95 |
96 | 97 |
98 | 99 |
100 |

2 Installation

101 |
102 | 103 | 104 |

105 | LoL has a load of dependencies, which themselves depend on others, 106 | etc. The best way to deal with this is to use clbuild, a library 107 | management tool. 108 |

109 |

110 | If you'd prefer to manage your libraries manually, the dependencies, 111 | according to clbuild, are : 112 |

113 |

114 | alexandria arnesi bordeaux-threads cl-base64 cl-fad cl-mime cl-ppcre 115 | cl-qprint closer-mop contextl iterate lift local-time lw-compat 116 | net-telent-date parenscript parse-number portable-threads puri rfc2109 117 | slime split-sequence trivial-garbage ucw usocket yaclml 118 |

119 |

120 | All libraries should be installed from version control where available. 121 |

122 |
123 | 124 |
125 | 126 |
127 |

3 Describing the domain with the MAO protocol.

128 |
129 | 130 | 131 |

132 | LoL uses a protocol it calls Meta-Attributed Objects, or MAO, as the 133 | basis of its display mechanism. In MAO, we create context-aware 134 | DESCRIPTIONs of objects, and those descriptions are used to generate 135 | the display of the object itself. By having these external 136 | descriptions change based on the context in which they are used, a few 137 | generic components can come together to create complex interfaces. 138 |

139 | 140 |
141 | 142 |
143 |

3.1 Descriptions

144 |
145 | 146 |

Descriptions are a similar conceptually to classes. Every Lisp object 147 | has one, and the root description that all descriptions inherit from 148 | is known as T. FIND-DESCRIPTION is used to, well, find descriptions. 149 |

150 | 151 | 152 | 
  (find-description t) 
153 |   => #<DESCRIPTION T {B7B9861}>
154 |
155 | 156 | 157 |
158 | 159 |
160 | 161 |
162 |

3.2 Attributes and Properties

163 |
164 | 165 |

A description is a collection of ATTRIBUTEs, among other things. Each 166 | attribute describes a part of an object, and any number of attributes 167 | may or may not be active. The ATTRIBUTES function is used to find a 168 | the list attributes that are both active and applicable in the current 169 | context. 170 |

171 | 172 | 173 | 
(attributes (find-description t))
174 | =>(#<ATTRIBUTE IDENTITY {BBC9691}> 
175 |    #<ATTRIBUTE TYPE {BBC96A1}>
176 |    #<ATTRIBUTE CLASS {BBC96B1}>)
177 |
178 | 179 | 180 |

181 | The functions DESCRIPTION-ATTRIBUTES, DESCRIPTION-ACTIVE-ATTRIBUTES 182 | and DESCRIPTION-CURRENT-ATTRIBUTES return all the descriptions 183 | attributes, Attributes that are currently active regardless of 184 | context, and attributes that exist in the current context but may or 185 | may not be active, respectively. 186 |

187 |

188 | Attributes have properties, for example ATTRIBUTE-LABEL and 189 | ATTRIBUTE-VALUE. By simply iterating through the attributes of a 190 | described object, we can create a generic display for any lisp 191 | object. This is very similar, and was inspired by the technique 192 | outlined by Adrian Lienhard in MEWA: A Meta-level Architecture for Generic Web-Application Construction_. 193 |

194 | 195 |

196 | For attribute properties to be useful, the description must be 197 | associated with the object it is meant to describe. 198 |

199 |

200 | The function FUNCALL-WITH-DESCRIBED-OBJECT takes care of setting up 201 | the proper context. There is some syntax for it in the form of 202 | WITH-DESCRIBED-OBJECT : 203 |

204 | 205 | 206 | 
207 | (let ((description (find-description t))
208 |            (object "Hello World"))
209 |        (with-described-object (object description)
210 |          (dolist (a (attributes description))
211 |            (format t "~@[~A: ~]~A~%" 
212 |                    (attribute-label a)
213 |                    (attribute-value a)))))
214 | =>
215 | Hello World
216 | Type: (SIMPLE-ARRAY CHARACTER (11))
217 | Class: #<BUILT-IN-CLASS SB-KERNEL::SIMPLE-CHARACTER-STRING>
218 | 
219 | NIL
220 |
221 | 222 | 223 |

224 | FUNCALL-WITH-DESCRIBED-OBJECT binds two specials, DESCRIPTION and 225 | OBJECT, to its arguments. Knowing this, we can shorten our code 226 | somewhat. Later on we'll be far away from the lexical bindings of 227 | description and object, so these special variables are essential. 228 |

229 |

230 | Another reason for the description variable is that 231 | WITH-DESCRIBED-OBJECT will use DESCRIPTION-OF to determine the 232 | description if the DESCRIPTION argument is NIL 233 |

234 | 235 | 236 | 
(with-described-object ("Hello World" nil)
237 |   (dolist (a (attributes *description*))
238 |     (format t "~@[~A: ~]~A~%" 
239 |             (attribute-label a)
240 |             (attribute-value a))))
241 | 
242 | Lets wrap that up in a function that we can re-use. LoL includes an
243 | entire DISPLAY mechanism that is slightly more involved, but this
244 | serves as an excellent example with not bogging us down in details.
245 | 
246 | #+BEGIN_SRC lisp
247 | (defun present (object &optional description) 
248 |   (with-described-object (object description)
249 |     (dolist (a (attributes *description*))
250 |       (format t "~@[~A: ~]~A~%" 
251 |               (attribute-label a)
252 |               (attribute-value a)))))
253 |
254 | 255 | 256 |
257 | 258 |
259 | 260 |
261 |

3.3 Contexts

262 |
263 | 264 | 265 |

266 | MAO adds to MEWA the concept of dynamic context. By changing the 267 | context in which an object is described, we combine and specialize the 268 | generic displays, ultimately creating different views of our 269 | objects. LoL uses ContextL extensively. Descriptions are contextl 270 | layers, and attributes themselves are layered classes. Most of the 271 | exported functions are layered methods, and the idea of dynamic 272 | context-sensitivity is used throughout LoL. If you're not familiar 273 | with contextl, don't worry, LoL mostly stands on its own. Still, 274 | reading through the material on contextl won't hurt. 275 |

276 |

277 | Descriptions may have different attributes dependant on what 278 | description contexts (or layers) are currently active. Attributes 279 | themselves might have different properties. 280 |

281 |

282 | When an object is being described (using WITH-DESCRIBED-OBJECT), it is 283 | also activated as a layer context. One can also activate/deactivate 284 | contexts manually, using WITH-ACTIVE-DESCRIPTIONS and 285 | WITH-INACTIVE-DESCRIPTIONS. 286 |

287 |

288 | Hopefully a little code will make this more clear : 289 |

290 | 291 | 292 | 
(present "Hello World")
293 | =>
294 | Hello World
295 | Type: (SIMPLE-ARRAY CHARACTER (11))
296 | Class: #<BUILT-IN-CLASS SB-KERNEL::SIMPLE-CHARACTER-STRING>
297 | Simple character string
298 | 
299 | ;; Now we'll activate a built-in description, INLINE.
300 | 
301 | (with-active-descriptions (inline)
302 |   (present "Hello World"))
303 | =>
304 | Hello World
305 |
306 | 307 | 308 |

309 | You can see that the behavior of PRESENT changed when the INLINE 310 | context was activated. This is the key innovation that makes LoL so 311 | useful. In the next chapter we'll create our own descriptions and 312 | demonstrate this further. 313 |

314 |
315 |
316 | 317 |
318 | 319 |
320 |

4 Defining and Using Descriptions

321 |
322 | 323 | 324 | 325 |
326 | 327 |
328 |

4.1 Defining a simple description

329 |
330 | 331 |

The basics of the MAO should now (hopefully) be clear, so lets start 332 | using it. First, we'll create our very own description. 333 |

334 | 335 | 336 | 
(define-description hello-world ()
337 |   ((title :value "Lisp on Lines Demo")
338 |    (identity :label "Message")
339 |    (length :label "Length" :function #'length)
340 |    (active-attributes :value '(title identity length))))
341 |
342 | 343 | 344 |

345 | Descriptions are defined very much like CLOS classes, and are in fact 346 | implemented that way, inheritance rules apply. The object returned 347 | from FIND-DESCRIPTION is best described as a prototype-based 348 | singleton. In other words, there is only one instance, and it inherits 349 | attributes and properties from further up its hierarchy unless 350 | specifically overridden. 351 |

352 |

353 | Attributes can have any number of properties, (see the class 354 | STANDARD-ATTRIBUTE), but the three most important are accessed via the 355 | methods ATTRIBUTE-LABEL, ATTRIBUTE-VALUE and ATTRIBUTE-FUNCTION,and 356 | named (in DEFINE-DESCRIPTION forms and elsewhere) 357 | by the :label, :value, and :function keywords. 358 |

359 |

360 | ATTRIBUTE-LABEL is simply a textual label that describes the 361 | attribute. ATTRIBUTE-VALUE is defined to return the result of calling 362 | ATTRIBUTE-FUNCTION with the object as its argument. If 363 | ATTRIBUTE-FUNCTION is NIL, the value of the :value property is returned 364 | directly. 365 |

366 |

367 | In the example above, the IDENTITY and ACTIVE-ATTRIBUTES attributes 368 | are inherited from T, and we are simply overriding the default 369 | properties for our description. LENGTH and TITLE are specific to this 370 | description. A look at src/standard-descriptions/t.lisp may be 371 | instructive at this point. 372 |

373 |

374 | Now, we can present our object using our new description. 375 |

376 | 377 | 378 | 
(present "Hello World" (find-description 'hello-world))
379 | =>
380 | Lisp on Lines Demo
381 | Message: Hello World
382 | Length: 11
383 | 
384 | NIL
385 |
386 | 387 | 388 |
389 | 390 |
391 | 392 |
393 |

4.2 Using descriptions as and with contexts.

394 |
395 | 396 | 397 |

398 | A we mentioned earlier, when an object is being described, the 399 | 'description context' is also made active. On top of that, one can 400 | define partial descriptions that are only active when other 401 | description contexts have been activated. 402 |

403 |

404 | We'll make a ONE-LINE description similar to the INLINE description 405 | demonstrated earlier. 406 |

407 | 408 | 409 | 
(define-description one-line ())
410 | 
411 | (define-description hello-world ()
412 |   ((identity :label nil)
413 |    (active-attributes :value '(identity)))
414 |   (:in-description one-line))
415 | 
416 |
417 | 418 | 419 |

420 | Here we've defined a new description, ONE-LINE, and a 421 | context-sensitive extension to our HELLO-WORLD description. This 422 | partial desription will be active only when in the context of a 423 | one-line description. One can have attributes that only exist in 424 | certain description contexts, and attributes can have different 425 | properties. 426 |

427 | 428 | 429 | 
(let ((message "Hello World!")
430 |       (description (find-description 'hello-world)))
431 |   (print :normal)(terpri)
432 |   (present message description)       
433 |   (print :one-line)(terpri)
434 |   (with-active-descriptions (one-line)
435 |     (present message description)))
436 | =>
437 | :NORMAL 
438 | Lisp on Lines Demo
439 | Message: Hello World!
440 | Length: 12
441 | 
442 | :ONE-LINE 
443 | Hello World!
444 | 
445 | NIL
446 |
447 | 448 | 449 |

450 | By activating the description ONE-LINE, we've changed the context in 451 | which our object is displayed. We can create any number of 452 | descriptions and contexts and activate/deactivate them in any order. 453 |

454 |

455 | Descriptions are implemented as ContextL 'layers', so if all 456 | this seems weird, reading the ContextL papers might help. 457 |

458 |
459 | 460 |
461 | 462 |
463 |

4.3 T : The root of all descriptions.

464 |
465 | 466 | 467 |

468 | Because all descriptions inherit from T, we can define contexts for T 469 | and they will apply to every description. The INLINE description can 470 | be found in standard-descriptions/inline.lisp, where we define 471 | a desription for T in the context of the INLINE description : 472 |

473 | 474 | 475 | 
;; Defined by LoL in inline.lisp :
476 | (define-description t ()
477 |   ((identity :label nil)
478 |    (active-attributes :value '(identity))
479 |    (attribute-delimiter :value ", ")
480 |    (label-formatter :value (curry #'format nil "~A: "))
481 |    (value-formatter :value (curry #'format nil "~A")))
482 |   (:in-description inline))}
483 | 
484 |
485 | 486 | 487 |

488 | The does for the LoL DISPLAY mechanism what ONE-LINE did for PRESENT, 489 | only with more magic. By exetending T in this way, it's easy to create 490 | contexts the redefine the behavior of LoL while still reusing the basics. 491 |

492 |
493 | 494 |
495 | 496 |
497 |

4.4 DESCRIPTION-OF : Permanently Associate a description with a class.

498 |
499 | 500 | 501 |

502 | The LAYERED-FUNCTION DESCRIPTION-OF will return the description 503 | associated with an object. 504 |

505 | 506 | 507 | 
508 | (description-of nil)
509 | =>
510 | #<DESCRIPTION NULL {AA04F49}>
511 | 
512 | (description-of t)
513 | =>
514 | #<DESCRIPTION SYMBOL {AA04541}>
515 | 
516 | (description-of '(1 2 3))
517 | =>
518 | #<DESCRIPTION CONS {AA04C29}>
519 | 
520 | ;;etc
521 | 
522 |
523 | 524 | 525 |
526 |
527 | 528 |
529 | 530 |
531 |

5 The DISPLAY Protocol

532 |
533 | 534 | 535 |

536 | Our function, PRESENT, is very basic, though pretty powerful when 537 | combined with descriptions and contexts. LoL includes a superset of 538 | such functionality built-in. 539 |

540 |

541 | The main entry point into this protocol is the DISPLAY 542 | function. The signature for this functions is : 543 |

544 | 545 | 546 | 
(display DISPLAY OBJECT &REST ARGS &KEY DEACTIVATE ACTIVATE &ALLOW-OTHER-KEYS)
547 |
548 | 549 | 550 |

551 | The first argument, DISPLAY, is the place where we will display 552 | to/on/in/with. It could be a stream, a UCW component, a CLIM gadget, 553 | or anything else you might want to use. 554 |

555 |

556 | One can specialize on this argument (though it's better to specialize 557 | DISPLAY-USING-DESCRIPTION… more on that later) to use generic 558 | descriptions to display objects in different environments. 559 |

560 |

561 | The second argument is simply the object to be displayed. Here's a 562 | simple example : 563 |

564 | 565 | 566 | 
(display t t)
567 | =>
568 | T
569 | Type:BOOLEAN
570 | Class:#<BUILT-IN-CLASS SYMBOL>
571 | Symbol
572 | Name:T
573 | Value:T
574 | Package:#<PACKAGE "COMMON-LISP">
575 | Function:<UNBOUND>
576 | ; No value
577 |
578 | 579 | 580 |

581 | The two arguments specified in the lambda-list, ACTIVATE and 582 | DEACTIVATE, are used to activate and deactivate description contexts in 583 | the scope of the display function. 584 |

585 | 586 | 587 | 
588 | (display nil t :activate '(inline))
589 | => 
590 | "t"
591 | (with-active-descriptions (inline) 
592 |  (display nil t :deactivate '(inline))) 
593 | =>
594 | "T
595 | Type:BOOLEAN
596 | Class:#<BUILT-IN-CLASS SYMBOL>
597 | Symbol
598 | Name:T
599 | Value:T
600 | Package:#<PACKAGE \"COMMON-LISP\">
601 | Function:<UNBOUND>"
602 | 
603 |
604 | 605 | 606 |

607 | Any other keyword arguments passed will be used to set the value of an 608 | attribute with a :keyword property, in the dynamic context of the 609 | DISPLAY function call. Once such attribute, and a very useful one is 610 | ACTIVE-ATTRIBUTES with its :attributes keyword : 611 |

612 | 613 | 614 | 
615 | (display t t :attributes '(class package))
616 | =>
617 | Class:#<BUILT-IN-CLASS SYMBOL>
618 | Package:#<PACKAGE "COMMON-LISP">
619 | 
620 |
621 | 622 | 623 |

624 | The properties of attributes that do not have a :keyword property can 625 | also be set dynamically. Since :attributes is the :keyword property of 626 | the ACTIVE-ATTRIBUTES attribute, the following form is equivalent to 627 | the previous : 628 |

629 | 630 | 631 | 
(display t t  :attributes '((active-attributes 
632 |                              :value (class package))))
633 | =>
634 | Class:#<BUILT-IN-CLASS SYMBOL>
635 | Package:#<PACKAGE "COMMON-LISP">
636 |
637 | 638 | 639 |

640 | Setting the attributes this way is almost like creating an anonymous 641 | description context… you can express just about anything you would 642 | in a DEFINE-DESCRIPTION. Here's a more involved example : 643 |

644 | 645 | 646 | 
(display t t  :attributes `((identity :label "The Object") 
647 |                             (class :label "CLOS Class")
648 |                             (package :value "COMMON LISP" :function nil)
649 |                             (type :value-formatter 
650 |                                   ,(lambda (a)
651 |                                     (format nil "Got a value? ~A" a)))))
652 | =>
653 |                                  
654 | The Object:T
655 | CLOS Class:#<BUILT-IN-CLASS SYMBOL>
656 | Package:COMMON LISP
657 | Type:Got a value? BOOLEAN
658 | 
659 |
660 | 661 | 662 |

663 | I hope that serves well to demonstrate the concepts behind LoL, as 664 | there is no API documentation available at the moment… use the 665 | source luke! 666 |

667 | 668 |
669 | 670 |
671 | 672 |
673 |

6 Automatic Descriptions for CLOS classes.

674 |
675 | 676 | 677 |

678 | Lisp-on-Lines includes a compose-able metaclass, DESCRIBED-CLASS. It 679 | can be combined with any other metaclass without affecting the 680 | behavior of that class. DESCRIBED-CLASS has been used with the 681 | metaclasses provided by CLSQL, ROFL, Rucksack and UCW simply by 682 | defining a class that inherits from both metaclasses. 683 |

684 |

685 | DESCRIBED-CLASS creates a base description for the class, named 686 | DESCRIPTION-FOR-<class>, and another description with the same name 687 | as the class that has the previous description as a superclass. The 688 | then defines a method on DESCRIPTION-OF that returns the second 689 | description. 690 |

691 |

692 | LoL includes DESCRIBED-STANDARD-CLASS, which is subclass of 693 | STANDARD-CLASS and DESCRIBED-CLASS. We'll use this to create a class 694 | and its description. 695 |

696 | 697 | 698 | 
699 | (defclass person ()
700 |   (first-name last-name company-name 
701 |    date-of-birth phone fax email 
702 |    address city province postal-code)
703 |   (:metaclass described-standard-class))
704 | =>
705 | #<DESCRIBED-STANDARD-CLASS PERSON>
706 | 
707 | (display t (make-instance 'person))
708 | =>
709 | First name:#<UNBOUND>
710 | Last name:#<UNBOUND>
711 | Company name:#<UNBOUND>
712 | Date of birth:#<UNBOUND>
713 | Phone:#<UNBOUND>
714 | Fax:#<UNBOUND>
715 | Email:#<UNBOUND>
716 | Address:#<UNBOUND>
717 | City:#<UNBOUND>
718 | Province:#<UNBOUND>
719 | Postal code:#<UNBOUND>
720 | 
721 |
722 | 723 | 724 | 725 |
726 | 727 |
728 |

6.1 Described CLOS objects an the EDITABLE description

729 |
730 | 731 | 732 |

733 | The slots of an object are SETF'able places, and LoL takes 734 | advantage of that to provide EDITABLE descriptions 735 | automatically. When the EDITABLE description is active, and editor 736 | will be presented. The REPL based editor is pretty basic, but still 737 | useful. The HTML based editor will be described later. 738 |

739 | 740 | 741 | 742 | 
(defun edit-object (object &rest args)
743 |   (with-active-descriptions (editable)
744 |     (apply #'display t object args)))
745 | 
746 | (let ((object (make-instance 'person)))
747 |   (edit-object object)
748 |   (terpri)
749 |   (display t object))
750 | 
751 | ;; What follows are prompts and the information i entered
752 |        
753 | First name:Drew
754 | 
755 | Last name:Crampsie
756 | 
757 | Company name:The Tech Co-op
758 | 
759 | Date of birth:1978-07-31
760 | 
761 | Phone:555-5555
762 | 
763 | Fax:555-5555
764 | 
765 | Email:drewc@tech.coop
766 | 
767 | Address:s/v Kanu, Lower Fraser River
768 | 
769 | City:Richmond
770 | 
771 | Province:BC
772 | 
773 | Postal code:V1V3T6
774 | 
775 | ;; And this is what was displayed.
776 | 
777 | First name:Drew
778 | Last name:Crampsie
779 | Company name:The Tech Co-op
780 | Date of birth:1978-07-31
781 | Phone:555-5555
782 | Fax:555-5555
783 | Email:drewc@tech.coop
784 | Address:s/v Kanu, Lower Fraser River
785 | City:Richmond
786 | Province:BC
787 | Postal code:V1V3T6
788 |
789 | 790 | 791 |
792 | 793 |
794 | 795 |
796 |

6.2 Extending the generated description

797 |
798 | 799 | 800 |

801 | We mentioned earlier that DESCRIBED-CLASS creates two descriptions : 802 |

803 | 804 | 805 | 
806 | (find-description 'description-for-person)
807 | =>
808 | #<DESCRIPTION DESCRIPTION-FOR-PERSON {D296DE1}>
809 | 
810 | (find-description 'person)
811 | =>
812 | #<DESCRIPTION PERSON {ADFEDB1}>
813 | 
814 | (description-of (make-instance 'person))
815 | =>
816 | #<DESCRIPTION PERSON {ADFEDB1}>
817 | 
818 |
819 | 820 | 821 | 822 |

823 | The reason for this is so we can redefine the description PERSON while 824 | keeping all the generated information from DESCRIPTION-FOR-PERSON. 825 |

826 |

827 | In this case, we will add an attribute, PERSON-AGE, that calculates 828 | a persons age based on the data in the date-of-birth slot. 829 |

830 | 831 | 832 | 833 | 834 | 835 | 836 | 837 | 838 | 839 | 840 | 841 | 842 |
843 |
844 | 845 |
846 | 847 |
848 |

7 Using Lisp-on-Lines for the Web.

849 |
850 | 851 | 852 |

853 | LoL was developed, and is primarily used, for implementing 854 | data-driven web applications. As such, it comes with a host of 855 | features for doing just that. 856 |

857 |

858 | LoL, by default, implements its web portion on top of the wonderful 859 | UnCommon Web meta-framework. The LISP-ON-LINES-UCW ASDF system 860 | should be loaded, as it provides the features we're going to 861 | discuss. 862 |

863 | 864 | 865 | 866 | 867 | 868 | 869 | 870 | 871 | 872 | 873 | 874 | 875 | 876 | 877 |
878 |
879 |

Author: Drew Crampsie 880 | <Drew Crampsie > 881 |

882 |

Date: 2009/07/27 01:46:25 PM

883 |

HTML generated by org-mode 6.05 in emacs 22

884 |

885 | 886 | --------------------------------------------------------------------------------