(require 'patch-sly)

(defun ambrevar/prepare-sbcl-for-nyxt () ; TODO: Move this to a cl-flet.
  (let ((file (make-temp-file "sbcl")))
    (with-temp-file file
      (insert
       (format "%S"
               '(mapc #'asdf:load-system
                      (delete-if (lambda (s)
                                   (string= "nyxt" (subseq s 0 (min (length s) 4))))
                                 (append
                                  (asdf:system-depends-on (asdf:find-system :nyxt))
                                  (asdf:system-depends-on (asdf:find-system :nyxt/gtk))))))))
    file))

(when (executable-find "lisp-repl-core-dumper")
  ;; Warning: ,restart-lisp does not take changes into account, the buffer must be re-created.
  (setq sly-lisp-implementations
        `((sbcl-ambrevar ("lisp-repl-core-dumper" "sbcl" "ambrevar"))
          (sbcl ("lisp-repl-core-dumper" "sbcl"))
          (sbcl-nyxt ;; Faster, but not pure.  TODO: Can we purify it?  Run it in a container?  Try `env -i bash  --noprofile --norc...`.
           ;; TODO: Add easy way to reload: must delete profile.  No need to delete dump if we use -f.
           ;; TODO: Extract to separate functions.
           (lambda ()
             (let* ((guix-def (expand-file-name "~/common-lisp/nyxt/build-scripts/guix.scm"))
                    (guix-def-mtime (file-attribute-modification-time (file-attributes guix-def)))
                    (root (expand-file-name "~/.guix-temp-profiles/nyxt"))
                    (root-mtime (file-attribute-modification-time (file-attributes root)))
                    (cache (expand-file-name "~/.cache/lisp-repl-core-nyxt"))
                    (setup-file (ambrevar/prepare-sbcl-for-nyxt)))
               (unless (and (file-exists-p root)
                            (time-less-p guix-def-mtime root-mtime))
                 (make-directory (file-name-directory root) :parents)
                 (call-process "guix" nil nil nil
                               "environment" "--pure"
                               "--preserve=^PERSONAL$" ; To find personal config, like engines and bookmarks.
                               "-r" root
                               "-l" guix-def
                               "--ad-hoc" "glib" "glib-networking" "gsettings-desktop-schemas"
                               ;; "nss-certs" ; Only needed in containers.
                               ;; "libfixposix" ; TODO: We should not need this.  Delete if there is no issue after a while (Jan 2021?).
                               "gnupg"     ; For user .gpg decryption.
                               "coreutils" ; For "env".
                               "lisp-repl-core-dumper"
                               "--" "env" (concat "LISP_REPL_CORE_PATH=" cache)
                               "lisp-repl-core-dumper" "-f" "-g" (format "--load %s" setup-file) "sbcl")
                 (let ((delete-by-moving-to-trash nil))
                   (delete-file setup-file)))
               `(("bash" "-c" ,(concat
                                (format "source '%s/etc/profile'" root)
                                " && LISP_REPL_CORE_PATH=" cache
                                " lisp-repl-core-dumper sbcl"))))))
          ;; Simple REPL environment (no container):
          (sbcl-nyxt-failsafe ("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" "glib-networking" "gsettings-desktop-schemas"
                               "gnupg" "--" "sbcl"))
          (sbcl-nyxt-site ("guix" "environment" "--pure"
                           "-m" ,(expand-file-name "~/common-lisp/nyxt-site/guix-manifest.scm")
                           "--" "sbcl"))
          (ccl ("lisp-repl-core-dumper" "ccl"))
          (clisp ("lisp-repl-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)
  (global-helm-sly-mode)
  (add-to-list 'helm-source-names-using-follow "Lisp xrefs"))

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

(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)
;; REVIEW: With Emacs 27 we can:
;; (customize-set-variable 'helm-completion-style 'emacs)
;; (add-to-list 'completion-styles 'backend)
(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)
    (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)))

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

(defun ambrevar/sly-mrepl-previous-prompt ()
  "Go to the beginning of the previous REPL prompt."
  (interactive)
  ;; This has two wrinkles around the first prompt: (1) when going to
  ;; the first prompt it leaves point at column 0 (1) when called from
  ;; frist prompt goes to beginning of buffer.  The correct fix is to
  ;; patch comint.el's comint-next-prompt and comint-previous-prompt
  ;; anyway...
  (let* ((inhibit-field-text-motion t)
         (pos (previous-single-char-property-change
               (previous-single-char-property-change (point)
                'sly-mrepl--prompt)
               'sly-mrepl--prompt)))
    (goto-char pos)
    (goto-char (line-beginning-position)))
  (end-of-line))

(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--insert-prompt :around #'ambrevar/sly-prepare-prompt)

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

(provide 'init-sly)