Re: Re: [babel] Painless integration of source blocks with language

From: Seth Burleigh <wburle4@gmail.com>
To: Eric Schulte <schulte.eric@gmail.com>
Cc: emacs-orgmode@gnu.org, "Štěpán Němec" <stepnem@gmail.com>
Subject: Re: Re: [babel] Painless integration of source blocks with language
Date: Sun, 9 Jan 2011 18:59:25 -0600	[thread overview]
Message-ID: <AANLkTi=L8u03UQ_RiVrAX=Qh=5Mv_cf2wUKmX6UhbTn=@mail.gmail.com> (raw)
In-Reply-To: <8739p2ot4q.fsf@gmail.com>

[-- Attachment #1.1: Type: text/plain, Size: 786 bytes --]

As an update, ive been working on something i call chunks.
Basically, they are blocks of code (i.e. emacs overlays) that are linked
together.
So far, i have each ns of my clojure code in one source block which is
then tangled to one file.
So, i would like to open the tangled file and then make changes, and finally
'push' those changes to the org file.

Theres some bugs (pushing when mark is next to a parantheses), but i think
it is going in the correct way to also include noweb tangling. In the
attached code, you hit f8 in a source block to link the block to its file
and then f8 if you want to unlink it, and you hit ctrl-alt-p to push changes
from source file to org file.

just execute lp.el in an ielm buffer. and try it out with the previous test
org file that was attached.

[-- Attachment #1.2: Type: text/html, Size: 890 bytes --]

[-- Attachment #2: lp.el --]
[-- Type: application/octet-stream, Size: 8796 bytes --]

(require 'cl)

;;UTILS
(defun inform (operation arg)
  (if arg
      (progn (message "%s success!" operation) arg)
    (info "%s failed!" operation)))
(defun char (i str)
  "get char at index"
  (substring str i (+ i 1)))
;;cant get multiline regex to work for some reason. grr
(defun string-trim-right (test-str)
  "trim all right hand whitespace,newlines"
  (let ((place (- (length test-str) 1)) (continue t))
    (while continue
      (let ((c (char place test-str)))
	(if (or (equalp c "\n")
		(equalp c "\r")
		(equalp c " "))
	    (decf place)
	  (progn (setq continue nil) (incf place))) 
	(if (= place 0) (setq continue nil))))
    (substring test-str 0 place)))
(defmacro with-file (file &rest body)
  "open up file in a buffer, and set current buffer to it"
  `(with-current-buffer (find-file-noselect ,file t) ,@body))
(defun info (&rest args)
  "message which returns nil"
  (apply #'message args)
  nil)
(defmacro comment (&rest body) nil)
(defun mkdir (file)
  "given file name, make a directory if needed"
   (let ((dir (file-name-directory file-name)))
     (if dir (make-directory dir t))))
;;;

(defun ob-expand (&optional arg info params)
  "Expand the current source code block.
Expand according to the source code block's header
arguments and pop open the results in a preview buffer.
Trims whitespaces at the very right of text"
  (interactive) 
  (let* ((info (or info (org-babel-get-src-block-info)))
         (lang (nth 0 info))
	 (params (setf (nth 2 info)
                       (sort (org-babel-merge-params (nth 2 info) params)
                             (lambda (el1 el2) (string< (symbol-name (car el1))
                                                   (symbol-name (car el2)))))))
         (body (setf (nth 1 info)
		     (if (and (cdr (assoc :noweb params))
                              (string= "yes" (cdr (assoc :noweb params))))
			 (org-babel-expand-noweb-references info) (nth 1 info))))
         (cmd (intern (concat "org-babel-expand-body:" lang)))
         (expanded (funcall (if (fboundp cmd) cmd 'org-babel-expand-body:generic)
                            body params)))
    (string-trim-right expanded)))

;;TODO: more efficient
(defun ob-name ()
  (nth 4 (ob-info)))
(defun ob-info ()
  "return info, making sure to trim right hand whitespaces. The reason to trim is so that , in the indirect macro, we can search for the beginning and end
of the chunk. i was getting some problems with newlines at the very end messing things up - so i trimmed them away. im sure theres a better way."
  (let ((info (org-babel-get-src-block-info)))
    (if info `(,(first info) ,(string-trim-right (second info)) ,@(cddr info)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun tangle-chunk (tag)
  "find code block with the tag: if found, tangle it to file"
  (let* ((chunk (find-chunk tag))
	 (file-name (first chunk)))
    (when chunk
      (if (file-exists-p file-name) 
	  (delete-file file-name))
      (mkdir file-name)
      (with-temp-buffer
	(insert (second chunk))
	;; We avoid append-to-file as it does not work with tramp.
	(let ((content (buffer-string)))
	  (with-temp-buffer
	    (goto-char (point-max))
	    (insert content)
	    (write-region nil nil file-name))))
      chunk)))

(defun find-chunk (tag)
  "find the src block with the appropriate tag (i.e. srcname)"
  (when tag
    (flet ((chunk! 
	    (tag prev)
	    (save-excursion
	      (goto-char (point-min))
	      (let (chunks)
		(if (re-search-forward (format "<<[ \t]*%s[ \t]*>>" tag) nil t)
		    (let ((info (ob-info)))
		      (if (member info prev)
			  (message "when finding chunk, infinite loop detected")
			(if (and (equalp (first info) "clojure")
				 info (not (equalp "no"
						   (cdr (assoc :tangle (third info))))))
			    (list (cdr (assoc :tangle (third info)))
				  (ob-expand (second info))
				  (point))
			  (chunk! (ob-name) (append prev (list info)))))))))))
      (let ((info (ob-info)))
	(if (not (equalp "no" (cdr (assoc :tangle (third info)))))
	    (list (cdr (assoc :tangle (third info)))
		  (ob-expand (second info))
		  (point))	  
	  (chunk! tag nil))))))

;;TODO: if youre at end of buffer and the chunk is at the end of the buffer, the chunk will grow - how to inserta  new line?
;;TODO: cursor is set to beginning of chunk in synced buffer. fix?
(defmacro comment (&rest body))
(defun set-color (chunk color)
  (overlay-put chunk 'face (list :background color)))
(defvar lp-default-color "gray94")
(defun* new-chunk (start end buffer &optional (color lp-default-color))
  (interactive)
  (let ((chunk (make-overlay start end buffer t t)))
    (set-color chunk (if color color lp-default-color))
    ;;(overlay-put chunk 'modification-hooks '(mod-hook))
    chunk))

(defun link (from to) 
  (pushnew to (overlay-get from 'lp-link)))

(defun bi-link (node1 node2)
  (link node1 node2)
  (link node2 node1))

(defun chunks (o) (overlay-get o 'lp-link))
(defun overlay-string (overlay)
  (save-excursion
    (set-buffer (overlay-buffer overlay))
    (buffer-substring-no-properties
     (overlay-start overlay)
     (overlay-end overlay))))

;;TODO: instead of replacing entire region, replace only part that has changed
;;TODO: remove orphoned chunks?
(defun chunk? (chunk) (and (overlayp chunk) (overlay-buffer chunk)))
(defun push-string (str to &optional length)
  (when (chunk? to)
    (let ((start (overlay-start to))
	  (end (overlay-end to)))
      (save-excursion
	(set-buffer (overlay-buffer to))
	(delete-region start end)
	(goto-char start)
	(insert str)
	(move-overlay to start (+ start (length str)))))))

(defun push-chunk (from to &optional length)
  (push-string (overlay-string from) to))

(defun delete-chunks (c)
  (if (listp c)
      (mapcar #'delete-chunk c)
    (when (chunk? c) (delete-overlay c))))

;;after modification hook
(defun mod-hook (from type start end &optional length)
  (when type
    (dolist (to (chunks from))
      (push-chunk from to))))
(defun get-chunk ()
  (first (overlays-in (point-min) (point-max))))
(defun get-chunks ()
  (overlays-in (point-min) (point-max)))

;;src block chunks
(defun new-src-block-chunk (&optional color)
  (save-excursion
    (when (org-babel-mark-block)
      (new-chunk (point) (mark) (current-buffer)))))
(defun get-src-block-chunk ()
  (save-excursion
    (when (org-babel-mark-block) 
      (first (overlays-in (point) (mark))))))
(defun get-src-block-chunk-create (&optional color)
  (let ((chunk (get-src-block-chunk)))
    (if chunk chunk (new-src-block-chunk color))))
(defun delete-src-block-chunk ()
  (delete-chunks (get-src-block-chunk)))

;;file chunks
(defun new-src-block-file-chunk (&optional color)
  "get tangled file associated with chunk, open it, and create a chunk out of the whole file"
  (let ((file-name (first (find-chunk (ob-name)))))
    (if file-name
      (with-file
       file-name
       (save-excursion
	 (new-chunk (point-min) (point-max) (current-buffer) color)))
      (info "couldn't do it"))))
(defun get-src-block-file-chunk ()
  (let ((file-name (first (find-chunk (ob-name)))))
    (when file-name 
      (with-file
       file-name
       (get-chunk)))))
(defun get-src-block-file-chunk-create (&optional color)
  (let ((chunk (get-src-block-file-chunk)))
    (if chunk chunk (new-src-block-file-chunk color))))
(defun delete-src-block-file-chunk ()
  (delete-chunks (get-src-block-file-chunk)))

;;linking
(defun unlink-src-block ()
  (interactive)
  (delete-src-block-file-chunk)
  (delete-src-block-chunk))

(defun pull-src-block ()
  (interactive)
  (let ((chunk (get-src-block-chunk))
	(file-chunk (get-src-block-file-chunk)))
    (if (and chunk file-chunk)
      (inform "pull" (push-chunk file-chunk chunk))
      (info "only found chunk %s and file-chunk %s" chunk file-chunk))))

(defun bi-link-src-block (&optional color)
  (interactive)
  (let ((chunk (get-src-block-chunk-create)))
    (if chunk
      (let ((file-chunk (get-src-block-file-chunk-create (or color "white"))))
	(if file-chunk
	  (bi-link chunk file-chunk)
	  (progn (info "couldn't chunkify file") (unlink-src-block))))
      (info "couldn't chunkify src block"))))

(defun linked? ()
  (get-src-block-chunk))

(defun push-src-block ()
  (interactive)
  (let ((source (first (chunks (get-chunk)))))
    (if source
	(inform "push"
		(push-string
		 (buffer-substring-no-properties (point-min) (point-max))
		 source))
      (message "chunks are only %s" source))))

;;TODO; for some reason, when f8 is by a paren, dont work
(define-key org-mode-map (kbd "<f8>")
  (lambda ()
    (interactive)
    (if (linked?)
	(unlink-src-block)
      (bi-link-src-block))))
;;TODO: minor mode
(global-set-key
 (kbd "M-P")
 (lambda ()
   (interactive) 
   (if (linked?) (pull-src-block) (push-src-block))))

[-- Attachment #3: Type: text/plain, Size: 201 bytes --]

_______________________________________________
Emacs-orgmode mailing list
Please use `Reply All' to send replies to the list.
Emacs-orgmode@gnu.org
http://lists.gnu.org/mailman/listinfo/emacs-orgmode