;;;;  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 2002/03/02 01:03:12 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-automatic-reindent t
  "*Non-nil if sedit should reindent the code automatically.")

(defvar sedit-movement-sets-mark nil
  "*If non-nil, sedit sometimes automatically marks structures.
Moving out of a list or a string, using `\\[sedit-move-past-close]', or
`\\[sedit-string-literal]' inside a string, sets mark at the beginning of
the string or list exited.")

(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-string-literal)
  (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  "\C-c\C-j"	'sedit-join-structures)
  (define-key  keymap  "\C-c\C-s"	'sedit-split-structure)
  ;;(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))



;;;  ==================================================================
;;;  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 "Inside string: %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 "Inside comment: %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 "Parenthesis depth: %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)
      (re-search-forward "\\s\""))
    (point)))


(defun sedit-end-of-comment-pos (&optional pos)
  "Return the position of the end of the comment.
This is the first character *after* the comment; when end-of-line
terminates comments, it will be the first character of the next line.
POS (defaults to current value of point) must be a position inside
a comment, or the result is undefined."

  (save-excursion
    (if pos (goto-char pos))
    (while (sedit-inside-comment-p)
      (forward-char 1))
    (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))))


(defun sedit-get-matching-paren (char &optional table)
  (let ((table (or table (syntax-table))))
    (cdr (elt table char))))


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


(defun sedit-delete-char (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: Implement this with a `sedit-kill-or-delete-region' function?

  (interactive "*p\nP")
  (let* ((delfunc (if killp #'kill-region #'delete-region))
	 (start (point))
	 (end (+ start nchars)))
    (cond
     (nil ;;(< nchars 0)
      (sedit-delete-backward-char (- nchars) killp))
     
     ((not (sedit-well-formed-region-p start end))
      (error "Deleting a non-well-formed sequence of sexps is forbidden"))

     ((sedit-inside-string-p)
      (funcall delfunc start end))

     ((sedit-inside-comment-p)
      ;; XXXX: Check this logic more!
      (let* ((stop (min (+ start nchars)
			(1- (sedit-end-of-comment-pos)))))
	(if (> (+ start nchars) stop)
	    (error "Can't join comment line with next line this way"))
	(funcall delfunc start stop)))

     (t
      (funcall delfunc start end)))))


(defun sedit-delete-backward-char (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."

  (interactive "*p\nP")

  ;; XXXX: We punt for now
  (sedit-delete-char (- nchars) killp))

(defun sedit-delete-backward-char-OLD (nchars killp)
  ""
  ;; 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-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*\"")))))


(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)
    (if sedit-automatic-reindent (indent-sexp))
    (if sedit-movement-sets-mark
	(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 &optional openclose)
  "Put parenthesis 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")

  (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 openclose)
    (let* ((openclose (or openclose "()"))
	   (open-paren (elt openclose 0))
	   (close-paren (elt openclose 1)))
      (goto-char end)
      (insert close-paren)
      (goto-char start)
      (re-search-forward "\\S-")
      (forward-char -1)
      (insert open-paren)
      (if sedit-automatic-reindent
	  (progn
	    (forward-char -1)
	    (indent-sexp)
	    (forward-char 1))))))


(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)
	(condition-case nil
	    ;; In case we already are at topmost level
	    (progn
	      (backward-up-list 1)
	      (indent-sexp))
	  (error))
	(if (sedit-looking-under "\\sw\\|\\s_")
	    (insert ?\ )))
      (goto-char list-end-pos)
      (sit-for 1))))


(defun sedit-join-lists ()
  "Join two adjacent lists or vectors into one."
  (if (sedit-inside-string-p)
      (error "Must be outside a string to join two lists"))
  (if (sedit-inside-comment-p)
      (error "Must be outside a comment to join two lists"))
  (let (next-sexp-end
	prev-sexp-start
	next-list-start next-list-open next-list-close
	prev-list-end--1 prev-list-close prev-list-open)
    (save-excursion
      (forward-sexp 1)
      (setq next-sexp-end (point)))
    (save-excursion
      (forward-sexp -1)
      (setq prev-sexp-start (point)))
    (save-excursion
      (down-list 1)
      (backward-char 1)
      (setq next-list-start (point)
	    next-list-open (char-after (point))
	    next-list-close (sedit-get-matching-paren next-list-open)))
    (save-excursion
      (down-list -1)
      (setq prev-list-end--1 (point)
	    prev-list-close (char-after (point))
	    prev-list-open (sedit-get-matching-paren prev-list-close)))
    (if (or (<= next-sexp-end next-list-start)
	    (> prev-sexp-start prev-list-end--1))
	(error "Can only join two adjacent lists"))
    (if (or (not (equal prev-list-close next-list-close))
	    (not (equal prev-list-open next-list-open)))
	(error "Can't join lists of different types"))
    (save-excursion
      (goto-char next-list-start)
      (delete-char 1 nil)
      (goto-char prev-list-end--1)
      (delete-char 1 nil)
      (if sedit-automatic-reindent
	  (progn
	    (up-list -1)
	    (indent-sexp))))))


(defun sedit-split-list ()
  "Split a list or vector into two at point."
  (if (sedit-inside-comment-p)
      (error "Must be outside comments to split a list"))
  (if (sedit-inside-string-p)
      (error "Must be outside string to split a list"))
  ;; XXXX: The placement of point afterwards is not optimal.  It
  ;; should make sure that point is *between* the two created lists.
  ;; As it is, if point is just after an element, it will be inside
  ;; the first list.
  ;; XXXX: If point is within an atom, the behaviour is not quite
  ;; intuitive.  It should probably refuse execution then.
  (save-excursion
    (let* ((here (point))
	   ;; Would be better to get the corresponding open and close
	   ;; characters instead.
	   (close-paren
	    (progn (up-list -1)
		   (sedit-get-matching-paren (char-after (point)))))
	   (open-paren
	    (progn (forward-sexp 1) 
		   (sedit-get-matching-paren (char-after (1- (point)))))))
      (goto-char here)
      (backward-sexp 1)
      (forward-sexp 1)
      (insert close-paren)
      (forward-sexp 1)
      (backward-sexp 1)
      (insert open-paren))))


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


(defun sedit-string-literal ()
  "Insert a pair of string delimiters if not inside a string.
If following a quoting backslash, insert a single delimiter.  Otherwise,
if inside a string,leave that string (similar to sedit-move-past-close)."

  (interactive "*")
  (cond
   ((sedit-looking-under "\\([^\\]\\|\\`\\)\\\\\\(\\\\\\\\\\)*")
    ;; After an odd number of backslashes
    (self-insert-command 1))
   ((sedit-inside-comment-p)
    ;; Inside a comment, just insert a single delimiter
    (self-insert-command 1))
   ((sedit-inside-string-p)
    ;; Inside a string, go to the end of the string
    (goto-char (sedit-end-of-string-pos))
    (if sedit-movement-sets-mark
	(progn
	  (backward-sexp 1)
	  (push-mark (point) 'nomsg sedit-movement-activate-mark)
	  (forward-sexp))))
   (t
    ;; Otherwise, create a string literal and place point inside
    (self-insert-command 2)
    (forward-char -1))))


