;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: COMMON-LISP -*-
;;;; (C) 2003 Madhu. Send bugs to: <enometh@net.meer>
;;;; Touched: <02-Sep-03 11:13:53 IST, madhu>
;;;; SYNOPSIS: SUPER-READ-LINE
;;;;   like READ-LINE except it also provides the following limitations of GNU
;;;;   readline:
;;;;    - emacs like line editing (including single level yank)!
;;;;    - CLISP tab completion!
;;;;    - history!
;;;;
(cl:defpackage "TOPLEVEL"
  (:use "COMMON-LISP")
  (:export "SUPER-READ-LINE" "REPL"))

(cl:in-package "TOPLEVEL")

;;;
;;; CLISP keyboard magic
(defgeneric %handle-input-char (bits key char))

(defun super-read-char (&optional (input-stream ext:*keyboard-input*)
				  (eof-error-p t) (eof-value nil)
				  (recursive-p nil))
 (loop
   (let ((c (read-char input-stream eof-error-p eof-value recursive-p)))
     (if (typep c 'sys::input-character)
	 (with-slots (sys::char sys::bits sys::key) c
	   (when (and sys::char (graphic-char-p sys::char))
	     (return sys::char))
	   (%handle-input-char sys::bits sys::key sys::char))
	 (progn
	   (warn "sanity-check. didn't expect to see this")
	   (assert (and (not eof-error-p) (eq eof-value c)))
	   (return c))))))

;;;
;;; Installing handlers
(defun %make-specialized-lambda-list (keys-list)
  (let ((bits 0) (keys nil) (char nil))
    (loop for item in keys-list do
	  (etypecase item
	    (keyword (ecase item
		       (:control (incf bits ext:char-control-bit))
		       (:super (incf bits ext:char-super-bit))
		       (:hyper (incf bits ext:char-hyper-bit))
		       (:meta (incf bits ext:char-meta-bit))
		       ((:Home :End :Delete :PgUp :PgDn :Left :Right
			       :Up :Down :Insert)
			(when keys (error "multiple keys: ~a" keys))
			(setf keys item))))
	    (character (cond ((zerop bits) ; note - bits _must_ precede!
			      (when char (error "multiple chars: ~a" keys))
			      (setf char item))
			     (t (when keys (error "multiple keys: ~a" keys))
				(setf keys (char-upcase item)))))))
    (list (list 'bits (if (= bits 0) t (list 'eql bits)))
	  (list 'key (if (null keys) t (list 'eql keys)))
	  (list 'char (if (null char) t (list 'eql char)))) ))

