;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2023 Kierin Bell <fernseed@fernseed.me>
;;;
;;; 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 (tests home services emacs)
  #:use-module (gnu home services emacs)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix gexp)
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module (guix tests)
  #:use-module (guix read-print)
  #:use-module (gnu packages guile)
  #:use-module (ice-9 textual-ports)
  #:use-module (srfi srfi-64))

(test-begin "emacs-home-services")

;;; Test `elisp' syntax

(test-equal "test `elisp' syntax, symbol"
  't
  (elisp->sexp (elisp t)))

(test-equal "test `elisp' syntax, basic list"
  '(a b c)
  (elisp->sexp (elisp (a b c))))

(test-equal "test `elisp' syntax, substitute symbol"
  'a
  (let ((foo 'a))
    (elisp->sexp (elisp (unelisp foo)))))

(test-equal "test `elisp' syntax, substitute splicing"
  '(a b c)
  (let ((foo '(a b c)))
    (elisp->sexp (elisp ((unelisp-splicing foo))))))

(test-equal "test `elisp' syntax, comment"
  (comment ";comment\n")
  (elisp->sexp (elisp (unelisp-comment ";comment\n"))))

(test-equal "test `elisp' syntax, nested comment"
  `(a ,(comment ";comment\n") b)
  (elisp->sexp (elisp (a (unelisp-comment ";comment\n") b))))

(test-equal "test `elisp' syntax, newline"
  (vertical-space 0)
  (elisp->sexp (elisp (unelisp-newline))))

(test-equal "test `elisp' syntax, page break"
  (page-break)
  (elisp->sexp (elisp (unelisp-page-break))))

(test-equal "elisp->sexp, nested <elisp> objects"
  '(a (b c))
  (elisp->sexp (elisp (a (unelisp (elisp (b (unelisp (elisp c)))))))))

;;; Test #% reader extension

(test-equal "test hash extension, symbol"
  't
  (elisp->sexp #%t))

(test-equal "test hash extension, basic list"
  '(a b c)
  (elisp->sexp #%(a b c)))

(test-equal "test hash extension, dotted list"
  '(a . b)
  (elisp->sexp #%(a . b)))

(test-equal "test hash extension, substitute symbol"
  'a
  (let ((foo 'a))
    (elisp->sexp #%#$foo)))

(test-equal "test hash extension, substitute splicing"
  '(a b c)
  (let ((foo '(a b c)))
    (elisp->sexp #%(#$@foo))))

(test-equal "test hash extension, basic vector"
  #(a b c)
  (elisp->sexp #%[a b c]))

(test-equal "test hash extension, basic character"
  #\a
  (elisp->sexp #%?a))

(test-equal "test hash extension, comment"
  (elisp->sexp (elisp (unelisp-comment ";comment\n")))
  (elisp->sexp #%#;comment
               ))

(test-equal "test hash extension, nested comment"
  (elisp->sexp (elisp (a (unelisp-comment ";comment\n") b)))
  (elisp->sexp #%(a #;comment
                  b)))

(test-equal "test hash extension, page break"
  (elisp->sexp (elisp (unelisp-newline)))
  (elisp->sexp #%#>))

(test-equal "test hash extension, page break"
  (elisp->sexp (elisp (unelisp-page-break)))
  (elisp->sexp #%#^L))

(test-equal "test hash extension, nested"
  '(a (b c))
  (elisp->sexp #%(a #$#%(b #$#%c))))

;;; Test home Emacs service configuration

(define (input->home-emacs-configuration . x)
  (apply (@@ (gnu home services emacs) input->home-emacs-configuration) x))

(define (home-emacs-configuration->code . x)
  (apply (@@ (gnu home services emacs) home-emacs-configuration->code) x))

(define-syntax-rule (test-import-emacs-configuration str config)
  "Test equality of `home-emacs-configuration' generated from Elisp string STR
with record CONFIG"
  (test-equal "test Emacs home configuration import "
    (home-emacs-configuration->code (call-with-input-string str
                                      input->home-emacs-configuration))
    (home-emacs-configuration->code config)))

(test-import-emacs-configuration
 "(setq my--foo 1)
(setq my--bar 'symbol)
(setq my--baz (list 'a ;comment
		    'b 'c))
(setq my--quux '(a b . c))
(setq my--quuux #'my--fun)
(setopt foo-var my--foo)

(foo-mode -1)
(bar-mode 1)
(baz-mode)
(quux-mode my--foo)


(bind-key* \"M-<up>\" 'scroll-down-line)
(bind-key* \"M-<down>\" 'scroll-up-line t)
;;; Top-level comment
(global-set-key (kbd \"C-c b\") 'bar)
(global-set-key [remap bar] 'baz)
(keymap-global-set \"C-c v\" 'quux)
(bind-key \"C-c c\" 'quuux)
(bind-key [t] #'quuuux 'global-map t)

(use-package foo
  :demand t
  ;; Inconvenient comment
  :hook prog-mode
  :custom
  (foo-bar 'baz)
  (foo-baz baz)
  :init
  ;; Ding
  (ding)

  (message \"Ding\"))

(use-package bar
  :if (eq system-type 'gnu/linx)
  :after foo
  :load-path \"~/src/bar\"
  :autoload bar-internal
  :commands bar-status bar
  :bind* ((\"C-x n\" . bar-status))
  :bind ((\"C-c n\" . bar)
	 :map bar-mode
	 (\"C-@\" . bar-bar)
	 :map bar-status-mode
	 (\"C-n\" . bar-next)
	 (\"C-c C-c\" . bar-do)
	 :repeat-map bar-repeat-map
	 (\"n\" . bar-next)
	 (\"c\" . bar-do))
  :bind-keymap (\"C-c b\" . bar-mode-map)
  :custom
  (bar-bool t)
  (bar-string \"bar\")
  (bar-list '(bar-1 bar-2 bar-3))
  (bar-list-2 `(,@bar-list bar-4))
  (bar-var my--foo)
  :custom-face
  (bar-face ((t (:slant italic))))
  (bar-highlight-face ((((class color) (background light))
			:background \"goldenrod1\")
		       (((class color) (background dark))
			:background \"DarkGoldenrod4\")
		       (t :inverse-video t)))
  :hook ((prog-mode foo-mode) . bar-mode)
  :mode \"\\\\.bar\\\\'\"
  :magic \">>BAR<<\"
  :magic-fallback \"<<BAR>>\"
  :config
  ;; Extra configuration
  (add-to-list 'bar-extensions 'foo-bar)
  :catch (lambda (_ _)
	   (message \"Error package initialization\")))

(use-package baz
  :unless (eq system-name \"bar\")
  :after (foo bar)
  :load-path (\"~/src/my/baz\" \"~/src/baz\")
  :autoload (baz-1 baz-2)
  :commands (baz)
  :custom
  ((baz-option t)
   (bar-list '((baz-1 . baz-2)))
   (baz-var my--foo))
  :hook ((prog-mode . baz-mode)
	 (bar-mode . baz-mode))
  :mode (\"\\\\.baz\\\\'\" . baz-mode)
  :magic (\">>BAZ<<\" \"!XXBAZXX\"))

(defun my--fun-1 (arg)
  arg)

(defun my--fun ()
  (prog1 (my--fun-1 'foo)
    (ding)))
"
 (home-emacs-configuration
 (default-init
   (emacs-configuration
     (variables `((my--foo . 1)
                  (my--bar . symbol)
                  (my--baz . ,(elisp (list 'a
                                           (unelisp-comment ";comment\n") 'b
                                           'c)))
                  (my--quux a b . c)
                  (my--quuux . ,(elisp (function my--fun)))
                  (foo-var . ,(elisp my--foo))))
     (modes `((foo-mode . #f)
              (bar-mode . #t)
              (baz-mode . #t)
              (quux-mode . ,(elisp my--foo))))
     (keys '(("C-c b" . bar)
             (#(remap bar) . baz)
             ("C-c v" . quux)
             ("C-c c" . quuux)
             (#(t) . quuuux)))
     (keys-override '(("M-<up>" . scroll-down-line)
                      ("M-<down>" . scroll-up-line)))
     (extra-init
       (list (elisp (defun my--fun-1
                           (arg) arg))
             (elisp (defun my--fun ()
                           (prog1 (my--fun-1 'foo)
                                  (ding))))))))
 (configured-packages
   (list (emacs-package
           (name 'foo)
           (load-force? #t)
           (options `((foo-bar . baz)
                      (foo-baz . ,(elisp baz))))
           (hooks '((prog-mode . foo-mode)))
           (extra-init
             (list (elisp (unelisp-comment ";; Ding\n"))
                   (elisp (ding))
                   (elisp (unelisp-newline))
                   (elisp (message "Ding")))))
         (emacs-package
           (name 'bar)
           (load-predicates (list (elisp (eq system-type 'gnu/linx))))
           (load-after-packages '(foo))
           (load-paths '("~/src/bar"))
           (autoloads '(bar-internal))
           (autoloads-interactive '(bar-status bar))
           (keys-global '(("C-c n" . bar)))
           (keys-global-keymaps '(("C-c b" . bar-mode-map)))
           (keys-override '(("C-x n" . bar-status)))
           (keys-local (list (emacs-keymap
                               (name 'bar-mode)
                               (keys '(("C-@" . bar-bar))))
                             (emacs-keymap
                               (name 'bar-status-mode)
                               (keys '(("C-n" . bar-next)
                                       ("C-c C-c" . bar-do))))
                             (emacs-keymap
                               (name 'bar-repeat-map)
                               (repeat? #t)
                               (keys '(("n" . bar-next)
                                       ("c" . bar-do))))))
           (options `((bar-bool . #t)
                      (bar-string . "bar")
                      (bar-list bar-1 bar-2 bar-3)
                      (bar-list-2 . ,(elisp `(,@bar-list bar-4)))
                      (bar-var . ,(elisp my--foo))))
           (faces '((bar-face (t (:slant italic)))
                    (bar-highlight-face (((class color)
                                          (background light))
                                         :background "goldenrod1")
                                        (((class color)
                                          (background dark))
                                         :background "DarkGoldenrod4")
                                        (t :inverse-video t))))
           (hooks '((prog-mode . bar-mode)
                    (foo-mode . bar-mode)))
           (auto-modes '(("\\.bar\\'" . bar)))
           (magic-modes '((">>BAR<<" . bar)))
           (extra-after-load
             (list (elisp (unelisp-comment ";; Extra configuration\n"))
                   (elisp (add-to-list 'bar-extensions 'foo-bar))))
           (extra-keywords
             `((:magic-fallback ,(elisp "<<BAR>>"))
               (:catch ,(elisp (lambda (_ _)
                                 (message "Error package initialization")))))))
         (emacs-package
           (name 'baz)
           (load-predicates (list (elisp (not (eq system-name "bar")))))
           (load-after-packages '(foo bar))
           (load-paths '("~/src/my/baz" "~/src/baz"))
           (autoloads '(baz-1 baz-2))
           (autoloads-interactive '(baz))
           (options `((baz-option . #t)
                      (bar-list (baz-1 . baz-2))
                      (baz-var . ,(elisp my--foo))))
           (hooks '((prog-mode . baz-mode)
                    (bar-mode . baz-mode)))
           (auto-modes '(("\\.baz\\'" . baz-mode)))
           (magic-modes '((">>BAZ<<" . baz)
                          ("!XXBAZXX" . baz))))))))

(test-end "emacs-home-services")