(define-module (oms home services gnome)
  #:use-module (gnu home services)
  #:use-module (gnu home services shepherd)
  #:use-module (gnu packages glib)
  #:use-module (gnu packages gnome)
  #:use-module (gnu services configuration)
  #:use-module ((guix diagnostics) #:select (warning))
  #:use-module (guix gexp)
  #:use-module (guix i18n)
  #:use-module (ice-9 match)
  #:use-module (ice-9 string-fun)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:export (home-gsettings-configuration
            home-gsettings-configuration?
            home-gsettings-configuration-reset?
            home-gsettings-configuration-schemas

            gsettings-schema
            gsettings-schema?
            gsettings-schema-name
            gsettings-schema-settings

            raw-gvariant
            raw-gvariant?
            raw-gvariant-value

            home-gsettings-service-type))

(define-immutable-record-type <raw-gvariant>
  (raw-gvariant value)
  raw-gvariant?
  (value raw-gvariant-value))

(define (gvariant-association-list? x)
  (match x
    ((((? string?) . (? gvariant-printable?)) ...) #t)
    (_ #f)))

(define (list-of-gsettings-schemas? x)
  (and (list? x)
       ;; TODO who does this not work???
       ;(every (lambda (x) ((gsettings-schema? x))) x)
       ))

(define-configuration/no-serialization home-gsettings-configuration
  (reset?
   (boolean #t)
   "Whether to reset all undeclared GSettings to default values.  Resetting
ensures the configuration is declarative but makes it impossible to modify
settings persistently from any application's user interface.")
  (schemas
   (list-of-gsettings-schemas '())
   "The declared GSettings configuration values."))

(define-configuration/no-serialization gsettings-schema
  (name
   string
   "The identifier of the GSettings schema.  For example \"org.gnome.desktop.background\".")
  (settings
   (gvariant-association-list)
   "Keys and values to set in this schema."))

(define* (group lst #:key (similar? equal?))
  "Returns a list of non-empty lists such that all the values in each sublist
are SIMILAR? to it's first one."
  (match lst
    ((head _ ...)
     (let-values (((similar different)
                   (partition (cut similar? head <>) lst)))
       (cons similar (group different #:similar? similar?))))
    (() '())))

(define (equal?-under view)
  (lambda (x y)
    (equal? (view x)
            (view y))))

(define (gvariant-printable? x)
  (or (boolean? x)
      (string? x)
      (file-like? x)
      (number? x)
      (and (list? x)
           (every gvariant-printable? x))
      (raw-gvariant? x)))

(define (serialize-gvariant value)
  "Serialize VALUE to a string in GVariant text format or to a G-expression
that expands to an expression that evaluates to such a string."
  (match value
    ((or (? string?)
         (? file-like?))
     #~(begin
         (use-modules (ice-9 string-fun))
         (format #f "'~a'"
                 (string-replace-substring
                  (string-replace-substring #$value "\\" "\\\\")
                  "'" "\\'"))))
    ((? boolean?)
     (if value "true" "false"))
    ((? number?)
     (format #f "~a" value))
    ((? raw-gvariant? (= raw-gvariant-value raw-value))
     raw-value)
    (((? gvariant-printable? lst) ...)
     #~(format #f "[~a]" (string-join (list #$@(map serialize-gvariant lst)) ", ")))))

(define (home-gsettings-configuration->setting-list config)
  "Convert a home-gsettings-configuration record into a list-based format with
serialized values.  If the same key is set multiple times in the same schema, a
warning is raised and the leftmost value used."
  (define (serialize-keyvals keyvals)
    (match keyvals
      (((key . value))
       #~(list #$key #$(serialize-gvariant value)))
      (((key . value) (_ . ignored) ...)
       (warning (G_ "Multiple values set for GSetting key '~a ~a'! \
Using '~a' and ignoring the rest ~a.")
                schema-name key value ignored)
       #~(list #$key #$(serialize-gvariant value)))))
  (define (merge-schemas schemas)
    (let ((schema-name (gsettings-schema-name (car schemas))))
      #~(list #$schema-name
              #$@(map serialize-keyvals
                      (group (append-map gsettings-schema-settings schemas)
                             #:similar? (equal?-under car))))))
  #~(list
     #$@(map merge-schemas
             (group (home-gsettings-configuration-schemas config)
                    #:similar? (equal?-under gsettings-schema-name)))))

(define (extend-gsettings config extension-schemas)
  (home-gsettings-configuration
    (inherit config)
    (schemas
     ;; Leftmost values are preferred so instantiation overrides extensions
     (append (home-gsettings-configuration-schemas config)
             extension-schemas))))

(define (make-gsettings-script config)
  (program-file
   "set-gsettings"
   (with-imported-modules '((guix build utils))
     #~(begin
         (use-modules (guix build utils)
                      (ice-9 match))
         ;; Pass options via the environment to allow reusing this script
         (when #$(home-gsettings-configuration-reset? config)
           (invoke #$(file-append dconf "/bin/dconf") "reset" "-f" "/"))
         (match #$(home-gsettings-configuration->setting-list config)
           ((((? string? schemas) keyvals ...) ...)
            (map (lambda (schema keyvals)
                   (map (match-lambda
                          ((key value)
                           (invoke #$(file-append (gexp-input glib "bin")
                                                  "/bin/gsettings")
                                   "set" schema key value)))
                        keyvals))
                 schemas keyvals)))))))

(define (home-gsettings-shepherd-services config)
  (list
   (shepherd-service
     (documentation "Sets declared GSettings configuration values.")
     (provision '(gsettings))
     (one-shot? #t)
     (start #~(make-forkexec-constructor
               (list #$(make-gsettings-script config)))))))

(define home-gsettings-service-type
  (service-type
    (name 'home-gsettings)
    (extensions
      (list (service-extension home-shepherd-service-type
                               home-gsettings-shepherd-services)))
    (compose concatenate)
    (extend extend-gsettings)
    (default-value
     (home-gsettings-configuration
       ;; If the user has not added the service to their home configuration
       ;; themselves, they probably don't want it to reset their settings when
       ;; another service extends it.
       (reset? #f)))
    (description "Declare values for GSettings configuration settings used by GNOME.")))