;;;;  sedit.el
;;;;		En struktureditor a la InterLISPs Sedit, men under
;;;;		GNU-Emacs.
;;;;
;;;;
;;;;  Copyright (C) 1992-2002	Thomas Bellman
;;;;				Lysator Computer Club,
;;;;				Linköping University,  Sweden
;;;;
;;;;  Everyone is granted permission to copy, modify and redistribute
;;;;  this code, provided the people they give it to can.
;;;;
;;;;
;;;;  Author:	Thomas Bellman
;;;;		Lysator Computer Club
;;;;		Linköping University
;;;;		Sweden
;;;;
;;;;  email:	bellman@lysator.liu.se
;;;;
;;;;
;;;;  Any opinions expressed in this code are the author's PERSONAL opinions,
;;;;  and does NOT, repeat NOT, represent any official standpoint of Lysator,
;;;;  even if so stated.


(defconst sedit-rcsId "$Id: sedit.el,v 1.3 2007/08/14 17:37:52 bellman Exp $"
  "RCS id of sedit.el.")


;;;  ==================================================================
;;;  Variables

(defvar sedit-mode-map nil "Keymap used in sedit mode.")
(defvar sedit-mode-syntax-table nil "Syntax table for sedit mode.")
(defvar sedit-movement-activate-mark nil)

