diff --git a/Makefile b/Makefile index be0c21f6c..9fe70eba8 100644 --- a/Makefile +++ b/Makefile @@ -10,35 +10,42 @@ SUBST_ATAT = sed -e 's/@@GIT_VERSION@@/$(GIT_VERSION)/g;s/@GIT_VERSION@/$(GIT_VE ELFILES = \ ghc-core.el \ haskell-align-imports.el \ - haskell-c.el \ + haskell-bot.el \ haskell-cabal.el \ + haskell-c.el \ haskell-checkers.el \ + haskell-collapse.el \ + haskell-commands.el \ haskell-compat.el \ haskell-compile.el \ + haskell-complete-module.el \ + haskell-customize.el \ + haskell-debug.el \ haskell-decl-scan.el \ haskell-doc.el \ + haskell.el \ haskell-font-lock.el \ - haskell-indent.el \ haskell-indentation.el \ - haskell-collapse.el \ + haskell-indent.el \ haskell-interactive-mode.el \ + haskell-load.el \ haskell-menu.el \ haskell-mode.el \ haskell-move-nested.el \ haskell-navigate-imports.el \ haskell-package.el \ - haskell-complete-module.el \ + haskell-presentation-mode.el \ haskell-process.el \ + haskell-repl.el \ haskell-session.el \ haskell-show.el \ haskell-simple-indent.el \ haskell-sort-imports.el \ - haskell-string.el \ haskell-str.el \ + haskell-string.el \ haskell-unicode-input-method.el \ haskell-utils.el \ haskell-yas.el \ - haskell-presentation-mode.el \ inf-haskell.el ELCFILES = $(ELFILES:.el=.elc) diff --git a/gen-graph.sh b/gen-graph.sh new file mode 100644 index 000000000..74ded651d --- /dev/null +++ b/gen-graph.sh @@ -0,0 +1,12 @@ +echo "digraph {" +echo "rankdir=TB;" +for i in $(ls *.el | grep ^haskell) +do + + for x in $(egrep -o "^\\(require '([^)]+)" $i | sed "s/.require '//" | grep ^haskell) + do + z=$(echo $i | sed 's/.el$//') + echo "\"$z\" -> \"$x\"; " + done +done +echo "}" diff --git a/haskell-bot.el b/haskell-bot.el index 6969d9413..30cff1474 100644 --- a/haskell-bot.el +++ b/haskell-bot.el @@ -70,6 +70,8 @@ ;;; Code: +(require 'comint) + (defgroup haskell-bot nil "Major mode for interacting with an inferior Bot session." :group 'haskell diff --git a/haskell-commands.el b/haskell-commands.el new file mode 100644 index 000000000..c9c2f8bef --- /dev/null +++ b/haskell-commands.el @@ -0,0 +1,754 @@ +;;; haskell-commands.el --- Commands that can be run on the process + +;; Copyright (c) 2014 Chris Done. All rights reserved. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(require 'haskell-process) +(require 'haskell-font-lock) +(require 'haskell-interactive-mode) +(require 'haskell-session) + +(defun haskell-process-restart () + "Restart the inferior Haskell process." + (interactive) + (haskell-process-reset (haskell-interactive-process)) + (haskell-process-set (haskell-interactive-process) 'command-queue nil) + (haskell-process-start (haskell-interactive-session))) + +(defun haskell-process-start (session) + "Start the inferior Haskell process." + (let ((existing-process (get-process (haskell-session-name (haskell-interactive-session))))) + (when (processp existing-process) + (haskell-interactive-mode-echo session "Restarting process ...") + (haskell-process-set (haskell-session-process session) 'is-restarting t) + (delete-process existing-process))) + (let ((process (or (haskell-session-process session) + (haskell-process-make (haskell-session-name session)))) + (old-queue (haskell-process-get (haskell-session-process session) + 'command-queue))) + (haskell-session-set-process session process) + (haskell-process-set-session process session) + (haskell-process-set-cmd process nil) + (haskell-process-set (haskell-session-process session) 'is-restarting nil) + (let ((default-directory (haskell-session-cabal-dir session))) + (haskell-session-pwd session) + (haskell-process-set-process + process + (cl-ecase (haskell-process-type) + ('ghci + (haskell-process-log + (propertize (format "Starting inferior GHCi process %s ..." + haskell-process-path-ghci) + 'face font-lock-comment-face)) + (apply #'start-process + (append (list (haskell-session-name session) + nil + haskell-process-path-ghci) + haskell-process-args-ghci))) + ('cabal-repl + (haskell-process-log + (propertize + (format "Starting inferior `cabal repl' process using %s ..." + haskell-process-path-cabal) + 'face font-lock-comment-face)) + + (apply #'start-process + (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 + (haskell-process-log + (propertize + (format "Starting inferior cabal-ghci process using %s ..." + haskell-process-path-cabal-ghci) + 'face font-lock-comment-face)) + (start-process (haskell-session-name session) + nil + haskell-process-path-cabal-ghci)) + ('cabal-dev + (let ((dir (concat (haskell-session-cabal-dir session) + "/cabal-dev"))) + (haskell-process-log + (propertize (format "Starting inferior cabal-dev process %s -s %s ..." + haskell-process-path-cabal-dev + dir) + 'face font-lock-comment-face)) + (start-process (haskell-session-name session) + nil + haskell-process-path-cabal-dev + "ghci" + "-s" + dir)))))) + (progn (set-process-sentinel (haskell-process-process process) 'haskell-process-sentinel) + (set-process-filter (haskell-process-process process) 'haskell-process-filter)) + (haskell-process-send-startup process) + (unless (eq 'cabal-repl (haskell-process-type)) ;; "cabal repl" sets the proper CWD + (haskell-process-change-dir session + process + (haskell-session-current-dir session))) + (haskell-process-set process 'command-queue + (append (haskell-process-get (haskell-session-process session) + 'command-queue) + old-queue)) + process)) + +(defun haskell-process-send-startup (process) + "Send the necessary start messages." + (haskell-process-queue-command + process + (make-haskell-command + :state process + + :go (lambda (process) + (haskell-process-send-string process ":set prompt \"\\4\"") + (haskell-process-send-string process "Prelude.putStrLn \"\"") + (haskell-process-send-string process ":set -v1")) + + :live (lambda (process buffer) + (when (haskell-process-consume + process + "^\*\*\* WARNING: \\(.+\\) is writable by someone else, IGNORING!$") + (let ((path (match-string 1 buffer))) + (haskell-session-modify + (haskell-process-session process) + 'ignored-files + (lambda (files) + (cl-remove-duplicates (cons path files) :test 'string=))) + (haskell-interactive-mode-compile-warning + (haskell-process-session process) + (format "GHCi is ignoring: %s (run M-x haskell-process-unignore)" + path))))) + + :complete (lambda (process _) + (haskell-interactive-mode-echo + (haskell-process-session process) + (concat (nth (random (length haskell-process-greetings)) + haskell-process-greetings) + (when haskell-process-show-debug-tips + " +If I break, you can: + 1. Restart: M-x haskell-process-restart + 2. Configure logging: C-h v haskell-process-log (useful for debugging) + 3. General config: M-x customize-mode + 4. Hide these tips: C-h v haskell-process-show-debug-tips"))))))) + +(defun haskell-commands-process () + "Get the Haskell session, throws an error if not available." + (or (haskell-session-process (haskell-session-maybe)) + (error "No Haskell session/process associated with this + buffer. Maybe run M-x haskell-session-change?"))) + +(defun haskell-process-clear () + "Clear the current process." + (interactive) + (haskell-process-reset (haskell-commands-process)) + (haskell-process-set (haskell-commands-process) 'command-queue nil)) + +(defun haskell-process-interrupt () + "Interrupt the process (SIGINT)." + (interactive) + (interrupt-process (haskell-process-process (haskell-commands-process)))) + +(defun haskell-process-reload-with-fbytecode (process module-buffer) + "Reload FILE-NAME with -fbyte-code set, and then restore -fobject-code." + (haskell-process-queue-without-filters process ":set -fbyte-code") + (haskell-process-touch-buffer process module-buffer) + (haskell-process-queue-without-filters process ":reload") + (haskell-process-queue-without-filters process ":set -fobject-code")) + +(defun haskell-process-touch-buffer (process buffer) + "Updates mtime on the file for BUFFER by queing a touch on +PROCESS." + (interactive) + (haskell-process-queue-command + process + (make-haskell-command + :state (cons process buffer) + :go (lambda (state) + (haskell-process-send-string + (car state) + (format ":!%s %s" + "touch" + (shell-quote-argument (buffer-file-name + (cdr state)))))) + :complete (lambda (state _) + (with-current-buffer (cdr state) + (clear-visited-file-modtime)))))) + +(defvar url-http-response-status) +(defvar url-http-end-of-headers) + +(defun haskell-process-hayoo-ident (ident) + "Hayoo for IDENT, returns a list of modules asyncronously through CALLBACK." + ;; We need a real/simulated closure, because otherwise these + ;; variables will be unbound when the url-retrieve callback is + ;; called. + ;; TODO: Remove when this code is converted to lexical bindings by + ;; default (Emacs 24.1+) + (let ((url (format haskell-process-hayoo-query-url (url-hexify-string ident)))) + (with-current-buffer (url-retrieve-synchronously url) + (if (= 200 url-http-response-status) + (progn + (goto-char url-http-end-of-headers) + (let* ((res (json-read)) + (results (assoc-default 'result res))) + ;; TODO: gather packages as well, and when we choose a + ;; given import, check that we have the package in the + ;; cabal file as well. + (cl-mapcan (lambda (r) + ;; append converts from vector -> list + (append (assoc-default 'resultModules r) nil)) + results))) + (warn "HTTP error %s fetching %s" url-http-response-status url))))) + +(defun haskell-process-hoogle-ident (ident) + "Hoogle for IDENT, returns a list of modules." + (with-temp-buffer + (let ((hoogle-error (call-process "hoogle" nil t nil "search" "--exact" ident))) + (goto-char (point-min)) + (unless (or (/= 0 hoogle-error) + (looking-at "^No results found") + (looking-at "^package ")) + (while (re-search-forward "^\\([^ ]+\\).*$" nil t) + (replace-match "\\1" nil nil)) + (cl-remove-if (lambda (a) (string= "" a)) + (split-string (buffer-string) + "\n")))))) + +(defun haskell-process-haskell-docs-ident (ident) + "Search with haskell-docs for IDENT, returns a list of modules." + (cl-remove-if-not (lambda (a) (string-match "^[A-Z][A-Za-b0-9_'.]+$" a)) + (split-string (shell-command-to-string (concat "haskell-docs --modules " ident)) + "\n"))) + +(defun haskell-process-import-modules (process modules) + "Import `modules' with :m +, and send any import statements +from `module-buffer'." + (when haskell-process-auto-import-loaded-modules + (haskell-process-queue-command + process + (make-haskell-command + :state (cons process modules) + :go (lambda (state) + (haskell-process-send-string + (car state) + (format ":m + %s" (mapconcat 'identity (cdr state) " ")))))))) + +(defun haskell-describe (ident) + "Describe the given identifier." + (interactive (list (read-from-minibuffer "Describe identifier: " + (haskell-ident-at-point)))) + (let ((results (read (shell-command-to-string + (concat "haskell-docs --sexp " + ident))))) + (help-setup-xref (list #'haskell-describe ident) + (called-interactively-p 'interactive)) + (save-excursion + (with-help-window (help-buffer) + (with-current-buffer (help-buffer) + (if results + (cl-loop for result in results + do (insert (propertize ident 'font-lock-face + '((:inherit font-lock-type-face + :underline t))) + " is defined in " + (let ((module (cadr (assoc 'module result)))) + (if module + (concat module " ") + "")) + (cadr (assoc 'package result)) + "\n\n") + do (let ((type (cadr (assoc 'type result)))) + (when type + (insert (haskell-fontify-as-mode type 'haskell-mode) + "\n"))) + do (let ((args (cadr (assoc 'type results)))) + (cl-loop for arg in args + do (insert arg "\n")) + (insert "\n")) + do (insert (cadr (assoc 'documentation result))) + do (insert "\n\n")) + (insert "No results for " ident))))))) + +(defun haskell-rgrep (&optional prompt) + "Grep the effective project for the symbol at point. Very +useful for codebase navigation. Prompts for an arbitrary regexp +given a prefix arg." + (interactive "P") + (let ((sym (if prompt + (read-from-minibuffer "Look for: ") + (haskell-ident-at-point)))) + (rgrep sym + "*.hs" ;; TODO: common Haskell extensions. + (haskell-session-current-dir (haskell-interactive-session))))) + +;;;###autoload +(defun haskell-process-do-info (&optional prompt-value) + "Print info on the identifier at point. +If PROMPT-VALUE is non-nil, request identifier via mini-buffer." + (interactive "P") + (haskell-process-do-simple-echo + (let ((ident (if prompt-value + (read-from-minibuffer "Info: " (haskell-ident-at-point)) + (haskell-ident-at-point))) + (modname (unless prompt-value + (haskell-utils-parse-import-statement-at-point)))) + (if modname + (format ":browse! %s" modname) + (format (if (string-match "^[a-zA-Z_]" ident) + ":info %s" + ":info (%s)") + (or ident + (haskell-ident-at-point))))) + 'haskell-mode)) + +;;;###autoload +(defun haskell-process-do-type (&optional insert-value) + "Print the type of the given expression." + (interactive "P") + (if insert-value + (haskell-process-insert-type) + (haskell-process-do-simple-echo + (let ((ident (haskell-ident-at-point))) + ;; TODO: Generalize all these `string-match' of ident calls into + ;; one function. + (format (if (string-match "^[_[:lower:][:upper:]]" ident) + ":type %s" + ":type (%s)") + ident)) + 'haskell-mode))) + +;;;###autoload +(defun haskell-mode-jump-to-def-or-tag (&optional next-p) + "Jump to the definition (by consulting GHCi), or (fallback) +jump to the tag. + +Remember: If GHCi is busy doing something, this will delay, but +it will always be accurate, in contrast to tags, which always +work but are not always accurate. + +If the definition or tag is found, the location from which you +jumped will be pushed onto `find-tag-marker-ring', so you can +return to that position with `pop-tag-mark'." + (interactive "P") + (let ((initial-loc (point-marker)) + (loc (haskell-mode-find-def (haskell-ident-at-point)))) + (if loc + (haskell-mode-handle-generic-loc loc) + (call-interactively 'haskell-mode-tag-find)) + (unless (equal initial-loc (point-marker)) + ;; Store position for return with `pop-tag-mark' + (ring-insert find-tag-marker-ring initial-loc)))) + +;;;###autoload +(defun haskell-mode-goto-loc () + "Go to the location of the thing at point. Requires the :loc-at +command from GHCi." + (interactive) + (let ((loc (haskell-mode-loc-at))) + (when loc + (find-file (expand-file-name (plist-get loc :path) + (haskell-session-cabal-dir (haskell-interactive-session)))) + (goto-char (point-min)) + (forward-line (1- (plist-get loc :start-line))) + (forward-char (plist-get loc :start-col))))) + +(defun haskell-process-insert-type () + "Get the identifer at the point and insert its type, if +possible, using GHCi's :type." + (let ((process (haskell-interactive-process)) + (query (let ((ident (haskell-ident-at-point))) + (format (if (string-match "^[_[:lower:][:upper:]]" ident) + ":type %s" + ":type (%s)") + ident)))) + (haskell-process-queue-command + process + (make-haskell-command + :state (list process query (current-buffer)) + :go (lambda (state) + (haskell-process-send-string (nth 0 state) + (nth 1 state))) + :complete (lambda (state response) + (cond + ;; TODO: Generalize this into a function. + ((or (string-match "^Top level" response) + (string-match "^" response)) + (message response)) + (t + (with-current-buffer (nth 2 state) + (goto-char (line-beginning-position)) + (insert (format "%s\n" (replace-regexp-in-string "\n$" "" response))))))))))) + +(defun haskell-mode-find-def (ident) + "Find definition location of identifier. Uses the GHCi process +to find the location. + +Returns: + + (library ) + (file ) + (module ) +" + (let ((reply (haskell-process-queue-sync-request + (haskell-interactive-process) + (format (if (string-match "^[a-zA-Z_]" ident) + ":info %s" + ":info (%s)") + ident)))) + (let ((match (string-match "-- Defined \\(at\\|in\\) \\(.+\\)$" reply))) + (when match + (let ((defined (match-string 2 reply))) + (let ((match (string-match "\\(.+?\\):\\([0-9]+\\):\\([0-9]+\\)$" defined))) + (cond + (match + (list 'file + (expand-file-name (match-string 1 defined) + (haskell-session-current-dir (haskell-interactive-session))) + (string-to-number (match-string 2 defined)) + (string-to-number (match-string 3 defined)))) + (t + (let ((match (string-match "`\\(.+?\\):\\(.+?\\)'$" defined))) + (if match + (list 'library + (match-string 1 defined) + (match-string 2 defined)) + (let ((match (string-match "`\\(.+?\\)'$" defined))) + (if match + (list 'module + (match-string 1 defined)))))))))))))) + +(defun haskell-mode-jump-to-def (ident) + "Jump to definition of identifier at point." + (interactive (list (haskell-ident-at-point))) + (let ((loc (haskell-mode-find-def ident))) + (when loc + (haskell-mode-handle-generic-loc loc)))) + +(defun haskell-mode-handle-generic-loc (loc) + "Either jump to or display a generic location. Either a file or +a library." + (cl-case (car loc) + (file (haskell-mode-jump-to-loc (cdr loc))) + (library (message "Defined in `%s' (%s)." + (elt loc 2) + (elt loc 1))) + (module (message "Defined in `%s'." + (elt loc 1))))) + +(defun haskell-mode-loc-at () + "Get the location at point. Requires the :loc-at command from +GHCi." + (let ((pos (or (when (region-active-p) + (cons (region-beginning) + (region-end))) + (haskell-ident-pos-at-point) + (cons (point) + (point))))) + (when pos + (let ((reply (haskell-process-queue-sync-request + (haskell-interactive-process) + (save-excursion + (format ":loc-at %s %d %d %d %d %s" + (buffer-file-name) + (progn (goto-char (car pos)) + (line-number-at-pos)) + (1+ (current-column)) ;; GHC uses 1-based columns. + (progn (goto-char (cdr pos)) + (line-number-at-pos)) + (1+ (current-column)) ;; GHC uses 1-based columns. + (buffer-substring-no-properties (car pos) + (cdr pos))))))) + (if reply + (if (string-match "\\(.*?\\):(\\([0-9]+\\),\\([0-9]+\\))-(\\([0-9]+\\),\\([0-9]+\\))" + reply) + (list :path (match-string 1 reply) + :start-line (string-to-number (match-string 2 reply)) + ;; ;; GHC uses 1-based columns. + :start-col (1- (string-to-number (match-string 3 reply))) + :end-line (string-to-number (match-string 4 reply)) + ;; GHC uses 1-based columns. + :end-col (1- (string-to-number (match-string 5 reply)))) + (error (propertize reply 'face 'compilation-error))) + (error (propertize "No reply. Is :loc-at supported?" + 'face 'compilation-error))))))) +(defun haskell-mode-type-at () + "Get the type of the thing at point. Requires the :type-at +command from GHCi." + (let ((pos (or (when (region-active-p) + (cons (region-beginning) + (region-end))) + (haskell-ident-pos-at-point) + (cons (point) + (point))))) + (when pos + (replace-regexp-in-string + "\n$" + "" + (save-excursion + (haskell-process-queue-sync-request + (haskell-interactive-process) + (replace-regexp-in-string + "\n" + " " + (format ":type-at %s %d %d %d %d %s" + (buffer-file-name) + (progn (goto-char (car pos)) + (line-number-at-pos)) + (1+ (current-column)) + (progn (goto-char (cdr pos)) + (line-number-at-pos)) + (1+ (current-column)) + (buffer-substring-no-properties (car pos) + (cdr pos)))))))))) + +(defun haskell-process-cd (&optional not-interactive) + "Change directory." + (interactive) + (let* ((session (haskell-interactive-session)) + (dir (haskell-session-pwd session t))) + (haskell-process-log + (propertize (format "Changing directory to %s ...\n" dir) + 'face font-lock-comment-face)) + (haskell-process-change-dir session + (haskell-interactive-process) + dir))) + +(defun haskell-session-pwd (session &optional change) + "Prompt for the current directory." + (or (unless change + (haskell-session-get session 'current-dir)) + (progn (haskell-session-set-current-dir + session + (haskell-utils-read-directory-name + (if change "Change directory: " "Set current directory: ") + (or (haskell-session-get session 'current-dir) + (haskell-session-get session 'cabal-dir) + (if (buffer-file-name) + (file-name-directory (buffer-file-name)) + "~/")))) + (haskell-session-get session 'current-dir)))) + +(defun haskell-process-change-dir (session process dir) + "Change the directory of the current process." + (haskell-process-queue-command + process + (make-haskell-command + :state (list session process dir) + :go + (lambda (state) + (haskell-process-send-string + (cadr state) (format ":cd %s" (cl-caddr state)))) + + :complete + (lambda (state _) + (haskell-session-set-current-dir (car state) (cl-caddr state)) + (haskell-interactive-mode-echo (car state) + (format "Changed directory: %s" + (cl-caddr state))))))) + +(defun haskell-process-cabal-macros () + "Send the cabal macros string." + (interactive) + (haskell-process-queue-without-filters (haskell-interactive-process) + ":set -optP-include -optPdist/build/autogen/cabal_macros.h")) + +(defun haskell-process-do-try-info (sym) + "Get info of `sym' and echo in the minibuffer." + (let ((process (haskell-interactive-process))) + (haskell-process-queue-command + process + (make-haskell-command + :state (cons process sym) + :go (lambda (state) + (haskell-process-send-string + (car state) + (if (string-match "^[A-Za-z_]" (cdr state)) + (format ":info %s" (cdr state)) + (format ":info (%s)" (cdr state))))) + :complete (lambda (state response) + (unless (or (string-match "^Top level" response) + (string-match "^" response)) + (haskell-mode-message-line response))))))) + +(defun haskell-process-do-try-type (sym) + "Get type of `sym' and echo in the minibuffer." + (let ((process (haskell-interactive-process))) + (haskell-process-queue-command + process + (make-haskell-command + :state (cons process sym) + :go (lambda (state) + (haskell-process-send-string + (car state) + (if (string-match "^[A-Za-z_]" (cdr state)) + (format ":type %s" (cdr state)) + (format ":type (%s)" (cdr state))))) + :complete (lambda (state response) + (unless (or (string-match "^Top level" response) + (string-match "^" response)) + (haskell-mode-message-line response))))))) + +(defun haskell-mode-show-type-at (&optional insert-value) + "Show the type of the thing at point." + (interactive "P") + (let ((ty (haskell-mode-type-at))) + (if insert-value + (progn (goto-char (line-beginning-position)) + (insert (haskell-fontify-as-mode ty 'haskell-mode) + "\n")) + (message "%s" (haskell-fontify-as-mode ty 'haskell-mode))))) + +(defun haskell-process-generate-tags (&optional and-then-find-this-tag) + "Regenerate the TAGS table." + (interactive) + (let ((process (haskell-interactive-process))) + (haskell-process-queue-command + process + (make-haskell-command + :state (cons process and-then-find-this-tag) + :go (lambda (state) + (if (eq system-type 'windows-nt) + (haskell-process-send-string + (car state) + (format ":!powershell -Command \"& { cd %s ; hasktags -e -x (ls -fi *.hs -exclude \\\"#*#\\\" -name -r) ; exit }\"" + (haskell-session-cabal-dir + (haskell-process-session (car state))))) + (haskell-process-send-string + (car state) + (format ":!cd %s && %s | %s | %s" + (haskell-session-cabal-dir + (haskell-process-session (car state))) + "find . -name '*.hs*'" + "grep -v '#'" ; To avoid Emacs back-up files. Yeah. + "xargs hasktags -e -x")))) + :complete (lambda (state response) + (when (cdr state) + (let ((tags-file-name + (haskell-session-tags-filename + (haskell-process-session (car state))))) + (find-tag (cdr state)))) + (haskell-mode-message-line "Tags generated.")))))) + +(defun haskell-process-add-cabal-autogen () + "Add /dist/build/autogen/ to the ghci search +path. This allows modules such as 'Path_...', generated by cabal, +to be loaded by ghci." + (unless (eq 'cabal-repl (haskell-process-type)) ;; redundant with "cabal repl" + (let* + ((session (haskell-interactive-session)) + (cabal-dir (haskell-session-cabal-dir session)) + (ghci-gen-dir (format "%sdist/build/autogen/" cabal-dir))) + (haskell-process-queue-without-filters + (haskell-interactive-process) + (format ":set -i%s" ghci-gen-dir))))) + +(defun haskell-process-unignore () + "Unignore any files that were specified as being ignored by the + inferior GHCi process." + (interactive) + (let ((session (haskell-interactive-session)) + (changed nil)) + (if (null (haskell-session-get session + 'ignored-files)) + (message "Nothing to unignore!") + (cl-loop for file in (haskell-session-get session + 'ignored-files) + do (cl-case (read-event + (propertize (format "Set permissions? %s (y, n, v: stop and view file)" + file) + 'face 'minibuffer-prompt)) + (?y + (haskell-process-unignore-file session file) + (setq changed t)) + (?v + (find-file file) + (cl-return)))) + (when (and changed + (y-or-n-p "Restart GHCi process now? ")) + (haskell-process-restart))))) + +(defun haskell-session-change-target (target) + "Set the build target for cabal repl" + (interactive "sNew build target:") + (let* ((session haskell-session) + (old-target (haskell-session-get session 'target))) + (when session + (haskell-session-set-target session target) + (when (and (not (string= old-target target)) + (y-or-n-p "Target changed, restart haskell process?")) + (haskell-process-start session))))) + +(defun haskell-mode-stylish-buffer () + "Apply stylish-haskell to the current buffer." + (interactive) + (let ((column (current-column)) + (line (line-number-at-pos))) + (haskell-mode-buffer-apply-command "stylish-haskell") + (goto-char (point-min)) + (forward-line (1- line)) + (goto-char (+ column (point))))) + +(defun haskell-mode-buffer-apply-command (cmd) + "Execute shell command CMD with current buffer as input and +replace the whole buffer with the output. If CMD fails the buffer +remains unchanged." + (set-buffer-modified-p t) + (let* ((chomp (lambda (str) + (while (string-match "\\`\n+\\|^\\s-+\\|\\s-+$\\|\n+\\'" str) + (setq str (replace-match "" t t str))) + str)) + (errout (lambda (fmt &rest args) + (let* ((warning-fill-prefix " ")) + (display-warning cmd (apply 'format fmt args) :warning)))) + (filename (buffer-file-name (current-buffer))) + (cmd-prefix (replace-regexp-in-string " .*" "" cmd)) + (tmp-file (make-temp-file cmd-prefix)) + (err-file (make-temp-file cmd-prefix)) + (default-directory (if (and (boundp 'haskell-session) + haskell-session) + (haskell-session-cabal-dir haskell-session) + default-directory)) + (errcode (with-temp-file tmp-file + (call-process cmd filename + (list (current-buffer) err-file) nil))) + (stderr-output + (with-temp-buffer + (insert-file-contents err-file) + (funcall chomp (buffer-substring-no-properties (point-min) (point-max))))) + (stdout-output + (with-temp-buffer + (insert-file-contents tmp-file) + (buffer-substring-no-properties (point-min) (point-max))))) + (if (string= "" stderr-output) + (if (string= "" stdout-output) + (funcall errout + "Error: %s produced no output, leaving buffer alone" cmd) + (save-restriction + (widen) + ;; command successful, insert file with replacement to preserve + ;; markers. + (insert-file-contents tmp-file nil nil nil t))) + ;; non-null stderr, command must have failed + (funcall errout "%s failed: %s" cmd stderr-output)) + (delete-file tmp-file) + (delete-file err-file))) + +(provide 'haskell-commands) diff --git a/haskell-customize.el b/haskell-customize.el new file mode 100644 index 000000000..f61771a7f --- /dev/null +++ b/haskell-customize.el @@ -0,0 +1,316 @@ +;;; haskell-customize.el --- Customization settings + +;; Copyright (c) 2014 Chris Done. All rights reserved. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(with-no-warnings (require 'cl)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Customization variables + +(defgroup haskell nil + "Major mode for editing Haskell programs." + :link '(custom-manual "(haskell-mode)") + :group 'languages + :prefix "haskell-") + +(defvar haskell-mode-pkg-base-dir (file-name-directory load-file-name) + "Package base directory of installed `haskell-mode'. +Used for locating additional package data files.") + +(defcustom haskell-completing-read-function 'ido-completing-read + "Default function to use for completion." + :group 'haskell + :type '(choice + (function-item :tag "ido" :value ido-completing-read) + (function-item :tag "helm" :value helm--completing-read-default) + (function-item :tag "completing-read" :value completing-read) + (function :tag "Custom function"))) + +(defcustom haskell-process-type + 'auto + "The inferior Haskell process type to use." + :type '(choice (const auto) (const ghci) (const cabal-repl) (const cabal-dev) (const cabal-ghci)) + :group 'haskell-interactive) + +(defcustom haskell-ask-also-kill-buffers + t + "Ask whether to kill all associated buffers when a session + process is killed." + :type 'boolean + :group 'haskell-interactive) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Configuration + +(defvar haskell-process-end-hook nil + "Hook for when the haskell process ends.") + +(defgroup haskell-interactive nil + "Settings for REPL interaction via `haskell-interactive-mode'" + :link '(custom-manual "(haskell-mode)haskell-interactive-mode") + :group 'haskell) + +(defcustom haskell-process-path-ghci + "ghci" + "The path for starting ghci." + :group 'haskell-interactive + :type '(choice string (repeat string))) + +(defcustom haskell-process-path-cabal + "cabal" + "Path to the `cabal' executable." + :group 'haskell-interactive + :type '(choice string (repeat string))) + +(defcustom haskell-process-path-cabal-ghci + "cabal-ghci" + "The path for starting cabal-ghci." + :group 'haskell-interactive + :type '(choice string (repeat string))) + +(defcustom haskell-process-path-cabal-dev + "cabal-dev" + "The path for starting cabal-dev." + :group 'haskell-interactive + :type '(choice string (repeat string))) + +(defcustom haskell-process-args-ghci + '("-ferror-spans") + "Any arguments for starting ghci." + :group 'haskell-interactive + :type '(repeat (string :tag "Argument"))) + +(defcustom haskell-process-args-cabal-repl + '("--ghc-option=-ferror-spans") + "Additional arguments to for `cabal repl' invocation. +Note: The settings in `haskell-process-path-ghci' and +`haskell-process-args-ghci' are not automatically reused as `cabal repl' +currently invokes `ghc --interactive'. Use +`--with-ghc=' if you want to use a different +interactive GHC frontend; use `--ghc-option=' to +pass additional flags to `ghc'." + :group 'haskell-interactive + :type '(repeat (string :tag "Argument"))) + +(defcustom haskell-process-do-cabal-format-string + ":!cd %s && %s" + "The way to run cabal comands. It takes two arguments -- the directory and the command. +See `haskell-process-do-cabal' for more details." + :group 'haskell-interactive + :type 'string) + +(defcustom haskell-process-log + nil + "Enable debug logging to \"*haskell-process-log*\" buffer." + :type 'boolean + :group 'haskell-interactive) + +(defcustom haskell-process-show-debug-tips + t + "Show debugging tips when starting the process." + :type 'boolean + :group 'haskell-interactive) + +(defcustom haskell-notify-p + nil + "Notify using notifications.el (if loaded)?" + :type 'boolean + :group 'haskell-interactive) + +(defcustom haskell-process-suggest-no-warn-orphans + t + "Suggest adding -fno-warn-orphans pragma to file when getting orphan warnings." + :type 'boolean + :group 'haskell-interactive) + +(defcustom haskell-process-suggest-hoogle-imports + nil + "Suggest to add import statements using Hoogle as a backend." + :type 'boolean + :group 'haskell-interactive) + +(defcustom haskell-process-suggest-hayoo-imports + nil + "Suggest to add import statements using Hayoo as a backend." + :type 'boolean + :group 'haskell-interactive) + +(defcustom haskell-process-hayoo-query-url + "http://hayoo.fh-wedel.de/json/?query=%s" + "Query url for json hayoo results." + :type 'string + :group 'haskell-interactive) + +(defcustom haskell-process-suggest-haskell-docs-imports + nil + "Suggest to add import statements using haskell-docs as a backend." + :type 'boolean + :group 'haskell-interactive) + +(defcustom haskell-process-suggest-add-package + t + "Suggest to add packages to your .cabal file when Cabal says it +is a member of the hidden package, blah blah." + :type 'boolean + :group 'haskell-interactive) + +(defcustom haskell-process-suggest-language-pragmas + t + "Suggest adding LANGUAGE pragmas recommended by GHC." + :type 'boolean + :group 'haskell-interactive) + +(defcustom haskell-process-suggest-remove-import-lines + nil + "Suggest removing import lines as warned by GHC." + :type 'boolean + :group 'haskell-interactive) + +(defcustom haskell-process-suggest-overloaded-strings + t + "Suggest adding OverloadedStrings pragma to file when getting type mismatches with [Char]." + :type 'boolean + :group 'haskell-interactive) + +(defcustom haskell-process-check-cabal-config-on-load + t + "Check changes cabal config on loading Haskell files and +restart the GHCi process if changed.." + :type 'boolean + :group 'haskell-interactive) + +(defcustom haskell-process-prompt-restart-on-cabal-change + t + "Ask whether to restart the GHCi process when the Cabal file +has changed?" + :type 'boolean + :group 'haskell-interactive) + +(defcustom haskell-process-auto-import-loaded-modules + nil + "Auto import the modules reported by GHC to have been loaded?" + :type 'boolean + :group 'haskell-interactive) + +(defcustom haskell-process-reload-with-fbytecode + nil + "When using -fobject-code, auto reload with -fbyte-code (and +then restore the -fobject-code) so that all module info and +imports become available?" + :type 'boolean + :group 'haskell-interactive) + +(defcustom haskell-process-use-presentation-mode + nil + "Use presentation mode to show things like type info instead of + printing to the message area." + :type 'boolean + :group 'haskell-interactive) + +(defcustom haskell-process-suggest-restart + t + "Suggest restarting the process when it has died" + :type 'boolean + :group 'haskell-interactive) + +(defcustom haskell-interactive-mode-scroll-to-bottom + nil + "Scroll to bottom in the REPL always." + :type 'boolean + :group 'haskell-interactive) + +(defcustom haskell-interactive-popup-errors + t + "Popup errors in a separate buffer." + :type 'boolean + :group 'haskell-interactive) + +(defcustom haskell-interactive-mode-collapse + nil + "Collapse printed results." + :type 'boolean + :group 'haskell-interactive) + +(defcustom haskell-interactive-types-for-show-ambiguous + t + "Show types when there's no Show instance or there's an +ambiguous class constraint." + :type 'boolean + :group 'haskell-interactive) + +(defcustom haskell-interactive-mode-eval-pretty + nil + "Print eval results that can be parsed as Show instances prettily. Requires sexp-show (on Hackage)." + :type 'boolean + :group 'haskell-interactive) + +(defvar haskell-interactive-prompt "λ> " + "The prompt to use.") + +(defcustom haskell-interactive-mode-eval-mode + nil + "Use the given mode's font-locking to render some text." + :type '(choice function (const :tag "None" nil)) + :group 'haskell-interactive) + +(defcustom haskell-interactive-mode-hide-multi-line-errors + nil + "Hide collapsible multi-line compile messages by default." + :type 'boolean + :group 'haskell-interactive) + +(defcustom haskell-interactive-mode-delete-superseded-errors + t + "Whether to delete compile messages superseded by recompile/reloads." + :type 'boolean + :group 'haskell-interactive) + +(defcustom haskell-interactive-mode-include-file-name + t + "Include the file name of the module being compiled when +printing compilation messages." + :type 'boolean + :group 'haskell-interactive) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Accessor functions + +(defun haskell-process-type () + "Return `haskell-process-type', or a guess if that variable is 'auto." + (if (eq 'auto haskell-process-type) + (if (locate-dominating-file + default-directory + (lambda (d) + (or (file-directory-p (expand-file-name ".cabal-sandbox" d)) + (cl-find-if (lambda (f) (string-match-p ".\\.cabal\\'" f)) (directory-files d))))) + 'cabal-repl + 'ghci) + haskell-process-type)) + +;;;###autoload +(defun haskell-customize () + "Browse the haskell customize sub-tree. +This calls 'customize-browse' with haskell as argument and makes +sure all haskell customize definitions have been loaded." + (interactive) + ;; make sure all modules with (defcustom ...)s are loaded + (mapc 'require + '(haskell-checkers haskell-compile haskell-doc haskell-font-lock haskell-indentation haskell-indent haskell-interactive-mode haskell-menu haskell-process haskell-yas inf-haskell)) + (customize-browse 'haskell)) + +(provide 'haskell-customize) diff --git a/haskell-debug.el b/haskell-debug.el index 71d3913ec..7beb96274 100644 --- a/haskell-debug.el +++ b/haskell-debug.el @@ -21,18 +21,10 @@ (require 'haskell-session) (require 'haskell-process) (require 'haskell-interactive-mode) +(require 'haskell-font-lock) -(defmacro haskell-debug-with-breakpoints (&rest body) - "Breakpoints need to exist to start stepping." - `(if (haskell-debug-get-breakpoints) - ,@body - (error "No breakpoints to step into!"))) - -(defmacro haskell-debug-with-modules (&rest body) - "Modules need to exist to do debugging stuff." - `(if (haskell-debug-get-modules) - ,@body - (error "No modules loaded!"))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Configuration (defgroup haskell-debug nil "Settings for debugging support." @@ -69,6 +61,9 @@ "Face for muteds." :group 'haskell-debug) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Mode + (define-derived-mode haskell-debug-mode text-mode "Debug" "Major mode for debugging Haskell via GHCi.") @@ -83,24 +78,135 @@ (define-key haskell-debug-mode-map (kbd "n") 'haskell-debug/next) (define-key haskell-debug-mode-map (kbd "RET") 'haskell-debug/select) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Globals + (defvar haskell-debug-history-cache nil "Cache of the tracing history.") (defvar haskell-debug-bindings-cache nil "Cache of the current step's bindings.") -(defun haskell-debug-session-debugging-p (session) - "Does the session have a debugging buffer open?" - (not (not (get-buffer (haskell-debug-buffer-name session))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Macros -(defun haskell-debug () - "Start the debugger for the current Haskell (GHCi) session." +(defmacro haskell-debug-with-breakpoints (&rest body) + "Breakpoints need to exist to start stepping." + `(if (haskell-debug-get-breakpoints) + ,@body + (error "No breakpoints to step into!"))) + +(defmacro haskell-debug-with-modules (&rest body) + "Modules need to exist to do debugging stuff." + `(if (haskell-debug-get-modules) + ,@body + (error "No modules loaded!"))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Interactive functions + +(defun haskell-debug/select () + "Select whatever is at point." (interactive) - (let ((session (haskell-session))) - (switch-to-buffer-other-window (haskell-debug-buffer-name session)) - (unless (eq major-mode 'haskell-debug-mode) - (haskell-debug-mode) - (haskell-debug-start session)))) + (cond + ((get-text-property (point) 'break) + (let ((break (get-text-property (point) 'break))) + (haskell-debug-highlight (plist-get break :path) + (plist-get break :span)))) + ((get-text-property (point) 'module) + (let ((break (get-text-property (point) 'module))) + (haskell-debug-highlight (plist-get break :path)))))) + +(defun haskell-debug/abandon () + "Abandon the current computation." + (interactive) + (haskell-debug-with-breakpoints + (haskell-process-queue-sync-request (haskell-debug-process) ":abandon") + (message "Computation abandoned.") + (setq haskell-debug-history-cache nil) + (setq haskell-debug-bindings-cache nil) + (haskell-debug/refresh))) + +(defun haskell-debug/continue () + "Continue the current computation." + (interactive) + (haskell-debug-with-breakpoints + (haskell-process-queue-sync-request (haskell-debug-process) ":continue") + (message "Computation continued.") + (setq haskell-debug-history-cache nil) + (setq haskell-debug-bindings-cache nil) + (haskell-debug/refresh))) + +(defun haskell-debug/break-on-function () + "Break on function IDENT." + (interactive) + (haskell-debug-with-modules + (let ((ident (read-from-minibuffer "Function: " + (haskell-ident-at-point)))) + (haskell-process-queue-sync-request + (haskell-debug-process) + (concat ":break " + ident)) + (message "Breaking on function: %s" ident) + (haskell-debug/refresh)))) + +(defun haskell-debug/start-step (expr) + "Start stepping EXPR." + (interactive (list (read-from-minibuffer "Expression to step through: "))) + (haskell-debug/step expr)) + +(defun haskell-debug/breakpoint-numbers () + "List breakpoint numbers." + (interactive) + (let ((breakpoints (mapcar (lambda (breakpoint) + (number-to-string (plist-get breakpoint :number))) + (haskell-debug-get-breakpoints)))) + (if (null breakpoints) + (message "No breakpoints.") + (message "Breakpoint(s): %s" + (mapconcat #'identity + breakpoints + ", "))))) + +(defun haskell-debug/next () + "Go to next step to inspect bindings." + (interactive) + (haskell-debug-with-breakpoints + (haskell-debug-navigate "forward"))) + +(defun haskell-debug/previous () + "Go to previous step to inspect the bindings." + (interactive) + (haskell-debug-with-breakpoints + (haskell-debug-navigate "back"))) + +(defun haskell-debug/refresh () + "Refresh the debugger buffer." + (interactive) + (with-current-buffer (haskell-debug-buffer-name (haskell-debug-session)) + (let ((inhibit-read-only t) + (p (point))) + (erase-buffer) + (insert (propertize (concat "Debugging " + (haskell-session-name (haskell-debug-session)) + "\n\n") + 'face `((:weight bold)))) + (let ((modules (haskell-debug-get-modules)) + (breakpoints (haskell-debug-get-breakpoints)) + (context (haskell-debug-get-context)) + (history (haskell-debug-get-history))) + (unless modules + (insert (propertize "You have to load a module to start debugging." + 'face + 'haskell-debug-warning-face) + "\n\n")) + (haskell-debug-insert-bindings modules breakpoints context) + (when modules + (haskell-debug-insert-current-context context history) + (haskell-debug-insert-breakpoints breakpoints)) + (haskell-debug-insert-modules modules)) + (insert "\n") + (goto-char (min (point-max) p))))) (defun haskell-debug/delete () "Delete whatever's at the point." @@ -111,7 +217,7 @@ (when (y-or-n-p (format "Delete breakpoint #%d?" (plist-get break :number))) (haskell-process-queue-sync-request - (haskell-process) + (haskell-debug-process) (format ":delete %d" (plist-get break :number))) (haskell-debug/refresh)))))) @@ -124,7 +230,7 @@ (context (haskell-debug-get-context)) (string (haskell-process-queue-sync-request - (haskell-process) + (haskell-debug-process) (if expr (concat ":step " expr) ":step")))) @@ -137,8 +243,8 @@ (t (let ((maybe-stopped-at (haskell-debug-parse-stopped-at string))) (cond (maybe-stopped-at - (set (make-local-variable 'haskell-debug-bindings-cache) - maybe-stopped-at) + (setq haskell-debug-bindings-cache + maybe-stopped-at) (message "Computation paused.") (haskell-debug/refresh)) (t @@ -146,58 +252,103 @@ (message "Computation finished.") (when (y-or-n-p "Computation completed without breaking. Reload the module and retry?") (message "Reloading and resetting breakpoints...") - (haskell-interactive-mode-reset-error (haskell-session)) + (haskell-interactive-mode-reset-error (haskell-debug-session)) (cl-loop for break in breakpoints - do (haskell-process-file-loadish - (concat "load " (plist-get break :path)) - nil - nil)) + do (haskell-process-queue-sync-request + (haskell-debug-process) + (concat ":load " (plist-get break :path)))) (cl-loop for break in breakpoints do (haskell-debug-break break)) (haskell-debug/step expr))))))))) (haskell-debug/refresh))) -(defun haskell-debug/start-step (expr) - "Start stepping EXPR." - (interactive (list (read-from-minibuffer "Expression to step through: "))) - (haskell-debug/step expr)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Internal functions -(defun haskell-debug/refresh () - "Refresh the debugger buffer." - (interactive) - (with-current-buffer (haskell-debug-buffer-name (haskell-session)) - (let ((inhibit-read-only t) - (p (point))) - (erase-buffer) - (insert (propertize (concat "Debugging " - (haskell-session-name (haskell-session)) - "\n\n") - 'face `((:weight bold)))) - (let ((modules (haskell-debug-get-modules)) - (breakpoints (haskell-debug-get-breakpoints)) - (context (haskell-debug-get-context)) - (history (haskell-debug-get-history))) - (unless modules - (insert (propertize "You have to load a module to start debugging." - 'face - 'haskell-debug-warning-face) - "\n\n")) - (haskell-debug-insert-bindings modules breakpoints context) - (when modules - (haskell-debug-insert-current-context context history) - (haskell-debug-insert-breakpoints breakpoints)) - (haskell-debug-insert-modules modules)) - (insert "\n") - (goto-char (min (point-max) p))))) +(defun haskell-debug-session () + "Get the Haskell session." + (or (haskell-session-maybe) + (error "No Haskell session associated with this debug + buffer. Please just close the buffer and start again."))) -(defun haskell-debug-break (break) - "Set BREAK breakpoint in module at line/col." - (haskell-process-queue-without-filters - (haskell-process) - (format ":break %s %s %d" - (plist-get break :module) - (plist-get (plist-get break :span) :start-line) - (plist-get (plist-get break :span) :start-col)))) +(defun haskell-debug-process () + "Get the Haskell session." + (or (haskell-session-process (haskell-session-maybe)) + (error "No Haskell session associated with this debug + buffer. Please just close the buffer and start again."))) + +(defun haskell-debug-buffer-name (session) + "The debug buffer name for the current session." + (format "*debug:%s*" + (haskell-session-name session))) + +(defun haskell-debug-get-breakpoints () + "Get the list of breakpoints currently set." + (let ((string (haskell-process-queue-sync-request + (haskell-debug-process) + ":show breaks"))) + (if (string= string "No active breakpoints.\n") + (list) + (mapcar #'haskell-debug-parse-break-point + (haskell-debug-split-string string))))) + +(defun haskell-debug-get-modules () + "Get the list of modules currently set." + (let ((string (haskell-process-queue-sync-request + (haskell-debug-process) + ":show modules"))) + (if (string= string "") + (list) + (mapcar #'haskell-debug-parse-module + (haskell-debug-split-string string))))) + +(defun haskell-debug-get-context () + "Get the current context." + (let ((string (haskell-process-queue-sync-request + (haskell-debug-process) + ":show context"))) + (if (string= string "") + nil + (haskell-debug-parse-context string)))) + +(defun haskell-debug-get-history () + "Get the step history." + (let ((string (haskell-process-queue-sync-request + (haskell-debug-process) + ":history"))) + (if (or (string= string "") + (string= string "Not stopped at a breakpoint\n")) + nil + (if (string= string "Empty history. Perhaps you forgot to use :trace?\n") + nil + (let ((entries (mapcar #'haskell-debug-parse-history-entry + (cl-remove-if (lambda (line) (or (string= "" line) + (string= "..." line))) + (haskell-debug-split-string string))))) + (setq haskell-debug-history-cache + entries) + entries))))) + +(defun haskell-debug-insert-bindings (modules breakpoints context) + "Insert a list of bindings." + (if breakpoints + (progn (haskell-debug-insert-binding "s" "step into an expression") + (haskell-debug-insert-binding "b" "breakpoint" t)) + (progn + (when modules + (haskell-debug-insert-binding "b" "breakpoint")) + (when breakpoints + (haskell-debug-insert-binding "s" "step into an expression" t)))) + (when breakpoints + (haskell-debug-insert-binding "d" "delete breakpoint")) + (when context + (haskell-debug-insert-binding "a" "abandon context") + (haskell-debug-insert-binding "c" "continue" t)) + (when context + (haskell-debug-insert-binding "p" "previous step") + (haskell-debug-insert-binding "n" "next step" t)) + (haskell-debug-insert-binding "g" "refresh" t) + (insert "\n")) (defun haskell-debug-insert-current-context (context history) "Insert the current context." @@ -207,28 +358,83 @@ (haskell-debug-insert-debug-finished)) (insert "\n")) -(defun haskell-debug-insert-debug-finished () - "Insert message that no debugging is happening, but if there is -some old history, then display that." - (if haskell-debug-history-cache - (progn (haskell-debug-insert-muted "Finished debugging.") - (insert "\n") - (haskell-debug-insert-history haskell-debug-history-cache)) - (haskell-debug-insert-muted "Not debugging right now."))) - -(defun haskell-debug-insert-context (context history) - "Insert the context and history." - (when context - (insert (propertize (plist-get context :name) 'face `((:weight bold))) - (haskell-debug-muted " - ") - (file-name-nondirectory (plist-get context :path)) - (haskell-debug-muted " (stopped)") - "\n")) - (when haskell-debug-bindings-cache - (insert "\n") - (let ((bindings haskell-debug-bindings-cache)) - (insert - (haskell-debug-get-span-string +(defun haskell-debug-insert-breakpoints (breakpoints) + "insert the list of breakpoints." + (haskell-debug-insert-header "breakpoints") + (if (null breakpoints) + (haskell-debug-insert-muted "no active breakpoints.") + (cl-loop for break in breakpoints + do (insert (propertize (format "%d" + (plist-get break :number)) + 'face `((:weight bold)) + 'break break) + (haskell-debug-muted " - ") + (propertize (plist-get break :module) + 'break break + 'break break) + (haskell-debug-muted + (format " (%d:%d)" + (plist-get (plist-get break :span) :start-line) + (plist-get (plist-get break :span) :start-col))) + "\n"))) + (insert "\n")) + +(defun haskell-debug-insert-modules (modules) + "Insert the list of modules." + (haskell-debug-insert-header "Modules") + (if (null modules) + (haskell-debug-insert-muted "No loaded modules.") + (progn (cl-loop for module in modules + do (insert (propertize (plist-get module :module) + 'module module + 'face `((:weight bold))) + (haskell-debug-muted " - ") + (propertize (file-name-nondirectory (plist-get module :path)) + 'module module)) + do (insert "\n"))))) + +(defun haskell-debug-split-string (string) + "Split GHCi's line-based output, stripping the trailing newline." + (split-string string "\n" t)) + +(defun haskell-debug-parse-context (string) + "Parse the context." + (cond + ((string-match "^--> \\(.+\\)\n \\(.+\\)" string) + (let ((name (match-string 1 string)) + (stopped (haskell-debug-parse-stopped-at (match-string 2 string)))) + (list :name name + :path (plist-get stopped :path) + :span (plist-get stopped :span)))))) + +(defun haskell-debug-insert-binding (binding desc &optional end) + "Insert a helpful keybinding." + (insert (propertize binding 'face 'haskell-debug-keybinding-face) + (haskell-debug-muted " - ") + desc + (if end + "\n" + (haskell-debug-muted ", ")))) + +(defun haskell-debug-insert-header (title) + "Insert a header title." + (insert (propertize title + 'face 'haskell-debug-heading-face) + "\n\n")) + +(defun haskell-debug-insert-context (context history) + "Insert the context and history." + (when context + (insert (propertize (plist-get context :name) 'face `((:weight bold))) + (haskell-debug-muted " - ") + (file-name-nondirectory (plist-get context :path)) + (haskell-debug-muted " (stopped)") + "\n")) + (when haskell-debug-bindings-cache + (insert "\n") + (let ((bindings haskell-debug-bindings-cache)) + (insert + (haskell-debug-get-span-string (plist-get bindings :path) (plist-get bindings :span))) (insert "\n\n") @@ -241,6 +447,86 @@ some old history, then display that." (insert "\n") (haskell-debug-insert-history history)))) +(defun haskell-debug-insert-debug-finished () + "Insert message that no debugging is happening, but if there is +some old history, then display that." + (if haskell-debug-history-cache + (progn (haskell-debug-insert-muted "Finished debugging.") + (insert "\n") + (haskell-debug-insert-history haskell-debug-history-cache)) + (haskell-debug-insert-muted "Not debugging right now."))) + +(defun haskell-debug-insert-muted (text) + "Insert some muted text." + (insert (haskell-debug-muted text) + "\n")) + +(defun haskell-debug-muted (text) + "Make some muted text." + (propertize text 'face 'haskell-debug-muted-face)) + +(defun haskell-debug-parse-logged (string) + "Parse the logged breakpoint." + (cond + ((string= "no more logged breakpoints\n" string) + nil) + ((string= "already at the beginning of the history\n" string) + nil) + (t + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (list :path (progn (search-forward " at ") + (buffer-substring-no-properties + (point) + (1- (search-forward ":")))) + :span (haskell-debug-parse-span + (buffer-substring-no-properties + (point) + (line-end-position))) + :types (progn (forward-line) + (haskell-debug-split-string + (buffer-substring-no-properties + (point) + (point-max))))))))) + +(defun haskell-debug-parse-stopped-at (string) + "Parse the location stopped at from the given string. + +For example: + +Stopped at /home/foo/project/src/x.hs:6:25-36 + +" + (let ((index (string-match "Stopped at \\([^:]+\\):\\(.+\\)\n?" + string))) + (when index + (list :path (match-string 1 string) + :span (haskell-debug-parse-span (match-string 2 string)) + :types (cdr (haskell-debug-split-string (substring string index))))))) + +(defun haskell-debug-get-span-string (path span) + "Get the string from the PATH and the SPAN." + (save-window-excursion + (find-file path) + (buffer-substring + (save-excursion + (goto-char (point-min)) + (forward-line (1- (plist-get span :start-line))) + (forward-char (1- (plist-get span :start-col))) + (point)) + (save-excursion + (goto-char (point-min)) + (forward-line (1- (plist-get span :end-line))) + (forward-char (plist-get span :end-col)) + (point))))) + +(defun haskell-debug-make-fake-history (context) + "Make a fake history item." + (list :index -1 + :path (plist-get context :path) + :span (plist-get context :span))) + (defun haskell-debug-insert-history (history) "Insert tracing HISTORY." (let ((i (length history))) @@ -259,11 +545,38 @@ some old history, then display that." "\n") (setq i (1- i)))))) -(defun haskell-debug-make-fake-history (context) - "Make a fake history item." - (list :index -1 - :path (plist-get context :path) - :span (plist-get context :span))) +(defun haskell-debug-parse-span (string) + "Parse a source span from a string. + +Examples: + + (5,1)-(6,37) + 6:25-36 + 5:20 + +People like to make other people's lives interesting by making +variances in source span notation." + (cond + ((string-match "\\([0-9]+\\):\\([0-9]+\\)-\\([0-9]+\\)" + string) + (list :start-line (string-to-number (match-string 1 string)) + :start-col (string-to-number (match-string 2 string)) + :end-line (string-to-number (match-string 1 string)) + :end-col (string-to-number (match-string 3 string)))) + ((string-match "\\([0-9]+\\):\\([0-9]+\\)" + string) + (list :start-line (string-to-number (match-string 1 string)) + :start-col (string-to-number (match-string 2 string)) + :end-line (string-to-number (match-string 1 string)) + :end-col (string-to-number (match-string 2 string)))) + ((string-match "(\\([0-9]+\\),\\([0-9]+\\))-(\\([0-9]+\\),\\([0-9]+\\))" + string) + (list :start-line (string-to-number (match-string 1 string)) + :start-col (string-to-number (match-string 2 string)) + :end-line (string-to-number (match-string 3 string)) + :end-col (string-to-number (match-string 4 string)))) + (t (error "Unable to parse source span from string: %s" + string)))) (defun haskell-debug-preview-span (span string &optional collapsed) "Make a one-line preview of the given expression." @@ -290,121 +603,45 @@ some old history, then display that." (point-max))) (buffer-string)))) -(defun haskell-debug-get-span-string (path span) - "Get the string from the PATH and the SPAN." - (save-window-excursion - (find-file path) - (buffer-substring - (save-excursion - (goto-char (point-min)) - (forward-line (1- (plist-get span :start-line))) - (forward-char (1- (plist-get span :start-col))) - (point)) - (save-excursion - (goto-char (point-min)) - (forward-line (1- (plist-get span :end-line))) - (forward-char (plist-get span :end-col)) - (point))))) - -(defun haskell-debug-insert-bindings (modules breakpoints context) - "Insert a list of bindings." - (if breakpoints - (progn (haskell-debug-insert-binding "s" "step into an expression") - (haskell-debug-insert-binding "b" "breakpoint" t)) - (progn - (when modules - (haskell-debug-insert-binding "b" "breakpoint")) - (when breakpoints - (haskell-debug-insert-binding "s" "step into an expression" t)))) - (when breakpoints - (haskell-debug-insert-binding "d" "delete breakpoint")) - (when context - (haskell-debug-insert-binding "a" "abandon context") - (haskell-debug-insert-binding "c" "continue" t)) - (when context - (haskell-debug-insert-binding "p" "previous step") - (haskell-debug-insert-binding "n" "next step" t)) - (haskell-debug-insert-binding "g" "refresh" t) - (insert "\n")) - -(defun haskell-debug-insert-binding (binding desc &optional end) - "Insert a helpful keybinding." - (insert (propertize binding 'face 'haskell-debug-keybinding-face) - (haskell-debug-muted " - ") - desc - (if end - "\n" - (haskell-debug-muted ", ")))) - -(defun haskell-debug/breakpoint-numbers () - "List breakpoint numbers." - (interactive) - (let ((breakpoints (mapcar (lambda (breakpoint) - (number-to-string (plist-get breakpoint :number))) - (haskell-debug-get-breakpoints)))) - (if (null breakpoints) - (message "No breakpoints.") - (message "Breakpoint(s): %s" - (mapconcat #'identity - breakpoints - ", "))))) - -(defun haskell-debug/abandon () - "Abandon the current computation." - (interactive) - (haskell-debug-with-breakpoints - (haskell-process-queue-sync-request (haskell-process) ":abandon") - (message "Computation abandoned.") - (setq haskell-debug-history-cache nil) - (setq haskell-debug-bindings-cache nil) - (haskell-debug/refresh))) - -(defun haskell-debug/continue () - "Continue the current computation." - (interactive) - (haskell-debug-with-breakpoints - (haskell-process-queue-sync-request (haskell-process) ":continue") - (message "Computation continued.") - (setq haskell-debug-history-cache nil) - (setq haskell-debug-bindings-cache nil) - (haskell-debug/refresh))) +(defun haskell-debug-start (session) + "Start the debug mode." + (setq buffer-read-only t) + (haskell-session-assign session) + (haskell-debug/refresh)) -(defun haskell-debug/break-on-function () - "Break on function IDENT." +(defun haskell-debug () + "Start the debugger for the current Haskell (GHCi) session." (interactive) - (haskell-debug-with-modules - (let ((ident (read-from-minibuffer "Function: " - (haskell-ident-at-point)))) - (haskell-process-queue-sync-request - (haskell-process) - (concat ":break " - ident)) - (message "Breaking on function: %s" ident) - (haskell-debug/refresh)))) + (let ((session (haskell-debug-session))) + (switch-to-buffer-other-window (haskell-debug-buffer-name session)) + (unless (eq major-mode 'haskell-debug-mode) + (haskell-debug-mode) + (haskell-debug-start session)))) -(defun haskell-debug/select () - "Select whatever is at point." - (interactive) - (cond - ((get-text-property (point) 'break) - (let ((break (get-text-property (point) 'break))) - (haskell-debug-highlight (plist-get break :path) - (plist-get break :span)))) - ((get-text-property (point) 'module) - (let ((break (get-text-property (point) 'module))) - (haskell-debug-highlight (plist-get break :path)))))) +(defun haskell-debug-break (break) + "Set BREAK breakpoint in module at line/col." + (haskell-process-queue-without-filters + (haskell-debug-process) + (format ":break %s %s %d" + (plist-get break :module) + (plist-get (plist-get break :span) :start-line) + (plist-get (plist-get break :span) :start-col)))) -(defun haskell-debug/next () - "Go to next step to inspect bindings." - (interactive) - (haskell-debug-with-breakpoints - (haskell-debug-navigate "forward"))) +(defun haskell-debug-navigate (direction) + "Navigate in DIRECTION \"back\" or \"forward\"." + (let ((string (haskell-process-queue-sync-request + (haskell-debug-process) + (concat ":" direction)))) + (let ((bindings (haskell-debug-parse-logged string))) + (setq haskell-debug-bindings-cache + bindings) + (when (not bindings) + (message "No more %s results!" direction))) + (haskell-debug/refresh))) -(defun haskell-debug/previous () - "Go to previous step to inspect the bindings." - (interactive) - (haskell-debug-with-breakpoints - (haskell-debug-navigate "back"))) +(defun haskell-debug-session-debugging-p (session) + "Does the session have a debugging buffer open?" + (not (not (get-buffer (haskell-debug-buffer-name session))))) (defun haskell-debug-highlight (path &optional span) "Highlight the file at span." @@ -438,145 +675,6 @@ some old history, then display that." (delete-overlay o)) (delete-overlay p))))) -(defun haskell-debug-insert-modules (modules) - "Insert the list of modules." - (haskell-debug-insert-header "Modules") - (if (null modules) - (haskell-debug-insert-muted "No loaded modules.") - (progn (cl-loop for module in modules - do (insert (propertize (plist-get module :module) - 'module module - 'face `((:weight bold))) - (haskell-debug-muted " - ") - (propertize (file-name-nondirectory (plist-get module :path)) - 'module module)) - do (insert "\n"))))) - -(defun haskell-debug-insert-header (title) - "Insert a header title." - (insert (propertize title - 'face 'haskell-debug-heading-face) - "\n\n")) - -(defun haskell-debug-insert-breakpoints (breakpoints) - "Insert the list of breakpoints." - (haskell-debug-insert-header "Breakpoints") - (if (null breakpoints) - (haskell-debug-insert-muted "No active breakpoints.") - (cl-loop for break in breakpoints - do (insert (propertize (format "%d" - (plist-get break :number)) - 'face `((:weight bold)) - 'break break) - (haskell-debug-muted " - ") - (propertize (plist-get break :module) - 'break break - 'break break) - (haskell-debug-muted - (format " (%d:%d)" - (plist-get (plist-get break :span) :start-line) - (plist-get (plist-get break :span) :start-col))) - "\n"))) - (insert "\n")) - -(defun haskell-debug-insert-muted (text) - "Insert some muted text." - (insert (haskell-debug-muted text) - "\n")) - -(defun haskell-debug-muted (text) - "Make some muted text." - (propertize text 'face 'haskell-debug-muted-face)) - -(defun haskell-debug-buffer-name (session) - "The debug buffer name for the current session." - (format "*debug:%s*" - (haskell-session-name session))) - -(defun haskell-debug-start (session) - "Start the debug mode." - (setq buffer-read-only t) - (haskell-session-assign session) - (haskell-debug/refresh)) - -(defun haskell-debug-split-string (string) - "Split GHCi's line-based output, stripping the trailing newline." - (split-string string "\n" t)) - -(defun haskell-debug-get-modules () - "Get the list of modules currently set." - (let ((string (haskell-process-queue-sync-request - (haskell-process) - ":show modules"))) - (if (string= string "") - (list) - (mapcar #'haskell-debug-parse-module - (haskell-debug-split-string string))))) - -(defun haskell-debug-get-context () - "Get the current context." - (let ((string (haskell-process-queue-sync-request - (haskell-process) - ":show context"))) - (if (string= string "") - nil - (haskell-debug-parse-context string)))) - -(defun haskell-debug-navigate (direction) - "Navigate in DIRECTION \"back\" or \"forward\"." - (let ((string (haskell-process-queue-sync-request - (haskell-process) - (concat ":" direction)))) - (let ((bindings (haskell-debug-parse-logged string))) - (set (make-local-variable 'haskell-debug-bindings-cache) - bindings) - (when (not bindings) - (message "No more %s results!" direction))) - (haskell-debug/refresh))) - -(defun haskell-debug-parse-logged (string) - "Parse the logged breakpoint." - (cond - ((string= "no more logged breakpoints\n" string) - nil) - ((string= "already at the beginning of the history\n" string) - nil) - (t - (with-temp-buffer - (insert string) - (goto-char (point-min)) - (list :path (progn (search-forward " at ") - (buffer-substring-no-properties - (point) - (1- (search-forward ":")))) - :span (haskell-debug-parse-span - (buffer-substring-no-properties - (point) - (line-end-position))) - :types (progn (forward-line) - (haskell-debug-split-string - (buffer-substring-no-properties - (point) - (point-max))))))))) - -(defun haskell-debug-get-history () - "Get the step history." - (let ((string (haskell-process-queue-sync-request - (haskell-process) - ":history"))) - (if (or (string= string "") - (string= string "Not stopped at a breakpoint\n")) - nil - (if (string= string "Empty history. Perhaps you forgot to use :trace?\n") - nil - (let ((entries (mapcar #'haskell-debug-parse-history-entry - (cl-remove-if (lambda (line) (or (string= "" line) - (string= "..." line))) - (haskell-debug-split-string string))))) - (set (make-local-variable 'haskell-debug-history-cache) - entries) - entries))))) - (defun haskell-debug-parse-history-entry (string) "Parse a history entry." (if (string-match "^\\([-0-9]+\\)[ ]+:[ ]+\\([A-Za-z0-9_':]+\\)[ ]+(\\([^:]+\\):\\(.+?\\))$" @@ -587,41 +685,6 @@ some old history, then display that." :span (haskell-debug-parse-span (match-string 4 string))) (error "Unable to parse history entry: %s" string))) -(defun haskell-debug-parse-context (string) - "Parse the context." - (cond - ((string-match "^--> \\(.+\\)\n \\(.+\\)" string) - (let ((name (match-string 1 string)) - (stopped (haskell-debug-parse-stopped-at (match-string 2 string)))) - (list :name name - :path (plist-get stopped :path) - :span (plist-get stopped :span)))))) - -(defun haskell-debug-get-breakpoints () - "Get the list of breakpoints currently set." - (let ((string (haskell-process-queue-sync-request - (haskell-process) - ":show breaks"))) - (if (string= string "No active breakpoints.\n") - (list) - (mapcar #'haskell-debug-parse-break-point - (haskell-debug-split-string string))))) - -(defun haskell-debug-parse-stopped-at (string) - "Parse the location stopped at from the given string. - -For example: - -Stopped at /home/foo/project/src/x.hs:6:25-36 - -" - (let ((index (string-match "Stopped at \\([^:]+\\):\\(.+\\)\n?" - string))) - (when index - (list :path (match-string 1 string) - :span (haskell-debug-parse-span (match-string 2 string)) - :types (cdr (haskell-debug-split-string (substring string index))))))) - (defun haskell-debug-parse-module (string) "Parse a module and path. @@ -654,38 +717,6 @@ For example: (error "Unable to parse breakpoint from string: %s" string))) -(defun haskell-debug-parse-span (string) - "Parse a source span from a string. - -Examples: - - (5,1)-(6,37) - 6:25-36 - 5:20 - -People like to make other people's lives interesting by making -variances in source span notation." - (cond - ((string-match "\\([0-9]+\\):\\([0-9]+\\)-\\([0-9]+\\)" - string) - (list :start-line (string-to-number (match-string 1 string)) - :start-col (string-to-number (match-string 2 string)) - :end-line (string-to-number (match-string 1 string)) - :end-col (string-to-number (match-string 3 string)))) - ((string-match "\\([0-9]+\\):\\([0-9]+\\)" - string) - (list :start-line (string-to-number (match-string 1 string)) - :start-col (string-to-number (match-string 2 string)) - :end-line (string-to-number (match-string 1 string)) - :end-col (string-to-number (match-string 2 string)))) - ((string-match "(\\([0-9]+\\),\\([0-9]+\\))-(\\([0-9]+\\),\\([0-9]+\\))" - string) - (list :start-line (string-to-number (match-string 1 string)) - :start-col (string-to-number (match-string 2 string)) - :end-line (string-to-number (match-string 3 string)) - :end-col (string-to-number (match-string 4 string)))) - (t (error "Unable to parse source span from string: %s" - string)))) - (provide 'haskell-debug) + ;;; haskell-debug.el ends here diff --git a/haskell-font-lock.el b/haskell-font-lock.el index c4afaf7d8..c6ce110bb 100644 --- a/haskell-font-lock.el +++ b/haskell-font-lock.el @@ -693,6 +693,16 @@ Invokes `haskell-font-lock-hook' if not nil." "Turns off font locking in current buffer." (font-lock-mode -1)) +(defun haskell-fontify-as-mode (text mode) + "Fontify TEXT as MODE, returning the fontified text." + (with-temp-buffer + (funcall mode) + (insert text) + (if (fboundp 'font-lock-ensure) + (font-lock-ensure) + (with-no-warnings (font-lock-fontify-buffer))) + (buffer-substring (point-min) (point-max)))) + ;; Provide ourselves: (provide 'haskell-font-lock) diff --git a/haskell-interactive-mode.el b/haskell-interactive-mode.el index fff690665..6e9225fac 100644 --- a/haskell-interactive-mode.el +++ b/haskell-interactive-mode.el @@ -27,46 +27,32 @@ ;;; Code: -(require 'ansi-color) -(require 'cl-lib) +(require 'haskell-compile) +(require 'haskell-navigate-imports) (require 'haskell-process) (require 'haskell-collapse) (require 'haskell-session) (require 'haskell-show) +(require 'haskell-font-lock) +(require 'haskell-presentation-mode) -(defcustom haskell-interactive-mode-scroll-to-bottom - nil - "Scroll to bottom in the REPL always." - :type 'boolean - :group 'haskell-interactive) +(require 'ansi-color) +(require 'cl-lib) +(require 'etags) -(defcustom haskell-interactive-popup-errors - t - "Popup errors in a separate buffer." - :type 'boolean - :group 'haskell-interactive) +(defvar haskell-interactive-mode-history-index) +(make-variable-buffer-local 'haskell-interactive-mode-history-index) -(defcustom haskell-interactive-mode-collapse - nil - "Collapse printed results." - :type 'boolean - :group 'haskell-interactive) +(defvar haskell-interactive-mode-history (list)) +(make-variable-buffer-local 'haskell-interactive-mode-history) -(defcustom haskell-interactive-types-for-show-ambiguous - t - "Show types when there's no Show instance or there's an -ambiguous class constraint." - :type 'boolean - :group 'haskell-interactive) +(defvar haskell-interactive-mode-completion-cache) +(make-variable-buffer-local 'haskell-interactive-mode-completion-cache) -(defcustom haskell-interactive-mode-eval-pretty +(defvar haskell-interactive-mode-old-prompt-start nil - "Print eval results that can be parsed as Show instances prettily. Requires sexp-show (on Hackage)." - :type 'boolean - :group 'haskell-interactive) - -(defvar haskell-interactive-prompt "λ> " - "The prompt to use.") + "Mark used for the old beginning of the prompt.") +(make-variable-buffer-local 'haskell-interactive-mode-old-prompt-start) (defun haskell-interactive-prompt-regex () "Generate a regex for searching for any occurence of the prompt @@ -74,43 +60,8 @@ at the beginning of the line. This should prevent any interference with prompts that look like haskell expressions." (concat "^" (regexp-quote haskell-interactive-prompt))) -(defvar haskell-interactive-mode-prompt-start - nil - "Mark used for the beginning of the prompt.") - -(defvar haskell-interactive-mode-result-end - nil - "Mark used to figure out where the end of the current result - output is. Used to distinguish betwen user input.") - -(defvar haskell-interactive-mode-old-prompt-start - nil - "Mark used for the old beginning of the prompt.") - -(defcustom haskell-interactive-mode-eval-mode - nil - "Use the given mode's font-locking to render some text." - :type '(choice function (const :tag "None" nil)) - :group 'haskell-interactive) - -(defcustom haskell-interactive-mode-hide-multi-line-errors - nil - "Hide collapsible multi-line compile messages by default." - :type 'boolean - :group 'haskell-interactive) - -(defcustom haskell-interactive-mode-delete-superseded-errors - t - "Whether to delete compile messages superseded by recompile/reloads." - :type 'boolean - :group 'haskell-interactive) - -(defcustom haskell-interactive-mode-include-file-name - t - "Include the file name of the module being compiled when -printing compilation messages." - :type 'boolean - :group 'haskell-interactive) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Globals used internally (defvar haskell-interactive-mode-map (let ((map (make-sparse-keymap))) @@ -132,12 +83,6 @@ printing compilation messages." map) "Interactive Haskell mode map.") -;; buffer-local variables used internally by `haskell-interactive-mode' -(defvar haskell-interactive-mode-history) -(defvar haskell-interactive-mode-history-index) -(defvar haskell-interactive-mode-completion-cache) - -;;;###autoload (define-derived-mode haskell-interactive-mode fundamental-mode "Interactive-Haskell" "Interactive mode for Haskell. @@ -147,9 +92,9 @@ information. Key bindings: \\{haskell-interactive-mode-map}" :group 'haskell-interactive - (set (make-local-variable 'haskell-interactive-mode-history) (list)) - (set (make-local-variable 'haskell-interactive-mode-history-index) 0) - (set (make-local-variable 'haskell-interactive-mode-completion-cache) nil) + (setq haskell-interactive-mode-history (list)) + (setq haskell-interactive-mode-history-index 0) + (setq haskell-interactive-mode-completion-cache nil) (setq next-error-function 'haskell-interactive-next-error-function) (add-hook 'completion-at-point-functions @@ -157,6 +102,33 @@ Key bindings: (haskell-interactive-mode-prompt)) +(defvar haskell-interactive-mode-prompt-start + nil + "Mark used for the beginning of the prompt.") + +(defvar haskell-interactive-mode-result-end + nil + "Mark used to figure out where the end of the current result + output is. Used to distinguish betwen user input.") + +(defvar haskell-interactive-previous-buffer nil + "Records the buffer to which `haskell-interactive-switch-back' should jump. +This is set by `haskell-interactive-switch', and should otherwise +be nil.") +(make-variable-buffer-local 'haskell-interactive-previous-buffer) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Hooks + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Mode + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Faces + (defface haskell-interactive-face-prompt '((t :inherit font-lock-function-name-face)) "Face for the prompt." @@ -182,6 +154,9 @@ Key bindings: "Face for trailing garbage after a command has completed." :group 'haskell-interactive) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Actions + (defun haskell-interactive-mode-newline-indent () "Make newline and indent." (interactive) @@ -194,36 +169,6 @@ Key bindings: (kill-region haskell-interactive-mode-prompt-start (line-end-position))) -;;;###autoload -(defun haskell-interactive-bring () - "Bring up the interactive mode for this session." - (interactive) - (let* ((session (haskell-session)) - (buffer (haskell-session-interactive-buffer session))) - (unless (and (cl-find-if (lambda (window) (equal (window-buffer window) buffer)) - (window-list)) - (= 2 (length (window-list)))) - (delete-other-windows) - (display-buffer buffer) - (other-window 1)))) - -(defvar haskell-interactive-previous-buffer nil - "Records the buffer to which `haskell-interactive-switch-back' should jump. -This is set by `haskell-interactive-switch', and should otherwise -be nil.") -(make-variable-buffer-local 'haskell-interactive-previous-buffer) - -;;;###autoload -(defun haskell-interactive-switch () - "Switch to the interactive mode for this session." - (interactive) - (let ((initial-buffer (current-buffer)) - (buffer (haskell-session-interactive-buffer (haskell-session)))) - (with-current-buffer buffer - (setq haskell-interactive-previous-buffer initial-buffer)) - (unless (eq buffer (window-buffer)) - (switch-to-buffer-other-window buffer)))) - (defun haskell-interactive-switch-back () "Switch back to the buffer from which this interactive buffer was reached." (interactive) @@ -231,15 +176,6 @@ be nil.") (switch-to-buffer-other-window haskell-interactive-previous-buffer) (message "No previous buffer."))) -(defun haskell-interactive-mode-return () - "Handle the return key." - (interactive) - (cond - ((haskell-interactive-at-compile-message) - (next-error-internal)) - (t - (haskell-interactive-handle-expr)))) - (defun haskell-interactive-mode-space (n) "Handle the space key." (interactive "p") @@ -257,156 +193,12 @@ be nil.") haskell-interactive-mode-prompt-start nil)) -(defun haskell-interactive-handle-expr () - "Handle an inputted expression at the REPL." - (when (haskell-interactive-at-prompt) - (let ((expr (haskell-interactive-mode-input))) - (unless (string= "" (replace-regexp-in-string " " "" expr)) - (cond - ;; If already evaluating, then the user is trying to send - ;; input to the REPL during evaluation. Most likely in - ;; response to a getLine-like function. - ((and (haskell-process-evaluating-p (haskell-process)) - (= (line-end-position) (point-max))) - (goto-char (point-max)) - (let ((process (haskell-process)) - (string (buffer-substring-no-properties - haskell-interactive-mode-result-end - (point)))) - (insert "\n") - ;; Bring the marker forward - (setq haskell-interactive-mode-result-end - (point-max)) - (haskell-process-set-sent-stdin process t) - (haskell-process-send-string process string))) - ;; Otherwise we start a normal evaluation call. - (t (setq haskell-interactive-mode-old-prompt-start - (copy-marker haskell-interactive-mode-prompt-start)) - (set-marker haskell-interactive-mode-prompt-start (point-max)) - (haskell-interactive-mode-history-add expr) - (haskell-interactive-mode-do-expr expr))))))) - -(defun haskell-interactive-mode-do-expr (expr) - (cond - ((string-match "^:present " expr) - (haskell-interactive-mode-do-presentation (replace-regexp-in-string "^:present " "" expr))) - (t - (haskell-interactive-mode-run-expr expr)))) - -(defun haskell-interactive-mode-run-expr (expr) - "Run the given expression." - (let ((session (haskell-session)) - (process (haskell-process)) - (lines (length (split-string expr "\n")))) - (haskell-process-queue-command - process - (make-haskell-command - :state (list session process expr 0) - :go (lambda (state) - (goto-char (point-max)) - (insert "\n") - (setq haskell-interactive-mode-result-end - (point-max)) - (haskell-process-send-string (cadr state) - (haskell-interactive-mode-multi-line (cl-caddr state))) - (haskell-process-set-evaluating (cadr state) t)) - :live (lambda (state buffer) - (unless (and (string-prefix-p ":q" (cl-caddr state)) - (string-prefix-p (cl-caddr state) ":quit")) - (let* ((cursor (cl-cadddr state)) - (next (replace-regexp-in-string - haskell-process-prompt-regex - "" - (substring buffer cursor)))) - (haskell-interactive-mode-eval-result (car state) next) - (setf (cl-cdddr state) (list (length buffer))) - nil))) - :complete - (lambda (state response) - (haskell-process-set-evaluating (cadr state) nil) - (unless (haskell-interactive-mode-trigger-compile-error state response) - (haskell-interactive-mode-expr-result state response))))))) - -(defun haskell-interactive-mode-trigger-compile-error (state response) - "Look for an compile error; if there is one, pop - that up in a buffer, similar to `debug-on-error'." - (when (and haskell-interactive-types-for-show-ambiguous - (string-match "^\n:[0-9]+:[0-9]+:" response) - (not (string-match "^\n:[0-9]+:[0-9]+:[\n ]+Warning:" response))) - (let ((inhibit-read-only t)) - (delete-region haskell-interactive-mode-prompt-start (point)) - (set-marker haskell-interactive-mode-prompt-start - haskell-interactive-mode-old-prompt-start) - (goto-char (point-max))) - (cond - ((and (not (haskell-interactive-mode-line-is-query (elt state 2))) - (or (string-match "No instance for (?Show[ \n]" response) - (string-match "Ambiguous type variable " response))) - (haskell-process-reset (haskell-process)) - (let ((resp (haskell-process-queue-sync-request - (haskell-process) - (concat ":t " - (buffer-substring-no-properties - haskell-interactive-mode-prompt-start - (point-max)))))) - (cond - ((not (string-match ":" resp)) - (haskell-interactive-mode-insert-error resp)) - (t (haskell-interactive-popup-error response))))) - (t (haskell-interactive-popup-error response) - t)) - t)) - -(defun haskell-interactive-popup-error (response) - "Popup an error." - (if haskell-interactive-popup-errors - (let ((buf (get-buffer-create "*HS-Error*"))) - (pop-to-buffer buf nil t) - (with-current-buffer buf - - (haskell-error-mode) - (let ((inhibit-read-only t)) - (erase-buffer) - (insert (propertize response - 'font-lock-face - 'haskell-interactive-face-compile-error)) - (goto-char (point-min)) - (delete-blank-lines) - (insert (propertize "-- Hit `q' to close this window.\n\n" - 'font-lock-face 'font-lock-comment-face)) - (save-excursion - (goto-char (point-max)) - (insert (propertize "\n-- To disable popups, customize `haskell-interactive-popup-errors'.\n\n" - 'font-lock-face 'font-lock-comment-face)))))) - (haskell-interactive-mode-insert-error response))) - -(defun haskell-interactive-mode-insert-error (response) - "Insert an error message." - (insert "\n" - (haskell-fontify-as-mode - response - 'haskell-mode)) - (haskell-interactive-mode-prompt)) - (define-derived-mode haskell-error-mode special-mode "Error" "Major mode for viewing Haskell compile errors.") ;; (define-key haskell-error-mode-map (kbd "q") 'quit-window) -(defun haskell-interactive-mode-expr-result (state response) - "Print the result of evaluating the expression." - (let ((response - (with-temp-buffer - (insert (haskell-interactive-mode-cleanup-response - (cl-caddr state) response)) - (haskell-interactive-mode-handle-h (point-min)) - (buffer-string)))) - (when haskell-interactive-mode-eval-mode - (unless (haskell-process-sent-stdin-p (cadr state)) - (haskell-interactive-mode-eval-as-mode (car state) response)))) - (haskell-interactive-mode-prompt (car state))) - (defun haskell-interactive-mode-handle-h (&optional bound) "Handle ^H in output." (let ((bound (point-min)) @@ -481,33 +273,6 @@ do the (and (string-match "^:[itk] " line) t)) -(defun haskell-interactive-jump-to-error-line () - "Jump to the error line." - (let ((orig-line (buffer-substring-no-properties (line-beginning-position) - (line-end-position)))) - (and (string-match "^\\([^:]+\\):\\([0-9]+\\):\\([0-9]+\\)\\(-[0-9]+\\)?:" orig-line) - (let* ((file (match-string 1 orig-line)) - (line (match-string 2 orig-line)) - (col (match-string 3 orig-line)) - (session (haskell-session)) - (cabal-path (haskell-session-cabal-dir session)) - (src-path (haskell-session-current-dir session)) - (cabal-relative-file (expand-file-name file cabal-path)) - (src-relative-file (expand-file-name file src-path))) - (let ((file (cond ((file-exists-p cabal-relative-file) - cabal-relative-file) - ((file-exists-p src-relative-file) - src-relative-file)))) - (when file - (other-window 1) - (find-file file) - (haskell-interactive-bring) - (goto-char (point-min)) - (forward-line (1- (string-to-number line))) - (goto-char (+ (point) (string-to-number col) -1)) - (haskell-mode-message-line orig-line) - t)))))) - (defun haskell-interactive-mode-beginning () "Go to the start of the line." (interactive) @@ -515,22 +280,6 @@ do the (goto-char haskell-interactive-mode-prompt-start) (move-beginning-of-line nil))) -(defun haskell-interactive-mode-clear () - "Clear the screen and put any current input into the history." - (interactive) - (let ((session (haskell-session))) - (with-current-buffer (haskell-session-interactive-buffer session) - (let ((inhibit-read-only t)) - (set-text-properties (point-min) (point-max) nil)) - (delete-region (point-min) (point-max)) - (remove-overlays) - (haskell-interactive-mode-prompt session) - (haskell-session-set session 'next-error-region nil) - (haskell-session-set session 'next-error-locus nil)) - (with-current-buffer (get-buffer-create "*haskell-process-log*") - (delete-region (point-min) (point-max)) - (remove-overlays)))) - (defun haskell-interactive-mode-input-partial () "Get the interactive mode input up to point." (let ((input-start (haskell-interactive-at-prompt))) @@ -598,32 +347,6 @@ SESSION, otherwise operate on the current buffer. (goto-char (point-max)) (set-window-point w (point-max))))) -(defun haskell-interactive-mode-eval-as-mode (session text) - "Insert TEXT font-locked according to `haskell-interactive-mode-eval-mode'." - (with-current-buffer (haskell-session-interactive-buffer session) - (let ((inhibit-read-only t)) - (delete-region (1+ haskell-interactive-mode-prompt-start) (point)) - (goto-char (point-max)) - (let ((start (point))) - (insert (haskell-fontify-as-mode text - haskell-interactive-mode-eval-mode)) - (when haskell-interactive-mode-collapse - (haskell-collapse start (point))))))) - -;;;###autoload -(defun haskell-interactive-mode-echo (session message &optional mode) - "Echo a read only piece of text before the prompt." - (with-current-buffer (haskell-session-interactive-buffer session) - (save-excursion - (haskell-interactive-mode-goto-end-point) - (insert (if mode - (haskell-fontify-as-mode - (concat message "\n") - mode) - (propertize (concat message "\n") - 'read-only t - 'rear-nonsticky t)))))) - (defun haskell-interactive-mode-compile-error (session message) "Echo an error." (haskell-interactive-mode-compile-message @@ -660,25 +383,6 @@ SESSION, otherwise operate on the current buffer. 'read-only t 'rear-nonsticky t))))))) -(defun haskell-interactive-mode-compile-splice (session message) - "Echo a compiler splice." - (with-current-buffer (haskell-session-interactive-buffer session) - (setq next-error-last-buffer (current-buffer)) - (save-excursion - (haskell-interactive-mode-goto-end-point) - (insert (haskell-fontify-as-mode message 'haskell-mode) - "\n")))) - -(defun haskell-interactive-mode-insert-garbage (session message) - "Echo a read only piece of text before the prompt." - (with-current-buffer (haskell-session-interactive-buffer session) - (save-excursion - (haskell-interactive-mode-goto-end-point) - (insert (propertize message - 'font-lock-face 'haskell-interactive-face-garbage - 'read-only t - 'rear-nonsticky t))))) - (defun haskell-interactive-mode-insert (session message) "Echo a read only piece of text before the prompt." (with-current-buffer (haskell-session-interactive-buffer session) @@ -703,93 +407,28 @@ SESSION, otherwise operate on the current buffer. (setq haskell-interactive-mode-history-index 0)) -(defun haskell-interactive-mode-history-toggle (n) - "Toggle the history n items up or down." - (unless (null haskell-interactive-mode-history) - (setq haskell-interactive-mode-history-index - (mod (+ haskell-interactive-mode-history-index n) - (length haskell-interactive-mode-history))) - (unless (zerop haskell-interactive-mode-history-index) - (message "History item: %d" haskell-interactive-mode-history-index)) - (haskell-interactive-mode-set-prompt - (nth haskell-interactive-mode-history-index - haskell-interactive-mode-history)))) - -(defun haskell-interactive-mode-history-previous (arg) - "Cycle backwards through input history." - (interactive "*p") - (when (haskell-interactive-at-prompt) - (if (not (zerop arg)) - (haskell-interactive-mode-history-toggle arg) - (setq haskell-interactive-mode-history-index 0) - (haskell-interactive-mode-history-toggle 1)))) - -(defun haskell-interactive-mode-history-next (arg) - "Cycle forward through input history." - (interactive "*p") - (when (haskell-interactive-at-prompt) - (if (not (zerop arg)) - (haskell-interactive-mode-history-toggle (- arg)) - (setq haskell-interactive-mode-history-index 0) - (haskell-interactive-mode-history-toggle -1)))) - -(defun haskell-interactive-mode-set-prompt (p) - "Set (and overwrite) the current prompt." - (with-current-buffer (haskell-session-interactive-buffer (haskell-session)) - (goto-char haskell-interactive-mode-prompt-start) - (delete-region (point) (point-max)) - (insert p))) +(defun haskell-mode-message-line (str) + "Message only one line, multiple lines just disturbs the programmer." + (let ((lines (split-string str "\n" t))) + (when (and (car lines) (stringp (car lines))) + (message "%s" + (concat (car lines) + (if (and (cdr lines) (stringp (cadr lines))) + (format " [ %s .. ]" (haskell-string-take (haskell-trim (cadr lines)) 10)) + "")))))) -(defun haskell-interactive-buffer () - "Get the interactive buffer of the session." - (haskell-session-interactive-buffer (haskell-session))) - -(defun haskell-interactive-show-load-message (session type module-name file-name echo th) - "Show the '(Compiling|Loading) X' message." - (let ((msg (concat - (cl-ecase type - ('compiling - (if haskell-interactive-mode-include-file-name - (format "Compiling: %s (%s)" module-name file-name) - (format "Compiling: %s" module-name))) - ('loading (format "Loading: %s" module-name)) - ('import-cycle (format "Module has an import cycle: %s" module-name))) - (if th " [TH]" "")))) - (haskell-mode-message-line msg) - (when haskell-interactive-mode-delete-superseded-errors - (haskell-interactive-mode-delete-compile-messages session file-name)) - (when echo - (haskell-interactive-mode-echo session msg)))) - -(defun haskell-interactive-mode-completion-at-point-function () - "Offer completions for partial expression between prompt and point" - (when (haskell-interactive-at-prompt) - (let* ((process (haskell-process)) - (session (haskell-session)) - (inp (haskell-interactive-mode-input-partial))) - (if (string= inp (car-safe haskell-interactive-mode-completion-cache)) - (cdr haskell-interactive-mode-completion-cache) - (let* ((resp2 (haskell-process-get-repl-completions process inp)) - (rlen (- (length inp) (length (car resp2)))) - (coll (append (if (string-prefix-p inp "import") '("import")) - (if (string-prefix-p inp "let") '("let")) - (cdr resp2))) - (result (list (- (point) rlen) (point) coll))) - (setq haskell-interactive-mode-completion-cache (cons inp result)) - result))))) - -(defun haskell-interactive-mode-tab () - "Do completion if at prompt or else try collapse/expand." - (interactive) - (cond - ((haskell-interactive-at-prompt) - (completion-at-point)) - ((get-text-property (point) 'collapsible) - (let ((column (current-column))) - (search-backward-regexp "^[^ ]") - (haskell-interactive-mode-tab-expand) - (goto-char (+ column (line-beginning-position))))) - (t (haskell-interactive-mode-tab-expand)))) +(defun haskell-interactive-mode-tab () + "Do completion if at prompt or else try collapse/expand." + (interactive) + (cond + ((haskell-interactive-at-prompt) + (completion-at-point)) + ((get-text-property (point) 'collapsible) + (let ((column (current-column))) + (search-backward-regexp "^[^ ]") + (haskell-interactive-mode-tab-expand) + (goto-char (+ column (line-beginning-position))))) + (t (haskell-interactive-mode-tab-expand)))) (defun haskell-interactive-mode-tab-expand () "Expand the rest of the message." @@ -828,10 +467,180 @@ SESSION, otherwise operate on the current buffer. (progn (goto-char (point-max)) nil))) +(defun haskell-interactive-mode-delete-compile-messages (session &optional file-name) + "Delete compile messages in REPL buffer. +If FILE-NAME is non-nil, restrict to removing messages concerning +FILE-NAME only." + (with-current-buffer (haskell-session-interactive-buffer session) + (save-excursion + (goto-char (point-min)) + (when (search-forward-regexp "^Compilation failed.$" nil t 1) + (let ((inhibit-read-only t)) + (delete-region (line-beginning-position) + (1+ (line-end-position)))) + (goto-char (point-min))) + (while (when (re-search-forward haskell-interactive-mode-error-regexp nil t) + (let ((msg-file-name (match-string-no-properties 1)) + (msg-startpos (line-beginning-position))) + ;; skip over hanging continuation message lines + (while (progn (forward-line) (looking-at "^[ ]+"))) + + (when (or (not file-name) (string= file-name msg-file-name)) + (let ((inhibit-read-only t)) + (set-text-properties msg-startpos (point) nil)) + (delete-region msg-startpos (point)) + )) + t))))) + +;;;###autoload +(defun haskell-interactive-mode-reset-error (session) + "Reset the error cursor position." + (interactive) + (with-current-buffer (haskell-session-interactive-buffer session) + (haskell-interactive-mode-goto-end-point) + (let ((mrk (point-marker))) + (haskell-session-set session 'next-error-locus nil) + (haskell-session-set session 'next-error-region (cons mrk (copy-marker mrk t)))) + (goto-char (point-max)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Misc + +(defun haskell-session-interactive-buffer (s) + "Get the session interactive buffer." + (let ((buffer (haskell-session-get s 'interactive-buffer))) + (if (and buffer (buffer-live-p buffer)) + buffer + (let ((buffer (get-buffer-create (format "*%s*" (haskell-session-name s))))) + (haskell-session-set-interactive-buffer s buffer) + (with-current-buffer buffer + (haskell-interactive-mode) + (haskell-session-assign s)) + (switch-to-buffer-other-window buffer) + buffer)))) + +(defun haskell-process-cabal-live (state buffer) + "Do live updates for Cabal processes." + (haskell-interactive-mode-insert + (haskell-process-session (cadr state)) + (replace-regexp-in-string + haskell-process-prompt-regex + "" + (substring buffer (cl-cadddr state)))) + (setf (cl-cdddr state) (list (length buffer))) + nil) + +(defun haskell-process-parse-error (string) + "Parse the line number from the error." + (let ((span nil)) + (cl-loop for regex + in haskell-compilation-error-regexp-alist + do (when (string-match (car regex) string) + (setq span + (list :file (match-string 1 string) + :line (string-to-number (match-string 2 string)) + :col (string-to-number (match-string 4 string)) + :line2 (when (match-string 3 string) + (string-to-number (match-string 3 string))) + :col2 (when (match-string 5 string) + (string-to-number (match-string 5 string))))))) + span)) + +(defun haskell-process-suggest-add-package (session msg) + "Add the (matched) module to your cabal file." + (let* ((suggested-package (match-string 1 msg)) + (package-name (replace-regexp-in-string "-[^-]+$" "" suggested-package)) + (version (progn (string-match "\\([^-]+\\)$" suggested-package) + (match-string 1 suggested-package))) + (cabal-file (concat (haskell-session-name session) + ".cabal"))) + (when (y-or-n-p + (format "Add `%s' to %s?" + package-name + cabal-file)) + (haskell-cabal-add-dependency package-name version nil t)))) + +(defun haskell-process-suggest-remove-import (session file import line) + "Suggest removing or commenting out IMPORT on LINE." + (let ((continue t) + (first t)) + (cl-case (read-event + (propertize (format "%sThe import line `%s' is redundant. Remove? (y, n, c: comment out) " + (if (not first) + "Please answer n, y or c: " + "") + import) + 'face 'minibuffer-prompt)) + (?y + (haskell-process-find-file session file) + (save-excursion + (goto-char (point-min)) + (forward-line (1- line)) + (goto-char (line-beginning-position)) + (delete-region (line-beginning-position) + (line-end-position)))) + (?n + (message "Ignoring redundant import %s" import)) + (?c + (haskell-process-find-file session file) + (save-excursion + (goto-char (point-min)) + (forward-line (1- line)) + (goto-char (line-beginning-position)) + (insert "-- ")))))) + +(defun haskell-process-find-file (session file) + "Find the given file in the project." + (find-file (cond ((file-exists-p (concat (haskell-session-current-dir session) "/" file)) + (concat (haskell-session-current-dir session) "/" file)) + ((file-exists-p (concat (haskell-session-cabal-dir session) "/" file)) + (concat (haskell-session-cabal-dir session) "/" file)) + (t file)))) + +(defun haskell-process-suggest-pragma (session pragma extension file) + "Suggest to add something to the top of the file." + (let ((string (format "{-# %s %s #-}" pragma extension))) + (when (y-or-n-p (format "Add %s to the top of the file? " string)) + (haskell-process-find-file session file) + (save-excursion + (goto-char (point-min)) + (insert (concat string "\n")))))) + +(defun haskell-interactive-mode-insert-error (response) + "Insert an error message." + (insert "\n" + (haskell-fontify-as-mode + response + 'haskell-mode)) + (haskell-interactive-mode-prompt)) + +(defun haskell-interactive-popup-error (response) + "Popup an error." + (if haskell-interactive-popup-errors + (let ((buf (get-buffer-create "*HS-Error*"))) + (pop-to-buffer buf nil t) + (with-current-buffer buf + + (haskell-error-mode) + (let ((inhibit-read-only t)) + (erase-buffer) + (insert (propertize response + 'font-lock-face + 'haskell-interactive-face-compile-error)) + (goto-char (point-min)) + (delete-blank-lines) + (insert (propertize "-- Hit `q' to close this window.\n\n" + 'font-lock-face 'font-lock-comment-face)) + (save-excursion + (goto-char (point-max)) + (insert (propertize "\n-- To disable popups, customize `haskell-interactive-popup-errors'.\n\n" + 'font-lock-face 'font-lock-comment-face)))))) + (haskell-interactive-mode-insert-error response))) + (defun haskell-interactive-next-error-function (&optional n reset) "See `next-error-function' for more information." - (let* ((session (haskell-session)) + (let* ((session (haskell-interactive-session)) (next-error-region (haskell-session-get session 'next-error-region)) (next-error-locus (haskell-session-get session 'next-error-locus)) (reset-locus nil)) @@ -887,70 +696,25 @@ SESSION, otherwise operate on the current buffer. (compilation-goto-locus msgmrk m1 (and (marker-position m2) m2))) (error "don't know where to find %S" file))))))) -(defun haskell-interactive-mode-delete-compile-messages (session &optional file-name) - "Delete compile messages in REPL buffer. -If FILE-NAME is non-nil, restrict to removing messages concerning -FILE-NAME only." - (with-current-buffer (haskell-session-interactive-buffer session) - (save-excursion - (goto-char (point-min)) - (when (search-forward-regexp "^Compilation failed.$" nil t 1) - (let ((inhibit-read-only t)) - (delete-region (line-beginning-position) - (1+ (line-end-position)))) - (goto-char (point-min))) - (while (when (re-search-forward haskell-interactive-mode-error-regexp nil t) - (let ((msg-file-name (match-string-no-properties 1)) - (msg-startpos (line-beginning-position))) - ;; skip over hanging continuation message lines - (while (progn (forward-line) (looking-at "^[ ]+"))) - - (when (or (not file-name) (string= file-name msg-file-name)) - (let ((inhibit-read-only t)) - (set-text-properties msg-startpos (point) nil)) - (delete-region msg-startpos (point)) - )) - t))))) - -(defun haskell-interactive-mode-visit-error () - "Visit the buffer of the current (or last) error message." - (interactive) - (with-current-buffer (haskell-session-interactive-buffer (haskell-session)) - (if (progn (goto-char (line-beginning-position)) - (looking-at haskell-interactive-mode-error-regexp)) - (progn (forward-line -1) - (haskell-interactive-jump-to-error-line)) - (progn (goto-char (point-max)) - (haskell-interactive-mode-error-backward) - (haskell-interactive-jump-to-error-line))))) - -;;;###autoload -(defun haskell-interactive-mode-reset-error (session) - "Reset the error cursor position." - (interactive) - (with-current-buffer (haskell-session-interactive-buffer session) - (haskell-interactive-mode-goto-end-point) - (let ((mrk (point-marker))) - (haskell-session-set session 'next-error-locus nil) - (haskell-session-set session 'next-error-region (cons mrk (copy-marker mrk t)))) - (goto-char (point-max)))) - -(defun haskell-interactive-kill () - "Kill the buffer and (maybe) the session." - (interactive) - (when (eq major-mode 'haskell-interactive-mode) - (when (and (boundp 'haskell-session) - haskell-session - (y-or-n-p "Kill the whole session?")) - (haskell-session-kill t)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Presentation +(defun haskell-interactive-session () + "Get the `haskell-session', throw an error if it's not + available." + (or (haskell-session-maybe) + (haskell-session-assign + (or (haskell-session-from-buffer) + (haskell-session-choose) + (error "No session associated with this buffer. Try M-x haskell-session-change or report this as a bug."))))) + +(defun haskell-interactive-process () + "Get the Haskell session." + (or (haskell-session-process (haskell-interactive-session)) + (error "No Haskell session/process associated with this + buffer. Maybe run M-x haskell-process-restart?"))) (defun haskell-interactive-mode-do-presentation (expr) "Present the given expression. Requires the `present` package to be installed. Will automatically import it qualified as Present." - (let ((p (haskell-process))) + (let ((p (haskell-interactive-process))) ;; If Present.code isn't available, we probably need to run the ;; setup. (unless (string-match "^Present" (haskell-process-queue-sync-request p ":t Present.encode")) @@ -960,7 +724,7 @@ FILE-NAME only." (let ((error (haskell-process-queue-sync-request p (concat "let it = Present.asData (" expr ")")))) (if (not (string= "" error)) - (haskell-interactive-mode-eval-result (haskell-session) (concat error "\n")) + (haskell-interactive-mode-eval-result (haskell-interactive-session) (concat error "\n")) (let ((hash (haskell-interactive-mode-presentation-hash))) (haskell-process-queue-sync-request p (format "let %s = Present.asData (%s)" hash expr)) @@ -969,22 +733,29 @@ FILE-NAME only." (list 0)))) (insert "\n") (haskell-interactive-mode-insert-presentation hash presentation) - (haskell-interactive-mode-eval-result (haskell-session) "\n")))) - (haskell-interactive-mode-prompt (haskell-session))))) - -(defvar haskell-interactive-mode-presentation-hash 0 - "Counter for the hash.") - -(defun haskell-interactive-mode-presentation-hash () - "Generate a presentation hash." - (format "_present_%s" - (setq haskell-interactive-mode-presentation-hash - (1+ haskell-interactive-mode-presentation-hash)))) + (haskell-interactive-mode-eval-result (haskell-interactive-session) "\n")))) + (haskell-interactive-mode-prompt (haskell-interactive-session))))) -(define-button-type 'haskell-presentation-slot-button - 'action 'haskell-presentation-present-slot - 'follow-link t - 'help-echo "Click to expand…") +(defun haskell-interactive-mode-present-id (hash id) + "Generate a presentation for the current expression at ID." + ;; See below for commentary of this statement. + (let ((p (haskell-interactive-process))) + (haskell-process-queue-without-filters + p "let _it = it") + (let* ((text (haskell-process-queue-sync-request + p + (format "Present.putStr (Present.encode (Present.fromJust (Present.present (Present.fromJust (Present.fromList [%s])) %s)))" + (mapconcat 'identity (mapcar 'number-to-string id) ",") + hash))) + (reply + (if (string-match "^*** " text) + '((rep nil)) + (read text)))) + ;; Not necessary, but nice to restore it to the expression that + ;; the user actually typed in. + (haskell-process-queue-without-filters + p "let it = _it") + reply))) (defun haskell-presentation-present-slot (btn) "The callback to evaluate the slot and present it in place of the button." @@ -1108,27 +879,6 @@ they're both up to date, or report a bug.")) (insert err) (error err)))))) -(defun haskell-interactive-mode-present-id (hash id) - "Generate a presentation for the current expression at ID." - ;; See below for commentary of this statement. - (let ((p (haskell-process))) - (haskell-process-queue-without-filters - p "let _it = it") - (let* ((text (haskell-process-queue-sync-request - p - (format "Present.putStr (Present.encode (Present.fromJust (Present.present (Present.fromJust (Present.fromList [%s])) %s)))" - (mapconcat 'identity (mapcar 'number-to-string id) ",") - hash))) - (reply - (if (string-match "^*** " text) - '((rep nil)) - (read text)))) - ;; Not necessary, but nice to restore it to the expression that - ;; the user actually typed in. - (haskell-process-queue-without-filters - p "let it = _it") - reply))) - (defun haskell-interactive-mode-setup-presentation (p) "Setup the GHCi REPL for using presentations. @@ -1145,10 +895,179 @@ don't care when the thing completes as long as it's soonish." (haskell-process-queue-without-filters p "Present.present (Present.fromJust (Present.fromList [0])) ()")) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Misc +(defvar haskell-interactive-mode-presentation-hash 0 + "Counter for the hash.") + +(defun haskell-interactive-mode-presentation-hash () + "Generate a presentation hash." + (format "_present_%s" + (setq haskell-interactive-mode-presentation-hash + (1+ haskell-interactive-mode-presentation-hash)))) + +(define-button-type 'haskell-presentation-slot-button + 'action 'haskell-presentation-present-slot + 'follow-link t + 'help-echo "Click to expand…") + +(defun haskell-interactive-mode-history-toggle (n) + "Toggle the history n items up or down." + (unless (null haskell-interactive-mode-history) + (setq haskell-interactive-mode-history-index + (mod (+ haskell-interactive-mode-history-index n) + (length haskell-interactive-mode-history))) + (unless (zerop haskell-interactive-mode-history-index) + (message "History item: %d" haskell-interactive-mode-history-index)) + (haskell-interactive-mode-set-prompt + (nth haskell-interactive-mode-history-index + haskell-interactive-mode-history)))) + +(defun haskell-interactive-mode-set-prompt (p) + "Set (and overwrite) the current prompt." + (with-current-buffer (haskell-session-interactive-buffer (haskell-interactive-session)) + (goto-char haskell-interactive-mode-prompt-start) + (delete-region (point) (point-max)) + (insert p))) + +(defun haskell-interactive-mode-history-previous (arg) + "Cycle backwards through input history." + (interactive "*p") + (when (haskell-interactive-at-prompt) + (if (not (zerop arg)) + (haskell-interactive-mode-history-toggle arg) + (setq haskell-interactive-mode-history-index 0) + (haskell-interactive-mode-history-toggle 1)))) + +(defun haskell-interactive-mode-history-next (arg) + "Cycle forward through input history." + (interactive "*p") + (when (haskell-interactive-at-prompt) + (if (not (zerop arg)) + (haskell-interactive-mode-history-toggle (- arg)) + (setq haskell-interactive-mode-history-index 0) + (haskell-interactive-mode-history-toggle -1)))) + +(defun haskell-interactive-mode-clear () + "Clear the screen and put any current input into the history." + (interactive) + (let ((session (haskell-interactive-session))) + (with-current-buffer (haskell-session-interactive-buffer session) + (let ((inhibit-read-only t)) + (set-text-properties (point-min) (point-max) nil)) + (delete-region (point-min) (point-max)) + (remove-overlays) + (haskell-interactive-mode-prompt session) + (haskell-session-set session 'next-error-region nil) + (haskell-session-set session 'next-error-locus nil)) + (with-current-buffer (get-buffer-create "*haskell-process-log*") + (delete-region (point-min) (point-max)) + (remove-overlays)))) + +(defun haskell-interactive-mode-completion-at-point-function () + "Offer completions for partial expression between prompt and point" + (when (haskell-interactive-at-prompt) + (let* ((process (haskell-interactive-process)) + (session (haskell-interactive-session)) + (inp (haskell-interactive-mode-input-partial))) + (if (string= inp (car-safe haskell-interactive-mode-completion-cache)) + (cdr haskell-interactive-mode-completion-cache) + (let* ((resp2 (haskell-process-get-repl-completions process inp)) + (rlen (- (length inp) (length (car resp2)))) + (coll (append (if (string-prefix-p inp "import") '("import")) + (if (string-prefix-p inp "let") '("let")) + (cdr resp2))) + (result (list (- (point) rlen) (point) coll))) + (setq haskell-interactive-mode-completion-cache (cons inp result)) + result))))) -(add-hook 'kill-buffer-hook 'haskell-interactive-kill) +(defun haskell-interactive-mode-trigger-compile-error (state response) + "Look for an compile error; if there is one, pop + that up in a buffer, similar to `debug-on-error'." + (when (and haskell-interactive-types-for-show-ambiguous + (string-match "^\n:[0-9]+:[0-9]+:" response) + (not (string-match "^\n:[0-9]+:[0-9]+:[\n ]+Warning:" response))) + (let ((inhibit-read-only t)) + (delete-region haskell-interactive-mode-prompt-start (point)) + (set-marker haskell-interactive-mode-prompt-start + haskell-interactive-mode-old-prompt-start) + (goto-char (point-max))) + (cond + ((and (not (haskell-interactive-mode-line-is-query (elt state 2))) + (or (string-match "No instance for (?Show[ \n]" response) + (string-match "Ambiguous type variable " response))) + (haskell-process-reset (haskell-interactive-process)) + (let ((resp (haskell-process-queue-sync-request + (haskell-interactive-process) + (concat ":t " + (buffer-substring-no-properties + haskell-interactive-mode-prompt-start + (point-max)))))) + (cond + ((not (string-match ":" resp)) + (haskell-interactive-mode-insert-error resp)) + (t (haskell-interactive-popup-error response))))) + (t (haskell-interactive-popup-error response) + t)) + t)) + +;;;###autoload +(defun haskell-interactive-mode-echo (session message &optional mode) + "Echo a read only piece of text before the prompt." + (with-current-buffer (haskell-session-interactive-buffer session) + (save-excursion + (haskell-interactive-mode-goto-end-point) + (insert (if mode + (haskell-fontify-as-mode + (concat message "\n") + mode) + (propertize (concat message "\n") + 'read-only t + 'rear-nonsticky t)))))) + +(defun haskell-interactive-mode-compile-splice (session message) + "Echo a compiler splice." + (with-current-buffer (haskell-session-interactive-buffer session) + (setq next-error-last-buffer (current-buffer)) + (save-excursion + (haskell-interactive-mode-goto-end-point) + (insert (haskell-fontify-as-mode message 'haskell-mode) + "\n")))) + +(defun haskell-interactive-mode-insert-garbage (session message) + "Echo a read only piece of text before the prompt." + (with-current-buffer (haskell-session-interactive-buffer session) + (save-excursion + (haskell-interactive-mode-goto-end-point) + (insert (propertize message + 'font-lock-face 'haskell-interactive-face-garbage + 'read-only t + 'rear-nonsticky t))))) + +;;;###autoload +(defun haskell-process-do-simple-echo (line &optional mode) + "Send LINE to the GHCi process and echo the result in some +fashion, such as printing in the minibuffer, or using +haskell-present, depending on configuration." + (let ((process (haskell-interactive-process))) + (haskell-process-queue-command + process + (make-haskell-command + :state (list process line mode) + :go (lambda (state) + (haskell-process-send-string (car state) (cadr state))) + :complete (lambda (state response) + ;; TODO: TBD: don't do this if + ;; `haskell-process-use-presentation-mode' is t. + (haskell-interactive-mode-echo + (haskell-process-session (car state)) + response + (cl-caddr state)) + (if haskell-process-use-presentation-mode + (progn (haskell-present (cadr state) + (haskell-process-session (car state)) + response) + (haskell-session-assign + (haskell-process-session (car state)))) + (haskell-mode-message-line response))))))) (provide 'haskell-interactive-mode) diff --git a/haskell-load.el b/haskell-load.el new file mode 100644 index 000000000..6e96ddb90 --- /dev/null +++ b/haskell-load.el @@ -0,0 +1,387 @@ +;;; haskell-load.el --- Compiling and loading modules in the GHCi process + +;; Copyright (c) 2014 Chris Done. All rights reserved. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(require 'haskell-process) +(require 'haskell-interactive-mode) +(require 'haskell-commands) + +(defun haskell-process-look-config-changes (session) + "Checks whether a cabal configuration file has +changed. Restarts the process if that is the case." + (let ((current-checksum (haskell-session-get session 'cabal-checksum)) + (new-checksum (haskell-cabal-compute-checksum + (haskell-session-get session 'cabal-dir)))) + (when (not (string= current-checksum new-checksum)) + (haskell-interactive-mode-echo session (format "Cabal file changed: %s" new-checksum)) + (haskell-session-set-cabal-checksum session + (haskell-session-get session 'cabal-dir)) + (unless (and haskell-process-prompt-restart-on-cabal-change + (not (y-or-n-p "Cabal file changed; restart GHCi process? "))) + (haskell-process-start (haskell-interactive-session)))))) + +(defun haskell-process-live-build (process buffer echo-in-repl) + "Show live updates for loading files." + (cond ((haskell-process-consume + process + (concat "\\[[ ]*\\([0-9]+\\) of \\([0-9]+\\)\\]" + " Compiling \\([^ ]+\\)[ ]+" + "( \\([^ ]+\\), \\([^ ]+\\) )[^\r\n]*[\r\n]+")) + (haskell-process-echo-load-message process buffer echo-in-repl nil) + t) + ((haskell-process-consume + process + (concat "\\[[ ]*\\([0-9]+\\) of \\([0-9]+\\)\\]" + " Compiling \\[TH\\] \\([^ ]+\\)[ ]+" + "( \\([^ ]+\\), \\([^ ]+\\) )[^\r\n]*[\r\n]+")) + (haskell-process-echo-load-message process buffer echo-in-repl t) + t) + ((haskell-process-consume process "Loading package \\([^ ]+\\) ... linking ... done.\n") + (haskell-mode-message-line + (format "Loading: %s" + (match-string 1 buffer))) + t) + ((haskell-process-consume + process + "^Preprocessing executables for \\(.+?\\)\\.\\.\\.") + (let ((msg (format "Preprocessing: %s" (match-string 1 buffer)))) + (haskell-interactive-mode-echo + (haskell-process-session process) + msg) + (haskell-mode-message-line msg))) + ((haskell-process-consume process "Linking \\(.+?\\) \\.\\.\\.") + (let ((msg (format "Linking: %s" (match-string 1 buffer)))) + (haskell-interactive-mode-echo (haskell-process-session process) msg) + (haskell-mode-message-line msg))) + ((haskell-process-consume process "\nBuilding \\(.+?\\)\\.\\.\\.") + (let ((msg (format "Building: %s" (match-string 1 buffer)))) + (haskell-interactive-mode-echo + (haskell-process-session process) + msg) + (haskell-mode-message-line msg))))) + +(defun haskell-process-load-complete (session process buffer reload module-buffer &optional cont) + "Handle the complete loading response. BUFFER is the string of +text being sent over the process pipe. MODULE-BUFFER is the +actual Emacs buffer of the module being loaded." + (cond ((haskell-process-consume process "Ok, modules loaded: \\(.+\\)\\.$") + (let* ((modules (haskell-process-extract-modules buffer)) + (cursor (haskell-process-response-cursor process))) + (haskell-process-set-response-cursor process 0) + (let ((warning-count 0)) + (while (haskell-process-errors-warnings session process buffer) + (setq warning-count (1+ warning-count))) + (haskell-process-set-response-cursor process cursor) + (if (and (not reload) + haskell-process-reload-with-fbytecode) + (haskell-process-reload-with-fbytecode process module-buffer) + (haskell-process-import-modules process (car modules))) + (haskell-mode-message-line + (if reload "Reloaded OK." "OK.")) + (when cont + (condition-case e + (funcall cont t) + (error (message "%S" e)) + (quit nil)))))) + ((haskell-process-consume process "Failed, modules loaded: \\(.+\\)\\.$") + (let* ((modules (haskell-process-extract-modules buffer)) + (cursor (haskell-process-response-cursor process))) + (haskell-process-set-response-cursor process 0) + (while (haskell-process-errors-warnings session process buffer)) + (haskell-process-set-response-cursor process cursor) + (if (and (not reload) haskell-process-reload-with-fbytecode) + (haskell-process-reload-with-fbytecode process module-buffer) + (haskell-process-import-modules process (car modules))) + (haskell-interactive-mode-compile-error session "Compilation failed.") + (when cont + (condition-case e + (funcall cont nil) + (error (message "%S" e)) + (quit nil))))))) + +(defun haskell-process-suggest-imports (session file modules ident) + "Given a list of MODULES, suggest adding them to the import section." + (cl-assert session) + (cl-assert file) + (cl-assert ident) + (let* ((process (haskell-session-process session)) + (suggested-already (haskell-process-suggested-imports process)) + (module (cond ((> (length modules) 1) + (when (y-or-n-p (format "Identifier `%s' not in scope, choose module to import?" + ident)) + (haskell-complete-module-read "Module: " modules))) + ((= (length modules) 1) + (let ((module (car modules))) + (unless (member module suggested-already) + (haskell-process-set-suggested-imports process (cons module suggested-already)) + (when (y-or-n-p (format "Identifier `%s' not in scope, import `%s'?" + ident + module)) + module))))))) + (when module + (haskell-process-find-file session file) + (save-excursion + (goto-char (point-max)) + (haskell-navigate-imports) + (insert (read-from-minibuffer "Import line: " (concat "import " module)) + "\n") + (haskell-sort-imports) + (haskell-align-imports))))) + +(defun haskell-process-trigger-suggestions (session msg file line) + "Trigger prompting to add any extension suggestions." + (cond ((let ((case-fold-search nil)) + (or (and (string-match " -X\\([A-Z][A-Za-z]+\\)" msg) + (not (string-match "\\([A-Z][A-Za-z]+\\) is deprecated" msg))) + (string-match "Use \\([A-Z][A-Za-z]+\\) to permit this" msg) + (string-match "Use \\([A-Z][A-Za-z]+\\) to allow" msg) + (string-match "use \\([A-Z][A-Za-z]+\\)" msg) + (string-match "You need \\([A-Z][A-Za-z]+\\)" msg))) + (when haskell-process-suggest-language-pragmas + (haskell-process-suggest-pragma session "LANGUAGE" (match-string 1 msg) file))) + ((string-match " The \\(qualified \\)?import of[ ][‘`‛]\\([^ ]+\\)['’] is redundant" msg) + (when haskell-process-suggest-remove-import-lines + (haskell-process-suggest-remove-import session + file + (match-string 2 msg) + line))) + ((string-match "Warning: orphan instance: " msg) + (when haskell-process-suggest-no-warn-orphans + (haskell-process-suggest-pragma session "OPTIONS" "-fno-warn-orphans" file))) + ((or (string-match "against inferred type [‘`‛]\\[Char\\]['’]" msg) + (string-match "with actual type [‘`‛]\\[Char\\]['’]" msg)) + (when haskell-process-suggest-overloaded-strings + (haskell-process-suggest-pragma session "LANGUAGE" "OverloadedStrings" file))) + ((string-match "^Not in scope: .*[‘`‛]\\(.+\\)['’]$" msg) + (let* ((match1 (match-string 1 msg)) + (ident (if (string-match "^[A-Za-z0-9_'.]+\\.\\(.+\\)$" match1) + ;; Skip qualification. + (match-string 1 match1) + match1))) + (when haskell-process-suggest-hoogle-imports + (let ((modules (haskell-process-hoogle-ident ident))) + (haskell-process-suggest-imports session file modules ident))) + (when haskell-process-suggest-haskell-docs-imports + (let ((modules (haskell-process-haskell-docs-ident ident))) + (haskell-process-suggest-imports session file modules ident))) + (when haskell-process-suggest-hayoo-imports + (let ((modules (haskell-process-hayoo-ident ident))) + (haskell-process-suggest-imports session file modules ident))))) + ((string-match "^[ ]+It is a member of the hidden package [‘`‛]\\(.+\\)['’].$" msg) + (when haskell-process-suggest-add-package + (haskell-process-suggest-add-package session msg))))) + +(defun haskell-process-do-cabal (command) + "Run a Cabal command." + (let ((process (haskell-interactive-process))) + (haskell-process-queue-command + process + (make-haskell-command + :state (list (haskell-interactive-session) process command 0) + + :go + (lambda (state) + (haskell-process-send-string + (cadr state) + (format haskell-process-do-cabal-format-string + (haskell-session-cabal-dir (car state)) + (format "%s %s" + (cl-ecase (haskell-process-type) + ('ghci haskell-process-path-cabal) + ('cabal-repl haskell-process-path-cabal) + ('cabal-ghci haskell-process-path-cabal) + ('cabal-dev haskell-process-path-cabal-dev)) + (cl-caddr state))))) + + :live + (lambda (state buffer) + (let ((cmd (replace-regexp-in-string "^\\([a-z]+\\).*" + "\\1" + (cl-caddr state)))) + (cond ((or (string= cmd "build") + (string= cmd "install")) + (haskell-process-live-build (cadr state) buffer t)) + (t + (haskell-process-cabal-live state buffer))))) + + :complete + (lambda (state response) + (let* ((process (cadr state)) + (session (haskell-process-session process)) + (message-count 0) + (cursor (haskell-process-response-cursor process))) + (haskell-process-set-response-cursor process 0) + (while (haskell-process-errors-warnings session process response) + (setq message-count (1+ message-count))) + (haskell-process-set-response-cursor process cursor) + (let ((msg (format "Complete: cabal %s (%s compiler messages)" + (cl-caddr state) + message-count))) + (haskell-interactive-mode-echo session msg) + (when (= message-count 0) + (haskell-interactive-mode-echo + session + "No compiler messages, dumping complete output:") + (haskell-interactive-mode-echo session response)) + (haskell-mode-message-line msg) + (when (and haskell-notify-p + (fboundp 'notifications-notify)) + (notifications-notify + :title (format "*%s*" (haskell-session-name (car state))) + :body msg + :app-name (cl-ecase (haskell-process-type) + ('ghci haskell-process-path-cabal) + ('cabal-repl haskell-process-path-cabal) + ('cabal-ghci haskell-process-path-cabal) + ('cabal-dev haskell-process-path-cabal-dev)) + :app-icon haskell-process-logo))))))))) + +(defun haskell-process-echo-load-message (process buffer echo-in-repl th) + "Echo a load message." + (let ((session (haskell-process-session process)) + (module-name (match-string 3 buffer)) + (file-name (match-string 4 buffer))) + (haskell-interactive-show-load-message + session + 'compiling + module-name + (haskell-session-strip-dir session file-name) + echo-in-repl + th))) + +(defun haskell-process-extract-modules (buffer) + "Extract the modules from the process buffer." + (let* ((modules-string (match-string 1 buffer)) + (modules (split-string modules-string ", "))) + (cons modules modules-string))) + +(defun haskell-process-errors-warnings (session process buffer) + "Trigger handling type errors or warnings." + (cond + ((haskell-process-consume + process + "\\(Module imports form a cycle:[ \n]+module [^ ]+ ([^)]+)[[:unibyte:][:nonascii:]]+?\\)\nFailed") + (let ((err (match-string 1 buffer))) + (when (string-match "module [`'‘‛]\\([^ ]+\\)['’`] (\\([^)]+\\))" err) + (let* ((default-directory (haskell-session-current-dir session)) + (module (match-string 1 err)) + (file (match-string 2 err)) + (relative-file-name (file-relative-name file))) + (haskell-interactive-show-load-message + session + 'import-cycle + module + relative-file-name + nil + nil) + (haskell-interactive-mode-compile-error + session + (format "%s:1:0: %s" + relative-file-name + err))))) + t) + ((haskell-process-consume + process + (concat "[\r\n]\\([A-Z]?:?[^ \r\n:][^:\n\r]+\\):\\([0-9()-:]+\\):" + "[ \n\r]+\\([[:unibyte:][:nonascii:]]+?\\)\n[^ ]")) + (haskell-process-set-response-cursor process + (- (haskell-process-response-cursor process) 1)) + (let* ((buffer (haskell-process-response process)) + (file (match-string 1 buffer)) + (location (match-string 2 buffer)) + (error-msg (match-string 3 buffer)) + (warning (string-match "^Warning:" error-msg)) + (splice (string-match "^Splicing " error-msg)) + (final-msg (format "%s:%s: %s" + (haskell-session-strip-dir session file) + location + error-msg))) + (funcall (cond (warning + 'haskell-interactive-mode-compile-warning) + (splice + 'haskell-interactive-mode-compile-splice) + (t 'haskell-interactive-mode-compile-error)) + session final-msg) + (unless warning + (haskell-mode-message-line final-msg)) + (haskell-process-trigger-suggestions + session + error-msg + file + (plist-get (haskell-process-parse-error final-msg) :line))) + t))) + +(defun haskell-interactive-show-load-message (session type module-name file-name echo th) + "Show the '(Compiling|Loading) X' message." + (let ((msg (concat + (cl-ecase type + ('compiling + (if haskell-interactive-mode-include-file-name + (format "Compiling: %s (%s)" module-name file-name) + (format "Compiling: %s" module-name))) + ('loading (format "Loading: %s" module-name)) + ('import-cycle (format "Module has an import cycle: %s" module-name))) + (if th " [TH]" "")))) + (haskell-mode-message-line msg) + (when haskell-interactive-mode-delete-superseded-errors + (haskell-interactive-mode-delete-compile-messages session file-name)) + (when echo + (haskell-interactive-mode-echo session msg)))) + +(defun haskell-process-reload-devel-main () + "Reload the module `DevelMain' and then run +`DevelMain.update'. This is for doing live update of the code of +servers or GUI applications. Put your development version of the +program in `DevelMain', and define `update' to auto-start the +program on a new thread, and use the `foreign-store' package to +access the running context across :load/:reloads in GHCi." + (interactive) + (with-current-buffer (or (get-buffer "DevelMain.hs") + (if (y-or-n-p "You need to open a buffer named DevelMain.hs. Find now?") + (ido-find-file) + (error "No DevelMain.hs buffer."))) + (let ((session (haskell-interactive-session))) + (let ((process (haskell-interactive-process))) + (haskell-process-queue-command + process + (make-haskell-command + :state (list :session session + :process process + :buffer (current-buffer)) + :go (lambda (state) + (haskell-process-send-string (plist-get state ':process) + ":l DevelMain")) + :live (lambda (state buffer) + (haskell-process-live-build (plist-get state ':process) + buffer + nil)) + :complete (lambda (state response) + (haskell-process-load-complete + (plist-get state ':session) + (plist-get state ':process) + response + nil + (plist-get state ':buffer) + (lambda (ok) + (when ok + (haskell-process-queue-without-filters + (haskell-interactive-process) + "DevelMain.update") + (message "DevelMain updated."))))))))))) + +(provide 'haskell-load) diff --git a/haskell-menu.el b/haskell-menu.el index 567027c26..87770a8e7 100644 --- a/haskell-menu.el +++ b/haskell-menu.el @@ -31,6 +31,7 @@ (require 'haskell-compat) (require 'haskell-session) (require 'haskell-process) +(require 'haskell-interactive-mode) (defcustom haskell-menu-buffer-name "*haskell-menu*" "The name of the Haskell session menu buffer" diff --git a/haskell-mode.el b/haskell-mode.el index 5017dac25..c11631ef5 100644 --- a/haskell-mode.el +++ b/haskell-mode.el @@ -124,6 +124,7 @@ ;;; Code: +(require 'haskell-customize) (require 'ansi-color) (require 'dabbrev) (require 'compile) @@ -137,20 +138,6 @@ (require 'haskell-sort-imports) (require 'haskell-string) -;; FIXME: code-smell: too many forward decls for haskell-session are required here -(defvar haskell-session) -(declare-function haskell-process "haskell-process" ()) -(declare-function interactive-haskell-mode "haskell-process" (&optional arg)) -(declare-function haskell-process-do-try-info "haskell-process" (sym)) -(declare-function haskell-process-queue-sync-request (process reqstr)) -(declare-function haskell-process-generate-tags "haskell-process" (&optional and-then-find-this-tag)) -(declare-function haskell-session "haskell-session" ()) -(declare-function haskell-session-all-modules "haskell-session" (&optional DONTCREATE)) -(declare-function haskell-session-cabal-dir "haskell-session" (session &optional no-prompt)) -(declare-function haskell-session-maybe "haskell-session" ()) -(declare-function haskell-session-tags-filename "haskell-session" (session)) -(declare-function haskell-session-current-dir "haskell-session" (session)) - ;; All functions/variables start with `(literate-)haskell-'. ;; Version of mode. @@ -160,10 +147,6 @@ (defconst haskell-git-version "@GIT_VERSION@" "The Git version of `haskell-mode'.") -(defvar haskell-mode-pkg-base-dir (file-name-directory load-file-name) - "Package base directory of installed `haskell-mode'. -Used for locating additional package data files.") - ;;;###autoload (defun haskell-version (&optional here) "Show the `haskell-mode` version in the echo area. @@ -191,23 +174,6 @@ When MESSAGE is non-nil, display a message with the version." (outline-next-visible-heading 1) (show-subtree))) -(defgroup haskell nil - "Major mode for editing Haskell programs." - :link '(custom-manual "(haskell-mode)") - :group 'languages - :prefix "haskell-") - -;;;###autoload -(defun haskell-customize () - "Browse the haskell customize sub-tree. -This calls 'customize-browse' with haskell as argument and makes -sure all haskell customize definitions have been loaded." - (interactive) - ;; make sure all modules with (defcustom ...)s are loaded - (mapc 'require - '(haskell-checkers haskell-compile haskell-doc haskell-font-lock haskell-indentation haskell-indent haskell-interactive-mode haskell-menu haskell-process haskell-yas inf-haskell)) - (customize-browse 'haskell)) - ;; Are we looking at a literate script? (defvar haskell-literate nil "*If not nil, the current buffer contains a literate Haskell script. @@ -708,15 +674,6 @@ is asked to show extra info for the items matching QUERY.." (const "ghc -fno-code") (string :tag "Other command"))) -(defcustom haskell-completing-read-function 'ido-completing-read - "Default function to use for completion." - :group 'haskell - :type '(choice - (function-item :tag "ido" :value ido-completing-read) - (function-item :tag "helm" :value helm--completing-read-default) - (function-item :tag "completing-read" :value completing-read) - (function :tag "Custom function"))) - (defcustom haskell-stylish-on-save nil "Whether to run stylish-haskell on the buffer before saving." :group 'haskell @@ -731,7 +688,8 @@ is asked to show extra info for the items matching QUERY.." "Internal use.") (defcustom haskell-indent-spaces 2 - "Number of spaces to indent inwards.") + "Number of spaces to indent inwards." + :group 'haskell) ;; Like Python. Should be abstracted, sigh. (defun haskell-check (command) @@ -778,269 +736,10 @@ Run M-x describe-variable haskell-mode-hook for a list of such modes.")) (goto-char (+ (line-beginning-position) col)))) -(defun haskell-mode-message-line (str) - "Message only one line, multiple lines just disturbs the programmer." - (let ((lines (split-string str "\n" t))) - (when (and (car lines) (stringp (car lines))) - (message "%s" - (concat (car lines) - (if (and (cdr lines) (stringp (cadr lines))) - (format " [ %s .. ]" (haskell-string-take (haskell-trim (cadr lines)) 10)) - "")))))) - -(defun haskell-mode-contextual-space () - "Contextually do clever stuff when hitting space." - (interactive) - (if (or (not (bound-and-true-p interactive-haskell-mode)) - (not (haskell-session-maybe))) - (self-insert-command 1) - (cond ((and haskell-mode-contextual-import-completion - (save-excursion (forward-word -1) - (looking-at "^import$"))) - (insert " ") - (let ((module (haskell-complete-module-read "Module: " (haskell-session-all-modules)))) - (insert module) - (haskell-mode-format-imports))) - ((not (string= "" (save-excursion (forward-char -1) (haskell-ident-at-point)))) - (let ((ident (save-excursion (forward-char -1) (haskell-ident-at-point)))) - (insert " ") - (haskell-process-do-try-info ident))) - (t (insert " "))))) - (defun haskell-mode-before-save-handler () "Function that will be called before buffer's saving." ) -(defun haskell-mode-after-save-handler () - "Function that will be called after buffer's saving." - (when haskell-tags-on-save - (ignore-errors (when (and (boundp 'haskell-session) haskell-session) - (haskell-process-generate-tags)))) - (when haskell-stylish-on-save - (ignore-errors (haskell-mode-stylish-buffer)) - (let ((before-save-hook '()) - (after-save-hook '())) - (basic-save-buffer)))) - -(defun haskell-mode-buffer-apply-command (cmd) - "Execute shell command CMD with current buffer as input and -replace the whole buffer with the output. If CMD fails the buffer -remains unchanged." - (set-buffer-modified-p t) - (let* ((chomp (lambda (str) - (while (string-match "\\`\n+\\|^\\s-+\\|\\s-+$\\|\n+\\'" str) - (setq str (replace-match "" t t str))) - str)) - (errout (lambda (fmt &rest args) - (let* ((warning-fill-prefix " ")) - (display-warning cmd (apply 'format fmt args) :warning)))) - (filename (buffer-file-name (current-buffer))) - (cmd-prefix (replace-regexp-in-string " .*" "" cmd)) - (tmp-file (make-temp-file cmd-prefix)) - (err-file (make-temp-file cmd-prefix)) - (default-directory (if (and (boundp 'haskell-session) - haskell-session) - (haskell-session-cabal-dir haskell-session) - default-directory)) - (errcode (with-temp-file tmp-file - (call-process cmd filename - (list (current-buffer) err-file) nil))) - (stderr-output - (with-temp-buffer - (insert-file-contents err-file) - (funcall chomp (buffer-substring-no-properties (point-min) (point-max))))) - (stdout-output - (with-temp-buffer - (insert-file-contents tmp-file) - (buffer-substring-no-properties (point-min) (point-max))))) - (if (string= "" stderr-output) - (if (string= "" stdout-output) - (funcall errout - "Error: %s produced no output, leaving buffer alone" cmd) - (save-restriction - (widen) - ;; command successful, insert file with replacement to preserve - ;; markers. - (insert-file-contents tmp-file nil nil nil t))) - ;; non-null stderr, command must have failed - (funcall errout "%s failed: %s" cmd stderr-output) - ) - (delete-file tmp-file) - (delete-file err-file) - )) - -(defun haskell-mode-stylish-buffer () - "Apply stylish-haskell to the current buffer." - (interactive) - (let ((column (current-column)) - (line (line-number-at-pos))) - (haskell-mode-buffer-apply-command "stylish-haskell") - (goto-char (point-min)) - (forward-line (1- line)) - (goto-char (+ column (point))))) - -(defun haskell-mode-goto-loc () - "Go to the location of the thing at point. Requires the :loc-at -command from GHCi." - (interactive) - (let ((loc (haskell-mode-loc-at))) - (when loc - (find-file (expand-file-name (plist-get loc :path) - (haskell-session-cabal-dir (haskell-session)))) - (goto-char (point-min)) - (forward-line (1- (plist-get loc :start-line))) - (forward-char (plist-get loc :start-col))))) - -(defun haskell-mode-show-type-at (&optional insert-value) - "Show the type of the thing at point." - (interactive "P") - (let ((ty (haskell-mode-type-at))) - (if insert-value - (progn (goto-char (line-beginning-position)) - (insert (haskell-fontify-as-mode ty 'haskell-mode) - "\n")) - (message "%s" (haskell-fontify-as-mode ty 'haskell-mode))))) - -(defun haskell-mode-loc-at () - "Get the location at point. Requires the :loc-at command from -GHCi." - (let ((pos (or (when (region-active-p) - (cons (region-beginning) - (region-end))) - (haskell-ident-pos-at-point) - (cons (point) - (point))))) - (when pos - (let ((reply (haskell-process-queue-sync-request - (haskell-process) - (save-excursion - (format ":loc-at %s %d %d %d %d %s" - (buffer-file-name) - (progn (goto-char (car pos)) - (line-number-at-pos)) - (1+ (current-column)) ;; GHC uses 1-based columns. - (progn (goto-char (cdr pos)) - (line-number-at-pos)) - (1+ (current-column)) ;; GHC uses 1-based columns. - (buffer-substring-no-properties (car pos) - (cdr pos))))))) - (if reply - (if (string-match "\\(.*?\\):(\\([0-9]+\\),\\([0-9]+\\))-(\\([0-9]+\\),\\([0-9]+\\))" - reply) - (list :path (match-string 1 reply) - :start-line (string-to-number (match-string 2 reply)) - ;; ;; GHC uses 1-based columns. - :start-col (1- (string-to-number (match-string 3 reply))) - :end-line (string-to-number (match-string 4 reply)) - ;; GHC uses 1-based columns. - :end-col (1- (string-to-number (match-string 5 reply)))) - (error (propertize reply 'face 'compilation-error))) - (error (propertize "No reply. Is :loc-at supported?" - 'face 'compilation-error))))))) - -(defun haskell-mode-type-at () - "Get the type of the thing at point. Requires the :type-at -command from GHCi." - (let ((pos (or (when (region-active-p) - (cons (region-beginning) - (region-end))) - (haskell-ident-pos-at-point) - (cons (point) - (point))))) - (when pos - (replace-regexp-in-string - "\n$" - "" - (save-excursion - (haskell-process-queue-sync-request - (haskell-process) - (replace-regexp-in-string - "\n" - " " - (format ":type-at %s %d %d %d %d %s" - (buffer-file-name) - (progn (goto-char (car pos)) - (line-number-at-pos)) - (1+ (current-column)) - (progn (goto-char (cdr pos)) - (line-number-at-pos)) - (1+ (current-column)) - (buffer-substring-no-properties (car pos) - (cdr pos)))))))))) - -(defun haskell-mode-jump-to-def-or-tag (&optional next-p) - "Jump to the definition (by consulting GHCi), or (fallback) -jump to the tag. - -Remember: If GHCi is busy doing something, this will delay, but -it will always be accurate, in contrast to tags, which always -work but are not always accurate. - -If the definition or tag is found, the location from which you -jumped will be pushed onto `find-tag-marker-ring', so you can -return to that position with `pop-tag-mark'." - (interactive "P") - (let ((initial-loc (point-marker)) - (loc (haskell-mode-find-def (haskell-ident-at-point)))) - (if loc - (haskell-mode-handle-generic-loc loc) - (call-interactively 'haskell-mode-tag-find)) - (unless (equal initial-loc (point-marker)) - ;; Store position for return with `pop-tag-mark' - (ring-insert find-tag-marker-ring initial-loc)))) - -(defun haskell-mode-tag-find (&optional next-p) - "The tag find function, specific for the particular session." - (interactive "P") - (cond - ((elt (syntax-ppss) 3) ;; Inside a string - (haskell-mode-jump-to-filename-in-string)) - (t (call-interactively 'haskell-mode-jump-to-tag)))) - -(defun haskell-mode-jump-to-filename-in-string () - "Jump to the filename in the current string." - (let* ((string (save-excursion - (buffer-substring-no-properties - (1+ (search-backward-regexp "\"" (line-beginning-position) nil 1)) - (1- (progn (forward-char 1) - (search-forward-regexp "\"" (line-end-position) nil 1)))))) - (fp (expand-file-name string - (haskell-session-cabal-dir (haskell-session))))) - (find-file - (read-file-name - "" - fp - fp)))) - -(defun haskell-mode-jump-to-tag (&optional next-p) - "Jump to the tag of the given identifier." - (interactive "P") - (let ((ident (haskell-ident-at-point)) - (tags-file-name (haskell-session-tags-filename (haskell-session))) - (tags-revert-without-query t)) - (when (not (string= "" (haskell-trim ident))) - (cond ((file-exists-p tags-file-name) - (find-tag ident next-p)) - (t (haskell-process-generate-tags ident)))))) - -(defun haskell-mode-jump-to-def (ident) - "Jump to definition of identifier at point." - (interactive (list (haskell-ident-at-point))) - (let ((loc (haskell-mode-find-def ident))) - (when loc - (haskell-mode-handle-generic-loc loc)))) - -(defun haskell-mode-handle-generic-loc (loc) - "Either jump to or display a generic location. Either a file or -a library." - (cl-case (car loc) - (file (haskell-mode-jump-to-loc (cdr loc))) - (library (message "Defined in `%s' (%s)." - (elt loc 2) - (elt loc 1))) - (module (message "Defined in `%s'." - (elt loc 1))))) - (defun haskell-mode-jump-to-loc (loc) "Jump to the given location. LOC = (list FILE LINE COL)" @@ -1050,44 +749,6 @@ LOC = (list FILE LINE COL)" (goto-char (+ (line-beginning-position) (1- (elt loc 2))))) -(defun haskell-mode-find-def (ident) - "Find definition location of identifier. Uses the GHCi process -to find the location. - -Returns: - - (library ) - (file ) - (module ) -" - (let ((reply (haskell-process-queue-sync-request - (haskell-process) - (format (if (string-match "^[a-zA-Z_]" ident) - ":info %s" - ":info (%s)") - ident)))) - (let ((match (string-match "-- Defined \\(at\\|in\\) \\(.+\\)$" reply))) - (when match - (let ((defined (match-string 2 reply))) - (let ((match (string-match "\\(.+?\\):\\([0-9]+\\):\\([0-9]+\\)$" defined))) - (cond - (match - (list 'file - (expand-file-name (match-string 1 defined) - (haskell-session-current-dir (haskell-session))) - (string-to-number (match-string 2 defined)) - (string-to-number (match-string 3 defined)))) - (t - (let ((match (string-match "`\\(.+?\\):\\(.+?\\)'$" defined))) - (if match - (list 'library - (match-string 1 defined) - (match-string 2 defined)) - (let ((match (string-match "`\\(.+?\\)'$" defined))) - (if match - (list 'module - (match-string 1 defined)))))))))))))) - ;; From Bryan O'Sullivan's blog: ;; http://www.serpentine.com/blog/2007/10/09/using-emacs-to-insert-scc-annotations-in-haskell-code/ (defun haskell-mode-insert-scc-at-point () @@ -1123,28 +784,6 @@ Returns: (kill-region (match-beginning 0) (match-end 0)) (error "No SCC at point"))))) -(defun haskell-rgrep (&optional prompt) - "Grep the effective project for the symbol at point. Very -useful for codebase navigation. Prompts for an arbitrary regexp -given a prefix arg." - (interactive "P") - (let ((sym (if prompt - (read-from-minibuffer "Look for: ") - (haskell-ident-at-point)))) - (rgrep sym - "*.hs" ;; TODO: common Haskell extensions. - (haskell-session-current-dir (haskell-session))))) - -(defun haskell-fontify-as-mode (text mode) - "Fontify TEXT as MODE, returning the fontified text." - (with-temp-buffer - (funcall mode) - (insert text) - (if (fboundp 'font-lock-ensure) - (font-lock-ensure) - (with-no-warnings (font-lock-fontify-buffer))) - (buffer-substring (point-min) (point-max)))) - (defun haskell-guess-module-name () "Guess the current module name of the buffer." (interactive) @@ -1177,42 +816,6 @@ given a prefix arg." (goto-char (point-min)) (forward-char 4))) -(defun haskell-describe (ident) - "Describe the given identifier." - (interactive (list (read-from-minibuffer "Describe identifier: " - (haskell-ident-at-point)))) - (let ((results (read (shell-command-to-string - (concat "haskell-docs --sexp " - ident))))) - (help-setup-xref (list #'haskell-describe ident) - (called-interactively-p 'interactive)) - (save-excursion - (with-help-window (help-buffer) - (with-current-buffer (help-buffer) - (if results - (cl-loop for result in results - do (insert (propertize ident 'font-lock-face - '((:inherit font-lock-type-face - :underline t))) - " is defined in " - (let ((module (cadr (assoc 'module result)))) - (if module - (concat module " ") - "")) - (cadr (assoc 'package result)) - "\n\n") - do (let ((type (cadr (assoc 'type result)))) - (when type - (insert (haskell-fontify-as-mode type 'haskell-mode) - "\n"))) - do (let ((args (cadr (assoc 'type results)))) - (cl-loop for arg in args - do (insert arg "\n")) - (insert "\n")) - do (insert (cadr (assoc 'documentation result))) - do (insert "\n\n")) - (insert "No results for " ident))))))) - ;; Provide ourselves: diff --git a/haskell-process.el b/haskell-process.el index bf306341a..e89c528cc 100644 --- a/haskell-process.el +++ b/haskell-process.el @@ -1,6 +1,6 @@ ;;; haskell-process.el --- Communicating with the inferior Haskell process -;; Copyright (C) 2011-2012 Chris Done +;; Copyright (C) 2011 Chris Done ;; Author: Chris Done @@ -21,214 +21,21 @@ ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. -;;; Commentary: - -;;; Todo: - ;;; Code: -(require 'cl-lib) (require 'json) (require 'url-util) -(require 'haskell-complete-module) -(require 'haskell-mode) (require 'haskell-session) -(require 'haskell-compat) +(require 'haskell-customize) (require 'haskell-str) -(require 'haskell-compile) -(require 'haskell-utils) -(require 'haskell-presentation-mode) -(require 'haskell-navigate-imports) - -;; FIXME: haskell-process shouldn't depend on haskell-interactive-mode to avoid module-dep cycles -(declare-function haskell-interactive-mode-echo "haskell-interactive-mode" (session message &optional mode)) -(declare-function haskell-interactive-mode-compile-error "haskell-interactive-mode" (session message)) -(declare-function haskell-interactive-mode-compile-warning "haskell-interactive-mode" (session message)) -(declare-function haskell-interactive-mode-insert "haskell-interactive-mode" (session message)) -(declare-function haskell-interactive-mode-reset-error "haskell-interactive-mode" (session)) -(declare-function haskell-interactive-show-load-message "haskell-interactive-mode" (session type module-name file-name echo th)) -(declare-function haskell-interactive-mode-insert-garbage "haskell-interactive-mode" (session message)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Configuration -(defgroup haskell-interactive nil - "Settings for REPL interaction via `haskell-interactive-mode'" - :link '(custom-manual "(haskell-mode)haskell-interactive-mode") - :group 'haskell) - -(defcustom haskell-process-path-ghci - "ghci" - "The path for starting ghci." - :group 'haskell-interactive - :type '(choice string (repeat string))) - -(defcustom haskell-process-path-cabal - "cabal" - "Path to the `cabal' executable." - :group 'haskell-interactive - :type '(choice string (repeat string))) - -(defcustom haskell-process-path-cabal-ghci - "cabal-ghci" - "The path for starting cabal-ghci." - :group 'haskell-interactive - :type '(choice string (repeat string))) - -(defcustom haskell-process-path-cabal-dev - "cabal-dev" - "The path for starting cabal-dev." - :group 'haskell-interactive - :type '(choice string (repeat string))) - -(defcustom haskell-process-args-ghci - '("-ferror-spans") - "Any arguments for starting ghci." - :group 'haskell-interactive - :type '(repeat (string :tag "Argument"))) - -(defcustom haskell-process-args-cabal-repl - '("--ghc-option=-ferror-spans") - "Additional arguments to for `cabal repl' invocation. -Note: The settings in `haskell-process-path-ghci' and -`haskell-process-args-ghci' are not automatically reused as `cabal repl' -currently invokes `ghc --interactive'. Use -`--with-ghc=' if you want to use a different -interactive GHC frontend; use `--ghc-option=' to -pass additional flags to `ghc'." - :group 'haskell-interactive - :type '(repeat (string :tag "Argument"))) - -(defcustom haskell-process-do-cabal-format-string - ":!cd %s && %s" - "The way to run cabal comands. It takes two arguments -- the directory and the command. -See `haskell-process-do-cabal' for more details." - :group 'haskell-interactive - :type 'string) - -(defcustom haskell-process-type - 'auto - "The inferior Haskell process type to use." - :type '(choice (const auto) (const ghci) (const cabal-repl) (const cabal-dev) (const cabal-ghci)) - :group 'haskell-interactive) - -(defcustom haskell-process-log - nil - "Enable debug logging to \"*haskell-process-log*\" buffer." - :type 'boolean - :group 'haskell-interactive) - -(defcustom haskell-process-show-debug-tips - t - "Show debugging tips when starting the process." - :type 'boolean - :group 'haskell-interactive) - -(defcustom haskell-notify-p - nil - "Notify using notifications.el (if loaded)?" - :type 'boolean - :group 'haskell-interactive) - -(defcustom haskell-process-suggest-no-warn-orphans - t - "Suggest adding -fno-warn-orphans pragma to file when getting orphan warnings." - :type 'boolean - :group 'haskell-interactive) - -(defcustom haskell-process-suggest-hoogle-imports - nil - "Suggest to add import statements using Hoogle as a backend." - :type 'boolean - :group 'haskell-interactive) - -(defcustom haskell-process-suggest-hayoo-imports - nil - "Suggest to add import statements using Hayoo as a backend." - :type 'boolean - :group 'haskell-interactive) - -(defcustom haskell-process-hayoo-query-url - "http://hayoo.fh-wedel.de/json/?query=%s" - "Query url for json hayoo results." - :type 'string - :group 'haskell-interactive) - -(defcustom haskell-process-suggest-haskell-docs-imports - nil - "Suggest to add import statements using haskell-docs as a backend." - :type 'boolean - :group 'haskell-interactive) - -(defcustom haskell-process-suggest-add-package - t - "Suggest to add packages to your .cabal file when Cabal says it -is a member of the hidden package, blah blah." - :type 'boolean - :group 'haskell-interactive) - -(defcustom haskell-process-suggest-language-pragmas - t - "Suggest adding LANGUAGE pragmas recommended by GHC." - :type 'boolean - :group 'haskell-interactive) - -(defcustom haskell-process-suggest-remove-import-lines - nil - "Suggest removing import lines as warned by GHC." - :type 'boolean - :group 'haskell-interactive) - -(defcustom haskell-process-suggest-overloaded-strings - t - "Suggest adding OverloadedStrings pragma to file when getting type mismatches with [Char]." - :type 'boolean - :group 'haskell-interactive) - -(defcustom haskell-process-check-cabal-config-on-load - t - "Check changes cabal config on loading Haskell files and -restart the GHCi process if changed.." - :type 'boolean - :group 'haskell-interactive) - -(defcustom haskell-process-prompt-restart-on-cabal-change - t - "Ask whether to restart the GHCi process when the Cabal file -has changed?" - :type 'boolean - :group 'haskell-interactive) - -(defcustom haskell-process-auto-import-loaded-modules - nil - "Auto import the modules reported by GHC to have been loaded?" - :type 'boolean - :group 'haskell-interactive) - -(defcustom haskell-process-reload-with-fbytecode - nil - "When using -fobject-code, auto reload with -fbyte-code (and -then restore the -fobject-code) so that all module info and -imports become available?" - :type 'boolean - :group 'haskell-interactive) - -(defcustom haskell-process-use-presentation-mode - nil - "Use presentation mode to show things like type info instead of - printing to the message area." - :type 'boolean - :group 'haskell-interactive) - -(defcustom haskell-process-suggest-restart - t - "Suggest restarting the process when it has died" - :type 'boolean - :group 'haskell-interactive) - -(defvar haskell-process-prompt-regex "\4") -(defvar haskell-reload-p nil) - -(defvar haskell-process-greetings +(defconst haskell-process-prompt-regex "\4" + "Used for delimiting command replies. 4 is End of Transmission.") + +(defvar haskell-reload-p nil + "Used internally for `haskell-process-loadish'.") + +(defconst haskell-process-greetings (list "Hello, Haskell!" "The lambdas must flow." "Hours of hacking await!" @@ -240,9 +47,9 @@ imports become available?" (expand-file-name "logo.svg" haskell-mode-pkg-base-dir) "Haskell logo for notifications.") - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Accessing commands -- using cl 'defstruct' + (cl-defstruct haskell-command "Data structure representing a command to be executed when with a custom state and three callback." @@ -260,963 +67,16 @@ imports become available?" ;; complete :: a -> Response -> () complete) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Accessing commands - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Specialised commands - -;;;###autoload -(defun haskell-process-generate-tags (&optional and-then-find-this-tag) - "Regenerate the TAGS table." - (interactive) - (let ((process (haskell-process))) - (haskell-process-queue-command - process - (make-haskell-command - :state (cons process and-then-find-this-tag) - :go (lambda (state) - (if (eq system-type 'windows-nt) - (haskell-process-send-string - (car state) - (format ":!powershell -Command \"& { cd %s ; hasktags -e -x (ls -fi *.hs -exclude \\\"#*#\\\" -name -r) ; exit }\"" - (haskell-session-cabal-dir - (haskell-process-session (car state))))) - (haskell-process-send-string - (car state) - (format ":!cd %s && %s | %s | %s" - (haskell-session-cabal-dir - (haskell-process-session (car state))) - "find . -name '*.hs*'" - "grep -v '#'" ; To avoid Emacs back-up files. Yeah. - "xargs hasktags -e -x")))) - :complete (lambda (state response) - (when (cdr state) - (let ((tags-file-name - (haskell-session-tags-filename - (haskell-process-session (car state))))) - (find-tag (cdr state)))) - (haskell-mode-message-line "Tags generated.")))))) - -;;;###autoload -(defun haskell-process-do-type (&optional insert-value) - "Print the type of the given expression." - (interactive "P") - (if insert-value - (haskell-process-insert-type) - (haskell-process-do-simple-echo - (let ((ident (haskell-ident-at-point))) - ;; TODO: Generalize all these `string-match' of ident calls into - ;; one function. - (format (if (string-match "^[_[:lower:][:upper:]]" ident) - ":type %s" - ":type (%s)") - ident)) - 'haskell-mode))) - -(defun haskell-process-insert-type () - "Get the identifer at the point and insert its type, if -possible, using GHCi's :type." - (let ((process (haskell-process)) - (query (let ((ident (haskell-ident-at-point))) - (format (if (string-match "^[_[:lower:][:upper:]]" ident) - ":type %s" - ":type (%s)") - ident)))) - (haskell-process-queue-command - process - (make-haskell-command - :state (list process query (current-buffer)) - :go (lambda (state) - (haskell-process-send-string (nth 0 state) - (nth 1 state))) - :complete (lambda (state response) - (cond - ;; TODO: Generalize this into a function. - ((or (string-match "^Top level" response) - (string-match "^" response)) - (message response)) - (t - (with-current-buffer (nth 2 state) - (goto-char (line-beginning-position)) - (insert (format "%s\n" (replace-regexp-in-string "\n$" "" response))))))))))) - -;;;###autoload -(defun haskell-process-do-info (&optional prompt-value) - "Print info on the identifier at point. -If PROMPT-VALUE is non-nil, request identifier via mini-buffer." - (interactive "P") - (haskell-process-do-simple-echo - (let ((ident (if prompt-value - (read-from-minibuffer "Info: " (haskell-ident-at-point)) - (haskell-ident-at-point))) - (modname (unless prompt-value - (haskell-utils-parse-import-statement-at-point)))) - (if modname - (format ":browse! %s" modname) - (format (if (string-match "^[a-zA-Z_]" ident) - ":info %s" - ":info (%s)") - (or ident - (haskell-ident-at-point))))) - 'haskell-mode)) - -(defun haskell-process-do-try-info (sym) - "Get info of `sym' and echo in the minibuffer." - (let ((process (haskell-process))) - (haskell-process-queue-command - process - (make-haskell-command - :state (cons process sym) - :go (lambda (state) - (haskell-process-send-string - (car state) - (if (string-match "^[A-Za-z_]" (cdr state)) - (format ":info %s" (cdr state)) - (format ":info (%s)" (cdr state))))) - :complete (lambda (state response) - (unless (or (string-match "^Top level" response) - (string-match "^" response)) - (haskell-mode-message-line response))))))) - -(defun haskell-process-do-try-type (sym) - "Get type of `sym' and echo in the minibuffer." - (let ((process (haskell-process))) - (haskell-process-queue-command - process - (make-haskell-command - :state (cons process sym) - :go (lambda (state) - (haskell-process-send-string - (car state) - (if (string-match "^[A-Za-z_]" (cdr state)) - (format ":type %s" (cdr state)) - (format ":type (%s)" (cdr state))))) - :complete (lambda (state response) - (unless (or (string-match "^Top level" response) - (string-match "^" response)) - (haskell-mode-message-line response))))))) - -(defun haskell-process-do-simple-echo (line &optional mode) - "Send LINE to the GHCi process and echo the result in some -fashion, such as printing in the minibuffer, or using -haskell-present, depending on configuration." - (let ((process (haskell-process))) - (haskell-process-queue-command - process - (make-haskell-command - :state (list process line mode) - :go (lambda (state) - (haskell-process-send-string (car state) (cadr state))) - :complete (lambda (state response) - ;; TODO: TBD: don't do this if - ;; `haskell-process-use-presentation-mode' is t. - (haskell-interactive-mode-echo - (haskell-process-session (car state)) - response - (cl-caddr state)) - (if haskell-process-use-presentation-mode - (progn (haskell-present (cadr state) - (haskell-process-session (car state)) - response) - (haskell-session-assign - (haskell-process-session (car state)))) - (haskell-mode-message-line response))))))) - -(defun haskell-process-look-config-changes (session) - "Checks whether a cabal configuration file has -changed. Restarts the process if that is the case." - (let ((current-checksum (haskell-session-get session 'cabal-checksum)) - (new-checksum (haskell-cabal-compute-checksum - (haskell-session-get session 'cabal-dir)))) - (when (not (string= current-checksum new-checksum)) - (haskell-interactive-mode-echo session (format "Cabal file changed: %s" new-checksum)) - (haskell-session-set-cabal-checksum session - (haskell-session-get session 'cabal-dir)) - (unless (and haskell-process-prompt-restart-on-cabal-change - (not (y-or-n-p "Cabal file changed; restart GHCi process? "))) - (haskell-process-start (haskell-session)))))) - -;;;###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))) - -;;;###autoload -(defun haskell-process-reload-file () - "Re-load the current buffer file." - (interactive) - (save-buffer) - (haskell-interactive-mode-reset-error (haskell-session)) - (haskell-process-file-loadish "reload" t nil)) - -;;;###autoload -(defun haskell-process-load-or-reload (&optional toggle) - "Load or reload. Universal argument toggles which." - (interactive "P") - (if toggle - (progn (setq haskell-reload-p (not haskell-reload-p)) - (message "%s (No action taken this time)" - (if haskell-reload-p - "Now running :reload." - "Now running :load ."))) - (if haskell-reload-p (haskell-process-reload-file) (haskell-process-load-file)))) - -(defun haskell-process-file-loadish (command reload-p module-buffer) - "Run a loading-ish COMMAND that wants to pick up type errors -and things like that. RELOAD-P indicates whether the notification -should say 'reloaded' or 'loaded'. MODULE-BUFFER may be used -for various things, but is optional." - (let ((session (haskell-session))) - (haskell-session-current-dir session) - (when haskell-process-check-cabal-config-on-load - (haskell-process-look-config-changes session)) - (let ((process (haskell-process))) - (haskell-process-queue-command - process - (make-haskell-command - :state (list session process command reload-p module-buffer) - :go (lambda (state) - (haskell-process-send-string - (cadr state) (format ":%s" (cl-caddr state)))) - :live (lambda (state buffer) - (haskell-process-live-build - (cadr state) buffer nil)) - :complete (lambda (state response) - (haskell-process-load-complete - (car state) - (cadr state) - response - (cl-cadddr state) - (cl-cadddr (cdr state))))))))) - -;;;###autoload -(defun haskell-process-cabal-build () - "Build the Cabal project." - (interactive) - (haskell-process-do-cabal "build") - (haskell-process-add-cabal-autogen)) - -;;;###autoload -(defun haskell-process-cabal (p) - "Prompts for a Cabal command to run." - (interactive "P") - (if p - (haskell-process-do-cabal - (read-from-minibuffer "Cabal command (e.g. install): ")) - (haskell-process-do-cabal - (funcall haskell-completing-read-function "Cabal command: " - (append haskell-cabal-commands - (list "build --ghc-options=-fforce-recomp")))))) - -(defun haskell-process-add-cabal-autogen () - "Add /dist/build/autogen/ to the ghci search -path. This allows modules such as 'Path_...', generated by cabal, -to be loaded by ghci." - (unless (eq 'cabal-repl (haskell-process-type)) ;; redundant with "cabal repl" - (let* - ((session (haskell-session)) - (cabal-dir (haskell-session-cabal-dir session)) - (ghci-gen-dir (format "%sdist/build/autogen/" cabal-dir))) - (haskell-process-queue-without-filters - (haskell-process) - (format ":set -i%s" ghci-gen-dir))))) - -(defun haskell-process-type () - "Return `haskell-process-type', or a guess if that variable is 'auto." - (if (eq 'auto haskell-process-type) - (if (locate-dominating-file - default-directory - (lambda (d) - (or (file-directory-p (expand-file-name ".cabal-sandbox" d)) - (cl-find-if (lambda (f) (string-match-p ".\\.cabal\\'" f)) (directory-files d))))) - 'cabal-repl - 'ghci) - haskell-process-type)) - -(defun haskell-process-do-cabal (command) - "Run a Cabal command." - (let ((process (haskell-process))) - (haskell-process-queue-command - process - (make-haskell-command - :state (list (haskell-session) process command 0) - - :go - (lambda (state) - (haskell-process-send-string - (cadr state) - (format haskell-process-do-cabal-format-string - (haskell-session-cabal-dir (car state)) - (format "%s %s" - (cl-ecase (haskell-process-type) - ('ghci haskell-process-path-cabal) - ('cabal-repl haskell-process-path-cabal) - ('cabal-ghci haskell-process-path-cabal) - ('cabal-dev haskell-process-path-cabal-dev)) - (cl-caddr state))))) - - :live - (lambda (state buffer) - (let ((cmd (replace-regexp-in-string "^\\([a-z]+\\).*" - "\\1" - (cl-caddr state)))) - (cond ((or (string= cmd "build") - (string= cmd "install")) - (haskell-process-live-build (cadr state) buffer t)) - (t - (haskell-process-cabal-live state buffer))))) - - :complete - (lambda (state response) - (let* ((process (cadr state)) - (session (haskell-process-session process)) - (message-count 0) - (cursor (haskell-process-response-cursor process))) - (haskell-process-set-response-cursor process 0) - (while (haskell-process-errors-warnings session process response) - (setq message-count (1+ message-count))) - (haskell-process-set-response-cursor process cursor) - (let ((msg (format "Complete: cabal %s (%s compiler messages)" - (cl-caddr state) - message-count))) - (haskell-interactive-mode-echo session msg) - (when (= message-count 0) - (haskell-interactive-mode-echo - session - "No compiler messages, dumping complete output:") - (haskell-interactive-mode-echo session response)) - (haskell-mode-message-line msg) - (when (and haskell-notify-p - (fboundp 'notifications-notify)) - (notifications-notify - :title (format "*%s*" (haskell-session-name (car state))) - :body msg - :app-name (cl-ecase (haskell-process-type) - ('ghci haskell-process-path-cabal) - ('cabal-repl haskell-process-path-cabal) - ('cabal-ghci haskell-process-path-cabal) - ('cabal-dev haskell-process-path-cabal-dev)) - :app-icon haskell-process-logo - ))))))))) - -(defun haskell-process-cabal-live (state buffer) - "Do live updates for Cabal processes." - (haskell-interactive-mode-insert - (haskell-process-session (cadr state)) - (replace-regexp-in-string - haskell-process-prompt-regex - "" - (substring buffer (cl-cadddr state)))) - (setf (cl-cdddr state) (list (length buffer))) - nil) - -(defun haskell-process-load-complete (session process buffer reload module-buffer &optional cont) - "Handle the complete loading response. BUFFER is the string of -text being sent over the process pipe. MODULE-BUFFER is the -actual Emacs buffer of the module being loaded." - (cond ((haskell-process-consume process "Ok, modules loaded: \\(.+\\)\\.$") - (let* ((modules (haskell-process-extract-modules buffer)) - (cursor (haskell-process-response-cursor process))) - (haskell-process-set-response-cursor process 0) - (let ((warning-count 0)) - (while (haskell-process-errors-warnings session process buffer) - (setq warning-count (1+ warning-count))) - (haskell-process-set-response-cursor process cursor) - (if (and (not reload) - haskell-process-reload-with-fbytecode) - (haskell-process-reload-with-fbytecode process module-buffer) - (haskell-process-import-modules process (car modules))) - (haskell-mode-message-line - (if reload "Reloaded OK." "OK.")) - (when cont - (condition-case e - (funcall cont t) - (error (message "%S" e)) - (quit nil)))))) - ((haskell-process-consume process "Failed, modules loaded: \\(.+\\)\\.$") - (let* ((modules (haskell-process-extract-modules buffer)) - (cursor (haskell-process-response-cursor process))) - (haskell-process-set-response-cursor process 0) - (while (haskell-process-errors-warnings session process buffer)) - (haskell-process-set-response-cursor process cursor) - (if (and (not reload) haskell-process-reload-with-fbytecode) - (haskell-process-reload-with-fbytecode process module-buffer) - (haskell-process-import-modules process (car modules))) - (haskell-interactive-mode-compile-error session "Compilation failed.") - (when cont - (condition-case e - (funcall cont nil) - (error (message "%S" e)) - (quit nil))))))) - -(defun haskell-process-reload-with-fbytecode (process module-buffer) - "Reload FILE-NAME with -fbyte-code set, and then restore -fobject-code." - (haskell-process-queue-without-filters process ":set -fbyte-code") - (haskell-process-touch-buffer process module-buffer) - (haskell-process-queue-without-filters process ":reload") - (haskell-process-queue-without-filters process ":set -fobject-code")) - -(defun haskell-process-touch-buffer (process buffer) - "Updates mtime on the file for BUFFER by queing a touch on -PROCESS." - (interactive) - (haskell-process-queue-command - process - (make-haskell-command - :state (cons process buffer) - :go (lambda (state) - (haskell-process-send-string - (car state) - (format ":!%s %s" - "touch" - (shell-quote-argument (buffer-file-name - (cdr state)))))) - :complete (lambda (state _) - (with-current-buffer (cdr state) - (clear-visited-file-modtime)))))) - -(defun haskell-process-extract-modules (buffer) - "Extract the modules from the process buffer." - (let* ((modules-string (match-string 1 buffer)) - (modules (split-string modules-string ", "))) - (cons modules modules-string))) - -(defun haskell-process-import-modules (process modules) - "Import `modules' with :m +, and send any import statements -from `module-buffer'." - (when haskell-process-auto-import-loaded-modules - (haskell-process-queue-command - process - (make-haskell-command - :state (cons process modules) - :go (lambda (state) - (haskell-process-send-string - (car state) - (format ":m + %s" (mapconcat 'identity (cdr state) " ")))))))) - -(defun haskell-process-live-build (process buffer echo-in-repl) - "Show live updates for loading files." - (cond ((haskell-process-consume - process - (concat "\\[[ ]*\\([0-9]+\\) of \\([0-9]+\\)\\]" - " Compiling \\([^ ]+\\)[ ]+" - "( \\([^ ]+\\), \\([^ ]+\\) )[^\r\n]*[\r\n]+")) - (haskell-process-echo-load-message process buffer echo-in-repl nil) - t) - ((haskell-process-consume - process - (concat "\\[[ ]*\\([0-9]+\\) of \\([0-9]+\\)\\]" - " Compiling \\[TH\\] \\([^ ]+\\)[ ]+" - "( \\([^ ]+\\), \\([^ ]+\\) )[^\r\n]*[\r\n]+")) - (haskell-process-echo-load-message process buffer echo-in-repl t) - t) - ((haskell-process-consume process "Loading package \\([^ ]+\\) ... linking ... done.\n") - (haskell-mode-message-line - (format "Loading: %s" - (match-string 1 buffer))) - t) - ((haskell-process-consume - process - "^Preprocessing executables for \\(.+?\\)\\.\\.\\.") - (let ((msg (format "Preprocessing: %s" (match-string 1 buffer)))) - (haskell-interactive-mode-echo - (haskell-process-session process) - msg) - (haskell-mode-message-line msg))) - ((haskell-process-consume process "Linking \\(.+?\\) \\.\\.\\.") - (let ((msg (format "Linking: %s" (match-string 1 buffer)))) - (haskell-interactive-mode-echo (haskell-process-session process) msg) - (haskell-mode-message-line msg))) - ((haskell-process-consume process "\nBuilding \\(.+?\\)\\.\\.\\.") - (let ((msg (format "Building: %s" (match-string 1 buffer)))) - (haskell-interactive-mode-echo - (haskell-process-session process) - msg) - (haskell-mode-message-line msg))))) - -(defun haskell-process-echo-load-message (process buffer echo-in-repl th) - "Echo a load message." - (let ((session (haskell-process-session process)) - (module-name (match-string 3 buffer)) - (file-name (match-string 4 buffer))) - (haskell-interactive-show-load-message - session - 'compiling - module-name - (haskell-session-strip-dir session file-name) - echo-in-repl - th))) - -(defun haskell-process-errors-warnings (session process buffer) - "Trigger handling type errors or warnings." - (cond - ((haskell-process-consume - process - "\\(Module imports form a cycle:[ \n]+module [^ ]+ ([^)]+)[[:unibyte:][:nonascii:]]+?\\)\nFailed") - (let ((err (match-string 1 buffer))) - (when (string-match "module [`'‘‛]\\([^ ]+\\)['’`] (\\([^)]+\\))" err) - (let* ((default-directory (haskell-session-current-dir session)) - (module (match-string 1 err)) - (file (match-string 2 err)) - (relative-file-name (file-relative-name file))) - (haskell-interactive-show-load-message - session - 'import-cycle - module - relative-file-name - nil - nil) - (haskell-interactive-mode-compile-error - session - (format "%s:1:0: %s" - relative-file-name - err))))) - t) - ((haskell-process-consume - process - (concat "[\r\n]\\([A-Z]?:?[^ \r\n:][^:\n\r]+\\):\\([0-9()-:]+\\):" - "[ \n\r]+\\([[:unibyte:][:nonascii:]]+?\\)\n[^ ]")) - (haskell-process-set-response-cursor process - (- (haskell-process-response-cursor process) 1)) - (let* ((buffer (haskell-process-response process)) - (file (match-string 1 buffer)) - (location (match-string 2 buffer)) - (error-msg (match-string 3 buffer)) - (warning (string-match "^Warning:" error-msg)) - (splice (string-match "^Splicing " error-msg)) - (final-msg (format "%s:%s: %s" - (haskell-session-strip-dir session file) - location - error-msg))) - (funcall (cond (warning - 'haskell-interactive-mode-compile-warning) - (splice - 'haskell-interactive-mode-compile-splice) - (t 'haskell-interactive-mode-compile-error)) - session final-msg) - (unless warning - (haskell-mode-message-line final-msg)) - (haskell-process-trigger-suggestions - session - error-msg - file - (plist-get (haskell-process-parse-error final-msg) :line))) - t))) - -(defun haskell-process-parse-error (string) - "Parse the line number from the error." - (let ((span nil)) - (cl-loop for regex - in haskell-compilation-error-regexp-alist - do (when (string-match (car regex) string) - (setq span - (list :file (match-string 1 string) - :line (string-to-number (match-string 2 string)) - :col (string-to-number (match-string 4 string)) - :line2 (when (match-string 3 string) - (string-to-number (match-string 3 string))) - :col2 (when (match-string 5 string) - (string-to-number (match-string 5 string))))))) - span)) - -(defun haskell-process-trigger-suggestions (session msg file line) - "Trigger prompting to add any extension suggestions." - (cond ((let ((case-fold-search nil)) - (or (and (string-match " -X\\([A-Z][A-Za-z]+\\)" msg) - (not (string-match "\\([A-Z][A-Za-z]+\\) is deprecated" msg))) - (string-match "Use \\([A-Z][A-Za-z]+\\) to permit this" msg) - (string-match "Use \\([A-Z][A-Za-z]+\\) to allow" msg) - (string-match "use \\([A-Z][A-Za-z]+\\)" msg) - (string-match "You need \\([A-Z][A-Za-z]+\\)" msg))) - (when haskell-process-suggest-language-pragmas - (haskell-process-suggest-pragma session "LANGUAGE" (match-string 1 msg) file))) - ((string-match " The \\(qualified \\)?import of[ ][‘`‛]\\([^ ]+\\)['’] is redundant" msg) - (when haskell-process-suggest-remove-import-lines - (haskell-process-suggest-remove-import session - file - (match-string 2 msg) - line))) - ((string-match "Warning: orphan instance: " msg) - (when haskell-process-suggest-no-warn-orphans - (haskell-process-suggest-pragma session "OPTIONS" "-fno-warn-orphans" file))) - ((or (string-match "against inferred type [‘`‛]\\[Char\\]['’]" msg) - (string-match "with actual type [‘`‛]\\[Char\\]['’]" msg)) - (when haskell-process-suggest-overloaded-strings - (haskell-process-suggest-pragma session "LANGUAGE" "OverloadedStrings" file))) - ((string-match "^Not in scope: .*[‘`‛]\\(.+\\)['’]$" msg) - (let* ((match1 (match-string 1 msg)) - (ident (if (string-match "^[A-Za-z0-9_'.]+\\.\\(.+\\)$" match1) - ;; Skip qualification. - (match-string 1 match1) - match1))) - (when haskell-process-suggest-hoogle-imports - (let ((modules (haskell-process-hoogle-ident ident))) - (haskell-process-suggest-imports session file modules ident))) - (when haskell-process-suggest-haskell-docs-imports - (let ((modules (haskell-process-haskell-docs-ident ident))) - (haskell-process-suggest-imports session file modules ident))) - (when haskell-process-suggest-hayoo-imports - (let ((modules (haskell-process-hayoo-ident ident))) - (haskell-process-suggest-imports session file modules ident))))) - ((string-match "^[ ]+It is a member of the hidden package [‘`‛]\\(.+\\)['’].$" msg) - (when haskell-process-suggest-add-package - (haskell-process-suggest-add-package session msg))))) - -(defun haskell-process-suggest-add-package (session msg) - "Add the (matched) module to your cabal file." - (let* ((suggested-package (match-string 1 msg)) - (package-name (replace-regexp-in-string "-[^-]+$" "" suggested-package)) - (version (progn (string-match "\\([^-]+\\)$" suggested-package) - (match-string 1 suggested-package))) - (cabal-file (concat (haskell-session-name session) - ".cabal"))) - (when (y-or-n-p - (format "Add `%s' to %s?" - package-name - cabal-file)) - (haskell-cabal-add-dependency package-name version nil t)))) - -(defun haskell-process-suggest-imports (session file modules ident) - "Given a list of MODULES, suggest adding them to the import section." - (cl-assert session) - (cl-assert file) - (cl-assert ident) - (let* ((process (haskell-session-process session)) - (suggested-already (haskell-process-suggested-imports process)) - (module (cond ((> (length modules) 1) - (when (y-or-n-p (format "Identifier `%s' not in scope, choose module to import?" - ident)) - (haskell-complete-module-read "Module: " modules))) - ((= (length modules) 1) - (let ((module (car modules))) - (unless (member module suggested-already) - (haskell-process-set-suggested-imports process (cons module suggested-already)) - (when (y-or-n-p (format "Identifier `%s' not in scope, import `%s'?" - ident - module)) - module))))))) - (when module - (haskell-process-find-file session file) - (save-excursion - (goto-char (point-max)) - (haskell-navigate-imports) - (insert (read-from-minibuffer "Import line: " (concat "import " module)) - "\n") - (haskell-sort-imports) - (haskell-align-imports))))) - -(defun haskell-process-haskell-docs-ident (ident) - "Search with haskell-docs for IDENT, returns a list of modules." - (cl-remove-if-not (lambda (a) (string-match "^[A-Z][A-Za-b0-9_'.]+$" a)) - (split-string (shell-command-to-string (concat "haskell-docs --modules " ident)) - "\n"))) - -(defun haskell-process-hoogle-ident (ident) - "Hoogle for IDENT, returns a list of modules." - (with-temp-buffer - (let ((hoogle-error (call-process "hoogle" nil t nil "search" "--exact" ident))) - (goto-char (point-min)) - (unless (or (/= 0 hoogle-error) - (looking-at "^No results found") - (looking-at "^package ")) - (while (re-search-forward "^\\([^ ]+\\).*$" nil t) - (replace-match "\\1" nil nil)) - (cl-remove-if (lambda (a) (string= "" a)) - (split-string (buffer-string) - "\n")))))) - -(defvar url-http-response-status) -(defvar url-http-end-of-headers) - -(defun haskell-process-hayoo-ident (ident) - "Hayoo for IDENT, returns a list of modules asyncronously through CALLBACK." - ;; We need a real/simulated closure, because otherwise these - ;; variables will be unbound when the url-retrieve callback is - ;; called. - ;; TODO: Remove when this code is converted to lexical bindings by - ;; default (Emacs 24.1+) - (let ((url (format haskell-process-hayoo-query-url (url-hexify-string ident)))) - (with-current-buffer (url-retrieve-synchronously url) - (if (= 200 url-http-response-status) - (progn - (goto-char url-http-end-of-headers) - (let* ((res (json-read)) - (results (assoc-default 'result res))) - ;; TODO: gather packages as well, and when we choose a - ;; given import, check that we have the package in the - ;; cabal file as well. - (cl-mapcan (lambda (r) - ;; append converts from vector -> list - (append (assoc-default 'resultModules r) nil)) - results))) - (warn "HTTP error %s fetching %s" url-http-response-status url))))) - -(defun haskell-process-suggest-remove-import (session file import line) - "Suggest removing or commenting out IMPORT on LINE." - (let ((continue t) - (first t)) - (cl-case (read-event - (propertize (format "%sThe import line `%s' is redundant. Remove? (y, n, c: comment out) " - (if (not first) - "Please answer n, y or c: " - "") - import) - 'face 'minibuffer-prompt)) - (?y - (haskell-process-find-file session file) - (save-excursion - (goto-char (point-min)) - (forward-line (1- line)) - (goto-char (line-beginning-position)) - (delete-region (line-beginning-position) - (line-end-position)))) - (?n - (message "Ignoring redundant import %s" import)) - (?c - (haskell-process-find-file session file) - (save-excursion - (goto-char (point-min)) - (forward-line (1- line)) - (goto-char (line-beginning-position)) - (insert "-- ")))))) - -(defun haskell-process-suggest-pragma (session pragma extension file) - "Suggest to add something to the top of the file." - (let ((string (format "{-# %s %s #-}" pragma extension))) - (when (y-or-n-p (format "Add %s to the top of the file? " string)) - (haskell-process-find-file session file) - (save-excursion - (goto-char (point-min)) - (insert (concat string "\n")))))) - -(defun haskell-process-find-file (session file) - "Find the given file in the project." - (find-file (cond ((file-exists-p (concat (haskell-session-current-dir session) "/" file)) - (concat (haskell-session-current-dir session) "/" file)) - ((file-exists-p (concat (haskell-session-cabal-dir session) "/" file)) - (concat (haskell-session-cabal-dir session) "/" file)) - (t file)))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Building the process -;;;###autoload -(defun haskell-process-start (session) - "Start the inferior Haskell process." - (let ((existing-process (get-process (haskell-session-name (haskell-session))))) - (when (processp existing-process) - (haskell-interactive-mode-echo session "Restarting process ...") - (haskell-process-set (haskell-session-process session) 'is-restarting t) - (delete-process existing-process))) - (let ((process (or (haskell-session-process session) - (haskell-process-make (haskell-session-name session)))) - (old-queue (haskell-process-get (haskell-session-process session) - 'command-queue))) - (haskell-session-set-process session process) - (haskell-process-set-session process session) - (haskell-process-set-cmd process nil) - (haskell-process-set (haskell-session-process session) 'is-restarting nil) - (let ((default-directory (haskell-session-cabal-dir session))) - (haskell-session-pwd session) - (haskell-process-set-process - process - (cl-ecase (haskell-process-type) - ('ghci - (haskell-process-log - (propertize (format "Starting inferior GHCi process %s ..." - haskell-process-path-ghci) - 'face font-lock-comment-face)) - (apply #'start-process - (append (list (haskell-session-name session) - nil - haskell-process-path-ghci) - haskell-process-args-ghci))) - ('cabal-repl - (haskell-process-log - (propertize - (format "Starting inferior `cabal repl' process using %s ..." - haskell-process-path-cabal) - 'face font-lock-comment-face)) - - (apply #'start-process - (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 - (haskell-process-log - (propertize - (format "Starting inferior cabal-ghci process using %s ..." - haskell-process-path-cabal-ghci) - 'face font-lock-comment-face)) - (start-process (haskell-session-name session) - nil - haskell-process-path-cabal-ghci)) - ('cabal-dev - (let ((dir (concat (haskell-session-cabal-dir session) - "/cabal-dev"))) - (haskell-process-log - (propertize (format "Starting inferior cabal-dev process %s -s %s ..." - haskell-process-path-cabal-dev - dir) - 'face font-lock-comment-face)) - (start-process (haskell-session-name session) - nil - haskell-process-path-cabal-dev - "ghci" - "-s" - dir)))))) - (progn (set-process-sentinel (haskell-process-process process) 'haskell-process-sentinel) - (set-process-filter (haskell-process-process process) 'haskell-process-filter)) - (haskell-process-send-startup process) - (unless (eq 'cabal-repl (haskell-process-type)) ;; "cabal repl" sets the proper CWD - (haskell-process-change-dir session - process - (haskell-session-current-dir session))) - (haskell-process-set process 'command-queue - (append (haskell-process-get (haskell-session-process session) - 'command-queue) - old-queue)) - process)) - -(defun haskell-process-clear () - "Clear the current process." - (interactive) - (haskell-process-reset (haskell-process)) - (haskell-process-set (haskell-process) 'command-queue nil)) - -(defun haskell-process-restart () - "Restart the inferior Haskell process." - (interactive) - (haskell-process-reset (haskell-process)) - (haskell-process-set (haskell-process) 'command-queue nil) - (haskell-process-start (haskell-session))) - -(defun haskell-kill-session-process (&optional session) - "Kill the process." - (interactive) - (let* ((session (or session (haskell-session))) - (existing-process (get-process (haskell-session-name session)))) - (when (processp existing-process) - (haskell-interactive-mode-echo session "Killing process ...") - (haskell-process-set (haskell-session-process session) 'is-restarting t) - (delete-process existing-process)))) - (defun haskell-process-make (name) "Make an inferior Haskell process." (list (cons 'name name))) -;;;###autoload -(defun haskell-process () - "Get the current process from the current session." - (haskell-session-process (haskell-session))) - -(defun haskell-process-interrupt () - "Interrupt the process (SIGINT)." - (interactive) - (interrupt-process (haskell-process-process (haskell-process)))) - -(defun haskell-process-cd (&optional not-interactive) - "Change directory." - (interactive) - (let* ((session (haskell-session)) - (dir (haskell-session-pwd session t))) - (haskell-process-log - (propertize (format "Changing directory to %s ...\n" dir) - 'face font-lock-comment-face)) - (haskell-process-change-dir session - (haskell-process) - dir))) - -(defun haskell-session-pwd (session &optional change) - "Prompt for the current directory." - (or (unless change - (haskell-session-get session 'current-dir)) - (progn (haskell-session-set-current-dir - session - (haskell-utils-read-directory-name - (if change "Change directory: " "Set current directory: ") - (or (haskell-session-get session 'current-dir) - (haskell-session-get session 'cabal-dir) - (if (buffer-file-name) - (file-name-directory (buffer-file-name)) - "~/")))) - (haskell-session-get session 'current-dir)))) - -(defun haskell-process-change-dir (session process dir) - "Change the directory of the current process." - (haskell-process-queue-command - process - (make-haskell-command - :state (list session process dir) - - :go - (lambda (state) - (haskell-process-send-string - (cadr state) (format ":cd %s" (cl-caddr state)))) - - :complete - (lambda (state _) - (haskell-session-set-current-dir (car state) (cl-caddr state)) - (haskell-interactive-mode-echo (car state) - (format "Changed directory: %s" - (cl-caddr state))))))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Process communication -(defun haskell-process-send-startup (process) - "Send the necessary start messages." - (haskell-process-queue-command - process - (make-haskell-command - :state process - - :go (lambda (process) - (haskell-process-send-string process ":set prompt \"\\4\"") - (haskell-process-send-string process "Prelude.putStrLn \"\"") - (haskell-process-send-string process ":set -v1")) - - :live (lambda (process buffer) - (when (haskell-process-consume - process - "^\*\*\* WARNING: \\(.+\\) is writable by someone else, IGNORING!$") - (let ((path (match-string 1 buffer))) - (haskell-session-modify - (haskell-process-session process) - 'ignored-files - (lambda (files) - (cl-remove-duplicates (cons path files) :test 'string=))) - (haskell-interactive-mode-compile-warning - (haskell-process-session process) - (format "GHCi is ignoring: %s (run M-x haskell-process-unignore)" - path))))) - - :complete (lambda (process _) - (haskell-interactive-mode-echo - (haskell-process-session process) - (concat (nth (random (length haskell-process-greetings)) - haskell-process-greetings) - (when haskell-process-show-debug-tips - " -If I break, you can: - 1. Restart: M-x haskell-process-restart - 2. Configure logging: C-h v haskell-process-log (useful for debugging) - 3. General config: M-x customize-mode - 4. Hide these tips: C-h v haskell-process-show-debug-tips"))))))) - (defun haskell-process-sentinel (proc event) "The sentinel for the process pipe." (let ((session (haskell-process-project-by-proc proc))) @@ -1229,7 +89,7 @@ If I break, you can: (haskell-process-log (propertize "Process reset.\n" 'face font-lock-comment-face)) - (haskell-process-prompt-restart process)))))) + (run-hook-with-args 'haskell-process-ended-hook process)))))) (defun haskell-process-filter (proc response) "The filter for the process pipe." @@ -1247,8 +107,7 @@ If I break, you can: (haskell-process-collect session response (haskell-session-process session)) - (haskell-interactive-mode-insert-garbage - session + (haskell-process-log (replace-regexp-in-string "\4" "" response)))))) (defun haskell-process-log (msg) @@ -1306,26 +165,7 @@ If I break, you can: 'face '((:weight bold)))) (process-send-string child out)) (unless (haskell-process-restarting process) - (haskell-process-prompt-restart process))))) - -(defun haskell-process-prompt-restart (process) - "Prompt to restart the died process." - (let ((process-name (haskell-process-name process))) - (if haskell-process-suggest-restart - (cl-case (read-event - (propertize (format "The Haskell process `%s' has died. Restart? (y, n, l: show process log)" - process-name) - 'face 'minibuffer-prompt)) - (?y (haskell-process-start (haskell-process-session process))) - (?l (let* ((response (haskell-process-response process)) - (buffer (get-buffer "*haskell-process-log*"))) - (if buffer - (switch-to-buffer buffer) - (progn (switch-to-buffer (get-buffer-create "*haskell-process-log*")) - (insert response))))) - (?n)) - (message (format "The Haskell process `%s' is dearly departed." - process-name))))) + (run-hook-with-args 'haskell-process-ended process))))) (defun haskell-process-live-updates (process) "Process live updates." @@ -1361,8 +201,8 @@ the response." (haskell-process-set-cmd process cmd) (haskell-command-exec-go cmd)))) (progn (haskell-process-reset process) - (haskell-process-set (haskell-process) 'command-queue nil) - (haskell-process-prompt-restart process)))) + (haskell-process-set process 'command-queue nil) + (run-hook-with-args 'haskell-process-ended process)))) (defun haskell-process-queue-flushed-p (process) "Return t if command queue has been completely processed." @@ -1528,71 +368,6 @@ Returns nil if queue is empty." (haskell-process-set process 'command-queue (cdr queue)) (car queue)))) -(defun haskell-process-unignore () - "Unignore any files that were specified as being ignored by the - inferior GHCi process." - (interactive) - (let ((session (haskell-session)) - (changed nil)) - (if (null (haskell-session-get session - 'ignored-files)) - (message "Nothing to unignore!") - (cl-loop for file in (haskell-session-get session - 'ignored-files) - do (cl-case (read-event - (propertize (format "Set permissions? %s (y, n, v: stop and view file)" - file) - 'face 'minibuffer-prompt)) - (?y - (haskell-process-unignore-file session file) - (setq changed t)) - (?v - (find-file file) - (cl-return)))) - (when (and changed - (y-or-n-p "Restart GHCi process now? ")) - (haskell-process-restart))))) - -(defun haskell-process-reload-devel-main () - "Reload the module `DevelMain' and then run -`DevelMain.update'. This is for doing live update of the code of -servers or GUI applications. Put your development version of the -program in `DevelMain', and define `update' to auto-start the -program on a new thread, and use the `foreign-store' package to -access the running context across :load/:reloads in GHCi." - (interactive) - (with-current-buffer (or (get-buffer "DevelMain.hs") - (if (y-or-n-p "You need to open a buffer named DevelMain.hs. Find now?") - (ido-find-file) - (error "No DevelMain.hs buffer."))) - (let ((session (haskell-session))) - (let ((process (haskell-process))) - (haskell-process-queue-command - process - (make-haskell-command - :state (list :session session - :process process - :buffer (current-buffer)) - :go (lambda (state) - (haskell-process-send-string (plist-get state ':process) - ":l DevelMain")) - :live (lambda (state buffer) - (haskell-process-live-build (plist-get state ':process) - buffer - nil)) - :complete (lambda (state response) - (haskell-process-load-complete - (plist-get state ':session) - (plist-get state ':process) - response - nil - (plist-get state ':buffer) - (lambda (ok) - (when ok - (haskell-process-queue-without-filters - (haskell-process) - "DevelMain.update") - (message "DevelMain updated."))))))))))) (defun haskell-process-unignore-file (session file) " @@ -1615,7 +390,7 @@ function and remove this comment. (concat "chmod 700 " file))) (haskell-session-modify - (haskell-session) + session 'ignored-files (lambda (files) (cl-remove-if (lambda (path) @@ -1647,31 +422,6 @@ function and remove this comment. (haskell-command-state command) response)))) -(defun haskell-process-cabal-macros () - "Send the cabal macros string." - (interactive) - (haskell-process-queue-without-filters (haskell-process) - ":set -optP-include -optPdist/build/autogen/cabal_macros.h")) - -(defun haskell-process-minimal-imports () - "Dump minimal imports." - (interactive) - (unless (> (save-excursion - (goto-char (point-min)) - (haskell-navigate-imports-go) - (point)) - (point)) - (goto-char (point-min)) - (haskell-navigate-imports-go)) - (haskell-process-queue-sync-request (haskell-process) - ":set -ddump-minimal-imports") - (haskell-process-load-file) - (insert-file-contents-literally - (concat (haskell-session-current-dir (haskell-session)) - "/" - (haskell-guess-module-name) - ".imports"))) - (defvar interactive-haskell-mode-map (let ((map (make-sparse-keymap))) (define-key map (kbd "C-c C-l") 'haskell-process-load-or-reload) diff --git a/haskell-repl.el b/haskell-repl.el new file mode 100644 index 000000000..e057100c5 --- /dev/null +++ b/haskell-repl.el @@ -0,0 +1,117 @@ +;;; haskell-repl.el --- REPL evaluation + +;; Copyright (c) 2014 Chris Done. All rights reserved. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(require 'haskell-interactive-mode) + +(defun haskell-interactive-handle-expr () + "Handle an inputted expression at the REPL." + (when (haskell-interactive-at-prompt) + (let ((expr (haskell-interactive-mode-input))) + (unless (string= "" (replace-regexp-in-string " " "" expr)) + (cond + ;; If already evaluating, then the user is trying to send + ;; input to the REPL during evaluation. Most likely in + ;; response to a getLine-like function. + ((and (haskell-process-evaluating-p (haskell-interactive-process)) + (= (line-end-position) (point-max))) + (goto-char (point-max)) + (let ((process (haskell-interactive-process)) + (string (buffer-substring-no-properties + haskell-interactive-mode-result-end + (point)))) + (insert "\n") + ;; Bring the marker forward + (setq haskell-interactive-mode-result-end + (point-max)) + (haskell-process-set-sent-stdin process t) + (haskell-process-send-string process string))) + ;; Otherwise we start a normal evaluation call. + (t (setq haskell-interactive-mode-old-prompt-start + (copy-marker haskell-interactive-mode-prompt-start)) + (set-marker haskell-interactive-mode-prompt-start (point-max)) + (haskell-interactive-mode-history-add expr) + (haskell-interactive-mode-do-expr expr))))))) + +(defun haskell-interactive-mode-do-expr (expr) + (cond + ((string-match "^:present " expr) + (haskell-interactive-mode-do-presentation (replace-regexp-in-string "^:present " "" expr))) + (t + (haskell-interactive-mode-run-expr expr)))) + +(defun haskell-interactive-mode-run-expr (expr) + "Run the given expression." + (let ((session (haskell-interactive-session)) + (process (haskell-interactive-process)) + (lines (length (split-string expr "\n")))) + (haskell-process-queue-command + process + (make-haskell-command + :state (list session process expr 0) + :go (lambda (state) + (goto-char (point-max)) + (insert "\n") + (setq haskell-interactive-mode-result-end + (point-max)) + (haskell-process-send-string (cadr state) + (haskell-interactive-mode-multi-line (cl-caddr state))) + (haskell-process-set-evaluating (cadr state) t)) + :live (lambda (state buffer) + (unless (and (string-prefix-p ":q" (cl-caddr state)) + (string-prefix-p (cl-caddr state) ":quit")) + (let* ((cursor (cl-cadddr state)) + (next (replace-regexp-in-string + haskell-process-prompt-regex + "" + (substring buffer cursor)))) + (haskell-interactive-mode-eval-result (car state) next) + (setf (cl-cdddr state) (list (length buffer))) + nil))) + :complete + (lambda (state response) + (haskell-process-set-evaluating (cadr state) nil) + (unless (haskell-interactive-mode-trigger-compile-error state response) + (haskell-interactive-mode-expr-result state response))))))) + +(defun haskell-interactive-mode-expr-result (state response) + "Print the result of evaluating the expression." + (let ((response + (with-temp-buffer + (insert (haskell-interactive-mode-cleanup-response + (cl-caddr state) response)) + (haskell-interactive-mode-handle-h (point-min)) + (buffer-string)))) + (when haskell-interactive-mode-eval-mode + (unless (haskell-process-sent-stdin-p (cadr state)) + (haskell-interactive-mode-eval-as-mode (car state) response)))) + (haskell-interactive-mode-prompt (car state))) + +(defun haskell-interactive-mode-eval-as-mode (session text) + "Insert TEXT font-locked according to `haskell-interactive-mode-eval-mode'." + (with-current-buffer (haskell-session-interactive-buffer session) + (let ((inhibit-read-only t)) + (delete-region (1+ haskell-interactive-mode-prompt-start) (point)) + (goto-char (point-max)) + (let ((start (point))) + (insert (haskell-fontify-as-mode text + haskell-interactive-mode-eval-mode)) + (when haskell-interactive-mode-collapse + (haskell-collapse start (point))))))) + +(provide 'haskell-repl) diff --git a/haskell-session.el b/haskell-session.el index 5bb117caf..0d85ac2c8 100644 --- a/haskell-session.el +++ b/haskell-session.el @@ -27,29 +27,17 @@ ;;; Code: -(require 'cl-lib) (require 'haskell-cabal) (require 'haskell-string) -(require 'haskell-mode) - -(declare-function haskell-interactive-mode "haskell-interactive-mode" ()) -(declare-function haskell-kill-session-process "haskell-process" (&optional session)) -(declare-function haskell-process-start "haskell-process" (session)) -(declare-function haskell-process-cd "haskell-process" (&optional not-interactive)) -(declare-function haskell-process-type "haskell-process" ()) +(require 'haskell-customize) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Configuration +;; Globals -(defcustom haskell-ask-also-kill-buffers - t - "Ask whether to kill all associated buffers when a session - process is killed." - :type 'boolean - :group 'haskell-interactive) +;; Used internally +(defvar haskell-session) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Globals +(make-variable-buffer-local 'haskell-session) (defvar haskell-sessions (list) "All Haskell sessions in the Emacs session.") @@ -58,96 +46,9 @@ "Get the filename for the TAGS file." (concat (haskell-session-cabal-dir session) "/TAGS")) -;;;###autoload -(defun haskell-session-all-modules (&optional dontcreate) - "Get all modules -- installed or in the current project. -If DONTCREATE is non-nil don't create a new session." - (append (haskell-session-installed-modules dontcreate) - (haskell-session-project-modules dontcreate))) - -;;;###autoload -(defun haskell-session-installed-modules (&optional dontcreate) - "Get the modules installed in the current package set. -If DONTCREATE is non-nil don't create a new session." - ;; TODO: Again, this makes HEAVY use of unix utilities. It'll work - ;; fine in Linux, probably okay on OS X, and probably not at all on - ;; Windows. Again, if someone wants to test on Windows and come up - ;; with alternatives that's OK. - ;; - ;; Ideally all these package queries can be provided by a Haskell - ;; program based on the Cabal API. Possibly as a nice service. Such - ;; a service could cache and do nice things like that. For now, this - ;; simple shell script takes us far. - ;; - ;; Probably also we can take the code from inferior-haskell-mode. - ;; - ;; Ugliness aside, if it saves us time to type it's a winner. - ;; - ;; FIXME/TODO: add support for (eq 'cabal-repl (haskell-process-type)) - (let ((modules (shell-command-to-string - (format "%s | %s | %s" - (if (eq 'cabal-dev (haskell-process-type)) - (if (or (not dontcreate) (haskell-session-maybe)) - (format "cabal-dev -s %s/cabal-dev ghc-pkg dump" - (haskell-session-cabal-dir (haskell-session))) - "echo ''") - "ghc-pkg dump") - "egrep '^(exposed-modules: | )[A-Z]'" - "cut -c18-")))) - (split-string modules))) - -(defun haskell-session-project-modules (&optional dontcreate) - "Get the modules of the current project. -If DONTCREATE is non-nil don't create a new session." - (if (or (not dontcreate) (haskell-session-maybe)) - (let* ((session (haskell-session)) - (modules - (shell-command-to-string - (format "%s && %s" - (format "cd %s" (haskell-session-cabal-dir session)) - ;; TODO: Use a different, better source. Possibly hasktags or some such. - ;; TODO: At least make it cross-platform. Linux - ;; (and possibly OS X) have egrep, Windows - ;; doesn't -- or does it via Cygwin or MinGW? - ;; This also doesn't handle module\nName. But those gits can just cut it out! - "egrep '^module[\t\r ]+[^(\t\r ]+' . -r -I --include='*.*hs' --include='*.hsc' -s -o -h | sed 's/^module[\t\r ]*//' | sort | uniq")))) - (split-string modules)))) - -(defun haskell-session-kill (&optional leave-interactive-buffer) - "Kill the session process and buffer, delete the session. -0. Prompt to kill all associated buffers. -1. Kill the process. -2. Kill the interactive buffer. -3. Walk through all the related buffers and set their haskell-session to nil. -4. Remove the session from the sessions list." - (interactive) - (let* ((session (haskell-session)) - (name (haskell-session-name session)) - (also-kill-buffers - (and haskell-ask-also-kill-buffers - (y-or-n-p (format "Killing `%s'. Also kill all associated buffers?" name))))) - (haskell-kill-session-process session) - (unless leave-interactive-buffer - (kill-buffer (haskell-session-interactive-buffer session))) - (cl-loop for buffer in (buffer-list) - do (with-current-buffer buffer - (when (and (boundp 'haskell-session) - (string= (haskell-session-name haskell-session) name)) - (setq haskell-session nil) - (when also-kill-buffers - (kill-buffer))))) - (setq haskell-sessions - (cl-remove-if (lambda (session) - (string= (haskell-session-name session) - name)) - haskell-sessions)))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Finding/clearing the session -;; Used internally -(defvar haskell-session) - ;;;###autoload (defun haskell-session-maybe () "Maybe get the Haskell session, return nil if there isn't one." @@ -155,24 +56,6 @@ If DONTCREATE is non-nil don't create a new session." haskell-session (setq haskell-session nil))) -;;;###autoload -(defun haskell-session () - "Get the Haskell session, prompt if there isn't one or fail." - (or (haskell-session-maybe) - (haskell-session-assign - (or (haskell-session-from-buffer) - (haskell-session-new-assume-from-cabal) - (haskell-session-choose) - (haskell-session-new))))) - -(defun haskell-session-new-assume-from-cabal () - "Prompt to create a new project based on a guess from the nearest Cabal file." - (let ((name (haskell-session-default-name))) - (unless (haskell-session-lookup name) - (when (y-or-n-p (format "Start a new project named “%s”? " - name)) - (haskell-session-make name))))) - (defun haskell-session-from-buffer () "Get the session based on the buffer." (when (and (buffer-file-name) @@ -194,16 +77,6 @@ If DONTCREATE is non-nil don't create a new session." haskell-sessions :initial-value nil))) -(defun haskell-session-new () - "Make a new session." - (let ((name (read-from-minibuffer "Project name: " (haskell-session-default-name)))) - (when (not (string= name "")) - (let ((session (haskell-session-lookup name))) - (if session - (when (y-or-n-p (format "Session %s already exists. Use it?" name)) - session) - (haskell-session-make name)))))) - (defun haskell-session-default-name () "Generate a default project name for the new project prompt." (let ((file (haskell-cabal-find-file))) @@ -236,23 +109,69 @@ If DONTCREATE is non-nil don't create a new session." "Clear the buffer of any Haskell session choice." (set (make-local-variable 'haskell-session) nil)) -(defun haskell-session-change () - "Change the session for the current buffer." - (interactive) - (haskell-session-assign (or (haskell-session-new-assume-from-cabal) - (haskell-session-choose) - (haskell-session-new)))) - -(defun haskell-session-change-target (target) - "Set the build target for cabal repl" - (interactive "sNew build target:") - (let* ((session haskell-session) - (old-target (haskell-session-get session 'target))) - (when session - (haskell-session-set-target session target) - (when (and (not (string= old-target target)) - (y-or-n-p "Target changed, restart haskell process?")) - (haskell-process-start session))))) +(defun haskell-session-lookup (name) + "Get the session by name." + (cl-remove-if-not (lambda (s) + (string= name (haskell-session-name s))) + haskell-sessions)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Session modules + +;;;###autoload +(defun haskell-session-installed-modules (session &optional dontcreate) + "Get the modules installed in the current package set. +If DONTCREATE is non-nil don't create a new session." + ;; TODO: Again, this makes HEAVY use of unix utilities. It'll work + ;; fine in Linux, probably okay on OS X, and probably not at all on + ;; Windows. Again, if someone wants to test on Windows and come up + ;; with alternatives that's OK. + ;; + ;; Ideally all these package queries can be provided by a Haskell + ;; program based on the Cabal API. Possibly as a nice service. Such + ;; a service could cache and do nice things like that. For now, this + ;; simple shell script takes us far. + ;; + ;; Probably also we can take the code from inferior-haskell-mode. + ;; + ;; Ugliness aside, if it saves us time to type it's a winner. + ;; + ;; FIXME/TODO: add support for (eq 'cabal-repl (haskell-process-type)) + (let ((modules (shell-command-to-string + (format "%s | %s | %s" + (if (eq 'cabal-dev (haskell-process-type)) + (if (or (not dontcreate) (haskell-session-maybe)) + (format "cabal-dev -s %s/cabal-dev ghc-pkg dump" + (haskell-session-cabal-dir session)) + "echo ''") + "ghc-pkg dump") + "egrep '^(exposed-modules: | )[A-Z]'" + "cut -c18-")))) + (split-string modules))) + +;;;###autoload +(defun haskell-session-all-modules (session &optional dontcreate) + "Get all modules -- installed or in the current project. +If DONTCREATE is non-nil don't create a new session." + (append (haskell-session-installed-modules session dontcreate) + (haskell-session-project-modules session dontcreate))) + +;;;###autoload +(defun haskell-session-project-modules (session &optional dontcreate) + "Get the modules of the current project. +If DONTCREATE is non-nil don't create a new session." + (if (or (not dontcreate) (haskell-session-maybe)) + (let* ((modules + (shell-command-to-string + (format "%s && %s" + (format "cd %s" (haskell-session-cabal-dir session)) + ;; TODO: Use a different, better source. Possibly hasktags or some such. + ;; TODO: At least make it cross-platform. Linux + ;; (and possibly OS X) have egrep, Windows + ;; doesn't -- or does it via Cygwin or MinGW? + ;; This also doesn't handle module\nName. But those gits can just cut it out! + "egrep '^module[\t\r ]+[^(\t\r ]+' . -r -I --include='*.*hs' --include='*.hsc' -s -o -h | sed 's/^module[\t\r ]*//' | sort | uniq")))) + (split-string modules)))) (defun haskell-session-strip-dir (session file) "Strip the load dir from the file path." @@ -267,28 +186,15 @@ If DONTCREATE is non-nil don't create a new session." file) file))) -(defun haskell-session-lookup (name) - "Get the session by name." - (cl-remove-if-not (lambda (s) - (string= name (haskell-session-name s))) - haskell-sessions)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Building the session - -(defun haskell-session-make (name) - "Make a Haskell session." - (when (haskell-session-lookup name) - (error "Session of name %s already exists!" name)) - (let ((session (set (make-local-variable 'haskell-session) - (list (cons 'name name))))) - (add-to-list 'haskell-sessions session) - (haskell-process-start session) - session)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Accessing the session +(defun haskell-session-current-dir (s) + "Get the session current directory." + (let ((dir (haskell-session-get s 'current-dir))) + (or dir + (error "No current directory.")))) + (defun haskell-session-name (s) "Get the session name." (haskell-session-get s 'name)) @@ -306,19 +212,6 @@ If DONTCREATE is non-nil don't create a new session." "Set the session build target." (haskell-session-set s 'target target)) -(defun haskell-session-interactive-buffer (s) - "Get the session interactive buffer." - (let ((buffer (haskell-session-get s 'interactive-buffer))) - (if (and buffer (buffer-live-p buffer)) - buffer - (let ((buffer (get-buffer-create (format "*%s*" (haskell-session-name s))))) - (haskell-session-set-interactive-buffer s buffer) - (with-current-buffer buffer - (haskell-interactive-mode) - (haskell-session-assign s)) - (switch-to-buffer-other-window buffer) - buffer)))) - (defun haskell-session-set-interactive-buffer (s v) "Set the session interactive buffer." (haskell-session-set s 'interactive-buffer v)) @@ -348,12 +241,6 @@ If DONTCREATE is non-nil don't create a new session." (haskell-session-set s 'cabal-checksum (haskell-cabal-compute-checksum cabal-dir))) -(defun haskell-session-current-dir (s) - "Get the session current directory." - (let ((dir (haskell-session-get s 'current-dir))) - (or dir - (haskell-process-cd t)))) - (defun haskell-session-cabal-dir (s &optional no-prompt) "Get the session cabal-dir." (let ((dir (haskell-session-get s 'cabal-dir))) diff --git a/haskell.el b/haskell.el new file mode 100644 index 000000000..b29c46c02 --- /dev/null +++ b/haskell.el @@ -0,0 +1,391 @@ +;;; haskell.el --- Top-level Haskell package + +;; Copyright (c) 2014 Chris Done. All rights reserved. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(require 'haskell-mode) +(require 'haskell-process) +(require 'haskell-debug) +(require 'haskell-interactive-mode) +(require 'haskell-repl) +(require 'haskell-load) +(require 'haskell-commands) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Basic configuration hooks + +(add-hook 'haskell-process-ended-hook 'haskell-process-prompt-restart) +(add-hook 'kill-buffer-hook 'haskell-interactive-kill) + +(defun haskell-interactive-mode-return () + "Handle the return key." + (interactive) + (cond + ((haskell-interactive-at-compile-message) + (next-error-internal)) + (t + (haskell-interactive-handle-expr)))) + +(defun haskell-session-kill (&optional leave-interactive-buffer) + "Kill the session process and buffer, delete the session. +0. Prompt to kill all associated buffers. +1. Kill the process. +2. Kill the interactive buffer. +3. Walk through all the related buffers and set their haskell-session to nil. +4. Remove the session from the sessions list." + (interactive) + (let* ((session (haskell-session)) + (name (haskell-session-name session)) + (also-kill-buffers + (and haskell-ask-also-kill-buffers + (y-or-n-p (format "Killing `%s'. Also kill all associated buffers?" name))))) + (haskell-kill-session-process session) + (unless leave-interactive-buffer + (kill-buffer (haskell-session-interactive-buffer session))) + (cl-loop for buffer in (buffer-list) + do (with-current-buffer buffer + (when (and (boundp 'haskell-session) + (string= (haskell-session-name haskell-session) name)) + (setq haskell-session nil) + (when also-kill-buffers + (kill-buffer))))) + (setq haskell-sessions + (cl-remove-if (lambda (session) + (string= (haskell-session-name session) + name)) + haskell-sessions)))) + +(defun haskell-interactive-kill () + "Kill the buffer and (maybe) the session." + (interactive) + (when (eq major-mode 'haskell-interactive-mode) + (when (and (boundp 'haskell-session) + haskell-session + (y-or-n-p "Kill the whole session?")) + (haskell-session-kill t)))) + +(defun haskell-session-make (name) + "Make a Haskell session." + (when (haskell-session-lookup name) + (error "Session of name %s already exists!" name)) + (let ((session (setq haskell-session + (list (cons 'name name))))) + (add-to-list 'haskell-sessions session) + (haskell-process-start session) + session)) + +(defun haskell-session-new-assume-from-cabal () + "Prompt to create a new project based on a guess from the nearest Cabal file." + (let ((name (haskell-session-default-name))) + (unless (haskell-session-lookup name) + (when (y-or-n-p (format "Start a new project named “%s”? " + name)) + (haskell-session-make name))))) + +;;;###autoload +(defun haskell-session () + "Get the Haskell session, prompt if there isn't one or fail." + (or (haskell-session-maybe) + (haskell-session-assign + (or (haskell-session-from-buffer) + (haskell-session-new-assume-from-cabal) + (haskell-session-choose) + (haskell-session-new))))) + +;;;###autoload +(defun haskell-interactive-switch () + "Switch to the interactive mode for this session." + (interactive) + (let ((initial-buffer (current-buffer)) + (buffer (haskell-session-interactive-buffer (haskell-session)))) + (with-current-buffer buffer + (setq haskell-interactive-previous-buffer initial-buffer)) + (unless (eq buffer (window-buffer)) + (switch-to-buffer-other-window buffer)))) + +(defun haskell-session-new () + "Make a new session." + (let ((name (read-from-minibuffer "Project name: " (haskell-session-default-name)))) + (when (not (string= name "")) + (let ((session (haskell-session-lookup name))) + (if session + (when (y-or-n-p (format "Session %s already exists. Use it?" name)) + session) + (haskell-session-make name)))))) + +;;;###autoload +(defun haskell-session-change () + "Change the session for the current buffer." + (interactive) + (haskell-session-assign (or (haskell-session-new-assume-from-cabal) + (haskell-session-choose) + (haskell-session-new)))) + +(defun haskell-process-prompt-restart (process) + "Prompt to restart the died process." + (let ((process-name (haskell-process-name process))) + (if haskell-process-suggest-restart + (cl-case (read-event + (propertize (format "The Haskell process `%s' has died. Restart? (y, n, l: show process log)" + process-name) + 'face 'minibuffer-prompt)) + (?y (haskell-process-start (haskell-process-session process))) + (?l (let* ((response (haskell-process-response process)) + (buffer (get-buffer "*haskell-process-log*"))) + (if buffer + (switch-to-buffer buffer) + (progn (switch-to-buffer (get-buffer-create "*haskell-process-log*")) + (insert response))))) + (?n)) + (message (format "The Haskell process `%s' is dearly departed." + process-name))))) + +(defun haskell-process () + "Get the current process from the current session." + (haskell-session-process (haskell-session))) + +(defun haskell-interactive-buffer () + "Get the interactive buffer of the session." + (haskell-session-interactive-buffer (haskell-session))) + +(defun haskell-kill-session-process (&optional session) + "Kill the process." + (interactive) + (let* ((session (or session (haskell-session))) + (existing-process (get-process (haskell-session-name session)))) + (when (processp existing-process) + (haskell-interactive-mode-echo session "Killing process ...") + (haskell-process-set (haskell-session-process session) 'is-restarting t) + (delete-process existing-process)))) + +(defun haskell-interactive-mode-visit-error () + "Visit the buffer of the current (or last) error message." + (interactive) + (with-current-buffer (haskell-session-interactive-buffer (haskell-session)) + (if (progn (goto-char (line-beginning-position)) + (looking-at haskell-interactive-mode-error-regexp)) + (progn (forward-line -1) + (haskell-interactive-jump-to-error-line)) + (progn (goto-char (point-max)) + (haskell-interactive-mode-error-backward) + (haskell-interactive-jump-to-error-line))))) + +(defun haskell-mode-contextual-space () + "Contextually do clever stuff when hitting space." + (interactive) + (if (or (not (bound-and-true-p interactive-haskell-mode)) + (not (haskell-session-maybe))) + (self-insert-command 1) + (cond ((and haskell-mode-contextual-import-completion + (save-excursion (forward-word -1) + (looking-at "^import$"))) + (insert " ") + (let ((module (haskell-complete-module-read + "Module: " + (haskell-session-all-modules (haskell-session))))) + (insert module) + (haskell-mode-format-imports))) + ((not (string= "" (save-excursion (forward-char -1) (haskell-ident-at-point)))) + (let ((ident (save-excursion (forward-char -1) (haskell-ident-at-point)))) + (insert " ") + (haskell-process-do-try-info ident))) + (t (insert " "))))) + +(defun haskell-mode-jump-to-tag (&optional next-p) + "Jump to the tag of the given identifier." + (interactive "P") + (let ((ident (haskell-ident-at-point)) + (tags-file-name (haskell-session-tags-filename (haskell-session))) + (tags-revert-without-query t)) + (when (not (string= "" (haskell-trim ident))) + (cond ((file-exists-p tags-file-name) + (find-tag ident next-p)) + (t (haskell-process-generate-tags ident)))))) + +(defun haskell-mode-after-save-handler () + "Function that will be called after buffer's saving." + (when haskell-tags-on-save + (ignore-errors (when (and (boundp 'haskell-session) haskell-session) + (haskell-process-generate-tags)))) + (when haskell-stylish-on-save + (ignore-errors (haskell-mode-stylish-buffer)) + (let ((before-save-hook '()) + (after-save-hook '())) + (basic-save-buffer)))) + +(defun haskell-mode-tag-find (&optional next-p) + "The tag find function, specific for the particular session." + (interactive "P") + (cond + ((elt (syntax-ppss) 3) ;; Inside a string + (haskell-mode-jump-to-filename-in-string)) + (t (call-interactively 'haskell-mode-jump-to-tag)))) + +(defun haskell-mode-jump-to-filename-in-string () + "Jump to the filename in the current string." + (let* ((string (save-excursion + (buffer-substring-no-properties + (1+ (search-backward-regexp "\"" (line-beginning-position) nil 1)) + (1- (progn (forward-char 1) + (search-forward-regexp "\"" (line-end-position) nil 1)))))) + (fp (expand-file-name string + (haskell-session-cabal-dir (haskell-session))))) + (find-file + (read-file-name + "" + fp + fp)))) + +;;;###autoload +(defun haskell-interactive-bring () + "Bring up the interactive mode for this session." + (interactive) + (let* ((session (haskell-session)) + (buffer (haskell-session-interactive-buffer session))) + (unless (and (cl-find-if (lambda (window) (equal (window-buffer window) buffer)) + (window-list)) + (= 2 (length (window-list)))) + (delete-other-windows) + (display-buffer buffer) + (other-window 1)))) + +(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))) + +;;;###autoload +(defun haskell-process-reload-file () + "Re-load the current buffer file." + (interactive) + (save-buffer) + (haskell-interactive-mode-reset-error (haskell-session)) + (haskell-process-file-loadish "reload" t nil)) + +;;;###autoload +(defun haskell-process-load-or-reload (&optional toggle) + "Load or reload. Universal argument toggles which." + (interactive "P") + (if toggle + (progn (setq haskell-reload-p (not haskell-reload-p)) + (message "%s (No action taken this time)" + (if haskell-reload-p + "Now running :reload." + "Now running :load ."))) + (if haskell-reload-p (haskell-process-reload-file) (haskell-process-load-file)))) + +;;;###autoload +(defun haskell-process-cabal-build () + "Build the Cabal project." + (interactive) + (haskell-process-do-cabal "build") + (haskell-process-add-cabal-autogen)) + +;;;###autoload +(defun haskell-process-cabal (p) + "Prompts for a Cabal command to run." + (interactive "P") + (if p + (haskell-process-do-cabal + (read-from-minibuffer "Cabal command (e.g. install): ")) + (haskell-process-do-cabal + (funcall haskell-completing-read-function "Cabal command: " + (append haskell-cabal-commands + (list "build --ghc-options=-fforce-recomp")))))) + +(defun haskell-process-file-loadish (command reload-p module-buffer) + "Run a loading-ish COMMAND that wants to pick up type errors +and things like that. RELOAD-P indicates whether the notification +should say 'reloaded' or 'loaded'. MODULE-BUFFER may be used +for various things, but is optional." + (let ((session (haskell-session))) + (haskell-session-current-dir session) + (when haskell-process-check-cabal-config-on-load + (haskell-process-look-config-changes session)) + (let ((process (haskell-process))) + (haskell-process-queue-command + process + (make-haskell-command + :state (list session process command reload-p module-buffer) + :go (lambda (state) + (haskell-process-send-string + (cadr state) (format ":%s" (cl-caddr state)))) + :live (lambda (state buffer) + (haskell-process-live-build + (cadr state) buffer nil)) + :complete (lambda (state response) + (haskell-process-load-complete + (car state) + (cadr state) + response + (cl-cadddr state) + (cl-cadddr (cdr state))))))))) + +(defun haskell-process-minimal-imports () + "Dump minimal imports." + (interactive) + (unless (> (save-excursion + (goto-char (point-min)) + (haskell-navigate-imports-go) + (point)) + (point)) + (goto-char (point-min)) + (haskell-navigate-imports-go)) + (haskell-process-queue-sync-request (haskell-process) + ":set -ddump-minimal-imports") + (haskell-process-load-file) + (insert-file-contents-literally + (concat (haskell-session-current-dir (haskell-session)) + "/" + (haskell-guess-module-name) + ".imports"))) + +(defun haskell-interactive-jump-to-error-line () + "Jump to the error line." + (let ((orig-line (buffer-substring-no-properties (line-beginning-position) + (line-end-position)))) + (and (string-match "^\\([^:]+\\):\\([0-9]+\\):\\([0-9]+\\)\\(-[0-9]+\\)?:" orig-line) + (let* ((file (match-string 1 orig-line)) + (line (match-string 2 orig-line)) + (col (match-string 3 orig-line)) + (session (haskell-interactive-session)) + (cabal-path (haskell-session-cabal-dir session)) + (src-path (haskell-session-current-dir session)) + (cabal-relative-file (expand-file-name file cabal-path)) + (src-relative-file (expand-file-name file src-path))) + (let ((file (cond ((file-exists-p cabal-relative-file) + cabal-relative-file) + ((file-exists-p src-relative-file) + src-relative-file)))) + (when file + (other-window 1) + (find-file file) + (haskell-interactive-bring) + (goto-char (point-min)) + (forward-line (1- (string-to-number line))) + (goto-char (+ (point) (string-to-number col) -1)) + (haskell-mode-message-line orig-line) + t)))))) + +(provide 'haskell) diff --git a/w3m-haddock.el b/w3m-haddock.el index 842723a87..7e6c99268 100644 --- a/w3m-haddock.el +++ b/w3m-haddock.el @@ -22,6 +22,9 @@ ;; Boston, MA 02110-1301, USA. (require 'cl-lib) +(require 'haskell-mode) +(require 'haskell-font-lock) + (declare-function w3m-buffer-title "w3m") (declare-function w3m-browse-url "w3m") (defvar w3m-current-url)