1 (uiop:define-package
#:lw2.client-script
2 (:documentation
"Facilities for code that runs on both web browsers and the server.")
3 (:use
#:cl
#:parenscript
#:lw2.html-reader
)
4 (:import-from
#:alexandria
#:assoc-value
)
5 (:export
#:client-script-function
#:client-script
#:client-defun
6 #:write-package-client-scripts
7 #:if-client
#:when-client
#:when-server
8 #:call-with-server-data
9 #:activate-client-trigger
))
11 (in-package #:lw2.client-script
)
13 (sb-ext:defglobal
*client-script-hash
* (make-hash-table :test
'eq
:weakness
:key
:synchronized t
))
15 (defclass client-script-function
(closer-mop:funcallable-standard-object
)
16 ((script :initarg
:script
:accessor client-script
:type string
))
17 (:metaclass closer-mop
:funcallable-standard-class
))
19 (defmacro client-defun
(name (&rest lambda-list
) &body body
)
20 (labels ((client-test-macros (client-p body
)
21 `(macrolet ((if-client (client server
)
22 (declare (ignorable client server
))
23 ,(if client-p
'client
'server
))
24 (when-client (&body body
) `(if-client (progn ,@body
) nil
))
25 (when-server (&body body
) `(if-client nil
(progn ,@body
))))
28 (declaim (ftype function
,name
))
29 (let* ((csf (make-instance 'client-script-function
30 :script
(parenscript:ps
,(client-test-macros t
`(defun ,name
,lambda-list
,@body
))))))
31 (closer-mop:set-funcallable-instance-function csf
,(client-test-macros nil
`(lambda ,lambda-list
,@body
)))
32 (setf (fdefinition ',name
) csf
)
33 (add-client-script-to-package ',name csf
*package
*)))))
35 (defun add-client-script-to-package (name csf package
)
36 (setf (assoc-value (gethash package
*client-script-hash
*) name
)
39 (defun write-package-client-scripts (package stream
)
40 (dolist (csf-acons (gethash package
*client-script-hash
*))
41 (write-string (client-script (cdr csf-acons
)) stream
)
44 (defmacro if-client
(client server
)
45 (declare (ignore client
))
48 (defmacro when-client
(&body body
)
49 (declare (ignore body
))
52 (defmacro when-server
(&body body
)
55 (defun call-with-server-data (client-function server-endpoint-uri
)
56 (with-html-stream-output (:stream stream
)
57 (format stream
"<script async src=\"data:text/javascript,callWithServerData('~A','~A');\"></script>" (json:lisp-to-camel-case
(string client-function
)) server-endpoint-uri
)))
59 (defun activate-client-trigger (trigger-name)
60 (with-html-stream-output (:stream stream
)
61 (format stream
"<script>activateTrigger('~A');</script>" trigger-name
)))