From 3667e1f966885ee8f49e5c7f13a0c15d826d227c Mon Sep 17 00:00:00 2001 From: David Botton Date: Sun, 28 Aug 2022 10:52:43 -0400 Subject: [PATCH] reorg files --- clog.asd | 14 +- tools/clog-builder-asdf-browser.lisp | 38 +++ tools/clog-builder-projects.lisp | 285 +++++++++++++++++ tools/clog-builder-sys-browser.lisp | 133 ++++++++ tools/clog-builder.lisp | 452 --------------------------- 5 files changed, 466 insertions(+), 456 deletions(-) create mode 100644 tools/clog-builder-asdf-browser.lisp create mode 100644 tools/clog-builder-projects.lisp create mode 100644 tools/clog-builder-sys-browser.lisp diff --git a/clog.asd b/clog.asd index 8543309..e52b058 100644 --- a/clog.asd +++ b/clog.asd @@ -53,15 +53,21 @@ :depends-on (#:clog #:clog-ace #:clog-terminal #:s-base64 #:swank #:definitions) :pathname "tools/" - :components ((:file "clog-db-admin") - (:file "clog-builder-settings") + :components (;; clog-db-admin app + (:file "clog-db-admin") + ;; clog-builder generated clode (:file "clog-templates") - (:file "clog-builder") - (:file "clog-builder-repl") (:file "image-to-data") (:file "quick-start") (:file "threads") (:file "systems") (:file "sys-browser") (:file "projects") + (:file "clog-builder-repl") + ;; clog-builder code + (:file "clog-builder-settings") + (:file "clog-builder") + (:file "clog-builder-projects") + (:file "clog-builder-asdf-browser") + (:file "clog-builder-sys-browser") (:file "clog-builder-images"))) diff --git a/tools/clog-builder-asdf-browser.lisp b/tools/clog-builder-asdf-browser.lisp new file mode 100644 index 0000000..750fb1e --- /dev/null +++ b/tools/clog-builder-asdf-browser.lisp @@ -0,0 +1,38 @@ +(in-package :clog-tools) + +(defun on-new-asdf-browser (obj &key (project nil)) + (let* ((win (create-gui-window obj :title "ASDF System Browser" + :top 40 :left 225 + :width 592 :height 435 + :client-movement t)) + (panel (create-asdf-systems (window-content win)))) + (when project + (setf (text-value (loaded-systems panel)) (string-downcase project)) + (asdf-browser-populate panel)))) + +(defun asdf-browser-reset (panel) + (let* ((app (connection-data-item panel "builder-app-data"))) + (setf (inner-html (loaded-systems panel)) "") + (dolist (n (sort (asdf:already-loaded-systems) #'string-lessp)) + (add-select-option (loaded-systems panel) n n)) + (if (current-project app) + (setf (text-value (loaded-systems panel)) (current-project app)) + (setf (text-value (loaded-systems panel)) "clog")) + (asdf-browser-populate panel))) + +(Defun asdf-browser-populate (panel) + (setf (text-value (source-file panel)) + (asdf:system-source-file + (asdf:find-system (text-value (loaded-systems panel))))) + (setf (inner-html (deps panel)) "") + (dolist (n (asdf:system-depends-on + (asdf:find-system (text-value (loaded-systems panel))))) + (add-select-option (deps panel) n n)) + (setf (inner-html (files panel)) "") + (dolist (n (asdf:module-components + (asdf:find-system (text-value (loaded-systems panel))))) + (let ((name (asdf:component-relative-pathname n)) + (path (asdf:component-pathname n))) + (add-select-option (files panel) path name)))) + + diff --git a/tools/clog-builder-projects.lisp b/tools/clog-builder-projects.lisp new file mode 100644 index 0000000..9985481 --- /dev/null +++ b/tools/clog-builder-projects.lisp @@ -0,0 +1,285 @@ +(in-package :clog-tools) + +(defun projects-setup (panel) + (let* ((app (connection-data-item panel "builder-app-data"))) + (when (uiop:directory-exists-p #P"~/common-lisp/") + (pushnew #P"~/common-lisp/" ql:*local-project-directories*)) + (add-select-option (project-list panel) "None" "None") + (dolist (n (sort (ql:list-local-systems) #'string-lessp)) + (add-select-option (project-list panel) n n)) + (cond((current-project app) + (setf (text-value (project-list panel)) (current-project app)) + (projects-populate panel)) + (t + (setf (text-value (project-list panel)) "None"))))) + +(defun projects-run (panel) + (let ((val (text-value (entry-point panel)))) + (unless (equal val "") + (let ((result (capture-eval (format nil "(~A)" val) :clog-obj panel + :eval-in-package "clog-user"))) + (clog-web-alert (connection-body panel) "Result" + (format nil "~&result: ~A" result) + :color-class "w3-green" + :time-out 3))))) + +(defun projects-entry-point-change (panel) + (let* ((sys (text-value (project-list panel))) + (entry-point (text-value (entry-point panel))) + (fname (asdf:system-source-file (asdf:find-system sys))) + (sys-list '())) + (with-open-file (s fname) + (loop + (let* ((line (read s nil))) + (unless line (return)) + (when (equalp (format nil "~A" (second line)) sys) + (if (getf line :entry-point) + (setf (getf line :entry-point) entry-point) + (setf line (append line `(:entry-point ,entry-point))))) + (push line sys-list)))) + (with-open-file (s fname :direction :output :if-exists :rename) + (let ((*print-case* :downcase)) + (dolist (n (reverse sys-list)) + (pprint n s)))))) + +(defun projects-populate (panel) + (let ((app (connection-data-item panel "builder-app-data")) + (already (asdf/operate:already-loaded-systems)) + (sel (text-value (project-list panel)))) + (reset-control-pallete panel) + (setf (inner-html (runtime-list panel)) "") + (setf (inner-html (designtime-list panel)) "") + (setf (inner-html (runtime-deps panel)) "") + (setf (inner-html (design-deps panel)) "") + (setf (text-value (entry-point panel)) "") + (setf (disabledp (runtime-add-lisp panel)) t) + (setf (disabledp (runtime-delete panel)) t) + (setf (disabledp (designtime-add-lisp panel)) t) + (setf (disabledp (designtime-add-clog panel)) t) + (setf (disabledp (designtime-delete panel)) t) + (setf (disabledp (runtime-add-dep panel)) t) + (setf (disabledp (runtime-del-dep panel)) t) + (setf (disabledp (design-add-dep panel)) t) + (setf (disabledp (design-del-dep panel)) t) + (setf (disabledp (design-plugin panel)) t) + (setf (disabledp (entry-point panel)) t) + (setf (disabledp (run-button panel)) t) + (setf (current-project app) (if (equal sel "None") + nil + sel)) + (when (current-project app) + (cond ((member sel already :test #'equal) + ;; entry point + (setf (text-value (entry-point panel)) + (or (asdf/system:component-entry-point + (asdf:find-system sel)) + "")) + (setf (current-project-dir app) + (asdf:component-pathname + (asdf:find-system sel))) + ;; fill runtime + (dolist (n (asdf:module-components + (asdf:find-system sel))) + (let ((name (asdf:component-relative-pathname n)) + (path (asdf:component-pathname n))) + (add-select-option (runtime-list panel) path name))) + (dolist (n (asdf:system-depends-on + (asdf:find-system sel))) + (add-select-option (runtime-deps panel) n n)) + ;; fill designtime) + (handler-case + (let ((sys (asdf:find-system (format nil "~A/tools" sel)))) + (dolist (n (asdf:module-components sys)) + (let ((name (asdf:component-relative-pathname n)) + (path (asdf:component-pathname n))) + (add-select-option (designtime-list panel) path name))) + (dolist (n (asdf:system-depends-on + (asdf:find-system sys))) + (add-select-option (design-deps panel) n n)) + (cond ((member "clog" (asdf:system-defsystem-depends-on sys) :test #'equal) + (setf (disabledp (runtime-add-lisp panel)) nil) + (setf (disabledp (runtime-delete panel)) nil) + (setf (disabledp (designtime-add-lisp panel)) nil) + (setf (disabledp (designtime-add-clog panel)) nil) + (setf (disabledp (designtime-delete panel)) nil) + (setf (disabledp (runtime-add-dep panel)) nil) + (setf (disabledp (runtime-del-dep panel)) nil) + (setf (disabledp (design-add-dep panel)) nil) + (setf (disabledp (design-del-dep panel)) nil) + (setf (disabledp (design-plugin panel)) nil) + (setf (disabledp (entry-point panel)) nil) + (setf (disabledp (run-button panel)) nil)) + (t + (alert-toast panel "Warning" "Missing :defsystem-depends-on (:clog)" + :color-class "w3-yellow" :time-out 2)))) + (t (c) + (declare (ignore c)) + (add-select-option (designtime-list panel) "" "Missing /tools") + (add-select-option (design-deps panel) "" "Missing /tools")))) + (t + (confirm-dialog panel "Load project?" + (lambda (answer) + (cond (answer + (ql:quickload sel) + (ignore-errors + (ql:quickload (format nil "~A/tools" sel))) + (ql:quickload sel) + (projects-populate panel)) + (t + (setf (current-project app) nil) + (setf (text-value (project-list panel)) "None")))) + :title "System not loaded")))))) + +(defun projects-add-dep (panel sys) + (Input-dialog panel "Enter system name:" + (lambda (result) + (when result + (add-dep-to-defsystem sys result) + (ql:quickload sys) + (projects-populate panel))) + :height 230) + (ql:quickload sys)) + +(defun projects-add-plugin (panel sys) + (input-dialog panel (format nil "Enter plugin name (without /tools), ~ + plugin will be added to the runtime and designtime:") + (lambda (result) + (when result + (let* ((s (format nil "~A/tools" sys))) + (add-dep-to-defsystem s (format nil "~A/tools" result)) + (ql:quickload s)) + (add-dep-to-defsystem sys result) + (ql:quickload sys) + (projects-populate panel))) + :height 250)) + +(defun add-dep-to-defsystem (sys file) + (let ((fname (asdf:system-source-file (asdf:find-system sys))) + (sys-list '())) + (with-open-file (s fname) + (loop + (let* ((line (read s nil))) + (unless line (return)) + (when (equalp (format nil "~A" (second line)) sys) + (setf (getf line :depends-on) + (append (getf line :depends-on) `(,file)))) + (push line sys-list)))) + (with-open-file (s fname :direction :output :if-exists :rename) + (let ((*print-case* :downcase)) + (dolist (n (reverse sys-list)) + (pprint n s)))))) + +(defun remove-dep-from-defsystem (sys file) + (let ((fname (asdf:system-source-file (asdf:find-system sys))) + (sys-list '())) + (with-open-file (s fname) + (loop + (let* ((line (read s nil))) + (unless line (return)) + (when (equalp (format nil "~A" (second line)) sys) + (let (new-comp) + (dolist (n (getf line :depends-on)) + (unless (equalp (format nil "~A" n) file) + (push n new-comp))) + (setf (getf line :depends-on) (reverse new-comp)))) + (push line sys-list)))) + (with-open-file (s fname :direction :output :if-exists :rename) + (let ((*print-case* :downcase)) + (dolist (n (reverse sys-list)) + (pprint n s)))))) + +(defun projects-add-lisp (panel sys) + (Input-dialog panel "Enter lisp component name (with out .lisp):" + (lambda (result) + (when result + (let ((path (asdf:component-pathname + (asdf:find-system sys)))) + (write-file "" (format nil "~A~A.lisp" + path result) + :action-if-exists nil) + (add-file-to-defsystem sys result :file) + (ql:quickload sys) + (projects-populate panel)))) + :height 230) + (ql:quickload sys)) + +(defun projects-add-clog (panel sys) + (input-dialog panel (format nil "Enter clog component name (with out .clog), ~ + a lisp component will also be created in the runtime system:") + (lambda (result) + (when result + (let* ((s (format nil "~A/tools" sys)) + (path (asdf:component-pathname + (asdf:find-system s)))) + (write-file "" (format nil "~A~A.clog" + path result) + :action-if-exists nil) + (add-file-to-defsystem s result :clog-file) + (ql:quickload s)) + (let ((path (asdf:component-pathname + (asdf:find-system sys)))) + (write-file "" (format nil "~A~A.lisp" + path result) + :action-if-exists nil) + (add-file-to-defsystem sys result :file) + (ql:quickload sys) + (projects-populate panel)))) + :height 250)) + +(defun add-file-to-defsystem (system file ftype) + (let ((fname (asdf:system-source-file (asdf:find-system system))) + (sys-list '())) + (with-open-file (s fname) + (loop + (let* ((line (read s nil))) + (unless line (return)) + (when (equalp (format nil "~A" (second line)) system) + (setf (getf line :components) + (append (getf line :components) `((,ftype ,file))))) + (push line sys-list)))) + (with-open-file (s fname :direction :output :if-exists :rename) + (let ((*print-case* :downcase)) + (dolist (n (reverse sys-list)) + (pprint n s)))))) + +(defun remove-file-from-defsystem (system file ftype) + (let ((fname (asdf:system-source-file (asdf:find-system system))) + (sys-list '())) + (with-open-file (s fname) + (loop + (let* ((line (read s nil))) + (unless line (return)) + (when (equalp (format nil "~A" (second line)) system) + (let (new-comp) + (dolist (n (getf line :components)) + (unless (and (equal (first n) ftype) + (equalp (second n) file)) + (push n new-comp))) + (setf (getf line :components) (reverse new-comp)))) + (push line sys-list)))) + (with-open-file (s fname :direction :output :if-exists :rename) + (let ((*print-case* :downcase)) + (dolist (n (reverse sys-list)) + (pprint n s))))) + (ql:quickload system)) + +(defun open-projects-component (target system list) + (let ((disp (select-text target)) + (item (text-value target))) + (cond ((equal item "") + (alert-toast target "Invalid action" "No /tools project" :time-out 1)) + ((equal (subseq item (1- (length item))) "/") + (setf (inner-html list) "") + (dolist (n (asdf:module-components + (asdf:find-component + (asdf:find-system system) + (subseq disp 0 (1- (length disp)))))) + (let ((name (asdf:component-relative-pathname n)) + (path (asdf:component-pathname n))) + (add-select-option list path name)))) + ((and (> (length item) 5) + (equal (subseq item (- (length item) 5)) ".clog")) + (on-new-builder-panel target :open-file item) + (on-show-control-events-win target)) + (t + (on-open-file target :open-file item))))) diff --git a/tools/clog-builder-sys-browser.lisp b/tools/clog-builder-sys-browser.lisp new file mode 100644 index 0000000..9e0e713 --- /dev/null +++ b/tools/clog-builder-sys-browser.lisp @@ -0,0 +1,133 @@ +(in-package :clog-tools) + +(defun on-new-sys-browser (obj &key (search nil)) + (let* ((win (create-gui-window obj :title "System Browser" + :top 40 :left 225 + :width 685 :height 530 + :client-movement t)) + (panel (create-sys-browser (window-content win)))) + (when search + (setf (text-value (search-box panel)) search) + (sys-browser-populate panel)) + (set-on-window-size-done win (lambda (obj) + (declare (ignore obj)) + (clog-ace:resize (src-box panel)))))) + +(defun sys-browser-populate (panel) + (setf (inner-html (class-box panel)) "") + (setf (text-value (src-box panel)) "") + (setf (text-value (doc-box panel)) "") + (setf (text-value (file-name panel)) "") + (setf (fname panel) nil) + (let* ((filter (text-value (search-box panel))) + (has-pac (position #\: filter :test #'equal)) + (class-only (checkedp (class-only panel))) + (pac (text-value (package-box panel)))) + (when has-pac + (setf pac (string-upcase (subseq filter 0 has-pac))) + (setf (text-value (package-box panel)) pac) + (unless (equalp (text-value (package-box panel)) pac) + (setf (text-value (package-box panel)) "All") + (setf pac "All")) + (setf filter (subseq filter (+ has-pac 1))) + (setf (text-value (search-box panel)) filter)) + (cond ((equalp pac "All") + (setf class-only nil) + (setf (classes panel) nil) + (unless (equal filter "") + (setf (classes panel) (definitions:apropos-definitions + filter + :type (find-symbol + (text-value (type-box panel)) + (find-package :definitions)))))) + (t + (setf (classes panel) (definitions:find-definitions + (text-value (package-box panel)) + :package (find-package :key) + :type (find-symbol + (text-value (type-box panel)) + (find-package :definitions)))))) + (let ((i 0)) + (dolist (c (classes panel)) + (let ((name (format nil "~A" (definitions:designator c)))) + (if (or (equal filter "") + (search filter name :test #'char-equal)) + (if class-only + (if (equalp (package-name (definitions:package c)) + pac) + (add-select-option (class-box panel) i + (format nil "~A - ~A" + name + (definitions:type c)))) + (add-select-option (class-box panel) i + (format nil "~A:~A - ~A" + (package-name (definitions:package c)) + name + (definitions:type c))))) + (incf i)))))) + +(defun sys-browser-select (panel target) + (let* ((item (nth (parse-integer (text-value (class-box panel))) (classes panel)))) + (setf (fname panel) (getf (definitions:source-location item) :file)) + (setf (text-value (doc-box panel)) + (or (definitions:documentation item) + "No documentation")) + (cond ((fname panel) + (let ((c (read-file (fname panel)))) + (setf (text-value (src-box panel)) c) + (setf (text-value (pac-box panel)) (get-package-from-string c))) + (setf (text-value (file-name panel)) (fname panel)) + (setf (disabledp (eval-button panel)) nil) + (setf (disabledp (eval-sel-button panel)) nil) + (setf (disabledp (eval-form-button panel)) nil) + (setf (state panel) nil) + (let* ((type (type-of item)) + (name (format nil "~A" (definitions:designator item)))) + (setf name (ppcre:regex-replace-all "\\\\" name "\\x5C\\x5C")) + (setf name (ppcre:regex-replace-all "\\\(" name "\\x5C(")) + (setf name (ppcre:regex-replace-all "\\\)" name "\\x5C)")) + (setf name (ppcre:regex-replace-all "\\\*" name "\\x5C*")) + (js-execute target (format nil "~A.find('~A',{caseSensitive:false,regExp:true})" + (clog-ace::js-ace (src-box panel)) + (cond ((eq type 'definitions:generic-function) + (format nil "defgeneric\\\\s+~A" name)) + ((eq type 'definitions:method) + (format nil "defmethod\\\\s+~A" name)) + ((eq type 'definitions:function) + (format nil "defun\\\\s+~A" name)) + ((eq type 'definitions:macro) + (format nil "defmacro\\\\s+~A" name)) + ((eq type 'definitions:class) + (format nil "defclass\\\\s+~A" name)) + ((eq type 'definitions:compiler-macro) + (format nil "define-compiler-macro\\\\s+~A" name)) + ((eq type 'definitions:condition) + (format nil "define-condition\\\\s+~A" name)) + ((eq type 'definitions:alien-type) + (format nil "define-alien-type ~A" name)) + ((eq type 'definitions:constant) + (format nil "defconstant\\\\s+~A" name)) + ((eq type 'definitions:package) + (format nil "defpackage\\\\s+~A" name)) + ((eq type 'definitions:special-variable) + (format nil "(defsection|defparameter|defvar)\\\\s+~A" name)) + ((eq type 'definitions:vop) + (format nil "define-type-vop\\\\s+~A" name)) + ((eq type 'definitions:structure) + (format nil "defstruct\\\\s*\\\\(\\\\s*~A" name)) + ((eq type 'definitions:setf-expander) + (format nil "(defsetf|def)\\\\s+~A" name)) + ((eq type 'definitions:optimizer) + (format nil "defoptimizer\\\\s*\\\\(\\\\s*~A" name)) + ((eq type 'definitions:ir1-convert) + (format nil "def-ir1-translator\\\\s+~A" name)) + (t + name)))))) + (t + (setf (text-value (file-name panel)) "") + (setf (disabledp (eval-button panel)) t) + (setf (disabledp (eval-sel-button panel)) t) + (setf (disabledp (eval-form-button panel)) t) + (setf (disabledp (save-button panel)) t) + (setf (state panel) t) + (setf (text-value (src-box panel)) "No file information"))))) diff --git a/tools/clog-builder.lisp b/tools/clog-builder.lisp index 1712534..2b20056 100644 --- a/tools/clog-builder.lisp +++ b/tools/clog-builder.lisp @@ -2498,173 +2498,6 @@ of controls and double click to select control." (set-geometry (create-clog-builder-repl (window-content win)) :units "%" :width 100 :height 100))) -(defun on-new-asdf-browser (obj &key (project nil)) - (let* ((win (create-gui-window obj :title "ASDF System Browser" - :top 40 :left 225 - :width 592 :height 435 - :client-movement t)) - (panel (create-asdf-systems (window-content win)))) - (when project - (setf (text-value (loaded-systems panel)) (string-downcase project)) - (asdf-browser-populate panel)))) - -(defun asdf-browser-reset (panel) - (let* ((app (connection-data-item panel "builder-app-data"))) - (setf (inner-html (loaded-systems panel)) "") - (dolist (n (sort (asdf:already-loaded-systems) #'string-lessp)) - (add-select-option (loaded-systems panel) n n)) - (if (current-project app) - (setf (text-value (loaded-systems panel)) (current-project app)) - (setf (text-value (loaded-systems panel)) "clog")) - (asdf-browser-populate panel))) - -(Defun asdf-browser-populate (panel) - (setf (text-value (source-file panel)) - (asdf:system-source-file - (asdf:find-system (text-value (loaded-systems panel))))) - (setf (inner-html (deps panel)) "") - (dolist (n (asdf:system-depends-on - (asdf:find-system (text-value (loaded-systems panel))))) - (add-select-option (deps panel) n n)) - (setf (inner-html (files panel)) "") - (dolist (n (asdf:module-components - (asdf:find-system (text-value (loaded-systems panel))))) - (let ((name (asdf:component-relative-pathname n)) - (path (asdf:component-pathname n))) - (add-select-option (files panel) path name)))) - -(defun on-new-sys-browser (obj &key (search nil)) - (let* ((win (create-gui-window obj :title "System Browser" - :top 40 :left 225 - :width 685 :height 530 - :client-movement t)) - (panel (create-sys-browser (window-content win)))) - (when search - (setf (text-value (search-box panel)) search) - (sys-browser-populate panel)) - (set-on-window-size-done win (lambda (obj) - (declare (ignore obj)) - (clog-ace:resize (src-box panel)))))) - -(defun sys-browser-populate (panel) - (setf (inner-html (class-box panel)) "") - (setf (text-value (src-box panel)) "") - (setf (text-value (doc-box panel)) "") - (setf (text-value (file-name panel)) "") - (setf (fname panel) nil) - (let* ((filter (text-value (search-box panel))) - (has-pac (position #\: filter :test #'equal)) - (class-only (checkedp (class-only panel))) - (pac (text-value (package-box panel)))) - (when has-pac - (setf pac (string-upcase (subseq filter 0 has-pac))) - (setf (text-value (package-box panel)) pac) - (unless (equalp (text-value (package-box panel)) pac) - (setf (text-value (package-box panel)) "All") - (setf pac "All")) - (setf filter (subseq filter (+ has-pac 1))) - (setf (text-value (search-box panel)) filter)) - (cond ((equalp pac "All") - (setf class-only nil) - (setf (classes panel) nil) - (unless (equal filter "") - (setf (classes panel) (definitions:apropos-definitions - filter - :type (find-symbol - (text-value (type-box panel)) - (find-package :definitions)))))) - (t - (setf (classes panel) (definitions:find-definitions - (text-value (package-box panel)) - :package (find-package :key) - :type (find-symbol - (text-value (type-box panel)) - (find-package :definitions)))))) - (let ((i 0)) - (dolist (c (classes panel)) - (let ((name (format nil "~A" (definitions:designator c)))) - (if (or (equal filter "") - (search filter name :test #'char-equal)) - (if class-only - (if (equalp (package-name (definitions:package c)) - pac) - (add-select-option (class-box panel) i - (format nil "~A - ~A" - name - (definitions:type c)))) - (add-select-option (class-box panel) i - (format nil "~A:~A - ~A" - (package-name (definitions:package c)) - name - (definitions:type c))))) - (incf i)))))) - -(defun sys-browser-select (panel target) - (let* ((item (nth (parse-integer (text-value (class-box panel))) (classes panel)))) - (setf (fname panel) (getf (definitions:source-location item) :file)) - (setf (text-value (doc-box panel)) - (or (definitions:documentation item) - "No documentation")) - (cond ((fname panel) - (let ((c (read-file (fname panel)))) - (setf (text-value (src-box panel)) c) - (setf (text-value (pac-box panel)) (get-package-from-string c))) - (setf (text-value (file-name panel)) (fname panel)) - (setf (disabledp (eval-button panel)) nil) - (setf (disabledp (eval-sel-button panel)) nil) - (setf (disabledp (eval-form-button panel)) nil) - (setf (state panel) nil) - (let* ((type (type-of item)) - (name (format nil "~A" (definitions:designator item)))) - (setf name (ppcre:regex-replace-all "\\\\" name "\\x5C\\x5C")) - (setf name (ppcre:regex-replace-all "\\\(" name "\\x5C(")) - (setf name (ppcre:regex-replace-all "\\\)" name "\\x5C)")) - (setf name (ppcre:regex-replace-all "\\\*" name "\\x5C*")) - (js-execute target (format nil "~A.find('~A',{caseSensitive:false,regExp:true})" - (clog-ace::js-ace (src-box panel)) - (cond ((eq type 'definitions:generic-function) - (format nil "defgeneric\\\\s+~A" name)) - ((eq type 'definitions:method) - (format nil "defmethod\\\\s+~A" name)) - ((eq type 'definitions:function) - (format nil "defun\\\\s+~A" name)) - ((eq type 'definitions:macro) - (format nil "defmacro\\\\s+~A" name)) - ((eq type 'definitions:class) - (format nil "defclass\\\\s+~A" name)) - ((eq type 'definitions:compiler-macro) - (format nil "define-compiler-macro\\\\s+~A" name)) - ((eq type 'definitions:condition) - (format nil "define-condition\\\\s+~A" name)) - ((eq type 'definitions:alien-type) - (format nil "define-alien-type ~A" name)) - ((eq type 'definitions:constant) - (format nil "defconstant\\\\s+~A" name)) - ((eq type 'definitions:package) - (format nil "defpackage\\\\s+~A" name)) - ((eq type 'definitions:special-variable) - (format nil "(defsection|defparameter|defvar)\\\\s+~A" name)) - ((eq type 'definitions:vop) - (format nil "define-type-vop\\\\s+~A" name)) - ((eq type 'definitions:structure) - (format nil "defstruct\\\\s*\\\\(\\\\s*~A" name)) - ((eq type 'definitions:setf-expander) - (format nil "(defsetf|def)\\\\s+~A" name)) - ((eq type 'definitions:optimizer) - (format nil "defoptimizer\\\\s*\\\\(\\\\s*~A" name)) - ((eq type 'definitions:ir1-convert) - (format nil "def-ir1-translator\\\\s+~A" name)) - (t - name)))))) - (t - (setf (text-value (file-name panel)) "") - (setf (disabledp (eval-button panel)) t) - (setf (disabledp (eval-sel-button panel)) t) - (setf (disabledp (eval-form-button panel)) t) - (setf (disabledp (save-button panel)) t) - (setf (state panel) t) - (setf (text-value (src-box panel)) "No file information"))))) - (defun on-convert-image (body) (let ((params (form-multipart-data body))) (create-div body :content params) @@ -2683,290 +2516,6 @@ of controls and double click to select control." (create-br body) (create-div body :content (format nil "For example:
(create-img body :url-src \"~A\")" pic-data)))))) -(defun projects-setup (panel) - (let* ((app (connection-data-item panel "builder-app-data"))) - (when (uiop:directory-exists-p #P"~/common-lisp/") - (pushnew #P"~/common-lisp/" ql:*local-project-directories*)) - (add-select-option (project-list panel) "None" "None") - (dolist (n (sort (ql:list-local-systems) #'string-lessp)) - (add-select-option (project-list panel) n n)) - (cond((current-project app) - (setf (text-value (project-list panel)) (current-project app)) - (projects-populate panel)) - (t - (setf (text-value (project-list panel)) "None"))))) - -(defun projects-run (panel) - (let ((val (text-value (entry-point panel)))) - (unless (equal val "") - (let ((result (capture-eval (format nil "(~A)" val) :clog-obj panel - :eval-in-package "clog-user"))) - (clog-web-alert (connection-body panel) "Result" - (format nil "~&result: ~A" result) - :color-class "w3-green" - :time-out 3))))) - -(defun projects-entry-point-change (panel) - (let* ((sys (text-value (project-list panel))) - (entry-point (text-value (entry-point panel))) - (fname (asdf:system-source-file (asdf:find-system sys))) - (sys-list '())) - (with-open-file (s fname) - (loop - (let* ((line (read s nil))) - (unless line (return)) - (when (equalp (format nil "~A" (second line)) sys) - (if (getf line :entry-point) - (setf (getf line :entry-point) entry-point) - (setf line (append line `(:entry-point ,entry-point))))) - (push line sys-list)))) - (with-open-file (s fname :direction :output :if-exists :rename) - (let ((*print-case* :downcase)) - (dolist (n (reverse sys-list)) - (pprint n s)))))) - -(defun projects-populate (panel) - (let ((app (connection-data-item panel "builder-app-data")) - (already (asdf/operate:already-loaded-systems)) - (sel (text-value (project-list panel)))) - (reset-control-pallete panel) - (setf (inner-html (runtime-list panel)) "") - (setf (inner-html (designtime-list panel)) "") - (setf (inner-html (runtime-deps panel)) "") - (setf (inner-html (design-deps panel)) "") - (setf (text-value (entry-point panel)) "") - (setf (disabledp (runtime-add-lisp panel)) t) - (setf (disabledp (runtime-delete panel)) t) - (setf (disabledp (designtime-add-lisp panel)) t) - (setf (disabledp (designtime-add-clog panel)) t) - (setf (disabledp (designtime-delete panel)) t) - (setf (disabledp (runtime-add-dep panel)) t) - (setf (disabledp (runtime-del-dep panel)) t) - (setf (disabledp (design-add-dep panel)) t) - (setf (disabledp (design-del-dep panel)) t) - (setf (disabledp (design-plugin panel)) t) - (setf (disabledp (entry-point panel)) t) - (setf (disabledp (run-button panel)) t) - (setf (current-project app) (if (equal sel "None") - nil - sel)) - (when (current-project app) - (cond ((member sel already :test #'equal) - ;; entry point - (setf (text-value (entry-point panel)) - (or (asdf/system:component-entry-point - (asdf:find-system sel)) - "")) - (setf (current-project-dir app) - (asdf:component-pathname - (asdf:find-system sel))) - ;; fill runtime - (dolist (n (asdf:module-components - (asdf:find-system sel))) - (let ((name (asdf:component-relative-pathname n)) - (path (asdf:component-pathname n))) - (add-select-option (runtime-list panel) path name))) - (dolist (n (asdf:system-depends-on - (asdf:find-system sel))) - (add-select-option (runtime-deps panel) n n)) - ;; fill designtime) - (handler-case - (let ((sys (asdf:find-system (format nil "~A/tools" sel)))) - (dolist (n (asdf:module-components sys)) - (let ((name (asdf:component-relative-pathname n)) - (path (asdf:component-pathname n))) - (add-select-option (designtime-list panel) path name))) - (dolist (n (asdf:system-depends-on - (asdf:find-system sys))) - (add-select-option (design-deps panel) n n)) - (cond ((member "clog" (asdf:system-defsystem-depends-on sys) :test #'equal) - (setf (disabledp (runtime-add-lisp panel)) nil) - (setf (disabledp (runtime-delete panel)) nil) - (setf (disabledp (designtime-add-lisp panel)) nil) - (setf (disabledp (designtime-add-clog panel)) nil) - (setf (disabledp (designtime-delete panel)) nil) - (setf (disabledp (runtime-add-dep panel)) nil) - (setf (disabledp (runtime-del-dep panel)) nil) - (setf (disabledp (design-add-dep panel)) nil) - (setf (disabledp (design-del-dep panel)) nil) - (setf (disabledp (design-plugin panel)) nil) - (setf (disabledp (entry-point panel)) nil) - (setf (disabledp (run-button panel)) nil)) - (t - (alert-toast panel "Warning" "Missing :defsystem-depends-on (:clog)" - :color-class "w3-yellow" :time-out 2)))) - (t (c) - (declare (ignore c)) - (add-select-option (designtime-list panel) "" "Missing /tools") - (add-select-option (design-deps panel) "" "Missing /tools")))) - (t - (confirm-dialog panel "Load project?" - (lambda (answer) - (cond (answer - (ql:quickload sel) - (ignore-errors - (ql:quickload (format nil "~A/tools" sel))) - (ql:quickload sel) - (projects-populate panel)) - (t - (setf (current-project app) nil) - (setf (text-value (project-list panel)) "None")))) - :title "System not loaded")))))) - -(defun projects-add-dep (panel sys) - (Input-dialog panel "Enter system name:" - (lambda (result) - (when result - (add-dep-to-defsystem sys result) - (ql:quickload sys) - (projects-populate panel))) - :height 230) - (ql:quickload sys)) - -(defun projects-add-plugin (panel sys) - (input-dialog panel (format nil "Enter plugin name (without /tools), ~ - plugin will be added to the runtime and designtime:") - (lambda (result) - (when result - (let* ((s (format nil "~A/tools" sys))) - (add-dep-to-defsystem s (format nil "~A/tools" result)) - (ql:quickload s)) - (add-dep-to-defsystem sys result) - (ql:quickload sys) - (projects-populate panel))) - :height 250)) - -(defun add-dep-to-defsystem (sys file) - (let ((fname (asdf:system-source-file (asdf:find-system sys))) - (sys-list '())) - (with-open-file (s fname) - (loop - (let* ((line (read s nil))) - (unless line (return)) - (when (equalp (format nil "~A" (second line)) sys) - (setf (getf line :depends-on) - (append (getf line :depends-on) `(,file)))) - (push line sys-list)))) - (with-open-file (s fname :direction :output :if-exists :rename) - (let ((*print-case* :downcase)) - (dolist (n (reverse sys-list)) - (pprint n s)))))) - -(defun remove-dep-from-defsystem (sys file) - (let ((fname (asdf:system-source-file (asdf:find-system sys))) - (sys-list '())) - (with-open-file (s fname) - (loop - (let* ((line (read s nil))) - (unless line (return)) - (when (equalp (format nil "~A" (second line)) sys) - (let (new-comp) - (dolist (n (getf line :depends-on)) - (unless (equalp (format nil "~A" n) file) - (push n new-comp))) - (setf (getf line :depends-on) (reverse new-comp)))) - (push line sys-list)))) - (with-open-file (s fname :direction :output :if-exists :rename) - (let ((*print-case* :downcase)) - (dolist (n (reverse sys-list)) - (pprint n s)))))) - -(defun projects-add-lisp (panel sys) - (Input-dialog panel "Enter lisp component name (with out .lisp):" - (lambda (result) - (when result - (let ((path (asdf:component-pathname - (asdf:find-system sys)))) - (write-file "" (format nil "~A~A.lisp" - path result) - :action-if-exists nil) - (add-file-to-defsystem sys result :file) - (ql:quickload sys) - (projects-populate panel)))) - :height 230) - (ql:quickload sys)) - -(defun projects-add-clog (panel sys) - (input-dialog panel (format nil "Enter clog component name (with out .clog), ~ - a lisp component will also be created in the runtime system:") - (lambda (result) - (when result - (let* ((s (format nil "~A/tools" sys)) - (path (asdf:component-pathname - (asdf:find-system s)))) - (write-file "" (format nil "~A~A.clog" - path result) - :action-if-exists nil) - (add-file-to-defsystem s result :clog-file) - (ql:quickload s)) - (let ((path (asdf:component-pathname - (asdf:find-system sys)))) - (write-file "" (format nil "~A~A.lisp" - path result) - :action-if-exists nil) - (add-file-to-defsystem sys result :file) - (ql:quickload sys) - (projects-populate panel)))) - :height 250)) - -(defun add-file-to-defsystem (system file ftype) - (let ((fname (asdf:system-source-file (asdf:find-system system))) - (sys-list '())) - (with-open-file (s fname) - (loop - (let* ((line (read s nil))) - (unless line (return)) - (when (equalp (format nil "~A" (second line)) system) - (setf (getf line :components) - (append (getf line :components) `((,ftype ,file))))) - (push line sys-list)))) - (with-open-file (s fname :direction :output :if-exists :rename) - (let ((*print-case* :downcase)) - (dolist (n (reverse sys-list)) - (pprint n s)))))) - -(defun remove-file-from-defsystem (system file ftype) - (let ((fname (asdf:system-source-file (asdf:find-system system))) - (sys-list '())) - (with-open-file (s fname) - (loop - (let* ((line (read s nil))) - (unless line (return)) - (when (equalp (format nil "~A" (second line)) system) - (let (new-comp) - (dolist (n (getf line :components)) - (unless (and (equal (first n) ftype) - (equalp (second n) file)) - (push n new-comp))) - (setf (getf line :components) (reverse new-comp)))) - (push line sys-list)))) - (with-open-file (s fname :direction :output :if-exists :rename) - (let ((*print-case* :downcase)) - (dolist (n (reverse sys-list)) - (pprint n s))))) - (ql:quickload system)) - -(defun open-projects-component (target system list) - (let ((disp (select-text target)) - (item (text-value target))) - (cond ((equal item "") - (alert-toast target "Invalid action" "No /tools project" :time-out 1)) - ((equal (subseq item (1- (length item))) "/") - (setf (inner-html list) "") - (dolist (n (asdf:module-components - (asdf:find-component - (asdf:find-system system) - (subseq disp 0 (1- (length disp)))))) - (let ((name (asdf:component-relative-pathname n)) - (path (asdf:component-pathname n))) - (add-select-option list path name)))) - ((and (> (length item) 5) - (equal (subseq item (- (length item) 5)) ".clog")) - (on-new-builder-panel target :open-file item) - (on-show-control-events-win target)) - (t - (on-open-file target :open-file item))))) - (defun on-show-callers (body) (input-dialog body "Enter package:function-name :" (lambda (result) @@ -3017,7 +2566,6 @@ of controls and double click to select control." (create-gui-menu-item file :content "New CLOG-GUI Panel" :on-click 'on-new-builder-panel) (create-gui-menu-item file :content "New CLOG-WEB Page" :on-click 'on-new-builder-page) (create-gui-menu-item file :content "New Basic HTML Page" :on-click 'on-new-builder-basic-page) - (create-gui-menu-item file :content "New Bootstrap Page" :on-click 'on-new-builder-bst-page) (create-gui-menu-item file :content "New CLOG-WEB Delay Launch" :on-click 'on-new-builder-launch-page) (create-gui-menu-item file :content "New Custom Boot Page" :on-click 'on-new-builder-custom) (create-gui-menu-item file :content "New Application Template" :on-click 'on-new-app-template)