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

project tree controls

Browse source
This commit is contained in:
David Botton 2024-05-05 20:55:54 -04:00
parent 358b4b1309
commit 7a3f0ddace
9 changed files with 135 additions and 70 deletions
Download patch file Download diff file Expand all files Collapse all files

5
tools/clog-builder-control-list.lisp
View file

@ -46,7 +46,10 @@
(unless (controls-win app) (unless (controls-win app)
(let* ((*default-title-class* *builder-title-class*) (let* ((*default-title-class* *builder-title-class*)
(*default-border-class* *builder-border-class*) (*default-border-class* *builder-border-class*)
(win (create-gui-window obj :title "Controls" :has-pinner t :width 220)) (win (create-gui-window obj :title "Controls"
:has-pinner t
:keep-on-top t
:width 220))
(content (window-content win)) (content (window-content win))
(sheight (floor (/ (height content) 2))) (sheight (floor (/ (height content) 2)))
(swidth (floor (width content))) (swidth (floor (width content)))

5
tools/clog-builder-control-properties.lisp
View file

@ -6,7 +6,10 @@
(unless (control-properties-win app) (unless (control-properties-win app)
(let* ((*default-title-class* *builder-title-class*) (let* ((*default-title-class* *builder-title-class*)
(*default-border-class* *builder-border-class*) (*default-border-class* *builder-border-class*)
(win (create-gui-window obj :title "Properties" :has-pinner t :width 400)) (win (create-gui-window obj :title "Properties"
:has-pinner t
:keep-on-top t
:width 400))
(content (window-content win)) (content (window-content win))
(control-list (create-table content))) (control-list (create-table content)))
(add-class content *builder-pallete-class*) (add-class content *builder-pallete-class*)

1
tools/clog-builder-dir-win.lisp
View file

@ -8,6 +8,7 @@
:top top :left left :top top :left left
:width 600 :height 400 :width 600 :height 400
:has-pinner t :has-pinner t
:keep-on-top t
:client-movement *client-side-movement*)) :client-movement *client-side-movement*))
(d (create-dir-view (window-content win)))) (d (create-dir-view (window-content win))))
(set-geometry d :top 0 :left 0 :right 0 :bottom 0 :width "" :height "") (set-geometry d :top 0 :left 0 :right 0 :bottom 0 :width "" :height "")

8
tools/clog-builder-files.lisp
View file

@ -94,6 +94,8 @@
(win (create-gui-window obj :title title (win (create-gui-window obj :title title
:title-class title-class :title-class title-class
:width 700 :height 480 :width 700 :height 480
:has-pinner is-console
:keep-on-top is-console
:client-movement *client-side-movement*)) :client-movement *client-side-movement*))
(box (create-panel-box-layout (window-content win) (box (create-panel-box-layout (window-content win)
:left-width 0 :right-width 0 :left-width 0 :right-width 0
@ -104,9 +106,11 @@
(m-save (create-gui-menu-item m-file :content "save (cmd/ctrl-s)")) (m-save (create-gui-menu-item m-file :content "save (cmd/ctrl-s)"))
(m-saveas (create-gui-menu-item m-file :content "save as..")) (m-saveas (create-gui-menu-item m-file :content "save as.."))
(m-revert (create-gui-menu-item m-file :content "revert")) (m-revert (create-gui-menu-item m-file :content "revert"))
(m-emacs (unless (in-clog-popup-p obj) (m-emacs (unless (or (in-clog-popup-p obj)
is-console)
(create-gui-menu-item m-file :content "open in emacs"))) (create-gui-menu-item m-file :content "open in emacs")))
(m-ntab (unless (in-clog-popup-p obj) (m-ntab (unless (or (in-clog-popup-p obj)
is-console)
(create-gui-menu-item m-file :content "open in new tab"))) (create-gui-menu-item m-file :content "open in new tab")))
(m-edit (create-gui-menu-drop-down menu :content "Edit")) (m-edit (create-gui-menu-drop-down menu :content "Edit"))
(m-undo (create-gui-menu-item m-edit :content "undo (cmd/ctrl-z)")) (m-undo (create-gui-menu-item m-edit :content "undo (cmd/ctrl-z)"))

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

@ -24,21 +24,6 @@
(setf (width obj) (width obj)) (setf (width obj) (width obj))
(setf (height obj) (height obj))))))))))))) (setf (height obj) (height obj)))))))))))))
(defun project-tree-dir-select (panel dir)
(dolist (item (uiop:subdirectories dir))
(create-clog-tree (tree-root panel)
:fill-function (lambda (obj)
(project-tree-dir-select obj (format nil "~A" item)))
:indent-level (1+ (indent-level panel))
:visible nil
:content (first (last (pathname-directory item)))))
(dolist (item (uiop:directory-files (directory-namestring dir)))
(create-clog-tree-item (tree-root panel)
:on-click (lambda (obj)
(project-tree-select obj (format nil "~A" item)))
; :indent-level (1+ (indent-level panel))
:content (file-namestring item))))
(defun on-project-tree (obj &key project) (defun on-project-tree (obj &key project)
(let ((app (connection-data-item obj "builder-app-data"))) (let ((app (connection-data-item obj "builder-app-data")))
(when (uiop:directory-exists-p #P"~/common-lisp/") (when (uiop:directory-exists-p #P"~/common-lisp/")
@ -54,30 +39,90 @@
(win (create-gui-window obj :title "Project Tree" (win (create-gui-window obj :title "Project Tree"
:width 300 :width 300
:has-pinner t :has-pinner t
:keep-on-top t
:client-movement *client-side-movement*)) :client-movement *client-side-movement*))
(projects (create-select (window-content win))) (projects (create-select (window-content win)))
(dir-loc (create-panel (window-content win) :background-color :silver (panel (create-panel (window-content win) :background-color :silver
:style "text-align:center;"
:class "w3-tiny"
:height 27 :top 30 :left 0 :right 0)) :height 27 :top 30 :left 0 :right 0))
(tree (create-panel (window-content win) :overflow :scroll (load-btn (create-button panel :content "no project" :style "height:27px;width:72px"))
(run-btn (create-button panel :content "run" :style "height:27px;width:72px"))
(entry-point "")
(filter-btn (create-button panel :content "filter" :style "height:27px;width:72px"))
(asd-btn (create-button panel :content "asd edit" :style "height:27px;width:72px"))
(tree (create-panel (window-content win)
:class "w3-small"
:overflow :scroll
:top 60 :bottom 0 :left 0 :right 0))) :top 60 :bottom 0 :left 0 :right 0)))
(setf (project-tree-win app) win) (setf (project-tree-win app) win)
(set-geometry win :top (menu-bar-height win) :left 0 :height "" :bottom 5 :right "") (set-geometry win :top (menu-bar-height win) :left 0 :height "" :bottom 5 :right "")
(set-on-click asd-btn (lambda (obj)
(on-show-project obj)))
(set-on-window-move win (lambda (obj) (set-on-window-move win (lambda (obj)
(setf (height obj) (height obj)))) (setf (height obj) (height obj))))
(set-on-window-close win (lambda (obj) (set-on-window-close win (lambda (obj)
(declare (ignore obj)) (declare (ignore obj))
(setf (project-tree-win app) nil))) (setf (project-tree-win app) nil)))
(setf (positioning projects) :absolute) (setf (positioning projects) :absolute)
(set-geometry projects :height 27 :width "" :top 0 :left 0 :right 0) (set-geometry projects :height 27 :width "100%" :top 0 :left 0 :right 0)
(add-class dir-loc "w3-tiny") (set-on-click filter-btn (lambda (obj)
(add-class tree "w3-small") (declare (ignore obj))
(flet ((on-change (obj) (if (equalp (text-value filter-btn)
"filter")
(setf (text-value filter-btn) "filter off")
(setf (text-value filter-btn) "filter"))))
(set-on-click run-btn
(lambda (obj)
(let* ((*default-title-class* *builder-title-class*)
(*default-border-class* *builder-border-class*))
(input-dialog obj "Run form:"
(lambda (result)
(when result
(setf clog:*clog-debug*
(lambda (event data)
(with-clog-debugger (panel :standard-output (stdout app))
(funcall event data))))
(capture-eval result
:clog-obj obj
:capture-console nil
:capture-result nil
:eval-in-package "clog-user")))
:default-value entry-point))))
(labels ((project-tree-dir-select (node dir)
(let ((filter (equalp (text-value filter-btn)
"filter")))
(dolist (item (uiop:subdirectories dir))
(unless (and (ppcre:scan *project-tree-dir-filter* (format nil "~A" item))
filter)
(create-clog-tree (tree-root node)
:fill-function (lambda (obj)
(project-tree-dir-select obj (format nil "~A" item)))
:indent-level (1+ (indent-level node))
:visible nil
:content (first (last (pathname-directory item))))))
(dolist (item (uiop:directory-files (directory-namestring dir)))
(unless (and (ppcre:scan *project-tree-file-filter* (file-namestring item))
filter)
(create-clog-tree-item (tree-root node)
:on-click (lambda (obj)
(project-tree-select obj (format nil "~A" item)))
:content (file-namestring item))))))
(load-proj (sel)
(handler-case
(projects-load (format nil "~A/tools" sel))
(error ()
(projects-load sel)))
(setf (text-value load-btn) "loaded")
(window-focus win))
(on-change (obj)
(declare (ignore obj)) (declare (ignore obj))
(let* ((sel (value projects)) (let* ((sel (value projects))
(root (quicklisp:where-is-system sel)) (root (quicklisp:where-is-system sel))
(dir (directory-namestring (uiop:truename* root)))) (dir (directory-namestring (uiop:truename* root))))
(cond (root (cond (root
(setf (text dir-loc) "Not Loaded") (setf (current-project app) sel)
(setf (text-value load-btn) "not loaded")
(setf (text tree) "") (setf (text tree) "")
(create-clog-tree tree (create-clog-tree tree
:fill-function (lambda (obj) :fill-function (lambda (obj)
@ -86,26 +131,29 @@
:content root) :content root)
(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 dir-loc) "Loaded") (setf (text-value load-btn) "loaded")
(flet ((load-proj (answer)
(cond (answer
(setf (current-project app) sel)
(handler-case
(projects-load (format nil "~A/tools" sel))
(error ()
(projects-load sel)))
(setf (text dir-loc) "Loaded")
(window-focus win))
(t
(setf (current-project app) nil)))))
(let* ((*default-title-class* *builder-title-class*) (let* ((*default-title-class* *builder-title-class*)
(*default-border-class* *builder-border-class*)) (*default-border-class* *builder-border-class*))
(setf (text-value load-btn) "loading")
(confirm-dialog win "Load project?" (confirm-dialog win "Load project?"
(lambda (answer) (lambda (answer)
(load-proj answer)) (if answer
:title "System not loaded")))))) (load-proj sel)
(setf (text-value load-btn) "not loaded")))
:title "System not loaded"))))
(setf entry-point (format nil "(~A)"
(or (asdf/system:component-entry-point (asdf:find-system sel))
""))))
(t (t
(setf (text dir-loc) "")))))) (setf entry-point "")
(setf (text-value load-btn) "no project"))))))
(set-on-click load-btn (lambda (obj)
(declare (ignore obj))
(cond ((equalp (text-value load-btn) "loaded")
(asdf:clear-system (value projects))
(setf (text-value load-btn) "not loaded"))
((equalp (text-value load-btn) "not loaded")
(load-proj (value projects))))))
(dolist (n (quicklisp:list-local-systems)) (dolist (n (quicklisp:list-local-systems))
(add-select-option projects n n :selected (equalp n project)) (add-select-option projects n n :selected (equalp n project))
(when (equalp n project) (when (equalp n project)

4
tools/clog-builder-projects.lisp
View file

@ -11,7 +11,9 @@
(win (create-gui-window obj :title "ASD Project Window" (win (create-gui-window obj :title "ASD Project Window"
:top 60 :left 325 :top 60 :left 325
:width 643 :height 625 :width 643 :height 625
:has-pinner t :client-movement *client-side-movement*))) :has-pinner t
:keep-on-top t
:client-movement *client-side-movement*)))
(create-projects (window-content win)) (create-projects (window-content win))
(setf (project-win app) win) (setf (project-win app) win)
(set-on-window-close win (lambda (obj) (set-on-window-close win (lambda (obj)

2
tools/clog-builder-settings.lisp
View file

@ -50,6 +50,8 @@
;; CLOG Panels ;; CLOG Panels
(defparameter *project-tree-sticky-open* t) (defparameter *project-tree-sticky-open* t)
(defparameter *project-tree-dir-filter* "(\\\\|\\/)\\..*(\\\\|\\/)$")
(defparameter *project-tree-file-filter* "(^\\..*)|(.*~$)|(.*\\.bak$)")
;; CLOG Builder REPL ;; CLOG Builder REPL
(defparameter *clog-repl-use-console* t) (defparameter *clog-repl-use-console* t)

5
tools/clog-builder.lisp
View file

@ -337,7 +337,7 @@ clog-builder window.")
(with-clog-debugger (body :standard-output (stdout app)) (with-clog-debugger (body :standard-output (stdout app))
(when *builder-window-show-static-root-class* (when *builder-window-show-static-root-class*
(setf (z-index (create-panel body :positioning :fixed (setf (z-index (create-panel body :positioning :fixed
:bottom 0 :left 0 :bottom 0 :right 0
:class *builder-window-show-static-root-class* :class *builder-window-show-static-root-class*
:content (format nil "static-root: ~A" clog:*static-root*))) :content (format nil "static-root: ~A" clog:*static-root*)))
-9999)) -9999))
@ -392,7 +392,7 @@ clog-builder window.")
(create-gui-menu-item tools :content "Thread Viewer" :on-click 'on-show-thread-viewer) (create-gui-menu-item tools :content "Thread Viewer" :on-click 'on-show-thread-viewer)
(create-gui-menu-item tools :content "CLOG Builder REPL" :on-click 'on-repl) (create-gui-menu-item tools :content "CLOG Builder REPL" :on-click 'on-repl)
(create-gui-menu-item tools :content "CLOG Builder Console" :on-click 'on-open-console) (create-gui-menu-item tools :content "CLOG Builder Console" :on-click 'on-open-console)
(create-gui-menu-item tools :content "OS Shell" :on-click 'on-shell) (create-gui-menu-item tools :content "OS Pseudo Shell" :on-click 'on-shell)
(create-gui-menu-item tools :content "Copy/Cut History" :on-click 'on-show-copy-history-win) (create-gui-menu-item tools :content "Copy/Cut History" :on-click 'on-show-copy-history-win)
(unless *clogframe-mode* (unless *clogframe-mode*
(create-gui-menu-item tools :content "Image to HTML Data" :on-click 'on-image-to-data)) (create-gui-menu-item tools :content "Image to HTML Data" :on-click 'on-image-to-data))
@ -496,7 +496,6 @@ clog-builder window.")
(t (t
(when *start-project* (when *start-project*
(projects-load *start-project*)) (projects-load *start-project*))
(on-show-project body :project *start-project*)
(on-project-tree body :project *start-project*) (on-project-tree body :project *start-project*)
(when *start-dir* (when *start-dir*
(when *start-project* (when *start-project*

3
tools/preferences.lisp.sample vendored
View file

@ -22,6 +22,9 @@
;; When opennning source editors not external, open to fill right of tree to ;; When opennning source editors not external, open to fill right of tree to
;; browser edge ;; browser edge
(setf *project-tree-sticky-open* t) (setf *project-tree-sticky-open* t)
;; Regex filters to use when set to remove from project directories
(setf *project-tree-dir-filter* "(\\\\|\\/)\\..*(\\\\|\\/)$")
(setf *project-tree-file-filter* "(^\\..*)|(.*~$)|(.*\\.bak$)")
;; CLOG Source Editor ;; CLOG Source Editor