;; -*- 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 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-§"     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-c])
	([?\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 active buffer."
  (interactive)
  (let ((conf (alist-get (current-buffer) *buffer-layouts*)))
    (if conf
	(progn
	  (set-window-configuration conf)
	  (message "Restored buffer layout"))
      (error "No layout associated with buffer"))))
(defun set-buffer-layout ()
  "Set the layout associated with the visible buffers."
  (interactive)
  (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. Before,
associate the currently visible buffers 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" set-buffer-layout
	  "C-c m" 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)

;;; Processes
(defun launch-program (command)
  (interactive (list (read-shell-command "Launch program: ")))
  (make-process :name command
		:buffer "*launch-program*"
		:filter #'launch-program-filter
		:command (list shell-file-name shell-command-switch command))
  (switch-to-buffer "*launch-program*")
  (bury-buffer "*launch-program*"))
(defun launch-program-filter (proc string)
  (when (buffer-live-p (process-buffer proc))
    (with-current-buffer (process-buffer proc)
      (let ((moving (= (point) (process-mark proc))))
        (save-excursion
          (goto-char (process-mark proc))
          (insert "<" (car (last (process-command proc))) "> " string)
          (set-marker (process-mark proc) (point)))
        (if moving (goto-char (process-mark proc)))))))
(set-keys "C-M-&" launch-program)

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