mirror of https://codeberg.org/cage/tinmop/
- prefixed all parsing rule for software configuration to avoid clashes with other rules in the code.
This commit is contained in:
cage
parent
4ac967966b
commit
07bdc7c65c
|
|
@ -109,40 +109,40 @@
|
|||
|
||||
(define-constant +false-values+ '("no" "false") :test #'equalp)
|
||||
|
||||
(defrule blank (or #\space #\Newline #\Tab)
|
||||
(defrule conf-blank (or #\space #\Newline #\Tab)
|
||||
(:constant nil))
|
||||
|
||||
(defrule blanks (* blank)
|
||||
(defrule conf-blanks (* conf-blank)
|
||||
(:constant nil))
|
||||
|
||||
(defrule assign #\=
|
||||
(defrule conf-assign #\=
|
||||
(:constant nil))
|
||||
|
||||
(defrule comment (and blanks #\# (* (not #\Newline)) blanks)
|
||||
(defrule conf-comment (and conf-blanks #\# (* (not #\Newline)) conf-blanks)
|
||||
(:constant nil))
|
||||
|
||||
(defrule hexcolor-prefix #\#)
|
||||
(defrule conf-hexcolor-prefix #\#)
|
||||
|
||||
(defrule digit (character-ranges (#\0 #\9))
|
||||
(defrule conf-digit (character-ranges (#\0 #\9))
|
||||
(:text t))
|
||||
|
||||
(defrule hex-digit
|
||||
(defrule conf-hex-digit
|
||||
(or (character-ranges (#\0 #\9))
|
||||
(character-ranges (#\a #\f))
|
||||
(character-ranges (#\A #\F))))
|
||||
|
||||
(defrule hexcolor
|
||||
(and hexcolor-prefix
|
||||
hex-digit hex-digit ; r
|
||||
hex-digit hex-digit ; g
|
||||
hex-digit hex-digit) ; b
|
||||
(defrule conf-hexcolor
|
||||
(and conf-hexcolor-prefix
|
||||
conf-hex-digit conf-hex-digit ; r
|
||||
conf-hex-digit conf-hex-digit ; g
|
||||
conf-hex-digit conf-hex-digit) ; b
|
||||
(:text t)
|
||||
(:function (lambda (a) (parse-integer a :start 1 :radix 16))))
|
||||
|
||||
(defun keywordize (a)
|
||||
(make-keyword (string-upcase a)))
|
||||
|
||||
(defrule colorname
|
||||
(defrule conf-colorname
|
||||
(or "black"
|
||||
"red"
|
||||
"green"
|
||||
|
|
@ -153,25 +153,25 @@
|
|||
"white")
|
||||
(:function keywordize))
|
||||
|
||||
(defrule escaped-character (and #\\ character)
|
||||
(defrule conf-escaped-character (and #\\ character)
|
||||
(:function (lambda (a) (list (second a)))))
|
||||
|
||||
(defrule field-separator #\.)
|
||||
(defrule conf-field-separator #\.)
|
||||
|
||||
(defrule field
|
||||
(* (or escaped-character
|
||||
(not (or #\# assign field-separator blank))))
|
||||
(defrule conf-field
|
||||
(* (or conf-escaped-character
|
||||
(not (or #\# conf-assign conf-field-separator conf-blank))))
|
||||
|
||||
(:text t))
|
||||
|
||||
;; this rule is not actually part of the grammar but jus a convenience
|
||||
;; function to remove duplicated code (see rules: key and value)
|
||||
(defrule fields
|
||||
(and field
|
||||
(? (and field-separator fields)))
|
||||
(defrule conf-fields
|
||||
(and conf-field
|
||||
(? (and conf-field-separator conf-fields)))
|
||||
(:function flatten))
|
||||
|
||||
(defrule key fields
|
||||
(defrule conf-key conf-fields
|
||||
(:function (lambda (a)
|
||||
(mapcar (lambda (element)
|
||||
(if (string= +field-separator-value+ element)
|
||||
|
|
@ -180,25 +180,25 @@
|
|||
a)))
|
||||
(:function remove-if-null))
|
||||
|
||||
(defrule generic-value fields
|
||||
(defrule conf-generic-value conf-fields
|
||||
(:text t))
|
||||
|
||||
(defrule generic-assign
|
||||
(and key blanks assign blanks
|
||||
(or quoted-string
|
||||
hexcolor
|
||||
colorname
|
||||
generic-value) ; the order in this list *is* important
|
||||
blanks)
|
||||
(defrule conf-generic-assign
|
||||
(and conf-key conf-blanks conf-assign conf-blanks
|
||||
(or conf-quoted-string
|
||||
conf-hexcolor
|
||||
conf-colorname
|
||||
conf-generic-value) ; the order in this list *is* important
|
||||
conf-blanks)
|
||||
(:function remove-if-null))
|
||||
|
||||
(defrule quoted-string (and #\" (* (not #\")) #\")
|
||||
(defrule conf-quoted-string (and #\" (* (not #\")) #\")
|
||||
(:function (lambda (a) (second a)))
|
||||
(:text t))
|
||||
|
||||
(defrule regexp quoted-string)
|
||||
(defrule conf-regexp conf-quoted-string)
|
||||
|
||||
(defrule color-re-key "color-regexp"
|
||||
(defrule conf-color-re-key "color-regexp"
|
||||
(:constant :color-re))
|
||||
|
||||
(defclass color-re-assign ()
|
||||
|
|
@ -253,61 +253,83 @@
|
|||
(and (not color-name-p) color)
|
||||
attributes))))
|
||||
|
||||
(defrule attribute-value (or "bold"
|
||||
"italic"
|
||||
"underline"
|
||||
"blink")
|
||||
(defrule conf-attribute-value (or "bold"
|
||||
"italic"
|
||||
"underline"
|
||||
"blink")
|
||||
(:text t)
|
||||
(:function (lambda (a) (tui-utils:text->tui-attribute a))))
|
||||
|
||||
(defrule color-re-assign
|
||||
(and color-re-key blanks
|
||||
assign blanks regexp blanks
|
||||
(or hexcolor colorname) blanks
|
||||
(? (and attribute-value blanks)))
|
||||
(defrule conf-color-re-assign
|
||||
(and conf-color-re-key
|
||||
conf-blanks
|
||||
conf-assign
|
||||
conf-blanks
|
||||
conf-regexp
|
||||
conf-blanks
|
||||
(or conf-hexcolor conf-colorname) conf-blanks
|
||||
(? (and conf-attribute-value conf-blanks)))
|
||||
(:function remove-if-null)
|
||||
(:function build-color-re-assign))
|
||||
|
||||
(defrule ignore-user-re-key "ignore-user-regexp"
|
||||
(defrule conf-ignore-user-re-key "ignore-user-regexp"
|
||||
(:constant :ignore-user-re))
|
||||
|
||||
(defrule ignore-user-boost-re-key "ignore-user-boost-regexp"
|
||||
(defrule conf-ignore-user-boost-re-key "ignore-user-boost-regexp"
|
||||
(:constant :ignore-user-boost-re))
|
||||
|
||||
(defrule ignore-tag-re-assign "ignore-tag-regexp"
|
||||
(defrule conf-ignore-tag-re-assign "ignore-tag-regexp"
|
||||
(:constant :ignore-tag-re))
|
||||
|
||||
(defrule ignore-user-re-assign
|
||||
(and ignore-user-re-key blanks
|
||||
assign blanks regexp blanks)
|
||||
(defrule conf-ignore-user-re-assign
|
||||
(and conf-ignore-user-re-key
|
||||
conf-blanks
|
||||
conf-assign
|
||||
conf-blanks
|
||||
conf-regexp
|
||||
conf-blanks)
|
||||
(:function (lambda (a) (list (first a) (fifth a)))))
|
||||
|
||||
(defrule ignore-user-boost-re-assign
|
||||
(and ignore-user-boost-re-key blanks
|
||||
assign blanks regexp blanks)
|
||||
(defrule conf-ignore-user-boost-re-assign
|
||||
(and conf-ignore-user-boost-re-key
|
||||
conf-blanks
|
||||
conf-assign
|
||||
conf-blanks
|
||||
conf-regexp
|
||||
conf-blanks)
|
||||
(:function (lambda (a) (list (first a) (fifth a)))))
|
||||
|
||||
(defrule server-key "server"
|
||||
(defrule conf-server-key "server"
|
||||
(:constant :server))
|
||||
|
||||
(defrule username-key "username"
|
||||
(defrule conf-username-key "username"
|
||||
(:constant :username))
|
||||
|
||||
(defrule open "open"
|
||||
(defrule conf-open "open"
|
||||
(:constant :open))
|
||||
|
||||
(defrule open-link-helper-key open)
|
||||
(defrule conf-open-link-helper-key conf-open)
|
||||
|
||||
(defrule with "with"
|
||||
(defrule conf-with "with"
|
||||
(:constant :with))
|
||||
|
||||
(defrule server-assign
|
||||
(and server-key blanks assign blanks generic-value blanks)
|
||||
(defrule conf-server-assign
|
||||
(and conf-server-key
|
||||
conf-blanks
|
||||
conf-assign
|
||||
conf-blanks
|
||||
conf-generic-value
|
||||
conf-blanks)
|
||||
(:function (lambda (a)
|
||||
(list (first a) (fifth a)))))
|
||||
|
||||
(defrule username-assign
|
||||
(and username-key blanks assign blanks generic-value blanks)
|
||||
(defrule conf-username-assign
|
||||
(and conf-username-key
|
||||
conf-blanks
|
||||
conf-assign
|
||||
conf-blanks
|
||||
conf-generic-value
|
||||
conf-blanks)
|
||||
(:function (lambda (a)
|
||||
(list (first a) (fifth a)))))
|
||||
|
||||
|
|
@ -366,42 +388,44 @@
|
|||
:wait wait
|
||||
:buffer-size buffer-size))
|
||||
|
||||
(defrule use "use"
|
||||
(defrule conf-use "use"
|
||||
(:text t))
|
||||
|
||||
(defrule cache "cache"
|
||||
(defrule conf-cache "cache"
|
||||
(:text t))
|
||||
|
||||
(defrule no "no"
|
||||
(defrule conf-no "no"
|
||||
(:text t))
|
||||
|
||||
(defrule wait "wait"
|
||||
(defrule conf-wait "wait"
|
||||
(:text t))
|
||||
|
||||
(defrule buffer-label "buffer"
|
||||
(defrule conf-buffer-label "buffer"
|
||||
(:text t))
|
||||
|
||||
(defrule use-cache (and use blanks cache)
|
||||
(defrule conf-use-cache (and conf-use conf-blanks conf-cache)
|
||||
(:constant t))
|
||||
|
||||
(defrule no-wait (and no blanks wait)
|
||||
(defrule conf-no-wait (and conf-no conf-blanks conf-wait)
|
||||
(:constant t))
|
||||
|
||||
(defrule open-link-helper
|
||||
(and open-link-helper-key
|
||||
blanks
|
||||
regexp ; 2 link-pattern
|
||||
blanks
|
||||
with
|
||||
blanks
|
||||
regexp ; 6 program to use
|
||||
blanks
|
||||
(? (and use-cache ; 8 use cache?
|
||||
blanks))
|
||||
(? (and no-wait ; 9 wait download? Buffer size?
|
||||
blanks
|
||||
(? (and buffer-label blanks (+ digit)))
|
||||
blanks)))
|
||||
(defrule conf-open-link-helper
|
||||
(and conf-open-link-helper-key
|
||||
conf-blanks
|
||||
conf-regexp ; 2 link-pattern
|
||||
conf-blanks
|
||||
conf-with
|
||||
conf-blanks
|
||||
conf-regexp ; 6 program to use
|
||||
conf-blanks
|
||||
(? (and conf-use-cache ; 8 use cache?
|
||||
conf-blanks))
|
||||
(? (and conf-no-wait ; 9 wait download? Buffer size?
|
||||
conf-blanks
|
||||
(? (and conf-buffer-label
|
||||
conf-blanks
|
||||
(+ conf-digit)))
|
||||
conf-blanks)))
|
||||
(:function (lambda (args)
|
||||
(let* ((use-cache (elt args 8))
|
||||
(wait-parameters (elt args 9))
|
||||
|
|
@ -423,14 +447,20 @@
|
|||
:wait waitp
|
||||
:buffer-size buffer-size))))))
|
||||
|
||||
(defrule post-allowed-language (and "post-allowed-language" blanks assign regexp)
|
||||
(defrule conf-post-allowed-language (and "post-allowed-language"
|
||||
conf-blanks
|
||||
conf-assign
|
||||
conf-regexp)
|
||||
(:function remove-if-null))
|
||||
|
||||
(defrule filepath quoted-string)
|
||||
(defrule conf-filepath conf-quoted-string)
|
||||
|
||||
(defparameter *already-included-files* ())
|
||||
|
||||
(defrule use-file (and use blanks filepath blanks)
|
||||
(defrule conf-use-file (and conf-use
|
||||
conf-blanks
|
||||
conf-filepath
|
||||
conf-blanks)
|
||||
(:function (lambda (a)
|
||||
(let ((file (third a)))
|
||||
(if (find file *already-included-files* :test #'string=)
|
||||
|
|
@ -440,28 +470,28 @@
|
|||
(load-config-file (third a) nil)))
|
||||
nil))))
|
||||
|
||||
(defrule entries
|
||||
(and (* comment)
|
||||
(or use-file
|
||||
color-re-assign
|
||||
ignore-user-re-assign
|
||||
ignore-user-boost-re-assign
|
||||
ignore-tag-re-assign
|
||||
server-assign
|
||||
username-assign
|
||||
open-link-helper
|
||||
post-allowed-language
|
||||
generic-assign)
|
||||
(* comment))
|
||||
(defrule conf-entries
|
||||
(and (* conf-comment)
|
||||
(or conf-use-file
|
||||
conf-color-re-assign
|
||||
conf-ignore-user-re-assign
|
||||
conf-ignore-user-boost-re-assign
|
||||
conf-ignore-tag-re-assign
|
||||
conf-server-assign
|
||||
conf-username-assign
|
||||
conf-open-link-helper
|
||||
conf-post-allowed-language
|
||||
conf-generic-assign)
|
||||
(* conf-comment))
|
||||
(:function second))
|
||||
|
||||
(defrule config (* entries)
|
||||
(defrule conf-config (* conf-entries)
|
||||
(:function remove-if-null))
|
||||
|
||||
(defgeneric parse-config (object))
|
||||
|
||||
(defmethod parse-config ((object string))
|
||||
(parse 'config object))
|
||||
(parse 'conf-config object))
|
||||
|
||||
(defmethod parse-config ((object pathname))
|
||||
(parse-config (fs:slurp-file object)))
|
||||
|
|
@ -727,13 +757,13 @@
|
|||
|
||||
(defun suggestion-window-selected-item-colors ()
|
||||
(values (access-non-null-conf-value *software-configuration*
|
||||
+key-suggestions-window+
|
||||
+key-selected+
|
||||
+key-background+)
|
||||
+key-suggestions-window+
|
||||
+key-selected+
|
||||
+key-background+)
|
||||
(access-non-null-conf-value *software-configuration*
|
||||
+key-suggestions-window+
|
||||
+key-selected+
|
||||
+key-foreground+)))
|
||||
+key-suggestions-window+
|
||||
+key-selected+
|
||||
+key-foreground+)))
|
||||
(defun gemini-downloading-animation ()
|
||||
(let ((animation (access-non-null-conf-value *software-configuration*
|
||||
+key-gemini+
|
||||
|
|
@ -1023,25 +1053,25 @@
|
|||
|
||||
(gen-simple-access (delete-fetched-mentions-p
|
||||
:transform-value-fn db-utils:db-not-nil-p)
|
||||
+key-delete+
|
||||
+key-fetched+
|
||||
+key-mentions+)
|
||||
+key-delete+
|
||||
+key-fetched+
|
||||
+key-mentions+)
|
||||
|
||||
(gen-simple-access (gemini-fullscreen-toc-width
|
||||
:transform-value-fn main-window:parse-subwin-w)
|
||||
+key-gemini+
|
||||
+key-exclusive+
|
||||
+key-mode+
|
||||
+key-toc+
|
||||
+key-width+)
|
||||
+key-gemini+
|
||||
+key-exclusive+
|
||||
+key-mode+
|
||||
+key-toc+
|
||||
+key-width+)
|
||||
|
||||
(gen-simple-access (gemini-fullscreen-links-height
|
||||
:transform-value-fn main-window:parse-subwin-h)
|
||||
+key-gemini+
|
||||
+key-exclusive+
|
||||
+key-mode+
|
||||
+key-links+
|
||||
+key-height+)
|
||||
+key-gemini+
|
||||
+key-exclusive+
|
||||
+key-mode+
|
||||
+key-links+
|
||||
+key-height+)
|
||||
|
||||
(gen-simple-access (post-allowed-language
|
||||
:transform-value-fn
|
||||
|
|
@ -1651,39 +1681,39 @@
|
|||
:background bg
|
||||
:foreground fg
|
||||
:selected-background (access:accesses *software-configuration*
|
||||
window-key
|
||||
+key-input+
|
||||
+key-selected+
|
||||
+key-background+)
|
||||
window-key
|
||||
+key-input+
|
||||
+key-selected+
|
||||
+key-background+)
|
||||
:selected-foreground (access:accesses *software-configuration*
|
||||
window-key
|
||||
+key-input+
|
||||
+key-selected+
|
||||
+key-foreground+)
|
||||
window-key
|
||||
+key-input+
|
||||
+key-selected+
|
||||
+key-foreground+)
|
||||
|
||||
:unselected-background unselected-bg
|
||||
:unselected-foreground unselected-fg
|
||||
:input-background (access:accesses *software-configuration*
|
||||
window-key
|
||||
+key-input+
|
||||
+key-background+)
|
||||
window-key
|
||||
+key-input+
|
||||
+key-background+)
|
||||
:input-foreground (access:accesses *software-configuration*
|
||||
window-key
|
||||
+key-input+
|
||||
+key-foreground+))))
|
||||
window-key
|
||||
+key-input+
|
||||
+key-foreground+))))
|
||||
|
||||
(gen-simple-access (default-post-language)
|
||||
+key-default+
|
||||
+key-post+
|
||||
+key-language+)
|
||||
+key-default+
|
||||
+key-post+
|
||||
+key-language+)
|
||||
|
||||
(gen-simple-access (announcements-separator)
|
||||
+key-announcements+
|
||||
+key-separator+)
|
||||
+key-announcements+
|
||||
+key-separator+)
|
||||
|
||||
(gen-simple-access (announcements-icon)
|
||||
+key-announcements+
|
||||
+key-icon+)
|
||||
+key-announcements+
|
||||
+key-icon+)
|
||||
|
||||
(defun config-gemini-proxy ()
|
||||
(when-let* ((iri (access:accesses *software-configuration*
|
||||
|
|
|
|||
Loading…
Reference in New Issue