From c39b05eb5c405dc84589836139a67479b1b3544d Mon Sep 17 00:00:00 2001 From: David Botton Date: Fri, 3 May 2024 16:33:50 -0400 Subject: [PATCH] project tree --- clog.asd | 1 + tools/clog-builder-project-tree.lisp | 178 +++++++++++++++++++++++++++ tools/clog-builder-projects.lisp | 6 +- tools/clog-builder.lisp | 16 ++- 4 files changed, 195 insertions(+), 6 deletions(-) create mode 100644 tools/clog-builder-project-tree.lisp diff --git a/clog.asd b/clog.asd index 07ab7f6..b10e5b8 100644 --- a/clog.asd +++ b/clog.asd @@ -94,6 +94,7 @@ (:file "clog-builder-asdf-browser") (:file "clog-builder-sys-browser") (:file "clog-builder-dir-win") + (:file "clog-builder-project-tree") (:file "clog-builder-repl") (:file "clog-builder-shell") (:file "clog-builder-images") diff --git a/tools/clog-builder-project-tree.lisp b/tools/clog-builder-project-tree.lisp new file mode 100644 index 0000000..9aef98f --- /dev/null +++ b/tools/clog-builder-project-tree.lisp @@ -0,0 +1,178 @@ +(in-package :clog-tools) + +(defclass clog-tree (clog-div) + ((tree-root :accessor tree-root) + (indent-level :accessor indent-level)) + (:documentation "CLOG-Tree object - a collapsible tree component")) + +(defgeneric tree-root (clog-tree) + (:documentation "Accessor for clog-tree root, create clog-tree-items +on the tree-root or other clog-tree's.")) + +(defmethod create-clog-tree ((obj clog-obj) &key (content "") + (indent-level 0) + (node-html "📁") + (fill-function nil) + (visible t) + (class nil) + (html-id nil) + (auto-place t)) + (let* ((new-obj (create-div obj :content (format nil "~A " node-html) + :class class + :html-id html-id + :auto-place auto-place)) + (header (create-span new-obj :content content))) + (change-class new-obj 'clog-tree) + (setf (indent-level new-obj) indent-level) + (setf (tree-root new-obj) (create-span header)) + (dotimes (n indent-level) + (create-span new-obj :content "  " :auto-place :top)) + (flet ((toggle-tree () + (cond (fill-function + (if visible + (setf (text (tree-root new-obj)) "") + (funcall fill-function new-obj)) + (setf visible (not visible))) + (t + (if visible + (setf (hiddenp (tree-root new-obj)) t) + (setf (hiddenp (tree-root new-obj)) nil)) + (setf visible (not visible)))))) + (setf visible (not visible)) + (toggle-tree) + (set-on-mouse-down new-obj + (lambda (obj data) + (declare (ignore obj data)) + (toggle-tree)) + :cancel-event t)) ; prevent event bubble up tree + new-obj)) + +(defclass clog-tree-item (clog-div) + ((tree-item :accessor tree-item) + (indent-level :accessor indent-level)) + (:documentation "CLOG-tree-item object - a tree list item")) + +(defgeneric tree-item (clog-tree-item) + (:documentation "Accessor for clog-tree-item item.")) + +(defmethod create-clog-tree-item ((obj clog-obj) &key (content "") + (indent-level 0) + (node-html "📄") + (on-click nil) + (class nil) + (html-id nil) + (auto-place t)) + (let* ((new-obj (create-div obj :content (format nil "~A " node-html) + :class class + :html-id html-id + :auto-place auto-place)) + (header (create-span new-obj :content content))) + (change-class new-obj 'clog-tree-item) + (dotimes (n indent-level) + (create-span new-obj :content "  " :auto-place :top)) + (setf (indent-level new-obj) indent-level) + (setf (tree-item new-obj) (create-span header)) + (when on-click + (set-on-mouse-down new-obj (lambda (obj data) + (declare (ignore data)) + (funcall on-click obj)) + :cancel-event t)) + new-obj)) + +(defun project-tree-select (panel item) + (unless (equal item "") + (cond ((and (> (length item) 5) + (equal (subseq item (- (length item) 5)) ".clog")) + (if t + (on-new-builder-panel-ext panel :open-file item) ;; need ext for both + (on-new-builder-panel panel :open-file item))) + (t + (if nil + (on-open-file-ext panel :open-file item) + (on-open-file panel :open-file item)))))) + +(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) + (let ((app (connection-data-item obj "builder-app-data"))) + (when (uiop:directory-exists-p #P"~/common-lisp/") + (pushnew #P"~/common-lisp/" + (symbol-value (read-from-string "ql:*local-project-directories*")) + :test #'equalp)) + (when project + (setf (current-project app) project)) + (if (project-tree-win app) + (window-focus (project-tree-win app)) + (let* ((*default-title-class* *builder-title-class*) + (*default-border-class* *builder-border-class*) + (win (create-gui-window obj :title "Project Tree" + :width 300 + :has-pinner t + :client-movement *client-side-movement*)) + (projects (create-select (window-content win))) + (dir-loc (create-panel (window-content win) :background-color :silver + :height 27 :top 30 :left 0 :right 0)) + (tree (create-panel (window-content win) :overflow :scroll + :top 60 :bottom 0 :left 0 :right 0))) + (setf (project-tree-win app) win) + (set-geometry win :top (menu-bar-height win) :left 0 :height "" :bottom 5 :right "") + (set-on-window-move win (lambda (obj) + (setf (height obj) (height obj)))) + (setf (positioning projects) :absolute) + (set-geometry projects :height 27 :width "" :top 0 :left 0 :right 0) + (add-class dir-loc "w3-tiny") + (add-class tree "w3-small") + (flet ((on-change (obj) + (declare (ignore obj)) + (let* ((sel (value projects)) + (root (quicklisp:where-is-system sel)) + (dir (directory-namestring (uiop:truename* root)))) + (cond (root + (setf (text dir-loc) "Not Loaded") + (setf (text tree) "") + (create-clog-tree tree + :fill-function (lambda (obj) + (project-tree-dir-select obj dir)) + :node-html "🦎" + :content root) + (let ((already (asdf:already-loaded-systems))) + (if (member sel already :test #'equalp) + (setf (text dir-loc) "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*) + (*default-border-class* *builder-border-class*)) + (confirm-dialog win "Load project?" + (lambda (answer) + (load-proj answer)) + :title "System not loaded")))))) + (t + (setf (text dir-loc) "")))))) + (dolist (n (quicklisp:list-local-systems)) + (add-select-option projects n n :selected (equalp n project)) + (when (equalp n project) + (on-change projects))) + (add-select-option projects "" "Select Project" :selected (not project)) + (set-on-change projects #'on-change)))))) diff --git a/tools/clog-builder-projects.lisp b/tools/clog-builder-projects.lisp index a5d5764..576a2c1 100644 --- a/tools/clog-builder-projects.lisp +++ b/tools/clog-builder-projects.lisp @@ -8,8 +8,8 @@ (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 + (win (create-gui-window obj :title "ASD Project Window" + :top 60 :left 325 :width 643 :height 625 :has-pinner t :client-movement *client-side-movement*))) (create-projects (window-content win)) @@ -153,7 +153,7 @@ (already (asdf:already-loaded-systems)) (sel (text-value (project-list panel)))) (setf (window-title (parent (parent panel))) - (format nil "Project - ~A" sel)) + (format nil "ASD Project - ~A" sel)) (reset-control-pallete panel) (setf (inner-html (runtime-list panel)) "") (setf (inner-html (designtime-list panel)) "") diff --git a/tools/clog-builder.lisp b/tools/clog-builder.lisp index 4a896f5..16cebec 100644 --- a/tools/clog-builder.lisp +++ b/tools/clog-builder.lisp @@ -64,10 +64,14 @@ clog-builder window.") :accessor current-project-dir :initform "" :documentation "Current Project") + (project-tree-win + :accessor project-tree-win + :initform nil + :documentation "Project Tree window") (project-win :accessor project-win :initform nil - :documentation "Project window") + :documentation "ASD Project window") (control-properties-win :accessor control-properties-win :initform nil @@ -370,9 +374,14 @@ clog-builder window.") (on-new-builder-panel obj)))) (create-gui-menu-item file :content "New CLOG Panel Popup Editor" :on-click 'on-new-builder-page) (create-gui-menu-item file :content "New HTML Panel Popup Editor" :on-click 'on-new-builder-basic-page) - (create-gui-menu-item file :content "New Custom Boot Panel External Editor" :on-click 'on-new-builder-custom-page)) + (create-gui-menu-item file :content "New Custom Boot Panel External Editor" :on-click 'on-new-builder-custom-page) + (create-gui-menu-item file :content "New CLOG Builder Window" :on-click + (lambda (obj) + (declare (ignore obj)) + (open-window (window body) "/builder")))) ;; Menu -> Project - (create-gui-menu-item src :content "Project Window" :on-click 'on-show-project) + (create-gui-menu-item src :content "Project Tree" :on-click 'on-project-tree) + (create-gui-menu-item src :content "ASD Project Window" :on-click 'on-show-project) (create-gui-menu-item src :content "New Project from template" :on-click 'on-new-app-template) (create-gui-menu-item src :content "New OS Directory Browser" :on-click 'on-dir-win) (create-gui-menu-item src :content "New System Source Browser" :on-click 'on-new-sys-browser) @@ -488,6 +497,7 @@ clog-builder window.") (when *start-project* (projects-load *start-project*)) (on-show-project body :project *start-project*) + (on-project-tree body :project *start-project*) (when *start-dir* (when *start-project* (set-geometry (current-window body) :top 38 :left 5 :right "" :height "" :bottom 22)