;;; tprops.el -- dealing with text with properties and saving it as sexps
;;
;; Author:  Eduardo Ochs <edrx@mat.puc-rio.br>
;; Version: 2004aug25
;; URL: http://angg.twu.net/elisp/trops.el
;;
;; This doesn't do much right now, but check the demos at the end.
;; Note that they won't work if you're in font-lock mode: font-lock
;; fontifies everything in his own way, so you'll lose the tprops
;; faces.
;;
;; (find-elnode "Saving Properties")
;; (find-elnode "Format Conversion")
;; (find-elnode "Changing Properties" "Function: propertize")
;; (find-elnode "Special Properties")
;; (find-node "(cl)Loop Basics")

;; (load "tprops.el")

;; The data types. We deal with eight data types, named
;;
;;   r0    r1   r2
;;   r0s   r1s  r2s
;;   r0sc       r2sc
;;
;; meaning:
;;
;;   r0:    "representation 0": an emacs string with constant properties
;;   r0s:   a list of r0's
;;   r0sc:  a series of r0's, concatenated; an emacs string with properties
;;   r1:    "representation 1": a string consed to a property plist
;;   r1s:   a list of r1's
;;   r2:    "representation 2": an r1 converted to text
;;   r2s:   a list of r2's
;;   r2sc:  a list of r2's, concatenated (possibly with newlines)
;;
;; Examples:
;;
;;   r0:    #("el" 0 2 (face fg:yellow))
;;   r0s:   ("H" #("el" 0 2 (face fg:yellow)) "lo")
;;   r0sc:  #("Hello" 0 1 nil 1 3 (face fg:yellow) 3 5 nil)
;;   r1:    ("el" face fg:yellow)
;;   r1s:   (("H") ("el" face fg:yellow) ("lo"))
;;   r2:    "(\"el\" face fg:yellow)"
;;   r2s:   ("(\"H\")" "(\"el\" face fg:yellow)" "(\"lo\")")
;;   r2sc:  "(\"H\")\n(\"el\" face fg:yellow)\n(\"lo\")\n"

;; Converting from internal (r0) to external (r2):
;;
(defun tp-r0-region-to-r1 (s e)
  (interactive "r")
  (cons (buffer-substring-no-properties s e)
	(text-properties-at s)))

(defun tp-r0sc-region-to-r1s (s e)
  (interactive "r")
  (let ((nextpos (next-property-change s nil e)))
    (if (and nextpos (< nextpos e))
        (cons (tp-r0-region-to-r1 s nextpos)
	      (tp-r0sc-region-to-r1s nextpos e))
      (if (< s e)
	  (list (tp-r0-region-to-r1 s e))))))

(defun tp-r1s-to-r2sc (r1s)
  (mapconcat (lambda (r1) (format "%S\n" r1)) r1s ""))

;; Converting from external (r2) to internal (r0):
;;
(defun tp-r2sc-to-r1s (r2sc)
  (read (concat "(" r2sc ")")))

(defun tp-r1-to-r0 (r1)
  (if (cdr r1) (apply 'propertize r1) (car r1)))

(defun tp-r1s-to-r0sc (r1s)
  (mapconcat 'tp-r1-to-r0 r1s ""))

;; r2sc buffer -> r0sc buffer
;;
(defun tp-r2sc-region-to-r0sc-buffer (buffername s e)
  (if (get-buffer buffername)
      (error "tp-make-r0-buffer: buffer %S exists" buffername))
  (let* ((r2sc (buffer-substring-no-properties s e))
	 (r1s (tp-r2sc-to-r1s r2sc))
	 (r0sc (tp-r1s-to-r0sc r1s))
	 (b-f-c-s buffer-file-coding-system))
    (with-current-buffer (get-buffer-create buffername)
      (set (make-local-variable 'buffer-file-coding-system) b-f-c-s)
      (insert r0sc))))

(defun tp-r0ize-buffer (buffername &optional s e)
  (tp-r2sc-region-to-r0sc-buffer
   buffername (or s (point-min)) (or e (point-max)))
  (switch-to-buffer buffername))

;; Saving the contents of a r0sc buffer into the r2sc buffer that generated it
;;
(defun tp-end-of-initial-comments ()
  (save-excursion
    (goto-char (point-min))
    (while (and (not (eobp)) (looking-at "[ \t]*\\(;\\|$\\)"))
      (forward-line 1))
    (point)))
      
(defun tp-beginning-of-final-comments ()
  (save-excursion
    (goto-char (point-max))
    (forward-line 0)
    (let ((pos (point-max)))
      (while (and (not (bobp)) (looking-at "[ \t]*\\(;\\|$\\)"))
	(setq pos (point))
	(forward-line -1))
      pos)))

(defun tp-replace-r2sc-block (newr2sc)
  (let ((s (tp-end-of-initial-comments))
	(e (tp-beginning-of-final-comments)))
    (if (> s e) (error "No r2sc part found!"))
    (delete-region s e)
    (goto-char s)
    (insert newr2sc)))

(defun tp-r2ize-buffer (buffername)
  (let* ((r1s (tp-r0sc-region-to-r1s (point-min) (point-max)))
	 (r2sc (tp-r1s-to-r2sc r1s)))
    (switch-to-buffer buffername)
    (tp-replace-r2sc-block r2sc)))


;; Demos
;; (info "(elisp)Special Properties")

(make-face 'fg:yellow)
(set-face-foreground 'fg:yellow "yellow")

(setq tp-sample-r1s '(
  ("a" face (:foreground "red"))
  (" ")
  (":=" face bold)
  (" ")
  ("2" face fg:yellow)
))

(setq tp-hello-r1s '(
  ("H")
  ("el" face fg:yellow)
  ("lo")
))

;; The tp-r1s--to-r0sc demo won't work if you're in font-lock-mode
' (insert (tp-r1s-to-r0sc tp-sample-r1s))
' (insert (tp-r1s-to-r2sc tp-sample-r1s))


;; An application:
;;
(defun tp-filter-props (filter plist)
  (if plist
      (let ((propkey (car plist))
	    (propval (cadr plist))
	    (rest (cddr plist)))
	(append (funcall filter propkey propval)
		(tp-filter-props filter rest)))))

(defun tp-r1s-filter-props (filter r1s)
  (mapcar (lambda (r1)
	    (cons (car r1) (tp-filter-props filter (cdr r1))))
	  r1s))

(defun tp-r1s-propkeys (r1s)
  (let ((propkeys ()))
    (tp-r1s-filter-props
     (lambda (key val) (add-to-list 'propkeys key))
     r1s)
    propkeys))

(defun tp-r0sc-region-propkeys (s e show-it)
  (interactive "r\np")
  (let* ((max-lisp-eval-depth 500000)
	 (max-specpdl-size 50000)
	 (r1s (tp-r0sc-region-to-r1s (min s e) (max s e))) 
	 (propkeys (tp-r1s-propkeys r1s)))
    (if show-it (message "%S" propkeys))
    propkeys))


;; r0 files <-> r2 files
;;
(defun tp-read-r2-file (fname)
  "Destroy the contents of the current file & rebuild them (r0<-r2) from FNAME" 
  (let (r1s coding (thisbuffer (current-buffer)) (pos (point)))
    (find-file fname)
    (setq r1s (read (buffer-substring (point-min) (point-max))))
    (setq coding buffer-file-coding-system)
    (switch-to-buffer thisbuffer)
    (delete-region (point-min) (point-max))
    (set-buffer-file-coding-system coding)
    (insert (tp-r1s-to-r0sc r1s))
    (goto-char pos)))

(defun tp-save-into-r2-file (fname)
  "Destroys most of FNAME and stores this file there, doing r0->r2"
  (let* ((max-lisp-eval-depth 500000)
	 (max-specpdl-size 500000)
	 (thisbuffer (current-buffer))
	 (r1s (tp-r0sc-region-to-r1s (point-min) (point-max))))
    (find-file fname)
    (goto-char (tp-end-of-initial-comments))
    (delete-region (point) (point-max))
    (save-excursion
      (insert "(\n"
	      (tp-r1s-to-r2sc r1s)
	      ")\n"))
    (switch-to-buffer thisbuffer)))


;; tp-r0-mode and tp-r2-mode
;;
(defvar tp-r0-file nil
  "The name of the associated tp-r0 file (for tp-r2 buffers)")
(defvar tp-r2-file nil
  "The name of the associated tp-r2 file (for tp-r0 buffers)")
(defvar tp-r0-status nil
  "True in a tp-r0 buffer if we have executed tp-read-r2-file")

(make-variable-buffer-local 'tp-r0-file)
(make-variable-buffer-local 'tp-r2-file)
(make-variable-buffer-local 'tp-r0-status)

(defun tp-r0-visit-r2-file ()
  (interactive)
  (find-file tp-r2-file))
(defun tp-r0-assert-properties ()
  (interactive)
  (if (null tp-r0-status)
      (tp-r0-read-r2-file)
    (message "Properties already read")))
(defun tp-r0-read-r2-file ()
  (interactive)
  (let ((bm (buffer-modified-p)))
    (tp-read-r2-file tp-r2-file)
    (if (not bm)
	(set-buffer-modified-p nil)))
  (setq tp-r0-status t)
  (message "Read %s" tp-r2-file))
(defun tp-r0-save-properties ()
  (interactive)
  (tp-save-into-r2-file tp-r2-file)
  (message "Wrote %s" tp-r2-file))

(defvar tp-r0-mode-map (make-sparse-keymap))
(define-key tp-r0-mode-map "\C-c2" 'tp-r0-visit-r2-file)
(define-key tp-r0-mode-map "\C-c\C-o" 'tp-r0-visit-r2-file)
(define-key tp-r0-mode-map "\C-c\C-a" 'tp-r0-assert-properties)
(define-key tp-r0-mode-map "\C-c\C-r" 'tp-r0-read-r2-file)
(define-key tp-r0-mode-map "\C-c\C-s" 'tp-r0-save-properties)

(define-minor-mode tp-r0-mode
  "Mode for editing a tp-r0 file"
  :init-value nil :global nil :lighter " r0")

(defun tp-r2-visit-r0-file ()
  (interactive)
  (find-file tp-r0-file)
  (tp-r0-assert-properties))
(defun tp-r2-write-r0-file ()
  (interactive)
  (let ((thisfname (buffer-file-name)) (thisbuffer (current-buffer)))
    (find-file tp-r0-file)
    (tp-read-r2-file thisfname)
    (normal-mode)
    (switch-to-buffer thisbuffer)))

(defvar tp-r2-mode-map (make-sparse-keymap))
(define-key tp-r2-mode-map "\C-c0" 'tp-r2-visit-r0-file)
(define-key tp-r2-mode-map "\C-c\C-o" 'tp-r2-visit-r0-file)
(define-key tp-r2-mode-map "\C-c\C-s" 'tp-r2-write-r0-file)

(define-minor-mode tp-r2-mode
  "Mode for editing a tp-r2 file"
  :init-value nil :global nil :lighter " r2")




(provide 'tprops)



;; (defun tpes-buffer-initial-comments ()
;;   (save-excursion
;;     (goto-char (point-min))
;;     (re-search-forward "^\\([ \t]*\\(;[^\n]*\\)?\n\\)*" nil t)
;;     (match-string 0)))



;; Local Variables:
;; coding:               raw-text-unix
;; ee-comment-prefix:    ";;"
;; modes:                (emacs-lisp-mode fundamental-mode)
;; End: