diff --git a/haskell.el b/haskell.el index a3dc618b2..1352fd0fb 100644 --- a/haskell.el +++ b/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 () diff --git a/tests/haskell-hsc2hs-tests.el b/tests/haskell-hsc2hs-tests.el new file mode 100644 index 000000000..6a8a811aa --- /dev/null +++ b/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 + +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:\"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 diff --git a/tests/haskell-test-utils.el b/tests/haskell-test-utils.el index 58ff67f93..e4e4f8f66 100644 --- a/tests/haskell-test-utils.el +++ b/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.