;; -*- 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)))
(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 *layout-stack* (list) "Window layout stack")
(defvar *active-layout* -1 "Active window layout")
(defun layout-load-fun (reg)
  (lambda ()
    (interactive)
    (when (not (= *active-layout* reg))
      (set-register *active-layout* (current-window-configuration))
      (set-window-configuration (get-register reg))
      (when *active-layout*
	(push *layout-stack* *active-layout*))
      (setq *active-layout* reg)
      (message (format-message "Loaded layout %c." reg)))))
(defun layout-save-fun (reg)
  (lambda ()
    (interactive)
    (when (not (= *active-layout* reg))
      (setq *active-layout* reg)
      (message (format-message "Saved layout %c." reg)))))
(defun which-layout ()
  (interactive)
  (message (format-message "Current layout: %c" *active-layout*)))
(set-keys "C-c §"   which-layout
	  "C-c 1"   (layout-load-fun ?1)
	  "C-c M-1" (layout-save-fun ?1)
	  "C-c 2"   (layout-load-fun ?2)
	  "C-c M-2" (layout-save-fun ?2)
	  "C-c 3"   (layout-load-fun ?3)
	  "C-c M-3" (layout-save-fun ?3)
	  "C-c 4"   (layout-load-fun ?4)
	  "C-c M-4" (layout-save-fun ?4)
	  "C-c 5"   (layout-load-fun ?5)
	  "C-c M-5" (layout-save-fun ?5)
	  "C-c 6"   (layout-load-fun ?6)
	  "C-c M-6" (layout-save-fun ?6)
	  "C-c 7"   (layout-load-fun ?7)
	  "C-c M-7" (layout-save-fun ?7)
	  "C-c 8"   (layout-load-fun ?8)
	  "C-c M-8" (layout-save-fun ?8)
	  "C-c 9"   (layout-load-fun ?9)
	  "C-c M-9" (layout-save-fun ?9)
	  "C-c 0"   (layout-load-fun ?0)
	  "C-c M-0" (layout-save-fun ?0))
					; In a way, the only thing
					; that is needed is to hook
					; into the "create other
					; window" hook and save the
					; previous layout and the new
					; 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)
 '(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.
 )