;; -*- lexical-binding: t; -*-

(require 'package)
(add-to-list 'package-archives '("melpa" . "https://melpa.org/packages/") t)
(package-initialize)

;; Helpers

(defmacro set-keys (&rest keys)
  "Set multiple global keys at once."
  (cl-loop for (key fun) on keys by #'cddr
	   collect `(global-set-key
		     ,(if (stringp key) `(kbd ,key) key)
		     ,(if (listp fun) fun `#',fun))
	   into exps
	   finally return `(progn ,@exps)))

(defmacro set-keys-in (maps &rest keys)
  "Set multiple keys in multiple keymaps."
  (declare (indent defun))
  (cl-loop for (key fun) on keys by #'cddr
	   collect (cl-loop for map in maps
			    collect `(define-key ,map
				       ,(if (stringp key) `(kbd ,key) key)
				       ,(if (listp fun) fun `#',fun))
			    into exps
			    finally return `(progn ,@exps))
	   into exps
	   finally return `(progn ,@exps)))

(defun add-hooks (fun &rest modes)
  "Add a function to multiple mode hooks at once."
  (dolist (mode modes)
    (add-hook (intern (concat (symbol-name mode) "-mode-hook")) fun)))

(defun align-setq ()
  "Align `setq' expression at point. Note that this removes all comments."
  (interactive)
  (let ((sexp (list-at-point)))
    (unless (string-prefix-p "set" (prin1-to-string (car sexp)))
      (error "Not a set* expression"))
    (let ((bounds (thing-at-point-bounds-of-list-at-point))
	  (max-length 0))
      (delete-region (car bounds) (cdr bounds))
      (insert "(" (prin1-to-string (car sexp)) " ")
      (when (string= "set-keys-in" (prin1-to-string (car sexp)))
	(insert (prin1-to-string (cadr sexp)) "\n")
	(setq sexp (cdr sexp)))
      (cl-loop for (sym val) on (cdr sexp) by #'cddr
	       do (let ((length (length (prin1-to-string sym))))
		    (when (< max-length length)
		      (setq max-length length))))
      (cl-loop for (sym val) on (cdr sexp) by #'cddr
	       do (let* ((length (length (prin1-to-string sym)))
			 (diff (- max-length length)))
		    (insert (prin1-to-string sym))
		    (when (<= 0 diff)
		      (insert (make-string (1+ diff) ? )))
		    (insert (prin1-to-string val) "\n")))
      (backward-delete-char 1)
      (insert ")")
      (left-char)
      (setq bounds (thing-at-point-bounds-of-list-at-point))
      (indent-region (car bounds) (cdr bounds))
      (right-char))))

(defun apply-with-normal-backward-delete-char (fun &rest args)
  (cl-letf (((symbol-function #'backward-delete-char-untabify) #'backward-delete-char))
    (apply fun args)))

(defun async-shell-command-here ()
  "Run `async-shell-command', then delete the current window."
  (interactive)
  (call-interactively #'async-shell-command)
  (delete-window)) ; TODO: Function for opening X program with
		   ; associated command output buffer.

(defun customize-setq ()
  "Customize variable according to `setq' expression at point."
  (interactive)
  (let ((sexp (list-at-point)))
    (unless (symbol-value))))

(defun kill-buffer-now ()
  "Kill the current buffer immediately."
  (interactive)
  (kill-buffer))

(defun launch-program (command)
  (interactive (list (read-shell-command "Launch program: ")))
  (start-process-shell-command command nil command))

(defun sort-config-paragraphs ()
  (interactive)
  (save-excursion
    (goto-char (point-min))
    (re-search-forward "^;;; ")
    (move-beginning-of-line 1)
    (sort-paragraphs nil (point) (point-max))))

(defun switch-to-other-buffer ()
  "Switch to the last visited buffer immediately."
  (interactive)
  (switch-to-buffer nil))

;; Configuration

(setq insert-directory-program "gls"
      x-pointer-shape          x-pointer-top-left-arrow)

(set-mouse-color "black")
(tool-bar-mode -1)
(window-divider-mode 1)
(column-number-mode 1)
(recentf-mode 1)
(save-place-mode 1)
(delete-selection-mode 1)

(set-keys "C-M-&"   async-shell-command-here
	  "C-§"     delete-other-windows
	  "C-x C-b" ibuffer
	  "C-x K"   kill-buffer-now
	  "C-c s c" sort-config-paragraphs
	  "C-c s f" sort-fields
	  "C-c s l" sort-lines
	  "C-c s p" sort-paragraphs
	  "C-z"     nil)

;;; EXWM
(require 'exwm)
(add-hook 'exwm-update-class-hook
	  (lambda ()
	    (exwm-workspace-rename-buffer exwm-class-name)))
(setq exwm-input-simulation-keys
      '(([?\C-b] . [left])
	([?\C-f] . [right])
	([?\C-p] . [up])
	([?\C-n] . [down])
	([?\C-a] . [home])
	([?\C-e] . [end])
	([?\M-v] . [prior])
	([?\C-v] . [next])
	([?\C-d] . [delete])
	([?\C-k] . [S-end delete])
	([?\M-w] . [C-insert])
	([?\C-y] . [S-insert])
	([?\M-f] . [C-right])
	([?\M-b] . [C-left])))
(setq exwm-input-global-keys '(("" . exwm-input-send-next-key)))
(push ?\C-§ exwm-input-prefix-keys)
(setq exwm-manage-force-tiling t)
(exwm-enable)

;;; Helm
(require 'helm)
(require 'helm-ext)
(set-keys "M-x"       helm-M-x
	  "M-s o"     helm-occur
	  "C-x b"     helm-multi-files
	  "C-x C-SPC" helm-global-mark-ring
	  "C-x M-b"   helm-exwm
	  "C-x C-f"   helm-find-files
	  "C-x r b"   helm-filtered-bookmarks
	  "C-M-y"     helm-show-kill-ring)
(setq helm-ff-DEL-up-one-level-maybe t
      helm-allow-mouse t
      ;; helm-completion-style 'emacs
      ;; completion-styles '(helm-flex)
      )
(helm-mode 1)
(helm-ext-ff-enable-skipping-dots t)
(helm-ext-minibuffer-enable-header-line-maybe t)

;;; Helm-exwm
(autoload #'helm-exwm "helm-exwm" nil t)
(with-eval-after-load 'helm-exwm
  (setq helm-exwm-emacs-buffers-source (helm-exwm-build-emacs-buffers-source))
  (setq helm-exwm-source (helm-exwm-build-source))
  (setq helm-mini-default-sources '(helm-exwm-emacs-buffers-source
				    helm-exwm-source
				    helm-source-recentf
				    helm-source-buffer-not-found)))

;;; Ibuffer
(require 'ibuf-ext)
(add-to-list 'ibuffer-never-show-predicates "^\\*helm[- ]")
;; (add-to-list 'ibuffer-never-show-predicates "^magit-")

;;; Layouts
(defvar *buffer-layouts* (list) "Buffer-layout associations")
(defvar *protect-buffer-layouts* nil "Temporarily protect buffer layouts")
(defun restore-buffer-layout ()
  "Restore the layout associated with the current buffer."
  (interactive)
  (let ((conf (alist-get (current-buffer) *buffer-layouts*)))
    (if conf
	(progn
	  (set-window-configuration conf)
	  (message "Restored buffer layout"))
      (setf (alist-get (current-buffer) *buffer-layouts*)
	    (current-window-configuration))
      (message "Set buffer layout"))))
(defun switch-to-buffer-with-layout ()
  "Switch to the window layout associated with a buffer. At the
same time, associate the original buffer with the original
layout.

If the new buffer has no associated layout, it is displayed as
the only window in the frame."
  (interactive)
  (let ((*protect-buffer-layouts* t))
    (dolist (window (window-list))
      (setf (alist-get (window-buffer window) *buffer-layouts*)
	    (current-window-configuration)))
    (call-interactively #'helm-multi-files)
    (delete-other-windows)
    (let* ((buf (current-buffer))
	   (conf (alist-get buf *buffer-layouts*)))
      (when conf
	(set-window-configuration conf)
	(select-window (get-buffer-window buf))))))
(advice-add #'delete-other-windows :before
	    (lambda (&optional window)
	      (when (not *protect-buffer-layouts*)
		(dolist (window (window-list))
		  (setf (alist-get (window-buffer window) *buffer-layouts*) nil)))))
(advice-add #'delete-window :before
	    (lambda (&optional window)
	      (when (not window)
		(setq window (get-buffer-window)))
	      (when (not *protect-buffer-layouts*)
		(setf (alist-get (window-buffer window) *buffer-layouts*) nil))))
(advice-add #'quit-window :before
	    (lambda (&optional kill window)
	      (when (not window)
		(setq window (get-buffer-window)))
	      (when (not *protect-buffer-layouts*)
		(setf (alist-get (window-buffer window) *buffer-layouts*) nil))))
(set-keys "C-c b" switch-to-buffer-with-layout
	  "C-c n" restore-buffer-layout)

;;; Lisp
(autoload #'enable-paredit-mode "paredit" nil t)
(add-hooks #'enable-paredit-mode 'lisp 'emacs-lisp)
(add-hooks #'show-paren-mode 'lisp 'emacs-lisp)
(set-keys "C-x M-s ."   isearch-forward-symbol-at-point
	  "C-x M-s _"   isearch-forward-symbol
	  "C-x M-s o"   helm-occur
	  "C-x M-s w"   isearch-forward-word
	  "C-x M-s h ." highlight-symbol-at-point
	  "C-x M-s h f" hi-lock-find-patterns
	  "C-x M-s h l" highlight-lines-matching-regexp
	  "C-x M-s h p" highlight-phrase
	  "C-x M-s h r" highlight-regexp
	  "C-x M-s h u" unhighlight-regexp
	  "C-x M-s h w" hi-lock-write-interactive-patterns
	  "C-x M-s M-w" eww-search-words) ; Replace M-s keys
					  ; overridden by Paredit.
(advice-add #'paredit-backward-delete :around #'apply-with-normal-backward-delete-char)
(set-keys-in (lisp-mode-map emacs-lisp-mode-map)
  "M-Q"     align-setq)

;;; Mouse
(setq mouse-wheel-scroll-amount '(3 ((shift) . 1) ((control))))
(setq mouse-wheel-progressive-speed nil) ; For some reason, Emacs has
					 ; crazy defaults with regards
					 ; to mouse wheel scrolling.

;;; Perspective
;; (require 'perspective)
;; (persp-mode)

;;; Undo-tree
(require 'undo-tree)
(global-undo-tree-mode 1)

;;; Wanderlust
(autoload 'wl "wl" "Wanderlust" t)
(autoload 'wl-other-frame "wl" "Wanderlust on new frame." t)
(autoload 'wl-draft "wl-draft" "Write draft with Wanderlust." t)
(require 'mime-view)
(setq elmo-imap4-default-server      "imap.mailbox.org"
      elmo-imap4-default-user        "john@ankarstrom.se"
      elmo-imap4-default-stream-type (quote starttls)
      wl-from                        "<john@ankarstrom.se>"
      wl-smtp-posting-server         "smtp.mailbox.org"
      mail-user-agent                (quote wl-user-agent)
      wl-message-ignored-field-list  (list "^.*:")
      wl-message-visible-field-list  (list "^To:" "^Cc:" "^From:" "^Subject:" "^Date:"))
(define-mail-user-agent 'wl-user-agent
  #'wl-user-agent-compose
  #'wl-draft-send
  #'wl-draft-kill
  'mail-send-hook)

;;; Wanderlust: Fix scrolling
(defmacro fix-wl-scroll (feature maps)
  `(with-eval-after-load ',feature
     (set-keys-in ,maps
       "<mouse-4>" mwheel-scroll
       "<mouse-5>" mwheel-scroll)))
(fix-wl-scroll wl (wl-plugged-mode-map))
(fix-wl-scroll wl-addrmgr (wl-addrmgr-mode-map))
(fix-wl-scroll wl-draft (wl-draft-mode-map))
(fix-wl-scroll wl-fldmgr (wl-fldmgr-mode-map))
(fix-wl-scroll wl-spam (wl-summary-spam-map))
(fix-wl-scroll wl-template (wl-template-mode-map))
(fix-wl-scroll wl-address (wl-address-minibuffer-local-map))
(fix-wl-scroll wl-folder (wl-folder-mode-map))
(fix-wl-scroll wl-summary (wl-summary-mode-map))
(fix-wl-scroll wl-message (wl-message-button-map
			   wl-message-header-narrowing-map
			   wl-message-header-narrowing-widen-map))
(fix-wl-scroll wl-score (wl-score-mode-map))
(advice-add #'wl-message-wheel-up :around
	    (lambda (&rest _)
	      (interactive)
	      (call-interactively #'mwheel-scroll)))
(advice-add #'wl-message-wheel-down :around
	    (lambda (&rest _)
	      (interactive)
	      (call-interactively #'mwheel-scroll)))

;;; Which-key
(require 'which-key)
(which-key-mode 1)

(custom-set-variables
 ;; custom-set-variables was added by Custom.
 ;; If you edit it by hand, you could mess it up, so be careful.
 ;; Your init file should contain only one such instance.
 ;; If there is more than one, they won't work right.
 '(c-backspace-function (quote backward-delete-char))
 '(c-default-style
   (quote
    ((java-mode . "java")
     (awk-mode . "awk")
     (other . "bsd"))))
 '(helm-always-two-windows t)
 '(mouse-autoselect-window t)
 '(org-support-shift-select t)
 '(package-selected-packages
   (quote
    (perspective wanderlust magit helm-exwm helm-ext undo-tree which-key paredit helm exwm)))
 '(sentence-end-double-space nil)
 '(undo-tree-enable-undo-in-region t)
 '(wdired-allow-to-change-permissions t))
(custom-set-faces
 ;; custom-set-faces was added by Custom.
 ;; If you edit it by hand, you could mess it up, so be careful.
 ;; Your init file should contain only one such instance.
 ;; If there is more than one, they won't work right.
 )