[PATCH 2/3] Introduce machinery to ox.el for concordance generation

[Aaron Ecay <aaronecay@gmail.com>]

* lisp/ox.el (org-export-concordance): New buffer-local variable
(org-export-with-concordance): New user option
(org-export--concordance-propertize),
(org-export--concordance-propertize-pre),
(org-export--build-concordance),
(org-export--read-concordance): New functions
(org-export-data): Call org-export–concordance-propertize where
appropriate
(org-export-as),
(org-export-to-buffer),
(org-export-to-file): Handle concordance generation

The general idea is as follows:
1) Before copying the buffer for export, call org-export--propertize-pre
   to add line-number properties to the buffer
2) The parser sees these properties during export (previous commit)
3) org-export-data adds text properties to the strings it generates,
   indicating which lines they originated from (using function
   org-export--propertize)
4) These properties survive into the output buffer (because export no
   longer calls org-no-properties)
5) After export is finished, org-export-build-concordance walks the
   result buffer, calculating a concordance of source lines and output
   lines.
6) This value is stored in the org buffer’s org-export-concordance local
   variable
---
 lisp/ox.el | 151 +++++++++++++++++++++++++++++++++++++++++++++++++------------
 1 file changed, 121 insertions(+), 30 deletions(-)

diff --git a/lisp/ox.el b/lisp/ox.el
index ff6407b..e1c76bd 100644
--- a/lisp/ox.el
+++ b/lisp/ox.el
@@ -302,6 +302,13 @@ and its CDR is a list of export options.")
 This marker will be used with `C-u C-c C-e' to make sure export repetition
 uses the same subtree if the previous command was restricted to a subtree.")
 
+(defvar org-export-concordance nil
+  "The concordance resulting from the last export operation.
+
+The variable is always buffer-local, and only manipulated if
+`org-export-with-concordance' is set.")
+(make-variable-buffer-local 'org-export-concordance)
+
 \f
 ;;; User-configurable Variables
 ;;
@@ -351,6 +358,16 @@ e.g. \"c:t\"."
   :group 'org-export-general
   :type 'boolean)
 
+(defcustom org-export-with-concordance nil
+  "Non-nil means to generate a concordance.
+
+This is currently useful only for the LaTeX backend (and derived
+backends), which can use it to patch the SyncTeX file generated
+by LaTeX, so that it is possible to jump back and forth between
+the org file and resulting pdf."
+  :group 'org-export-general
+  :type 'boolean)
+
 (defcustom org-export-with-creator 'comment
   "Non-nil means the postamble should contain a creator sentence.
 
@@ -2040,6 +2057,61 @@ INFO is a plist containing export directives."
       (let ((transcoder (cdr (assq type (plist-get info :translate-alist)))))
 	(and (functionp transcoder) transcoder)))))
 
