cage/tinmop
1
0
Fork 0
mirror of https://codeberg.org/cage/tinmop/ synced 2025-02-20 08:40:36 +01:00
Code Issues

- added a generated TOC for gemini files.

Browse Source
This commit is contained in:
cage 2021-05-16 14:18:19 +02:00
parent 3b92318814
commit 4a6e2fca3d
15 changed files with 322 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
etc/default-theme.conf
View File

@ -548,3 +548,19 @@ gemini-subscription-window.foreground = cyan
gemini-subscription-window.input.selected.background = cyan
gemini-subscription-window.input.selected.foreground = black
# gemini text table of contents window
gemini-toc-window.height = 1
gemini-toc-window.background = black
gemini-toc-window.foreground = #67998B
# the colors for currently selected tags
gemini-toc-window.input.selected.background = black
gemini-toc-window.input.selected.foreground = #71AF8C
gemini-toc-window.padding = "⋅"

12
etc/init.lisp
View File

@ -351,13 +351,23 @@
(define-key "p" #'message-toggle-preformatted-block *gemini-message-keymap*)
(define-key "t" #'next-tour-link *gemini-message-keymap*)
(define-key "t t" #'next-tour-link *gemini-message-keymap*)
(define-key "t o" #'open-gemini-toc *gemini-message-keymap*)
(define-key "T" #'show-tour-links *gemini-message-keymap*)
(define-key "|" #'send-to-pipe *gemini-message-keymap*)
;; gemini page table of contents keymap
(define-key "up" #'gemini-toc-scroll-up *gemini-toc-keymap*)
(define-key "down" #'gemini-toc-scroll-down *gemini-toc-keymap*)
(define-key "C-J" #'gemini-toc-jump-to-entry *gemini-toc-keymap*)
(define-key "q" #'gemini-toc-close *gemini-toc-keymap*)
;; gemini stream window keymap

97
src/gemini-page-toc.lisp Normal file
View File

@ -0,0 +1,97 @@
;; tinmop: an humble gemini and pleroma client
;; Copyright (C) 2020 cage
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(in-package :gemini-page-toc)
(defclass gemini-toc-window (focus-marked-window
simple-line-navigation-window
title-window
border-window)
((gemini-window
:initform specials:*message-window*
:initarg gemini-window
:accessor gemini-window)))
(defmethod refresh-config :after ((object gemini-toc-window))
(with-accessors ((croatoan-window croatoan-window)
(histogram-fg histogram-fg)
(selected-line-bg selected-line-bg)
(selected-line-fg selected-line-fg)
(new-messages-mark new-messages-mark)) object
(let* ((theme-style (swconf:form-style swconf:+key-gemini-toc-window+))
(fg (swconf:foreground theme-style))
(bg (swconf:background theme-style))
(selected-fg (swconf:selected-foreground theme-style))
(selected-bg (swconf:selected-background theme-style))
(width (- (win-width *main-window*)
(win-width *thread-window*)))
(raw-height (swconf:win-height swconf:+key-gemini-toc-window+))
(height (- (main-window:parse-subwin-h raw-height)
(win-height *command-window*)))
(y 0)
(x 0))
(setf selected-line-fg selected-fg)
(setf selected-line-bg selected-bg)
(setf (background croatoan-window) (tui:make-win-background bg))
(setf (bgcolor croatoan-window) bg)
(setf (fgcolor croatoan-window) fg)
(win-resize object width height)
(win-move object x y)
object)))
(defmethod resync-rows-db ((object gemini-toc-window) &key (redraw t) (suggested-message-index nil))
(with-accessors ((rows rows)
(selected-line-bg selected-line-bg)
(selected-line-fg selected-line-fg)
(gemini-window gemini-window)) object
(flet ((make-rows (toc bg fg)
(mapcar (lambda (fields)
(let ((text (message-window:gemini-toc-entry fields toc)))
(make-instance 'line
:fields fields
:normal-text text
:selected-text text
:normal-bg bg
:normal-fg fg
:selected-bg fg
:selected-fg bg)))
toc)))
(let ((toc (message-window:generate-gemini-toc gemini-window)))
(line-oriented-window:update-all-rows object
(make-rows toc
selected-line-bg
selected-line-fg))
(when suggested-message-index
(select-row object suggested-message-index))
(when redraw
(draw object))))))
(defun open-toc-window (gemini-window)
(let* ((low-level-window (make-croatoan-window :enable-function-keys t)))
(setf *gemini-toc-window*
(make-instance 'gemini-toc-window
:title (_ "Table of contents")
:single-row-height 1
:uses-border-p t
:keybindings keybindings:*gemini-toc-keymap*
:croatoan-window low-level-window
:gemini-window gemini-window))
(refresh-config *gemini-toc-window*)
(resync-rows-db *gemini-toc-window* :redraw nil)
(when (not (line-oriented-window:rows-empty-p *gemini-toc-window*))
(select-row *gemini-toc-window* 0))
(draw *gemini-toc-window*)
*gemini-toc-window*))

1
src/gemini-viewer.lisp
View File

@ -401,6 +401,7 @@
(ui:notify (_ "Gemini document downloading aborted"))
(progn
(ui:notify (_ "Gemini document downloading completed"))
(ui:open-gemini-toc)
(setf (stream-status wrapper-object) :completed)))
;; (allow-downloading wrapper-object)
(gemini-client:close-ssl-socket download-socket)))))))

4
src/gemini/gemini-parser.lisp
View File

@ -35,6 +35,8 @@
(define-constant +link-prefix+ "=>" :test #'string=)
(define-constant +max-header-level+ 3 :test #'=)
(defmacro gen-geminize-line (name prefix)
`(defun ,(format-fn-symbol t "geminize-~a" name) (text)
(strcat ,prefix text)))
@ -436,7 +438,7 @@
:link-value link-value))
(defun sexp->text-rows (parsed-gemini theme)
(let ((win-width (message-window:viewport-width (viewport theme)))
(let ((win-width (message-window:viewport-width (viewport theme)))
(pre-group-id -1)
(header-group-id -1)
(pre-alt-text ""))

1
src/gemini/package.lisp
View File

@ -38,6 +38,7 @@
(:export
:+gemini-scheme+
:+preformatted-prefix+
:+max-header-level+
:geminize-h1
:geminize-h2
:geminize-h3

3
src/keybindings.lisp
View File

@ -267,6 +267,9 @@ produces a tree and graft the latter on `existing-tree'"
(defparameter *gemlog-subscription-keymap* (make-starting-comand-tree)
"The keymap for gemlog subscriptions window.")
(defparameter *gemini-toc-keymap* (make-starting-comand-tree)
"The keymap for gemini table of contents window.")
(defun define-key (key-sequence function &optional (existing-keymap *global-keymap*))
"Define a key sequence that trigger a function:

2
src/main-window.lisp
View File

@ -63,6 +63,8 @@
(declare (ignore e))
main-window-size))))
(cond
((= raw 1)
main-window-size)
((integerp raw)
raw)
(t

71
src/message-window.lisp
View File

@ -53,14 +53,21 @@
(defgeneric search-regex (object regex))
(defgeneric jump-to-group-id (object gid-looking-for))
(defgeneric text->rendered-lines-rows (window text))
(defgeneric colorize-lines (object))
(defgeneric viewport-width (object))
(defgeneric generate-toc (object))
(defun gemini-window-p* (window)
(gemini-viewer:gemini-metadata-p (message-window:metadata window)))
(defun gemini-window-p ()
(gemini-viewer:gemini-metadata-p (message-window:metadata specials:*message-window*)))
(gemini-window-p* specials:*message-window*))
(defun display-gemini-text-p (window)
(eq (keybindings window)
@ -507,6 +514,68 @@
(calc-highlight)
(highlight))))))))
(defmethod jump-to-group-id ((object message-window) gid-looking-for)
(when-let ((line-found (rows-position-if object
(lambda (a)
(when-let ((header (row-get-original-object a)))
(when (typep header 'gemini-parser:header-line)
(let ((gid (gemini-parser:group-id header)))
(= gid gid-looking-for)))))
:start 0)))
(select-row object 0)
(row-move object line-found)
(draw object)))
(defmethod generate-gemini-toc ((object message-window))
(let* ((toc-number (make-list gemini-parser:+max-header-level+ :initial-element 0))
(current-gid -1)
(all-headers (remove-if-not (lambda (a)
(typep (row-get-original-object a)
'gemini-parser:header-line))
(rows object)))
(toc (loop for row in all-headers
collect
(let* ((header (row-get-original-object row))
(level (gemini-parser:level header))
(gid (gemini-parser:group-id header)))
(when (/= gid current-gid)
(setf current-gid gid)
(incf (elt toc-number (1- level)))
(loop for i from level below (length toc-number) do
(setf (elt toc-number i) 0))
(loop for i from (- level 2 ) downto 0
when (= (elt toc-number i) 0) do
(setf (elt toc-number i) 1))
(list :header (regex-replace "^\\P{Letter}+"
(first (gemini-parser:lines header))
"")
:group-id gid
:number (subseq toc-number
0
level)))))))
(remove-if #'null toc)))
(defun gemini-toc-header (fields)
(getf fields :header))
(defun gemini-toc-max-number-length (toc)
(* 2
(num:find-max (mapcar (lambda (a) (length (getf a :number)))
toc))))
(defun gemini-toc-number (fields toc)
(let ((raw (mapcar #'to-s (getf fields :number)))
(max-number-length (gemini-toc-max-number-length toc)))
(right-padding (join-with-strings raw ".")
max-number-length
:padding-char (swconf:gemini-toc-padding-char))))
(defun gemini-toc-entry (fields toc)
(format nil "~a ~a" (gemini-toc-number fields toc) (gemini-toc-header fields)))
(defun gemini-toc-group-id (fields)
(getf fields :group-id))
(defun init ()
(let* ((low-level-window (make-croatoan-window :enable-function-keys t)))
(setf *message-window*

37
src/package.lisp
View File

@ -1065,6 +1065,7 @@
:+key-chat-window+
:+key-chats-list-window+
:+key-gemini-subscription-window+
:+key-gemini-toc-window+
:+key-favourite+
:+key-sensitive+
:+key-boosted+
@ -1117,6 +1118,7 @@
:gemini-bullet-prefix
:gemini-preformatted-fg
:gemini-certificates-window-colors
:gemini-toc-padding-char
:signature-file-path
:vote-vertical-bar
:crypted-mark-value
@ -1271,6 +1273,7 @@
:*gemini-streams-window*
:*gemini-certificates-window*
:*gemini-subscription-window*
:*gemini-toc-window*
:*chats-list-window*))
(defpackage :complete
@ -1399,6 +1402,8 @@
:gemlog-cancel-subscription-event
:gemlog-show-event
:gemlog-refresh-all-event
:gemini-toc-jump-to-section
:gemini-toc-open
:get-chat-messages-event
:get-chats-event
:chat-show-event
@ -1562,6 +1567,7 @@
:*chats-list-keymap*
:*chat-message-keymap*
:*gemlog-subscription-keymap*
:*gemini-toc-keymap*
:define-key
:init-keyboard-mapping
:find-keymap-node
@ -1952,6 +1958,7 @@
(:export
:message-window
:metadata
:gemini-window-p*
:gemini-window-p
:display-gemini-text-p
:display-chat-p
@ -1983,7 +1990,10 @@
:scroll-next-page
:scroll-previous-page
:search-regex
:jump-to-group-id
:generate-gemini-toc
:gemini-toc-entry
:gemini-toc-group-id
:init))
(defpackage :open-attach-window
@ -2076,6 +2086,26 @@
(:export
:open-gemini-subscription-window))
(defpackage :gemini-page-toc
(:use
:cl
:alexandria
:cl-ppcre
:access
:croatoan
:config
:constants
:text-utils
:misc
:mtree
:specials
:windows
:line-oriented-window
:tui-utils)
(:shadowing-import-from :misc :random-elt :shuffle)
(:export
:open-toc-window))
(defpackage :command-window
(:use
:cl
@ -2489,6 +2519,11 @@
:tour-mode-link
:next-tour-link
:show-tour-links
:open-gemini-toc
:gemini-toc-scroll-up
:gemini-toc-scroll-down
:gemini-toc-jump-to-entry
:gemini-toc-close
:pass-focus-on-left
:pass-focus-on-right
:pass-focus-on-bottom

77
src/program-events.lisp
View File

@ -1131,53 +1131,6 @@
(refresh-gemini-message-window links source ir-line append-text)
(windows:draw win))))))
;; (defclass gemini-compact-lines-event (program-event)
;; ((download-iri
;; :initform nil
;; :initarg :download-iri
;; :accessor download-iri)))
;; (defmethod process-event ((object gemini-compact-lines-event))
;; (with-accessors ((download-iri download-iri)) object
;; (let ((all-lines "")
;; (all-links ())
;; (all-source "")
;; (append-text t))
;; (map-events (lambda (a)
;; (with-accessors ((response payload)
;; (wrapper-object wrapper-object)) a
;; (with-accessors ((parsed-file gemini-client:parsed-file)
;; (source gemini-client:source)
;; (links gemini-client:links)
;; (text-rendering-theme gemini-client:text-rendering-theme))
;; response
;; (when (and (typep a 'gemini-got-line-event)
;; (string= download-iri
;; (gemini-viewer:download-iri wrapper-object))
;; (gemini-viewer:downloading-allowed-p wrapper-object)
;; (not (skip-rendering-p a)))
;; (let ((rendered-text (gemini-parser:sexp->text parsed-file
;; text-rendering-theme)))
;; (when (null (append-text a))
;; (setf append-text nil))
;; (appendf all-links links)
;; (setf all-source
;; (text-utils:strcat all-source source))
;; (setf all-lines
;; (text-utils:strcat all-lines rendered-text))))))
;; a))
;; (when (text-utils:string-not-empty-p all-lines)
;; (remove-event-if (lambda (a)
;; (with-accessors ((wrapper-object wrapper-object)) a
;; (and (typep a 'gemini-got-line-event)
;; (string= download-iri
;; (gemini-viewer:download-iri wrapper-object))))))
;; (let* ((win specials:*message-window*))
;; (setf (windows:keybindings win)
;; keybindings:*gemini-message-keymap*)
;; (refresh-gemini-message-window all-links all-source all-lines append-text)
;; (windows:draw win))))))
(defclass gemini-abort-downloading-event (program-event) ())
(defmethod process-event ((object gemini-abort-downloading-event))
@ -1301,6 +1254,36 @@
(loop for subscription in all-subscribed-gemlogs do
(gemini-subscription:refresh subscription))))
(defclass gemini-toc-jump-to-section (program-event)
((toc-win
:initform nil
:initarg :toc-win
:accessor toc-win)
(message-win
:initform nil
:initarg :message-win
:accessor message-win)
(gid-looking-for
:initform nil
:initarg :gid-looking-for
:accessor gid-looking-for)))
(defmethod process-event ((object gemini-toc-jump-to-section))
(with-accessors ((toc-win toc-win)
(message-win message-win)
(gid-looking-for gid-looking-for)) object
(let* ((selected-row (line-oriented-window:selected-row-fields toc-win))
(gid-looking-for (message-window:gemini-toc-group-id selected-row)))
(message-window:jump-to-group-id message-win gid-looking-for))))
(defclass gemini-toc-open (program-event) ())
(defmethod process-event ((object gemini-toc-open))
(let ((win specials:*message-window*))
(if (message-window:gemini-window-p* win)
(gemini-page-toc:open-toc-window win)
(ui:error-message (_ "TOC can be shown for gemini windows only.")))))
;;;; pleroma
(defclass get-chat-messages-event (program-event)

21
src/software-configuration.lisp
View File

@ -406,6 +406,7 @@
focus
prefix
postfix
padding
value
scheme
link
@ -450,6 +451,7 @@
chat-window
chats-list-window
gemini-subscription-window
gemini-toc-window
attachment-header
max-numbers-allowed-attachments
max-message-length
@ -615,12 +617,11 @@
+key-prefix+))
(defun gemini-preformatted-fg ()
(or
(access-non-null-conf-value *software-configuration*
+key-gemini+
+key-preformatted-text+
+key-foreground+)
:white))
(or (access-non-null-conf-value *software-configuration*
+key-gemini+
+key-preformatted-text+
+key-foreground+)
:white))
(defun gemini-certificates-window-colors ()
"return three color values"
@ -637,6 +638,14 @@
+key-access-time+
+key-foreground+)))
(defun gemini-toc-padding-char ()
(let ((padding-from-conf (access:accesses *software-configuration*
+key-gemini-toc-window+
+key-padding+)))
(if padding-from-conf
(elt padding-from-conf 0)
#\Space)))
(defun signature-file-path ()
"Returns the filepath of the signature file, the $HOME is prepended."
(let* ((signature-file (or (access:accesses *software-configuration*

3
src/specials.lisp
View File

@ -61,5 +61,8 @@
(defparameter *gemini-subscription-window* nil
"The window that shows all the subscribed gemlogs.")
(defparameter *gemini-toc-window* nil
"The window that shows the table of contents of a gemini page.")
(defparameter *chats-list-window* nil
"The window that shows all the chats.")

33
src/ui-goodies.lisp
View File

@ -538,6 +538,11 @@ current has focus"
:documentation "Move focus on open-gemini certificates window"
:info-change-focus-message (_ "Focus passed on gemlog subscriptions window."))
(gen-focus-to-window gemini-toc-window
*gemini-toc-window*
:documentation "Move focus on gemini page table of contents window"
:info-change-focus-message (_ "Focus passed on gemini toc window."))
(defun print-quick-help ()
"Print a quick help"
(keybindings:print-help *main-window*))
@ -1770,6 +1775,12 @@ open-message-link-window:open-message-link"
(gemini-viewer:open-gemini-stream-window)
(focus-to-open-gemini-stream-windows))
(defun trivial-line-oriented-window-move (win amount)
(ignore-errors
(line-oriented-window:unselect-all win)
(line-oriented-window:row-move win amount)
(draw win)))
(defun gemini-streams-move (amount)
(ignore-errors
(line-oriented-window:unselect-all *gemini-streams-window*)
@ -1915,3 +1926,25 @@ gemini://gemini.circumlunar.space/docs/companion/subscription.gmi
"Show a link window with all the links in the tour queue."
(open-message-link-window:init-gemini-links (reverse tour))
(focus-to-open-message-link-window)))
(defun open-gemini-toc ()
"Opend a windows that contains a generated table of contents of the
gemini page the program is rendering."
(push-event (make-instance 'gemini-toc-open)))
(defun gemini-toc-scroll-up ()
(trivial-line-oriented-window-move *gemini-toc-window* -1))
(defun gemini-toc-scroll-down ()
(trivial-line-oriented-window-move *gemini-toc-window* 2))
(defun gemini-toc-jump-to-entry ()
(let* ((selected-row (line-oriented-window:selected-row-fields *gemini-toc-window*))
(gid-looking-for (message-window:gemini-toc-group-id selected-row)))
(push-event (make-instance 'gemini-toc-jump-to-section
:toc-win *gemini-toc-window*
:message-win *message-window*
:gid-looking-for gid-looking-for))))
(defun gemini-toc-close ()
(close-window-and-return-to-message *gemini-toc-window*))

1
tinmop.asd
View File

@ -114,6 +114,7 @@
(:file "open-message-link-window")
(:file "gemini-client-certificates-window")
(:file "gemini-subscription-window")
(:file "gemini-page-toc")
(:file "command-window")
(:file "sending-message")
(:file "follow-requests")