Support ParenScript events

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")

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))