cage/tinmop
1
0
Fork 0
mirror of https://codeberg.org/cage/tinmop/ synced 2025-03-08 10:47:37 +01:00
Code Issues

- implemented some features of tree filesystem window: expanding/closing nodes and renaming files or directory.

Browse Source
This commit is contained in:
cage 2021-12-10 11:50:37 +01:00
parent 026784e8c5
commit 7619344a36
14 changed files with 399 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
etc/default-theme.conf
View File

@ -623,4 +623,36 @@ gemini-toc-window.input.selected.background = black
gemini-toc-window.input.selected.foreground = #71AF8C
gemini-toc-window.padding = "⋅"
gemini-toc-window.padding = "⋅"
# file explorer
# this is the message that shows available keybindings
file-explorer.background = black
file-explorer.foreground = #E2BE6F
file-explorer.height = 1/2
# see configuration for tree in thread window above
file-explorer.tree.branch.foreground = red
file-explorer.tree.arrow.foreground = magenta
file-explorer.tree.root.foreground = #ffff00
file-explorer.tree.data.foreground = white
file-explorer.tree.data-leaf.foreground = cyan
file-explorer.tree.arrow.value = "🞂"
file-explorer.tree.leaf.value = "╰"
file-explorer.tree.branch.value = "├"
file-explorer.tree.spacer.value = "─"
file-explorer.tree.vertical-line.value = "│"

14
etc/init.lisp
View File