(defun sedit-join-strings ()
  "Join the string constant before point with the one after point."
  (if (sedit-inside-string-p)
      (error "Must be outside a string to join two strings"))
  (if (sedit-inside-comment-p)
      (error "Must be outside a comment to join two strings"))
  (let* ((here (point))
	 (prev-sexp-end (save-excursion
			  (backward-sexp 1)
			  (forward-sexp 1)
			  (backward-char 1)
			  (if (not (sedit-inside-string-p))
			      (error "Sexp before point is not a string"))
			  (point)))
	 (next-sexp-start (save-excursion
			    (forward-sexp 1)
			    (backward-sexp 1)
			    (forward-char 1)
			    (if (not (sedit-inside-string-p))
				(error "Sexp after point is not a string"))
			    (point))))
    ;; XXXX: Should check if there is a comment between (1+ prev-sexp-end)
    ;; and (1- next-sexp-end)
    (delete-region prev-sexp-end next-sexp-start)))


(defun sedit-split-string ()
  "Split a string into two at point."
  (if (not (sedit-inside-string-p))
      (error "Must be inside a string to split it"))
  ;; XXXX: Get the actual string delimiters used.
  (insert "\" \""))


(defun sedit-join-structures ()
  "Join two strings or two lists around point to one."
  (interactive "*")
  (condition-case signame
      (sedit-join-lists)
    (error (sedit-join-strings))))


(defun sedit-split-structure ()
  "Split a string or list in two at point."
  (interactive "*")
  (if (sedit-inside-string-p)
      (sedit-split-string)
    (sedit-split-list)))



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


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

(defun sedit-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)