;;; 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 (;; Event codes
            %ev-code-mouse-left
            %ev-code-mouse-right
            %ev-code-mouse-scroll-click

            ;; Configuration records.
            sway-configuration
            sway-bar
            sway-output
            sway-input
            point
            sway-color
            sway-border-color
            home-sway-service-type
            sway-configuration->file
            sway-mode

            ;; Default values.
            %sway-default-variables
            %sway-default-gestures
            %sway-default-keybindings
            %sway-default-status-command
            %sway-default-execs))

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

\f
;;;
;;; Default settings and useful constants.
;;;

(define %ev-code-mouse-left 272)
(define %ev-code-mouse-right 273)
(define %ev-code-mouse-scroll-click 274)

(define %sway-default-variables
  `((mod   . "Mod4")
    (left  . "h")
    (down  . "j")
    (up    . "k")
    (right . "l")
    (term  . ,(file-append st "/bin/st"))
    (menu  . ,#~(string-append
                 #$dmenu "/bin/dmenu_path | "
                 #$wmenu "/bin/wmenu | "
                 #$findutils "/bin/xargs "
                 #$sway "/bin/swaymsg exec --"))))

(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")))

(define %sway-default-keybindings
  `(($mod+Return . "exec $term")
    ($mod+Shift+q . "kill")
    ($mod+d . "exec $menu")
    ($mod+Shift+c . "reload")
    ($mod+Shift+e
     . ,#~(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' '"
           #$sway "/bin/swaymsg exit'"))
    ($mod+$left . "focus left")
    ($mod+$down . "focus down")
    ($mod+$up . "focus up")
    ($mod+$right . "focus right")
    ($mod+Left . "focus left")
    ($mod+Down . "focus down")
    ($mod+Up . "focus up")
    ($mod+Right . "focus right")
    ($mod+Shift+$left . "move left")
    ($mod+Shift+$down . "move down")
    ($mod+Shift+$up . "move up")
    ($mod+Shift+$right . "move right")
    ($mod+Shift+Left . "move left")
    ($mod+Shift+Down . "move down")
    ($mod+Shift+Up . "move up")
    ($mod+Shift+Right . "move right")
    ($mod+1 . "workspace number 1")
    ($mod+2 . "workspace number 2")
    ($mod+3 . "workspace number 3")
    ($mod+4 . "workspace number 4")
    ($mod+5 . "workspace number 5")
    ($mod+6 . "workspace number 6")
    ($mod+7 . "workspace number 7")
    ($mod+8 . "workspace number 8")
    ($mod+9 . "workspace number 9")
    ($mod+0 . "workspace number 10")
    ($mod+Shift+1 . "move container to workspace number 1")
    ($mod+Shift+2 . "move container to workspace number 2")
    ($mod+Shift+3 . "move container to workspace number 3")
    ($mod+Shift+4 . "move container to workspace number 4")
    ($mod+Shift+5 . "move container to workspace number 5")
    ($mod+Shift+6 . "move container to workspace number 6")
    ($mod+Shift+7 . "move container to workspace number 7")
    ($mod+Shift+8 . "move container to workspace number 8")
    ($mod+Shift+9 . "move container to workspace number 9")
    ($mod+Shift+0 . "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+a . "focus parent")
    ($mod+Shift+minus . "move scratchpad")
    ($mod+minus . "scratchpad show")
    ($mod+r . "mode \"resize\"")))

(define %sway-default-status-command
  "while date +'%Y-%m-%d %X'; do sleep 1; done")

(define %sway-default-execs
  (list
   #~(string-append
      #$swayidle "/bin/swayidle -w \\\n"
      ;; 300: lock screen.
      "    timeout 300 '" #$swaylock "/bin/swaylock "
      "--indicator-radius 75 "
      "-i " #$sway "/share/backgrounds/sway/Sway_Wallpaper_Blue_1920x1080.png"
      " -f -c 000000' \\\n"
      ;; 600: lock + screen off.
      "    timeout 600 '" #$sway "/bin/swaymsg \"output * power off\"' \\\n"
      ;; Resume + sleep.
      "    resume '" #$sway "/bin/swaymsg \"output * power on\"' \\\n"
      "    before-sleep '" #$swaylock "/bin/swaylock -f -c 000000'")))

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

(define (string-ish? s)
  (or (gexp? s)
      (file-append? s)
      (string? s)))

(define (list-of-string-ish? lst)
  (every string-ish? 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 (make-alist-predicate key? val?)
  (lambda (lst)
    (every
     (lambda (item)
       (match item
         ((k . v)
          (and (key? k)
               (val? v)))
         (_ #f)))
     lst)))

(define bindings?
  (make-alist-predicate symbol? string-ish?))

(define mouse-bindings?
  (make-alist-predicate integer? string-ish?))

(define (variables? lst)
  (make-alist-predicate symbol? string-ish?))

(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
   (strings '())
   "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
   "Colour scheme for focused workspaces.")
  (active-workspace
   maybe-sway-border-color
   "Colour scheme for active workspaces.")
  (inactive-workspace
   maybe-sway-border-color
   "Colour scheme for inactive workspaces.")
  (urgent-workspace
   maybe-sway-border-color
   "Colour scheme for workspaces containing `urgent' windows.")
  (binding-mode
   maybe-sway-border-color
   "Colour scheme for the binding mode indicator."))

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

(define (status-command? c)
  (or (string? c)
      (file-like? c)
      (gexp? c)))

(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
   (status-command %sway-default-status-command)
   "Status command.  It must be file-like.")
  (keybindings
   (bindings '())
   "Keybindings.")
  (mouse-bindings
   (mouse-bindings '())
   "Actions triggered by mouse events.")
  (extra-content
   (list-of-string-ish '())
   "Extra configuration lines."))

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

(define (file-like-or-gexp? f)
  (or (file-like? f)
      (gexp? f)))

(define-maybe point (no-serialization))
(define-maybe file-like-or-gexp (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-or-gexp
   "Background image.")
  (extra-content
   (list-of-string-ish '())
   "Extra lines."))

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

(define-configuration/no-serialization sway-mode
  (mode-name
   (string "default")
   "Name of the mode.")
  (keybindings
   (bindings '())
   "Keybindings.")
  (mouse-bindings
   (mouse-bindings '())
   "Mouse bindings."))
;; TODO: switch bindings.

(define (sway-modes? lst)
  (every sway-mode? lst))

(define-configuration/no-serialization sway-configuration
  (keybindings
   (bindings %sway-default-keybindings)
   "Keybindings.")
  (gestures
   (bindings %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
   (variables %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.")
  (modes
   (sway-modes '())
   "Additional modes.")
  (always-execs
   (list-of-string-ish '())
   "Programs to execute at startup time.")
  (execs
   (list-of-string-ish %sway-default-execs)
   "Programs to execute at startup time.")
  (extra-content
   (list-of-string-ish '())
   "Lines to add at the end of the configuration file."))

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

(define (serialize-mouse-binding var)
  (let ((ev-code (number->string (car var)))
        (command (cdr var)))
    #~(string-append "bindcode " #$ev-code " " #$command)))

(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 b)
  (if b
      (lambda (exe)
        #~(string-append "exec_always " #$exe))
      (lambda (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))))))
     (map
      (lambda (s)
        #~(string-append "    " #$s))
      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-append "    xkb_options "
                          (string-join 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))))
  (if (eq? %unset-value colors)
      '()
      (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 (serialize-sway-mode mode)
  (let ((name (sway-mode-mode-name mode))
        (keys (sway-mode-keybindings mode))
        (clicks (sway-mode-mouse-bindings mode))
        (serialize-keybinding
         (lambda (kbd)
           #~(string-append "    " #$(serialize-keybinding kbd))))
        (serialize-mouse-binding
         (lambda (kbd)
           #~(string-append "    " #$(serialize-mouse-binding kbd)))))
    (append
     (list (string-append "mode \"" name "\" {"))
     (map serialize-keybinding keys)
     (map serialize-mouse-binding clicks)
     '("}"))))

(define (sway-configuration->file 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))

           (let* ((file #$output)
                  (port (open-output-file #$output)))

             ;; Helper functions to pretty-print the configuration file.
             (define (line s)
               (lambda (i)
                 (format port "~a~a~%" (string-pad "" i) s)
                 i))
             (define (lines lst)
               (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))))
                 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 (i)
                 (+ i k)))
             (define (begin-block name)
               (lambda (i)
                 (format port "~a~a {~%" (string-pad "" i) name)
                 (+ i 4)))
             (define (end-block)
               (lambda (i)
                 (let ((i (- i 4)))
                   (format port "~a}~%" (string-pad "" i))
                   i)))

             ;; The value that is threaded in the following block is the
             ;; indentation level.
             (with-monad %identity-monad
               (>>=
                ;; We start with no indentation at all.
                (return 0)
                ;; 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
                (line*
                 #$@(map serialize-keybinding
                         (sway-bar-keybindings bar)))
                (line*
                 #$@(map serialize-mouse-binding
                         (sway-bar-mouse-bindings bar)))
                (line*
                 #$@(sway-bar-extra-content bar))
                (end-block) ;; bar
                (line*
                 "" "# Modes." "# ======"
                 #$@(flatten
                     (map serialize-sway-mode
                          (sway-configuration-modes conf))))
                (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. (at startup & after reloads)"
                 "# ===================="
                 #$@(map (serialize-exec #t)
                         (sway-configuration-always-execs conf)))
                (line*
                 "" "# Programs to execute. (at startup)"
                 "# ===================="
                 #$@(map (serialize-exec #f)
                         (sway-configuration-execs conf)))))))))))

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

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