xyzzy lisp repl

.xyzzy

(require "ac-mode-lisp")
(require "ldoc2")
(require "paren")

(require "xl-repl")
(push 'lisp-repl-mode ed::*ldoc-activated-mode-list*)
(push 'lisp-repl-mode ed::*ac-mode-lisp-mode*)

;; *startup-hook*の前に*lisp-mode-hook*も実行するので
;; 被ってる物は不要
(add-hook repl:*startup-hook*
	  #'(lambda ()
	      (ac-mode-on)
	      (turn-on-ldoc)
	      (toggle-paren t)))

xl-repl.l

;;; -*- mode:lisp; package:repl -*-

;; Copyright (c) 2012  Yousuke Ushiki
;;
;; Permission is hereby granted, free of charge, to any person obtaining a copy
;; of this software and associated documentation files (the "Software"), to deal
;; in the Software without restriction, including without limitation the rights
;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;; copies of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;;
;; The above copyright notice and this permission notice shall be included in
;; all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
;; THE SOFTWARE.

;; :usage
;; (require "xl-repl")
;; M-x start-repl

(provide "xl-repl")


(in-package :editor)
(export '(start-repl lisp-repl-mode))

(in-package :lisp)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (export '(** *** // /// ++ +++)))

(defpackage :repl
  (:use :lisp :editor))

(in-package :repl)
(export '(*buffer-name*
	  *keymap*
	  *prompt*
	  *prompt-style*
	  *error-style*
	  *startup-hook*))

(defvar *buffer-name* "*xl-repl*")
(defvar *prompt* "%p>")
(defvar *prompt-style* '(:foreground 12 :bold t))
(defvar *error-style* '(:foreground 1))
(defvar *startup-hook* nil)
(defvar *startup-package* "user")
(defvar *commands* nil)

(defparameter *keymap* (copy-keymap ed::*lisp-mode-map*))
(define-key *keymap* #\RET 'newline-or-eval-input)
(define-key *keymap* '(#\C-c #\C-l) 'clear-buffer)
(define-key *keymap* #\C-h 'repl-backward-delete-char)
(define-key *keymap* #\Delete 'repl-delete-char-or-selection)
(define-key *keymap* #\C-d 'repl-delete-char-or-selection)
(define-key *keymap* #\C-l 'clear-repl)

(defvar-local *input-history* nil)

(defmacro iflet (var test then else)
  `(let ((,var ,test)) (if ,var ,then ,else)))

(defmacro whenlet (var test &body body)
  `(let ((,var ,test)) (when ,var ,@body)))

(defmacro whilet (var test &body body)
  `(do ((,var ,test ,test)) ((not ,var) nil) ,@body))

(defmacro nth-value (n form)
  `(nth ,n (multiple-value-list ,form)))


(defun format-prompt ()
  (with-output-to-string (os)
    (with-input-from-string (is *prompt*)
      (whilet c (read-char is nil nil)
	(princ
         (if (char= c #\%)
	     (let ((post (read-char is nil nil)))
	       (if (null post) c
		 (case (char-downcase post)
		   (#\p *buffer-package*)
		   (#\d (default-directory))
		   (#\u (user-name))
		   (#\m (machine-name))
		   (#\o (os-platform))
		   (#\v (software-version))
		   (#\n (software-type))
		   (t post))))
	   c) os)))))

(defun show-prompt (&optional default)
  (goto-char (point-max))
  (unless (bolp) (insert "\n") (forward-char))
  (let ((p (point)))
    (insert (format-prompt) #\SPC)
    (apply #'set-text-attribute p (point-max) 'prompt *prompt-style*)
    #0=(goto-char (point-max))
    (when default (insert default))
    #0#))

(defmacro previous-prompt-point ()
  `(find-text-attribute 'prompt :end (point) :from-end t))

(defmacro next-prompt-point ()
  `(find-text-attribute 'prompt :start (point)))

(defun repl-backward-delete-char (&optional (n 1))
  (interactive "p")
  (let ((p (point)))
    (multiple-value-bind (from to) (previous-prompt-point)
      (if (<= from p (1- to))
	  (goto-char to)
	(backward-delete-char-untabify-or-selection (min n (- p to)))))))

(defun repl-delete-char-or-selection (&optional (n 1))
  (interactive "p")
  (let ((p (point)))
    (multiple-value-bind (from to) (previous-prompt-point)
      (unless (<= from p (1- to))
	(delete-char-or-selection n)))))


(defun get-input ()
  (multiple-value-bind (from to) (previous-prompt-point)
    (save-excursion
      (goto-eol)
      (buffer-substring to (point)))))

(defun input-complete-p ()
  (save-excursion
    (let ((from (nth-value 1 (previous-prompt-point))))
      (goto-eol)
      (while (and (>= (point) from)
		  (ignore-errors (backward-sexp)))
	(skip-chars-backward " \t\n"))
      (<= (point) from))))

(defun eval-and-print (input)
  (handler-case
      (let ((*package* (or (find-package *buffer-package*)
			   (find-package "user")))
	    (forms nil))
	(with-input-from-string (is input)
	  (do ((s #0=(read is nil #1='#:eos) #0#))
	      ((eq s #1#))
	    (push s forms)))
	(with-output-to-buffer ((selected-buffer) (point-max))
	  (setq forms (nreverse forms))
	  (iflet com (and (keywordp (car forms)) (getf *commands* (car forms)))
		 (apply com (cdr forms))
	    (dolist (expr (nreverse forms))
	      (setq - expr)
	      (let ((results (save-excursion
			       (multiple-value-list (eval expr)))))
		(setq *** ** ** * * (car results)
		      +++ ++ ++ + + expr
		      /// // // / / (if (cdr results) results *)
		      *buffer-package* (package-name *package*))
		(format t "~{~S~^ ;~%~}~%~%" results))))))
    (error (c)
      (let ((start (point-max)))
	(with-output-to-buffer ((selected-buffer) start)
	  (format t "~A~%~%" (si:*condition-string c)))
	(apply #'set-text-attribute start (- (point-max) 2) 'error
	       *error-style*)))))

(defun newline-or-eval-input ()
  (interactive)
  (if (input-complete-p)
      (let ((input (get-input)))
	(if (next-prompt-point)
	    (show-prompt input)
	  (goto-eol))
	(newline)
	(eval-and-print input)
	(show-prompt))
    (lisp-newline-and-indent)))

(defun clear-repl ()
  (interactive)
  (delete-region (point-min) (point-max))
  (show-prompt))

(defmacro define-repl-command (name args &body body)
  (let ((kw (intern (string name) :keyword)))
    `(setf (getf *commands* ,kw)
	   (lambda ,args ,@body))))
(setf (get 'define-repl-command 'ed:lisp-indent-hook) 2)


;;; repl command
(define-repl-command require (name)
  (let ((*load-path* (cons (default-directory) *load-path*)))
    (eval-and-print (format nil "(require \"~A\")" name))))

(define-repl-command load (name)
  (let ((*load-path* (cons (default-directory) *load-path*)))
    (eval-and-print (format nil "(load-library \"~A\")" name))))

(define-repl-command dir (&optional wild)
  (let* ((dir (default-directory))
	 (files (directory dir :wild (or wild "*"))))
    (format t "[~A]~%~{~A~%~}~%" dir files)))

(define-repl-command cd (dir)
  (let ((path (merge-pathnames dir (default-directory))))
    (set-default-directory dir)
    (format t "[~A]~%~%" path)))


;;; major mode
(defun ed::lisp-repl-mode ()
  (interactive)
  (lisp-mode)
  (setq buffer-mode 'ed::lisp-repl-mode
	mode-name "REPL")
  (use-keymap *keymap*)
  (unless (file-visited-p)
    (make-local-variable 'need-not-save)
    (make-local-variable 'auto-save)
    (setq need-not-save t
	  auto-save nil))
  (mapc #'make-local-variable
	'(* ** *** / // /// + ++ +++ -))
  (setq *buffer-package* *startup-package*)
  (run-hooks '*startup-hook*))


;;; launcher
(defun ed::start-repl ()
  (interactive)
  (let ((buf (get-buffer-create *buffer-name*)))
    (set-buffer buf)
    (when (eq buffer-mode 'ed::lisp-repl-mode)
      (return-from ed::start-repl))
    (ed::lisp-repl-mode)
    (insert ";;; xyzzy lisp REPL\n")
    (show-prompt)))