(setq sedit-mode-map (make-sparse-keymap))
(defun sedit--define-sedit-keys (keymap)
  (define-key  keymap  "("		'sedit-insert-parentheses)
  (define-key  keymap  "["		'sedit-insert-brackets)
  (define-key  keymap  ")"		'sedit-move-past-close)
  (define-key  keymap  "]"		'sedit-move-past-close)
  (define-key  keymap  "\""		'sedit-double-quotes)
  (define-key  keymap  "\C-d"		'sedit-delete-char)
  (define-key  keymap  "\C-?"		'sedit-delete-backward-char)
  (define-key  keymap  "\C-w"		'sedit-kill-region)
  (define-key  keymap  "\M-("		'sedit-parenthesize-region)
  (define-key  keymap  "\C-\M-r"	'sedit-unparenthesize)
  ;;(define-key  keymap  " "		'sedit-space)
  ;;(define-key  keymap  ";"		'sedit-comment)
  ;;(define-key  keymap  "\C-k"		'sedit-kill-line)
  )
(sedit--define-sedit-keys sedit-mode-map)


(let ((i 0))
  (setq sedit-mode-syntax-table (make-syntax-table))
  (while (< i ?0)
    (modify-syntax-entry i "_   " sedit-mode-syntax-table)
    (setq i (1+ i)))
  (setq i (1+ ?9))
  (while (< i ?A)
    (modify-syntax-entry i "_   " sedit-mode-syntax-table)
    (setq i (1+ i)))
  (setq i (1+ ?Z))
  (while (< i ?a)
    (modify-syntax-entry i "_   " sedit-mode-syntax-table)
    (setq i (1+ i)))
  (setq i (1+ ?z))
  (while (< i 128)
    (modify-syntax-entry i "_   " sedit-mode-syntax-table)
    (setq i (1+ i)))
  (modify-syntax-entry ?  "    " sedit-mode-syntax-table)
  (modify-syntax-entry ?\t "    " sedit-mode-syntax-table)
  (modify-syntax-entry ?\n ">   " sedit-mode-syntax-table)
  (modify-syntax-entry ?\f ">   " sedit-mode-syntax-table)
  (modify-syntax-entry ?\; "<   " sedit-mode-syntax-table)
  (modify-syntax-entry ?` "'   " sedit-mode-syntax-table)
  (modify-syntax-entry ?' "'   " sedit-mode-syntax-table)
  (modify-syntax-entry ?, "'   " sedit-mode-syntax-table)
  (modify-syntax-entry ?. "'   " sedit-mode-syntax-table)
  (modify-syntax-entry ?# "'   " sedit-mode-syntax-table)
  (modify-syntax-entry ?\" "\"    " sedit-mode-syntax-table)
  (modify-syntax-entry ?\\ "\\   " sedit-mode-syntax-table)
  (modify-syntax-entry ?\( "()  " sedit-mode-syntax-table)
  (modify-syntax-entry ?\) ")(  " sedit-mode-syntax-table)
  (modify-syntax-entry ?\[ "(]  " sedit-mode-syntax-table)
  (modify-syntax-entry ?\] ")[  " sedit-mode-syntax-table))


(put 'sedit-bad-structure-deletion
     'error-conditions '(error sedit-bad-structure-deletion))
(put 'sedit-bad-structure-deletion
     'error-message "Bad structure deletion")
(if (not (member 'sedit-bad-structure-deletion debug-ignored-errors))
    (setq debug-ignored-errors
	  (cons 'sedit-bad-structure-deletion debug-ignored-errors)))



;;;  ==================================================================
;;;  Help functions


(defun sedit-inside-string-p (&optional pos)
  "Returns non-nil if point or optional argument POS is inside a string,
nil otherwise."
  (interactive "d")

  (let ((in-string (save-excursion
		     (if pos (goto-char pos))
		     (let ((endpoint (point)))
		       (beginning-of-defun)
		       (elt (parse-partial-sexp (point) endpoint) 3)))))
    (if (interactive-p)
	(message "[%s]" in-string))
    in-string))


(defun sedit-inside-comment-p (&optional pos)
  "Returns non-nil if point or optional argument POS is inside a comment,
nil otherwise."
  (interactive "d")
  (let ((in-comment (save-excursion
		      (if pos (goto-char pos))
		      (let ((endpoint (point)))
			(beginning-of-defun)
			(elt (parse-partial-sexp (point) endpoint) 4)))))
    (if (interactive-p)
	(message "[%s]" in-comment))
    in-comment))


(defun sedit-paren-depth (&optional pos)
  (interactive "d")
  (let ((depth (save-excursion
		 (beginning-of-defun)
		 (elt (parse-partial-sexp (point) pos) 0))))
    (if (interactive-p)
	(message "[%s]" depth))
    depth))


(defun sedit-end-of-string-pos (&optional pos)
  "Return the position of the end of the string.
POS (defaults to current value of point) must be a position inside
a string, or the result is undefined."

  (save-excursion
    (if pos (goto-char pos))
    (while (sedit-inside-string-p)
      (search-forward "\""))
    (point)))


(defun sedit-well-formed-region-p (start end)
  "Returns non-nil if the region is a well-formed sequence of sexps.
"
  ;;(interactive "r")
  (if (< end start)
      (sedit-well-formed-region-p end start)
    (save-excursion
      (goto-char start)
      (beginning-of-defun)
      (let* ((state0 (parse-partial-sexp (point) start))
	     (start-depth (elt state0 0))
	     (start-in-string (elt state0 3))
	     (end-of-string-pos (if start-in-string
				    (sedit-end-of-string-pos (point))))
	     (state (parse-partial-sexp start end nil nil state0))
	     (end-depth (elt state 0))
	     (min-depth (elt state 6))
	     (end-in-string (elt state 3))
	     (parens-ok (and (= start-depth end-depth)
			     (<= start-depth min-depth)))
	     (strings-ok (or (and (not start-in-string) (not end-in-string))
			     (and start-in-string end-in-string
				  (> end-of-string-pos end))))
	     (comments-ok t
			  ;; Well, this is obviously a bit simplistic...
			  )
	     (answer (and parens-ok strings-ok comments-ok)))
	(if (interactive-p)
	    ;; Some debugging messages
	    (progn
	      (message "Parens: %d %d %d => %s"
		       start-depth min-depth end-depth parens-ok)
	      (message "Strings: %s %s %s %s => %s"
		       start-in-string end-in-string end-of-string-pos end
		       strings-ok)
	      (message "Comments: => %s"
		       comments-ok)
	      ))
	answer))))



;;;  ==================================================================
;;;  Some commands


(defun sedit-delete-char-OLD (nchars killp)
  "Delete the following NCHARS characters (previous, with negative arg).
Optional second arg KILLFLAG non-nil means kill instead (save in kill ring).
Interactively, NCHARS is the prefix arg, and KILLFLAG is set if
NCHARS was explicitly specified."
  ;; XXXX: Should behave differently inside strings and comments
  (interactive "*p\nP")
  (cond
   ((< nchars 0)
    (sedit-delete-backward-char (- nchars) killp))
   ((sedit-inside-comment-p)
    (let* ((start (point))
	   (stop (min (+ start nchars) (save-excursion (end-of-line) (point))))
	   err)
      (if killp
	  (kill-region start stop)
	(delete-region start stop))
      (if (> (+ start nchars) stop)
	  (error "Can't join comment line with next line this way"))
      ))
   (t
    (let ((start (point)) stop err)
      (save-excursion
	(setq err (re-search-forward "\\s(\\|\\s)\\|\\s\""
				     (+ start nchars) 'nofail))
	(if err
	    (setq stop (1- (point)))
	  (setq stop (point))))
      (if killp
	  (kill-region start stop)
	(delete-region start stop))
      (if err
	  (error "Can't delete structure this way"))))
   ((sedit-inside-string-p)
    (error "Don't know how to delete inside strings yet"))))

(defun sedit-delete-char (nchars killflag)
  "Delete the following NCHARS characters (previous, with negative arg).
Optional second arg KILLFLAG non-nil means kill instead (save in kill ring).
Interactively, NCHARS is the prefix arg, and KILLFLAG is set if
NCHARS was explicitly specified."
  (interactive "*p\nP")
  (let ((start (point))
	(end (+ (point) nchars)))
    (cond
     ((< nchars 0)
      (sedit-delete-backward-char (- nchars) killflag))
     ((> end (point-max))
      (signal 'end-of-buffer nil))
     ((sedit-well-formed-region-p start end)
      (if killflag
	  (kill-region start end)
	(delete-region start end)))
     (t
      (signal 'sedit-bad-structure-deletion nil)))))


(defun sedit-delete-backward-char-OLD (nchars killp)
  "Delete the previous NCHARS characters (following, with negative arg).
Optional second arg KILLFLAG non-nil means kill instead (save in kill ring).
Interactively, NCHARS is the prefix arg, and KILLFLAG is set if
NCHARS was explicitly specified."
  ;; XXXX: Should behave differently inside strings and comments
  (interactive "*p\nP")
  (if (< nchars 0)
      (sedit-delete-char (- nchars) killp)
    (let ((start (point)) stop err)
      (save-excursion
	(setq err (re-search-backward "\\s(\\|\\s)\\|\\s\""
				      (- start nchars) 'nofail))
	(if err
	    (setq stop (1+ (point)))
	  (setq stop (point))))
      (if killp
	  (kill-region start stop)
	(delete-region start stop))
      (if err
	  (error "Can't delete structure this way")))))

(defun sedit-delete-backward-char (nchars &optional killflag)
  "Delete the previous NCHARS characters (following, with negative arg).
Optional second arg KILLFLAG non-nil means kill instead (save in kill ring).
Interactively, NCHARS is the prefix arg, and KILLFLAG is set if
NCHARS was explicitly specified."
  (interactive "*p\nP")
  (let ((start (point))
	(end (- (point) nchars)))
    (cond
     ((< nchars 0)
      (sedit-delete-char (- nchars) killflag))
     ((< end (point-min))
      (signal 'beginning-of-buffer nil))
     ((sedit-well-formed-region-p start end)
      (if killflag
	  (kill-region start end)
	(delete-region start end)))
     (t
      (signal 'sedit-bad-structure-deletion nil)))))



(defun sedit-space (arg)
  "Insert a space and possibly reformat code."
  (interactive "*P")

  (cond
   (arg
    (insert-char ?  (prefix-numeric-value arg)))
   ((or (sedit-inside-string-p) (sedit-inside-comment-p))
    (insert " "))
   ((>= (current-column) fill-column)
    (save-excursion
      (backward-sexp)
      (newline-and-indent))
    (insert " "))
   (t
    (insert " "))))


(defun sedit-forward-sexp (arg)
  (cond
   ((sedit-inside-string-p)
    (if (looking-at "\\w*\"") nil))))


(defun sedit-kill-region (start end)
  "Kill between point and mark, if the structure remains well-formed.
See command \\[kill-region] for more information."
  (interactive "*r")
  (if (sedit-well-formed-region-p start end)
      (kill-region start end)
    (error "Region is not a well-formed sequence of sexps")))


(defun sedit-kill-line (arg)
  "Kill the rest of the line."
  (interactive "*P")
  (let ((start-point (point))
	(line-end (save-excursion (end-of-line) (point))))
    (while (<= (point) line-end)
      (forward-sexp))))


;;;  ==================================================================
;;;  Handle lists


(defun sedit--insert-brackets-internal (arg)
  ;; This is a literal copy of the definition of insert-parentheses in
  ;; lisp.el, with [ and ] substituted for ( and ).
  "Put brackets (`[]') around next ARG sexps.  Leave point after open-bracket.
A negative ARG encloses the preceding ARG sexps instead.
No argument is equivalent to zero: just insert `[]' and leave point between.
If `parens-require-spaces' is non-nil, this command also inserts a space
before and after, depending on the surronding characters."
  (interactive "*P")
  (if arg (setq arg (prefix-numeric-value arg))
    (setq arg 0))
  (cond ((> arg 0) (skip-chars-forward " \t"))
        ((< arg 0) (forward-sexp arg) (setq arg (- arg))))
  (and parens-require-spaces
       (not (bobp))
       (memq (char-syntax (preceding-char)) '(?w ?_ ?\( ))
       (insert " "))
  (insert ?\[)
  (save-excursion
    (or (eq arg 0) (forward-sexp arg))
    (insert ?\])
    (and parens-require-spaces
	 (not (eobp))
	 (memq (char-syntax (following-char)) '(?w ?_ ?\( ))
	 (insert " "))))

(defun sedit-insert-brackets (arg)
  (interactive "*P")
  (if (or (sedit-inside-string-p) (sedit-inside-comment-p))
      (self-insert-command (prefix-numeric-value arg))
    (sedit--insert-brackets-internal arg)))


(defun sedit-insert-parentheses (arg)
  (interactive "*P")
  (if (or (sedit-inside-string-p) (sedit-inside-comment-p))
      (self-insert-command (prefix-numeric-value arg))
    (insert-parentheses arg)))


;;; XXXX -- In some version of Emacs 19, this should display the exited
;;;	    list underlined.

(defun sedit-move-past-close (arg)
  "Move out of the list the point is.  Move ARG lists if given, or 1
default."
  (interactive "p")
  (if (or (sedit-inside-string-p) (sedit-inside-comment-p))
      (self-insert-command arg)
    (backward-up-list arg)
    (push-mark (point) 'nomsg sedit-movement-activate-mark)
    (forward-sexp 1)
    (if (not sedit-movement-activate-mark)
	(blink-matching-open)))
  )



;;; XXXX -- Where should point be placed afterwards?

(defun sedit-parenthesize-region (start end)
  "Put paranthesis around region.  Point is placed after opening parenthesis.
START and END must be on the same level of sexps.
When called from a program, START and END are positions in the current buffer."
  (interactive "*r")

  ;; XXXX: This check isn't complete.  It doesn't catch this situation:
  ;;	(cond (^(foo-p) nil) ((bar-p)_ 17))
  ;; Start and end are marked with ^ and _.
  (if (not (sedit-well-formed-region-p start end))
      (error "Region is not a well-formed sequence of sexps"))
  (if (< end start)
      (sedit-parenthesize-region end start)
    (goto-char end)
    (insert ?\))
    (goto-char start)
    (re-search-forward "\\S-")
    (forward-char -1)
    (insert ?\()))



(defun sedit-unparenthesize (arg)
  (interactive "*p")
  (re-search-forward "\\s-*")
  (save-excursion
    (let ((list-start-pos (point))
	  list-end-pos)
      (while (>= (setq arg (1- arg)) 0)
	(if (not (looking-at "\\s("))
	    (error "Not at start of list, sedit-unparenthesize"))
	(forward-sexp 1)
	(delete-backward-char 1)
	(if (looking-at "\\sw\\|\\s_")
	    (insert ?\ ))
	(setq list-end-pos (1- (point)))
	(goto-char list-start-pos)
	(delete-char 1)
	(backward-up-list 1)
	(indent-sexp)
	(if (looking-under "\\sw\\|\\s_")
	    (insert ?\ )))
      (goto-char list-end-pos)
      (sit-for 1))))



;;;  ==================================================================
;;;  Handle strings


(defun sedit-double-quotes ()
  "Insert a pair of double quotes if not inside a string.  If following a
quoting backslash, insert one double quote.  Otherwise, if inside a string,
leave that string (similar to move-past-close)."
  (interactive "*")
  (cond
   ((looking-under "\\([^\\]\\|\\`\\)\\\\\\(\\\\\\\\\\)*")
    ;; After an odd number of backslashes
    (insert ?\"))
   ((sedit-inside-comment-p)
    ;; Inside a comment, just insert a single double quote
    (insert ?\"))
   ((sedit-inside-string-p)
    ;; Inside a string, go to the end of the string
    (goto-char (sedit-end-of-string-pos)))
   (t
    ;; Otherwise, create a string literal and place point inside
    (insert ?\"?\")
    (forward-char -1))))





;;;  ==================================================================
;;;  Support functions


;; Same as looking-at, but compares against the text immediately before
;; point in stead of after.

(defun looking-under (pat)
  "Return non-nil if text before point matches regular expression PAT.
This function modifies the match data that `match-beginning',
`match-end' and `match-data' access; save and restore the match
data if you want to preserve them."
  (save-excursion
    (eq (point)
	(progn
	  (re-search-backward pat nil t)
	  (match-end 0)))))



;;;  ==================================================================
;;;  Final touch-ups

;;;  These should be removed when SEDIT mode is usable.

(sedit--define-sedit-keys emacs-lisp-mode-map)
(sedit--define-sedit-keys lisp-interaction-mode-map)