+(defun org-export--concordance-propertize (data string)
+  "Add line number text properties to STRING, based on DATA.
+
+This will allow the construction of a concordance from the
+completed string."
+  (let ((len (length string)))
+    (when (> len 1)
+      (put-text-property 0 1 'org-line-num
+			 (org-element-property :begin-line data)
+			 string)
+      (put-text-property (1- len) len 'org-line-num
+			 (org-element-property :end-line data)
+			 string)))
+  string)
+
+(defun org-export--concordance-propertize-pre ()
+  "Put line-number text properties on a buffer.
+
+Each line gets a org-line-num-pre property, which is its line
+number in the buffer before any export operations have changed
+the buffer."
+  ;; This is called from `org-export-as', which has issued
+  ;; `save-restriction'.
+  (widen)
+  (while (= 0 (forward-line 1))
+    (put-text-property (point) (point-at-eol) 'org-line-num-pre
+		       (line-number-at-pos))))
+
+(defun org-export--build-concordance ()
+  "Build a concordance, based on text props in an exported buffer."
+  (save-excursion
+    (let ((res '())
+	  next)
+      (goto-char (point-min))
+      (while (setq next (next-single-property-change (point) 'org-line-num))
+	(goto-char next)
+	(setq res (cons (cons (line-number-at-pos)
+			      (get-text-property (point) 'org-line-num))
+			res))
+	(forward-char 1))
+      (setq res (nreverse res))
+      (setq next res)
+      (while (cdr next)
+	(if (equal (caar next) (caadr next))
+	    (setcdr next (cddr next))
+	  (setq next (cdr next))))
+      res)))
+
+(defun org-export--read-concordance (concordance src-line)
+  "Get the original line number from CONCORDANCE for output line SRC-LINE."
+  (while (and (caadr concordance)
+	      (<= (caadr concordance) src-line))
+    (setq concordance (cdr concordance)))
+  (cdar concordance))
+
 (defun org-export-data (data info)
   "Convert DATA into current back-end format.
 
@@ -2056,11 +2128,16 @@ Return transcoded string."
 	       ((memq data (plist-get info :ignore-list)) nil)
 	       ;; Plain text.
 	       ((eq type 'plain-text)
-		(org-export-filter-apply-functions
-		 (plist-get info :filter-plain-text)
-		 (let ((transcoder (org-export-transcoder data info)))
-		   (if transcoder (funcall transcoder data info) data))
-		 info))
+		(let* ((transcoder (org-export-transcoder data info))
+		       (transcoded-string (if transcoder
+					      (funcall transcoder data info)
+					    data))
+		       (propertized-string (org-export--concordance-propertize
+					    data transcoded-string)))
+		  (org-export-filter-apply-functions
+		   (plist-get info :filter-plain-text)
+		   propertized-string
+		   info)))
 	       ;; Uninterpreted element/object: change it back to Org
 	       ;; syntax and export again resulting raw string.
 	       ((not (org-export--interpret-p data info))
@@ -2081,15 +2158,18 @@ Return transcoded string."
 		    (and (eq type 'headline)
 			 (eq (plist-get info :with-archived-trees) 'headline)
 			 (org-element-property :archivedp data)))
-		(let ((transcoder (org-export-transcoder data info)))
-		  (or (and (functionp transcoder)
-			   (funcall transcoder data nil info))
-		      ;; Export snippets never return a nil value so
-		      ;; that white spaces following them are never
-		      ;; ignored.
-		      (and (eq type 'export-snippet) ""))))
-	       ;; Element/Object with contents.
-	       (t
+		(let* ((transcoder (org-export-transcoder data info))
+                       (transcoded-string
+                        (or (and (functionp transcoder)
+                                 (funcall transcoder data nil info))
+                            ;; Export snippets never return a nil value so
+                            ;; that white spaces following them are never
+                            ;; ignored.
+                            (and (eq type 'export-snippet) ""))))
+                  (and transcoded-string
+                       (org-export--concordance-propertize data transcoded-string))))
+               ;; Element/Object with contents.
+               (t
 		(let ((transcoder (org-export-transcoder data info)))
 		  (when transcoder
 		    (let* ((greaterp (memq type org-element-greater-elements))
@@ -2118,11 +2198,13 @@ Return transcoded string."
 					  data)
 				      (memq (org-element-type parent)
 					    '(footnote-definition item))))))))
-			     "")))
-		      (funcall transcoder data
-			       (if (not greaterp) contents
-				 (org-element-normalize-string contents))
-			       info))))))))
+			     ""))
+			   (transcoded-string
+			    (funcall transcoder data
+				     (if (not greaterp) contents
+				       (org-element-normalize-string contents))
+				     info)))
+		      (org-export--concordance-propertize data transcoded-string))))))))
 	;; Final result will be memoized before being returned.
 	(puthash
 	 data
@@ -2893,6 +2975,8 @@ Return code as a string."
 	;; created, where include keywords, macros are expanded and
 	;; code blocks are evaluated.
 	(org-export-with-buffer-copy
+	 (when org-export-with-concordance
+	   (org-export--concordance-propertize-pre))
 	 ;; Run first hook with current back-end as argument.
 	 (run-hook-with-args 'org-export-before-processing-hook backend)
 	 (org-export-expand-include-keyword)
@@ -2953,15 +3037,12 @@ Return code as a string."
 			     (funcall inner-template body info)))
 		(template (cdr (assq 'template
 				     (plist-get info :translate-alist)))))
-	   ;; Remove all text properties since they cannot be
-	   ;; retrieved from an external process.  Finally call
-	   ;; final-output filter and return result.
-	   (org-no-properties
-	    (org-export-filter-apply-functions
-	     (plist-get info :filter-final-output)
-	     (if (or (not (functionp template)) body-only) full-body
-	       (funcall template full-body info))
-	     info))))))))
+	   ;; Call final-output filter and return result.
+	   (org-export-filter-apply-functions
+	    (plist-get info :filter-final-output)
+	    (if (or (not (functionp template)) body-only) full-body
+	      (funcall template full-body info))
+	    info)))))))
 
 ;;;###autoload
 (defun org-export-to-buffer
@@ -2980,11 +3061,16 @@ see.
 Depending on `org-export-copy-to-kill-ring', add buffer contents
 to kill ring.  Return buffer."
   (let ((out (org-export-as backend subtreep visible-only body-only ext-plist))
-	(buffer (get-buffer-create buffer)))
+	(buffer (get-buffer-create buffer))
+	concordance)
     (with-current-buffer buffer
       (erase-buffer)
       (insert out)
+      (when org-export-with-concordance
+	(setq concordance (org-export--build-concordance)))
       (goto-char (point-min)))
+    (when concordance
+      (setq org-export-concordance concordance))
     ;; Maybe add buffer contents to kill ring.
     (when (and (org-export--copy-to-kill-ring-p) (org-string-nw-p out))
       (org-kill-new out))
@@ -3009,11 +3095,16 @@ to kill ring.  Return output file's name."
   ;; we'd rather avoid needless transcoding of parse tree.
   (unless (file-writable-p file) (error "Output file not writable"))
   ;; Insert contents to a temporary buffer and write it to FILE.
-  (let ((out (org-export-as backend subtreep visible-only body-only ext-plist)))
+  (let ((out (org-export-as backend subtreep visible-only body-only ext-plist))
+	concordance)
     (with-temp-buffer
       (insert out)
+      (when org-export-with-concordance
+	(setq concordance (org-export--build-concordance)))
       (let ((coding-system-for-write org-export-coding-system))
 	(write-file file)))
+    (when concordance
+      (setq org-export-concordance concordance))
     ;; Maybe add file contents to kill ring.
     (when (and (org-export--copy-to-kill-ring-p) (org-string-nw-p out))
       (org-kill-new out)))
-- 
1.8.2