mirror of
https://github.com/rabbibotton/clog.git
synced 2025-12-06 02:30:42 -08:00
383 lines
18 KiB
Common Lisp
383 lines
18 KiB
Common Lisp
(in-package :clog-tools)
|
|
|
|
(defun on-show-project (obj &key project)
|
|
(let ((app (connection-data-item obj "builder-app-data")))
|
|
(when project
|
|
(setf (current-project app) project))
|
|
(if (project-win app)
|
|
(window-focus (project-win app))
|
|
(let* ((*default-title-class* *builder-title-class*)
|
|
(*default-border-class* *builder-border-class*)
|
|
(win (create-gui-window obj :title "Project Window"
|
|
:top 60 :left 232
|
|
:width 643 :height 625
|
|
:has-pinner t :client-movement *client-side-movement*)))
|
|
(create-projects (window-content win))
|
|
(setf (project-win app) win)
|
|
(set-on-window-close win (lambda (obj)
|
|
(declare (ignore obj))
|
|
(setf (project-win app) nil)))))))
|
|
|
|
(defun projects-load (fname)
|
|
(funcall (read-from-string "ql:quickload") fname))
|
|
|
|
(defun projects-list-local-systems ()
|
|
(funcall (read-from-string "ql:list-local-systems")))
|
|
|
|
(defun projects-local-directories ()
|
|
(symbol-value (read-from-string "ql:*local-project-directories*")))
|
|
|
|
(defun projects-setup (panel)
|
|
(let* ((app (connection-data-item panel "builder-app-data")))
|
|
(when *open-external*
|
|
(setf (checkedp (open-ext panel)) t))
|
|
(when *open-panels-as-popups*
|
|
(setf (checkedp (pop-panel panel)) t))
|
|
(when (uiop:directory-exists-p #P"~/common-lisp/")
|
|
(pushnew #P"~/common-lisp/"
|
|
(symbol-value (read-from-string "ql:*local-project-directories*"))
|
|
:test #'equalp))
|
|
(add-select-option (project-list panel) "None" "None")
|
|
(dolist (n (sort (projects-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")
|
|
(projects-populate panel)))))
|
|
|
|
(defun projects-view-dir (panel)
|
|
(let* ((sel (text-value (project-list panel))))
|
|
(if (equal sel "None")
|
|
(on-dir-win panel)
|
|
(let ((sys (asdf:find-system (format nil "~A" sel))))
|
|
(on-dir-win panel :dir (asdf:system-source-directory sys))))))
|
|
|
|
(defun projects-run (panel)
|
|
(let ((val (text-value (entry-point panel))))
|
|
(unless (equal val "")
|
|
(setf clog:*clog-debug* (lambda (event data)
|
|
(with-clog-debugger (panel :title val)
|
|
(funcall event data))))
|
|
(capture-eval (format nil "(~A)" val) :clog-obj panel
|
|
:capture-console nil
|
|
:capture-result nil
|
|
:eval-in-package "clog-user"))))
|
|
|
|
(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-rerender (panel)
|
|
(let ((app (connection-data-item panel "builder-app-data"))
|
|
(sel (text-value (project-list panel))))
|
|
(unless (equal sel "None")
|
|
(let ((sys (asdf:find-system (format nil "~A/tools" sel))))
|
|
(dolist (n (asdf:component-children sys))
|
|
(let ((name (format nil "~A" (asdf:component-relative-pathname n)))
|
|
(file-name (asdf:component-pathname n)))
|
|
(when (and (> (length name) 5)
|
|
(equal (subseq name (- (length name) 5)) ".clog"))
|
|
(let* ((win (create-gui-window panel :top 40 :left 225
|
|
:width 645 :height 430))
|
|
(box (create-panel-box-layout (window-content win)
|
|
:left-width 0 :right-width 0
|
|
:top-height 33 :bottom-height 0))
|
|
(content (center-panel box))
|
|
(panel-id (html-id content))
|
|
(render-file-name (format nil "~A~A.lisp"
|
|
(directory-namestring file-name)
|
|
(pathname-name file-name))))
|
|
(setf-next-id content 1)
|
|
(setf (overflow content) :auto)
|
|
(init-control-list app panel-id)
|
|
(clrhash (get-control-list app panel-id))
|
|
;; preset in case of empty clog file
|
|
(setf (attribute content "data-clog-name") "empty-clog-file")
|
|
(setf (attribute content "data-clog-type") "clog-data")
|
|
(setf (attribute content "data-in-package") "clog-user")
|
|
(setf (attribute content "data-custom-slots") "")
|
|
(setf (inner-html content)
|
|
(or (read-file file-name)
|
|
""))
|
|
(on-populate-loaded-window content :win win)
|
|
(setf (window-title win) (attribute content "data-clog-name"))
|
|
(write-file (render-clog-code content (bottom-panel box))
|
|
render-file-name)
|
|
(window-close win)
|
|
(format t "~A -> ~A~%" file-name render-file-name)))))))))
|
|
|
|
(defun projects-populate (panel)
|
|
(let ((app (connection-data-item panel "builder-app-data"))
|
|
(already (asdf:already-loaded-systems))
|
|
(sel (text-value (project-list panel))))
|
|
(setf (window-title (current-window panel))
|
|
(format nil "Project - ~A" sel))
|
|
(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)
|
|
(let ((fs (asdf:find-system sel)))
|
|
;; entry point
|
|
(setf (text-value (entry-point panel))
|
|
(or (asdf/system:component-entry-point
|
|
fs)
|
|
""))
|
|
(setf (current-project-dir app)
|
|
(asdf:component-pathname
|
|
fs))
|
|
;; fill runtime
|
|
(dolist (n (asdf:component-children
|
|
fs))
|
|
(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
|
|
fs))
|
|
(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:component-children 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 1))))
|
|
(t (c)
|
|
(declare (ignore c))
|
|
(add-select-option (designtime-list panel) "" "Missing /tools")
|
|
(add-select-option (design-deps panel) "" "Missing /tools"))))
|
|
(t
|
|
(flet ((load-proj (answer)
|
|
(cond (answer
|
|
(projects-load sel)
|
|
(ignore-errors
|
|
(progn
|
|
(projects-load (format nil "~A/tools" sel))))
|
|
(projects-load sel)
|
|
(projects-populate panel))
|
|
(t
|
|
(setf (current-project app) nil)
|
|
(setf (text-value (project-list panel)) "None")))))
|
|
(cond ((eq *app-mode* :batch)
|
|
(load-proj t)
|
|
(projects-rerender panel)
|
|
(clog:shutdown)
|
|
(uiop:quit))
|
|
(t
|
|
(let* ((*default-title-class* *builder-title-class*)
|
|
(*default-border-class* *builder-border-class*))
|
|
(confirm-dialog panel "Load project?"
|
|
(lambda (answer)
|
|
(load-proj answer))
|
|
: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)
|
|
(projects-load sys)
|
|
(projects-populate panel)))
|
|
:height 230)
|
|
(projects-load 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))
|
|
(projects-load s))
|
|
(add-dep-to-defsystem sys result)
|
|
(projects-load 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)
|
|
(projects-load sys)
|
|
(projects-populate panel))))
|
|
:height 230)
|
|
(projects-load 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)
|
|
(projects-load 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)
|
|
(projects-load 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)))))
|
|
(projects-load system))
|
|
|
|
(defun open-projects-component (target panel 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:component-children
|
|
(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"))
|
|
(if (checkedp (open-ext panel))
|
|
(on-new-builder-panel-ext target :open-file item :open-ext (checkedp (pop-panel panel)))
|
|
(on-new-builder-panel target :open-file item :open-ext (checkedp (pop-panel panel)))))
|
|
(t
|
|
(if (checkedp (open-ext panel))
|
|
(on-open-file-ext target :open-file item)
|
|
(on-open-file target :open-file item))))))
|