Towards a customizable haskell-mode

From: haskell#350 (comment)

Author: ardumont

haskell-process.el

@@ -119,32 +119,62 @@ Docker users may want to use something like \"run-my-docker\"."
   :group 'haskell-interactive
   :type '(choice string (repeat string)))
 
-(defun haskell-process-wrapper-command (cmd)
+(defun haskell-process--stringify-cmd (cmd &optional args)
+  "Stringify the CMD with optional ARGS."
+  (format "%s" (s-join " " (cons cmd args))))
+
+(require 'ert)
+(ert-deftest haskell-process-stringify-cmd-no-arg ()
+  "No wrapper, return directly the command (between string quote)."
+  (should (equal "\"run\""
+                 (let ((haskell-process-wrapper nil))
+                   (haskell-process--stringify-cmd "run")))))
+(ert-deftest haskell-process-stringify-cmd-with-args ()
+  "No wrapper, return directly the command."
+  (should (equal "\"run -a b -c d\""
+                 (let ((haskell-process-wrapper nil))
+                   (haskell-process--stringify-cmd "run" '("-a" "b" "-c" "d"))))))
+
+(defun haskell-process-wrapper-command (cmd &optional cmd-args)
   "Compute the haskell command to execute to launch the haskell-process type.
-if haskell-process-wrapper is set, return a wrapper of the CMD.
-Otherwise, return CMD."
+if haskell-process-wrapper is set, return a wrapper of the CMD as list.
+Otherwise, return CMD as list.
+Deal with optional CMD-ARGS for the CMD."
   (require 's)
   (if haskell-process-wrapper
-      (if (stringp haskell-process-wrapper)
-          (format "%s \"%s\"" haskell-process-wrapper (shell-quote-argument cmd))
-        (s-join " " (append haskell-process-wrapper (list (format "\"%s\"" (shell-quote-argument cmd))))))
-    cmd))
+      (let ((wrapped-cmd (haskell-process--stringify-cmd cmd cmd-args)))
+        (if (stringp haskell-process-wrapper)
+            (list haskell-process-wrapper wrapped-cmd)
+          (append haskell-process-wrapper (list wrapped-cmd))))
+    (cons cmd cmd-args)))
 
-(require 'ert)
 (ert-deftest haskell-process-wrapper-command-nil ()
   "No wrapper, return directly the command."
-  (custom-set-variables '(haskell-process-wrapper nil))
-  (should (equal "ghci" (haskell-process-wrapper-command "ghci"))))
+  (should (equal '("ghci")
+                 (let ((haskell-process-wrapper nil))
+                   (haskell-process-wrapper-command "ghci")))))
 (ert-deftest haskell-process-wrapper-command-with-string ()
   "Wrapper as a string, return the wrapping command as a string."
-  (custom-set-variables '(haskell-process-wrapper "nix-shell shell.nix --command"))
-  (should (equal "nix-shell shell.nix --command \"cabal\\ run\"" (haskell-process-wrapper-command "cabal run"))))
+  (should (equal '("nix-shell" "\"cabal run\"")
+                 (let ((haskell-process-wrapper "nix-shell"))
+                   (haskell-process-wrapper-command "cabal run")))))
+(ert-deftest haskell-process-wrapper-command-with-string-2 ()
+  "Wrapper as a string, return the wrapping command as a string."
+  (should (equal '("nix-shell" "\"cabal run\"")
+                 (let ((haskell-process-wrapper "nix-shell"))
+                   (haskell-process-wrapper-command "cabal" '("run"))))))
 (ert-deftest haskell-process-wrapper-command-with-repeat-string ()
   "Wrapper as a list of string, return the wrapping command as a string."
-  (custom-set-variables '(haskell-process-wrapper '("nix-shell" "default.nix" "--command")))
-  (should (equal "nix-shell default.nix --command \"cabal\\ build\"" (haskell-process-wrapper-command "cabal build"))))
+  (should (equal '("nix-shell" "default.nix" "--command" "\"cabal build\"")
+                 (let ((haskell-process-wrapper '("nix-shell" "default.nix" "--command")))
+                   (haskell-process-wrapper-command "cabal" '("build"))))))
 
-(custom-set-variables '(haskell-process-wrapper '("nix-shell" "haskell-lab.nix" "--command")))
+;; (custom-set-variables '(haskell-process-wrapper '("nix-shell" "default.nix" "--command")))
+;; (custom-set-variables '(haskell-process-wrapper nil))
+;; (custom-set-variables '(haskell-process-type 'cabal-repl))
+;; (custom-set-variables '(haskell-process-type 'cabal-ghci))
+;; (custom-set-variables '(haskell-process-type 'ghci))
+;; (custom-set-variables '(haskell-process-type 'cabal-dev))
 
 (defcustom haskell-process-log
   nil
@@ -1049,68 +1079,104 @@ from `module-buffer'."
   "Compute the log and process to start command for the SESSION from the HPTYPE.
 Do not actually start any process.
 HPTYPE is the result of calling `'haskell-process-type`' function."
-  (cl-ecase hptype
-    ('ghci
-     (cons (format "Starting inferior GHCi process %s ..." haskell-process-path-ghci)
-           (append (list (haskell-session-name session)
-                         nil
-                         haskell-process-path-ghci)
-                   haskell-process-args-ghci)))
-    ('cabal-repl
-     (cons (format "Starting inferior `cabal repl' process using %s ..." haskell-process-path-cabal)
-           (append (list (haskell-session-name session)
-                         nil
-                         haskell-process-path-cabal)
-                   '("repl") haskell-process-args-cabal-repl
-                   (let ((target (haskell-session-target session)))
-                     (if target (list target) nil)))))
-    ('cabal-ghci
-     (list (format "Starting inferior cabal-ghci process using %s ..." haskell-process-path-cabal-ghci)
-           (haskell-session-name session)
-           nil
-           haskell-process-path-cabal-ghci))
-    ('cabal-dev
-     (let ((dir (concat (haskell-session-cabal-dir session) "/cabal-dev")))
-       (list (format "Starting inferior cabal-dev process %s -s %s ..." haskell-process-path-cabal-dev dir)
-             (haskell-session-name session)
-             nil
-             haskell-process-path-cabal-dev
-             "ghci"
-             "-s"
-             dir)))))
+  (let ((session-name (haskell-session-name session)))
+    (cl-ecase hptype
+      ('ghci
+       (append (list (format "Starting inferior GHCi process %s ..." haskell-process-path-ghci)
+                     session-name
+                     nil)
+               (haskell-process-wrapper-command haskell-process-path-ghci haskell-process-args-ghci)))
+      ('cabal-repl
+       (append (list (format "Starting inferior `cabal repl' process using %s ..." haskell-process-path-cabal)
+                     session-name
+                     nil)
+               (haskell-process-wrapper-command haskell-process-path-cabal (cons "repl" haskell-process-args-cabal-repl))
+               (let ((target (haskell-session-target session)))
+                 (if target (list target) nil))))
+      ('cabal-ghci
+       (append (list (format "Starting inferior cabal-ghci process using %s ..." haskell-process-path-cabal-ghci)
+                     session-name
+                     nil)
+               (haskell-process-wrapper-command haskell-process-path-cabal-ghci)))
+      ('cabal-dev
+       (let ((dir (concat (haskell-session-cabal-dir session) "/cabal-dev")))
+         (append (list (format "Starting inferior cabal-dev process %s -s %s ..." haskell-process-path-cabal-dev dir)
+                       session-name
+                       nil)
+                 (haskell-process-wrapper-command haskell-process-path-cabal-dev (list "ghci" "-s" dir))))))))
 
 (require 'ert)
 (require 'el-mock)
 
 (ert-deftest test-haskell-process--compute-process-log-and-command-ghci ()
   (should (equal '("Starting inferior GHCi process ghci ..." "dumses1" nil "ghci" "-ferror-spans")
                  (let ((haskell-process-path-ghci "ghci")
-                       (haskell-process-args-ghci '("-ferror-spans")))
+                       (haskell-process-args-ghci '("-ferror-spans"))
+                       (haskell-process-wrapper   nil))
+                   (with-mock
+                     (mock (haskell-session-name "dummy-session") => "dumses1")
+                     (haskell-process--compute-process-log-and-command "dummy-session" 'ghci))))))
+
+(ert-deftest test-haskell-process--with-wrapper-compute-process-log-and-command-ghci ()
+  (should (equal '("Starting inferior GHCi process ghci ..." "dumses1" nil "nix-shell" "default.nix" "--command" "\"ghci -ferror-spans\"")
+                 (let ((haskell-process-path-ghci "ghci")
+                       (haskell-process-args-ghci '("-ferror-spans"))
+                       (haskell-process-wrapper '("nix-shell" "default.nix" "--command")))
                    (with-mock
                      (mock (haskell-session-name "dummy-session") => "dumses1")
                      (haskell-process--compute-process-log-and-command "dummy-session" 'ghci))))))
 
 (ert-deftest test-haskell-process--compute-process-log-and-command-cabal-repl ()
   (should (equal '("Starting inferior `cabal repl' process using cabal ..." "dumses2" nil "cabal" "repl" "--ghc-option=-ferror-spans" "dumdum-session")
                  (let ((haskell-process-path-cabal "cabal")
-                       (haskell-process-args-cabal-repl '("--ghc-option=-ferror-spans")))
+                       (haskell-process-args-cabal-repl '("--ghc-option=-ferror-spans"))
+                       (haskell-process-wrapper nil))
+                   (with-mock
+                     (mock (haskell-session-name "dummy-session2") => "dumses2")
+                     (mock (haskell-session-target "dummy-session2") => "dumdum-session")
+                     (haskell-process--compute-process-log-and-command "dummy-session2" 'cabal-repl))))))
+
+(ert-deftest test-haskell-process--with-wrapper-compute-process-log-and-command-cabal-repl ()
+  (should (equal '("Starting inferior `cabal repl' process using cabal ..." "dumses2" nil "nix-shell" "default.nix" "--command" "\"cabal repl --ghc-option=-ferror-spans\"" "dumdum-session")
+                 (let ((haskell-process-path-cabal "cabal")
+                       (haskell-process-args-cabal-repl '("--ghc-option=-ferror-spans"))
+                       (haskell-process-wrapper   '("nix-shell" "default.nix" "--command")))
                    (with-mock
                      (mock (haskell-session-name "dummy-session2") => "dumses2")
                      (mock (haskell-session-target "dummy-session2") => "dumdum-session")
                      (haskell-process--compute-process-log-and-command "dummy-session2" 'cabal-repl))))))
 
 (ert-deftest test-haskell-process--compute-process-log-and-command-cabal-ghci ()
   (should (equal '("Starting inferior cabal-ghci process using cabal-ghci ..." "dumses3" nil "cabal-ghci")
-                 (let ((haskell-process-path-ghci "ghci"))
+                 (let ((haskell-process-path-ghci "ghci")
+                       (haskell-process-wrapper   nil))
+                   (with-mock
+                     (mock (haskell-session-name "dummy-session3") => "dumses3")
+                     (haskell-process--compute-process-log-and-command "dummy-session3" 'cabal-ghci))))))
+
+(ert-deftest test-haskell-process--with-wrapper-compute-process-log-and-command-cabal-ghci ()
+  (should (equal '("Starting inferior cabal-ghci process using cabal-ghci ..." "dumses3" nil "nix-shell" "default.nix" "--command" "\"cabal-ghci\"")
+                 (let ((haskell-process-path-ghci "ghci")
+                       (haskell-process-wrapper   '("nix-shell" "default.nix" "--command")))
                    (with-mock
                      (mock (haskell-session-name "dummy-session3") => "dumses3")
                      (haskell-process--compute-process-log-and-command "dummy-session3" 'cabal-ghci))))))
 
 (ert-deftest test-haskell-process--compute-process-log-and-command-cabal-dev ()
   (should (equal '("Starting inferior cabal-dev process cabal-dev -s directory/cabal-dev ..." "dumses4" nil "cabal-dev" "ghci" "-s" "directory/cabal-dev")
-                 (let ((haskell-process-path-cabal-dev "cabal-dev"))
+                 (let ((haskell-process-path-cabal-dev "cabal-dev")
+                       (haskell-process-wrapper   nil))
+                   (with-mock
+                     (mock (haskell-session-name "dummy-session4")      => "dumses4")
+                     (mock (haskell-session-cabal-dir "dummy-session4") => "directory")
+                     (haskell-process--compute-process-log-and-command "dummy-session4" 'cabal-dev))))))
+
+(ert-deftest test-haskell-process--with-wrapper-compute-process-log-and-command-cabal-dev ()
+  (should (equal '("Starting inferior cabal-dev process cabal-dev -s directory/cabal-dev ..." "dumses4" nil "run-with-docker" "\"cabal-dev ghci -s directory/cabal-dev\"")
+                 (let ((haskell-process-path-cabal-dev "cabal-dev")
+                       (haskell-process-wrapper        "run-with-docker"))
                    (with-mock
-                     (mock (haskell-session-name "dummy-session4") => "dumses4")
+                     (mock (haskell-session-name "dummy-session4")      => "dumses4")
                      (mock (haskell-session-cabal-dir "dummy-session4") => "directory")
                      (haskell-process--compute-process-log-and-command "dummy-session4" 'cabal-dev))))))
 
@@ -1130,6 +1196,8 @@ HPTYPE is the result of calling `'haskell-process-type`' function."
     (haskell-process-set-session process session)
     (haskell-process-set-cmd process nil)
     (haskell-process-set (haskell-session-process session) 'is-restarting nil)
+    ;; (when haskell-process-wrapper
+    ;;   (setq default-directory (haskell-session-current-dir session)))
     (let ((default-directory (haskell-session-cabal-dir session))
           (log-and-process-to-start (haskell-process--compute-process-log-and-command session (haskell-process-type))))
       (haskell-session-pwd session)