(require 'patch-sly)
(with-eval-after-load 'sly-mrepl
  (require 'patch-sly-prompt))
(require 'cl-lib)

(defun ambrevar/delete-lisp-image-dump ()
  "Delete SLY current connection image dump.
This dump is expected to be generated by `lisp-repl-core-dumper'."
  (interactive)
  (let* ((pid (process-id (sly-inferior-process (sly-current-connection))))
         (args (alist-get 'args (process-attributes pid)))
         (command (car (split-string (alist-get 'args (process-attributes pid))))))
    (if (and (string= "image"
                      (file-name-extension command))
             (string= (file-name-directory command)
                      (expand-file-name "~/.cache/lisp-repl-core-directory/")))
        (when (yes-or-no-p (format "Delete %s?" command))
          (let ((delete-by-moving-to-trash nil))
            (delete-file command)
            (message "%S deleted." command)))
      (message "%S is not a Lisp image dump." command))))

(load "~/projects/nyxt/build-scripts/nyxt-guix.el" :noerror)

;; Warning: ,restart-lisp does not take changes into account, the buffer must be re-created.
;; TODO: SLY: Add pre-inst-env SBCL, maybe ask for packages?
(setq sly-lisp-implementations
      (let* ((maybe-core-dumper (when-let ((exec (executable-find "lisp-repl-core-dumper")))
                                  (list exec)))
             (nyxt-ad-hoc-deps '("emacs" ; For external editor editing.
                                 "git"  ; For vcs-mode.
                                 "gnupg" ;
                                 "guix"  ; For OSPM.
                                 "password-store"
                                 ;; For xdg-open:
                                 "xdg-utils"
                                 ;; For magnet link support:
                                 "transmission"
                                 ;; For nx-notmuch:
                                 "cl-yason"
                                 "notmuch"))
             (nyxt-command `("guix" "environment" "--pure"
                             "--preserve=^PERSONAL$" ; To find personal config, like engines and bookmarks.
                             "-l" ,(expand-file-name "~/common-lisp/nyxt/build-scripts/guix.scm")
                             ;; glib is needed to export GIO_EXTRA_MODULES.
                             "--ad-hoc" "glib"
                             ;; Not necessary?
                             "glib-networking" "gsettings-desktop-schemas"
                             ,@nyxt-ad-hoc-deps
                             ;; "--" "sbcl"
                             )))
        ;; TODO: Shouldn't lisp-repl-core-dumper include sb-sprof?  Should SBCL
        ;; packages remain loadable?
        `((sbcl-ambrevar ("lisp-repl-core-dumper" "-g" "--non-interactive"
                          "-s" "ambrevar sb-sprof" "sbcl"
                          "--eval" "(in-package :ambrevar/all)"
                          "--eval" "(named-readtables:in-readtable ambrevar/syntax:syntax)"))
          (sbcl (,@maybe-core-dumper "sbcl"))
          (sbcl-failsafe ("sbcl"))
          (sbcl-pre-inst-env ,(list (expand-file-name "~/projects/guix/pre-inst-env")
                                    "guix" "environment" "--ad-hoc" "sbcl" "sbcl-quickproject"
                                    "--" "sbcl"))
          (sbcl-nyxt (lambda ()
                       (nyxt-make-guix-sbcl-for-nyxt "~/projects/nyxt"
                                                     :preserve '("PERSONAL")
                                                     :ad-hoc ',nyxt-ad-hoc-deps)))
          (sbcl-nyxt-force (lambda ()
                             (nyxt-make-guix-sbcl-for-nyxt "~/projects/nyxt"
                                                           :preserve '("PERSONAL")
                                                           :ad-hoc ',nyxt-ad-hoc-deps
                                                           :force t)))
          (sbcl-nyxt-pre-inst-env ,(append
                                    (list (expand-file-name "~/projects/guix/pre-inst-env"))
                                    nyxt-command
                                    '("--" "sbcl")))
          ;; Simple REPL environment for Nyxt, in case sbcl-nyxt does not work.
          (sbcl-nyxt-failsafe ,(append nyxt-command '("--" "sbcl")))
          (ccl-nyxt ,(append nyxt-command '("ccl" "cl-osicat" ; Osicat is required by non-SBCL compilers.
                                            "--" "ccl")))
          (sbcl-nyxt-site ("guix" "environment" "--pure"
                           "-m" ,(expand-file-name "~/common-lisp/nyxt-site/guix-manifest.scm")
                           "--" "sbcl"))
          (ccl (,@maybe-core-dumper "ccl"))
          (clisp (,@maybe-core-dumper "clisp"))
          (ecl ("ecl")))))

(setq sly-connection-update-interval 0.1)

(when (require 'helm nil :noerror)
  (with-eval-after-load 'sly-mrepl
    (define-key sly-mrepl-mode-map (kbd "M-p") 'helm-comint-input-ring)
    (define-key sly-mrepl-mode-map (kbd "M-s f") 'helm-comint-prompts-all)
    (define-key sly-autodoc-mode-map (kbd "C-c C-d C-a") 'helm-sly-apropos)
    (define-key sly-mrepl-mode-map (kbd "C-c C-x c") 'helm-sly-list-connections)))

(when (require 'helm-sly nil :noerror)
  (when (require 'evil-collection nil :noerror)
    (evil-define-key '(normal insert) helm-sly-connections-map
      (kbd "S-<return>") 'helm-sly-run-go-to-repl-other-window))
  (defun ambrevar/helm-sly-format-connection (connection buffer)
    (let ((fstring "%s%2s  %s"))
      (format fstring
              (if (eq sly-default-connection connection)
                  "*"
                " ")
              (helm-sly-connection-number connection)
              (replace-regexp-in-string
               "*$" ""
               (replace-regexp-in-string
                "*sly-mrepl for " ""
                (replace-regexp-in-string "*sly-inferior-lisp for " ""
                                          (buffer-name buffer)))))))
  (setq helm-sly-connection-formatter #'ambrevar/helm-sly-format-connection)
  (global-helm-sly-mode)
  (add-to-list 'helm-source-names-using-follow "Lisp xrefs"))

(defun ambrevar/sly-insert-cmd ()
  "Convenient to call commands."
  (interactive)
  (insert "(cmd:cmd \"\")")
  (backward-char 2)
  (when (and (boundp 'evil-state)
             (not (eq evil-state 'insert)))
    (call-interactively #'evil-insert)))

(defun ambrevar/sly-insert-double-quotes ()
  "Convenient to write list of string, e.g. when writing a shell command line."
  (interactive)
  (while (sly-inside-string-p)
    (forward-char))
  (cycle-spacing)
  (insert "\"\"")
  (backward-char)
  (when (and (boundp 'evil-state)
             (not (eq evil-state 'insert)))
    (call-interactively #'evil-insert)))

(defun ambrevar/sly-insert-pipe ()
  "Convenient to write a `:-' pipe."
  (interactive)
  (while (sly-inside-string-p)
    (forward-char))
  (newline-and-indent)
  (insert ":-")
  (ambrevar/sly-insert-double-quotes))

;; Glyphs
(defun ambrevar/insert-lambda () (interactive) (insert "\u03bb"))
(defun ambrevar/insert-cursive-f () (interactive) (insert "\u0192"))
(defun ambrevar/insert-right-arrow () (interactive) (insert "\u2192"))
(defun ambrevar/insert-alpha () (interactive) (insert "\u03b1"))
(defun ambrevar/insert-psy () (interactive) (insert "\u03c8"))

(with-eval-after-load 'sly-mrepl
  (set-face-attribute 'sly-mrepl-output-face nil :inherit 'default :foreground)
  (setq sly-mrepl-history-file-name (expand-file-name "sly-mrepl-history" user-emacs-directory))
  ;; While `,i RET` is short enough, it's one more key away in Evil insert state:
  (define-key sly-mrepl-mode-map (kbd "C-c M-p") 'sly-mrepl-set-package)
  (define-key sly-mrepl-mode-map (kbd "C-c M-o") 'sly-mrepl-clear-repl)
  (define-key sly-mrepl-mode-map (kbd "S-SPC") 'ambrevar/sly-insert-double-quotes)
  (define-key sly-mrepl-mode-map (kbd "C-S-SPC") 'ambrevar/sly-insert-pipe)
  (define-key sly-mrepl-mode-map (kbd "<C-return>") 'ambrevar/sly-insert-cmd)
  ;; Glyphs
  (define-key sly-mrepl-mode-map (kbd "M-l") 'ambrevar/insert-lambda)
  (define-key sly-mrepl-mode-map (kbd "M-f") 'ambrevar/insert-cursive-f)
  (define-key sly-mrepl-mode-map (kbd "M-a") 'ambrevar/insert-alpha)
  (define-key sly-mrepl-mode-map (kbd "M->") 'ambrevar/insert-right-arrow)
  (define-key sly-mrepl-mode-map (kbd "<M-right>") 'ambrevar/insert-right-arrow)
  (define-key sly-mrepl-mode-map (kbd "C-M-y") 'ambrevar/insert-psy))

(defun ambrevar/sly-load-reload-system ()
  (interactive)
  (funcall
   (if (sly-eval `(slynk-asdf:asdf-system-loaded-p ,(intern (sly-current-package))))
       #'sly-asdf-reload-system
     #'sly-asdf-load-system)
   (intern (sly-current-package))))
(define-key lisp-mode-map (kbd "<f6>") 'ambrevar/sly-load-reload-system)

(defun ambrevar/sly-colorize-buffer (str)
  "Useful for colorized output like the tests of Prove."
  (ansi-color-apply str))
(add-hook 'sly-mrepl-output-filter-functions 'ambrevar/sly-colorize-buffer)

(defun ambrevar/indent-and-helm-company (arg)
  "Indent then call `helm-company'.
Good substitute for `sly-mrepl-indent-and-complete-symbol'."
  (interactive "P")
  (indent-for-tab-command arg)
  (helm-company))

(setq sly-command-switch-to-existing-lisp 'always)
(add-hook 'sly-mrepl-hook #'ambrevar/init-lispy)
(add-hook 'sly-mrepl-hook #'rainbow-delimiters-mode)
(require 'patch-sly-rainbow)

;; #p completion.  See https://github.com/joaotavora/sly/issues/405.
(with-eval-after-load 'company
  (defcustom ambrevar/complete-cl-file-prefix "./"
    "Prefix for `ambrevar/complete-cl-file'."
    :type 'string)

  (defun ambrevar/complete-cl-file (action &rest _)
    (interactive (list 'interactive))
    (cl-flet ((look-back
               (&key suffix use-limit)
               (cl-some
                (lambda (reader-macro)
                  (let ((expr (concat reader-macro suffix)))
                    (looking-back expr
                                  (when use-limit
                                    (- (point) (length expr))))))
                ;; #f is for FOF.
                '("#p" "#f"))))
      (cl-case action
        (interactive (company-begin-backend #'my/complete-cl-file))
        (candidates
         (cond ((and (save-match-data (look-back :use-limit t)))
                (if (looking-at-p "\"")
                    (company-files 'candidates ambrevar/complete-cl-file-prefix)
                  (mapcar (lambda (s)
                            (concat "\"" s "\""))
                          (company-files 'candidates ambrevar/complete-cl-file-prefix))))
               ((save-match-data (look-back :suffix "\"" :use-limit t))
                (company-files 'candidates ambrevar/complete-cl-file-prefix))))
        (prefix (and (save-match-data (look-back :suffix "\"?")) ""))
        (t (company-files action)))))

  (defun ambrevar/set-sly-company-backends ()
    (set (make-local-variable 'company-backends)
         (cons 'ambrevar/complete-cl-file company-backends)))
  (add-hook 'sly-mrepl-hook 'ambrevar/set-sly-company-backends))

;; REVIEW: With Emacs 27 we can:
;; (customize-set-variable 'helm-completion-style 'emacs)
;; (add-to-list 'completion-styles 'backend) ; Useless?
(when (require 'helm-sly nil 'noerror)
  (add-hook 'sly-mrepl-hook #'helm-sly-disable-internal-completion)
  ;; REVIEW: Company completion has the benefit of having annotations.
  (when (require 'helm-company nil :noerror)
    (setq helm-company-initialize-pattern-with-prefix t)
    (add-hook 'lisp-mode-hook #'company-mode)
    (define-key lisp-mode-map (kbd "<tab>") 'ambrevar/indent-and-helm-company)
    (define-key lisp-mode-map (kbd "M-<tab>") 'ambrevar/indent-and-helm-company)
    (defun ambrevar/sly-set-keys ()
      (define-key sly-mrepl-mode-map (kbd "<tab>") 'ambrevar/indent-and-helm-company)
      (define-key sly-mrepl-mode-map (kbd "M-<tab>") 'ambrevar/indent-and-helm-company))
    (add-hook 'sly-mrepl-hook #'ambrevar/sly-set-keys)
    (add-hook 'sly-mrepl-hook #'company-mode)))
;; Pros and cons of internal completion vs. company completion.
;; Cons:
;; - Internal does not support spaces like Helm does.
;; - Word order matters.
;; - Cannot complete against current package.
;; - [ ] File completion does not work.
;; Pros:
;; - [X] Current prefix is included in completion input.
;;   Fix: (setq helm-company-initialize-pattern-with-prefix t)
;; - Less config.
;; - Company seem to miss some symbols?
;;   Problem with cache?
;;   https://github.com/joaotavora/sly/issues/328

(when (require 'helm-selector nil :noerror)
  (require 'init-sly-selector))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Prompt customization
;; TODO: Upstream!

(defvar ambrevar/sly-status--last-command-time nil)
(make-variable-buffer-local 'ambrevar/sly-status--last-command-time)
(defun ambrevar/sly-status--record ()
  (setq ambrevar/sly-status--last-command-time (current-time)))

(defun ambrevar/sly-status-formatter (timestamp duration)
  "Return the status display for `ambrevar/sly-status'.
TIMESTAMP is the value returned by `current-time' and DURATION is the floating
time the command took to complete in seconds."
  (format "#[STATUS] End time %s, duration %.3fs\n"
          (format-time-string "%F %T" timestamp)
          duration))

(defcustom ambrevar/sly-status-min-duration 1
  "If a command takes more time than this, display its status with `ambrevar/sly-status'."
  :group 'sly
  :type 'number)

(defun ambrevar/sly-status (&optional formatter min-duration)
  "Termination timestamp and duration of command.
Status is only returned if command duration was longer than
MIN-DURATION \(defaults to `ambrevar/sly-status-min-duration').  FORMATTER
is a function of two arguments, TIMESTAMP and DURATION, that
returns a string."
  (if ambrevar/sly-status--last-command-time
      (let ((duration (time-to-seconds
                       (time-subtract (current-time) ambrevar/sly-status--last-command-time))))
        (setq ambrevar/sly-status--last-command-time nil)
        (if (> duration (or min-duration
                            ambrevar/sly-status-min-duration))
            (funcall (or formatter
                         #'ambrevar/sly-status-formatter)
                     (current-time)
                     duration)
          ""))
    (progn
      (advice-add 'sly-mrepl--send-input-sexp :after #'ambrevar/sly-status--record)
      "")))

(defun ambrevar/sly-prepare-prompt (old-func &rest args) ; TODO: Remove when upstream have merged `sly-mrepl-prompt-formatter'.
  (let ((package (nth 0 args))
        (new-prompt (format "%s%s\n%s"
                            (ambrevar/sly-status)
                            (abbreviate-file-name default-directory)
                            (nth 1 args)))
        (error-level (nth 2 args))
        (condition (nth 3 args)))
    (funcall old-func package new-prompt error-level condition)))

(cl-defun ambrevar/sly-new-prompt (_package
                                package-nickname
                                error-level
                                entry-idx
                                _condition)
  (concat
   (propertize (ambrevar/sly-status) 'font-lock-face 'font-lock-comment-face)
   "("
   (propertize (abbreviate-file-name default-directory) 'font-lock-face 'diff-added)
   ")\n"
   (propertize "<" 'font-lock-face 'sly-mrepl-prompt-face)
   (propertize (number-to-string entry-idx) 'font-lock-face 'sly-mode-line)
   (propertize ":" 'font-lock-face 'sly-mrepl-prompt-face)
   (propertize package-nickname 'font-lock-face 'sly-mode-line)
   (when (cl-plusp error-level)
     (concat (sly-make-action-button
              (format "[%d]" error-level)
              #'sly-db-pop-to-debugger-maybe)
             " "))
   (propertize "> " 'font-lock-face 'sly-mrepl-prompt-face)))

(with-eval-after-load 'sly-mrepl
  (setq sly-mrepl-prompt-formatter #'ambrevar/sly-new-prompt))

(defun ambrevar/sly-end-of-prompt-p ()
  (and (not (= (point) (point-min)))
       (not (get-text-property (point) 'sly-mrepl--prompt))
       (get-text-property (1- (point)) 'sly-mrepl--prompt)))

(defun ambrevar/sly-prompt-line-p ()
  (or (ambrevar/sly-end-of-prompt-p)
      (save-excursion
        (goto-char (line-beginning-position))
        (ambrevar/sly-end-of-prompt-p))))

(defun ambrevar/sly-mrepl-previous-prompt ()
  "Go to the beginning of the previous REPL prompt."
  (interactive)
  (cl-flet ((go-back ()
                     (goto-char
                      (previous-single-char-property-change
                       (point) 'sly-mrepl--prompt))))
    (if (ambrevar/sly-prompt-line-p)
        (progn
          (unless (ambrevar/sly-end-of-prompt-p)
            (goto-char (line-beginning-position)))
          (go-back)
          (go-back))
      (go-back))
    (unless (ambrevar/sly-prompt-line-p)
      ;; We did not end up on a prompt, means we are above the first prompt.
      ;; Return back.
      (ambrevar/sly-mrepl-next-prompt))))

(defun ambrevar/sly-mrepl-next-prompt ()
  "Go to the beginning of the next REPL prompt."
  (interactive)
  (let ((pos (next-single-char-property-change (line-beginning-position 2)
                                               'sly-mrepl--prompt)))
    (goto-char pos)
    (if (get-text-property (point) 'sly-mrepl--prompt)
        (goto-char (next-single-char-property-change (point)
                                                     'sly-mrepl--prompt))
      (point))))

(advice-add 'sly-mrepl-next-prompt :override #'ambrevar/sly-mrepl-next-prompt)
(advice-add 'sly-mrepl-previous-prompt :override #'ambrevar/sly-mrepl-previous-prompt)

(require 'init-sly-narrow)

(provide 'init-sly)