From 89418c8ef0719cfaa0106fbd138feb672036e10b Mon Sep 17 00:00:00 2001 From: David Botton Date: Sun, 17 Mar 2024 14:13:52 -0400 Subject: [PATCH] Support ParenScript events --- clog.asd | 2 +- tools/clog-builder.lisp | 158 +++++++++++++++++++++++++++++++++++++++- 2 files changed, 156 insertions(+), 4 deletions(-) diff --git a/clog.asd b/clog.asd index 4e769ad..428d49e 100644 --- a/clog.asd +++ b/clog.asd @@ -52,7 +52,7 @@ (asdf:defsystem #:clog/tools :depends-on (#:clog #:clog-ace #:clog-terminal #:s-base64 #:swank - #:definitions) + #:definitions #:parenscript) :pathname "tools/" :components (;; clog-db-admin app (:file "clog-db-admin") diff --git a/tools/clog-builder.lisp b/tools/clog-builder.lisp index 3996010..e8192b4 100644 --- a/tools/clog-builder.lisp +++ b/tools/clog-builder.lisp @@ -79,6 +79,14 @@ :accessor event-js-editor :initform nil :documentation "JS Editor in events window") + (events-ps-list + :accessor events-ps-list + :initform nil + :documentation "ParenScript Event list in events window") + (event-ps-editor + :accessor event-ps-editor + :initform nil + :documentation "PS Editor in events window") (auto-complete-configured :accessor auto-complete-configured :initform nil @@ -95,6 +103,10 @@ :accessor control-js-events-win :initform nil :documentation "Current control events window") + (control-ps-events-win + :accessor control-ps-events-win + :initform nil + :documentation "Current control events window") (control-list-win :accessor control-list-win :initform nil @@ -949,7 +961,7 @@ not a temporarily attached one when using select-control." (remove-attribute control attr)) (t (setf (select-text elist) (format nil "~A ~A" (code-char 9632) opt)) - (setf (attribute control attr) (text-value (event-editor app)))))) + (setf (attribute control attr) txt)))) (jquery-execute (get-placer control) "trigger('clog-builder-snap-shot')"))) (set-on-blur (event-editor app) #'on-blur)) (on-change (obj) @@ -972,9 +984,10 @@ not a temporarily attached one when using select-control." (setf (attribute elist "data-current-event") attr) (set-on-blur (event-editor app) #'on-blur))))))) (populate-options)))))) + (on-populate-control-ps-events-win obj) (on-populate-control-js-events-win obj)) -(defun on-populate-control-js-events-win (obj) + (defun on-populate-control-js-events-win (obj) "Populate the control js events for the current control" (let* ((app (connection-data-item obj "builder-app-data")) (event-win (control-js-events-win app)) @@ -1020,7 +1033,7 @@ not a temporarily attached one when using select-control." (remove-attribute control attr)) (t (setf (select-text elist) (format nil "~A ~A" (code-char 9632) opt)) - (setf (attribute control attr) (text-value (event-js-editor app)))))) + (setf (attribute control attr) txt)))) (jquery-execute (get-placer control) "trigger('clog-builder-snap-shot')"))) (set-on-blur (event-js-editor app) #'on-blur)) (on-change (obj) @@ -1044,6 +1057,81 @@ not a temporarily attached one when using select-control." (set-on-blur (event-js-editor app) #'on-blur))))))) (populate-options))))))) + (defun on-populate-control-ps-events-win (obj) + "Populate the control ps events for the current control" + (let* ((app (connection-data-item obj "builder-app-data")) + (event-win (control-ps-events-win app)) + (elist (events-ps-list app)) + (control (current-control app))) + (when event-win + (set-on-blur (event-ps-editor app) nil) + (set-on-change elist nil) + (setf (inner-html elist) "") + (remove-attribute elist "data-current-ps-event") + (setf (text-value (event-ps-editor app)) "") + (setf (clog-ace:read-only-p (event-ps-editor app)) t) + (when control + (let ((info (control-info (attribute control "data-clog-type")))) + (labels ((populate-options (&key (current "")) + (set-on-change elist nil) + (setf (inner-html elist) "") + (add-select-option elist "" "Select JS Event for ParenScript") + (dolist (event (getf info :events)) + (when (getf event :js-event) + (let ((attr (format nil "~A" (getf event :js-event)))) + (add-select-option elist + (getf event :js-event) + (format nil "~A ~A" + (if (has-attribute control attr) + "■‎ " + "□ ") + (getf event :js-event)) + :selected (equal attr current))))) + (set-on-change elist #'on-change)) + (on-blur (obj) + (declare (ignore obj)) + (set-on-blur (event-ps-editor app) nil) + (let* ((attr (attribute elist "data-current-ps-event")) + (ps-attr (format nil "data-ps-~A" attr))) + (unless (equalp attr "undefined") + (let ((opt (select-text elist)) + (txt (text-value (event-ps-editor app)))) + (setf (char opt 0) #\space) + (setf opt (string-left-trim "#\space" opt)) + (cond ((or (equal txt "") + (equalp txt "undefined")) + (setf (select-text elist) (format nil "~A ~A" (code-char 9633) opt)) + (remove-attribute control ps-attr) + (remove-attribute control attr)) + (t + (setf (select-text elist) (format nil "~A ~A" (code-char 9632) opt)) + (setf (attribute control ps-attr) txt) + (let ((ss (make-string-input-stream txt))) + (setf (attribute control attr) (ps:ps-compile-stream ss))))) + (jquery-execute (get-placer control) "trigger('clog-builder-snap-shot')")))) + (set-on-blur (event-ps-editor app) #'on-blur)) + (on-change (obj) + (declare (ignore obj)) + (set-on-blur (event-ps-editor app) nil) + (let ((event (select-value elist "clog-ps-events"))) + (cond ((equal event "") + (set-on-blur (event-ps-editor app) nil) + (remove-attribute elist "data-current-ps-event") + (setf (text-value (event-ps-editor app)) "") + (setf (clog-ace:read-only-p (event-ps-editor app)) t)) + (t + (setf (clog-ace:read-only-p (event-ps-editor app)) nil) + (let* ((attr (format nil "~A" event)) + (ps-attr (format nil "data-ps-~A" attr)) + (txt (attribute control ps-attr))) + (setf (text-value (event-ps-editor app)) + (if (equalp txt "undefined") + "" + txt)) + (setf (attribute elist "data-current-ps-event") attr) + (set-on-blur (event-ps-editor app) #'on-blur))))))) + (populate-options))))))) + (defun on-populate-control-properties-win (obj &key win) "Populate the control properties for the current control" ;; obj if current-control is nil must be content @@ -1810,6 +1898,65 @@ It parse the string TEXT without using READ functions." (setf (control-js-events-win app) nil)))))) (on-populate-control-js-events-win obj)) +(defun on-show-control-ps-events-win (obj) + "Show control events window" + (let ((app (connection-data-item obj "builder-app-data"))) + (if (control-ps-events-win app) + (window-focus (control-ps-events-win app)) + (let* ((win (create-gui-window obj :title "Control Client ParenScript Events" + :left 225 + :top 700 + :height 200 :width 645 + :has-pinner t :client-movement *client-side-movement*)) + (content (window-content win)) + status) + (setf (current-editor-is-lisp app) nil) + (set-on-window-focus win + (lambda (obj) + (declare (ignore obj)) + (setf (current-editor-is-lisp app) nil))) + (setf (control-ps-events-win app) win) + (setf (events-ps-list app) (create-select content :name "clog-ps-events" :class "w3-gray w3-text-white")) + (setf (positioning (events-ps-list app)) :absolute) + (set-geometry (events-ps-list app) :top 5 :left 5 :right 5) + (setf (event-ps-editor app) (clog-ace:create-clog-ace-element content)) + (setf (clog-ace:read-only-p (event-ps-editor app)) t) + (set-on-event (event-ps-editor app) "clog-save-ace" + (lambda (obj) + (declare (ignore obj)) + ;; toggle focus to force a save of event + (focus (events-ps-list app)) + (focus (event-ps-editor app)))) + (setf (positioning (event-ps-editor app)) :absolute) + (setf (width (event-ps-editor app)) "") + (setf (height (event-ps-editor app)) "") + (set-geometry (event-ps-editor app) :top 35 :left 5 :right 5 :bottom 30) + (clog-ace:resize (event-ps-editor app)) + (setf status (create-div content :class "w3-tiny w3-border" + :content "Use (ps:chain ($ \"[data-clog-name=\\\"control-name\\\"]\")) to access controls.")) + (setf (positioning status) :absolute) + (setf (width status) "") + (set-geometry status :height 20 :left 5 :right 5 :bottom 5) + (setup-lisp-ace (event-ps-editor app) nil :package "parenscript") + (set-on-window-size-done win (lambda (obj) + (declare (ignore obj)) + (clog-ace:resize (event-ps-editor app)))) + (panel-mode win t) + (set-on-window-focus win + (lambda (obj) + (declare (ignore obj)) + (panel-mode win t))) + (set-on-window-blur win + (lambda (obj) + (declare (ignore obj)) + (panel-mode win nil))) + (set-on-window-close win (lambda (obj) + (declare (ignore obj)) + (setf (event-ps-editor app) nil) + (setf (events-ps-list app) nil) + (setf (control-ps-events-win app) nil)))))) + (on-populate-control-ps-events-win obj)) + (defun on-show-copy-history-win (obj) "Create and show copy/but history" (let ((app (connection-data-item obj "builder-app-data"))) @@ -3110,6 +3257,7 @@ It parse the string TEXT without using READ functions." (create-gui-menu-item src :content "New ASDF System Browser" :on-click 'on-new-asdf-browser) (create-gui-menu-item tools :content "Control CLOG Events" :on-click 'on-show-control-events-win) (create-gui-menu-item tools :content "Control JavaScript Events" :on-click 'on-show-control-js-events-win) + (create-gui-menu-item tools :content "Control ParenScript Events" :on-click 'on-show-control-ps-events-win) (create-gui-menu-item tools :content "Directory Window" :on-click 'on-dir-win) (create-gui-menu-item tools :content "List Callers" :on-click 'on-show-callers) (create-gui-menu-item tools :content "List Callees" :on-click 'on-show-callees) @@ -3142,6 +3290,10 @@ It parse the string TEXT without using READ functions." (lambda (obj) (declare (ignore obj)) (open-window (window body) "https://github.com/rabbibotton/clog/blob/main/LEARN.md"))) + (create-gui-menu-item help :content "ParenScript Reference" :on-click + (lambda (obj) + (declare (ignore obj)) + (open-window (window body) "https://parenscript.common-lisp.dev/"))) (create-gui-menu-item help :content "L1sp Search" :on-click (lambda (obj) (declare (ignore obj))