I have this parenscript macro:
;;; Parenscript macro for showModal() and close() methods for pop-up dialogs.
;;;Takes the dialog's id, button for opening the dialog's id, and closing button's id.
(defpsmacro open-close-modal-dialog (dialog-id element-id-1 element-id-2 &key open close open-args close-args)
(let ((dialog (ps-gensym)))
`(progn
(setf ,dialog (chain document (get-element-by-id ,dialog-id)))
(setf (chain document (get-element-by-id ,element-id-1) onclick)
(lambda (,#open-args)
(progn
,#open
(funcall (chain ,dialog show-modal)))))
(setf (chain document (get-element-by-id ,element-id-2) onclick)
(lambda (,#close-args)
(progn
,#close
(funcall (chain ,dialog close))))))))
And I'm using it in a Hunchentoot handler like so:
(define-easy-handler (student-name :uri "/student-info") (name)
(let ((student (student-from-name name)))
(standard-page (:title "Ashtanga Yoga Osaka | Student Page"
:script (ps
(defun init ()
(open-close-modal-dialog "editPassDialog" "getPass" "submitPass"
;; This is the pop-up dialog
:open (ps(defvar frm (chain document (get-element-by-id "editPass"))))))
(setf (chain window onload) init)))
;; Main form
(:form :action "/edit-student" :method "post" :id "editStudent"
(:p "Name" (:input :type "text" :name "name" :class "txt" :value (format nil "~A" (name student))))
(:P "Email" (:input :type "email" :name "email" :class "txt" :value (format nil "~A" (email student))))
(:p "Passes" (:select :name "passlist"
(dolist (pass (pass student))
(htm
(:option :id "pass" :value (pass->json pass)
(fmt "~A ~A" (print-month (getf pass :date))
(print-year (getf pass :date)))))))
(:button :type "button" :id "getPass" :class "btn" "Get Pass"))
(:input :type "hidden" :name "previous" :value nil) ; previous value of the pass
(:input :type "hidden" :name "old-name" :value name) ; old name of student, used for retrieving the correct instance
(:p (:input :type "submit" :value "Edit Info" :class "btn")))
;; Pop-up dialog for editing passes
(:dialog :id "editPassDialog"
(:h1 "Edit Pass")
(:form :action "#" :method "post" :id "editPass"
(:p "Date bought" (:input :type "text" :name "date" :class "txt"))
(:p "Type" (:input :type "text" :name "type" :class "txt"))
(:p "Amount Paid" (:input :type "text" :name "amt"))
(:p (:button :type "button" :class "btn" :id "submitPass" "Edit Pass")))))))
Now when I load the system through Quicklisp, I get this error:
; caught ERROR:
; during macroexpansion of
; (PS
; (DEFUN INIT # ...)
; (SETF #)).
; Use *BREAK-ON-SIGNALS* to intercept.
;
; The Parenscript form (DEFVAR FRM
; (CHAIN DOCUMENT
; (GET-ELEMENT-BY-ID
; editPass))) cannot be compiled into an expression.
Which is strange, because I can define this form in the REPL:
SHALA-SYS> (macroexpand-1 '(ps (defvar frm (chain document (GET-ELEMENT-BY-ID "editPass")))))
"var frm = document.getElementById('editPass');"
And if I remove the :open and it's arguments, the system loads, then I add :open and args back in and recompile the handler and it compiles without a problem.
Any thoughts?
This will happen if you have both the defpsmacro and the use of the defined macro in the same file. I haven't had the time to dig into parenscript code deep enough to understand what exactly goes wrong with the order of evaluation, but the end result is that, when compiling the file, the macro definition does not exist at the time of the 'compilation' of the ps form.
As a solution, move your parenscript macros into a separate file and make your other code files depend on it.
As a side note, the (ps ...) form on the :open keyword argument is unnecessary - the open parameter is already expanded inside parenscript code in your macro. Additionally, ,# is incorrect at the expansion of open as well - and these two bugs happen to cancel each other.
(progn
,#open
(funcall (chain ,dialog show-modal)))
;; with :open (ps (foo)) expands to
"ps; foo(); dialog.showModal();"
;; and with :open (foo) expands to
"foo; dialog.showModal();"
(progn
,open
(funcall (chain ,dialog show-modal)))
;; would expand :open (ps (foo)) to
"ps(foo()); dialog.showModal();"
;; and :open (foo) to
"foo(); dialog.showModal();"
;; which is what you intended.
Also, funcall is not necessary in that piece of code; you could simply use (chain ,dialog (show-modal)).
Ok so it seems I didn't (still don't) understand how the defpsmacro works. Changing that with a normal defmacro wrapped in a ps form solved the problem.
So the macro code is now:
(ps (defmacro open-close-modal-dialog (dialog-id element-id-1 element-id-2 &key open close open-args close-args)
(let ((dialog (ps-gensym)))
`(progn
(setf ,dialog (chain document (get-element-by-id ,dialog-id)))
(setf (chain document (get-element-by-id ,element-id-1) onclick)
(lambda (,#open-args)
(progn
,#open
(funcall (chain ,dialog show-modal)))))
(setf (chain document (get-element-by-id ,element-id-2) onclick)
(lambda (,#close-args)
(progn
,#close
(funcall (chain ,dialog close)))))))))
If any ParenScript expert can explain what was wrong I'd be much obliged.
Related
I am working through the MP3 database example in Peter Seibel's Practical Common Lisp. Seibel demonstrates how macros can be used to shorten the code for the where function; so now, I am trying to use a macro to shorten the code for the update function. (The original version of the update function is included for reference.) When I run my code, the following error originates from the second-to-last line --
*** - CAR: TERMS is not a list
What am I doing wrong? Here is my code.
(defvar *db* nil)
(defun add-record (cd)
(push cd *db*))
(defun dump-db ()
(dolist (cd *db*)
(format t "~{~a:~10t~a~%~}~%" cd)))
(defun make-cd (title artist rating ripped)
(list :title title :artist artist :rating rating :ripped ripped))
(defun prompt-read (prompt)
(format *query-io* "~a: " prompt)
(force-output *query-io*)
(read-line *query-io*))
(defun prompt-for-cd ()
(make-cd
(prompt-read "Title")
(prompt-read "Artist")
(or (parse-integer (prompt-read "Rating") :junk-allowed t) 0)
(y-or-n-p "Ripped [y/n]: ")))
(defun add-cds ()
(loop (add-record (prompt-for-cd) )
(if (not (y-or-n-p "Another? [y/n]: ")) (return) )))
(defun save-db (filename)
(with-open-file (out filename
:direction :output
:if-exists :supersede)
(with-standard-io-syntax
(print *db* out))))
(defun load-db (filename)
(with-open-file (in filename)
(with-standard-io-syntax
(setf *db* (read in) ))))
(defun select (selector-fn)
(remove-if-not selector-fn *db*))
(defun make-comparison-expr (field value)
`(equal (getf cd ,field) ,value))
(defun make-comparison-list (func fields)
(loop while fields
collecting (funcall func (pop fields) (pop fields))))
(defmacro where (&rest clauses)
`#'(lambda (cd) (and ,#(make-comparison-list 'make-comparison-expr clauses))))
(defun make-update-expr (field value)
`(setf (getf row ,field) ,value))
(defmacro make-update-list (fields)
(make-comparison-list 'make-update-expr fields))
(defun update (selector-fn &rest terms)
(print (type-of terms))
(setf *db*
(mapcar
#'(lambda (row)
(when (funcall selector-fn row)
(make-update-list terms))
row)
*db*)))
;(defun update (selector-fn &key title artist rating (ripped nil ripped-p))
; (setf *db*
; (mapcar
; #'(lambda (row)
; (when (funcall selector-fn row)
; (if title (setf (getf row :title) title) )
; (if artist (setf (getf row :artist) artist) )
; (if rating (setf (getf row :rating) rating) )
; (if ripped-p (setf (getf row :ripped) ripped) ))
; row)
; *db*)))
(defun delete-rows (selector-fn)
(setf *db* (remove-if selector-fn *db*)))
;(loop (print (eval (read))))
(add-record (make-cd "Be" "Common" 9 nil))
(add-record (make-cd "Like Water for Chocolate" "Common" 9 nil))
(add-record (make-cd "Be" "Beatles" 9 nil))
(dump-db)
(update (where :artist "Common" :title "Be") :rating 8)
(dump-db)
-----Edit-----
I figured it out. The solution was to make update a macro and to make make-update-list a function. This way, make-update-list could evaluate fields at run-time and update can still abstract away some tedious if statements. Here is the updated update and make-update-list below:
(defun make-update-list (fields)
(make-comparison-list 'make-update-expr fields))
(defmacro update (selector-fn &rest terms)
`(setf *db*
(mapcar
#'(lambda (row)
(when (funcall ,selector-fn row)
,#(make-update-list terms))
row)
*db*)))
Macroexpansion of that make-update-list is done in a separate phase (called "macroexpansion phase") - which occurs around the time a piece of code is compiled or loaded; in this case we're talking about compilation / loading of update. The macro gets expanded with fields bound to the symbol terms, which (the symbol itself) is used as a value in make-comparison-list; I suppose that was not what you expected.
Note, if you go and compile the file line-by-line (C-c C-c in Emacs + SLIME), it'll tell you right during compilation of update that the macro expansion fails because "the value TERMS is not of type LIST".
Generally, think of macros as functions that take in their arguments unevaluated - i.e. a form (make-update-list foo) will get expanded with the macro parameter's fields value bound to foo. What you're trying to achieve here - code generation based on run-time values - is a bit more difficult to do.
You are trying to take the car of a symbol!
> (car 'terms)
*** - CAR: TERMS is not a list
Think of macros as a function that, when used, replaces the code with the result of the macro function everywhere it's used. At this time variables are just symbols and have no meaning besides that.
When you do (make-update-list terms) it will call the macro function with the argument fields being the symbol you passed, which is terms. Since it's a symbol it cannot be iterated like you are trying. You may iterate it at runtime when it surely is a list, but as a macro it isn't a list until you are passing it a list like (make-update-list (title artist rating ripped)).
If it is dynamic in runtime then your macro needs to expand to code that does most of its magic at runtime. Thus a macro is just a source rewriting service and should not have anything to do with what variable might be at runtime since then it has already done its thing.
When accessing class slots, instead of writing
(defmethod get-name ((somebody person) (slot-value somebody 'name))
is it possible to use the dot notation aka C++, namely
(defmethod get-name ((somebody person) somebody.name) ?
Otherwise, when there are many slot operations in a method, (slot-value... creates a lot of boilerplate code.
I have figured out the answer today and I am just posting it as a Q&A, but if there are better solutions or there are problems I should expect with my solution, feel free to add new answers or comments.
The library access provides a dot notation reader macro for accessing slots (and hash-tables and other things). After enabling the reader macro by calling (access:enable-dot-syntax) you'll able to use #D. to access a slot name with the dot syntax popular in other languages.
(defclass person ()
((name :initarg :name :reader name)))
CL-USER> (access:enable-dot-syntax)
; No values
CL-USER> (defvar *foo* (make-instance 'person :name "John Smith"))
*FOO*
CL-USER> #D*foo*
#<PERSON #x302001F1E5CD>
CL-USER> #D*foo*.name
"John Smith"
There is also a with-dot macro if you don't want to use a reader macro
CL-USER> (access:with-dot () *foo*.name)
"John Smith"
You should not write accessors by hand, nor use slot-value (outside of object lifecycle functions, where the accessors may not have been created yet). Use the class slot options instead:
(defclass foo ()
((name :reader foo-name
:initarg :name)
(bar :accessor foo-bar
:initarg :bar)))
Now you can use the named accessors:
(defun example (some-foo new-bar)
(let ((n (foo-name some-foo))
(old-bar (foo-bar some-foo)))
(setf (foo-bar some-foo) new-bar)
(values n old-bar)))
Often, you want your classes to be "immutable", you'd use :reader instead of :accessor then, which only creates the reader, not the setf expansion.
The easiest solutions seems to be a reader macro that overloads . so that (slot-value somebody 'name) can be written as .somebody.name My strategy is to read somebody.name as a string (we need to define a non-terminating macro character so that the reader does not stop mid-string), and then process the string to construct the appropriate (slot-value...
I will need two helper functions:
(defun get-symbol (str)
"Make an uppercase symbol"
(intern (string-upcase str)))
(defun split-string (str sep &optional (start 0))
"Split a string into lists given a character separator"
(let ((end (position sep str :start start)))
(cons (subseq str start end) (if end (split-string str sep (1+ end))))))
And then I can define my reader macro:
(defun dot-reader (stream char)
(declare (ignore char))
(labels ((make-query (list)
(let ((car (car list))
(cdr (cdr list)))
(if cdr `(slot-value ,(make-query cdr) (quote ,(get-symbol car)))
(get-symbol car)))))
(make-query (nreverse (split-string (symbol-name (read stream)) #\.)))))
Finally, I need to register this reader macro:
(set-macro-character #\. #'dot-reader t)
Now it is possible to write:
(defmethod get-name ((somebody person) .somebody.name)
or, if name is itself a class,
(defmethod get-name ((somebody person) .somebody.name.first-name)
One restriction is that s-expressions will not work between the dots, say
.(get-my-class).name
won't work.
Say if I define a metaclass that enhances standard slots with a validator slot, when I pass :validator (clavier:valid-email "The email is invalid") as an option, instead of storing the result of of the expression, which is a funcallable, it stores the expression itself. Am I'm missing a step when extending the standard slots? How do I ensure the expression is evaluated before stored? I'm using SBCL 1.2.11 btw. Here is the code in question
(unless (find-package 'clavier)
(ql:quickload :clavier))
(unless (find-package 'c2mop)
(ql:quickload :c2mop))
(defpackage #:clos2web/validation
(:use #:cl)
(:import-from #:c2mop
#:standard-class
#:standard-direct-slot-definition
#:standard-effective-slot-definition
#:validate-superclass
#:direct-slot-definition-class
#:effective-slot-definition-class
#:compute-effective-slot-definition
#:slot-value-using-class))
(in-package #:clos2web/validation)
(defun true (value)
"Always return true."
(declare (ignore value))
t)
(defclass validation-class (standard-class)
()
(:documentation "Meta-class for objects whose slots know how to validate
their values."))
(defmethod validate-superclass
((class validation-class) (super standard-class))
t)
(defmethod validate-superclass
((class standard-class) (super validation-class))
t)
(defclass validation-slot (c2mop:standard-slot-definition)
((validator :initarg :validator :accessor validator :initform #'true
:documentation "The function to determine if the value is
valid. It takes as a parameter the value.")))
(defclass validation-direct-slot (validation-slot
standard-direct-slot-definition)
())
(defclass validation-effective-slot (validation-slot
standard-effective-slot-definition)
())
(defmethod direct-slot-definition-class ((class validation-class) &rest initargs)
(declare (ignore initargs))
(find-class 'validation-direct-slot))
(defmethod effective-slot-definition-class ((class validation-class) &rest initargs)
(declare (ignore initargs))
(find-class 'validation-effective-slot))
(defmethod compute-effective-slot-definition
((class validation-class) slot-name direct-slot-definitions)
(let ((effective-slot-definition (call-next-method)))
(setf (validator effective-slot-definition)
(some #'validator direct-slot-definitions))
effective-slot-definition))
(defmethod (setf slot-value-using-class) :before
(new (class validation-class) object (slot validation-effective-slot))
(when (slot-boundp slot 'validator)
(multiple-value-bind (validp msg)
(funcall (validator slot) new)
(unless validp
(error msg)))))
;; Example usage
(defclass user ()
((name :initarg :name)
(email :initarg :email :validator (clavier:valid-email "The email is invalid") :accessor email))
(:metaclass validation-class))
(let ((pepe (make-instance 'user :name "Pepe" :email "pepe#tumadre.com")))
(setf (email pepe) "FU!")) ;; should throw
The code fails when making an instance as (CLAVIER:VALID-EMAIL "The email is invalid") is not a funcallable.
(CLAVIER:VALID-EMAIL
"The email is invalid") fell through ETYPECASE expression.
Wanted one of (FUNCTION SYMBOL).
[Condition of type SB-KERNEL:CASE-FAILURE]
Like the comment above says, defclass does not evaluate arguments (it is a macro). While the usual advice is to avoid eval, I think that eval in this circumstance might be exactly what you want. While usually you would splice the form directly into some macro body, with defclass I think the answer is to eval the form in slot initialization and store the evaluation (if it has not yet been evaled).
This would probably occur in:
(defmethod initialize-instance :after ((obj validation-slot)
&key &allow-other-keys)
#| ... |#)
Optionally you could also store the :validation-message and :validation-fn as two separate arguments then call:
(multiple-value-bind (validp msg)
(funcall (funcall (validator-fn slot)
(validator-message slot))
new)
(unless validp
(error msg)))
Another alternative would be to store the evaluation of the form and pass that to the macro:
(defvar *email-validator* (CLAVIER:VALID-EMAIL "The email is invalid"))
(defun email-validator (val)
(funcall *email-validator* val))
Then pass email-validator to defclass.
Additionally I might suggest that your validation functions signal slot-validation-error type conditions instead of error type conditions. Then your condition could contain references to the validator that failed, the value, the slot and the instance. This could give you much better control than the raw error. You could also add some restarts (abort to skip setting the slot, use-value to provide a different value).
Depending on your setup, it might also make more sense for your validation function to signal these directly instead of returning multiple values that are then coerced to signals.
(ql:quickload :postmodern)
(defpackage :test-case
(:use :cl)
(:import :pomo))
(in-package :test-case)
;; (defclass dao-class (standard-class)
;; ((direct-keys :initarg :keys :initform nil :reader direct-keys)
;; (effective-keys :reader dao-keys)
;; (table-name)
;; (column-map :reader dao-column-map))
;; (:documentation "Metaclass for database-access-object classes."))
(defclass definition ()
((id :col-type serial :reader definition-id)
(content :col-type string :initarg :content :accessor definition-content)
(word :col-type string :initarg :word :accessor definition-word))
(:metaclass dao-class)
(:keys id))
(pomo:dao-keys 'definition)
;; => (ID)
;; What I am setting with :keys? a slot in the meta class?
https://gist.github.com/PuercoPop/5850773
dao-class has the slot direct-keys, whose :initarg is named :keys, so, if I understand your question correctly, the answer ist: "Yes, (:keys id) provides the value for the direct-keys slot in the meta-class dao-class."
EDIT To be more precise, here, since the wording is not quite clear... dao-class is a meta-class, i.e., a class, whose instances are classes themselves. In this case, the class definition is an instance of dao-class, which has the slot direct-keys (declared in dao-class), and the value of that slot in definition is initialized from the value supplied via the :keys option.
I have a class with a number of slots. I also have a builder function to make objects of that class such that passing the following list '(:id "john" :name "John Doe" :age 42) to that function will construct a new object with those slots values. I will use that function to generate more than one object, using a list of lists.
How can I convert from a keyword like :id to a slot name that SLOT-VALUE can use?
Thanks.
If the keywords are the initargs for the class, then you just can call MAKE-INSTANCE via APPLY:
(defclass person ()
((id :initarg :id )
(name :initarg :name)
(age :initarg :age )))
CL-USER > (mapcar
(lambda (initargs)
(apply #'make-instance 'person initargs))
'((:id "john" :name "John Doe" :age 42)
(:id "mary" :name "Mary Doe" :age 42)))
(#<PERSON 402027AB7B> #<PERSON 402027AC33>)
The find-symbol and symbol-name functions will be helpful to you. If defclass and slot-value happen in the same package, you can use those functions as follows:
(defclass person ()
((id :initarg :id)
(name :initarg :name)
(age :initarg :age)))
(slot-value (make-instance 'person :id "john" :name "John Doe" :age 42)
(find-symbol (symbol-name :id)))
If defclass and slot-value happen in two different packages, you need to give find-symbol the name of the package where defclass happens:
(in-package #:common-lisp-user)
(defpackage #:foo
(:use #:common-lisp)
(:export #:person))
(defpackage #:bar
(:use #:common-lisp #:foo))
(in-package #:foo)
(defclass person ()
((id :initarg :id)
(name :initarg :name)
(age :initarg :age)))
(in-package #:bar)
(slot-value (make-instance 'person :id "john" :name "John Doe" :age 42)
(find-symbol (symbol-name :id) 'foo))
(find-symbol name &optional (package (sane-package)))
Function: Return the symbol named STRING in PACKAGE. If such a symbol is found then the second value is :INTERNAL, :EXTERNAL or :INHERITED to indicate how the symbol is accessible. If no symbol is found then both values are NIL.
(symbol-name symbol)
Function: Return SYMBOL's name as a string.
I realize that this is quite old, but I think that the most important point to be made here is:
Don't use slot-value like that!
In order to get an accessor, use the :accessor or :reader slot options, and for passing values to the constructor, use :initarg:
(defclass foo ()
((bar :accessor foo-bar :initarg :bar)))
This means: create a getter method and a setf expander named foo-bar, and use a keyword argument named :bar to make-instance to initialize this slot's value.
Now you can instantiate such an object like this:
(make-instance 'foo :bar "quux")
or, if you get a property list of initargs (as Rainer had already shown):
(let ((initargs (list :bar "quux"))) ; getting this from somewhere
(apply #'make-instance 'foo initargs))
You can then get the value like this:
(foo-bar some-foo)
And set it with setf as usual:
(setf (foo-bar some-foo) "wobble")
If you use :reader instead of :accessor, setting is not allowed. This is often useful to communicate intent of immutability.
Slot-value is really for special situations in the lifetime of an object, such as when playing around with methods for initialize-instance. That is an advanced topic.
My solution to this stupidity of CL was:
(defun locate-symbol
(inst kw)
(let* ((slot-name (symbol-name kw))
(slot-def (find slot-name
(clos:compute-slots (class-of inst))
:test #'(lambda (name sd)
(string= name
(symbol-name (clos:slot-definition-name sd)))))))
(if slot-def
(clos:slot-definition-name slot-def)
(error "Can't find a slot definition named ~s." slot-name))))
(defun gets
(self slot-name)
"Get a value of a slot by its name (keyword)"
(slot-value self (locate-symbol self slot-name)))
(defun sets!
(self slot-name value)
"Set a value of a slot by its name (keyword)"
(setf (slot-value self (locate-symbol self slot-name))
value))
So now you can do:
(defvar obj (make-instance '<some-class>))
(sets! obj :some-slot "some value")
(format t "-> ~a~%" (gets obj :some-slot))