mirror of
https://github.com/rabbibotton/clog.git
synced 2025-12-06 10:40:45 -08:00
241 lines
18 KiB
Common Lisp
241 lines
18 KiB
Common Lisp
(in-package :clog-tools)
|
|
|
|
(defun project-tree-select (panel item &key method)
|
|
(unless (equal item "")
|
|
(cond ((and (> (length item) 5)
|
|
(equal (subseq item (- (length item) 5)) ".clog"))
|
|
(if (or (eq method :tab)
|
|
(and (not (eq method :here)) *open-external*))
|
|
(on-new-builder-panel-ext panel :open-file item) ;; need ext for both
|
|
(on-new-builder-panel panel :open-file item)))
|
|
(t
|
|
(if (eq method :emacs)
|
|
(swank:ed-in-emacs item)
|
|
(if (or (eq method :tab)
|
|
(and (not (eq method :here)) *open-external*))
|
|
(on-open-file-ext panel :open-file item)
|
|
(progn
|
|
(let ((win (on-open-file panel :open-file item)))
|
|
(when *project-tree-sticky-open*
|
|
(when win
|
|
(set-geometry win
|
|
:top (menu-bar-height win)
|
|
:left 300
|
|
:height "" :width ""
|
|
:bottom 5 :right 0)
|
|
(clog-ace:resize (window-param win))
|
|
(set-on-window-move win (lambda (obj)
|
|
(setf (width obj) (width obj))
|
|
(setf (height obj) (height obj))))))))))))))
|
|
|
|
(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
|
|
:keep-on-top t
|
|
:client-movement *client-side-movement*))
|
|
(projects (create-select (window-content win)))
|
|
(panel (create-panel (window-content win) :background-color :silver
|
|
:style "text-align:center;"
|
|
:class "w3-tiny"
|
|
:height 27 :top 30 :left 0 :right 0))
|
|
(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)))
|
|
(setf (project-tree-win app) win)
|
|
(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)
|
|
(setf (height obj) (height obj))))
|
|
(set-on-window-close win (lambda (obj)
|
|
(declare (ignore obj))
|
|
(setf (project-tree-win app) nil)))
|
|
(setf (positioning projects) :absolute)
|
|
(set-geometry projects :height 27 :width "100%" :top 0 :left 0 :right 0)
|
|
(set-on-click filter-btn (lambda (obj)
|
|
(declare (ignore 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 entry-point 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 (sort (uiop:subdirectories dir)
|
|
(lambda (a b)
|
|
(string-lessp (format nil "~A" a) (format nil "~A" b)))))
|
|
(unless (and (ppcre:scan *project-tree-dir-filter* (string-downcase (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
|
|
:on-context-menu
|
|
(lambda (obj)
|
|
(let* ((disp (text-value (content obj)))
|
|
(menu (create-panel obj
|
|
:left (left obj) :top (top obj)
|
|
:width (width obj)
|
|
:class *builder-window-desktop-class*))
|
|
(title (create-div menu :content disp))
|
|
(op (create-div menu :content "Toggle Open" :class *builder-menu-context-item-class*))
|
|
(opo (create-div menu :content "Open in OS" :class *builder-menu-context-item-class*)))
|
|
(declare (ignore title op))
|
|
(set-on-click opo (lambda (i)
|
|
(declare (ignore i))
|
|
(open-file-with-os item))
|
|
:cancel-event t)
|
|
(set-on-mouse-leave menu (lambda (obj) (destroy obj)))))
|
|
:content (first (last (pathname-directory item))))))
|
|
(dolist (item (sort (uiop:directory-files (directory-namestring dir))
|
|
(lambda (a b)
|
|
(if (equal (pathname-name a) (pathname-name b))
|
|
(string-lessp (format nil "~A" a)
|
|
(format nil "~A" b))
|
|
(string-lessp (format nil "~A" (pathname-name a))
|
|
(format nil "~A" (pathname-name b)))))))
|
|
(unless (and (ppcre:scan *project-tree-file-filter* (string-downcase (file-namestring item)))
|
|
filter)
|
|
(create-clog-tree-item (tree-root node)
|
|
:on-context-menu
|
|
(lambda (obj)
|
|
(let* ((disp (text-value (content obj)))
|
|
(menu (create-panel obj
|
|
:left (left obj) :top (top obj)
|
|
:width (width obj)
|
|
:class *builder-window-desktop-class*))
|
|
(title (create-div menu :content disp))
|
|
(op (create-div menu :content "Open" :class *builder-menu-context-item-class*))
|
|
(oph (create-div menu :content "Open this tab" :class *builder-menu-context-item-class*))
|
|
(opt (create-div menu :content "Open new tab" :class *builder-menu-context-item-class*))
|
|
(ope (create-div menu :content "Open emacs" :class *builder-menu-context-item-class*))
|
|
(opo (create-div menu :content "Open OS default" :class *builder-menu-context-item-class*))
|
|
(del (create-div menu :content "Delete" :class *builder-menu-context-item-class*)))
|
|
(declare (ignore title op))
|
|
(set-on-click menu (lambda (i)
|
|
(declare (ignore i))
|
|
(project-tree-select obj (format nil "~A" item)))
|
|
:cancel-event t)
|
|
(set-on-click oph (lambda (i)
|
|
(declare (ignore i))
|
|
(project-tree-select obj (format nil "~A" item) :method :here))
|
|
:cancel-event t)
|
|
(set-on-click opt (lambda (i)
|
|
(declare (ignore i))
|
|
(project-tree-select obj (format nil "~A" item) :method :tab))
|
|
:cancel-event t)
|
|
(set-on-click ope (lambda (i)
|
|
(declare (ignore i))
|
|
(project-tree-select obj (format nil "~A" item) :method :emacs))
|
|
:cancel-event t)
|
|
(set-on-click opo (lambda (i)
|
|
(declare (ignore i))
|
|
(open-file-with-os item))
|
|
:cancel-event t)
|
|
(set-on-click del (lambda (i)
|
|
(confirm-dialog i (format nil "Delete ~A?" disp)
|
|
(lambda (result)
|
|
(when result
|
|
(uiop:delete-file-if-exists item)
|
|
(destroy obj)))))
|
|
:cancel-event t)
|
|
(set-on-mouse-leave menu (lambda (obj) (destroy obj)))))
|
|
: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))
|
|
(setf (text tree) "")
|
|
(let* ((sel (value projects)))
|
|
(setf entry-point "")
|
|
(cond ((equal sel "")
|
|
(setf (text-value load-btn) "no project")
|
|
(setf (current-project app) nil))
|
|
(t
|
|
(setf (text-value load-btn) "loading")
|
|
(let* ((root (quicklisp:where-is-system sel))
|
|
(dir (directory-namestring (uiop:truename* root))))
|
|
(cond (root
|
|
(setf (text-value load-btn) "not loaded")
|
|
(setf (current-project app) sel)
|
|
(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-value load-btn) "loaded")
|
|
(let* ((*default-title-class* *builder-title-class*)
|
|
(*default-border-class* *builder-border-class*))
|
|
(setf (text-value load-btn) "loading")
|
|
(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)"
|
|
(or (asdf/system:component-entry-point (asdf:find-system sel))
|
|
""))))
|
|
(t
|
|
(setf entry-point "")
|
|
(setf (current-project app) nil)
|
|
(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))
|
|
(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))))))
|