;; -*- emacs-lisp -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; $Id: lisp.el,v 1.15 2006/03/06 12:07:06 ole Exp $
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; (Emacs) Lisp programming settings
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require 'cl)
(require 'parenface)
(require 'mic-paren)
(require 'paredit)
(require 'hl-sexp)

(paren-activate)
(setf paren-priority 'close)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Inferior Lisp & Slime
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; (setq inferior-lisp-program "/usr/bin/lisp")
;; (setq inferior-lisp-program "clisp -K full")
;; (setq inferior-lisp-program "/usr/bin/sbcl --noinform --no-linedit")
(require 'outline)
(require 'slime)

(setq slime-lisp-implementations
      '((sbcl ("/usr/bin/sbcl" "--noinform") :coding-system iso-latin-1-unix)
        (cmucl ("/usr/bin/lisp") :coding-system iso-latin-1-unix)
        (clisp ("/usr/bin/clisp" "-K" "full") :coding-system utf-8-unix)))

(slime-setup :autodoc t)

(setq slime-complete-symbol-function 'slime-complete-symbol*
      common-lisp-hyperspec-root "file:///usr/share/doc/hyperspec-7.0/HyperSpec/"
      slime-sbcl-manual-root "file:///usr/share/doc/sbcl-0.9.14/html/sbcl/"
      slime-startup-animation nil
      slime-kill-without-query-p t
      slime-enable-evaluate-in-emacs t
      slime-ed-use-dedicated-frame nil)

(defun oa:basic-lisp-mode-hook ()
  (paredit-mode 1)
  ;;  (hl-sexp-mode 1)
  (set-fill-column 80)
  (auto-fill-mode 1))

(defun oa:emacs-lisp-mode-hook ()
  (oa:basic-lisp-mode-hook)
  (eldoc-mode 1))

(defun oa:common-lisp-mode-hook ()
  (oa:basic-lisp-mode-hook)
  (set (make-local-variable 'lisp-indent-function)
       'common-lisp-indent-function))


(add-hook 'lisp-mode-hook #'oa:common-lisp-mode-hook)
(add-hook 'emacs-lisp-mode-hook #'oa:emacs-lisp-mode-hook)

(def-slime-selector-method ?a "interactive emacs lisp REPL buffer."
  (or (get-buffer "*ielm*")
      (progn (ielm)
             (get-buffer "*ielm*"))))

(def-slime-selector-method ?w "emacs lisp scratch buffer."
  (get-buffer-create "*scratch*"))

(defun oa:end-of-defun (&optional arg)
  "Move to end of defun leaving point directly after the closing paren."
  (interactive "p")
  (forward-char 1)
  (end-of-defun arg)
  (backward-char 1))

(defun oa:reformat-defun ()
  "Reformat trailing parentheses Lisp-stylishly and reindent toplevel form."
  (interactive)
  (save-excursion
    (oa:end-of-defun)
    (slime-close-all-sexp)
    (slime-reindent-defun)))

(defun oa:close-all-sexp-and-reindent (&optional region)
  "Balance parentheses of open s-expressions at point.
Insert enough right parentheses to balance unmatched left parentheses.
Delete extra left parentheses.  Reformat trailing parentheses 
Lisp-stylishly."
  (interactive)
  (slime-close-all-sexp region)
  (newline-and-indent)
  (slime-reindent-defun))

(defun oa:move-past-close-and-reindent ()
  "Move past the closing paren and reindent. "
  (interactive)
  (condition-case c
      (move-past-close-and-reindent)
    (error (oa:close-all-sexp-and-reindent))))

(defun oa:close-list ()
  "Move past the closing paren. At toplevel add a newline."
  (interactive)
  (delete-horizontal-space)
  (condition-case c
      (paredit-close-parenthesis)
    (scan-error (unless (looking-at "^$")
                  (slime-close-all-sexp)
                  (reindent-then-newline-and-indent)))))

(defun oa:close-list-and-newline ()
  "Move past the closing paren. At toplevel add a newline."
  (interactive)
  (delete-horizontal-space)
  (condition-case c
      (paredit-close-parenthesis-and-newline)
    (scan-error (unless (looking-at "^$")
                  (slime-close-all-sexp)
                  (reindent-then-newline-and-indent)))))

(defun oa:backward-up-list-or-backward-sexp ()
  "Move point one list up or one sexp backwards if at toplevel. "
  (interactive)
  (condition-case c
      (backward-up-list)
    (scan-error (paredit-backward))))

(defun oa:backward-down-list-or-backward-sexp ()
  "Move point one list up or one sexp backwards if at toplevel. "
  (interactive)
  (condition-case c
      (backward-down-list)
    (scan-error (paredit-backward))))

(defun oa:down-list-or-forward-sexp ()
  "Move point one list down or one sexp forward if at lowest level. "
  (interactive)
  (condition-case c
      (down-list)
    (scan-error
     (paredit-forward))))

(defun oa:mark-list (&optional arg)
  "Repeatedly select ever larger balanced expressions around the cursor.
Once you have such an expression marked, you can expand to the end of
the following expression with \\[mark-sexp] and to the beginning of the
previous with \\[backward-sexp]."
  (interactive "p")
  (condition-case c
      (progn
        (backward-up-list arg)
        (let ((end (save-excursion (forward-sexp) (point))))
          (push-mark end nil t)))
    (scan-error (mark-sexp))))

(defun oa:backward-up-list-and-kill (&optional arg)
  "Kill sexp point is in."
  (interactive "p")
  (backward-up-list arg)
  (kill-sexp))

(defun oa:insert-double-quotes (&optional arg)
  "Wrap region in double quotes if region is active, else call paredit-"
  (interactive "P")
  (if mark-active
      (insert-pair arg)
    (paredit-doublequote arg)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Keys
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(global-set-key [(control c) ?r] 'slime-selector)

(defmacro define-lisp-key (keyspec command)
  `(progn
     ,@(mapcar (lambda (map)
                 `(define-key ,map ,keyspec ,command))
               '(slime-mode-map lisp-mode-map emacs-lisp-mode-map))))

;;; tnou ou oeunthoeu nththeoun  oenuth oentuh tnh noteuh toehu tnh
;;; nthoeu noeh unth onetuh ntoehu ntoeuh nth hoenuh etou hthu oeuh he
;;; uth heu hu theu toehu hntheu oehu otehu toehu th uenthonetuh oethu
;;; tnoehu

;;;; thdoeut thdoeu toetuhd oehtud thdthdeuthd oethud thoedu thd
;;;; thdeouth ttohedu ue
;;;; das hnuhonuh oethu oehu toehu oehu tnoehu tohe uoehu toeuh oehu
;;;; oheu oheu heu hnh hneuh nthnthth thountohu oaeuh ohu noteuh noehu oehu oehu ntoehu
;;;; tnoehu nh untohu oehu ntohu ohu tohu ohu ou oehu outh  euh u onuh onuh oeu nohu
;;;; 


(defvar oa:lisp-key-bindings
  `(("C-z" ,#'yank)

    (")" ,#'oa:close-list)
    ("C-(" ,#'paredit-wrap-sexp)
    ("C-)" ,#'oa:close-list-and-newline)
    ("M-(" ,#'paredit-backward-slurp-sexp)
    ("M-)" ,#'paredit-forward-slurp-sexp)
    ("C-c )" ,#'slime-close-all-sexp)
    ("C-M-(" ,#'paredit-backward-barf-sexp)
    ("C-M-)" ,#'paredit-forward-barf-sexp)

    ("M-a" ,#'beginning-of-defun)
    ("M-e" ,#'oa:end-of-defun)

    ("C-c C-b" ,#'oa:backward-up-list-and-kill)

    ("M-f" ,#'transpose-sexps)
    ("C-M-f" ,#'transpose-words)

    ("M-'" ,#'oa:reformat-defun)
    ("C-M-S-SPC" ,#'oa:mark-list)

    ("M-h" ,#'paredit-backward)
    ("M-n" ,#'paredit-forward)
    ("M-w" ,#'down-list)
    ("M-t" ,#'backward-up-list)
    ("M-d" ,#'kill-sexp)
    ("M-b" ,#'backward-kill-sexp)
    ("M-p" ,#'slime-pop-find-definition-stack)

    ("C-M-n" ,#'forward-word)
    ("C-M-h" ,#'backward-word)
    ("C-M-w" ,#'up-list)
    ("C-M-t" ,#'backward-down-list)
    ("C-M-d" ,#'paredit-forward-kill-word)
    ("C-M-b" ,#'backward-kill-word)
    
    ("C-c RET" ,#'oa:close-all-sexp-and-reindent)
    ("M-RET" ,#'oa:move-past-close-and-reindent)
    ("<M-return>" ,#'indent-new-comment-line)
    ("RET" ,#'paredit-newline)))


(oa:setup-keys paredit-mode-map oa:dvorak-keys)
(oa:setup-keys paredit-mode-map oa:lisp-key-bindings)

(oa:setup-keys emacs-lisp-mode-map oa:lisp-key-bindings)

(oa:setup-keys slime-mode-map oa:dvorak-keys)
(oa:setup-keys slime-mode-map oa:lisp-key-bindings)

(define-key slime-mode-map [(control c) (control d) (control d)] #'slime-describe-symbol)
(define-key emacs-lisp-mode-map [(control c) (control d) (control d)] #'describe-foo-at-point)

;; (define-key paredit-mode-map (kbd "\"") 'oa:insert-double-quotes)

(dolist (binding '("RET"))
  (define-key paredit-mode-map (read-kbd-macro binding) nil))

(define-key emacs-lisp-mode-map [(tab)]
  (make-region-indent-completion-function (lisp-complete-symbol)))
(define-key lisp-mode-map [(tab)]
  (make-region-indent-completion-function (slime-complete-symbol) (lisp-indent-line)))
(define-key slime-mode-map [(tab)]
  (make-region-indent-completion-function (slime-complete-symbol) (lisp-indent-line)))

(define-key slime-mode-map [(control c) tab] 'slime-complete-form)
(define-key emacs-lisp-mode-map [(control c) (control c)] #'compile-defun)

;; in other modes f3 - f8 are for Xrefactory
;; in lisp mode use emacs documentation facilities

(define-key emacs-lisp-mode-map [(f1)] 'describe-foo-at-point)
(define-key emacs-lisp-mode-map [(control f1)] 'describe-function)
(define-key emacs-lisp-mode-map [(shift f1)] 'describe-variable)

(define-key emacs-lisp-mode-map [(f3)] 'eval-last-sexp)
(define-key emacs-lisp-mode-map [(control f3)] 'eval-buffer)
(define-key emacs-lisp-mode-map [(shift f3)] 'eval-region)

(define-key emacs-lisp-mode-map [(f5)] 'find-variable-at-point)
(define-key emacs-lisp-mode-map [(control f5)] 'find-variable)

(define-key emacs-lisp-mode-map [(f6)] 'find-function-at-point)
(define-key emacs-lisp-mode-map [(control f6)] 'find-function)
(define-key emacs-lisp-mode-map [(shift f6)] 'find-library)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Emacs Lisp programming settings
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun describe-foo-at-point ()
  "Show the documentation of the Elisp function and variable near point.
This checks in turn:

-- for a function name where point is
-- for a variable name where point is
-- for a surrounding function call
"
  (interactive)
  (let (sym)
    ;; sigh, function-at-point is too clever.  we want only the first half.
    (cond ((setq sym (ignore-errors
                       (with-syntax-table emacs-lisp-mode-syntax-table
                         (save-excursion
                           (or (not (zerop (skip-syntax-backward "_w")))
                               (eq (char-syntax (char-after (point))) ?w)
                               (eq (char-syntax (char-after (point))) ?_)
                               (forward-sexp -1))
                           (skip-chars-forward "`'")
                           (let ((obj (read (current-buffer))))
                             (and (symbolp obj) (fboundp obj) obj))))))
           (describe-function sym))
          ((setq sym (variable-at-point)) (describe-variable sym))
          ;; now let it operate fully -- i.e. also check the
          ;; surrounding sexp for a function call.
          ((setq sym (function-at-point)) (describe-function sym)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Compatibility
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(cond ((not (fboundp 'replace-regexp-in-string))

(defun replace-regexp-in-string (regexp rep string &optional
                                        fixedcase literal subexp start)
  "Replace all matches for REGEXP with REP in STRING.

Return a new string containing the replacements.

Optional arguments FIXEDCASE, LITERAL and SUBEXP are like the
arguments with the same names of function `replace-match'.  If START
is non-nil, start replacements at that index in STRING.

REP is either a string used as the NEWTEXT arg of `replace-match' or a
function.  If it is a function it is applied to each match to generate
the replacement passed to `replace-match'; the match-data at this
point are such that match 0 is the function's argument.

To replace only the first match (if any), make REGEXP match up to \\'
and replace a sub-expression, e.g.
  (replace-regexp-in-string \"\\(foo\\).*\\'\" \"bar\" \" foo foo\" nil nil 1)
    => \" bar foo\"
"

  ;; To avoid excessive consing from multiple matches in long strings,
  ;; don't just call `replace-match' continually.  Walk down the
  ;; string looking for matches of REGEXP and building up a (reversed)
  ;; list MATCHES.  This comprises segments of STRING which weren't
  ;; matched interspersed with replacements for segments that were.
  ;; [For a `large' number of replacments it's more efficient to
  ;; operate in a temporary buffer; we can't tell from the function's
  ;; args whether to choose the buffer-based implementation, though it
  ;; might be reasonable to do so for long enough STRING.]
  (let ((l (length string))
        (start (or start 0))
        matches str mb me)
    (save-match-data
      (while (and (< start l) (string-match regexp string start))
        (setq mb (match-beginning 0)
              me (match-end 0))
        ;; If we matched the empty string, make sure we advance by one char
        (when (= me mb) (setq me (min l (1+ mb))))
        ;; Generate a replacement for the matched substring.
        ;; Operate only on the substring to minimize string consing.
        ;; Set up match data for the substring for replacement;
        ;; presumably this is likely to be faster than munging the
        ;; match data directly in Lisp.
        (string-match regexp (setq str (substring string mb me)))
        (setq matches
              (cons (replace-match (if (stringp rep)
                                       rep
                                     (funcall rep (match-string 0 str)))
                                   fixedcase literal str subexp)
                    (cons (substring string start mb) ; unmatched prefix
                          matches)))
        (setq start me))
      ;; Reconstruct a string from the pieces.
      (setq matches (cons (substring string start l) matches)) ; leftover
      (apply #'concat (nreverse matches)))))
))

(if (not (fboundp 'replace-in-string))
    (defun replace-in-string (string regexp replacement &optional literal)
      "Replace regex in string with replacement"
      (replace-regexp-in-string regexp replacement string t literal)))

;; xemacs has no font-lock-add-keywords, so ignore it
(unless (fboundp 'font-lock-add-keywords)
  (defalias 'font-lock-add-keywords 'ignore))

;; unify region checking
(if (boundp 'mark-active)
    (defun mark-or-region-active ()
      "check if the region is currenty active"
      mark-active)
    (defun mark-or-region-active ()
      "check if the region is currenty active"
      zmacs-region-active-p))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;_* Indentation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(put 'defsystem 'common-lisp-indent-function '(4 2))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;_* Templates
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(push `(("\\.asd\\'" . "ASDF Skeleton") 
        "System Name: "
        ";;; -*- lisp -*-

(eval-when (:compile-toplevel :load-toplevel :execute)
  (unless (find-package #:" str ".system)
    (defpackage #:" str ".system
      (:use :common-lisp :asdf))))

(in-package #:" str ".system)

(defsystem :" str " 
  :description " ?\" (read-string "Description: ") ?\"" 
  :long-description " ?\" (read-string "Long Description: ") ?\"" 
  :version \"" (completing-read "Version: " nil nil nil "0.1") "\"
  :author \"" (user-full-name) " <" user-mail-address ">\"
  :maintainer \"" (user-full-name) " <" user-mail-address ">\"
  :licence \"" (completing-read "License: " '(("GPL" 1) ("LGPL" 2) ("LLGPL" 3) ("BSD" 4)))"\"
  :depends-on ()
  :in-order-to ((test-op (load-op : " str "-test)))
  :perform (test-op :after (op c)
                    (funcall (intern (string '#:run!) '#:it.bese.FiveAM) :" str "))
  :components ((:doc-file \"README\")
               (:static-file \"" str ".asd\")
               (:module \"src\"
                        :components ((:file \"packages\")
                                     (:file " str " :depends-on (\"packages\"))))))

(defsystem :" str "-test
  :components ((:module \"test\"
                        :components ()))
  :depends-on (:" str " :FiveAM))

(defmethod operation-done-p ((o test-op) (c (eql (find-system :" str "))))
  (values nil))
") auto-insert-alist)