;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; "Inferior" Guile Scheme with tab-completion for Emacs.
;;;
;;; To use it:
;;; 1. mkdir ~/emacs 
;;; 2. cp guile-completion.el ~/emacs
;;; 3. Put the following lines in your ~/.emacs file
;;;  (add-to-list 'load-path "~/emacs")
;;;  (load "guile-completion.el")
;;;  (add-to-list 'auto-mode-alist (cons (cons "\\.scm$" 'scheme-mode)))
;;; 4. In emacs, type M-x guile .
;;;
;;; Try out the completion by going to the guile> prompt and typing
;;; something such as "(def" (without the quotes) and then hitting the
;;; Tab key to see all the valid identifiers such as "define" that 
;;; begin with "def".

;;; This file was converted from lush.el in the Lush project.  The changes
;;; are copyright (C) 2007 Issac Trotts.  Here is the original header:
;;;
;;;   Copyright (C) 2002 Leon Bottou, Yann Le Cun, AT&T Corp, NECI.
;;; Includes parts of TL3:
;;;   Copyright (C) 1987-1999 Leon Bottou and Neuristique.
;;; Includes selected parts of SN3.2:
;;;   Copyright (C) 1991-2001 AT&T Corp.
;;;
;;; 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, USA
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(require 'pcomplete)

;; if this is set to nil then tab completion will read the environment
;; from the guile process every time, even when nothing new was defined
(defvar cache-symbols t)

(defvar *guile-symbols* ())
(defvar *guile-symbols-stale?* t)

(defun guile-proc ()
  (condition-case err
      (scheme-proc)
    (error ())))

(defun guile ()
  "same as run-guile"
  (interactive)
  (run-guile))

;; call this with M-X run-guile
(defun run-guile ()
  "starts guile in another subwindow"
  (interactive)
  (if (not (equal (buffer-name) "*scheme*"))
      (switch-to-buffer-other-window "*scheme*"))
  (run-scheme "guile")
  (setq comint-prompt-regexp "^guile>")
  (setq comint-get-old-input #'guile-get-incomplete-input)

  ;; This makes (ls) print out all available symbols.
  (comint-send-string (scheme-proc) "(use-modules (ice-9 ls))")

  (if cache-symbols
      (progn
        ;; override comint-send-string to check for definitions/file loads
        ;; entered by hand in the repl or through the lisp-load-file command
        (defvar prev-comint-send-string (symbol-function 'comint-send-string))
        (defun comint-send-string (proc inp)
          (let ((stale-re "load\\|define\\|define-macro\\|defmacro\\|define-syntax\\|define-option-inferface\\|define-private\\|define-public\\|define-syntax-macro"))
            (if (and (eq proc (guile-proc))
                     (string-match stale-re inp))
                (setq *guile-symbols-stale?* t)))
          (funcall prev-comint-send-string proc inp))

        ;; override comint-send-region to mark the symbol cache stale
        ;; whenever the lisp-eval-* commands are used
        (defvar prev-comint-send-region (symbol-function 'comint-send-region))
        (defun comint-send-region (proc start end)
          (setq *guile-symbols-stale?* t)
          (funcall prev-comint-send-region proc start end))))
    
  (set (make-local-variable 'pcomplete-parse-arguments-function)
       'guile-parse-arguments)

  ;; This caused my <Tab> key not to indent on certain lines.
  ;; The cursor just sat there, doing nothing. -ijt
  (local-set-key "\t" 'pcomplete)   

  ;; One or both of these caused my <Enter> key not to work. -ijt
  ;(local-set-key "\r" 'guile-filter-input)
  ;(local-set-key "\n" 'guile-filter-input)

  (other-window -1)) ;; go back to the other window to edit a .scm file

(global-set-key "\C-xg" 'goto-line)

(defun guile-avail? (mark)
  t)

(defun filter (p lst)
  (let ((ret ()))
    (mapc (lambda (x) (if (funcall p x) (setq ret (cons x ret)))) lst)
    (nreverse ret)))

;; be careful; calling this when guile isn't available will cause this to hang
(defun guile-symbols ()
  (let ((proc (guile-proc)))
    (if proc
        (let ((syms 
               (car (read-from-string
                     (car (comint-redirect-results-list-from-process
                           proc "(ls)" "(.*)" 0))))))
          (mapcar (lambda (sym) (format "%s" sym))
                  syms))
      ())))

(defun guile-complete (sym)
  (let* ((sym-name (if (stringp sym) sym (symbol-name sym)))
         (minl (length sym-name))
         (proc (guile-proc))
         (proc-buffer-is-current? (eq (current-buffer) (process-buffer proc)))
         (avail? (guile-avail? (process-mark proc))))
    ;; if we have the prompt and the symbols are stale, update *guile-symbols*
    (if (and *guile-symbols-stale?*
             proc
             proc-buffer-is-current?
             avail?)
        (progn
          (setq *guile-symbols* (guile-symbols))
          (if cache-symbols
              (setq *guile-symbols-stale?* ()))))
    
    (filter (lambda (s)
              (and (>= (length s) minl)
                   (string= sym-name (substring s 0 minl))))
            *guile-symbols*)))

(defun guile-get-incomplete-input ()
  (let ((proc (guile-proc)))
    (if (and proc (eq (current-buffer) (process-buffer proc)))
        (buffer-substring (process-mark proc) (point-max))
      "")))

;; see http://www.emacswiki.org/cgi-bin/wiki/PcompleteExamples
(defun guile-parse-arguments ()
  (save-excursion
    (let* ((cur (point))
           (beg (search-backward-regexp "[][{}#():'\" \t\n]" nil t))
           (pos (if beg (+ beg 1) cur))
           (arg (buffer-substring-no-properties pos cur)))
      (cons (list "guile-complete" arg)
            (list (point-min) pos)))))

(defun pcomplete/guile-complete ()
  "Complete the symbol at point"
  (let* ((sym (cadr (car (guile-parse-arguments))))
         (completions (guile-complete sym)))
    (if completions
        (throw 'pcomplete-completions completions)
      (pcomplete-here (pcomplete-all-entries)))))