mirror of https://codeberg.org/cage/tinmop/
440 lines
19 KiB
Common Lisp
440 lines
19 KiB
Common Lisp
;; tinmop: an humble gemini and pleroma client
|
|
;; Copyright © 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/][http://www.gnu.org/licenses/]].
|
|
|
|
(in-package :client-configuration)
|
|
|
|
;; see src/software-configuration for the grammar
|
|
|
|
(defparameter *client-configuration* ())
|
|
|
|
(a:define-constant +client-conf-filename+ "gui.conf" :test #'string=)
|
|
|
|
(swconf::gen-key-constants text
|
|
font
|
|
size
|
|
weight
|
|
slant
|
|
underline
|
|
preformatted-text
|
|
justification
|
|
keybinding
|
|
quit
|
|
stream
|
|
certificates
|
|
tour
|
|
type-address
|
|
next
|
|
shuffle
|
|
manage
|
|
up
|
|
bookmark
|
|
toggle
|
|
show
|
|
select
|
|
emphasize
|
|
wrapped
|
|
asterisk
|
|
autoresize
|
|
gemtext
|
|
scaling
|
|
increase
|
|
decrease
|
|
reset)
|
|
|
|
(defun load-config-file (&optional (virtual-filepath +client-conf-filename+)
|
|
(perform-missing-value-check nil))
|
|
(let* ((file (res:get-config-file virtual-filepath))
|
|
(tree (swconf:parse-config (fs:namestring->pathname file))))
|
|
(loop for entry in tree do
|
|
(let ((key (first entry))
|
|
(value (second entry)))
|
|
(cond
|
|
((keywordp key)
|
|
(setf (access:accesses *client-configuration* key) value))
|
|
(t
|
|
(multiple-value-bind (rest all)
|
|
(apply #'access:set-accesses value *client-configuration* key)
|
|
(declare (ignore rest))
|
|
(setf *client-configuration* all))))))
|
|
(when perform-missing-value-check
|
|
(swconf:perform-missing-value-check file))
|
|
(if *client-configuration*
|
|
(values *client-configuration* file)
|
|
(error (format nil (_ "fatal error: The file ~a is empty") file)))))
|
|
|
|
;;;; end of parser
|
|
|
|
(defun gemini-default-favicon ()
|
|
(swconf:access-non-null-conf-value *client-configuration*
|
|
swconf:+key-gemini+
|
|
swconf:+key-favicon+))
|
|
|
|
(defun gemini-window-colors ()
|
|
(values (gui-goodies:parse-color (access:accesses *client-configuration*
|
|
swconf:+key-gemini+
|
|
swconf:+key-main-window+
|
|
swconf:+key-background+))
|
|
(gui-goodies:parse-color (access:accesses *client-configuration*
|
|
swconf:+key-gemini+
|
|
swconf:+key-main-window+
|
|
swconf:+key-foreground+))))
|
|
|
|
(defun font-configuration (key)
|
|
(gui-goodies:make-font (access:accesses *client-configuration*
|
|
swconf:+key-gemini+
|
|
key
|
|
+key-font+)
|
|
(access:accesses *client-configuration*
|
|
swconf:+key-gemini+
|
|
key
|
|
+key-size+)
|
|
(access:accesses *client-configuration*
|
|
swconf:+key-gemini+
|
|
key
|
|
+key-weight+)
|
|
(access:accesses *client-configuration*
|
|
swconf:+key-gemini+
|
|
key
|
|
+key-slant+)
|
|
(not (swconf:false-value-p (access:accesses *client-configuration*
|
|
swconf:+key-gemini+
|
|
key
|
|
+key-underline+)))))
|
|
|
|
(defmacro gen-font-configuration (key)
|
|
(let* ((no-key (cl-ppcre:regex-replace-all "key-" (string-downcase (symbol-name key)) ""))
|
|
(no-plus (text-utils:trim-blanks no-key '(#\+))))
|
|
`(defun ,(misc:format-fn-symbol t "gemini-~a-font-configuration" no-plus) ()
|
|
(font-configuration ,key))))
|
|
|
|
(defun gemini-text-font-configuration ()
|
|
(format t "key ~a~%"
|
|
(access:accesses *client-configuration*
|
|
swconf:+key-gemini+
|
|
swconf:+key-main-window+
|
|
+key-text+
|
|
+key-font+))
|
|
(gui-goodies:make-font (access:accesses *client-configuration*
|
|
swconf:+key-gemini+
|
|
swconf:+key-main-window+
|
|
+key-text+
|
|
+key-font+)
|
|
(access:accesses *client-configuration*
|
|
swconf:+key-gemini+
|
|
swconf:+key-main-window+
|
|
+key-text+
|
|
+key-size+)
|
|
(access:accesses *client-configuration*
|
|
swconf:+key-gemini+
|
|
swconf:+key-main-window+
|
|
+key-text+
|
|
+key-weight+)
|
|
(access:accesses *client-configuration*
|
|
swconf:+key-gemini+
|
|
swconf:+key-main-window+
|
|
+key-text+
|
|
+key-slant+)
|
|
(not (swconf:false-value-p (access:accesses *client-configuration*
|
|
swconf:+key-gemini+
|
|
swconf:+key-main-window+
|
|
+key-text+
|
|
+key-underline+)))))
|
|
|
|
(defun font-text-bold ()
|
|
(gui-goodies:make-font (access:accesses *client-configuration*
|
|
swconf:+key-gemini+
|
|
+key-text+
|
|
+key-font+)
|
|
(access:accesses *client-configuration*
|
|
swconf:+key-gemini+
|
|
+key-text+
|
|
+key-size+)
|
|
"bold"
|
|
nil
|
|
nil))
|
|
|
|
(defun font-text-italic ()
|
|
(gui-goodies:make-font (access:accesses *client-configuration*
|
|
swconf:+key-gemini+
|
|
+key-text+
|
|
+key-font+)
|
|
(access:accesses *client-configuration*
|
|
swconf:+key-gemini+
|
|
+key-text+
|
|
+key-size+)
|
|
nil
|
|
"italic"
|
|
nil))
|
|
|
|
(defun font-text-underlined ()
|
|
(gui-goodies:make-font (access:accesses *client-configuration*
|
|
swconf:+key-gemini+
|
|
+key-text+
|
|
+key-font+)
|
|
(access:accesses *client-configuration*
|
|
swconf:+key-gemini+
|
|
+key-text+
|
|
+key-size+)
|
|
nil
|
|
nil
|
|
t))
|
|
|
|
(gen-font-configuration swconf:+key-link+)
|
|
|
|
(gen-font-configuration swconf:+key-quote+)
|
|
|
|
(gen-font-configuration swconf:+key-h1+)
|
|
|
|
(gen-font-configuration swconf:+key-h2+)
|
|
|
|
(gen-font-configuration swconf:+key-h3+)
|
|
|
|
(gen-font-configuration swconf:+key-preformatted-text+)
|
|
|
|
(defun conf-colors (key)
|
|
(values (gui-goodies:parse-color (access:accesses *client-configuration*
|
|
swconf:+key-gemini+
|
|
key
|
|
swconf:+key-background+))
|
|
(gui-goodies:parse-color (access:accesses *client-configuration*
|
|
swconf:+key-gemini+
|
|
key
|
|
swconf:+key-foreground+))))
|
|
|
|
(defmacro gen-conf-color (prefix key)
|
|
(let* ((no-key (cl-ppcre:regex-replace-all "key-" (string-downcase (symbol-name key)) ""))
|
|
(no-plus (text-utils:trim-blanks no-key '(#\+))))
|
|
`(defun ,(misc:format-fn-symbol t "~a-~a-colors" prefix no-plus) ()
|
|
(conf-colors ,key))))
|
|
|
|
(gen-conf-color gemini swconf:+key-link+)
|
|
|
|
(gen-conf-color gemini swconf:+key-quote+)
|
|
|
|
(gen-conf-color gemini swconf:+key-h1+)
|
|
|
|
(gen-conf-color gemini swconf:+key-h2+)
|
|
|
|
(gen-conf-color gemini swconf:+key-h3+)
|
|
|
|
(gen-conf-color gemini swconf:+key-preformatted-text+)
|
|
|
|
(defun gemini-link-prefix (scheme)
|
|
(swconf:access-non-null-conf-value *client-configuration*
|
|
swconf:+key-gemini+
|
|
swconf:+key-link+
|
|
swconf:+key-scheme+
|
|
scheme
|
|
swconf:+key-prefix+))
|
|
|
|
(defun gemini-link-prefix-to-gemini ()
|
|
(gemini-link-prefix swconf:+key-gemini+))
|
|
|
|
(defun gemini-link-prefix-to-other ()
|
|
(gemini-link-prefix swconf:+key-other+))
|
|
|
|
(defun gemini-link-prefix-to-http ()
|
|
(gemini-link-prefix swconf:+key-http+))
|
|
|
|
(defun gemini-quote-prefix ()
|
|
(swconf:access-non-null-conf-value *client-configuration*
|
|
swconf:+key-gemini+
|
|
swconf:+key-quote+
|
|
swconf:+key-prefix+))
|
|
|
|
(defun gemini-h*-prefix (level)
|
|
(swconf:access-non-null-conf-value *client-configuration*
|
|
swconf:+key-gemini+
|
|
level
|
|
swconf:+key-prefix+))
|
|
|
|
(defun gemini-h1-prefix ()
|
|
(gemini-h*-prefix swconf:+key-h1+))
|
|
|
|
(defun gemini-h2-prefix ()
|
|
(gemini-h*-prefix swconf:+key-h2+))
|
|
|
|
(defun gemini-h3-prefix ()
|
|
(gemini-h*-prefix swconf:+key-h3+))
|
|
|
|
(defun gemini-bullet-prefix ()
|
|
(swconf:access-non-null-conf-value *client-configuration*
|
|
swconf:+key-gemini+
|
|
swconf:+key-bullet+
|
|
swconf:+key-prefix+))
|
|
|
|
(defun conf-justification (key)
|
|
(let ((conf-value (access:accesses *client-configuration*
|
|
swconf:+key-gemini+
|
|
key
|
|
+key-justification+)))
|
|
(or conf-value
|
|
:left)))
|
|
|
|
(defmacro gen-conf-justification (prefix key)
|
|
(let* ((no-key (cl-ppcre:regex-replace-all "key-" (string-downcase (symbol-name key)) ""))
|
|
(no-plus (text-utils:trim-blanks no-key '(#\+))))
|
|
`(defun ,(misc:format-fn-symbol t "~a-~a-justification" prefix no-plus) ()
|
|
(conf-justification ,key))))
|
|
|
|
(gen-conf-justification gemini swconf:+key-link+)
|
|
|
|
(gen-conf-justification gemini swconf:+key-quote+)
|
|
|
|
(gen-conf-justification gemini swconf:+key-h1+)
|
|
|
|
(gen-conf-justification gemini swconf:+key-h2+)
|
|
|
|
(gen-conf-justification gemini swconf:+key-h3+)
|
|
|
|
(gen-conf-justification gemini swconf:+key-preformatted-text+)
|
|
|
|
(swconf:gen-simple-access (toc-maximum-width
|
|
:transform-value-fn (lambda (a)
|
|
(truncate (or (num-utils:safe-parse-number a)
|
|
20)))
|
|
:configuration-tree *client-configuration*)
|
|
swconf:+key-toc+
|
|
swconf:+key-maximum+
|
|
swconf:+key-width+)
|
|
|
|
(swconf:gen-simple-access (toc-minimum-width
|
|
:transform-value-fn (lambda (a)
|
|
(truncate (or (num-utils:safe-parse-number a)
|
|
80)))
|
|
:configuration-tree *client-configuration*)
|
|
swconf:+key-toc+
|
|
swconf:+key-minimum+
|
|
swconf:+key-width+)
|
|
|
|
(swconf:gen-simple-access (toc-autoresize-p
|
|
:transform-value-fn (lambda (a) (not (swconf:false-value-p a)))
|
|
:configuration-tree *client-configuration*)
|
|
swconf:+key-toc+
|
|
+key-autoresize+)
|
|
|
|
(swconf:gen-simple-access (gemtext-padding
|
|
:transform-value-fn (lambda (a) (parse-integer a))
|
|
:configuration-tree *client-configuration*)
|
|
swconf:+key-gemini+
|
|
swconf:+key-main-window+
|
|
+key-text+
|
|
swconf:+key-padding+)
|
|
|
|
(defun toc-font-configuration ()
|
|
(gui-goodies:make-font (access:accesses *client-configuration*
|
|
swconf:+key-toc+
|
|
+key-font+)
|
|
(access:accesses *client-configuration*
|
|
swconf:+key-toc+
|
|
+key-size+)
|
|
(access:accesses *client-configuration*
|
|
swconf:+key-toc+
|
|
+key-weight+)
|
|
(access:accesses *client-configuration*
|
|
swconf:+key-toc+
|
|
+key-slant+)
|
|
(not (swconf:false-value-p (access:accesses *client-configuration*
|
|
swconf:+key-toc+
|
|
+key-underline+)))))
|
|
|
|
(defun keybinding->tk-event (keys)
|
|
(nodgui.event-parser:parse-event (strcat "<" keys ">")))
|
|
|
|
(defun get-keybinding (key)
|
|
(keybinding->tk-event (access:accesses *client-configuration*
|
|
+key-keybinding+
|
|
key)))
|
|
|
|
(swconf:gen-simple-access (keybinding-tour-next
|
|
:transform-value-fn keybinding->tk-event
|
|
:configuration-tree *client-configuration*)
|
|
+key-keybinding+
|
|
+key-tour+
|
|
+key-next+)
|
|
|
|
(swconf:gen-simple-access (keybinding-tour-shuffle
|
|
:transform-value-fn keybinding->tk-event
|
|
:configuration-tree *client-configuration*)
|
|
+key-keybinding+
|
|
+key-tour+
|
|
+key-shuffle+)
|
|
|
|
(swconf:gen-simple-access (keybinding-tour-manage
|
|
:transform-value-fn keybinding->tk-event
|
|
:configuration-tree *client-configuration*)
|
|
+key-keybinding+
|
|
+key-tour+
|
|
+key-manage+)
|
|
|
|
(swconf:gen-simple-access (keybinding-bookmark-toggle
|
|
:transform-value-fn (lambda (a) (keybinding->tk-event a))
|
|
:configuration-tree *client-configuration*)
|
|
+key-keybinding+
|
|
+key-bookmark+
|
|
+key-toggle+)
|
|
|
|
(swconf:gen-simple-access (keybinding-bookmark-show
|
|
:transform-value-fn (lambda (a) (keybinding->tk-event a))
|
|
:configuration-tree *client-configuration*)
|
|
+key-keybinding+
|
|
+key-bookmark+
|
|
+key-show+)
|
|
|
|
(swconf:gen-simple-access (keybinding-gemtext-scaling-increase
|
|
:transform-value-fn (lambda (a) (keybinding->tk-event a))
|
|
:configuration-tree *client-configuration*)
|
|
+key-keybinding+
|
|
+key-gemtext+
|
|
+key-scaling+
|
|
+key-increase+)
|
|
|
|
(swconf:gen-simple-access (keybinding-gemtext-scaling-decrease
|
|
:transform-value-fn (lambda (a) (keybinding->tk-event a))
|
|
:configuration-tree *client-configuration*)
|
|
+key-keybinding+
|
|
+key-gemtext+
|
|
+key-scaling+
|
|
+key-decrease+)
|
|
|
|
(swconf:gen-simple-access (keybinding-gemtext-scaling-reset
|
|
:transform-value-fn (lambda (a) (keybinding->tk-event a))
|
|
:configuration-tree *client-configuration*)
|
|
+key-keybinding+
|
|
+key-gemtext+
|
|
+key-scaling+
|
|
+key-reset+)
|
|
|
|
(defun main-window-select-colors ()
|
|
(values (gui-goodies:parse-color (access:accesses *client-configuration*
|
|
swconf:+key-gemini+
|
|
swconf:+key-main-window+
|
|
+key-select+
|
|
swconf:+key-background+))
|
|
(gui-goodies:parse-color (access:accesses *client-configuration*
|
|
swconf:+key-gemini+
|
|
swconf:+key-main-window+
|
|
+key-select+
|
|
swconf:+key-foreground+))))
|
|
|
|
(defun emphasize-wrapped-asterisk-p ()
|
|
(let ((value (access:accesses *client-configuration*
|
|
+key-emphasize+
|
|
+key-wrapped+
|
|
+key-asterisk+)))
|
|
(not (swconf:false-value-p value))))
|