;; tinmop: an humble mastodon 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/][http://www.gnu.org/licenses/]].

(in-package :software-configuration)

;; CONFIG                := (ENTRIES)*
;; ENTRIES               := COMMENT*
;;                         (USE-FILE
;;                          | IGNORE-USER-RE-ASSIGN
;;                          | COLOR-RE-ASSIGN
;;                          | SERVER-ASSIGN
;;                          | USERNAME-ASSIGN
;;                          | GENERIC-ASSIGN)
;;                         COMMENT*
;; SERVER-ASSIGN         := SERVER-KEY BLANKS ASSIGN BLANKS GENERIC-VALUE BLANKS
;; USERNAME-ASSIGN       := USERNAME-KEY BLANKS ASSIGN BLANKS GENERIC-VALUE BLANKS
;; GENERIC-ASSIGN        := (and key blanks assign blanks
;;                           (or quoted-string
;;                               hexcolor
;;                               colorname
;;                               generic-value) ; the order in this list *is* important
;;                         blanks)
;; IGNORE-USER-RE-ASSIGN := IGNORE-USER-RE-KEY ASSIGN REGEXP
;; COLOR-RE-ASSIGN       := COLOR-RE-KEY ASSIGN REGEXP FG-COLOR (? ATTRIBUTE-VALUE)
;; USE-FILE              := (AND USE BLANKS FILEPATH BLANKS)
;; KEY                   := FIELD (FIELD-SEPARATOR KEY)*
;; BLANKS                := (BLANK)*
;; FILEPATH              := QUOTED-STRING
;; USE                   := "use"
;; SERVER-KEY            := "server"
;; USERNAME-KEY          := "username"
;; COLOR-RE-KEY          := "color-regexp"
;; IGNORE-USER-RE-KEY    := "ignore-user-regexp"
;; REGEXP                := QUOTED-STRING
;; QUOTED-STRING         := #\" (not #\") #\"
;; FIELD                 := ( (or ESCAPED-CHARACTER
;;                               (not #\# ASSIGN BLANK FIELD-SEPARATOR) )*
;; COMMENT               := BLANKS #\# (not #\Newline)* BLANKS
;; FIELD-SEPARATOR       := #\.
;; GENERIC-VALUE         := KEY
;; ASSIGN                := #\=
;; BLANK                 := (or #\space #\Newline #\Tab)
;; BG-COLOR              := COLOR
;; FG-COLOR              := COLOR
;; COLOR                 := HEX-COLOR | COLOR-NAME
;; HEX-COLOR             := HEXCOLOR-PREFIX
;;                         HEXDIGIT HEXDIGIT -> red
;;                         HEXDIGIT HEXDIGIT -> green
;;                         HEXDIGIT HEXDIGIT -> blue
;; ESCAPED-CHARACTER     := #\\ any-character
;; HEXCOLOR-PREFIX       := #\#
;; HEX-DIGIT             := (and (character-ranges #\0 #\9)
;;                              (character-ranges #\a #\f)
;;                              (character-ranges #\A #\f)
;; ATTRIBUTE-VALUE       := "bold"
;;                         | "italic"
;;                         | "underline"
;;                         | "blink"
;; COLOR-NAME            := "black"
;;                         | "red"
;;                         | "green"
;;                         | "yellow"
;;                         | "blue"
;;                         | "magenta"
;;                         | "cyan"
;;                         | "white"

(define-constant +conf-filename+         "main.conf"             :test #'string=)

(define-constant +shared-conf-filename+  "shared.conf"           :test #'string=)

(define-constant +field-separator-value+ "."                     :test #'string=)

(define-constant +field-separator+       :field-separator        :test #'eq)

(defrule blank (or #\space #\Newline #\Tab)
  (:constant nil))

(defrule blanks (* blank)
  (:constant nil))

(defrule assign #\=
  (:constant nil))

(defrule comment (and blanks #\# (* (not #\Newline)) blanks)
  (:constant nil))

(defrule hexcolor-prefix #\#)

(defrule 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
  (:text t)
  (:function (lambda (a) (parse-integer a :start 1 :radix 16))))

(defun keywordize (a)
  (make-keyword (string-upcase a)))

(defrule colorname
    (or "black"
        "red"
        "green"
        "yellow"
        "blue"
        "magenta"
        "cyan"
        "white")
  (:function keywordize))

(defrule escaped-character (and #\\ character)
  (:function (lambda (a) (list (second a)))))

(defrule field-separator #\.)

(defrule field
    (* (or escaped-character
           (not (or #\# assign field-separator 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)))
  (:function flatten))

(defrule key fields
  (:function (lambda (a)
               (mapcar (lambda (element)
                         (if (string= +field-separator-value+ element)
                             nil
                             (format-keyword element)))
                       a)))
  (:function remove-if-null))

(defrule generic-value 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)
  (:function remove-if-null))

(defrule quoted-string (and #\" (+ (not #\")) #\")
  (:function (lambda (a) (second a)))
  (:text t))

(defrule regexp quoted-string)

(defrule color-re-key "color-regexp"
  (:constant :color-re))

(defclass color-re-assign ()
  ((re
    :initform nil
    :initarg  :re
    :accessor re)
   (color-name
    :initform nil
    :initarg  :color-name
    :accessor color-name)
   (color-value
    :initform nil
    :initarg  :color-value
    :accessor color-value)
   (attributes
    :initform nil
    :initarg  :attributes
    :accessor attributes))
  (:documentation "A color assign based on a regular expression. Slots
  color-name and color-value are mutually exclusive"))

(defmethod print-object ((object color-re-assign) stream)
  (print-unreadable-object (object stream :type t :identity nil)
    (with-accessors ((re         re)
                     (color-name  color-name)
                     (color-value color-value)
                     (attributes  attributes)) object
      (format stream "re: ~s colorname: ~s colorvalue: ~s attributes ~a"
              re color-name color-value attributes))))

(defun make-color-re-assign (re color-name color-value attributes)
  (assert (and (or color-name
                   color-value)
               (or (null color-name)
                   (null color-value))))
  (make-instance 'color-re-assign
                 :re          re
                 :color-name  color-name
                 :color-value color-value
                 :attributes  attributes))

(defun build-color-re-assign (parsed)
  (let* ((clean         (remove-if-null parsed))
         (re            (second parsed))
         (color         (third  parsed))
         (color-name-p  (keywordp color))
         (attributes    (first (fourth parsed))))
    (list (first clean)
          (make-color-re-assign re
                                (and color-name-p       color)
                                (and (not color-name-p) color)
                                attributes))))

(defrule attribute-value (or "bold"
                             "italic"
                             "underline"
                             "blink")
  (:text t)
  (:function tui-utils:text->tui-attribute))

(defrule color-re-assign
    (and color-re-key blanks
         assign blanks regexp blanks
         (or hexcolor colorname) blanks
         (? (and attribute-value blanks)))
  (:function remove-if-null)
  (:function build-color-re-assign))

(defrule ignore-user-re-key "ignore-user-regexp"
  (:constant :ignore-user-re))

(defrule ignore-user-re-assign
    (and ignore-user-re-key blanks
         assign blanks regexp blanks)
  (:function (lambda (a) (list (first a) (fifth a)))))

(defrule server-key "server"
  (:constant :server))

(defrule username-key "username"
  (:constant :username))

(defrule server-assign
    (and server-key blanks assign blanks generic-value blanks)
  (:function remove-if-null))

(defrule username-assign
    (and username-key blanks assign blanks generic-value blanks)
  (:function remove-if-null))

(defrule filepath quoted-string)

(defparameter *already-included-files* ())

(defrule use-file (and "use" blanks filepath blanks)
  (:function (lambda (a)
               (let ((file (third a)))
                 (if (find file *already-included-files* :test #'string=)
                     (error "Cyclic include of file ~s detected" file)
                     (progn
                       (push file *already-included-files*)
                       (load-config-file (third a))))
                 nil))))

(defrule entries
    (and (* comment)
         (or use-file
             color-re-assign
             ignore-user-re-assign
             server-assign
             username-assign
             generic-assign)
         (* comment))
  (:function second))

(defrule config (* entries)
  (:function remove-if-null))

(defgeneric parse-config (object))

(defmethod parse-config ((object string))
  (parse 'config object))

(defmethod parse-config ((object pathname))
  (parse-config (fs:slurp-file object)))

(defparameter *software-configuration* ())

(defmacro gen-key-constant (name)
  `(define-constant ,(format-fn-symbol t "+key-~a+" name)
       ,(format-keyword name)
       :test #'eq))

(defmacro gen-key-constants (&rest names)
  `(progn
     ,@(loop for name in names collect
            `(gen-key-constant ,name))))

(gen-key-constants background
                   foreground
                   title
                   start
                   end
                   left
                   right
                   stopper
                   root
                   width
                   height
                   error
                   info
                   window
                   header
                   focus
                   prefix
                   postfix
                   value
                   attribute
                   new-message
                   mark
                   vote-vertical-bar
                   crypted
                   histogram
                   error-dialog
                   info-dialog
                   input-dialog
                   help-dialog
                   notify-window
                   life
                   quick-help
                   more-choices
                   modeline
                   date-format
                   locked
                   unlocked
                   account
                   main-window
                   thread-window
                   message-window
                   attachment-header
                   max-numbers-allowed-attachments
                   max-message-length
                   max-report-comment-length
                   reply-quoted-character
                   line-position-mark
                   favourite
                   sensitive
                   boosted
                   tags-window
                   conversations-window
                   keybindings-window
                   suggestions-window
                   open-attach-window
                   open-message-link-window
                   command-window
                   command-separator
                   tree
                   branch
                   arrow
                   data
                   data-leaf
                   leaf
                   branch
                   spacer
                   vertical-line
                   editor
                   username
                   server
                   message
                   selected
                   deleted
                   input
                   read
                   unread
                   color-re
                   ignore-user-re
                   purge-history-days-offset
                   purge-cache-days-offset)

(defun load-config-file (&optional (virtual-filepath +conf-filename+))
  (handler-case
      (progn
        (let* ((file (res:get-config-file virtual-filepath))
               (tree (parse-config (fs:namestring->pathname file))))
          (loop for entry in tree do
               (let ((key   (first  entry))
                     (value (second entry)))
                 (cond
                   ((or (eq +key-color-re+ key)
                        (eq +key-ignore-user-re+ key))
                    (setf (access:accesses *software-configuration* key)
                          (append (access:accesses *software-configuration* key)
                                  (list value))))
                   ((keywordp key)
                    (setf (access:accesses *software-configuration* key) value))
                   (t
                    (multiple-value-bind (rest all)
                        (apply #'access:set-accesses value *software-configuration* key)
                      (declare (ignore rest))
                      (setf *software-configuration* all))))))
          *software-configuration*))
    (error (e)
      (format *error-output* "~a~%" e)
      (os-utils:exit-program 1))))

;;;; end of parser

(defparameter *allowed-status-visibility* '("public" "unlisted" "private" "direct")
  "- public   Visible to everyone, shown in public timelines;
   - unlisted Visible to public, but not included in public timelines;
   - private  Visible to followers only, and to any mentioned users;
   - direct   Visible only to mentioned users.")

(defparameter *allowed-attachment-type*   '("unknown" "image" "gifv" "video" "audio"))

;;;; interface

(defun vote-vertical-bar ()
  (or (access:accesses *software-configuration*
                       +key-vote-vertical-bar+)
      "="))

(defun crypted-mark-value ()
  (or (access:accesses *software-configuration*
                       +key-crypted+
                       +key-mark+
                       +key-value+)
      (_ "This message was crypted.")))

(defun quick-help-header-colors ()
  (values (access:accesses *software-configuration*
                           +key-quick-help+
                           +key-header+
                           +key-background+)
          (access:accesses *software-configuration*
                           +key-quick-help+
                           +key-header+
                           +key-foreground+)
          (tui-utils:text->tui-attribute (access:accesses *software-configuration*
                                                          +key-quick-help+
                                                          +key-header+
                                                          +key-attribute+))))

(defun window-titles-end (side)
  (assert (member side (list +key-left+ +key-right+)))
  (access:accesses *software-configuration*
                   +key-window+
                   +key-title+
                   side
                   +key-stopper+
                   +key-value+))

(defun window-titles-ends ()
  (multiple-value-bind (x y focus-value)
      (config-win-focus-mark)
    (declare (ignore x y))
    (values (window-titles-end +key-left+)
            (window-titles-end +key-right+)
            (+ 2 (length focus-value)))))

(defun tags-histogram-foreground ()
  (access:accesses *software-configuration*
                   +key-tags-window+
                   +key-histogram+
                   +key-foreground+))

(defun tags-new-message-mark ()
  (access:accesses *software-configuration*
                   +key-tags-window+
                   +key-new-message+
                   +key-mark+
                   +key-value+))

(defun conversation-window-message-count-colors (key-read/unread)
  (values (access:accesses *software-configuration*
                           +key-conversations-window+
                           key-read/unread
                           +key-foreground+)
          (access:accesses *software-configuration*
                           +key-conversations-window+
                           key-read/unread
                           +key-background+)))

(defun conversation-window-read-colors ()
  (multiple-value-bind (fg bg)
      (conversation-window-message-count-colors +key-read+)
    (values fg bg)))

(defun conversation-window-unread-colors ()
  (multiple-value-bind (fg bg)
      (conversation-window-message-count-colors +key-unread+)
    (values fg bg)))

(defun max-message-length ()
  (num:parse-number-default (access:accesses *software-configuration*
                                             +key-max-message-length+)
                            500))

(defun max-report-comment-length ()
  (num:parse-number-default (access:accesses *software-configuration*
                                             +key-max-report-comment-length+)
                            100))

(defun quote-char ()
  (or (access:accesses *software-configuration*
                       +key-reply-quoted-character+)
      "> "))

(defun max-attachments-allowed ()
  (num:parse-number-default (access:accesses *software-configuration*
                                          +key-max-numbers-allowed-attachments+)
                            4))

(defun external-editor ()
  (access:accesses *software-configuration*
                   +key-editor+))

(defun color-regexps ()
  (access:accesses *software-configuration*
                   +key-color-re+))

(defun ignore-users-regexps ()
  (access:accesses *software-configuration*
                   +key-ignore-user-re+))

(defmacro gen-win-key-access (fn-suffix key)
  `(defun ,(misc:format-fn-symbol t "win-~a" fn-suffix) (win-key)
     (access:accesses *software-configuration*
                      win-key
                      ,key)))

(gen-win-key-access bg     +key-background+)

(gen-win-key-access fg     +key-foreground+)

(gen-win-key-access height +key-height+)

(gen-win-key-access width  +key-width+)

(defmacro gen-simple-access ((fn-name &key (transform-value-fn 'identity)) &rest keys)
  `(defun ,(misc:format-fn-symbol t "config-~a" fn-name) ()
     (,transform-value-fn (access:accesses *software-configuration*
                                           ,@keys))))

(gen-simple-access (purge-history-days-offset
                    :transform-value-fn
                    (lambda (a)
                      (num:safe-parse-number a
                                             :fix-fn (lambda (e)
                                                       (declare (ignore e))
                                                       100))))
                    +key-purge-history-days-offset+)

(gen-simple-access (purge-cage-days-offset
                    :transform-value-fn
                    (lambda (a)
                      (num:safe-parse-number a
                                             :fix-fn (lambda (e)
                                                       (declare (ignore e))
                                                       100))))
                    +key-purge-history-days-offset+)

(gen-simple-access (notification-life
                    :transform-value-fn
                    (lambda (a)
                      (num:safe-parse-number a
                                             :fix-fn (lambda (e)
                                                       (declare (ignore e))
                                                       100))))
                   +key-notify-window+
                   +key-life+)

(gen-simple-access (server-name)
                   +key-server+)

(gen-simple-access (username)
                   +key-username+)

(defun config-win-focus-mark ()
  (values (access:accesses  *software-configuration*
                            +key-window+
                            +key-focus+
                            +key-mark+
                            +key-background+)
          (access:accesses  *software-configuration*
                            +key-window+
                            +key-focus+
                            +key-mark+
                            +key-foreground+)
          (access:accesses  *software-configuration*
                            +key-window+
                            +key-focus+
                            +key-mark+
                            +key-value+)))

(defun command-separator-config-values ()
  (values (access:accesses *software-configuration*
                           +key-command-window+
                           +key-command-separator+
                           +key-background+)
          (access:accesses *software-configuration*
                           +key-command-window+
                           +key-command-separator+
                           +key-foreground+)
          (access:accesses *software-configuration*
                           +key-command-window+
                           +key-command-separator+
                           +key-value+)))

(defun command-error-message-colors ()
  (values (access:accesses *software-configuration*
                           +key-command-window+
                           +key-error+
                           +key-message+
                           +key-background+)
          (access:accesses *software-configuration*
                           +key-command-window+
                           +key-error+
                           +key-message+
                           +key-foreground+)
          (tui-utils:text->tui-attribute (access:accesses *software-configuration*
                                                          +key-command-window+
                                                          +key-error+
                                                          +key-message+
                                                          +key-attribute+))))

(defun command-info-message-colors ()
  (values (access:accesses *software-configuration*
                           +key-command-window+
                           +key-info+
                           +key-message+
                           +key-background+)
          (access:accesses *software-configuration*
                           +key-command-window+
                           +key-info+
                           +key-message+
                           +key-foreground+)
          (tui-utils:text->tui-attribute (access:accesses *software-configuration*
                                                          +key-command-window+
                                                          +key-info+
                                                          +key-message+
                                                          +key-attribute+))))


(defun tree-config-colors (tree-win-holder)
  (values (access:accesses *software-configuration*
                           tree-win-holder
                           +key-tree+
                           +key-branch+
                           +key-foreground+)
          (access:accesses *software-configuration*
                           tree-win-holder
                           +key-tree+
                           +key-arrow+
                           +key-foreground+)
          (access:accesses *software-configuration*
                           tree-win-holder
                           +key-tree+
                           +key-data+
                           +key-foreground+)
          (access:accesses *software-configuration*
                           tree-win-holder
                           +key-tree+
                           +key-data-leaf+
                           +key-foreground+)
          (access:accesses *software-configuration*
                           tree-win-holder
                           +key-tree+
                           +key-root+
                           +key-foreground+)))

(defun tree-config-rendering-values (tree-win-holder)
  (values (access:accesses *software-configuration*
                           tree-win-holder
                           +key-tree+
                           +key-arrow+
                           +key-value+)
          (access:accesses *software-configuration*
                           tree-win-holder
                           +key-tree+
                           +key-leaf+
                           +key-value+)
          (access:accesses *software-configuration*
                           tree-win-holder
                           +key-tree+
                           +key-branch+
                           +key-value+)
          (access:accesses *software-configuration*
                           tree-win-holder
                           +key-tree+
                           +key-spacer+
                           +key-value+)
          (access:accesses *software-configuration*
                           tree-win-holder
                           +key-tree+
                           +key-vertical-line+
                           +key-value+)))

(defun make-tree-colormap (window-key)
  (let ((tree-color-map ()))
    (flet ((add-color-pair (key color)
             (setf tree-color-map (acons key color tree-color-map))))
      (multiple-value-bind (branch-color arrow-color data-color leaf-color root-color)
          (swconf:tree-config-colors window-key)
        (add-color-pair :branch    branch-color)
        (add-color-pair :arrow     arrow-color)
        (add-color-pair :data      data-color)
        (add-color-pair :data-leaf leaf-color)
        (add-color-pair :data-root root-color))
      tree-color-map)))

(defun thread-message-symbol-lookup (field key)
  (access:accesses *software-configuration*
                   +key-thread-window+
                   +key-message+
                   field
                   key))

(defun thread-message-symbol-value (field)
  (thread-message-symbol-lookup field +key-value+))

(defun thread-message-symbol-fg (field)
  (thread-message-symbol-lookup field +key-foreground+))

(defun thread-message-symbol (field)
  (values (thread-message-symbol-value field)
          (thread-message-symbol-fg    field)))

(defun thread-message-colors (key)
  (values (access:accesses *software-configuration*
                           +key-thread-window+
                           +key-message+
                           key
                           +key-background+)
          (access:accesses *software-configuration*
                           +key-thread-window+
                           +key-message+
                           key
                           +key-foreground+)
          (tui-utils:text->tui-attribute (access:accesses *software-configuration*
                                                          +key-thread-window+
                                                          +key-message+
                                                          key
                                                          +key-attribute+))))
(defun thread-message-read-colors ()
  (multiple-value-bind (bg fg attribute)
      (thread-message-colors +key-read+)
    (values bg fg  attribute)))

(defun thread-message-unread-colors ()
  (multiple-value-bind (bg fg attribute)
      (thread-message-colors +key-unread+)
    (values bg fg attribute)))

(defun thread-message-selected-colors ()
  (multiple-value-bind (bg fg attribute)
      (thread-message-colors +key-selected+)
    (values bg fg attribute)))

(defun thread-message-deleted-colors ()
  (multiple-value-bind (bg fg attribute)
      (thread-message-colors +key-deleted+)
    (values bg fg attribute)))

(defun modeline-colors (window-key)
  (values (access:accesses *software-configuration*
                           window-key
                           +key-modeline+
                           +key-background+)
          (access:accesses *software-configuration*
                           window-key
                           +key-modeline+
                           +key-foreground+)))

(defun modeline-fmt (window-key)
  (access:accesses *software-configuration*
                   window-key
                   +key-modeline+
                   +key-value+))

(defun date-fmt (window-key)
  (let* ((raw (access:accesses *software-configuration*
                                    window-key
                                    +key-date-format+
                                    +key-value+)))
    (date-formatter:expand-date-formatter-spec raw)))

(defun locked/unlocked-value (key-window locked)
  (let ((key-locked (if locked
                        +key-locked+
                        +key-unlocked+)))
    (access:accesses *software-configuration*
                     key-window
                     key-locked
                     +key-value+)))

(defun locked/unlocked-account-mark-value (key-window locked)
  (let ((key-locked (if locked
                        +key-locked+
                        +key-unlocked+)))
    (access:accesses *software-configuration*
                     key-window
                     +key-account+
                     key-locked
                     +key-mark+
                     +key-value+)))

(defun message-window-locked-account-mark ()
  (locked/unlocked-account-mark-value +key-message-window+ t))

(defun message-window-unlocked-account-mark ()
  (locked/unlocked-account-mark-value +key-message-window+ nil))

(defun message-window-account-locking-status-mark (locking-value)
  (if locking-value
      (message-window-locked-account-mark)
      (message-window-unlocked-account-mark)))

(defun message-window-line-mark-values ()
  "return three values: mark string fg and bg"
  (values (access:accesses *software-configuration*
                           +key-message-window+
                           +key-line-position-mark+
                           +key-value+)
          (access:accesses *software-configuration*
                           +key-message-window+
                           +key-line-position-mark+
                           +key-foreground+)
          (access:accesses *software-configuration*
                           +key-message-window+
                           +key-line-position-mark+
                           +key-background+)))

(defun message-window-attachments-header ()
  (values (access:accesses *software-configuration*
                           +key-message-window+
                           +key-attachment-header+
                           +key-prefix+
                           +key-value+)
          (access:accesses *software-configuration*
                           +key-message-window+
                           +key-attachment-header+
                           +key-postfix+
                           +key-value+)
          (access:accesses *software-configuration*
                           +key-message-window+
                           +key-attachment-header+
                           +key-value+)))

(defclass form-style ()
  ((background
    :initform :black
    :initarg  :background
    :accessor background)
   (foreground
    :initform :white
    :initarg  :foreground
    :accessor foreground)
   (input-background
    :initform :black
    :initarg  :input-background
    :accessor input-background)
   (input-foreground
    :initform :white
    :initarg  :input-foreground
    :accessor input-foreground)
   (selected-background
    :initform :black
    :initarg  :selected-background
    :accessor selected-background)
   (selected-foreground
    :initform :white
    :initarg  :selected-foreground
    :accessor selected-foreground)))

(defmethod print-object ((object form-style) stream)
  (print-unreadable-object (object stream :type t)
    (with-accessors ((background          background)
                     (foreground          foreground)
                     (input-background    input-background)
                     (input-foreground    input-foreground)
                     (selected-background selected-background)
                     (selected-foreground selected-foreground)) object
      (format stream
              "fg ~a bg ~a input-fg ~a input-bg ~a selected-fg ~a selected-bg ~a"
              foreground
              background
              input-foreground
              input-background
              selected-foreground
              selected-background))))

(defun form-style (window-key)
  (make-instance 'form-style
                 :background          (access:accesses *software-configuration*
                                                       window-key
                                                       +key-background+)
                 :foreground          (access:accesses *software-configuration*
                                                       window-key
                                                       +key-foreground+)
                 :selected-background (access:accesses *software-configuration*
                                                       window-key
                                                       +key-input+
                                                       +key-selected+
                                                       +key-background+)
                 :selected-foreground (access:accesses *software-configuration*
                                                       window-key
                                                       +key-input+
                                                       +key-selected+
                                                       +key-foreground+)
                 :input-background    (access:accesses *software-configuration*
                                                       window-key
                                                       +key-input+
                                                       +key-background+)
                 :input-foreground    (access:accesses *software-configuration*
                                                       window-key
                                                       +key-input+
                                                       +key-foreground+)))