Run hs2hs on .hsc-files before loading

haskell.el

@@ -398,18 +398,58 @@ 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)))
+
+(defvar haskell-process-path-hsc2hs "hsc2hs"
+  "The path for running hsc2hs.
+This should be a single 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,75 @@
+;; 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
+ }
+")
+
+(defmacro with-hsc2hs (contents &rest body)
+  "Load CONTENTS as a .hsc, then run BODY after it's loaded into REPL.
+Uses `haskell-process-path-hsc2hs' if executable exists,
+otherwise fake script hsc2hs.sh from this directory."
+  (declare (debug t) (indent 1))
+  `(with-temp-switch-to-buffer
+     (let ((f (make-temp-file "haskell-hsc2hs-tests.el" nil ".hsc")))
+       (insert ,contents)
+       (write-file f)
+       (haskell-mode)
+       (let* ((dir (file-name-directory
+                    (find-lisp-object-file-name 'with-hsc2hs nil)))
+              (existing-hsc2hs (executable-find haskell-process-path-hsc2hs))
+              (haskell-process-path-hsc2hs
+               (if (and existing-hsc2hs (file-executable-p existing-hsc2hs))
+                   haskell-process-path-hsc2hs
+                 (format "%s/%s" dir "hsc2hs.sh"))))
+         (haskell-process-load-file))
+       (let ((proc (get-buffer-process "*hsc2hs*")))
+         (while (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 f)))))
+
+(ert-deftest hsc2hs-errors ()
+  (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 ()
+  (with-hsc2hs default-hsc
+    (with-current-buffer "*haskell*" ; TODO: Where is this defined?
+      (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")))))
+
+;; haskell-hsc2hs-tests.el ends here
+

tests/hsc2hs.sh

@@ -0,0 +1,29 @@
+#!/bin/sh
+
+# Very stupid fake hsc2hs specific to our tests
+
+awk -v hs="${1%c}" '
+/^#{/ {
+    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"
+        print lines > hs
+    }
+}
+' "$1"