mirror of
https://github.com/rabbibotton/clog.git
synced 2026-01-06 09:13:11 -08:00
project tree
This commit is contained in:
David Botton
parent
d45cd5641e
commit
c39b05eb5c
4 changed files with 195 additions and 6 deletions
1
clog.asd
vendored
1
clog.asd
vendored
|
|
@ -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")
|
||||
|
|
|
|||
178
tools/clog-builder-project-tree.lisp
Normal file
178
tools/clog-builder-project-tree.lisp
Normal file
|
|
@ -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))))))
|
||||
|
|
@ -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)) "")
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue