;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2024 Arnaud Daby-Seesaram <ds-ac@nanein.fr>
;;;
;;; 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 sway)
  #:use-module (guix monads)
  #:use-module (guix modules)
  #:use-module (guix gexp)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (guix packages)
  #:use-module (gnu services configuration)
  #:use-module (gnu home services)
  #:use-module (gnu packages freedesktop)
  #:use-module (gnu packages xdisorg)
  #:use-module (gnu packages image)
  #:use-module (gnu packages gnome)
  #:use-module (gnu packages wm)
  #:use-module (gnu packages emacs)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages base)
  #:use-module (gnu packages suckless)
  #:use-module (gnu packages glib)
  #:export (;; Accessors and predicates do not need to be exported.
            sway-configuration
            sway-bar
            sway-output
            sway-input
            point
            sway-color
            sway-border-color
            home-sway-service-type))

;; Helper function.
(define (flatten l)
  (let loop ((lst l) (acc '()))
    (match lst
      (() acc)
      ((head . tail)
       (loop tail (append acc head))))))

\f
;;;
;;; Default settings.
;;;

(define %sway-default-variables
  `((mod   . "Mod4")
    (left  . "h")
    (down  . "j")
    (up    . "k")
    (right . "l")
    (term  . ,#~(string-append #$st "/bin/st"))
    (menu  . ,#~(string-append #$dmenu "/bin/dmenu_run"))))

(define %sway-default-gestures
  `((swipe:3:right . "workspace next_on_output")
    (swipe:3:left  . "workspace prev_on_output")
    (swipe:3:down  . "move to scratchpad")
    (swipe:3:up    . "scratchpad show")
    (pinch:2:clockwise
     . "move container to workspace prev_on_output")
    (pinch:2:counterclockwise
     . "move container to workspace next_on_output")
    (swipe:4:left  . "exec alacritty")
    (swipe:4:right . "exec qutebrowser")
    (swipe:4:down . "exec st")
    (swipe:4:up
     . ,#~(string-append
           "exec " #$emacs "/bin/emacsclient -a '"
           #$libnotify "/bin/notify-send Oups \"emacs not loaded :/\"' -c"))
    (pinch:inward+right . "resize shrink width")
    (pinch:inward+left . "resize grow width")
    (pinch:inward+down . "resize shrink height")
    (pinch:inward+up . "resize grow height")
    (pinch:outward+up . "move up")
    (pinch:outward+down . "move down")
    (pinch:outward+left . "move left")
    (pinch:outward+right . "move right")))

(define %sway-default-keybindings
  `(($mod+Shift+e
     . ,#~(string-append
           "exec " #$emacs
           "/bin/emacsclient -a '"
           #$libnotify "/bin/notify-send Oups \"emacs not loaded :/\"' -c"))
    ($mod+Return . "exec $term")
    ($mod+Shift+c . "kill")
    ($mod+p . "exec $menu")
    ($mod+Shift+r . "reload")
    ($mod+Shift+q
     . ,#~(string-append
           "exec " #$sway "/bin/swaynag -t warning "
           "-m 'You pressed the exit shortcut. Do you really want to exit sway?"
           " This will end your Wayland session.'"
           " -B 'Yes, exit sway' 'swaymsg exit'"))
    ($mod+$left . "focus left")
    ($mod+$right . "focus right")
    ($mod+$up . "focus up")
    ($mod+$down . "focus down")
    ($mod+Shift+$left . "move left")
    ($mod+Shift+$right . "move right")
    ($mod+Shift+$up . "move up")
    ($mod+Shift+$down . "move down")
    ($mod+ampersand . "workspace number 1")
    ($mod+eacute . "workspace number 2")
    ($mod+quotedbl . "workspace number 3")
    ($mod+apostrophe . "workspace number 4")
    ($mod+parenleft . "workspace number 5")
    ($mod+minus . "workspace number 6")
    ($mod+egrave . "workspace number 7")
    ($mod+underscore . "workspace number 8")
    ($mod+ccedilla . "workspace number 9")
    ($mod+agrave . "workspace number 10")
    ($mod+Shift+ampersand . "move container to workspace number 1")
    ($mod+Shift+eacute . "move container to workspace number 2")
    ($mod+Shift+quotedbl . "move container to workspace number 3")
    ($mod+Shift+apostrophe . "move container to workspace number 4")
    ($mod+Shift+parenleft . "move container to workspace number 5")
    ($mod+Shift+minus . "move container to workspace number 6")
    ($mod+Shift+egrave . "move container to workspace number 7")
    ($mod+Shift+underscore . "move container to workspace number 8")
    ($mod+Shift+ccedilla . "move container to workspace number 9")
    ($mod+Shift+agrave . "move container to workspace number 10")
    ($mod+b . "splith")
    ($mod+v . "splitv")
    ($mod+s . "layout stacking")
    ($mod+w . "layout tabbed")
    ($mod+e . "layout toggle split")
    ($mod+f . "fullscreen")
    ($mod+Shift+space . "floating toggle")
    ($mod+space . "focus mode_toggle")
    ($mod+z . "focus parent")
    ($mod+Shift+o . "move scratchpad")
    ($mod+o . "scratchpad show")
    ($mod+r . "mode \"resize\"")
    ($mod+Shift+n . "bar mode toggle")
    ($mod+Shift+b . "border toggle")
    ($mod+tab . "workspace back_and_forth")))

\f
;;;
;;; Definition of configurations.
;;;

(define (list-of-string-or-gexp? lst)
  (every (lambda (elt)
           (or (string? elt)
               (gexp? elt)))
         lst))

(define (list-of-packages? lst)
  (every package? lst))

(define (bar-position? p)
  (member p '(top bottom)))

(define (hidden-state? st)
  (member st '(hide show)))

(define (string-or-symbol? s)
  (or (string? s)
      (symbol? s)))

(define (strings? lst)
  (every string? lst))

(define-maybe string (no-serialization))
(define-maybe strings (no-serialization))

(define-configuration/no-serialization sway-input
  (identifier
   (string-or-symbol '*)
   "Identifier of the input.")
  (xkb-layout
   maybe-string
   "Keyboard layout.")
  (xkb-model
   maybe-string
   "Keyboard model.")
  (xkb-options
   maybe-strings
   "Keyboard options.")
  (xkb-variant
   maybe-string
   "Keyboard layout variant.")
  (extra-content
   (list-of-string-or-gexp '())
   "Lines to add at the end of the configuration file."))

(define (sway-inputs? lst)
  (every sway-input? lst))

(define-configuration/no-serialization sway-border-color
  (border
   string
   "Border color.")
  (background
   string
   "Background color.")
  (text
   string
   "Text color."))

(define-maybe sway-border-color (no-serialization))

(define-configuration/no-serialization sway-color
  (background
   maybe-string
   "Background color of the bar.")
  (statusline
   maybe-string
   "Text color of the separator.")
  (focused-background
   maybe-string
   "Background color of the bar on the currently focused monitor.")
  (focused-statusline
   maybe-string
   "Text color of the statusline on the currently focused monitor.")
  (focused-workspace
   maybe-sway-border-color
   "...")
  (active-workspace
   maybe-sway-border-color
   "...")
  (inactive-workspace
   maybe-sway-border-color
   "...")
  (urgent-workspace
   maybe-sway-border-color
   "...")
  (binding-mode
   maybe-sway-border-color
   "..."))

(define-maybe sway-color (no-serialization))

(define-configuration/no-serialization sway-bar
  (identifier
   (symbol 'bar0)
   "Identifier of the bar.")
  (position
   (bar-position 'top)
   "Position of the bar.")
  (hidden-state
   (hidden-state 'hide)
   "Hidden state.")
  (binding-mode-indicator
   (boolean #t)
   "Binding indicator.")
  (colors
   maybe-sway-color
   "Color palette of the bar.")
  (status-command
   (file-like
    (program-file
     "sway-bar-status"
     (with-imported-modules
         (source-module-closure
          '((ice-9 textual-ports) (ice-9 regex) (ice-9 popen) (ice-9 format)
            (srfi srfi-19)))
       #~(begin
           (use-modules (ice-9 textual-ports)
                        (ice-9 format)
                        (ice-9 popen)
                        (ice-9 regex)
                        (srfi srfi-19))
           (let loop ()
             (let* ((date (date->string (current-date) "~a ~D ~H:~M:~S"))
                    (batline (let* ((p (open-pipe*
                                        OPEN_READ
                                        #$(file-append acpi "/bin/acpi") "-b"))
                                    (bat (get-line p)))
                               (close-pipe p)
                               bat))
                    (bat (match:substring (string-match "[0-9]+%" batline))))
               (format #t "~a - ~a~%~!" bat date)
               (sleep 1)
               (loop)))))))
    "Status command.  It must be file-like."))

(define-configuration/no-serialization point
  (x integer "X coordinate.")
  (y integer "Y coordinate."))

(define-maybe point (no-serialization))
(define-maybe file-like (no-serialization))

(define-configuration/no-serialization sway-output
  (identifier
   (string-or-symbol '*)
   "Identifier of the output.")
  (resolution
   maybe-string
   "Mode of the monitor.")
  (position
   maybe-point
   "Position of the monitor.")
  (bg
   maybe-file-like
   "Background image.")
  (extra-content
   (list-of-string-or-gexp '())
   "Extra lines."))

(define (sway-outputs? lst)
  (every sway-output? lst))

(define-configuration/no-serialization sway-configuration
  (keybindings
   (alist %sway-default-keybindings)
   "Keybindings.")
  (gestures
   (alist %sway-default-gestures)
   "Gestures.")
  (packages
   (list-of-packages
    (list sway swaylock waybar swaybg slurp grim dmenu bemenu
          dbus xdg-desktop-portal-wlr xdg-desktop-portal))
   "List of packages to add to the profile.")
  (variables
   (alist %sway-default-variables)
   "Variables declared at the beginning of the file.")
  (inputs
   (sway-inputs (list (sway-input)))
   "Inputs.")
  (outputs
   (sway-outputs '())
   "Outputs.")
  (bar
   (sway-bar (sway-bar))
   "Bar configuration.")
  (execs
   (list-of-string-or-gexp '())
   "Programs to execute at startup time.")
  (extra-content
   (list-of-string-or-gexp '())
   "Lines to add at the end of the configuration file."))

\f
;;;
;;; Serialization functions.
;;;

(define (serialize-keybinding var)
  (let ((name (symbol->string (car var)))
        (value (cdr var)))
    #~(string-append "bindsym " #$name " " #$value)))

(define (serialize-gesture var)
  (let ((name (symbol->string (car var)))
        (value (cdr var)))
    #~(string-append "bindgesture " #$name " " #$value)))

(define (serialize-variable var)
  (let ((name (symbol->string (car var)))
        (value (cdr var)))
    #~(string-append "set $" #$name " " #$value)))

(define (serialize-exec exe)
  #~(string-append "exec " #$exe))

(define (serialize-output out)
  (let* ((pre-ident (sway-output-identifier out))
         (ident (if (symbol? pre-ident)
                    (symbol->string pre-ident)
                    (string-append "\"" pre-ident "\"")))
         (bg (sway-output-bg out))
         (resolution (sway-output-resolution out))
         (position (sway-output-position out))
         (extra-content (sway-output-extra-content out)))
    (append
     (filter
      (lambda (elt) (not (eq? elt %unset-value)))
      (list
       ;; Beginning of the block.
       #~(string-append "output " #$ident " {")
       ;; Optional elements.
       (if (eq? %unset-value bg)
           %unset-value
           #~(string-append "    bg " #$bg " fill"))
       (if (eq? %unset-value resolution)
           %unset-value
           (string-append "    resolution " resolution))
       (if (eq? %unset-value position)
           %unset-value
           (string-append "    position " (number->string (point-x position))
                          " " (number->string (point-y position))))))
       extra-content
       ;; End of the block.
       '("}"))))

(define-inlinable (add-line-if prefix value)
  (if (eq? %unset-value value)
      %unset-value
      (string-append prefix " " value)))

(define (serialize-input input)
  (let* ((pre-ident (sway-input-identifier input))
         (ident (if (symbol? pre-ident)
                    (symbol->string pre-ident)
                    (string-append "\"" pre-ident "\"")))
         (xkb-layout (sway-input-xkb-layout input))
         (xkb-model (sway-input-xkb-model input))
         (xkb-variant (sway-input-xkb-variant input))
         (xkb-options (sway-input-xkb-options input)))
    (append
     (filter
      (lambda (elt) (not (eq? elt %unset-value)))
      (list
       (string-append "input " ident " {")
       ;; Optional.
       (add-line-if "    xkb_layout" xkb-layout)
       (add-line-if "    xkb_model" xkb-model)
       (add-line-if "    xkb_variant" xkb-variant)
       (if (eq? %unset-value xkb-options)
           %unset-value
           (string-concatenate (cons "    xkb_options " xkb-options)))))
     (map (lambda (s)
            (string-append (string-pad "" 4) s))
          (sway-input-extra-content input))
     '("}"))))

(define (serialize-colors colors)
  (define (add-border-color-if name val)
    (if (eq? %unset-value val)
        %unset-value
        (string-append
         name
         " " (sway-border-color-border val)
         " " (sway-border-color-background val)
         " " (sway-border-color-text val))))
  (let ((background (sway-color-background colors))
        (statusline (sway-color-statusline colors))
        (focused-background (sway-color-focused-background colors))
        (focused-statusline (sway-color-focused-statusline colors))
        (focused-workspace (sway-color-focused-workspace colors))
        (active-workspace (sway-color-active-workspace colors))
        (inactive-workspace (sway-color-inactive-workspace colors))
        (urgent-workspace (sway-color-urgent-workspace colors))
        (binding-mode (sway-color-binding-mode colors)))
    (filter
     (lambda (elt) (not (eq? elt %unset-value)))
     (list
      (add-line-if "background" background)
      (add-line-if "statusline" statusline)
      (add-line-if "focused_background" focused-background)
      (add-line-if "focused_statusline" focused-statusline)
      (add-border-color-if "focused_workspace" focused-workspace)
      (add-border-color-if "active_workspace" active-workspace)
      (add-border-color-if "inactive_workspace" inactive-workspace)
      (add-border-color-if "urgent_workspace" urgent-workspace)
      (add-border-color-if "binding_mode" binding-mode)))))

(define (make-sway-config conf)
  (let* ((extra (sway-configuration-extra-content conf))
         (bar (sway-configuration-bar conf)))

    (with-imported-modules
        (source-module-closure
         '((ice-9 popen) (ice-9 match) (ice-9 format) (guix monads)))
      (computed-file
       "sway-config"
       #~(begin
           (use-modules (ice-9 format) (ice-9 popen) (ice-9 match)
                        (guix monads))
           ;; Helper functions to pretty-print the configuration file.
           (define (line s)
             (lambda (port)
               (lambda (i)
                 (format port "~a~a~%" (string-pad "" i) s)
                 (values port i))))
           (define (lines lst)
             (lambda (port)
               (lambda (i)
                 (let loop ((l lst))
                   (match l
                     (() #t)
                     ((head . tail)
                      (format port "~a~a~%" (string-pad "" i)
                              (if (list? head)
                                  (string-concatenate head)
                                  head))
                      (loop tail))))
                 (values port i))))
           (define-syntax line*
             (syntax-rules ()
               ((line* elt ...)
                (lines (list elt ...)))))
           (define-syntax line2
             (syntax-rules ()
               ((line2 a b)
                (line (string-append a b)))))
           (define (indent k)
             (lambda (port)
               (lambda (i)
                 (values port (+ i k)))))
           (define (begin-block name)
             (lambda (port)
               (lambda (i)
                 (format port "~a~a {~%" (string-pad "" i) name)
                 (values port (+ i 4)))))
           (define (end-block)
             (lambda (port)
               (lambda (i)
                 (let ((i (- i 4)))
                   (format port "~a}~%" (string-pad "" i))
                   (values port i)))))

           (let* ((file #$output)
                  (port (open-output-file #$output)))
             ;; The previous iteration of this work computed the content of the
             ;; configuration file as a string.  The state monad was used to
             ;; keep track of the state during the computation.
             ;; However, this first approach was too expensive.  Now that I use
             ;; `computed-file', the "computed value" is the constant port to
             ;; which I write.  Thus, using the state monad is overkill here.
             ;; It can be replaced by the identity monad, where the value being
             ;; passed around is the pair of `port' and the indentation level.
             (run-with-state
                 (with-monad
                     %state-monad
                   (>>= (return port)
                        ;; Header of the configuration file.
                        (line*
                         "#####################################"
                         "### Auto-generated configuration. ###"
                         "#####################################"
                         "# DO NOT EDIT MANUALLY." "")
                        (line*
                         "# Variables."
                         "# =========="
                         #$@(map serialize-variable
                                 (sway-configuration-variables conf)) "")
                        (line*
                         "# Outputs."
                         "# ========"
                         #$@(flatten
                             (map serialize-output
                                  (sway-configuration-outputs conf))) "")
                        (line*
                         "# Inputs."
                         "# ======="
                         #$@(flatten
                             (map serialize-input
                                  (sway-configuration-inputs conf))) "")
                        (line* "# Bar configuration."
                               "# ==================")
                        (begin-block
                         (string-append
                          "bar " #$(symbol->string
                                    (sway-bar-identifier bar))))
                        (line2 "position " #$(symbol->string
                                              (sway-bar-position bar)))
                        (line2 "hidden_state "
                               #$(symbol->string
                                  (sway-bar-hidden-state bar)))
                        (line2 "status_command "
                               #$(sway-bar-status-command bar))
                        (line2 "binding_mode_indicator "
                               #$(if (sway-bar-binding-mode-indicator bar)
                                     "true" "false"))
                        (begin-block "colors")
                        (line*
                         #$@(serialize-colors (sway-bar-colors bar)))
                        (end-block) ;; colors
                        (end-block) ;; bar
                        (line*
                         "" "# Extra configuration content."
                         "# ============================"
                         #$@extra "")
                        (line*
                         "# Keybindings."
                         "# ============"
                         #$@(map serialize-keybinding
                                 (sway-configuration-keybindings conf))
                         "")
                        (line*
                         "# Gestures."
                         "# ========="
                         #$@(map serialize-gesture
                                 (sway-configuration-gestures conf)) "")
                        (line*
                         "# Programs to execute."
                         "# ===================="
                         #$@(map serialize-exec
                                 (sway-configuration-execs conf)))))
               0)))))))

(define (sway-configuration->file sway-conf)
  `((".config/sway/config"
     ,(make-sway-config
       sway-conf))))

(define home-sway-service-type
  (service-type
   (name 'home-sway-config)
   (extensions
    (list (service-extension home-files-service-type
                             sway-configuration->file)
          (service-extension home-profile-service-type
                             sway-configuration-packages)))
   (description "Configure Sway by providing a file
@file{~/.config/sway/config}.")
   (default-value (sway-configuration))))