;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2023 Luis Guilherme Coelho <lgcoelho@disroot.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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.
;;;
;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu home services zathura)
  #:use-module (ice-9 match)
  #:use-module (guix records)
  #:use-module (gnu home services)
  #:use-module (gnu services configuration)
  #:use-module (srfi srfi-1)
  #:use-module (guix gexp)
  #:export (face
            face?

            recolor-configuration
            recolor-configuration?

            gui-configuration
            gui-configuration?

            key-map
            key-map?

            home-zathura-configuration
            home-zathura-configuration-n-completion-items
            home-zathura-configuration-completion-face
            home-zathura-configuration-completion-group-face
            home-zathura-configuration-completion-highlight-face
            home-zathura-configuration-default-face
            home-zathura-configuration-exec-command
            home-zathura-configuration-font
            home-zathura-configuration-gui-configuration
            home-zathura-configuration-inputbar-face
            home-zathura-configuration-notification-face
            home-zathura-configuration-notification-error-face
            home-zathura-configuration-notification-warning-face
            home-zathura-configuration-statusbar-face
            home-zathura-configuration-statusbar-h-padding
            home-zathura-configuration-statusbar-v-padding
            home-zathura-configuration-window-icon
            home-zathura-configuration-window-height
            home-zathura-configuration-window-width
            home-zathura-configuration-abort-clear-search
            home-zathura-configuration-adjust-open
            home-zathura-configuration-advance-pages-per-row
            home-zathura-configuration-continuous-hist-save
            home-zathura-configuration-database
            home-zathura-configuration-dbus-service
            home-zathura-configuration-dbus-raise-window
            home-zathura-configuration-filemonitor
            home-zathura-configuration-incremental-search
            home-zathura-configuration-highlight-color
            home-zathura-configuration-highlight-active-color
            home-zathura-configuration-highlight-transparency
            home-zathura-configuration-page-padding
            home-zathura-configuration-page-cache-size
            home-zathura-configuration-page-thumbnail-size
            home-zathura-configuration-pages-per-row
            home-zathura-configuration-first-page-column
            home-zathura-configuration-recolor
            home-zathura-configuration-render-loading
            home-zathura-configuration-render-loading-face
            home-zathura-configuration-scroll-hstep
            home-zathura-configuration-scroll-step
            home-zathura-configuration-scroll-full-overlap
            home-zathura-configuration-scroll-wrap
            home-zathura-configuration-show-directories
            home-zathura-configuration-show-hidden
            home-zathura-configuration-show-recent
            home-zathura-configuration-scroll-page-aware
            home-zathura-configuration-link-zoom
            home-zathura-configuration-link-hadjust
            home-zathura-configuration-search-hadjust
            home-zathura-configuration-window-title-basename
            home-zathura-configuration-window-title-home-tilde
            home-zathura-configuration-window-title-page
            home-zathura-configuration-statusbar-basename
            home-zathura-configuration-statusbar-page-percent
            home-zathura-configuration-statusbar-home-tilde
            home-zathura-configuration-zoom-center
            home-zathura-configuration-vertical-center
            home-zathura-configuration-zoom-max
            home-zathura-configuration-zoom-min
            home-zathura-configuration-zoom-step
            home-zathura-configuration-selection-clipboard
            home-zathura-configuration-selection-notification
            home-zathura-configuration-synctex
            home-zathura-configuration-synctex-editor-command
            home-zathura-configuration-index-face
            home-zathura-configuration-index-active-face
            home-zathura-configuration-sandbox
            home-zathura-configuration-window-icon-document
            home-zathura-configuration-page-right-to-left
            home-zathura-configuration-key-maps

            home-zathura-service-type
            home-zathura-extension))

