;;; ob-sas.el --- org-babel functions for sas code evaluation

;; Copyright (C) 2017 P.A. Cornillon
;; Author: P.A. Cornillon
;;      G. Jay Kerns
;;      Eric Schulte
;;      Dan Davison


;; This file is not part of GNU Emacs.

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;; The file provides Org-Babel support for evaluating sas code.  It is
;; basically result of find-and-replace "sas" for "julia" in
;; ob-julia.el by G. Jay Kerns.
;; 1) Parameter ":results output" needs a
;; to give the right filename for SAS in the  Parameter ":results value"
;; does not work (I'm not sure it makes sense or is useful).  Parameter
;; ":session" works with default value using ESS
;; 

;;; Requirements:
;; Sas: http://sas.com
;; ESS: http://ess.r-project.org

;;; Code:
(require 'ob)
(require 'cl-lib)

(declare-function orgtbl-to-csv "org-table" (table params))
(declare-function sas "ext:ess-sas" (&optional start-args))
(declare-function inferior-ess-send-string "ext:ess-inf" ())
(declare-function ess-make-buffer-current "ext:ess-inf" ())
(declare-function ess-eval-buffer "ext:ess-inf" (vis))
(declare-function org-number-sequence "org-compat" (from &optional to inc))
;;;;;;;;;;;;;;;; could be useful to increase or decrease timeout ....
(defcustom org-babel-sas-timeout 1000
  "Timeout (in sec) used when waiting output from a submitted src block (to sas) with argument :session."
  :group 'org-babel
  :type 'integer)
;;;;;;;;;;;;;;;; could be useful to tweak printing page size
(defcustom org-babel-sas-print-options "options formdlim='' pagesize=max;\n"
  "general options used to have the maximum page size"
  :group 'org-babel
  :type 'string)

;;;;;;;;;;;;;;;; where is SAS
(defcustom org-babel-sas-command "/usr/local/bin/sas_u8"
;  inferior-SAS-program-name
  "Name of command to use for executing sas code."
  :group 'org-babel
  :type 'string)

;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar org-babel-sas-lepoint 1)
(defvar org-babel-sas-logfile-name "log_sas.log")
(defvar org-babel-sas-eoe-indicator "data eoe_org_data;\n nbabelvareoe=1;\nrun;\nOPTIONS NODATE NONUMBER;\nTITLE1;\nTITLE2;\nproc print data=eoe_org_data;\nrun;")
(defvar org-babel-sas-eoe-output "Obs.    nbabelvareoe\n\n                                1           1")
(defvar org-babel-sas-boe-output "$ tty\n/dev/pts/[0-9]+\n\\$")
(defconst org-babel-header-args:sas
  '((hsize		 . :any)
    (vsize		 . :any)
    (xpixels		 . :any)
    (ypixels		 . :any)
    (border		 . :any)
    (width		 . :any)
    (height		 . :any)
    (results             . ((file list vector table scalar verbatim)
			    (raw org html latex code pp wrap)
			    (replace silent append prepend)
                            ;; NOTE: not sure 'value' makes sense in sas
                            ;; we may want to remove it from the list
			    (output graphics))))
  "sas-specific header arguments.")

(add-to-list 'org-babel-tangle-lang-exts '("sas" . "sas"))

;; session using ESS is the way to go, so make that the default
(defvar org-babel-default-header-args:sas '((:results . "output") (:session . nil)))

;; trim white space and garbage
(defun org-babel-sas-trim-white (s)
  "replace S by empty string if S is whitespace only"
  (if (string-match "\\`[ \t\n\r]+\\'" s)
      (replace-match "" t t s)
    s))
;; let's go: main function
(defun org-babel-execute:sas (body params)
  "Execute a block of sas code.
This function is called by `org-babel-execute-src-block'."
  (save-excursion
    (let* ((result-params (cdr (assq :result-params params)))
	   (result-type (cdr (assq :result-type params)))
          (session (org-babel-sas-initiate-session
		    (cdr (assq :session params)) params))
	  (graphics-file (org-babel-sas-graphical-output-file params))
	  (graphics-type (or (member "odsgraphics" (cdr (assq :result-params params))) (member "graphics" (cdr (assq :result-params params)))))
	  (full-body (org-babel-expand-body:sas body params graphics-file graphics-type))
	  (result
	   (org-babel-sas-evaluate
	    session full-body result-type result-params)))
      (if graphics-file nil result))))

(defvar ess-ask-for-ess-directory) ; dynamically scoped

(defun org-babel-sas-initiate-session (session params)
  "If there is not a current sas process then create one."
  (unless (string= session "none")
    (let ((session (or session "*SAS*"))
	  (ess-ask-for-ess-directory
	   (and (and (boundp 'ess-ask-for-ess-directory) ess-ask-for-ess-directory)
		(not (cdr (assq :dir params))))))
      (if (org-babel-comint-buffer-livep session)
	  session
	(save-window-excursion
	  (require 'ess) (SAS)
	  (rename-buffer
	   (if (bufferp session)
	       (buffer-name session)
	     (if (stringp session)
		 session
	       (buffer-name))))
	  (current-buffer))))))

(defun org-babel-sas-associate-session (session)
  "Associate sas code buffer with a sas session.
Make SESSION be the inferior ESS process associated with the
current code buffer."
  (setq ess-local-process-name
	(process-name (get-buffer-process session)))
  (ess-make-buffer-current))

(defun org-babel-load-session:sas (session body params)
  "Load BODY into SESSION."
  (save-window-excursion
    (let ((buffer (org-babel-prep-session:sas session params)))
      (with-current-buffer buffer
        (goto-char (process-mark (get-buffer-process (current-buffer))))
        (insert (org-babel-chomp body)))
      buffer)))

(defun org-babel-sas-graphical-output-file (params)
  "Name of file to which sas should send graphical output."
  (and (or (member "graphics" (cdr (assq :result-params params)))
	   (member "odsgraphics" (cdr (assq :result-params params))))
       (cdr (assq :file params))))

(defun org-babel-expand-body:sas (body params &optional graphics-file graphics-type)
  "Expand BODY according to PARAMS, return the expanded body."
  (let ((graphics-file
	 (or graphics-file
	     (org-babel-sas-graphical-output-file params)))
	(graphics-type
	 (or graphics-type
	     (or (member "odsgraphics" (cdr (assq :result-params params)))
		 (member "graphics" (cdr (assq :result-params params)))))))
    (concat org-babel-sas-print-options
     (if graphics-file
	   (org-babel-sas-construct-graphics-device-call
	    graphics-file graphics-type params)
       "") body (if graphics-file
		    (if (string-equal (car graphics-type) "odsgraphics")
			"quit;\nods graphics off;\n"
		      "quit;\n")))))

(defvar org-babel-sas-graphics-devices
  '((:bmp "bmp")
    (:emf "emf")
    (:tiff "tiff")
    (:png "png")
    (:png300 "png300")
    (:svg "svg")
    (:pdf "pdf")
    (:ps "pscolor")
    (:postscript "pscolor"))
  "An alist mapping graphics file types to SAS devices.

Each member of this list is a list with three members:
1. the file extension of the graphics file, as an elisp :keyword
2. the SAS device function to call to generate such a file")

;; we need the following twolines with sas/graph :graphics
;; example of svg device
;; filename sortie "toto.svg";
;; goptions  device=svg gsfname=sortie
;; or this line with ODS graphics :odsgraphics
;; ods graphics on /  imagefmt=png imagename="barplot" border=off width=10cm;
(defun org-babel-sas-construct-graphics-device-call (out-file graphics-type params)
  "Construct the string for choosing device and saving graphic file"
  (let* ((allowed-args '(:hsize :vsize :xpixels :ypixels :border :width :height))
	 (device (file-name-extension out-file))
	 (device-info (or (assq (intern (concat ":" device))
				org-babel-sas-graphics-devices)
                          (assq :png org-babel-sas-graphics-devices)))
	 (extra-args (cdr (assq :SAS-dev-args params))) filearg args)
    (setq device (nth 1 device-info))
    (setq args (mapconcat
		(lambda (pair)
		  (if (member (car pair) allowed-args)
		      (format " %s=%S"
			      (substring (symbol-name (car pair)) 1)
			      (cdr pair)) ""))
		params ""))
    (if (string-equal (car graphics-type) "odsgraphics")
	(format "ods graphics on / imagename=\"%s\" imagefmt=%s %s;\n"
		(file-name-sans-extension out-file) device args
		(if extra-args " " "") (or extra-args ""))
      (format "filename outfob \"%s\";\ngoptions  device=%s gsfname= outfob %s;\n"
	    out-file device args
	    (if extra-args " " "") (or extra-args "")))))


(defun org-babel-sas-evaluate
  (session body result-type result-params)
  "Evaluate sas code in BODY."
  (if session
      (org-babel-sas-evaluate-session
       session body result-type result-params)
    (org-babel-sas-evaluate-external-process
     body result-type result-params)))

(defun org-babel-sas-evaluate-external-process
  (body result-type result-params)
  "Evaluate BODY in external sas process.
If RESULT-TYPE equals 'output then return standard output as a
string.  If RESULT-TYPE equals 'value then return the value of the
last statement in BODY, as elisp."
  (cl-case result-type
    (value
     (message "%s" "no ':results value' in SAS, please use ':results output' instead"))
    (output
     ;; org-babel-eval does pass external argument...
     (let ((tmp-file "sas-file4677846547.sas")
	   (directory-sas ""))
       (with-current-buffer
	   (switch-to-buffer (find-file-noselect tmp-file))
	 (insert body)
	 (save-buffer 0))
       (message "options %s" (format "%s -log %s -nonews -nodms %s" org-babel-sas-command org-babel-sas-logfile-name tmp-file))
       (shell-command (format "%s -log %s -nonews -nodms %s" org-babel-sas-command org-babel-sas-logfile-name tmp-file) nil nil)
       (kill-buffer "sas-file4677846547.sas")
       (delete-file "sas-file4677846547.sas")
       (setq directory-sas (file-name-directory (buffer-file-name (get-buffer org-babel-sas-logfile-name))))
       (message "directory: %s" directory-sas)
       (if (file-readable-p "sas-file4677846547.lst")
	   (progn
	     (with-current-buffer
		 (switch-to-buffer (find-file-noselect "sas-file4677846547.lst"))
	       (beginning-of-buffer)
	       (setq body (buffer-string)))
	     (delete-file "sas-file4677846547.lst")
	     (kill-buffer "sas-file4677846547.lst")
	     body)
	 (progn
	   (if (get-buffer org-babel-sas-logfile-name)
	       (with-current-buffer (get-buffer org-babel-sas-logfile-name)
		 (revert-buffer :ignore-auto :noconfirm :preserve-modes))
	     (save-window-excursion (pop-to-buffer-same-window (find-file-noselect org-babel-sas-logfile-name))))
	   (format "Errors, please see [[file://%s/%s][log file]] (in Buffer list)" directory-sas org-babel-sas-logfile-name)))))))

(defun org-babel-sas-evaluate-session
    (session body result-type result-params)
  "Evaluate BODY in SESSION.
If RESULT-TYPE equals 'output then return standard output as a
string.  If RESULT-TYPE equals 'value then return the value of the
last statement in BODY, as elisp."
  (cl-case result-type
    (value
     (message "%s" "no ':results value' in SAS, please use ':results output' instead"))
    (output
     ;; submit body through a temp buffer (in order to not go
     ;; beyond the limit of 500 bytes)
     ;; see 
     ;; https://stat.ethz.ch/pipermail/ess-help/2015-April/010518.html
    (let ((org-babel-sas-ess-process-name  (process-name (get-buffer-process session))))
      (with-temp-buffer
	(insert body)
	(let ((ess-local-process-name
	       (process-name (get-buffer-process session)))
	      (ess-eval-visibly-p nil))
	  (ess-eval-buffer nil)))
      (ess-send-string (get-process org-babel-sas-ess-process-name) org-babel-sas-eoe-indicator)
      ;;    excursion for cut/paste results from output buffer
      ;;   as output buffer is not the same as session buffer
      ;; org-babel-comint-with-output cannot be used 
      (save-excursion
      	(set-buffer (format "*%s.lst*" org-babel-sas-ess-process-name))
      	(let* ((a 0) (b 0) (ancienpoint org-babel-sas-lepoint))
      	 (while (< a org-babel-sas-timeout)
      	   (setq b a)
      	   (goto-char org-babel-sas-lepoint)
      	   (setq a (re-search-forward (regexp-quote org-babel-sas-eoe-output) nil t))
      	   (if a
      	       (progn (setq a org-babel-sas-timeout)
      	 	      (goto-char org-babel-sas-lepoint)
      	 	      (setq ancienpoint org-babel-sas-lepoint)
		      ;; well well, this is embarassing but
		      ;; as there's not history like in comint
		      ;; the last point is saved in this global
		      ;; variable (that will be used the
		      ;; next time)
      	 	      (setf org-babel-sas-lepoint (point-max)))
      	     (setq a (+ b 1)))
      	   (sit-for 0.01))
       	 (org-babel-sas-trim-white (replace-regexp-in-string (concat "\\(\f\\)\\|\\(" org-babel-sas-boe-output "\\)\\|\\(" org-babel-sas-eoe-output "\\)") "" (buffer-substring ancienpoint org-babel-sas-lepoint)))))))))

(provide 'ob-sas)

;;; ob-sas.el ends here