mirrors/clog
1
Fork 0
mirror of https://github.com/rabbibotton/clog.git synced 2025-12-26 11:53:09 -08:00
Code Issues Projects Releases Wiki Activity

color load button and no load dialog

Browse source
This commit is contained in:
David Botton 2024-05-31 12:13:44 -04:00
parent fe12e47acb
commit 49f777530e
1 changed files with 18 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

33
tools/clog-builder-project-tree.lisp
View file

@ -52,6 +52,7 @@
:class "w3-tiny" :class "w3-tiny"
:height 27 :top 30 :left 0 :right 0)) :height 27 :top 30 :left 0 :right 0))
(load-btn (create-button panel :content "no project" :style "height:27px;width:72px")) (load-btn (create-button panel :content "no project" :style "height:27px;width:72px"))
(load-np (background-color load-btn))
(run-btn (create-button panel :content "run" :style "height:27px;width:67px")) (run-btn (create-button panel :content "run" :style "height:27px;width:67px"))
(filter-btn (create-button panel :content "filter" :style "height:27px;width:67px")) (filter-btn (create-button panel :content "filter" :style "height:27px;width:67px"))
(asd-btn (create-button panel :content "asd edit" :style "height:27px;width:67px")) (asd-btn (create-button panel :content "asd edit" :style "height:27px;width:67px"))
@ -203,11 +204,14 @@
(project-tree-select obj (format nil "~A" item))) (project-tree-select obj (format nil "~A" item)))
:content (file-namestring item)))))) :content (file-namestring item))))))
(load-proj (sel) (load-proj (sel)
(setf (text-value load-btn) "loading")
(setf (background-color load-btn) :yellow)
(handler-case (handler-case
(projects-load (format nil "~A/tools" sel)) (projects-load (format nil "~A/tools" sel))
(error () (error ()
(projects-load sel))) (projects-load sel)))
(setf (text-value load-btn) "loaded") (setf (text-value load-btn) "loaded")
(setf (background-color load-btn) load-np)
(window-focus win)) (window-focus win))
(on-change (obj) (on-change (obj)
(declare (ignore obj)) (declare (ignore obj))
@ -215,14 +219,17 @@
(let* ((sel (value projects))) (let* ((sel (value projects)))
(setf entry-point "") (setf entry-point "")
(cond ((equal sel "") (cond ((equal sel "")
(setf (text-value load-btn) "no project") (setf (text-value load-btn) "no project")
(setf (background-color load-btn) load-np)
(setf (current-project app) nil)) (setf (current-project app) nil))
(t (t
(setf (text-value load-btn) "loading") (setf (text-value load-btn) "loading")
(setf (background-color load-btn) :yellow)
(let* ((root (quicklisp:where-is-system sel)) (let* ((root (quicklisp:where-is-system sel))
(dir (directory-namestring (uiop:truename* root)))) (dir (directory-namestring (uiop:truename* root))))
(cond (root (cond (root
(setf (text-value load-btn) "not loaded") (setf (text-value load-btn) "not loaded")
(setf (background-color load-btn) :tomato)
(setf (current-project app) sel) (setf (current-project app) sel)
(create-clog-tree tree (create-clog-tree tree
:fill-function (lambda (obj) :fill-function (lambda (obj)
@ -272,25 +279,20 @@
(set-on-mouse-leave menu (lambda (obj) (destroy obj)))))) (set-on-mouse-leave menu (lambda (obj) (destroy obj))))))
(let ((already (asdf:already-loaded-systems))) (let ((already (asdf:already-loaded-systems)))
(if (member sel already :test #'equalp) (if (member sel already :test #'equalp)
(setf (text-value load-btn) "loaded") (progn
(let* ((*default-title-class* *builder-title-class*) (setf (text-value load-btn) "loaded")
(*default-border-class* *builder-border-class*)) (setf (background-color load-btn) load-np))
(setf (text-value load-btn) "loading") (progn
(let* ((*default-title-class* *builder-title-class*) (setf (text-value load-btn) "not loaded")
(*default-border-class* *builder-border-class*)) (setf (background-color load-btn) :tomato))))
(confirm-dialog win "Load project?"
(lambda (answer)
(if answer
(load-proj sel)
(setf (text-value load-btn) "not loaded")))
:title "System not loaded")))))
(setf entry-point (format nil "(~A)" (setf entry-point (format nil "(~A)"
(or (asdf/system:component-entry-point (asdf:find-system sel)) (or (asdf/system:component-entry-point (asdf:find-system sel))
"")))) ""))))
(t (t
(setf entry-point "") (setf entry-point "")
(setf (current-project app) nil) (setf (current-project app) nil)
(setf (text-value load-btn) "no project")))))))) (setf (text-value load-btn) "no project")
(setf (background-color load-btn) :load-np))))))))
(fill-projects () (fill-projects ()
(setf (text projects) "") (setf (text projects) "")
(dolist (n (sort (quicklisp:list-local-systems) #'string-lessp)) (dolist (n (sort (quicklisp:list-local-systems) #'string-lessp))
@ -302,7 +304,8 @@
(declare (ignore obj)) (declare (ignore obj))
(cond ((equalp (text-value load-btn) "loaded") (cond ((equalp (text-value load-btn) "loaded")
(asdf:clear-system (value projects)) (asdf:clear-system (value projects))
(setf (text-value load-btn) "not loaded")) (setf (text-value load-btn) "not loaded")
(setf (background-color load-btn) :tomato))
((equalp (text-value load-btn) "not loaded") ((equalp (text-value load-btn) "not loaded")
(load-proj (value projects)))))) (load-proj (value projects))))))
(set-on-click refresh-btn (lambda (obj) (set-on-click refresh-btn (lambda (obj)