(:module :src
:components ((:file "packages")
(:file "utilities")
+
(:file "display")
(:file "attribute")
(:file "description-class")
- (:file "description")
-
- (:file "description-test")
- (:file "attribute-test"))
+ (:file "description"))
:serial t))
:serial t
- :depends-on (:contextl))
+ :depends-on (:contextl :arnesi))
(defsystem :lisp-on-lines.test
:components ((:module :src
- :components ((:file "description-test")
- (:file "attribute-test"))
+ :components ((:file "packages-test")
+ (:file "description-test")
+ (:file "attribute-test")
+ (:file "display-test"))
:serial t))
:depends-on (:lisp-on-lines :stefil))
(defmethod eval-attribute-initarg (attribute (initarg (eql :function)))
t)
-
(define-layered-function attribute-value (object attribute))
-(define-layered-method attribute-value (object attribute)
- (funcall (attribute-function attribute) object))
+
(deflayer LISP-ON-LINES)
(ensure-active-layer 'lisp-on-lines)
(initargs))
(defmethod shared-initialize :around ((instance attribute-special-layered-direct-slot-definition) slots &rest initargs )
- (setf (slot-value instance 'initargs) (apply #'arnesi:remove-keywords initargs *standard-direct-slot-initarg-symbols*))
+ (setf (slot-value instance 'initargs)
+ (apply #'arnesi:remove-keywords initargs *standard-direct-slot-initarg-symbols*))
(call-next-method))
(define-layered-class standard-attribute
:initarg :value
:layered t)))
+(define-layered-method attribute-value (object attribute)
+ (funcall (attribute-function attribute) object))
+
+
+
(defmethod shared-initialize :around ((attribute standard-attribute) slots &rest initargs)
(declare (ignore initargs))
(setf (attribute-function attribute)
((attribute standard-attribute) display object &rest args)
(declare (ignore args))
(format display "~@[~A ~]~A" (attribute-label attribute)
- (display display (attribute-value object attribute))))
+ (attribute-value object attribute)))
(let ((before (display-using-description
(find-description 'attribute-test-2)
- nil *object*)))
+ nil :foo)))
(with-active-layers (test-display)
(is (equalp "BRILLANT!" (display-using-description
(find-description 'attribute-test-2)
- nil *object*))))))
+ nil :foo))))))
\ No newline at end of file
--- /dev/null
+
+(cl:defpackage #:lol-test
+ (:use #:cl #:lisp-on-lines #:stefil #:contextl))
\ No newline at end of file
(defpackage #:lisp-on-lines
(:use
- #:common-lisp
- #:contextl)
+ :common-lisp
+ #:contextl)
(:nicknames #:lol)
-
(:export
-
+
+;; Descriptions
#:find-description
- #:ensure-description
#:define-description
-
+
+ ;; Displays
#:define-display
#:display
+ #:display-using-description
#:*display*
#:*object*
+ ;; Attributes
#:find-attribute
#:attribute-label
+ #:attribute-function
+ #:attribute-value))
+
-(cl:defpackage #:lol-test
- (:use #:cl #:lisp-on-lines #:stefil #:contextl))
--- /dev/null
+(in-package :lisp-on-lines)
+
+(defun make-enclosing-package (name)
+ (make-package name :use '()))
+
+(defgeneric enclose-symbol (symbol package)
+ (:method ((symbol symbol)
+ (package package))
+ (if (symbol-package symbol)
+ (intern (format nil "~A::~A"
+ (package-name (symbol-package symbol))
+ (symbol-name symbol))
+ package)
+ (or (get symbol package)
+ (setf (get symbol package) (gensym))))))
+
+#|
+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.
+|#
+
+
+(defvar *description-definers*
+ (make-enclosing-package "DESCRIPTION-DEFINERS"))
+
+(defun defining-description (name)
+ "Takes the name of a layer and returns its internal name."
+ (case name
+ ((t) 't)
+ ((nil) (error "NIL is not a valid description name."))
+ (otherwise (enclose-symbol name *description-definers*))))
+
+
+(defmethod initargs.slot-names (class)
+ "Returns ALIST of (initargs) . slot-name."
+ (nreverse (mapcar #'(lambda (slot)
+ (cons (closer-mop:slot-definition-initargs slot)
+ (closer-mop:slot-definition-name slot)))
+ (closer-mop:class-slots class))))
+
+(defun find-slot-name-from-initarg (class initarg)
+ (cdr (assoc-if #'(lambda (x) (member initarg x))
+ (initargs.slot-names class))))
+
+
+;;;!-- TODO: this has been so mangled that, while working, it's ooogly!
+(defun initargs-plist->special-slot-bindings (class initargs-plist)
+ "returns a list of (slot-name value) Given a plist of initargs such as one would pass to :DEFAULT-INITARGS."
+ (let ((initargs.slot-names-alist (initargs.slot-names class)))
+ (loop for (initarg value) on initargs-plist
+ nconc (let ((slot-name
+ ))
+ (when slot-name ;ignore invalid initargs. (good idea/bad idea?)
+ (list slot-name value))))))
+
+
+