@ -137,6 +137,8 @@
;; global keymap
(define-key "y y" #'open-file-explorer)
(define-key "q" #'quit) ; here we are calling the custom
; function defined above
(define-key "C-a" #'show-about-window)
@ -592,6 +594,18 @@
(define-key "a" #'open-chat-link-window *chat-message-keymap*)
;; file explorer
(define-key "x" #'file-explorer-expand *filesystem-explorer-keymap*)
(define-key "c" #'file-explorer-close *filesystem-explorer-keymap*)
(define-key "m" #'file-explorer-rename *filesystem-explorer-keymap*)
(define-key "up" #'file-explorer-go-up *filesystem-explorer-keymap*)
(define-key "down" #'file-explorer-go-down *filesystem-explorer-keymap*)
;;;; hooks
;; this module will install an hook to rewrite urls; By default it

224
src/filesystem-tree-window.lisp
View File

@ -17,36 +17,55 @@
(in-package :filesystem-tree-window)
(defun make-node-data (path dirp)
(list :path path :dirp dirp))
(cond
((or (fs:backreference-dir-p path)
(fs:loopback-reference-dir-p path)
(not dirp))
(list :path path :dirp dirp))
(dirp
(if (scan "/$" path)
(list :path path :dirp t)
(list :path (strcat path "/") :dirp t)))))
(defun make-root-tree (&optional (path "/"))
(mtree:make-node (make-node-data path t)))
(defclass filesysten-tree-window (tree-holder
(defclass filesystem-tree-window (wrapper-window
tree-holder
key-config-holder
row-oriented-widget
focus-marked-window
title-window)
title-window
border-window)
((filesystem-root
:initform (make-root-tree)
:initarg :filesystem-root
:accessor filesystem-root
:type m-tree
:documentation "The filesystem tree"))
:documentation "The filesystem tree")
(filesystem-expand-function
:initform #'expand-local-filesystem-node
:accessor filesystem-expand-function
:type function)
(filesystem-rename-function
:initform #'rename-local-filesystem-node
:accessor filesystem-rename-function
:type function))
(:documentation "A window that shows and allow intercating with a hierarchical filesystem"))
(defmethod refresh-config :after ((object filesysten-tree-window))
(defmethod refresh-config :after ((object filesystem-tree-window))
(with-croatoan-window (croatoan-window object)
(refresh-config-colors object swconf:+key-keybindings-window+)
(refresh-config-sizes object swconf:+key-keybindings-window+)
(refresh-config-colors object swconf:+key-file-explorer+)
(refresh-config-sizes object swconf:+key-file-explorer+)
(let ((y (- (win-height *main-window*)
(win-height object)
+command-window-height+)))
(win-move object 0 y))))
(defmethod calculate :after ((object filesysten-tree-window) dt)
(defmethod calculate :after ((object filesystem-tree-window) dt)
(declare (ignore object dt)))
(defmethod draw :after ((object filesysten-tree-window)))
(defmethod draw :after ((object filesystem-tree-window)))
(defmacro gen-tree-data-fetcher (name key)
`(defun ,(misc:format-fn-symbol t "tree-~a" name) (data)
@ -72,48 +91,195 @@
(bgcolor window)
(fgcolor window)))
;; (defun expand-local-filesystem-node (matching-node)
;; (let ((path (tree-path (data matching-node))))
(defun expand-local-filesystem-node (matching-node)
(let ((path (tree-path (data matching-node))))
(assert path)
(let* ((children (mapcar (lambda (a)
(if (not (or (fs:backreference-dir-p a)
(fs:loopback-reference-dir-p a)))
(uri:normalize-path a)
a))
(fs:collect-children path)))
(files (remove-if #'fs:dirp children))
(directories (remove-if-not #'fs:dirp children)))
(when (or files directories)
(remove-all-children matching-node)
(loop for directory in directories do
(add-child matching-node
(make-instance 'm-tree :data (make-node-data directory t))))
(loop for file in files do
(add-child matching-node
(make-instance 'm-tree :data (make-node-data file nil)))))
matching-node)))
;; (defun expand-treenode (root expand-fn))
(defun rename-local-filesystem-node (matching-node new-path)
(let ((path (tree-path (data matching-node))))
(assert path)
(fs:rename-a-file path new-path)))
(defun %expand-treenode (root path-to-expand expand-fn)
(when-let ((matching-node (first (mtree:find-child-if root
(lambda (a)
(string= (tree-path (data a))
path-to-expand))))))
(funcall expand-fn matching-node)))
(defun build-annotated-tree-rows (window)
"Split the tree in column to fit the window height and pages to fit window width"
(defmethod draw :around ((object filesystem-tree-window))
(when-window-shown (object)
(call-next-method)))
(defun %build-annotated-tree-rows (window root-node)
(with-accessors ((render-arrow-value render-arrow-value)
(render-leaf-value render-leaf-value)
(render-branch-value render-branch-value)
(render-spacer-value render-spacer-value)
(render-vertical-line-value render-vertical-line-value)
(filesystem-root filesystem-root)) window
(when-let* ((tree-lines (tree->annotated-lines filesystem-root
(when-let* ((tree-lines (tree->annotated-lines root-node
:print-data-fn #'build-data-for-print
:arrow-char render-arrow-value
:spacer-child render-spacer-value
:child-char render-branch-value
:line-char render-vertical-line-value
:last-child-char render-leaf-value
:print-data t)))
:print-data t))
(tree-data (collect-nodes-data root-node)))
(with-accessors ((tree-color-map tree-color-map)) window
(let ((colorized-rows (loop for line in tree-lines
collect
(colorize-tree-line line tree-color-map))))
(mapcar (lambda (node-data)
(reduce #'cat-tui-string
(colorize-tree-line line tree-color-map)))))
(mapcar (lambda (colored-text node-data)
(make-instance 'line
:normal-text (treenode->text node-data window)
:selected-text (treenode->selected-text node-data window)
:normal-text colored-text
:selected-text
(tui-string-apply-colors colored-text
(win-bgcolor window)
(win-fgcolor window))
:fields node-data
:normal-bg (bgcolor window)
:normal-fg (fgcolor window)
:selected-bg (fgcolor window)
:selected-fg (bgcolor window)))
colorized-rows))))))
:normal-bg (win-bgcolor window)
:normal-fg (win-fgcolor window)
:selected-bg (win-fgcolor window)
:selected-fg (win-bgcolor window)))
colorized-rows
(reverse tree-data)))))))
(defun init ()
(defun build-annotated-tree-rows (window)
(%build-annotated-tree-rows window (filesystem-root window)))
(defmethod resync-rows-db ((object filesystem-tree-window)
&key
(redraw t) (selected-path nil))
(with-accessors ((rows rows)
(selected-line-bg selected-line-bg)
(selected-line-fg selected-line-fg)) object
(line-oriented-window:update-all-rows object
(build-annotated-tree-rows object))
(when (string-not-empty-p selected-path)
(when-let ((index (rows-position-if object
(lambda (a)
(string= (tree-path (fields a))
selected-path)))))
(select-row object index)))
(when redraw
(draw object))
object))
(defun find-node (root-node matching-path)
(first (mtree:find-child-if root-node
(lambda (a)
(string= (tree-path (data a))
matching-path)))))
(defun close-treenode (window node-path)
(when-let ((matching-node (find-node (filesystem-root window) node-path)))
(remove-all-children matching-node)
(win-clear window :redraw nil)
(resync-rows-db window :redraw t :selected-path node-path)))
(defun jump-to-parent-node (window path)
(when (fs:backreference-dir-p path)
(let ((parent-path (fs:parent-dir-path (uri:normalize-path path))))
(win-clear window :redraw nil)
(resync-rows-db window :selected-path parent-path :redraw t))))
(defun expand-treenode (window expand-root-path &key (recurse t))
(with-accessors ((filesystem-root filesystem-root)
(filesystem-expand-function filesystem-expand-function)) window
(if (or (fs:backreference-dir-p expand-root-path)
(fs:loopback-reference-dir-p expand-root-path))
(jump-to-parent-node window expand-root-path)
(when-let ((matching-node (first (mtree:find-child-if filesystem-root
(lambda (a)
(string= (tree-path (data a))
expand-root-path))))))
(when (tree-dir-p (data matching-node))
(%expand-treenode filesystem-root expand-root-path filesystem-expand-function)
(resync-rows-db window :selected-path expand-root-path :redraw nil)
(when recurse
(let* ((expanded-tree (%expand-treenode (make-root-tree expand-root-path)
expand-root-path
filesystem-expand-function))
(expanded-rows (%build-annotated-tree-rows window expanded-tree))
(window-width (usable-window-width window))
(max-line-width nil))
(loop for expanded-row in expanded-rows
when (> (text-width (normal-text expanded-row))
window-width)
do
(setf max-line-width expanded-row))
(when max-line-width
(let ((new-root (fs:parent-dir-path (tree-path (fields max-line-width)))))
(setf filesystem-root (make-root-tree new-root))
(expand-treenode window new-root :recurse nil))))))
(win-clear window :redraw nil)
(draw window)))))
(defun rename-treenode (window old-path new-path)
(when-let* ((root-node (filesystem-root window))
(matching-node (find-node root-node old-path))
(parent-node (find-node root-node
(fs:parent-dir-path (tree-path (data matching-node))))))
(funcall (filesystem-rename-function window)
matching-node
new-path)
(remove-all-children parent-node)
(expand-treenode window (tree-path (data parent-node)))
(win-clear window :redraw nil)
(resync-rows-db window :redraw t :selected-path new-path)))
(defmethod draw :after ((object filesystem-tree-window))
(when-window-shown (object)
(let* ((window-width (usable-window-width object))
(rows (renderizable-rows-data object))
(x (if (uses-border-p object)
1
0))
(y-start (if (uses-border-p object)
1
0)))
(loop
for y from y-start by 1
for ct from 0
for row in rows do
(if (selectedp row)
(print-text object (text-ellipsis (selected-text row) window-width)
x y)
(print-text object (text-ellipsis (normal-text row) window-width)
x y))))))
(defun init (root)
"Initialize the window"
(let* ((low-level-window (make-croatoan-window :border t))
(high-level-window (make-instance 'filesysten-tree-window
:croatoan-window low-level-window)))
(high-level-window (make-instance 'filesystem-tree-window
:uses-border-p t
:title (_ "File explorer")
:key-config swconf:+key-keybindings-window+
:keybindings *filesystem-explorer-keymap*
:croatoan-window low-level-window
:filesystem-root (make-root-tree root))))
(refresh-config high-level-window)
(win-hide high-level-window)
(setf *filesystem-explorer-window* high-level-window)
(resync-rows-db high-level-window :redraw t :selected-path root)
high-level-window))

18
src/filesystem-utils.lisp
View File

@ -39,6 +39,9 @@
out)
nil))
(defun rename-a-file (old new)
(nix:rename old new))
(defun file-size (filename)
(with-open-file (stream filename :direction :input :element-type '(unsigned-byte 8)
:if-does-not-exist nil)
@ -110,7 +113,10 @@
(text-utils:strcat file "." extension))
(defun cat-parent-dir (parent direntry)
(format nil "~a~a~a" parent *directory-sep* direntry))
(if (or (backreference-dir-p direntry)
(loopback-reference-dir-p direntry))
(format nil "~a~a" parent direntry)
(format nil "~a~a~a" parent *directory-sep* direntry)))
(defmacro do-directory ((var) root &body body)
(with-gensyms (dir)
@ -133,6 +139,12 @@
(setf all-paths (sort all-paths #'string<))
all-paths))
(defun backreference-dir-p (path)
(string= (path-last-element path) ".."))
(defun loopback-reference-dir-p (path)
(string= (path-last-element path) "."))
(defun collect-files/dirs (root)
(let ((all-files '())
(all-dirs '()))
@ -142,8 +154,8 @@
(files (remove-if #'directory-exists-p all-children))
(directories (remove-if (lambda (a)
(or (file-exists-p a)
(string= (path-last-element a) ".")
(string= (path-last-element a) "..")))
(backreference-dir-p a)
(loopback-reference-dir-p a)))
all-children)))
(setf all-files (append all-files files))
(setf all-dirs (append all-dirs directories))

6
src/keybindings.lisp
View File

@ -273,6 +273,9 @@ produces a tree and graft the latter on `existing-tree'"
(defparameter *gempub-library-keymap* (make-starting-comand-tree)
"The keymap for gempub library of publication.")
(defparameter *filesystem-explorer-keymap* (make-starting-comand-tree)
"The keymap for gempub library of publication.")
(defparameter *all-keymaps* '(*global-keymap*
*thread-keymap*
*message-keymap*
@ -290,7 +293,8 @@ produces a tree and graft the latter on `existing-tree'"
*chat-message-keymap*
*gemlog-subscription-keymap*
*gemini-toc-keymap*
*gempub-library-keymap*))
*gempub-library-keymap*
*filesystem-explorer-keymap*))
(defun define-key (key-sequence function &optional (existing-keymap *global-keymap*))
"Define a key sequence that trigger a function:

11
src/line-oriented-window.lisp
View File

@ -345,6 +345,17 @@ this exact quantity would go beyond the length or rows or zero."
&key &allow-other-keys)
(mapcar function (slot-value object 'rows)))
(defmacro do-rows ((object row) &body body)
`(map nil (lambda (,row) (progn ,@body)) (rows ,object)))
(defmacro do-rows-raw ((object row) &body body)
`(map nil (lambda (,row) (progn ,@body)) (slot-value ,object 'rows)))
(defmacro loop-rows ((object row &rest loop-clauses) &body body)
`(loop for ,row in (rows ,object)
,@loop-clauses
,@body))
(defmethod rows-length ((object row-oriented-widget) &key &allow-other-keys)
(length (rows object)))

85
src/package.lisp
View File

@ -273,6 +273,7 @@
:*directory-sep-regexp*
:*directory-sep*
:copy-a-file
:rename-a-file
:file-size
:slurp-file
:dump-sequence-to-file
@ -284,6 +285,8 @@
:add-extension
:do-directory
:collect-children
:backreference-dir-p
:loopback-reference-dir-p
:collect-files/dirs
:prepend-pwd
:search-matching-file
@ -1148,6 +1151,7 @@
:+key-keybindings-window+
:+key-suggestions-window+
:+key-command-window+
:+key-file-explorer+
:+key-editor+
:+key-username+
:+key-server+
@ -1366,7 +1370,8 @@
:*gemini-subscription-window*
:*gemini-toc-window*
:*chats-list-window*
:*gempub-library-window*))
:*gempub-library-window*
:*filesystem-explorer-window*))
(defpackage :complete
(:use
@ -1486,6 +1491,9 @@
:report-status-event
:add-crypto-data-event
:poll-vote-event
:add-pagination-status-event
:status-id
:timeline
:gemini-display-data-page
:gemini-request-event
:gemini-back-event
@ -1511,12 +1519,10 @@
:search-link-event
:help-apropos-event
:redraw-window-event
:function-event
:send-to-pipe-event
:dispatch-program-events
:add-pagination-status-event
:status-id
:timeline))
:function-event
:with-enqueued-process
:dispatch-program-events))
(defpackage :api-pleroma
(:use
@ -1674,6 +1680,7 @@
:*gemlog-subscription-keymap*
:*gemini-toc-keymap*
:*gempub-library-keymap*
:*filesystem-explorer-keymap*
:define-key
:init-keyboard-mapping
:find-keymap-node
@ -1766,6 +1773,7 @@
:in-focus-p
:border-window
:uses-border-p
:usable-window-width
:window-uses-border-p
:title-window))
@ -1863,30 +1871,6 @@
:update-keybindings-tree
:init))
(defpackage :filesystem-tree-window
(:use
:cl
:alexandria
:cl-ppcre
:croatoan
:config
:constants
:text-utils
:misc
:mtree
:keybindings
:specials
:windows
:suggestions-window
:tui-utils)
(:shadowing-import-from :text-utils :split-lines)
(:shadowing-import-from :misc :random-elt :shuffle)
(:export
:keybindings-window
:keybindings-tree
:update-keybindings-tree
:init))
(defpackage :point-tracker
(:use
:cl
@ -1994,6 +1978,9 @@
:append-new-rows
:map-rows
:rows-map-raw
:do-rows
:do-rows-raw
:loop-rows
:rows-length
:rows-empty-p
:rows-remove-if
@ -2014,6 +2001,35 @@
:resync-rows-db
:make-blocking-list-dialog-window))
(defpackage :filesystem-tree-window
(:use
:cl
:alexandria
:cl-ppcre
:croatoan
:config
:constants
:text-utils
:misc
:mtree
:keybindings
:specials
:windows
:line-oriented-window
:tui-utils)
(:shadowing-import-from :text-utils :split-lines)
(:shadowing-import-from :misc :random-elt :shuffle)
(:export
:filesystem-tree-window
:filesystem-root
:tree-path
:tree-dir-p
:close-treenode
:expand-treenode
:rename-treenode
:resync-rows-db
:init))
(defpackage :message-rendering-utils
(:use
:cl
@ -2559,6 +2575,7 @@
(:nicknames :ui)
(:shadowing-import-from :text-utils :split-lines)
(:shadowing-import-from :misc :random-elt :shuffle)
(:local-nicknames (:fstree :filesystem-tree-window))
(:export
:delete-message-status-marked-to-delete
:open-manual
@ -2762,7 +2779,13 @@
:message-window-unlock-scrolling
:eval-command
:load-script-file
:view-user-avatar))
:view-user-avatar
:open-file-explorer
:file-explorer-expand
:file-explorer-close
:file-explorer-rename
:file-explorer-go-down
:file-explorer-go-up))
(defpackage :scheduled-events
(:use

5
src/program-events.lisp
View File

@ -1637,6 +1637,11 @@
(assert (functionp payload))
(funcall payload)))
(defmacro with-enqueued-process ((&optional (priority +standard-event-priority+)) &body body)
`(push-event (make-instance 'function-event
:payload (lambda () ,@body)
:priority ,priority)))
;;;; end events
(defun dispatch-program-events ()

3
src/software-configuration.lisp
View File

@ -557,6 +557,7 @@
open-gemini-stream-window
gemini-certificates-window
command-window
file-explorer
command-separator
gemini
gemlog
@ -1105,6 +1106,7 @@
+key-left-arrow+))
(defun tree-config-colors (tree-win-holder)
(assert tree-win-holder)
(values (access:accesses *software-configuration*
tree-win-holder
+key-tree+
@ -1159,6 +1161,7 @@
+key-value+)))
(defun make-tree-colormap (window-key)
(assert window-key)
(let ((tree-color-map ()))
(flet ((add-color-pair (key color)
(setf tree-color-map (acons key color tree-color-map))))

2
src/specials.lisp
View File

@ -69,3 +69,5 @@
(defparameter *gempub-library-window* nil
"The window that shows the gempub library.")
(defparameter *filesystem-explorer-window* nil)

4
src/thread-window.lisp
View File

@ -821,8 +821,8 @@ db:renumber-timeline-message-index."
(cond
(suggested-status-id
(let ((message-index (message-tuple-id->message-index timeline-type
timeline-folder
suggested-status-id)))
timeline-folder
suggested-status-id)))
(update-thread-window object message-index)))
(suggested-message-index
(update-thread-window object suggested-message-index))

50
src/ui-goodies.lisp
View File

@ -598,6 +598,11 @@ current has focus"
:documentation "Move focus on gempub library window"
:info-change-focus-message (_ "Focus passed on gempub library window"))
(gen-focus-to-window filesystem-explorer-window
*filesystem-explorer-window*
:documentation "Move focus on filesystem explorer window"
:info-change-focus-message (_ "Focus passed on file explorer window"))
(defun print-quick-help ()
"Print a quick help"
(keybindings:print-help *main-window*))
@ -2408,3 +2413,48 @@ printed, on the main window."
(account (db:acct->user username))
(avatar-url (db:row-avatar account)))
(open-attach-window:open-attachment avatar-url)))
(defun open-file-explorer ()
(push-event (make-instance 'function-event
:payload (lambda ()
(filesystem-tree-window:init "/")
(focus-to-filesystem-explorer-window)))))
(defun file-explorer-expand ()
(when-let* ((win *filesystem-explorer-window*)
(fields (line-oriented-window:selected-row-fields win))
(path (fstree:tree-path fields))
(dirp (fstree:tree-dir-p fields)))
(fstree:expand-treenode win path)))
(defun file-explorer-close ()
(when-let* ((win *filesystem-explorer-window*)
(fields (line-oriented-window:selected-row-fields win))
(path (fstree:tree-path fields))
(dirp (fstree:tree-dir-p fields)))
(fstree:close-treenode win path)))
(defun file-explorer-rename ()
"Rename (or move) a file or directory"
(when-let* ((win *filesystem-explorer-window*)
(fields (line-oriented-window:selected-row-fields win))
(path (fstree:tree-path fields)))
(flet ((on-input-complete (new-path)
(with-enqueued-process ()
(fstree:rename-treenode win path new-path))))
(ask-string-input #'on-input-complete
:prompt
(format nil (_ "rename ~a to: ") path)))))
(defun file-explorer-move (amount)
(ignore-errors
(line-oriented-window:unselect-all *filesystem-explorer-window*)
(line-oriented-window:row-move *filesystem-explorer-window* amount)
(win-clear *filesystem-explorer-window*)
(draw *filesystem-explorer-window*)))
(defun file-explorer-go-down ()
(file-explorer-move 1))
(defun file-explorer-go-up ()
(file-explorer-move -1))

9
src/windows.lisp
View File

@ -49,6 +49,8 @@
:accessor render-vertical-line-value)))
(defun refresh-config-color-map (window config-win-key)
(assert window)
(assert config-win-key)
(with-accessors ((tree-color-map tree-color-map)) window
(setf tree-color-map
(swconf:make-tree-colormap config-win-key))))
@ -675,6 +677,13 @@ insetred by the user"
(typep window 'border-window)
(uses-border-p window)))
(defgeneric usable-window-width (object))
(defmethod usable-window-width ((object border-window))
(if (uses-border-p object)
(win-width-no-border object)
(win-width object)))
(defmethod draw :after ((object border-window))
(when (uses-border-p object)
(win-box object)))

2
tinmop.asd
View File

@ -111,10 +111,10 @@
(:file "suggestions-window")
(:file "complete-window")
(:file "keybindings-window")
(:file "filesystem-tree-window")
(:file "point-tracker")
(:file "modeline-window")
(:file "line-oriented-window")
(:file "filesystem-tree-window")
(:file "message-rendering-utils")
(:file "thread-window")
(:file "message-window")