From f3feae865b37649e44261f83bf45d925e5f6cea0 Mon Sep 17 00:00:00 2001 From: Bruno BARBIER Date: Sat, 29 Apr 2023 10:43:16 +0200 Subject: [PATCH 11/13] lisp/ob-haskell.el: Fix how to use sessions * lisp/ob-haskell.el (org-babel-haskell-initiate-session): Redesign how to handle session names. (org-babel-haskell-with-session): New function to manage sessions. (org-babel-interpret-haskell): Refactor code. Use `org-babel-haskell-with-session` to manage sessions. (org-babel-prep-session:haskell): Don't ignore the PARAMS argument. --- lisp/ob-haskell.el | 182 +++++++++++++++++++++++++++------------------ 1 file changed, 110 insertions(+), 72 deletions(-) diff --git a/lisp/ob-haskell.el b/lisp/ob-haskell.el index 98b1b10f0..deaa434f8 100644 --- a/lisp/ob-haskell.el +++ b/lisp/ob-haskell.el @@ -129,54 +129,58 @@ (defun org-babel-interpret-haskell (body params) (lambda () (setq-local comint-prompt-regexp (concat haskell-prompt-regexp "\\|^λ?> ")))) - (let* ((session (cdr (assq :session params))) - (result-type (cdr (assq :result-type params))) - (full-body (org-babel-expand-body:generic - body params - (org-babel-variable-assignments:haskell params))) - (session (org-babel-haskell-initiate-session session params)) - (comint-preoutput-filter-functions - (cons 'ansi-color-filter-apply comint-preoutput-filter-functions)) - (raw (pcase result-type - (`output - (org-babel-comint-with-output - (session org-babel-haskell-eoe nil full-body) - (insert (org-trim full-body)) - (comint-send-input nil t) - (insert (concat "putStrLn \"" org-babel-haskell-eoe "\"\n")) - (comint-send-input nil t))) - (`value (org-babel-comint-with-output - (session org-babel-haskell-eoe nil full-body) - (insert "__LAST_VALUE_IMPROBABLE_NAME__=()::()\n") - (comint-send-input nil t) - (insert full-body) - (comint-send-input nil t) - (insert "__LAST_VALUE_IMPROBABLE_NAME__=it\n") - (comint-send-input nil t) - (insert (concat "putStrLn \"" org-babel-haskell-eoe "\"\n")) - (comint-send-input nil t)) - (org-babel-comint-with-output - (session org-babel-haskell-eoe nil) - (insert "__LAST_VALUE_IMPROBABLE_NAME__\n") - (comint-send-input nil t) - (insert (concat "putStrLn \"" org-babel-haskell-eoe "\"\n")) - (comint-send-input nil t)) - ) - )) - (results (mapcar #'org-strip-quotes - (cdr (member org-babel-haskell-eoe - (reverse (mapcar #'org-trim raw))))))) - (org-babel-reassemble-table - (let ((result - (pcase result-type - (`output (mapconcat #'identity (reverse results) "\n")) - (`value (car results))))) - (org-babel-result-cond (cdr (assq :result-params params)) - result (when result (org-babel-script-escape result)))) - (org-babel-pick-name (cdr (assq :colname-names params)) - (cdr (assq :colname-names params))) - (org-babel-pick-name (cdr (assq :rowname-names params)) - (cdr (assq :rowname-names params)))))) + (org-babel-haskell-with-session + params + (lambda (session) + (cl-labels + ((csend (txt) + (insert txt) (comint-send-input nil t)) + (eom () + (csend (concat "putStrLn \"" org-babel-haskell-eoe "\"\n"))) + (with-output (todo) + (let ((comint-preoutput-filter-functions + (cons 'ansi-color-filter-apply + comint-preoutput-filter-functions))) + (org-babel-comint-with-output + (session org-babel-haskell-eoe nil nil) + (funcall todo))))) + (let* ((result-type (cdr (assq :result-type params))) + (full-body (org-babel-expand-body:generic + body params + (org-babel-variable-assignments:haskell params))) + (raw (pcase result-type + (`output + (with-output + (lambda () (csend (org-trim full-body)) (eom)))) + (`value + ;; We first compute the value and store the + ;; value, ignoring any output. + (with-output + (lambda () + (csend "__LAST_VALUE_IMPROBABLE_NAME__=()::()\n") + (csend (org-trim full-body)) + (csend "__LAST_VALUE_IMPROBABLE_NAME__=it\n") + (eom))) + ;; We now display and capture the value. + (with-output + (lambda() + (csend "__LAST_VALUE_IMPROBABLE_NAME__\n") + (eom)))))) + (results (mapcar #'org-strip-quotes + (cdr (member org-babel-haskell-eoe + (reverse (mapcar #'org-trim raw))))))) + (org-babel-reassemble-table + (let ((result + (pcase result-type + (`output (mapconcat #'identity (reverse results) "\n")) + (`value (car results))))) + (org-babel-result-cond (cdr (assq :result-params params)) + result (when result (org-babel-script-escape result)))) + (org-babel-pick-name (cdr (assq :colname-names params)) + (cdr (assq :colname-names params))) + (org-babel-pick-name (cdr (assq :rowname-names params)) + (cdr (assq :rowname-names params))))))))) + (defun org-babel-execute:haskell (body params) "Execute a block of Haskell code." @@ -186,6 +190,23 @@ (defun org-babel-execute:haskell (body params) (org-babel-haskell-execute body params)))) +(defun org-babel-haskell-with-session (params todo) + "Call TODO with a suitable session buffer. +Use PARAMS to get/create/destroy the session as needed. +Return the result of the call." + (let* ((sn (cdr (assq :session params))) + (session (org-babel-haskell-initiate-session sn params)) + (one-shot (equal sn "none"))) + (unwind-protect + (funcall todo session) + (when (and one-shot (buffer-live-p session)) + ;; As we don't control how the session temporary buffer is + ;; created, we need to explicitly work around the hooks and + ;; query functions. + (with-current-buffer session + (let ((kill-buffer-query-functions nil) + (kill-buffer-hook nil)) + (kill-buffer session))))))) ;; Variable defined in inf-haskell (haskell-mode package). @@ -193,34 +214,51 @@ (defvar inferior-haskell-buffer) (defun org-babel-haskell-initiate-session (&optional session-name _params) "Initiate a haskell session. -Return the initialized session." +Return the initialized session, i.e. the buffer for this session. +When SESSION-NAME is nil, use a global session named +\"*ob-haskell*\". When SESSION-NAME is the string \"none\", use +a temporary buffer. Else, (re)use the session named +SESSION-NAME. The buffer name is the session name. See also +`org-babel-haskell-with-session'." (org-require-package 'inf-haskell "haskell-mode") - (when (and session-name (string= session-name "none")) - (setq session-name nil)) - (unless session-name - ;; As haskell-mode is using the buffer name "*haskell*", we stay - ;; away from it. - (setq session-name (generate-new-buffer-name "*ob-haskell*"))) + (cond + ((equal "none" session-name) + ;; Temporary buffer name. + (setq session-name (generate-new-buffer-name " *ob-haskell-tmp*"))) + ((eq nil session-name) + ;; The global default session. As haskell-mode is using the buffer + ;; named "*haskell*", we stay away from it. + (setq session-name "*ob-haskell*"))) (let ((session (get-buffer session-name))) (save-window-excursion (or (org-babel-comint-buffer-livep session) (let ((inferior-haskell-buffer session)) - (when (and (bufferp session) (not (org-babel-comint-buffer-livep session))) - (when (bufferp "*haskell*") (error "Conflicting buffer '*haskell*', rename it or kill it.")) - (with-current-buffer session (rename-buffer "*haskell*"))) - (save-window-excursion - ;; We don't use `run-haskell' to not popup the buffer. - ;; And we protect default-directory. - (let ((default-directory default-directory)) - (inferior-haskell-start-process)) - (sleep-for 0.25) - (setq session inferior-haskell-buffer) - (with-current-buffer session (rename-buffer session-name)) - ;; Disable secondary prompt. - (org-babel-comint-input-command - session - ":set prompt-cont \"\"") - session)))) + ;; As inferior-haskell expects the buffer to be named + ;; "*haskell*", we rename it, unless the user explicitly + ;; requested to use the name "*haskell*". + (when (not (equal "*haskell*" session-name)) + (when (and (bufferp session) + (not (org-babel-comint-buffer-livep session))) + (when (bufferp "*haskell*") + (user-error "Conflicting buffer '*haskell*', rename it or kill it")) + (with-current-buffer session (rename-buffer "*haskell*")))) + (unwind-protect + (save-window-excursion + ;; We don't use `run-haskell' to not popup the buffer. + ;; And we protect default-directory. + (let ((default-directory default-directory)) + (inferior-haskell-start-process)) + (sleep-for 0.25) + (setq session inferior-haskell-buffer)) + (when (and (not (equal "*haskell*" session-name)) + (bufferp session)) + (with-current-buffer session (rename-buffer session-name)))) + ;; Disable secondary prompt. + (org-babel-comint-input-command + session + ":set prompt-cont \"\"") + session) + )) session)) @@ -237,7 +275,7 @@ (defun org-babel-load-session:haskell (session body params) (defun org-babel-prep-session:haskell (session params) "Prepare SESSION according to the header arguments in PARAMS." (save-window-excursion - (let ((buffer (org-babel-haskell-initiate-session session))) + (let ((buffer (org-babel-haskell-initiate-session session params))) (org-babel-comint-in-buffer buffer (mapc (lambda (line) (insert line) -- 2.39.3