;;; shim.el -- Superior Haskell Interaction Mode for Emacs
;;
;;;; License
;;     Copyright (C) 2006 Benedikt Schmidt
;;     Copyright (C) 2003  Eric Marsden, Luke Gorrie, Helmut Eller
;;     Copyright (C) 2004,2005,2006  Luke Gorrie, Helmut Eller
;;
;;     This program is free software; you can redistribute it and/or
;;     modify it under the terms of the GNU General Public License as
;;     published by the Free Software Foundation; either version 2 of
;;     the License, or (at your option) any later version.
;;     
;;     This program is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;     GNU General Public License for more details.
;;     
;;     You should have received a copy of the GNU General Public
;;     License along with this program; if not, write to the Free
;;     Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
;;     MA 02111-1307, USA.


;;;; Commentary
;;
;; This file contains extensions for programming in Haskell. SHIM is
;; only tested with the latest cvs-snapshot of GNU Emacs and ghc-6.5.
;; In order to run SHIM you have to compile and install the shim-server
;; implemented in haskell.
;;
;; The following features are implemented:
;;
;;  unix domain socket based communication/RPC interface with the
;;  shim-server which uses the GHC api for parsing haskell.
;;
;;  Module name completion.
;;  Identifier completion.
;;


;;;; Dependencies and setup
(eval-and-compile
  (require 'cl)
  (require 'comint)
  (require 'haskell-mode))

; These functions exist in Emacs 22, but must be defined for Emacs 21
(unless (fboundp 'line-number-at-pos)   
  (defun line-number-at-pos (&optional pos)
    "Return the line number at position POS, or the current line number when POS is nil."
    (1+ (count-lines (point-min) (save-excursion (when pos (goto-char pos))
                                                 (forward-line 0) (point))))))
(unless (fboundp 'move-beginning-of-line)
  (defalias 'move-beginning-of-line 'beginning-of-line))

;;;; Customize groups

(defgroup shim nil
  "Interaction with the Superior Haskell Environment."
  :prefix "shim-"
  :group 'applications)

(defcustom shim-program "shim"
  "Location of the shim program"
  :type 'string
  :group 'shim)

(defcustom shim-ghcrts-env nil
  "emacs can set GHCRTS before starting shim, use -M<size>m if shim uses too much RAM"
  :type 'string
  :group 'shim)

(defcustom shim-socket-program "shim-udproxy"
  "Location of the unix-domain-socket to stdin/stdout proxy"
  :type 'string
  :group 'shim)

(defcustom shim-ghc-program "ghc"
  "This should be the ghc version used to compile shim"
  :type 'string
  :group 'shim)

(defcustom shim-truncate-lines t
  "Set `truncate-lines' in popup buffers.
This applies to buffers that present lines as rows of data, such as
debugger backtraces and apropos listings."
  :type 'boolean
  :group 'shim)

(defcustom shim-compilation-finished-function 'shim-maybe-list-compiler-notes
  "Automatically show compiler notes after load."
  :group 'shim
  :type '(choice
          (const :tag "List only for errors not marked in a buffer"
                  shim-maybe-list-compiler-notes)
          (const :tag "Always list"
                 shim-list-compiler-notes)
          (const :tag "Never show list"
                 shim-never-list-compiler-notes)))

(defcustom shim-complete-thing-function 'shim-fuzzy-complete-thing
  "Function to perform completion."
  :group 'shim
  :type '(choice (const :tag "Simple" shim-simple-complete-thing)
                 (const :tag "Fuzzy" shim-fuzzy-complete-thing)))

;;;;; shim-mode-faces

(defgroup shim-mode-faces nil
  "Faces in shim-mode source code buffers."
  :prefix "shim-"
  :group 'shim-mode)

(defun shim-underline-color (color)
  "Return a legal value for the :underline face attribute based on COLOR."
  ;; In XEmacs the :underline attribute can only be a boolean.
  ;; In GNU it can be the name of a colour.
  (if (featurep 'xemacs)
      (if color t nil)
    color))

(defface shim-error-face
  `((((class color) (background light))
     (:underline ,(shim-underline-color "red")))
    (((class color) (background dark))
     (:underline ,(shim-underline-color "red")))
    (t (:underline t)))
  "Face for errors from the compiler."
  :group 'shim-mode-faces)

(defface shim-fatal-face
  `((((class color) (background light))
     (:underline ,(shim-underline-color "red")))
    (((class color) (background dark))
     (:underline ,(shim-underline-color "red")))
    (t (:underline t)))
  "Face for errors from the compiler."
  :group 'shim-mode-faces)

(defface shim-warning-face
  `((((class color) (background light))
     (:underline ,(shim-underline-color "orange")))
    (((class color) (background dark))
     (:underline ,(shim-underline-color "coral")))
    (t (:underline t)))
  "Face for warnings from the compiler."
  :group 'shim-mode-faces)

(defface shim-info-face
  `((((class color) (background light))
     (:underline ,(shim-underline-color "brown4")))
    (((class color) (background dark))
     (:underline ,(shim-underline-color "light goldenrod")))
    (t (:underline t)))
  "Face for notes from the compiler."
  :group 'shim-mode-faces)

(defun shim-face-inheritance-possible-p ()
  "Return true if the :inherit face attribute is supported." 
  (assq :inherit custom-face-attributes))

(defface shim-highlight-face
  (if (shim-face-inheritance-possible-p)
      '((t (:inherit highlight :underline nil)))
    '((((class color) (background light))
       (:background "darkseagreen2"))
      (((class color) (background dark))
       (:background "darkolivegreen"))
      (t (:inverse-video t))))
  "Face for compiler notes while selected."
  :group 'shim-mode-faces)



;;;; Setup initial `shim-mode' hooks

(make-variable-buffer-local
 (defvar shim-pre-command-actions nil
   "List of functions to execute before the next Emacs command.
This list of flushed between commands."))

(defun shim-pre-command-hook ()
  "Execute all functions in `shim-pre-command-actions', then NIL it."
  (dolist (undo-fn shim-pre-command-actions)
    (ignore-errors (funcall undo-fn)))
  (setq shim-pre-command-actions nil))

(defun shim-post-command-hook ()
  (when (null pre-command-hook) ; sometimes this is lost
    (add-hook 'pre-command-hook 'shim-pre-command-hook)))

(defun shim-setup-command-hooks ()
  "Setup a buffer-local `pre-command-h'ook' to call `shim-pre-command-hook'."
  (make-local-hook 'pre-command-hook)
  (make-local-hook 'post-command-hook)
  ;; alanr: need local t
  (add-hook 'pre-command-hook 'shim-pre-command-hook nil t) 
  (add-hook 'post-command-hook 'shim-post-command-hook nil t))


;;;; Utility functions/macros

;;;;; Syntactic sugar

(defmacro destructure-case (value &rest patterns)
  "Dispatch VALUE to one of PATTERNS.
A cross between `case' and `destructuring-bind'.
The pattern syntax is:
  ((HEAD . ARGS) . BODY)
The list of patterns is searched for a HEAD `eq' to the car of
VALUE. If one is found, the BODY is executed with ARGS bound to the
corresponding values in the CDR of VALUE."
  (let ((operator (gensym "op-"))
	(operands (gensym "rand-"))
	(tmp (gensym "tmp-")))
    `(let* ((,tmp ,value)
	    (,operator (car ,tmp))
	    (,operands (cdr ,tmp)))
       (case ,operator
	 ,@(mapcar (lambda (clause)
                     (if (eq (car clause) t)
                         `(t ,@(cdr clause))
                       (destructuring-bind ((op &rest rands) &rest body) clause
                         `(,op (destructuring-bind ,rands ,operands
                                 . ,body)))))
		   patterns)
	 ,@(if (eq (caar (last patterns)) t)
	       '()
	     `((t (error "destructure-case failed: %S" ,tmp))))))))

(put 'destructure-case 'lisp-indent-function 1)

(defmacro* when-let ((var value) &rest body)
  "Evaluate VALUE, and if the result is non-nil bind it to VAR and
evaluate BODY.

\(fn (VAR VALUE) &rest BODY)"
  `(let ((,var ,value))
     (when ,var ,@body)))

(put 'when-let 'lisp-indent-function 1)

(defmacro* with-struct ((conc-name &rest slots) struct &body body)
  "Like with-slots but works only for structs.
\(fn (CONC-NAME &rest SLOTS) STRUCT &body BODY)"
  (flet ((reader (slot) (intern (concat (symbol-name conc-name)
					(symbol-name slot)))))
    (let ((struct-var (gensym "struct")))
      `(let ((,struct-var ,struct))
	 (symbol-macrolet
	     ,(mapcar (lambda (slot)
			(etypecase slot
			  (symbol `(,slot (,(reader slot) ,struct-var)))
			  (cons `(,(first slot) (,(reader (second slot)) 
                                                  ,struct-var)))))
		      slots)
	   . ,body)))))

(put 'with-struct 'lisp-indent-function 2)

;;;;; Very-commonly-used functions

(defun shim-message (format-string &rest format-args)
  "Like `message' but with special support for typeout frames.
Uses the support for multiline messages in GNU Emacs21, see
Slime code for an implementation that supports XEmacs and Emacs20."
  (if (shim-typeout-active-p)
      (apply #'shim-typeout-message format-string format-args)
      (apply 'message format-string format-args)))

(defun shim-background-message (format-string &rest format-args)
  "Display a message in passing.
This is like `shim-message', but less distracting because it
will never pop up a buffer or display multi-line messages.
It should be used for \"background\" messages such as argument lists."
  (if (shim-typeout-active-p)
      (shim-typeout-message format-string format-args))
    (let* ((msg (apply #'format format-string format-args)))
      (unless (minibuffer-window-active-p (minibuffer-window))
        (message  "%s" (shim-oneliner msg)))))

(defun shim-oneliner (string)
  "Return STRING truncated to fit in a single echo-area line."
  (substring string 0 (min (length string)
                           (or (position ?\n string) most-positive-fixnum)
                           (1- (frame-width)))))

(defun shim-set-truncate-lines ()
  "Apply `shim-truncate-lines' to the current buffer."
  (when shim-truncate-lines
    (set (make-local-variable 'truncate-lines) t)))

(defun* shim-define-key (key command &key prefixed inferior)
  "Define a keybinding of KEY for COMMAND.
If PREFIXED is non-nil, `shim-prefix-key' is prepended to KEY.
If INFERIOR is non-nil, the key is also bound for `inferior-shim-mode'."
  (when prefixed
    (setq key (concat shim-prefix-key key)))
  (define-key shim-mode-map key command)
  (when inferior
    (define-key inferior-shim-mode-map key command)))

(defmacro shim-define-keys (keymap &rest key-command)
  "Define keys in KEYMAP. Each KEY-COMMAND is a list of (KEY COMMAND)."
  `(progn . ,(mapcar (lambda (k-c) `(define-key ,keymap . ,k-c))
		     key-command)))

(defun shim-filter-buffers (predicate)
  "Return a list of where PREDICATE returns true.
PREDICATE is executed in the buffer to test."
  (remove-if-not (lambda (%buffer)
                   (with-current-buffer %buffer
                     (funcall predicate)))
                 (buffer-list)))

(defun shim-windows-p ()
  (or (eq system-type 'cygwin32)
      (eq system-type 'cygwin)
      (eq system-type 'windows-nt)))

(defun shim-cygwin-p ()
  (or (eq system-type 'cygwin32)
      (eq system-type 'cygwin)))

(defun shim-emacs-20-p ()
  (and (not (featurep 'xemacs))
       (= emacs-major-version 20)))

(defun shim-run-when-idle (function &rest args)
  "Call FUNCTION as soon as Emacs is idle."
  (apply #'run-at-time 
         (if (featurep 'xemacs) itimer-short-interval 0) 
         nil function args))


;;;; Typeout frame

;; When a "typeout frame" exists it is used to display certain
;; messages instead of the echo area or pop-up windows.

(defvar shim-typeout-window nil
  "The current typeout window.")

(defvar shim-typeout-frame-properties
  '((height . 10) (minibuffer . nil))
  "The typeout frame properties (passed to `make-frame').")

(defun shim-typeout-active-p ()
  (and shim-typeout-window
       (window-live-p shim-typeout-window)))

(defun shim-typeout-message (format-string &rest format-args)
  (assert (shim-typeout-active-p))
  (with-current-buffer (window-buffer shim-typeout-window)
    (erase-buffer)
    (insert (apply #'format format-string format-args))))

(defun shim-make-typeout-frame ()
  "Create a frame for displaying messages (e.g. arglists)."
  (interactive)
  (let ((frame (make-frame shim-typeout-frame-properties)))
    (save-selected-window
      (select-window (frame-selected-window frame))
      (switch-to-buffer "*SHIM-Typeout*")
      (setq shim-typeout-window (selected-window)))))

(defun shim-ensure-typeout-frame ()
  "Create the typeout frame unless it already exists."
  (interactive)
  (unless (shim-typeout-active-p)
    (shim-make-typeout-frame)))

;;;;; Temporary popup buffers

(make-variable-buffer-local
 (defvar shim-temp-buffer-saved-window-configuration nil
   "The window configuration before the temp-buffer was displayed.
Buffer local in temp-buffers."))

(make-variable-buffer-local
 (defvar shim-temp-buffer-fingerprint nil
   "The window config \"fingerprint\" after displaying the buffer."))

;; Interface
(defun* shim-get-temp-buffer-create (name &key mode noselectp reusep)
  "Return a fresh temporary buffer called NAME in MODE.
The buffer also uses the minor-mode `shim-temp-buffer-mode'. Pressing
`q' in the buffer will restore the window configuration to the way it
is when the buffer was created, i.e. when this function was called.

If NOSELECTP is true, then the buffer is shown by `display-buffer',
otherwise it is shown and selected by `pop-to-buffer'.

If REUSEP is true and a buffer does already exist with name NAME,
then the buffer will be reused instead of being killed."
  (let ((window-config (current-window-configuration)))
    (when (and (get-buffer name) (not reusep)) (kill-buffer name))
    (with-current-buffer (get-buffer-create name)
      (when mode (funcall mode))
      (shim-temp-buffer-mode 1)
      (setq shim-temp-buffer-saved-window-configuration window-config)
      (let ((window (if noselectp
                        (display-buffer (current-buffer) t)
                      (pop-to-buffer (current-buffer))
                      (selected-window))))
        (setq shim-temp-buffer-fingerprint (shim-window-config-fingerprint)))
      (current-buffer))))

(define-minor-mode shim-temp-buffer-mode 
  "Mode for displaying read only stuff"
  nil
  " temp"
  '(("q" . shim-temp-buffer-quit)))

;; Interface
(defun shim-temp-buffer-quit ()
  "Kill the current buffer and restore the old window configuration.
See `shim-temp-buffer-dismiss'."
  (interactive)
  (let ((buf (current-buffer)))
    (shim-dismiss-temp-buffer)
    (kill-buffer buf)))

;; Interface
(defun shim-dismiss-temp-buffer ()
  "Dismiss the current temp buffer and restore previous window config.
Don't change the window configuration if it has been significantly
changed since the temp buffer was displayed."
  (when (equalp (shim-window-config-fingerprint)
                shim-temp-buffer-fingerprint)
    (set-window-configuration shim-temp-buffer-saved-window-configuration)))

(defun shim-window-config-fingerprint (&optional frame)
  "Return a fingerprint of the current window configuration.
Fingerprints are `equalp' if and only if they represent window
configurations that are very similar (same windows and buffers.)

Unlike window-configuration objects fingerprints are not sensitive to
the point moving and they can't be restored."
  (mapcar (lambda (window) (list window (window-buffer window)))
          (shim-frame-windows frame)))

(defun shim-frame-windows (&optional frame)
  "Return the list of windows in FRAME."
  (loop with last-window = (previous-window (frame-first-window frame))
        for window = (frame-first-window frame) then (next-window window)
        collect window
        until (eq window last-window)))


;;;; Process Handling
(defvar shim-process nil)

(defvar shim-socket-process nil)

(defun* shim ()
  (interactive)
  (when (or shim-process shim-socket-process)
    (if (y-or-n-p "Restart shim-server process? ")
        (progn
          (when shim-process
            (set-process-sentinel shim-process nil)
            (kill-buffer (process-buffer shim-process)))
          (when shim-socket-process
            (set-process-sentinel shim-socket-process nil)
            (kill-buffer (process-buffer shim-socket-process)))
          (setq shim-process nil)
          (setq shim-socket-process nil))
        (return-from 'shim)))
  
  (destructuring-bind (socket-file-or-port log-file)
      (shim-socket-and-log-file)
    (shim-message "using %s as log file" log-file)
    (let* ((proc1 (shim-server-start shim-program
                                     (list socket-file-or-port log-file
                                           shim-ghc-program)))
           (proc2 (wait-for-socket
                   socket-file-or-port
                   #'(lambda ()
                       (shim-socket-start socket-file-or-port)))))
      (shim-message "shim-server started")
      (setq shim-process proc1)
      (setq shim-socket-process proc2))))

(defun shim-connect (socket-file)
  (interactive "Fsocketfile: ")
  (let ((socket-file (expand-file-name socket-file)))
    (when (or shim-process shim-socket-process)
      (if (y-or-n-p "close existing connection? ")
          (progn
            (when shim-process
              (set-process-sentinel shim-process nil)
              (kill-buffer (process-buffer shim-process)))
            (when shim-socket-process
              (set-process-sentinel shim-socket-process nil)
              (kill-buffer (process-buffer shim-socket-process)))
            (setq shim-process nil)
            (setq shim-socket-process nil))
          (return-from 'shim)))
    (let* ((proc2 (shim-socket-start socket-file)))
      (shim-message "shim-socket  connected")
      (setq shim-socket-process proc2))))

(defun wait-for-socket (filename f)
  ;; ToDo: really wait for socket
  (if (shim-windows-p)
    (sleep-for 1.0)
    (while (not (file-exists-p filename))
      (sleep-for 0.1)))
  (funcall f))

(defun shim-server-start (program program-args)  
  (when shim-ghcrts-env
    (setenv "GHCRTS" shim-ghcrts-env))
  (with-current-buffer (get-buffer-create " *shim*")
    (comint-mode)
    (comint-exec (current-buffer) "shim-server" program nil program-args)
    (when shim-ghcrts-env
      (setenv "GHCRTS" nil))
    (let ((proc (get-buffer-process (current-buffer))))
      (set-process-filter proc 'shim-process-filter)
      (set-process-sentinel proc 'shim-process-sentinel)
      proc)))

(defun shim-strip-newline (s)
  (when (equal ?\n (elt s (1- (length s))))
    (substring s 0 (1- (length s)))))

(defun maybe-translate-path-from-cygwin (path)
  (if (shim-cygwin-p)
      (progn
        (setenv "SHIM_ARG" path)
        (shim-strip-newline 
         (shell-command-to-string "cygpath -w \"$SHIM_ARG\"")))
      path))

(defun maybe-translate-path-to-cygwin (path)
  (if (shim-cygwin-p)
      (progn
        (setenv "SHIM_ARG" path)
        (shim-strip-newline
         (shell-command-to-string "cygpath -u \"$SHIM_ARG\"")))
      path))

(defun shim-socket-and-log-file ()
  (let* ((shim-dir (expand-file-name "~/.shim/")))
    (unless (file-directory-p shim-dir)
      (make-directory shim-dir nil)
      ;; 448 is 0o700
      (unless (shim-windows-p)
        (set-file-modes shim-dir 448)))
    (list
     (if (shim-windows-p)
         "3456"                         ; for win32, a port number
         (make-temp-name (concat shim-dir "io-")))
     (maybe-translate-path-from-cygwin (make-temp-name (concat shim-dir "log-"))))))

(defun shim-socket-start (file-or-port)
  (if (shim-windows-p)
      (shim-net-connect "127.0.0.1" (string-to-number file-or-port))
      (shim-connect-udproxy shim-socket-program file-or-port)))


(defun shim-connect-udproxy (program socket)
  (unless (file-exists-p socket)
    (error "shim socket does not exist"))
  (with-current-buffer (get-buffer-create " *shim-io*")
    (comint-mode)
    (comint-exec (current-buffer) "shim-socket" program nil (list socket))
    (let ((proc (get-buffer-process (current-buffer))))
      (set-process-filter proc 'shim-socket-filter)
      (set-process-sentinel proc 'shim-socket-sentinel)
      proc)))

;;; Interface
(defun shim-net-connect (host port)
  "Establish a connection with a CL."
  (let* ((inhibit-quit nil)
         (proc (open-network-stream "SHIM" nil host port))
         (buffer (shim-make-net-buffer " *shim-connection*")))
    (set-process-buffer proc buffer)
    (set-process-filter proc 'shim-socket-filter)
    (set-process-sentinel proc 'shim-socket-sentinel)
    proc))

(defun shim-make-net-buffer (name)
  "Make a buffer suitable for a network process."
  (let ((buffer (generate-new-buffer name)))
    (with-current-buffer buffer
      (buffer-disable-undo))
    buffer))

(defun shim-process-sentinel (process message)
  (shim-message "shim-server exited unexpectedly: %s" message)
  (when shim-process
    (kill-buffer (process-buffer shim-process))
    (setq shim-process nil)))

(defun shim-socket-sentinel (process message)
  (shim-message "shim-socket exited unexpectedly: %s" message)
  (when shim-socket
    (kill-buffer (process-buffer shim-socket))
    (setq shim-socket nil)))

(defun shim-server-close (process)
  (delete-process process))

(defun shim-server-read ()
  "Read a message from the network buffer."
  (goto-char (point-min))
  (let* ((length (shim-decode-length
                  (buffer-substring-no-properties (point) (+ (point) 6))))
         (start (+ 6 (point)))
         (end (+ start length)))
    (assert (plusp length))
    (let ((string (buffer-substring-no-properties start end)))
      (prog1 (read string)
        (delete-region (point-min) end)))))


(defun shim-server-have-input-p ()
  "Return true if a complete message is available."
  (goto-char (point-min))
  (and (>= (buffer-size) 6)
       (>= (- (buffer-size) 6)
           (shim-decode-length
            (buffer-substring-no-properties (point) (+ (point) 6))))))

(defun shim-decode-length (str)
  "Read a 24-bit hex-encoded integer from buffer."
  (string-to-number str 16))

(defun shim-server-send (sexp)
  "Send a SEXP to Lisp over the socket PROC.
This is the lowest level of communication. The sexp will be READ and
EVAL'd by Lisp."
  (unless shim-socket-process
    (error "can't send message, there is no shim-server running"))
  (let* ((msg (concat (shim-prin1-to-string sexp) "\n"))
         (string (concat (shim-encode-length (length msg)) msg)))
    (process-send-string shim-socket-process string)))

(defun shim-prin1-to-string (sexp)
  "Like `prin1-to-string' but don't octal-escape non-ascii characters.
This is more compatible with the CL reader."
  (with-temp-buffer
    (let ((print-escape-nonascii nil)
          (print-escape-newlines nil))
      (prin1 sexp (current-buffer))
      (buffer-string))))

(defun shim-encode-length (n)
  (format "%06x" n))

(defun shim-socket-filter (proc str)
  (with-current-buffer (process-buffer proc)
    (goto-char (point-max))
    (insert str))
  (shim-process-available-input proc))

(defun shim-process-filter (proc str)
  (when (shim-ghci-buffer)
    (with-current-buffer (shim-ghci-buffer)
      (insert str))))

(defun shim-process-available-input (process)
  "Process all complete messages that have arrived from shim-server."
  (with-current-buffer (process-buffer process)
    (when (shim-server-have-input-p)
      (let ((event (shim-server-read)))
	(shim-dispatch-event event)
;;     (let ((ok nil))
;;           (unwind-protect
;;               (save-current-buffer 
;;                 (shim-dispatch-event event process)
;;                 (setq ok t))
;;             (unless ok 
;;               (shim-run-when-idle 
;;                'shim-process-available-input process))))
	))))


;;;; Communication/RPC

;;; `shim-rex' is the RPC primitive which is used to implement both
;;; `shim-eval' and `shim-eval-async'. You can use it directly if
;;; you need to, but the others are usually more convenient.

(defmacro* shim-rex ((&rest saved-vars)
                      (sexp)
                      &rest continuations)
  "(shim-rex (VAR ...) (SEXP &optional PACKAGE THREAD) CLAUSES ...)

Remote EXecute SEXP.

VARs are a list of saved variables visible in the other forms.  Each
VAR is either a symbol or a list (VAR INIT-VALUE).

SEXP is evaluated and the princed version is sent to Lisp.

PACKAGE is evaluated and Lisp binds *BUFFER-PACKAGE* to this package.
The default value is (shim-current-package).

CLAUSES is a list of patterns with same syntax as `destructure-case'.
The result of the evaluation is dispatched on CLAUSES.  The result is
either a sexp of the form (:ok VALUE) or (:abort).  CLAUSES is
executed asynchronously.

Note: don't use backquote syntax for SEXP, because Emacs20 cannot
deal with that."
  (let ((result (gensym)))
    `(lexical-let ,(loop for var in saved-vars
                         collect (etypecase var
                                   (symbol (list var var))
                                   (cons var)))
       (shim-dispatch-event 
        (list :emacs-rex ,sexp
              (lambda (,result)
                (destructure-case ,result
                  ,@continuations)))))))

(put 'shim-rex 'lisp-indent-function 2)


(defvar shim-stack-eval-tags nil
  "List of stack-tags of continuations waiting on the stack.")

(defvar shim-rex-continuations nil
  "list of (ID . FUNCTION) continuations waiting for RPC results")

(defvar shim-rex-times nil
  "list of (ID . (msb-secs lsb-secs milisecs) with the request time")

(defvar shim-debug-times nil "show how long the RPCs take")

(defvar shim-rex-continuation-counter 0
  "continuation serial counter")


(defun shim-eval (sexp)
  (when-let (process shim-socket-process)
    (let* ((tag (gensym (format "shim-result-%d-" 
                                (1+ shim-rex-continuation-counter))))
	 (shim-stack-eval-tags (cons tag shim-stack-eval-tags)))
    (apply
     #'funcall 
     (catch tag
       (shim-rex (tag sexp)
           (sexp)
         ((:ok value)
          (unless (member tag shim-stack-eval-tags)
            (message "error")
            (error "tag = %S eval-tags = %S sexp = %S"
                   tag shim-stack-eval-tags sexp))
          (throw tag (list #'identity value)))
         ((:abort msg)
          (throw tag (list #'error
                           (format "Synchronous Lisp Evaluation aborted: %S" msg)))))
        (loop for i=1 upto 10000 do
             (accept-process-output nil 0 10000)))))))

(defun shim-eval-async (sexp &optional cont)
  "Evaluate EXPR and call CONT with the result."
  (shim-rex (cont)
      (sexp)
    ((:ok result) 
     (when cont (funcall cont result)))
    ((:abort msg) 
     (shim-message "Evaluation aborted: %S" msg))))

(defun shim-dispatch-event (event)
  (destructure-case event
    ((:emacs-rex form continuation)
     (let ((id (incf shim-rex-continuation-counter)))
       (push (cons id continuation) shim-rex-continuations)
       (push (cons id (current-time)) shim-rex-times)
       (shim-server-send `(:emacs-rex ,id ,form))))
    ((:return value id)
     (let ((rec (assq id shim-rex-continuations))
           (time (assq id shim-rex-times)))
       (cond (rec
              (setf shim-rex-continuations
                    (remove rec shim-rex-continuations))
              (when time
                (when shim-debug-times
                  (destructuring-bind (id msb-sec1 lsb-sec1 ms1) time
                    (destructuring-bind (msb-sec2 lsb-sec2 ms2) (current-time)
                      (let* ((micro 1000000)
                             (msdiff (- (+ (* micro lsb-sec2) ms2)
                                        (+ (* micro lsb-sec1) ms1))))
                        (shim-message "RPC took %d.%06d sec"
                                      (/ msdiff micro)
                                      (mod msdiff micro))))))
                (setf shim-rex-times (remove time shim-rex-times)))
              (funcall (cdr rec) value))
             (t
              (error "Unexpected reply: %S %S" id value)))))))


;;;; Commands

(defun shim-quit ()
  (interactive)
  (shim-eval `(quit)))

(defun shim-fuzzy-complete-module (name)
  (interactive "MModule: ")
  (let ((filename (buffer-file-name)))
    (shim-eval `(fuzzy-complete-module ,filename ,name))))

(defun shim-simple-complete-module (name)
  (interactive "MModule: ")
  (let ((filename (buffer-file-name)))
    (shim-eval `(simple-complete-module ,filename ,name))))

(defun shim-fuzzy-complete-identifier (name)
  (interactive "MIdentifier: ")
  (let ((filename (buffer-file-name)))
    (shim-eval `(fuzzy-complete-identifier
                 ,filename ,name))))

(defun shim-simple-complete-identifier (name)
  (interactive "MIdentifier: ")
  (let ((filename (buffer-file-name)))
    (shim-eval `(simple-complete-identifier
                 ,filename ,name))))

(defun shim-lookup-type-pos (line col)
  (let ((filename (buffer-file-name)))
    (shim-eval `(lookup-type ,filename ,line ,col
                             ,(if (buffer-modified-p)
                                  (list (shim-buffer-text))
                                  '())))))

(defun shim-search-backward-toplevel-def ()
  (save-excursion
    (end-of-line)
    (search-backward-regexp "^[a-zA-Z]")
    (values (line-number-at-pos) 0 (point))))

(defun shim-test-unexpected-exc ()
  (interactive)
  (shim-eval `(test-unexpected-exc)))

(defun shim-lookup-type-toplevel ()
  (interactive)
  (multiple-value-bind (line col point) (shim-search-backward-toplevel-def)
    (shim-message (shim-lookup-type-pos line col))))

(defun shim-lookup-type ()
  (interactive)
  (shim-message (shim-lookup-type-pos (line-number-at-pos)
                                      (current-column))))

(defun shim-insert-type ()
  (interactive)
  (multiple-value-bind (line col point) (shim-search-backward-toplevel-def)
    (let  ((type (shim-lookup-type-pos line col)))
      (if (string-equal type "looking up type failed") ;; ToDo: real error handling
          (shim-message type)
          (save-excursion
            (goto-char point)
            (insert (format "%s\n" type)))))))

(defun shim-guess-completer (module-completer identifier-completer)
  (let* ((begline (save-excursion (move-beginning-of-line nil) (point)))
         (line (buffer-substring-no-properties begline end)))
    (if (string-match "^import " line)
        module-completer
        identifier-completer)))

(defun shim-get-module-exports (module prefix)
  (let ((filename (buffer-file-name)))
    (shim-eval `(get-module-exports ,filename ,module ,prefix))))

(defun shim-buffer-needs-preprocessing ()
  (interactive)
  (car
   (shim-eval `(buffer-needs-preprocessing
                ,(shim-buffer-filename-maybe-translated)
                ,(shim-buffer-text)))))

(defun shim-ask-save-preprocessing ()
  (when (shim-buffer-needs-preprocessing)
    (save-some-buffers nil
                       (lambda ()
                         (and (equalp major-mode 'haskell-mode)
                              (not (null buffer-file-name)))))))

(defun shim-buffer-filename-maybe-translated ()
  (maybe-translate-path-from-cygwin (buffer-file-name)))

(defun shim-load-buffer ()
  (interactive)
  (shim-ask-save-preprocessing)
  (let* ((filename (shim-buffer-filename-maybe-translated))
         (res (shim-eval `(load-file ,filename ,(if (buffer-modified-p)
                                                    (list (shim-buffer-text))
                                                    '())))))
    (shim-handle-load-finished res)))

(defun shim-load-buffer-async ()
  (interactive)
  (shim-ask-save-preprocessing)
  (let* ((filename (shim-buffer-filename-maybe-translated)))
    (shim-eval-async `(load-file ,filename ,(if (buffer-modified-p)
                                                (list (shim-buffer-text))
                                                '()))
                     #'shim-handle-load-finished)))

(defun shim-handle-load-finished (res)
  (destructure-case res
    ((file-compiled notes)
     (%shim-handle-load-finished notes "Compilation successful"))
    ((compilation-failed notes)
     (%shim-handle-load-finished notes "Compilation failed"))
    ((compilation-exception msg notes)
     (%shim-handle-load-finished
      notes
      (format "Unexpected error while trying the second compile: %S" msg)))))


(defun %shim-handle-load-finished (notes msg)
  (shim-highlight-notes notes)
  (shim-message "%s: %s" msg (shim-show-note-counts notes))
  (setq *shim-compiler-notes* notes)
  (funcall shim-compilation-finished-function notes))

(defun shim-ghci-load-file (filename)
  (interactive "MFilename: ")
  (shim-eval `(load ,filename)))

(defun shim-ghci-load-buffer ()
  (interactive)
  (let ((filename (buffer-file-name)))
    (shim-ghci-load-file filename)))

(defun shim-ghci-add-bkpt (file line col)
  (interactive)
  (destructure-case
      (shim-eval `(addBkpt ,file ,line ,col))
    ((suceeded msg)
     (shim-message msg))
    ((failed msg)
     (shim-message msg))))

(defun shim-ghci-run-command (command)
  (interactive "MCommand: ")
  (unless (bolp) (insert "\n"))
  (let ((result (shim-eval `(runCommand ,command))))
    (destructure-case result
      ((succeeded prompt msg)
       (progn
         (setq *shim-ghci-prompt-string* prompt)
         (shim-ghci-insert-prompt `(:values (,msg)))))
      ((failed msg)
       (progn
         (setq *shim-ghci-prompt-string* prompt)
         (shim-ghci-insert-prompt `(:values (,msg)))))
      ((l)
       (shim-ghci-insert-prompt `(:values (,l)))))))

(defun shim-buffer-text ()
  (buffer-substring-no-properties (point-min) (point-max)))


;;;; Compiler notes

(defvar *shim-compiler-notes*)

(defun shim-compiler-notes ()
  *shim-compiler-notes*)

(defun shim-list-compiler-notes (&optional notes)
  "Show the compiler notes NOTES in tree view."
  (interactive)
  (with-temp-message "Preparing compiler note tree..."
    (let ((notes (or notes (shim-compiler-notes))))
      (with-current-buffer
          (shim-get-temp-buffer-create "*compiler notes*"
                                        :mode 'shim-compiler-notes-mode)
        (let ((inhibit-read-only t))
          (erase-buffer)
          (when (null notes)
            (insert "[no notes]"))
          (dolist (tree (shim-compiler-notes-to-tree notes))
            (shim-tree-insert tree "")
            (insert "\n")))
        (setq buffer-read-only t)
        (goto-char (point-min))))))

(defun shim-length> (list n)
  "Test if (length LIST) is greater than N."
  (while (and (> n 0) list)
    (setq list (cdr list))
    (decf n))
  list)

(defun shim-tree-for-note (note)
  (make-shim-tree :item (shim-note.message note)
                  :plist (list 'note note)
                  :print-fn #'shim-tree-default-printer))

(defun shim-tree-for-severity (severity notes collapsed-p)
  (make-shim-tree :item (format "%s (%d)" 
                                 (shim-severity-label severity)
                                 (length notes))
                   :kids (mapcar #'shim-tree-for-note notes)
                   :collapsed-p collapsed-p))

(defun shim-compiler-notes-to-tree (notes)
  (let* ((alist (shim-alistify notes #'shim-note.severity #'eq))
         (collapsed-p (shim-length> alist 1)))
    (loop for (severity . notes) in alist
          collect (shim-tree-for-severity severity notes 
                                           collapsed-p))))

(defvar shim-compiler-notes-mode-map)

(define-derived-mode shim-compiler-notes-mode fundamental-mode 
  "Compiler Notes"
  "\\<shim-compiler-notes-mode-map>\
\\{shim-compiler-notes-mode-map}"
  (shim-set-truncate-lines))

(shim-define-keys shim-compiler-notes-mode-map
  ((kbd "RET") 'shim-compiler-notes-default-action-or-show-details)
  ([mouse-2] 'shim-compiler-notes-default-action-or-show-details/mouse)
  ("q" 'shim-compiler-notes-quit))

(defun shim-compiler-notes-default-action-or-show-details/mouse (event)
  "Invoke the action pointed at by the mouse, or show details."
  (interactive "e")
  (destructuring-bind (mouse-2 (w pos &rest _) &rest __) event
    (save-excursion
      (goto-char pos)
      (let ((fn (get-text-property (point) 
                                   'shim-compiler-notes-default-action)))
	(if fn (funcall fn) (shim-compiler-notes-show-details))))))

(defun shim-compiler-notes-default-action-or-show-details ()
  "Invoke the action at point, or show details."
  (interactive)
  (let ((fn (get-text-property (point) 'shim-compiler-notes-default-action)))
    (if fn (funcall fn) (shim-compiler-notes-show-details))))

(defun shim-compiler-notes-quit ()
  (interactive)
  (let ((config shim-temp-buffer-saved-window-configuration))
    (kill-buffer (current-buffer))
    (set-window-configuration config)))

(defun shim-compiler-notes-show-details ()
  (interactive)
  (let* ((tree (shim-tree-at-point))
         (note (plist-get (shim-tree.plist tree) 'note))
         (inhibit-read-only t))
    (cond ((not (shim-tree-leaf-p tree))
           (shim-tree-toggle tree))
          (t
           (shim-show-source-location (shim-note.span note))))))

(defun shim-show-source-location (source-location)
  (shim-goto-source-location source-location)
  (shim-show-buffer-position (point)))

(defun shim-show-buffer-position (position)
  "Ensure sure that the POSITION in the current buffer is visible."
  (save-selected-window
    (let ((w (select-window (or (get-buffer-window (current-buffer) t)
                                (display-buffer (current-buffer) t)))))
      (goto-char position)
      (push-mark)
      (unless (pos-visible-in-window-p)
        (shim-recenter-window w nil)))))

(defun shim-recenter-window (window line)
  "Set window-start in WINDOW LINE lines before point."
  (let* ((line (if (not line)
                   (/ (window-height window) 2)
                 line))
         (start (save-excursion
                  (loop repeat line do (forward-line -1))
                  (point))))
    (set-window-start window start)))

(defun shim-goto-source-location (location)
  (destructure-case location
    ((:span filename-ut line col _ _)
     (let ((filename (maybe-translate-path-to-cygwin filename-ut)))
       (shim-message "file: %s line: %d" filename line)
       (set-buffer (find-file-noselect filename t))
       (goto-line line)
       (move-to-column col)))
    ((:loc filename-ut line col)
     (let ((filename (maybe-translate-path-to-cygwin filename-ut)))
       (set-buffer (find-file-noselect filename t))
       (goto-line line)
       (move-to-column col)))
    (t
     (shim-message "no location"))))

(defun shim-alistify (list key test)
  "Partition the elements of LIST into an alist.  KEY extracts the key
from an element and TEST is used to compare keys."
  (declare (type function key))
  (let ((alist '()))
    (dolist (e list)
      (let* ((k (funcall key e))
	     (probe (assoc* k alist :test test)))
	(if probe
	    (push e (cdr probe))
            (push (cons k (list e)) alist))))
    ;; Put them back in order.
    (loop for (key . value) in alist
       collect (cons key (reverse value)))))

(defun shim-note-count-string (severity count &optional suppress-if-zero)
  (cond ((and (zerop count) suppress-if-zero)
         "")
        (t (format "%2d %s%s " count severity (if (= count 1) "" "s")))))

(defun shim-show-note-counts (notes &optional secs)
  (let ((nerrors 0) (nwarnings 0) (nfatals 0) (ninfos 0))
    (dolist (note notes)
      (ecase (shim-note.severity note)
	(:sev-error      (incf nerrors))
        (:sev-warning    (incf nwarnings))
        (:sev-info       (incf ninfos))
        (:sev-fatal      (incf nfatals))))
    (message "%s%s%s%s%s"
             (shim-note-count-string "error" nerrors)
             (shim-note-count-string "warning" nwarnings)
             (shim-note-count-string "fatal" nfatals t)
             (shim-note-count-string "info" ninfos)
             (if secs (format "[%s secs]" secs) ""))))

(defun shim-note.severity (note)
  (car note))

(defun shim-note.span (note)
  (cadr note))

(defun shim-note.message (note)
  (caddr note))

(defun shim-severity-label (severity)
  (ecase severity
    (:sev-warning "Warnings")
    (:sev-error "Errors")
    (:sev-info "Infos")
    (:sev-fatal "Fatal Errors")))

(defun shim-note-has-span-p (note)
  (not (null (shim-note.span note))))

(defun shim-note-is-info-p (note)
  (eq :sev-info (shim-note.severity note)))

(defun shim-merge-notes-for-display (notes)
  notes) ;; add support for merging notes that have overlappings spans later

(defun shim-maybe-list-compiler-notes (notes)
  "Show the compiler notes if appropriate."
  ;; don't pop up a buffer if all notes are already annotated in
  ;; the buffer itself
  (unless (every #'(lambda (note) (or (shim-note-has-span-p note)
                                      (shim-note-is-info-p note)))
                 notes)
    (shim-list-compiler-notes notes)))

(defun shim-never-list-compiler-notes (notes)
  "Never show the compiler notes.")


(defun shim-highlight-notes (notes)
  "Highlight compiler notes, warnings, and errors in the buffer."
  (interactive (list (shim-compiler-notes)))
  (with-temp-message "Highlighting notes..."
    (save-excursion
      (shim-remove-old-overlays)
      (mapc #'shim-overlay-note (shim-merge-notes-for-display notes)))))

(defun shim-remove-old-overlays ()
  "Delete the existing Shim overlays in the current buffer."
  (dolist (buffer (shim-filter-buffers (lambda () (shim-buffer-p))))
    (with-current-buffer buffer
      (save-excursion
        (goto-char (point-min))
        (while (not (eobp))
          (dolist (o (overlays-at (point)))
            (when (overlay-get o 'shim)
              (delete-overlay o)))
          (goto-char (next-overlay-change (point))))))))

;; ToDo: look for shim (minor?)-mode instead
(defun shim-buffer-p ()
  (string-match "hs$" (or (buffer-file-name) "")))


;;;;; Adding a single compiler note

(defun shim-overlay-note (note)
  "Add a compiler note to the buffer as an overlay.
If an appropriate overlay for a compiler note in the same location
already exists then the new information is merged into it. Otherwise a
new overlay is created."
  (multiple-value-bind (start end) (shim-choose-overlay-region note)
    (when start
      (let ((severity (shim-note.severity note))
            (message (shim-note.message note)))
        (shim-create-note-overlay note start end severity message)))))

(defun shim-create-note-overlay (note start end severity message)
  "Create an overlay representing a compiler note.
The overlay has several properties:
  FACE       - to underline the relevant text.
  SEVERITY   - for future reference, :NOTE, :STYLE-WARNING, :WARNING, or :ERROR.
  MOUSE-FACE - highlight the note when the mouse passes over.
  HELP-ECHO  - a string describing the note, both for future reference
               and for display as a tooltip (due to the special
               property name)."
  (let ((overlay (make-overlay start end)))
    (flet ((putp (name value) (overlay-put overlay name value)))
      (putp 'shim note)
      (putp 'face (shim-severity-face severity))
      (putp 'severity severity)
      (unless (shim-emacs-20-p)
	(putp 'mouse-face 'highlight))
      (putp 'help-echo message)
      overlay)))

(defun shim-choose-overlay-region (note)
  "Choose the start and end points for an overlay over NOTE.
If the location's sexp is a list spanning multiple lines, then the
region around the first element is used.
Return nil if there's no useful source location."
  (let ((span (shim-note.span note)))
    (destructure-case span
      ((:span file l1 c1 l2 c2)
       (set-buffer (find-file-noselect file t))
       (save-excursion ;; have to set the buffer first to save the right
                       ;; excursion
         (shim-goto-source-location span)
         (let ((start (point)))
           (goto-line l2)
           (move-to-column c2)
           (let ((end (point)))
             (values start
                     end)))))
      (t nil))))

(defun shim-same-line-p (pos1 pos2)
  "Return t if buffer positions POS1 and POS2 are on the same line."
  (save-excursion (goto-char (min pos1 pos2))
                  (<= (max pos1 pos2) (line-end-position))))

(defun shim-severity-face (severity)
  "Return the name of the font-lock face representing SEVERITY."
  (ecase severity
    (:sev-error    'shim-error-face)
    (:sev-fatal    'shim-fatal-face)
    (:sev-warning  'shim-warning-face)
    (:sev-info     'shim-info-face)))

(defun shim-most-severe (sev1 sev2)
  "Return the most servere of two conditions.
Severity is ordered as in the list"
  (let ((order '(:sev-info :sev-warning :sev-error :sev-fatal)))
    (if (>= (position sev1 order) 
            (position sev2 order))
        sev1
      sev2)))


;;;;; Visiting and navigating the overlays of compiler notes

(defun shim-next-note ()
  "Go to and describe the next compiler note in the buffer."
  (interactive)
  (shim-find-next-note)
  (if (shim-note-at-point)
      (shim-show-note (shim-note-at-point))
    (message "No next note.")))

(defun shim-previous-note ()
  "Go to and describe the previous compiler note in the buffer."
  (interactive)
  (shim-find-previous-note)
  (if (shim-note-at-point)
      (shim-show-note (shim-note-at-point))
    (message "No previous note.")))

(defun shim-remove-notes ()
  "Remove compiler-note annotations from the current buffer."
  (interactive)
  (shim-remove-old-overlays))

(defun shim-show-note (overlay)
  "Present the details of a compiler note to the user."
  (shim-temporarily-highlight-note overlay)
  (let ((message (get-char-property (point) 'help-echo)))
    (shim-message "%s" (if (zerop (length message)) "\"\"" message))))

(defun shim-temporarily-highlight-note (overlay)
  "Temporarily highlight a compiler note's overlay.
The highlighting is designed to both make the relevant source more
visible, and to highlight any further notes that are nested inside the
current one.

The highlighting is automatically undone before the next Emacs command."
  (lexical-let ((old-face (overlay-get overlay 'face))
                (overlay overlay))
    (push (lambda () (overlay-put overlay 'face old-face))
	  shim-pre-command-actions)
    (overlay-put overlay 'face 'shim-highlight-face)))


;;;;; Overlay lookup operations

(defun shim-note-at-point ()
  "Return the overlay for a note starting at point, otherwise NIL."
  (find (point) (shim-note-overlays-at-point)
	:key 'overlay-start))

(defun shim-note-overlay-p (overlay)
  "Return true if OVERLAY represents a compiler note."
  (overlay-get overlay 'shim))

(defun shim-note-overlays-at-point ()
  "Return a list of all note overlays that are under the point."
  (remove-if-not 'shim-note-overlay-p (overlays-at (point))))

(defun shim-find-next-note ()
  "Go to the next position with the `shim-note' text property.
Retuns true if such a position is found."
  (shim-find-note 'next-single-char-property-change))

(defun shim-find-previous-note ()
  "Go to the next position with the `shim' text property.
Returns true if such a position is found."
  (shim-find-note 'previous-single-char-property-change))

(defun shim-find-note (next-candidate-fn)
  "Seek out the beginning of a note.
NEXT-CANDIDATE-FN is called to find each new position for consideration."
  (let ((origin (point)))
    (loop do (goto-char (funcall next-candidate-fn (point) 'shim))
	  until (or (shim-note-at-point)
		    (eobp)
		    (bobp)))
    (unless (shim-note-at-point)
      (goto-char origin))))


;;;;;; Tree Widget

(defstruct (shim-tree (:conc-name shim-tree.))
  item
  (print-fn #'shim-tree-default-printer :type function)
  (kids '() :type list)
  (collapsed-p t :type boolean)
  (prefix "" :type string)
  (start-mark nil)
  (end-mark nil)
  (plist '() :type list))

(defun shim-tree-leaf-p (tree)
  (not (shim-tree.kids tree)))

(defun shim-tree-default-printer (tree)
  (princ (shim-tree.item tree) (current-buffer)))

(defun shim-tree-print-with-references (tree)
  ;; for SBCL-style references
  (shim-tree-default-printer tree)
  (when-let (note (plist-get (shim-tree.plist tree) 'note))
    (when-let (references (shim-note.references note))
      (terpri (current-buffer))
      (princ "See also:" (current-buffer))
      (terpri (current-buffer))
      (shim-tree-insert-references references))))

(defun shim-tree-insert-references (references)
  "Insert documentation references from a condition.
See SWANK-BACKEND:CONDITION-REFERENCES for the datatype."
  (loop for refs on references
        for ref = (car refs)
        do
        (destructuring-bind (where type what) ref
          ;; FIXME: this is poorly factored, and shares some code and
          ;; data with sldb that it shouldn't: notably
          ;; sldb-reference-face.  Probably the names of
          ;; sldb-reference-foo should be altered to be not sldb
          ;; specific.
          (insert "  " (sldb-format-reference-source where) ", ")
          (shim-insert-propertized (sldb-reference-properties ref)
                                    (sldb-format-reference-node what))
          (insert (format " [%s]" (shim-cl-symbol-name type)))
          (when (cdr refs)
            (terpri (current-buffer))))))

(defun shim-tree-decoration (tree)
  (cond ((shim-tree-leaf-p tree) "-- ")
	((shim-tree.collapsed-p tree) "[+] ")
	(t "-+  ")))

(defun shim-tree-insert-list (list prefix)
  "Insert a list of trees."
  (loop for (elt . rest) on list 
	do (cond (rest
		  (insert prefix " |")
		  (shim-tree-insert elt (concat prefix " |"))
                  (insert "\n"))
		 (t
		  (insert prefix " `")
		  (shim-tree-insert elt (concat prefix "  "))))))

(defun shim-tree-insert-decoration (tree)
  (insert (shim-tree-decoration tree)))

(defun shim-tree-indent-item (start end prefix)
  "Insert PREFIX at the beginning of each but the first line.
This is used for labels spanning multiple lines."
  (save-excursion
    (goto-char end)
    (beginning-of-line)
    (while (< start (point))
      (insert-before-markers prefix)
      (forward-line -1))))

(defun shim-tree-insert (tree prefix)
  "Insert TREE prefixed with PREFIX at point."
  (with-struct (shim-tree. print-fn kids collapsed-p start-mark end-mark) tree
    (let ((line-start (line-beginning-position)))
      (setf start-mark (point-marker))
      (shim-tree-insert-decoration tree)
      (funcall print-fn tree)
      (shim-tree-indent-item start-mark (point) (concat prefix "   "))
      (add-text-properties line-start (point) (list 'shim-tree tree))
      (set-marker-insertion-type start-mark t)
      (when (and kids (not collapsed-p))
        (terpri (current-buffer))
        (shim-tree-insert-list kids prefix))
      (setf (shim-tree.prefix tree) prefix)
      (setf end-mark (point-marker)))))

(defun shim-tree-at-point ()
  (cond ((get-text-property (point) 'shim-tree))
        (t (error "No tree at point"))))

(defun shim-tree-delete (tree)
  "Delete the region for TREE."
  (delete-region (shim-tree.start-mark tree)
                 (shim-tree.end-mark tree)))

(defun shim-tree-toggle (tree)
  "Toggle the visibility of TREE's children."
  (with-struct (shim-tree. collapsed-p start-mark end-mark prefix) tree
    (setf collapsed-p (not collapsed-p))
    (shim-tree-delete tree)
    (insert-before-markers " ") ; move parent's end-mark
    (backward-char 1)
    (shim-tree-insert tree prefix)
    (delete-char 1)
    (goto-char start-mark)))


;;;; The REPL

;;;;; Buffer local variables and mode definition

(make-variable-buffer-local
 (defvar shim-output-start nil
   "Marker for the start of the output for the evaluation."))

(make-variable-buffer-local
 (defvar shim-output-end nil
   "Marker for end of output. New output is inserted at this mark."))

(defun shim-reset-ghci-markers ()
  (dolist (markname '(shim-output-start
                      shim-output-end
                      shim-ghci-prompt-start-mark
                      shim-ghci-input-start-mark
                      shim-ghci-input-end-mark
                      shim-ghci-last-input-start-mark))
    (set markname (make-marker))
    (set-marker (symbol-value markname) (point)))
  (set-marker-insertion-type shim-ghci-input-end-mark t)
  (set-marker-insertion-type shim-output-end t)
  (set-marker-insertion-type shim-ghci-prompt-start-mark t))


(make-variable-buffer-local
 (defvar shim-ghci-directory-stack nil
   "The stack of default directories associated with this ghci."))

(defun shim-make-variables-buffer-local (&rest variables)
  (mapcar #'make-variable-buffer-local variables))

(shim-make-variables-buffer-local
 ;; Local variables in the GHCI buffer.
 (defvar shim-ghci-input-history '()
   "History list of strings read from the GHCI buffer.")
 
 (defvar shim-ghci-input-history-position -1
   "Newer items have smaller indices.")

 (defvar shim-ghci-prompt-start-mark)
 (defvar shim-ghci-input-start-mark)
 (defvar shim-ghci-input-end-mark)
 (defvar shim-ghci-last-input-start-mark)
 (defvar shim-ghci-old-input-counter 0
   "Counter used to generate unique `shim-ghci-old-input' properties.
This property value must be unique to avoid having adjacent inputs be
joined together."))

(defvar shim-ghci-mode-map)

(setq shim-ghci-mode-map (make-sparse-keymap))

(shim-define-keys shim-ghci-mode-map
  ("\C-m" 'shim-ghci-return)
  ("\C-j" 'shim-ghci-newline-and-indent)
;; ("\M-p" 'shim-ghci-previous-input)
;;   ((kbd "C-<up>") 'shim-ghci-previous-input)
;;   ("\M-n" 'shim-ghci-next-input)
;;   ((kbd "C-<down>") 'shim-ghci-next-input)
;;   ("\M-r" 'shim-ghci-previous-matching-input)
;;   ("\M-s" 'shim-ghci-next-matching-input)
;;   ("\C-c\C-c" 'shim-interrupt)
  )

(defun shim-ghci-mode () 
  "Major mode for interacting with a superior Lisp.
\\{shim-ghci-mode-map}"
  (interactive)
  (kill-all-local-variables)
  (setq major-mode 'shim-ghci-mode)
  (use-local-map shim-ghci-mode-map)
  ;;  (lisp-mode-variables t)
  (setq font-lock-defaults nil)
  (setq mode-name "GHCI")
  ;;  (setq shim-current-thread :ghci-thread)
  (set (make-local-variable 'scroll-conservatively) 20)
  (set (make-local-variable 'scroll-margin) 0)
  ;;  (shim-ghci-safe-load-history)
  ;;  (make-local-hook 'kill-buffer-hook)
  ;;  (add-hook 'kill-buffer-hook 'shim-ghci-safe-save-merged-history nil t)
  ;;  (add-hook 'kill-emacs-hook 'shim-ghci-save-all-histories)
  ;;  (when shim-use-autodoc-mode 
  ;;  (shim-autodoc-mode 1))
  (run-hooks 'shim-ghci-mode-hook))


;;;; Edit definition

(defvar shim-find-definition-history-ring (make-ring 20)
  "History ring recording the definition-finding \"stack\".")

(defun shim-push-definition-stack (&optional mark)
  "Add MARKER to the edit-definition history stack.
If MARKER is nil, use the point."
  (ring-insert-at-beginning shim-find-definition-history-ring 
                            (or mark (point-marker))))

(defun shim-pop-find-definition-stack ()
  "Pop the edit-definition stack and goto the location."
  (interactive)
  (unless (ring-empty-p shim-find-definition-history-ring)
    (let* ((marker (ring-remove shim-find-definition-history-ring))
	   (buffer (marker-buffer marker)))
      (if (buffer-live-p buffer)
	  (progn (switch-to-buffer buffer)
		 (goto-char (marker-position marker)))
        ;; If this buffer was deleted, recurse to try the next one
        (shim-pop-find-definition-stack)))))

(defun shim-find-definition-pos (line col)
  (let ((filename (buffer-file-name)))
    (shim-eval `(find-definition ,filename ,line ,col
                                 ,(if (buffer-modified-p)
                                      (list (shim-buffer-text))
                                      '())))))

(defun shim-edit-definition ()
  (interactive)
  (shim-push-definition-stack)
  (shim-goto-source-location
   (shim-find-definition-pos (line-number-at-pos)
                             (current-column)))
  (switch-to-buffer (current-buffer)))

(defun shim-show-definition ()
  (interactive)
  (shim-push-definition-stack)
  (shim-show-source-location
   (shim-find-definition-pos (line-number-at-pos)
                             (current-column))))


;;;;; ghci interaction

(defun shim-ghci-buffer (&optional create connection)
  "Get the GHCI buffer for the current connection; optionally create."
  (funcall (if create #'get-buffer-create #'get-buffer)
           (format "*shim-ghci %s*" "ghci")))

(defun shim-output-buffer (&optional noprompt)
  "Return the output buffer, create it if necessary."
  (with-current-buffer (shim-ghci-buffer t)
    (unless (eq major-mode 'shim-ghci-mode) 
      (shim-ghci-mode))
    (shim-reset-ghci-markers)
    (unless noprompt 
      (shim-ghci-insert-prompt '(:suppress-output) 0))
    (current-buffer)))

(defun shim-ghci-insert-prompt (result &optional time)
  "Goto to point max, insert RESULT and the prompt.
Set shim-output-end to start of the inserted text shim-input-start
to end end."
  (goto-char (point-max))
  (let ((start (point)))
    (unless (bolp) (insert "\n"))
    (shim-ghci-insert-result result)
    (let ((prompt-start (point))
          (prompt (format "%s " (shim-ghci-prompt-string))))
      (shim-propertize-region
          '(face shim-ghci-prompt-face read-only t intangible t
                 shim-ghci-prompt t
                 ;; emacs stuff
                 rear-nonsticky (shim-ghci-prompt read-only face intangible)
                 ;; xemacs stuff
                 start-open t end-open t)
        (insert prompt))
      ;; FIXME: we could also set beginning-of-defun-function
      (setq defun-prompt-regexp (concat "^" prompt))
      (set-marker shim-output-end start)
      (set-marker shim-ghci-prompt-start-mark prompt-start)
      (shim-mark-input-start)
      (let ((time (or time 0.2)))
        (cond ((zerop time)
               (shim-ghci-move-output-mark-before-prompt (current-buffer)))
              (t 
               (run-at-time time nil 'shim-ghci-move-output-mark-before-prompt
                            (current-buffer)))))))
  (shim-ghci-show-maximum-output))

(defvar *shim-ghci-prompt-string* ">")

(defun shim-ghci-prompt-string ()
  *shim-ghci-prompt-string*)

(defun shim-ghci-insert-result (result)
  "Insert the result of an evaluation.
RESULT can be one of:
 (:values (STRING...))
 (:present ((STRING . ID)...))
 (:suppress-output)"
  (destructure-case result
    ((:values strings)
     (cond ((null strings) (insert "; No value\n"))
           (t (dolist (s strings)
                (shim-insert-propertized `(face shim-ghci-result-face) s)
                (insert "\n")))))
    ((:suppress-output))))


(defun shim-mark-input-start ()
  (set-marker shim-ghci-last-input-start-mark
              (marker-position shim-ghci-input-start-mark))
  (set-marker shim-ghci-input-start-mark (point) (current-buffer))
  (set-marker shim-ghci-input-end-mark (point) (current-buffer)))

(defun shim-mark-output-end ()
  ;; Don't put shim-ghci-output-face again; it would remove the
  ;; special presentation face, for instance in the SBCL inspector.
  (add-text-properties shim-output-start shim-output-end
                       '(;;face shim-ghci-output-face 
                         rear-nonsticky (face))))

(defun shim-ghci-move-output-mark-before-prompt (buffer)
  (when (buffer-live-p buffer)
    (with-current-buffer buffer
      (save-excursion 
        (goto-char shim-ghci-prompt-start-mark)
        (shim-mark-output-start)))))

(defun shim-mark-output-start (&optional position)
  (let ((position (or position (point))))
    (set-marker shim-output-start position)
    (set-marker shim-output-end position)))

(defun shim-ghci-show-maximum-output (&optional force)
  "Put the end of the buffer at the bottom of the window."
  (assert (eobp))
  (let ((win (get-buffer-window (current-buffer))))
    (when (and win (or force (not (pos-visible-in-window-p))))
      (save-selected-window
        (save-excursion
          (select-window win)
          (goto-char (point-max))
          (recenter -1))))))

(defun shim-ghci-return (&optional end-of-input)
  "Evaluate the current input string."
  (interactive "P")
  ;; (shim-check-connected)
  (assert (<= (point) shim-ghci-input-end-mark))
  (shim-ghci-send-input))

(defun shim-ghci-send-input (&optional newline)
  "Goto to the end of the input and send the current input.
If NEWLINE is true then add a newline at the end of the input."
  (when (< (point) shim-ghci-input-start-mark)
    (error "No input at point."))
  (goto-char shim-ghci-input-end-mark)
  (let ((end (point))) ; end of input, without the newline
    (when newline 
      (insert "\n")
      (shim-ghci-show-maximum-output))
    (let ((inhibit-read-only t))
      (add-text-properties shim-ghci-input-start-mark 
                           (point)
                           `(shim-ghci-old-input
                             ,(incf shim-ghci-old-input-counter))))
    (let ((overlay (make-overlay shim-ghci-input-start-mark end)))
      ;; These properties are on an overlay so that they won't be taken
      ;; by kill/yank.
      (overlay-put overlay 'read-only t)
      (overlay-put overlay 'face 'shim-ghci-input-face)))
  (shim-ghci-add-to-input-history 
   (buffer-substring shim-ghci-input-start-mark
                     shim-ghci-input-end-mark)) 

  (let ((input (shim-ghci-current-input)))
    (goto-char shim-ghci-input-end-mark)
    (shim-mark-input-start)
    (shim-mark-output-start)
    (shim-ghci-run-command input)))

(defun shim-ghci-current-input ()
  "Return the current input as string.
The input is the region from after the last prompt to the end of
buffer. Presentations of old results are expanded into code."
  (buffer-substring-no-properties  shim-ghci-input-start-mark
                                   shim-ghci-input-end-mark))

(defun shim-ghci-add-to-input-history (string)
  (when (and (plusp (length string))
             (eq ?\n (aref string (1- (length string)))))
    (setq string (substring string 0 -1)))
  (unless (equal string (car shim-ghci-input-history))
    (push string shim-ghci-input-history))
  (setq shim-ghci-input-history-position -1))

;; Interface
(defmacro shim-propertize-region (props &rest body)
  "Execute BODY and add PROPS to all the text it inserts.
More precisely, PROPS are added to the region between the point's
positions before and after executing BODY."
  (let ((start (gensym)))
    `(let ((,start (point)))
       (prog1 (progn ,@body)
	 (add-text-properties ,start (point) ,props)))))

(put 'shim-propertize-region 'lisp-indent-function 1)

;; Interface
(defsubst shim-insert-propertized (props &rest args)
  "Insert all ARGS and then add text-PROPS to the inserted text."
  (shim-propertize-region props (apply #'insert args)))


(defun shim-face-inheritance-possible-p ()
  "Return true if the :inherit face attribute is supported." 
  (assq :inherit custom-face-attributes))

;;;;; ghci buffer faces

(defface shim-ghci-prompt-face
  (if (shim-face-inheritance-possible-p)
      '((t (:inherit font-lock-keyword-face)))
    '((((class color) (background light)) (:foreground "Purple"))
      (((class color) (background dark)) (:foreground "Cyan"))
      (t (:weight bold))))
  "Face for the prompt in the SHIM GHCI."
  :group 'shim-ghci)

(defface shim-ghci-output-face
  (if (shim-face-inheritance-possible-p)
      '((t (:inherit font-lock-string-face)))
    '((((class color) (background light)) (:foreground "RosyBrown"))
      (((class color) (background dark)) (:foreground "LightSalmon"))
      (t (:slant italic))))
  "Face for Lisp output in the SHIM GHCI."
  :group 'shim-ghci)


(defface shim-ghci-output-mouseover-face
  (if (featurep 'xemacs)
      '((t (:bold t)))
    (if (shim-face-inheritance-possible-p)
        '((t
           (:box
            (:line-width 1 :color "black" :style released-button)
            :inherit
            (shim-ghci-inputed-output-face))))
      '((t (:box (:line-width 1 :color "black"))))))
  "Face for Lisp output in the SHIM GHCI, when the mouse hovers over it"
  :group 'shim-ghci)

(defface shim-ghci-input-face
  '((t (:bold t)))
  "Face for previous input in the SHIM GHCI."
  :group 'shim-ghci)

(defface shim-ghci-result-face
  '((t ()))
  "Face for the result of an evaluation in the SHIM GHCI."
  :group 'shim-ghci)

(defface shim-ghci-inputed-output-face
  '((((class color) (background light)) (:foreground "Red"))
    (((class color) (background dark)) (:foreground "Red"))
    (t (:slant italic)))
  "Face for the result of an evaluation in the SHIM GHCI."
  :group 'shim-ghci)

;;;; Simpler completion

(defun shim-complete-thing ()
    "Complete the symbol at point.

Completion is performed by `shim-complete-symbol-function'."
  (interactive)
  (funcall shim-complete-thing-function))

(defvar shim-completions-buffer-name "*Completions*")

(make-variable-buffer-local
 (defvar shim-complete-saved-window-configuration nil
   "Window configuration before we show the *Completions* buffer.
This is buffer local in the buffer where the completion is
performed."))

(make-variable-buffer-local
 (defvar shim-completions-window nil
   "The window displaying *Completions* after saving window configuration.
If this window is no longer active or displaying the completions
buffer then we can ignore `shim-complete-saved-window-configuration'."))

(defun shim-complete-maybe-save-window-configuration ()
  "Maybe save the current window configuration.
Return true if the configuration was saved."
  (unless (or shim-complete-saved-window-configuration
              (get-buffer-window shim-completions-buffer-name))
    (setq shim-complete-saved-window-configuration
          (current-window-configuration))
    t))

(defun shim-complete-delay-restoration ()
  (make-local-hook 'pre-command-hook)
  (add-hook 'pre-command-hook
            'shim-complete-maybe-restore-window-configuration))

(defun shim-complete-forget-window-configuration ()
  (setq shim-complete-saved-window-configuration nil)
  (setq shim-completions-window nil))

(defun shim-simple-complete-thing ()
  "Complete the thing at point.  
Perform completion more similar to Emacs' complete-symbol."
  (interactive)
  (let* ((end (point))
         (beg (shim-symbol-start-pos))
         (prefix (buffer-substring-no-properties beg end))
         (result (funcall (shim-guess-completer
                           'shim-simple-complete-module
                           'shim-simple-complete-identifier)
                          prefix)))
    (destructuring-bind (completions partial) result
      (if (null completions)
          (progn (shim-minibuffer-respecting-message
                  "Can't find completion for \"%s\"" prefix)
                 (ding)
                 (shim-complete-restore-window-configuration))
          (insert-and-inherit (substring partial (length prefix)))
          (cond ((= (length completions) 1)
                 (shim-minibuffer-respecting-message "Sole completion")
                 (shim-complete-restore-window-configuration))
                ;; Incomplete
                (t
                 (shim-minibuffer-respecting-message 
                  "Complete but not unique")
                 (shim-display-completion-list completions partial)
                 (shim-complete-delay-restoration)))))))


(defun shim-display-completion-list (completions base)
  (let ((savedp (shim-complete-maybe-save-window-configuration)))
    (with-output-to-temp-buffer shim-completions-buffer-name
      (display-completion-list completions)
      (let ((offset (- (point) 1 (length base))))
        (with-current-buffer standard-output
          (setq completion-base-size offset)
          (set-syntax-table lisp-mode-syntax-table))))
    (when savedp
      (setq shim-completions-window
            (get-buffer-window shim-completions-buffer-name)))))

(defun shim-complete-restore-window-configuration ()
  "Restore the window config if available."
  (remove-hook 'pre-command-hook
               'shim-complete-maybe-restore-window-configuration)
  (when (and shim-complete-saved-window-configuration
             (shim-completion-window-active-p))
    ;; XEmacs does not allow us to restore a window configuration from
    ;; pre-command-hook, so we do it asynchronously.
    (shim-run-when-idle
     (lambda ()
       (save-excursion
         (set-window-configuration
          shim-complete-saved-window-configuration))
       (setq shim-complete-saved-window-configuration nil)
       (when (buffer-live-p shim-completions-buffer-name)
         (kill-buffer shim-completions-buffer-name))))))

(defun shim-complete-maybe-restore-window-configuration ()
  "Restore the window configuration, if the following command
terminates a current completion."
  (remove-hook 'pre-command-hook
               'shim-complete-maybe-restore-window-configuration)
  (condition-case err
      (cond ((find last-command-char "()\"'`,# \r\n:")
             (shim-complete-restore-window-configuration))
            ((not (shim-completion-window-active-p))
             (shim-complete-forget-window-configuration))
            (t
             (shim-complete-delay-restoration)))
    (error
     ;; Because this is called on the pre-command-hook, we mustn't let
     ;; errors propagate.
     (message "Error in shim-complete-restore-window-configuration: %S" err))))

(defun shim-completion-window-active-p ()
  "Is the completion window currently active?"
  (and (window-live-p shim-completions-window)
       (equal (buffer-name (window-buffer shim-completions-window))
              shim-completions-buffer-name)))

;;;; Fuzzy completion

(defvar shim-fuzzy-target-buffer nil
  "The buffer that is the target of the completion activities.")
(defvar shim-fuzzy-saved-window-configuration nil
  "The saved window configuration before the fuzzy completion
buffer popped up.")
(defvar shim-fuzzy-start nil
  "The beginning of the completion slot in the target buffer.
This is a non-advancing marker.")
(defvar shim-fuzzy-end nil
  "The end of the completion slot in the target buffer.
This is an advancing marker.")
(defvar shim-fuzzy-original-text nil
  "The original text that was in the completion slot in the
target buffer.  This is what is put back if completion is
aborted.")
(defvar shim-fuzzy-text nil
  "The text that is currently in the completion slot in the
target buffer.  If this ever doesn't match, the target buffer has
been modified and we abort without touching it.")
(defvar shim-fuzzy-first nil
  "The position of the first completion in the completions buffer.
The descriptive text and headers are above this.")
(defvar shim-fuzzy-current-completion nil
  "The current completion object.  If this is the same before and
after point moves in the completions buffer, the text is not
replaced in the target for efficiency.")

(define-derived-mode shim-fuzzy-completions-mode 
  fundamental-mode "Fuzzy Completions"
  "Major mode for presenting fuzzy completion results.

\\<shim-fuzzy-completions-map>\
\\{shim-fuzzy-completions-map}"
  (use-local-map shim-fuzzy-completions-map))

(defvar shim-fuzzy-completions-map  
  (let* ((map (make-sparse-keymap)))
    
    (define-key map "q" 'shim-fuzzy-abort)
    (define-key map "\r" 'shim-fuzzy-select)
    
    (define-key map "n" 'shim-fuzzy-next)
    (define-key map "\M-n" 'shim-fuzzy-next)
    
    (define-key map "p" 'shim-fuzzy-prev)
    (define-key map "\M-p" 'shim-fuzzy-prev)
    
    (define-key map "\d" 'scroll-down)
    (define-key map " " 'scroll-up)
    
    (define-key map [mouse-2] 'shim-fuzzy-select/mouse)
    
    map)
  "Keymap for shim-fuzzy-completions-mode.")

(defun* shim-fuzzy-complete-thing ()
  "Fuzzily completes the abbreviation at point into a module or identifier."
  (interactive)
  (let* ((end (move-marker (make-marker) (shim-symbol-end-pos)))
         (beg (move-marker (make-marker) (shim-symbol-start-pos)))
         (prefix (buffer-substring-no-properties beg end))
         (completion-set
          (funcall
           (shim-guess-completer #'shim-fuzzy-complete-module
                                 #'shim-fuzzy-complete-identifier) prefix)))
    (if (null completion-set)
        (progn (shim-minibuffer-respecting-message
                "Can't find completion for \"%s\"" prefix)
               (ding))
      (goto-char end)
      (cond ((= (length completion-set) 1)
             (insert-and-inherit (caar completion-set))
             (delete-region beg end)
             (goto-char (+ beg (length (caar completion-set))))
             (shim-minibuffer-respecting-message "Sole completion"))
            ;; Incomplete
            (t
             (shim-minibuffer-respecting-message "Complete but not unique")
             (shim-fuzzy-choices-buffer completion-set beg end))))))

(defun* shim-fuzzy-insert-from-module (module)
  "Fuzzily completes the abbreviation at point into a symbol."
  (interactive "MModule: ")
  (shim-fuzzy-completion-from-module module nil))

(defun* shim-fuzzy-browse-from-module (module)
  "Fuzzily completes the abbreviation at point into a symbol."
  (interactive "MModule: ")
  (shim-fuzzy-completion-from-module module ""))

(defun* shim-fuzzy-completion-from-module (module &optional prefix)
  "Fuzzily completes the abbreviation at point into a symbol."
  (interactive "MModule: ")
  (let* ((end (move-marker (make-marker) (shim-symbol-end-pos)))
         (beg (move-marker (make-marker) (shim-symbol-start-pos)))
         (begline (save-excursion (move-beginning-of-line nil) (point)))
         (pref (buffer-substring-no-properties beg end))
         (line (buffer-substring-no-properties begline end))
         (completion-set (shim-get-module-exports module (or prefix pref))))
    (if (null completion-set)
        (progn (shim-minibuffer-respecting-message
                "Can't find export in module %s with prefix \"%s\""
                module prefix)
               (ding))
      (goto-char end)
      (cond ((= (length completion-set) 1)
             (insert-and-inherit (caar completion-set))
             (delete-region beg end)
             (goto-char (+ beg (length (caar completion-set))))
             (shim-minibuffer-respecting-message "Sole completion"))
            ;; Incomplete
            (t
             (shim-minibuffer-respecting-message "Complete but not unique")
             (shim-fuzzy-choices-buffer completion-set beg end))))))

(defun shim-get-fuzzy-buffer ()
  (get-buffer-create "*Fuzzy Completions*"))

(defvar shim-fuzzy-explanation
  "Click <mouse-2> on a completion to select it.
In this buffer, type n and p to navigate between completions.
Type RET to select the completion near point.  Type q to abort.
Flags: boundp fboundp generic-function class macro special-operator
\n"
  "The explanation that gets inserted at the beginning of the
*Fuzzy Completions* buffer.")

(defun shim-fuzzy-insert-completion-choice (completion max-length)
  "Inserts the completion object `completion' as a formatted
completion choice into the current buffer, and mark it with the
proper text properties."
  (let ((start (point))
        (symbol (first completion))
        (type (second completion)))
    (insert symbol)
    (let ((end (point)))
      (put-text-property start (point) 'mouse-face 'highlight)
      (dotimes (i (- max-length (- end start)))
        (insert " "))
      (insert type)
      (insert "\n")
      (put-text-property start (point) 'completion completion))))

(defun shim-fuzzy-insert (text)
  "Inserts `text' into the target buffer in the completion slot.
If the buffer has been modified in the meantime, abort the
completion process.  Otherwise, update all completion variables
so that the new text is present."
  (with-current-buffer shim-fuzzy-target-buffer
    (cond 
     ((not (string-equal shim-fuzzy-text 
                         (buffer-substring shim-fuzzy-start
                                           shim-fuzzy-end)))
      (shim-fuzzy-done)
      (beep)
      (message "Target buffer has been modified!"))
     (t
      (goto-char shim-fuzzy-start)
      (delete-region shim-fuzzy-start shim-fuzzy-end)
      (insert-and-inherit text)
      (setq shim-fuzzy-text text)
      (goto-char shim-fuzzy-end)))))

(defun shim-fuzzy-choices-buffer (completions start end)
  "Creates (if neccessary), populates, and pops up the *Fuzzy
Completions* buffer with the completions from `completions' and
the completion slot in the current buffer bounded by `start' and
`end'.  This saves the window configuration before popping the
buffer so that it can possibly be restored when the user is
done."
  (setq shim-fuzzy-target-buffer (current-buffer))
  (setq shim-fuzzy-start (move-marker (make-marker) start))
  (setq shim-fuzzy-end (move-marker (make-marker) end))
  (set-marker-insertion-type shim-fuzzy-end t)
  (setq shim-fuzzy-original-text (buffer-substring start end))
  (setq shim-fuzzy-text shim-fuzzy-original-text)
  (shim-fuzzy-save-window-configuration)
  (with-current-buffer (shim-get-fuzzy-buffer)
    (setq buffer-read-only nil)
    (erase-buffer)
    (shim-fuzzy-completions-mode)
    (insert shim-fuzzy-explanation)
    (let ((max-length 24))
      (dolist (completion completions)
        (setf max-length (max max-length (length (first completion)))))
      (insert "Completion:")
      (dotimes (i (- max-length 10)) (insert " "))
      (insert "Type:\n")
      (dotimes (i max-length) (insert "-"))
      (insert " ------ --------\n")
      (setq shim-fuzzy-first (point))
      (dolist (completion completions)
        (shim-fuzzy-insert-completion-choice completion max-length))
      (setq buffer-read-only t))
    (setq shim-fuzzy-current-completion
          (caar completions))
    (shim-fuzzy-insert (caar completions))
    (goto-char shim-fuzzy-first)
    (pop-to-buffer (current-buffer))
    (add-hook (make-local-variable 'post-command-hook)
              'shim-fuzzy-post-command-hook)))

(defun shim-fuzzy-insert-from-point ()
  "Inserts the completion that is under point in the completions
buffer into the target buffer.  If the completion in question had
already been inserted, it does nothing."
  (with-current-buffer (shim-get-fuzzy-buffer)
    (let ((current-completion (get-text-property (point) 'completion)))
      (when (and current-completion
                 (not (eq shim-fuzzy-current-completion 
                          current-completion)))
        (shim-fuzzy-insert 
         (first (get-text-property (point) 'completion)))
        (setq shim-fuzzy-current-completion
              current-completion)))))

(defun shim-fuzzy-post-command-hook ()
  "The post-command-hook for the *Fuzzy Completions* buffer.
This makes sure the completion slot in the target buffer matches
the completion that point is on in the completions buffer."
  (condition-case err
      (when shim-fuzzy-target-buffer
        (shim-fuzzy-insert-from-point))
    (error
     ;; Because this is called on the post-command-hook, we mustn't let
     ;; errors propagate.
     (message "Error in shim-fuzzy-post-command-hook: %S" err))))

(defun shim-fuzzy-next ()
  "Moves point directly to the next completion in the completions
buffer."
  (interactive)
  (goto-char 
   (next-single-char-property-change (point) 'completion)))

(defun shim-fuzzy-prev ()
  "Moves point directly to the previous completion in the
completions buffer."
  (interactive)
  (goto-char (previous-single-char-property-change 
              (point) 'completion
              nil shim-fuzzy-first)))

(defun shim-fuzzy-abort ()
  "Aborts the completion process, setting the completions slot in
the target buffer back to its original contents."
  (interactive)
  (when shim-fuzzy-target-buffer
    (shim-fuzzy-insert shim-fuzzy-original-text)
    (shim-fuzzy-done)))

(defun shim-fuzzy-select ()
  "Selects the current completion, making sure that it is inserted 
into the target buffer.  This tells the connected Lisp what completion
was selected."
  (interactive)
  (when shim-fuzzy-target-buffer
    (with-current-buffer (shim-get-fuzzy-buffer)
      (let ((completion (get-text-property (point) 'completion)))
        (when completion
          (shim-fuzzy-insert (first completion))
          (shim-fuzzy-done))))))

(defun shim-fuzzy-select/mouse (event)
  "Handle a mouse-2 click on a completion choice as if point were
on the completion choice and the shim-fuzzy-select command was
run."
  (interactive "e")
  (with-current-buffer (window-buffer (posn-window (event-end event)))
    (save-excursion
      (goto-char (posn-point (event-end event)))
      (when (get-text-property (point) 'mouse-face)
        (shim-fuzzy-insert-from-point)
        (shim-fuzzy-select)))))

(defun shim-fuzzy-done ()
  "Cleans up after the completion process.  This removes all hooks,
and attempts to restore the window configuration.  If this fails,
it just burys the completions buffer and leaves the window
configuration alone."
  (set-buffer shim-fuzzy-target-buffer)
  (remove-hook 'post-command-hook
               'shim-fuzzy-post-command-hook)
  (if (shim-fuzzy-maybe-restore-window-configuration)
      (bury-buffer (shim-get-fuzzy-buffer))
    ;; We couldn't restore the windows, so just bury the fuzzy
    ;; completions buffer and let something else fill it in.
    (pop-to-buffer (shim-get-fuzzy-buffer))
    (bury-buffer))
  (pop-to-buffer shim-fuzzy-target-buffer)
  (goto-char shim-fuzzy-end)
  (setq shim-fuzzy-target-buffer nil))

(defun shim-fuzzy-save-window-configuration ()
  "Saves the current window configuration, and (if the
window-configuration-change-hook variable exists) sets up for the
saved configuration to be nullified if the user changes the
window configuration further.  Adding the nullification routine
to window-configuration-change-hook is delayed so that the
windows stabalize before we start listening on the hook."
  (setq shim-fuzzy-saved-window-configuration 
        (current-window-configuration))
  (when (boundp 'window-configuration-change-hook)
    (run-with-timer 
     0.5 nil 'shim-fuzzy-window-configuration-change-add-hook)))

(defun shim-fuzzy-maybe-restore-window-configuration ()
  "Restores the saved window configuration if it has not been
nullified."
  (when (boundp 'window-configuration-change-hook)
    (remove-hook 'window-configuration-change-hook
                 'shim-fuzzy-window-configuration-change))
  (if (not shim-fuzzy-saved-window-configuration)
      nil
    (set-window-configuration shim-fuzzy-saved-window-configuration)
    (setq shim-fuzzy-saved-window-configuration nil)
    t))

(defun shim-fuzzy-window-configuration-change-add-hook ()
  "Sets up shim-fuzzy-window-configuration-change on
window-configuration-change-hook."
  (add-hook 'window-configuration-change-hook
            'shim-fuzzy-window-configuration-change))

(defun shim-fuzzy-window-configuration-change ()
  "Called on window-configuration-change-hook.  Since the window
configuration was changed, we nullify our saved configuration."
  (remove-hook 'window-configuration-change-hook
               'shim-fuzzy-window-configuration-change)
  (setq shim-fuzzy-saved-window-configuration nil))



;;;;; Extracting Lisp forms from the buffer or user

(defun shim-defun-at-point ()
  "Return the text of the defun at point."
  (apply #'buffer-substring-no-properties
         (shim-region-for-defun-at-point)))

(defun shim-region-for-defun-at-point ()
  "Return the start and end position of the toplevel form at point."
  (save-excursion
    (end-of-defun)
    (let ((end (point)))
      (beginning-of-defun)
      (list (point) end))))

(defun shim-beginning-of-symbol ()
  "Move point to the beginning of the current symbol."
  (when (shim-point-moves-p
          (while (shim-point-moves-p 
                   (skip-syntax-backward "w_")
                   (when (eq (char-before) ?|)
                     (backward-sexp)))))
    (when (eq (char-before) ?#) ; special case for things like "#<foo"
      (forward-char))))

(defun shim-end-of-symbol ()
  "Move point to the end of the current symbol."
  (while (shim-point-moves-p 
           (skip-syntax-forward "w_")
           ;; | has the syntax as ", so we need to 
           ;; treat it manually rather than via syntax. 
           (when (looking-at "|")
             (forward-sexp)))))

(put 'shim-symbol 'end-op 'shim-end-of-symbol)
(put 'shim-symbol 'beginning-op 'shim-beginning-of-symbol)

(defun shim-symbol-start-pos ()
  "Return the starting position of the symbol under point.
The result is unspecified if there isn't a symbol under the point."
  (save-excursion (shim-beginning-of-symbol) (point)))

(defun shim-symbol-end-pos ()
  (save-excursion (shim-end-of-symbol) (point)))

(defun shim-symbol-name-at-point ()
  "Return the name of the symbol at point, otherwise nil."
  (save-restriction
    ;; Don't be tricked into grabbing the GHCI prompt.
    (when (and (eq major-mode 'shim-ghci-mode)
               (>= (point) shim-ghci-input-start-mark))
      (narrow-to-region shim-ghci-input-start-mark (point-max)))
    (save-excursion
      (let ((string (thing-at-point 'shim-symbol)))
        (and string
             ;; In Emacs20 (thing-at-point 'symbol) returns "" instead
             ;; of nil when called from an empty (or
             ;; narrowed-to-empty) buffer.
             (not (equal string ""))
             (substring-no-properties string))))))

(defun shim-symbol-at-point ()
  "Return the symbol at point, otherwise nil."
  (let ((name (shim-symbol-name-at-point)))
    (and name (intern name))))

(defun shim-sexp-at-point ()
  "Return the sexp at point as a string, otherwise nil."
  (let ((string (thing-at-point 'sexp)))
    (if string (substring-no-properties string) nil)))

(defun shim-sexp-at-point-or-error ()
  "Return the sexp at point as a string, otherwise signal an error."
  (or (shim-sexp-at-point)
      (error "No expression at point.")))

(defmacro shim-point-moves-p (&rest body)
  "Execute BODY and return true if the current buffer's point moved."
  (let ((pointvar (gensym "point-")))
    `(let ((,pointvar (point)))
       (save-current-buffer ,@body)
       (/= ,pointvar (point)))))

(put 'shim-point-moves-p 'lisp-indent-function 0)

(eval-when (compile eval)
  (defmacro shim-defun-if-undefined (name &rest rest)
    `(unless (fboundp ',name)
       (defun ,name ,@rest))))

(defun shim-minibuffer-respecting-message (format &rest format-args)
  "Display TEXT as a message, without hiding any minibuffer contents."
  (let ((text (format " [%s]" (apply #'format format format-args))))
    (if (minibuffer-window-active-p (minibuffer-window))
        (if (fboundp 'temp-minibuffer-message) ;; XEmacs
            (temp-minibuffer-message text)
          (minibuffer-message text))
      (message "%s" text))))

(shim-defun-if-undefined next-single-char-property-change
    (position prop &optional object limit)
  (let ((limit (typecase limit
		 (null nil)
		 (marker (marker-position limit))
		 (t limit))))
    (if (stringp object)
	(or (next-single-property-change position prop object limit)
	    limit 
	    (length object))
      (with-current-buffer (or object (current-buffer))
	(let ((initial-value (get-char-property position prop object))
	      (limit (or limit (point-max))))
	  (loop for pos = position then (next-char-property-change pos limit)
		if (>= pos limit) return limit
		if (not (eq initial-value 
			    (get-char-property pos prop object))) 
		return pos))))))

(shim-defun-if-undefined previous-single-char-property-change 
    (position prop &optional object limit)
  (let ((limit (typecase limit
		 (null nil)
		 (marker (marker-position limit))
		 (t limit))))
    (if (stringp object)
	(or (previous-single-property-change position prop object limit)
	    limit 
	    (length object))
      (with-current-buffer (or object (current-buffer))
	(let ((limit (or limit (point-min))))
	  (if (<= position limit)
	      limit
            (let ((initial-value (get-char-property (1- position)
                                                    prop object)))
              (loop for pos = position then 
                    (previous-char-property-change pos limit)
                    if (<= pos limit) return limit
                    if (not (eq initial-value 
                                (get-char-property (1- pos) prop object))) 
                    return pos))))))))

(shim-defun-if-undefined next-char-property-change (position &optional limit)
  (let ((tmp (next-overlay-change position)))
    (when tmp
      (setq tmp (min tmp limit)))
    (next-property-change position nil tmp)))

(shim-defun-if-undefined previous-char-property-change 
    (position &optional limit)
  (let ((tmp (previous-overlay-change position)))
    (when tmp
      (setq tmp (max tmp limit)))
    (previous-property-change position nil tmp)))
        
(shim-defun-if-undefined substring-no-properties (string &optional start end)
  (let* ((start (or start 0))
	 (end (or end (length string)))
	 (string (substring string start end)))
    (set-text-properties 0 (- end start) nil string)
    string))

(shim-defun-if-undefined set-window-text-height (window height)
  (let ((delta (- height (window-text-height window))))
    (unless (zerop delta)
      (let ((window-min-height 1))
	(if (and window (not (eq window (selected-window))))
	    (save-selected-window
	      (select-window window)
	      (enlarge-window delta))
	  (enlarge-window delta))))))


(unless (fboundp 'overlay-at)
  (require 'overlay))

(unless (fboundp 'with-temp-message)
  (defmacro with-temp-message (message &rest body)
    (let ((current-message (make-symbol "current-message"))
          (temp-message (make-symbol "with-temp-message")))
      `(let ((,temp-message ,message)
             (,current-message))
         (unwind-protect
             (progn
               (when ,temp-message
                 (setq ,current-message (current-message))
                 (message "%s" ,temp-message))
               ,@body)
           (and ,temp-message ,current-message
                (message "%s" ,current-message)))))))



;;;; Key Bindings

(define-key haskell-mode-map "\C-c\t" 'shim-complete-thing)
(define-key haskell-mode-map "\C-c\C-t" 'shim-lookup-type)
(define-key haskell-mode-map "\C-c\C-d" 'shim-insert-type)
(define-key haskell-mode-map "\M-p" 'shim-previous-note)
(define-key haskell-mode-map "\M-n" 'shim-next-note)
(define-key haskell-mode-map "\C-c\C-k" 'shim-load-buffer-async)

;;;; Some adititional key bindings, you can add these to your .emacs 
;; (define-key haskell-mode-map "\C-x\t" 'shim-fuzzy-insert-from-module)
;; (define-key haskell-mode-map "\C-x\C-b" 'shim-fuzzy-browse-from-module)
;; (define-key haskell-mode-map "\C-x\C-s" 'shim-save-and-load-buffer)
;; (define-key haskell-mode-map "\M-." 'shim-edit-definition)
;; (define-key haskell-mode-map "\M-*" 'shim-pop-find-definition-stack)

(defun shim-save-and-load-buffer ()
  (interactive)
  (save-buffer)
  (shim-load-buffer-async))

(provide 'shim)

;; Local Variables: 
;; outline-regexp: ";;;;+"
;; indent-tabs-mode: nil
;; End: