mirrors/clog
1
Fork 0
mirror of https://github.com/rabbibotton/clog.git synced 2025-12-06 02:30:42 -08:00
Code Issues Projects Releases Wiki Activity

reorg files

Browse source
This commit is contained in:
David Botton 2022-08-28 10:52:43 -04:00
parent f9624adb03
commit 3667e1f966
5 changed files with 466 additions and 456 deletions
Download patch file Download diff file Expand all files Collapse all files

14
clog.asd
View file

@ -53,15 +53,21 @@
:depends-on (#:clog #:clog-ace #:clog-terminal #:s-base64 #:swank :depends-on (#:clog #:clog-ace #:clog-terminal #:s-base64 #:swank
#:definitions) #:definitions)
:pathname "tools/" :pathname "tools/"
:components ((:file "clog-db-admin") :components (;; clog-db-admin app
(:file "clog-builder-settings") (:file "clog-db-admin")
;; clog-builder generated clode
(:file "clog-templates") (:file "clog-templates")
(:file "clog-builder")
(:file "clog-builder-repl")
(:file "image-to-data") (:file "image-to-data")
(:file "quick-start") (:file "quick-start")
(:file "threads") (:file "threads")
(:file "systems") (:file "systems")
(:file "sys-browser") (:file "sys-browser")
(:file "projects") (: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"))) (:file "clog-builder-images")))

38
tools/clog-builder-asdf-browser.lisp Normal file
View file

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

285
tools/clog-builder-projects.lisp Normal file
View file

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

133
tools/clog-builder-sys-browser.lisp Normal file
View file

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

452
tools/clog-builder.lisp
View file

@ -2498,173 +2498,6 @@ of controls and double click to select control."
(set-geometry (create-clog-builder-repl (window-content win)) (set-geometry (create-clog-builder-repl (window-content win))
:units "%" :width 100 :height 100))) :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) (defun on-convert-image (body)
(let ((params (form-multipart-data body))) (let ((params (form-multipart-data body)))
(create-div body :content params) (create-div body :content params)
@ -2683,290 +2516,6 @@ of controls and double click to select control."
(create-br body) (create-br body)
(create-div body :content (format nil "For example:<br>(create-img body :url-src \"~A\")" pic-data)))))) (create-div body :content (format nil "For example:<br>(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) (defun on-show-callers (body)
(input-dialog body "Enter package:function-name :" (input-dialog body "Enter package:function-name :"
(lambda (result) (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-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 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 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 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 Custom Boot Page" :on-click 'on-new-builder-custom)
(create-gui-menu-item file :content "New Application Template" :on-click 'on-new-app-template) (create-gui-menu-item file :content "New Application Template" :on-click 'on-new-app-template)