(defmacro install-handler (keys designator)
   `(defmethod %handle-input-char ,(%make-specialized-lambda-list keys)
      (if (fboundp ,designator)
	(let ((*bits* bits) (*key* key) (*char* char))
	  (declare (special *bits* *key* *char*))
	  (funcall ,designator))
	 #+nil
	(warn "Undefined: ~a ~a" ,designator (fboundp ,designator)) )))
	
(install-handler () 'unhandled)

;;;
;;;
(define-condition newline () ())
(defun newline () (signal 'newline))

(install-handler (#\Return) 'newline)

;;;
;;; The line abstracton
(defvar *chars* nil "a list of characters")
(defvar *cursor* 0 "index into *chars*")

(defun collect-char (c)
  (cond ((= *cursor* 0) (setf *chars* (cons c *chars*)))
	(t (let ((cell (nthcdr (1- *cursor*) *chars*)))
	     (rplacd cell (cons c (cdr cell))))))
  (write-char c) ; maybe-redisplay
  (incf *cursor*))

(defun SUPER-READ-LINE (&optional (input-stream ext:*keyboard-input*)
				  (eof-error-p t) (eof-value nil)
				  (recursive-p nil))
  (handler-bind ((newline
		   (lambda (c)
		     (declare (ignore c))
		     (return-from super-read-line
				  (values (coerce *chars* 'string) nil))))
		 (end-of-file
		   (lambda (c)
		     (declare (ignore c))
		     (unless eof-error-p ; decline
		       (return-from super-read-line
				    (values (if (null *chars*)
					      eof-value
					      (coerce *chars* 'string)) t))))))
    (loop with *chars* = nil  and *cursor* = 0
	  for c = (super-read-char input-stream eof-error-p eof-value
				   recursive-p)
	  do (collect-char c))))

;;;
;;; display
(defun invariants ()
  (assert (<= 0 *cursor* (length *chars*)))
  (unless *chars* (assert (= *cursor* 0))))

(defun beep ()
  (invariants))

(defvar *prompt* "golem> ")

(defun redisplay (&rest keys)
  (declare (ignore keys))
  (invariants)
  (let* ((prompt (if (stringp *prompt*) *prompt* ""))
	 (padding (+ (length prompt) *cursor*)))
    (format t "~&~v:@a~&~a" padding #\v prompt)); ascii art denoting the cursor
  (format t "~a" (coerce *chars* 'string))
  (force-output))

(install-handler (:control #\l) 'redisplay)
(install-handler (:control #\g) 'beep)
;; Too bad we cant rebind Control-C

;;;
;;; moving around
(defun forward-char ()
  (cond ((= *cursor* (length *chars*)) (beep))
	(t (incf *cursor*) (redisplay :cursor))))

(defun backward-char ()
  (cond ((= *cursor* 0) (beep))
	(t (decf *cursor*) (redisplay :cursor))))

(install-handler (:right) 'forward-char)
(install-handler (:left) 'backward-char)
(install-handler (:control #\f) 'forward-char)
(install-handler (:control #\b) 'backward-char)

;;;
;;;
(defun move-cursor-if (&key (dir :forward) test)
  (loop until (or (ecase dir
		    (:forward (= *cursor* (length *chars*)))
		    (:backward (= *cursor* 0)))
		  (not (funcall test
		 	 (ecase dir
			   (:forward (nth *cursor* *chars*))
			   (:backward (nth (1- *cursor*) *chars*))))))
	do (ecase dir
	     (:forward (incf *cursor*))
	     (:backward (decf *cursor*)))))

(defun whitespacep (c)
  (and c (or (sys::whitespacep c) (char= c #\() (char= c #\)))))

(defun %end-of-word (&key (skip-white t))
  (let ((*cursor* *cursor*) (*chars* *chars*)) ; save-excursion
    (when skip-white (move-cursor-if :test #'whitespacep))
    (move-cursor-if :test (complement #'whitespacep))
    *cursor*))

(defun %begining-of-word (&key (skip-white t))
  (let ((*cursor* *cursor*) (*chars* *chars*)) ; save-excursion
    (when skip-white (move-cursor-if :test #'whitespacep :dir :backward))
    (move-cursor-if :test (complement #'whitespacep) :dir :backward)
    *cursor*))

(defun forward-word ()
  (setf *cursor* (%end-of-word))
  (redisplay :cursor))

(defun backward-word ()
  (setf *cursor* (%begining-of-word))
  (redisplay :cursor))

(install-handler (:control :left) 'backward-word)
(install-handler (:control :right ) 'forward-word)
(install-handler (:meta #\f) 'forward-word)
(install-handler (:meta #\b) 'backward-word)

;;;
;;;
(defun begining-of-line ()
  (setf *cursor* 0)
  (redisplay :cursor))

(defun end-of-line ()
  (setf *cursor* (length *chars*))
  (redisplay :cursor))

(install-handler (:control #\a) 'begining-of-line)
(install-handler (:control #\e) 'end-of-line)
(install-handler (:home) 'begining-of-line)
(install-handler (:end) 'end-of-line)

;;;
;;; modifying text
(defun delete-char ()
  (cond ((= *cursor* (length *chars*)) (beep))
	((= *cursor* 0) (setf *chars* (cdr *chars*)) (redisplay))
	(t (let ((cell (nthcdr (1- *cursor*) *chars*)))
	     (rplacd cell (cddr cell))
	     (redisplay)))))

(defun backward-delete-char ()
  (cond ((= *cursor* 0) (beep))
	(t (decf *cursor*) (delete-char))))

(install-handler (#\Backspace) 'backward-delete-char)
(install-handler (:control #\d) 'delete-char)

;;;
;;; yanked text
(defvar *yanked* nil)

(defun kill-to-eol ()
  (setf *yanked* (nthcdr *cursor* *chars*))
  (setf *chars* (nbutlast *chars* (- (length *chars*) *cursor*)))
  (redisplay))

(defun splice (items list cursor)
  "splice ITEMS into LIST at CURSOR position. modifies both lists"
  (let ((rest (nthcdr cursor list)))
    (nconc (nbutlast list (- (length list) cursor)) items rest)))

(defun append-yanked ()
  (cond ((endp *yanked*) (beep))
	(t (setf *chars* (splice (copy-list *yanked*) *chars*  *cursor*))
	   (incf *cursor* (length *yanked*))
	   (redisplay))))

(install-handler (:control #\k) 'kill-to-eol)
(install-handler (:control #\y) 'append-yanked)

;;;
;;; deleting words
(defun delete-word ()
  (if (= (length *chars*) *cursor*)
    (beep)
    (let* ((end-of-word (%end-of-word)) (rest (nthcdr end-of-word *chars*)))
      (setf *yanked* (subseq *chars* *cursor* end-of-word))
      (setf *chars* (nconc (nbutlast *chars* (- (length *chars*) *cursor*))
			   rest))
      (redisplay))))

(defun backward-delete-word ()
  (if (= *cursor* 0)
    (beep)
    (let ((beg-of-word (%begining-of-word)) (rest (nthcdr *cursor* *chars*)))
      (setf *yanked* (subseq *chars* beg-of-word *cursor*))
      (setf *cursor* beg-of-word)
      (setf *chars* (nconc (nbutlast *chars* (- (length *chars*) *cursor*))
			   rest))
      (redisplay))))

(install-handler (:meta #\d) 'delete-word)
(install-handler (:meta #\Backspace) 'backward-delete-word)

;;;
;;; Tab completion hack - hook into CLISP's completion function
#-completings ;; load complete.lisp (not loaded on win32)
(let ((*features* (adjoin :UNIX *features*)))
  (ext:without-package-lock ("SYSTEM")
    (load "c:/madhu/clisp/src/complete.lisp"))
  (pushnew :completings *features*))

(defun %mismatch-at (completions)
  (let ((index -1))
    (apply #'map nil #'(lambda (&rest chars)
			 (incf index)
			 (loop with hd = (car chars)
			       for x in (cdr chars)
			       unless (eql x hd)
			       do (return-from %mismatch-at index)))
	   completions)))

(defun %replace-with-completion (position-at replacement-string)
  (let ((rest (nthcdr *cursor* *chars*)))
    (setf *cursor* position-at)
    (setf *chars* (nbutlast *chars* (- (length *chars*) *cursor*)))
    (loop for c across replacement-string do
	  (setf *chars* (nconc *chars* (list c)))
	  (incf *cursor*))
    (setf *chars* (nconc *chars* rest)))
  (redisplay))

(defun complete (&aux (begining-of-word (%begining-of-word :skip-white nil))
		      (completions (sys::completion (coerce *chars* 'string)
					begining-of-word *cursor*)))
  (cond ((listp completions)
	 (cond ((endp completions) (beep))
	       ((endp (cddr completions)) ; full completion
		(%replace-with-completion begining-of-word (car completions)))
	       (t (pprint (cdr completions)) ; partial completion
		  (let ((idx (%mismatch-at (cdr completions))))
		    (if (and idx (< 0 idx)(<(- *cursor* begining-of-word) idx))
		      (%replace-with-completion begining-of-word
			(subseq (car completions) 0 idx))
		      (redisplay))))))
	(t (format t "hmm: ~a" completions) (redisplay))))
	
(install-handler (#\Tab) 'complete)

;;;
;;; primitive history manipulation
(defvar *history* nil)
(defvar *history-max* 5)
(defvar *history-idx* nil) ; if non nil: the index of active search

(defun %maybe-save-history (line) (assert (null *history-idx*))
  (unless (or (= (length line) 0)
	      (and *history* (string= line (car *history*))))
    (push line *history*)
    (let ((diff (- (length *history*) *history-max*)))
      (when (> diff 0) ;; snip off tail
	(assert (= diff 1)) ; (unless someone changed max on us)
	(setf *history* (nbutlast *history* diff))))))

(defun %history-redisplay () (assert *history-idx*)
  (setf *chars* (coerce (nth *history-idx* *history*) 'list)
	*cursor* (length *chars*))
  (redisplay))

(defun previous-history ()
  (if (endp *history*) (return-from previous-history (beep)))
  (unless *history-idx*
    (push (coerce *chars* 'string) *history*)
    (setf *history-idx* 0))
  (cond ((< -1 *history-idx* (1- (length *history*)))
	 (incf *history-idx*) (%history-redisplay))
	((= *history-idx* (1- (length *history*))) (beep))
	(t (error "prev-hist: sanity fails"))))

(defun next-history ()
  (cond ((or (null *history-idx*) (zerop *history-idx*)) (beep))
	((<= 1 *history-idx* (1- (length *history*)))
	 (decf *history-idx*) (%history-redisplay))
	(t (error "next-hist: sanity fails"))))

(install-handler (:control #\p) 'previous-history)
(install-handler (:control #\n) 'next-history)
(install-handler (:up) 'previous-history)
(install-handler (:down) 'next-history)

;;;
;;; Sample Use:
(defun repl (&aux read build eval)
  (loop
    (let ((*prompt* (concatenate 'string (funcall custom::*prompt*) " ") ))
      (with-simple-restart (continue "Return to poor man's repl.")
	(format t "~a" *prompt*) (force-output)
	(setf read (unwind-protect (super-read-line)
		     (if *history-idx* (setf *history* (cdr *history*) 
					     *history-idx* nil))))
	(%maybe-save-history read)
	(setf build (read-from-string read nil))
	(setf eval (multiple-value-list (let ((- build)) (eval build))))
	(shiftf +++ ++ + build) (shiftf *** ** * (car eval))
	(shiftf /// // / eval)
	(format t "~&~A~{ ;~&~A~}~&" (car eval) (cdr eval)) (force-output)))))
	    
(%handle-input-char t t t) ; reduce startup time in CLOS inits
#|
;;; TODO
(install-handler (:control #\w) 'delete-yank-word)
(install-handler (:control #\q) 'quote-verbatim)
(install-handler (:control #\u) 'kill-line-to-bol)

(install-handler (:meta #\w) 'copy-region)
(install-handler (:meta #\y) 'yank-cycle)

;;;
;;; regexp against history
(defvar *search-string* nil)

(defun %search-match ()
 (when *search-string*
  (loop with regex = (cl-ppcre:create-scanner (coerce *search-string* 'string))
	for i from 0 below (length *history*)
	for target = (coerce (nth i *history*) 'string)
	when (cl-ppcre:scan regex string) (return i))))
	
(define-condition accept-search () ())
(define-condition cancel-search () ())

;;; maybe we want something like *read-char-dispatcher* (bound to
;;; %handle-input-char) for super-read-char to call

(install-handler (:control #\r) 'search-history-backwards) ; cl-ppcre

;;; debug
(defun unhandled nil
 (declare (special *bits* *key* *char*))
 (let ((bits *bits*) (key *key*) (char *char*))
  (format t "bits=~a key=~a char=~a~&"
	      bits (if (and (characterp key) (not (graphic-char-p key)))
		     (char-name key)
		     key)
	      (if (and char (not (graphic-char-p char)))
		(char-name char)
		char) )))

(defun test2 ()
  (ext:with-keyboard)
  (loop (let ((c (super-read-char ext:*keyboard-input*)))
      (pprint c)
      (if (null c) (return))	
      (etypecase c (character)))))
|#