Run hs2hs on .hsc-files before loading

haskell.el

@@ -398,18 +398,61 @@ Give optional NEXT-P parameter to override value of
          (buffer (haskell-session-interactive-buffer session)))
     (pop-to-buffer buffer)))
 
+
+(defun haskell--file-name-to-load-string (file-name)
+  "Create a GHCi repl load statement from FILE-NAME."
+  (format "load \"%s\"" (replace-regexp-in-string
+                         "\""
+                         "\\\\\""
+                         file-name)))
+
+(defcustom haskell-process-path-hsc2hs
+  "hsc2hs"
+  "The path for running hsc2hs.
+This should be a single string."
+  :group 'haskell-interactive
+  :type 'string)
+
+(defun haskell--process-hsc2hs-load ()
+  "Run hsc2hs and load the resulting file (unless hsc2hs failed)."
+  ;; assumes lexical-binding
+  (let* ((hwin (get-buffer-window (current-buffer)))
+         (hs (replace-regexp-in-string "\\.hsc\\'" ".hs" (buffer-file-name)))
+         (cbuf (compilation-start (format "%s %s"
+                                          haskell-process-path-hsc2hs
+                                          (buffer-file-name))
+                                  nil
+                                  (lambda (_) "*hsc2hs*")))
+         (proc (get-buffer-process cbuf)))
+    (set-process-sentinel proc (lambda (p m)
+                                 (haskell--hsc2hs-sentinel hs hwin p m)))))
+
+(defun haskell--hsc2hs-sentinel (hs hwin proc msg)
+  "Load compiled .hs (and hide compilation) on hsc2hs success.
+Argument HS is the generated hsc source file name; HWIN is the
+window of the hsc source file; PROC is the hsc2hs process (MSG is
+currently ignored)."
+  (when (and (memq (process-status proc) '(exit signal))
+             (equal 0 (process-exit-status proc)))
+    (let ((cbuf (process-buffer proc)))
+      (select-window (get-buffer-window cbuf))
+      (bury-buffer)
+      (select-window hwin)
+      (haskell-process-file-loadish (haskell--file-name-to-load-string hs)
+                                    nil
+                                    (window-buffer hwin)))))
+
 ;;;###autoload
 (defun haskell-process-load-file ()
   "Load the current buffer file."
   (interactive)
   (save-buffer)
   (haskell-interactive-mode-reset-error (haskell-session))
-  (haskell-process-file-loadish (format "load \"%s\"" (replace-regexp-in-string
-                                                       "\""
-                                                       "\\\\\""
-                                                       (buffer-file-name)))
-                                nil
-                                (current-buffer)))
+  (if (equal "hsc" (file-name-extension (buffer-file-name)))
+      (haskell--process-hsc2hs-load)
+    (haskell-process-file-loadish (haskell--file-name-to-load-string (buffer-file-name))
+                                  nil
+                                  (current-buffer))))
 
 ;;;###autoload
 (defun haskell-process-reload ()

tests/haskell-hsc2hs-tests.el

@@ -0,0 +1,133 @@
+;; haskell-hsc2hs-tests.el --- -*- lexical-binding: t; -*-
+
+(require 'ert)
+(require 'haskell)
+(require 'haskell-test-utils)
+
+
+(defvar default-hsc "{-# LANGUAGE CPP                      #-}
+{-# LANGUAGE CApiFFI                  #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module Hsc2hsTest where
+
+import           Foreign
+import           Foreign.C.String
+import           Foreign.C.Types
+
+#include <stdlib.h>
+
+newtype NUMBERS = NUMBERS { unNUMBERS :: CInt }
+    deriving (Eq,Show)
+
+#{enum NUMBERS, NUMBERS
+ , rand_max = RAND_MAX
+ }
+")
+
+(defvar fake-ghci "#!/usr/bin/awk -f
+
+BEGIN {
+    printf \"%s\", \"Your wish is my IO ().\\nChanged directory: /tmp/\\nPrelude> \"
+    fflush()
+}
+
+/^:t unNUMBERS rand_max$/ {
+    printf \"%s\", \"unNUMBERS rand_max :: CInt\\nPrelude> \"
+    fflush()
+    next
+}
+
+{
+    printf \"%s\", \"\\n<interactive>:\"NR\":1-\"length($0)\": Not in scope: ‘\"$0\"’\\nPrelude> \"
+    fflush()
+}
+" "Very stupid fake ghci specific to our tests")
+
+(defvar fake-hsc2hs "#!/usr/bin/awk -f
+
+/^#{/ {
+    skip = 1
+}
+
+!skip && !/^#include/ {
+    lines = lines $0\"\\n\"
+}
+
+/}/ {
+    skip = 0
+}
+
+/A_TYPO/ {
+    print FILENAME\":\"NR\":58: error: ‘A_TYPO’ undeclared (first use in this function)\" >\"/dev/stderr\"
+    lines=\"\"
+    exit(1)
+}
+
+END {
+    if(lines) {
+        lines = lines \"rand_max  :: NUMBERS\\n\"
+        lines = lines \"rand_max  = NUMBERS 2147483647\\n\"
+        hs = FILENAME
+        sub(/hsc$/, \"hs\", hs)
+        if(FILENAME==hs) {
+            print FILENAME\" doesn't seem to end in .hsc\">\"/dev/stderr\"
+            exit(1)
+        }
+        else {
+            print lines > hs
+        }
+    }
+}
+" "Very stupid fake hsc2hs specific to our tests")
+
+
+(defmacro with-hsc2hs (contents &rest body)
+  "Load CONTENTS as a .hsc, then run BODY after it's loaded into REPL.
+Uses fake hsc2hs script from this directory."
+  (declare (debug t) (indent 1))
+  `(with-temp-switch-to-buffer
+     (let* ((hsc (make-temp-file "haskell-hsc2hs-tests.el" nil ".hsc"))
+            (hs (replace-regexp-in-string "\\.hsc\\'" ".hs" hsc)))
+       (insert ,contents)
+       (write-file hsc)
+       (haskell-mode)
+       (with-script-path haskell-process-path-hsc2hs fake-hsc2hs 'keep
+         (haskell-process-load-file)
+         (let ((proc (get-buffer-process "*hsc2hs*")))
+           (while (and proc (eq (process-status proc) 'run)) ; TODO: is there no built-in way to block-wait on a process?
+             (sit-for 0.5))
+           ,@body)
+         (delete-file haskell-process-path-hsc2hs))
+       (delete-file hsc)
+       (when (file-exists-p hs)
+         (delete-file hs)))))
+
+(ert-deftest hsc2hs-errors ()
+  (custom-set-variables '(haskell-process-wrapper-function #'identity)) ; altered by some earlier test
+  (let ((error-hsc (concat default-hsc
+                           "newtype FOO = FOO { unFOO :: CInt } deriving (Eq,Show)\n"
+                           "#{enum FOO, FOO , a_typo = A_TYPO }\n")))
+    (with-hsc2hs error-hsc
+      (with-current-buffer "*hsc2hs*"
+        (goto-char (point-min))
+        (when (re-search-forward "A_TYPO" nil 'noerror)
+          (goto-char (match-beginning 0)))
+        (should (looking-at-p "A_TYPO. undeclared"))))))
+
+(ert-deftest hsc2hs-compile-and-load ()
+  (custom-set-variables '(haskell-process-wrapper-function #'identity)) ; altered by some earlier test
+  (with-script-path haskell-process-path-ghci fake-ghci 'keep
+    (custom-set-variables '(haskell-process-args-ghci '("-W" "interactive")))
+    (with-hsc2hs default-hsc
+      (with-current-buffer (haskell-session-interactive-buffer haskell-session)
+        (goto-char (point-max))
+        (insert ":t unNUMBERS rand_max")
+        (goto-char (point-max))
+        (haskell-interactive-handle-expr)
+        (sit-for 1.0) ; TODO: can we wait until the prompt appears, with a timeout?
+        (forward-line -1)
+        (should (looking-at-p "unNUMBERS rand_max :: CInt"))))
+    (delete-file haskell-process-path-ghci)))
+
+;; haskell-hsc2hs-tests.el ends here

tests/haskell-test-utils.el

@@ -99,6 +99,25 @@ after a test as this aids interactive debugging."
        (funcall ,mode)
        ,@body)))
 
+(defmacro with-script-path (path script keep &rest body)
+  "Run a script using a temporary file.
+
+Creates an executable temp file and sets the PATH variable to
+point to that, and inserts SCRIPT in the file and adds the
+executable bit.  Unless KEEP is non-nil, the script is deleted
+after BODY has run.  The variable PATH is available for use in
+BODY."
+  (declare (indent 3) (debug t))
+  `(let ((,path (make-temp-file "haskell-mode-tests-script")))
+     (with-current-buffer (find-file-noselect ,path)
+       (insert ,script)
+       (save-buffer)
+       (kill-buffer))
+     (set-file-modes ,path (string-to-number "700" 8))
+     (prog1 (progn ,@body)
+       (unless ,keep
+         (delete-file ,path)))))
+
 (defun check-properties (lines-or-contents props &optional mode)
   "Check if syntax properties and font-lock properties as set properly.