;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2022 ( <paren@disroot.org>
;;; Copyright © 2023 David Wilson <david@daviwil.com>
;;;
;;; 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 emacs)
  #:use-module (gnu home services)
  #:autoload   (gnu packages emacs) (emacs-minimal
                                     emacs)
  #:use-module (gnu services configuration)
  #:use-module (guix gexp)
  #:use-module (guix packages)
  #:use-module (guix records)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)

  #:export (emacs-variables
            home-emacs-configuration
            home-emacs-extension
            home-emacs-service-type))

(define list-of-file-likes?
  (list-of file-like?))

(define (string-or-file-like? val)
  (or (string? val)
      (file-like? val)))

(define list-of-string-or-file-likes?
  (list-of string-or-file-like?))

(define-configuration/no-serialization home-emacs-configuration
  (emacs
   (file-like emacs)
   "The package providing the @file{/bin/emacs} command.")
  (packages
   (list-of-file-likes '())
   "Additional packages required by the Emacs configuration.")
  (user-emacs-directory
   (string "~/.cache/emacs")
   "Directory beneath which additional per-user Emacs-specific files are placed.")
  (init-file
   (text-config '())
   "Configuration text or files to include in init.el.")
  (early-init-file
   (text-config '())
   "Configuration text or files to include in early-init.el.")
  (load-paths
   (list-of-string-or-file-likes '())
   "Additional load paths to add to Emacs' @code{load-path} variable.  Lines
will be inserted at the beginning of early-init.el.")
  (native-compile?
   (boolean #f)
   "Whether to compile the @code{packages} using the Emacs package
provided as the value of the @code{emacs} field, which will enable
native compilation if the @code{emacs} package supports it."))

(define (home-emacs-profile-packages config)
  (cons (home-emacs-configuration-emacs config)
        (home-emacs-configuration-packages config)))

(define (home-emacs-transformed-packages config)
  (map (if (home-emacs-configuration-native-compile? config)
           (package-input-rewriting
            `((,emacs-minimal
              . ,(home-emacs-configuration-emacs config))))
           identity)
       (let ((packages (home-emacs-configuration-packages config)))
         (concatenate
          (cons packages
                (map (compose (cute map second <>)
                              package-transitive-propagated-inputs)
                     packages))))))

(define (serialize-emacs-load-paths config)
  #~(string-append
     ";; Additional load paths\n"
     #$@(map (lambda (load-path)
               #~(format #f "(add-to-list 'load-path \"~a\")" #$load-path))
             (home-emacs-configuration-load-paths config))
     "\n\n"))

(define (serialize-emacs-user-directory config)
  (format #f
          ";; Set the `user-emacs-directory` to a writeable path\n(setq user-emacs-directory \"~a\")\n\n"
          (home-emacs-configuration-user-emacs-directory config)))

(define (home-emacs-xdg-configuration-files config)
  `(("emacs/early-init.el"
     ,(apply mixed-text-file
             (cons* "early-init.el"
                    (serialize-emacs-load-paths config)
                    (serialize-emacs-user-directory config)
                    (home-emacs-configuration-early-init-file config))))
    ("emacs/init.el"
     ,(apply mixed-text-file
             (cons "init.el"
                   (home-emacs-configuration-init-file config))))))

(define-configuration/no-serialization home-emacs-extension
  (packages
   (list-of-file-likes '())
   "Additional packages required by the Emacs configuration.")
  (init-file
   (text-config '())
   "Configuration text or files to include in init.el.")
  (early-init-file
   (text-config '())
   "Configuration text or files to include in early-init.el.")
  (load-paths
   (list-of-string-or-file-likes '())
   "Additional load paths to add to Emacs' @code{load-path} variable.  Lines
will be inserted at the beginning of early-init.el."))

(define (home-emacs-extensions original-config extension-configs)
  (match-record original-config <home-emacs-configuration>
    (packages load-paths init-file early-init-file)
    (home-emacs-configuration
     (inherit original-config)
     (packages
      (append packages
              (append-map
               home-emacs-extension-packages extension-configs)))
     (init-file
      (append init-file
              (append-map
               home-emacs-extension-init-file extension-configs)))
     (early-init-file
      (append early-init-file
              (append-map
               home-emacs-extension-early-init-file extension-configs)))
     (load-paths
      (append load-paths
              (append-map
               home-emacs-extension-load-paths extension-configs))))))

(define home-emacs-service-type
  (service-type
   (name 'home-emacs)
   (extensions
    (list (service-extension
           home-profile-service-type
           home-emacs-profile-packages)
          (service-extension
           home-shepherd-service-type
           home-emacs-shepherd-services)
          (service-extension
           home-xdg-configuration-files-service-type
           home-emacs-xdg-configuration-files)))
   (default-value (home-emacs-configuration))
   (compose identity)
   (extend home-emacs-extensions)
   (description
    "Configure the GNU Emacs extensible text editor.")))

(define scheme-value->emacs-value
  (match-lambda (#t (quote 't))
                (#f (quote 'nil))
                (val val)))

(define (emacs-variables var-alist)
  "Converts an alist of variable names and values into a @code{setq}
expression that can be used in an Emacs configuration.  Scheme values
@code{#t} and @code{#f} will be converted into @code{t} and @code{nil},
respectively."
  #~(string-append
     "(setq"
     #$@(map (lambda (var)
               #~(format #f "\n  ~a ~s"
                         (quote #$(car var))
                         #$(scheme-value->emacs-value (cdr var))))
             var-alist)
     ")\n\n"))