(define (zathura-mode? value)
  (->bool (member value '(normal fullscreen presentation index))))

(define-configuration/no-serialization key-map
  (mode
   (zathura-mode 'normal)
   "The mode for which the key-map is being set.")
  (binding
   string ; improve this with regex
   "The key combination that the key-map will use.")
  (command string
   "Function and, optionally, arguments separated by spaces."))

(define list-of-key-maps?
  (list-of key-map?))

(define (serialize-list-of-key-maps field-name value)
  (define snake-case
    (@@ (guix import utils) snake-case))
  (apply string-append
         (map (match-record-lambda <key-map>
               (mode binding command)
               (format #f "~:[un~;~]map [~a] ~a~@[ ~a~]~%"
                          command
                          mode
                          binding
                          (and command
                            (match (string-split command #\ )
                             ((zathura-function . args)
                              (string-join (cons (snake-case zathura-function)
                                                 args)
                                           " "))))))
              value)))

(define (zathura-selection-clipboard? value)
  (->bool (member value '(clipboard primary))))

(define (zathura-sandbox? value)
  (->bool (member value '(normal strict #f))))

(define (serialize-zathura-sandbox field-name value)
  (format #f "set ~a ~:[none~;~a]~%" field-name value value))

(define (zathura-database? value)
  (->bool (member value '(plain sqlite #f))))

(define (serialize-zathura-filemonitor field-name value)
  (format #f "set ~a ~:[noop~;~a]~%" field-name value value))

(define (serialize-zathura-database field-name value)
  (format #f "set ~a ~:[null~;~a]~%" field-name value value))

(define (zathura-filemonitor? value)
  (->bool (member value '(glib signal #f))))

(define (serialize-zathura-filemonitor? field-name value)
  (format #f "set ~a ~:[noop~;~a]~%" field-name value value))

(define (zathura-adjust-open? value)
  (->bool (member value '(best-fit width))))

(define-configuration/no-serialization gui-configuration
  (command-line?
   (boolean #f)
   "Whether the zathura command line should be displayed or not.")
  (statusbar?
   (boolean #t)
   "Whether the zathura statusbar should be displayed or not.")
  (horizontal-scrollbar?
   (boolean #f)
   "Wheter the zathura horizontal scrollbar should be displayed.")
  (vertical-scrollbar?
   (boolean #f)
   "Wheter the zathura vertical scrollbar should be displayed."))

(define (serialize-gui-configuration field-name value)
  (match-record value <gui-configuration>
   (command-line? statusbar? horizontal-scrollbar? vertical-scrollbar?)
   (format #f "set guioptions ~@[c~]~@[s~]~@[h~]~@[v~]~%"
           command-line?
           statusbar?
           horizontal-scrollbar?
           vertical-scrollbar?)))

(define (hex-color? value)
  (define (hex-digit? value)
    (->bool (and (char? value)
                 (member value (char-set->list
                                char-set:hex-digit)))))
  (match (string->list value)
   ((\# . rest)
    (null? (filter (negate hex-digit?) rest)))
   (else #f)))

(define-maybe hex-color)

(define-configuration/no-serialization face
  (foreground
   maybe-hex-color
   "Foreground color.")
  (background
   maybe-hex-color
   "Background color."))

(define (unset? val)
  "Tests if VAL is unset."
  (equal? val (@@ (gnu services configuration)
                   %unset-value)))

(define* (if-set val #:optional (proc identity))
  "Apply PROC to VAL if VAL is not unset, otherwise returns #f."
  (if (not (unset? val)) (proc val) #f))

(define (serialize-face field-name value)
  (let ((str (string-drop-right (symbol->string field-name) 5)))
    (match-record value <face>
      (background foreground)
      (format #f "~:[~;set ~a-fg \"~a\"~%~]~
                  ~:[~;set ~a-bg \"~a\"~%~]"
              (if-set foreground) str foreground
              (if-set background) str background))))

(define-configuration/no-serialization recolor-configuration
  (default?
   (boolean #f)
   "Whether recoloring should be enabled by default.")
  (keephue?
   (boolean #f)
   "Enables or disables keeping original hue when recoloring.")
  (darkcolor
   (hex-color "#FFFFFF")
   "Defines the color value that is used to represent dark colors in recoloring
mode.")
  (lightcolor
   (hex-color "#000000")
   "Defines the color value that is used to represent light colors in recoloring
mode.")
  (reverse-video?
   (boolean #f)
   "Defines if original image colors should be kept while recoloring."))

(define (serialize-recolor-configuration field-name value)
  (match-record value <recolor-configuration>
    (default? keephue? darkcolor lightcolor reverse-video?)
    (format #f "set recolor ~:[false~;true~]~%~
                set recolor-keephue ~:[false~;true~]~%~
                set recolor-darkcolor ~a~%~
                set recolor-lightcolor ~a~%~
                set recolor-reverse-video ~:[false~;true~]~%"
            default?
            keephue?
            darkcolor
            lightcolor
            reverse-video?)))

(define (serialize-boolean field-name value)
  (define (strip-trailing-? name)
    ;; field? -> field
    (let ((str (symbol->string name)))
      (if (string-suffix? "?" str)
          (string-drop-right str 1)
          str)))
  (format #f "set ~a ~:[false~;true~]~%"
          (strip-trailing-? field-name)
          value))

(define (serialize-string field-name value)
  (format #f "set ~a \"~a\"~%" field-name value))

(define (serialize-* field-name value)
  (format #f "set ~a ~a~%" field-name value))
(define serialize-exact-integer serialize-*)
(define serialize-real serialize-*)
(define serialize-zathura-adjust-open serialize-*)
(define serialize-zathura-selection-clipboard serialize-*)

(define-maybe string)

(define-configuration home-zathura-configuration
  (n-completion-items
   (exact-integer 15)
   "Defines the maximum number of displayed completion entries.")
  (completion-face
   (face (face
          (background "#232323")
          (foreground "#DDDDDD")))
   "Defines the face used for command line completion entries.")
  (completion-group-face
   (face (face
          (background "#000000")
          (foreground "#DEDEDE")))
   "Defines the face used for command line completion group elements.")
  (completion-highlight-face
   (face (face 
          (background "#9FBC00")
          (foreground "#232323")))
   "Defines the face used for the current command line completion element.")
  (default-face
   (face (face
          (background "#000000")
          (foreground "#DDDDDD")))
   "Defines the default face.")
  (exec-command
   maybe-string
   "Defines a command the should be prepended to any command run with exec.")
  (font
   (string "monospace normal 9")
   "Defines the font that will be used.")
  (gui-configuration
   (gui-configuration (gui-configuration))
   "Whether the command line should be displayed or not.")
  (inputbar-face
   (face (face
          (background "#131313")
          (foreground "#9FBC00")))
   "Defines the face used for the inputbar.")
  (notification-face
   (face (face
          (background "#FFFFFF")
          (foreground "#000000")))
   "Defines the face used for notifications.")
  (notification-error-face
   (face (face
          (background "#FF1212")
          (foreground "#000000")))
   "Defines the face used for error notifications.")
  (notification-warning-face
   (face (face
          (background "#FFF712")
          (foreground "#000000")))
   "Defines the face used for a warning notification.")
  (statusbar-face
   (face (face
          (background "#000000")
          (foreground "#FFFFFF")))
   "Defines the face used for the statusbar.")
  (statusbar-h-padding
   (exact-integer 8)
   "Defines the horizontal padding of the statusbar and notificationbar.")
  (statusbar-v-padding
   (exact-integer 2)
   "Defines the vertical padding of the statusbar and notificationbar.")
  (window-icon
   maybe-string
   "Defines the path for a icon to be used as window icon.")
  (window-height
   (exact-integer 600)
   "Defines the window height on startup.")
  (window-width
   (exact-integer 800)
   "Defines the window width on startup.")
  (abort-clear-search?
   (boolean #t)
   "Defines if the search results should be cleared on abort.")
  (adjust-open
   (zathura-adjust-open 'best-fit)
   "Defines  which  auto  adjustment  mode should be used if a document is
loaded. Possible options are 'best-fit and 'width.")
  (advance-pages-per-row?
   (boolean #f)
   "Defines if the number of pages per row should be honored when advancing a
page.")
  (continuous-hist-save?
    (boolean #f)
    "Tells zathura whether to save document history at each page change or only
when closing a document.")
  (database
   (zathura-database 'plain)
   "Defines the database backend to use for bookmarks and input history.
Possible values are 'plain, 'sqlite (if built with sqlite support) and #f.
If #f is used, bookmarks and input history will not be stored.")
  (dbus-service?
   (boolean #t)
   "En/Disables the D-Bus service. If the services is disabled, SyncTeX forward
synchronization is not available.")
  (dbus-raise-window?
   (boolean #t)
   "Defines  whether zathura's window should be raised when receiving certain
commands via D-Bus.")
  (filemonitor
   (zathura-filemonitor 'glib)
   "Defines the file monitor backend used to check for changes in files.
Possible values are 'glib, 'signal (if signal handling is supported), and #f.
When set to #f, file monitor does not trigger reloads.")
  (incremental-search?
   (boolean #t)
   "En/Disables incremental search (search while typing).")
  (highlight-color
   (string "#9FBC00")
   "Defines the color that is used for highlighting parts of the document
(e.g.: show search results).")
  (highlight-fg
   (string "#9FBC00")
   "Defines  the  color that is used for text when highlighting parts of the
document (e.g.: number for links).")
  (highlight-active-color
   (string "#00BC00")
   "Defines the color that is used to show the current selected  highlighted
element (e.g: current search result).")
  (highlight-transparency
   (real 0.5)
   "Defines the opacity of a highlighted element.")
  (page-padding
   (exact-integer 1)
   "The page padding defines the gap in pixels between each rendered page.")
  (page-cache-size
   (exact-integer 15)
   "Defines the maximum number of pages that could be kept in the page cache.
When the cache is full and a new page that isn't cached becomes visible, the
least recently  viewed  page  in  the cache will be evicted to make room for
the new one.  Large values for this variable are NOT recommended, because this
will lead to consuming a significant portion of the system memory.")
  (page-thumbnail-size
   (exact-integer 4194304)
   "Defines  the maximum size in pixels of the thumbnail that could be kept in
the thumbnail cache per page. The thumbnail is scaled for a quick preview during
zooming  before the page is rendered. When the page is rendered, the result is
saved as the thumbnail only if the size is no more than this value.  A  larger
value  increases  quality but introduces longer delay in zooming and uses more
system memory.")
  (pages-per-row
   (exact-integer 1)
   "Defines the number of pages that are rendered next to each other in a row.")
  (first-page-column
   (string "1:2")
   "Defines the column in which the first page will be displayed. This setting
is stored separately for every value of pages-per-row according to the following
pattern <1 page per row>:[<2 pages per row>[: ...]]. The last value in the
list will be used for all other number of pages per row if not set explicitly.
Per default, the first column is set to 2 for double-page layout, i.e. the
value is set to 1:2. A value of 1:1:3 would put the first page in dual-page
layout in the first column, and for layouts with more columns the first page
would be put in the 3rd column.")
  (recolor
   (recolor-configuration (recolor-configuration))
   "Configuration used for recoloring. Disabled when no value is supplied.")
  (render-loading?
   (boolean #t)
   "Defines if the \"Loading...\" text should be displayed if a page is rendered.")
  (render-loading-face
   (face (face
          (background "#FFFFFF")
          (foreground "#000000")))
   "Defines the face used for the \"Loading...\" text.")
  (scroll-hstep
   (real -1.0)
   "Defines the horizontal step size of scrolling by calling the scroll command
once.")
  (scroll-step
   (real 40)
   "Defines the step size of scrolling by calling the scroll command once.")
  (scroll-full-overlap
   (real 0)
   "Defines the proportion of the current viewing area that should be visible
after scrolling a full page.")
  (scroll-wrap?
   (boolean #f)
   "Defines if the last/first page should be wrapped.")
  (show-directories?
   (boolean #t)
   "Defines if the directories should be displayed in completion.")
  (show-hidden?
   (boolean #f)
   "Defines if hidden files and directories should be displayed in completion.")
  (show-recent
   (exact-integer 10)
   "Defines the number of recent files that should be displayed in completion.
If the  value is negative, no upper bounds are applied. If the value is 0, no
recent files are shown.")
  (scroll-page-aware?
   (boolean #f)
   "Defines if scrolling by half or full pages stops at page boundaries.")
  (link-zoom?
   (boolean #t)
   "En/Disables the ability of changing zoom when following links.")
  (link-hadjust?
   (boolean #t)
   "En/Disables aligning to the left internal link targets, for example from the
index.")
  (search-hadjust?
   (boolean #t)
   "En/Disables horizontally centered search results.")
  (window-title-basename?
   (boolean #f)
   "Use basename of the file in the window title.")
  (window-title-home-tilde?
   (boolean #f)
   "Display  a short version of the file path, which replaces $HOME with ~, in
the window title.")
  (window-title-page?
   (boolean #f)
   "Display the page number in the window title.")
  (statusbar-basename?
   (boolean #f)
   "Use basename of the file in the statusbar.")
  (statusbar-page-percent?
   (boolean #f)
   "Display (current page / total pages) as a percent in the statusbar.")
  (statusbar-home-tilde?
   (boolean #f)
   "Display a short version of the file path, which replaces $HOME with ~, in
the statusbar.")
  (zoom-center?
   (boolean #f)
   "En/Disables horizontally centered zooming.")
  (vertical-center?
   (boolean #f)
   "Center the screen at the vertical midpoint of the page by default.")
  (zoom-max
   (exact-integer 1000)
   "Defines the maximum percentage that the zoom level can be.")
  (zoom-min
   (exact-integer 10)
   "Defines the minimum percentage that the zoom level can be.")
  (zoom-step
   (exact-integer 10)
   "Defines the amount of percent that is zoomed in or out on each command.")
  (selection-clipboard
   (zathura-selection-clipboard 'primary)
   "Defines  the X clipboard into which mouse-selected data will be written.
When it is 'clipboard, selected data will be written to the CLIPBOARD clipboard,
and can be pasted using the Ctrl+v key combination. When it is 'primary, se‐
lected data will be written to the PRIMARY clipboard, and can be pasted  using
the middle mouse button, or the Shift-Insert key combination.")
  (selection-notification?
   (boolean #t)
   "Defines if a notification should be displayed after selecting text.")
  (synctex
   (boolean #t)
   "En/Disables SyncTeX backward synchronization support.")
  (synctex-editor-command
   maybe-string
   "Defines the command executed for SyncTeX backward synchronization.")
  (index-face
   (face (face
          (background "#232323")
          (foreground "#DDDDDD")))
   "Defines the face used for the index mode.")
  (index-active-face
   (face (face
          (background "#9FBC00")
          (foreground "#232323")))
   "Defines the face used for selected elements in index mode.")
  (sandbox
   (zathura-sandbox 'normal)
   "Defines  the sandbox mode to use for the seccomp syscall filter. Possible
values are 'none, 'normal and 'strict. If 'none is used, the sandbox will be
disabled. The use of 'normal will provide minimal protection and allow normal
use of zathura with support for all features. The 'strict mode is a read only
sandbox that is intended for viewing documents only.
Some features are disabled when using strict sandbox mode:
@table @code
  @item saving/writing files
  @item use of input methods like ibus
  @item printing
  @item bookmarks and history
@end table
The strict sandbox mode is still experimental with some libc implementations.
Currently supported and tested libc implementations: glibc
No feature regressions are expected when using normal sandbox mode.
When running under WSL, the default is 'none since seccomp is  not  supported
in that environment.")
  (window-icon-document?
   (boolean #f)
   "Defines whether the window document should be updated based on the first
page of a document.")
  (page-right-to-left?
   (boolean #f)
   "Defines whether pages in multi-column view should start from the right side.")
  (key-maps
   (list-of-key-maps '())
   "Defines the list of key-maps for zathura. When shortcut-function is #f the
key-map is unset."))

(define (zathura-xdg-configuration-file-service configuration)
  `(("zathura/zathurarc"
     ,(mixed-text-file "zathurarc"
        (serialize-configuration configuration
                                 home-zathura-configuration-fields)))))


(define-configuration/no-serialization home-zathura-extension
  (key-maps
   (list-of-key-maps '())
   "List of key-map objects for extending the zathura configuration file."))

(define (home-zathura-extensions original-config extension-configs)
  (home-zathura-configuration
   (inherit original-config)
   (key-maps (append (home-zathura-configuration-key-maps original-config)
                     (append-map home-zathura-extension-key-maps
                                 extension-configs)))))

(define home-zathura-service-type
  (service-type
   (name 'zathura-service)
   (extensions
    (list (service-extension
            home-xdg-configuration-files-service-type
            zathura-xdg-configuration-file-service)))
   (compose identity)
   (extend home-zathura-extensions)
   (default-value (home-zathura-configuration))
   (description "Set ~/.config/zathura.conf")))

(define (generate-doc)
  (configuration->documentation 'home-zathura-configuration))