633 lines
27 KiB
EmacsLisp
633 lines
27 KiB
EmacsLisp
|
;;; haskell-load.el --- Compiling and loading modules in the GHCi process -*- lexical-binding: t -*-
|
|||
|
|
|
|||
|
|
;; Copyright © 2014 Chris Done. All rights reserved.
|
|||
|
|
;; 2016 Arthur Fayzrakhmanov
|
|||
|
|
|
|||
|
|
;; 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 <http://www.gnu.org/licenses/>.
|
|||
|
|
|
|||
|
|
;;; Commentary:
|
|||
|
|
|
|||
|
|
;;; Code:
|
|||
|
|
|
|||
|
|
(require 'cl-lib)
|
|||
|
|
(require 'haskell-mode)
|
|||
|
|
(require 'haskell-process)
|
|||
|
|
(require 'haskell-interactive-mode)
|
|||
|
|
(require 'haskell-modules)
|
|||
|
|
(require 'haskell-commands)
|
|||
|
|
(require 'haskell-session)
|
|||
|
|
(require 'haskell-string)
|
|||
|
|
|
|||
|
|
(defun haskell-process-look-config-changes (session)
|
|||
|
|
"Check whether a cabal configuration file has changed.
|
|||
|
|
Restarts the SESSION's 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))
|
|||
|
|
(haskell-mode-toggle-interactive-prompt-state)
|
|||
|
|
(unwind-protect
|
|||
|
|
(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)))
|
|||
|
|
(haskell-mode-toggle-interactive-prompt-state t)))))
|
|||
|
|
|
|||
|
|
(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)))
|
|||
|
|
((string-match "Collecting type info for [[:digit:]]+ module(s) \\.\\.\\."
|
|||
|
|
(haskell-process-response process)
|
|||
|
|
(haskell-process-response-cursor process))
|
|||
|
|
(haskell-mode-message-line (match-string 0 buffer))
|
|||
|
|
;; Do not consume "Ok, modules loaded" that goes before
|
|||
|
|
;; "Collecting type info...", just exit.
|
|||
|
|
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."
|
|||
|
|
(when (get-buffer (format "*%s:splices*" (haskell-session-name session)))
|
|||
|
|
(with-current-buffer (haskell-interactive-mode-splices-buffer session)
|
|||
|
|
(erase-buffer)))
|
|||
|
|
(let* ((ok (cond
|
|||
|
|
((haskell-process-consume
|
|||
|
|
process
|
|||
|
|
"Ok, \\(?:[0-9]+\\) modules? loaded\\.$")
|
|||
|
|
t)
|
|||
|
|
((haskell-process-consume
|
|||
|
|
process
|
|||
|
|
"Failed, \\(?:[0-9]+\\) modules? loaded\\.$")
|
|||
|
|
nil)
|
|||
|
|
((haskell-process-consume
|
|||
|
|
process
|
|||
|
|
"Ok, modules loaded: \\(.+\\)\\.$")
|
|||
|
|
t)
|
|||
|
|
((haskell-process-consume
|
|||
|
|
process
|
|||
|
|
"Failed, modules loaded: \\(.+\\)\\.$")
|
|||
|
|
nil)
|
|||
|
|
(t
|
|||
|
|
(error (message "Unexpected response from haskell process.")))))
|
|||
|
|
(modules (haskell-process-extract-modules buffer))
|
|||
|
|
(cursor (haskell-process-response-cursor process))
|
|||
|
|
(warning-count 0))
|
|||
|
|
(haskell-process-set-response-cursor process 0)
|
|||
|
|
(haskell-check-remove-overlays module-buffer)
|
|||
|
|
(while
|
|||
|
|
(haskell-process-errors-warnings module-buffer 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)))
|
|||
|
|
(if ok
|
|||
|
|
(haskell-mode-message-line (if reload "Reloaded OK." "OK."))
|
|||
|
|
(haskell-interactive-mode-compile-error session "Compilation failed."))
|
|||
|
|
(when cont
|
|||
|
|
(condition-case-unless-debug e
|
|||
|
|
(funcall cont ok)
|
|||
|
|
(error (message "%S" e))
|
|||
|
|
(quit nil)))))
|
|||
|
|
|
|||
|
|
(defun haskell-process-suggest-imports (session file modules ident)
|
|||
|
|
"Suggest add missed imports to file.
|
|||
|
|
Asks user to add to SESSION's FILE missed import. MODULES is a
|
|||
|
|
list of modules where missed IDENT was found."
|
|||
|
|
(cl-assert session)
|
|||
|
|
(cl-assert file)
|
|||
|
|
(cl-assert ident)
|
|||
|
|
(haskell-mode-toggle-interactive-prompt-state)
|
|||
|
|
(unwind-protect
|
|||
|
|
(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)
|
|||
|
|
(haskell-add-import module)))
|
|||
|
|
(haskell-mode-toggle-interactive-prompt-state t)))
|
|||
|
|
|
|||
|
|
(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]+\\) to enable" msg)
|
|||
|
|
(string-match
|
|||
|
|
"Use \\([A-Z][A-Za-z]+\\) if you want to disable this"
|
|||
|
|
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 "[Ww]arning: 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 [‘`‛]\\([^@\r\n]+\\).*['’].$" 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 (ignore-errors
|
|||
|
|
(haskell-interactive-process))))
|
|||
|
|
(cond
|
|||
|
|
((or (eq process nil)
|
|||
|
|
(let ((child (haskell-process-process process)))
|
|||
|
|
(not (equal 'run (process-status child)))))
|
|||
|
|
(message "Process is not running, so running directly.")
|
|||
|
|
(shell-command (concat "cabal " command)
|
|||
|
|
(get-buffer-create "*haskell-process-log*")
|
|||
|
|
(get-buffer-create "*haskell-process-log*"))
|
|||
|
|
(switch-to-buffer-other-window (get-buffer "*haskell-process-log*")))
|
|||
|
|
(t (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-new-repl haskell-process-path-cabal)
|
|||
|
|
('cabal-ghci haskell-process-path-cabal)
|
|||
|
|
('stack-ghci haskell-process-path-stack))
|
|||
|
|
(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)))
|
|||
|
|
;; XXX: what the hell about the rampant code duplication?
|
|||
|
|
(haskell-process-set-response-cursor process 0)
|
|||
|
|
(while (haskell-process-errors-warnings nil 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-new-repl haskell-process-path-cabal)
|
|||
|
|
('cabal-ghci haskell-process-path-cabal)
|
|||
|
|
('stack-ghci haskell-process-path-stack))
|
|||
|
|
: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 (and modules-string (split-string modules-string ", "))))
|
|||
|
|
(cons modules modules-string)))
|
|||
|
|
|
|||
|
|
;;;###autoload
|
|||
|
|
(defface haskell-error-face
|
|||
|
|
'((((supports :underline (:style wave)))
|
|||
|
|
:underline (:style wave :color "#dc322f"))
|
|||
|
|
(t
|
|||
|
|
:inherit error))
|
|||
|
|
"Face used for marking error lines."
|
|||
|
|
:group 'haskell-mode)
|
|||
|
|
|
|||
|
|
;;;###autoload
|
|||
|
|
(defface haskell-warning-face
|
|||
|
|
'((((supports :underline (:style wave)))
|
|||
|
|
:underline (:style wave :color "#b58900"))
|
|||
|
|
(t
|
|||
|
|
:inherit warning))
|
|||
|
|
"Face used for marking warning lines."
|
|||
|
|
:group 'haskell-mode)
|
|||
|
|
|
|||
|
|
;;;###autoload
|
|||
|
|
(defface haskell-hole-face
|
|||
|
|
'((((supports :underline (:style wave)))
|
|||
|
|
:underline (:style wave :color "#6c71c4"))
|
|||
|
|
(t
|
|||
|
|
:inherit warning))
|
|||
|
|
"Face used for marking hole lines."
|
|||
|
|
:group 'haskell-mode)
|
|||
|
|
|
|||
|
|
(defvar haskell-check-error-fringe (propertize "!" 'display '(left-fringe exclamation-mark)))
|
|||
|
|
(defvar haskell-check-warning-fringe (propertize "?" 'display '(left-fringe question-mark)))
|
|||
|
|
(defvar haskell-check-hole-fringe (propertize "_" 'display '(left-fringe horizontal-bar)))
|
|||
|
|
|
|||
|
|
(defun haskell-check-overlay-p (ovl)
|
|||
|
|
(overlay-get ovl 'haskell-check))
|
|||
|
|
|
|||
|
|
(defun haskell-check-filter-overlays (xs)
|
|||
|
|
(cl-remove-if-not 'haskell-check-overlay-p xs))
|
|||
|
|
|
|||
|
|
(defun haskell-check-remove-overlays (buffer)
|
|||
|
|
(with-current-buffer buffer
|
|||
|
|
(remove-overlays (point-min) (point-max) 'haskell-check t)))
|
|||
|
|
|
|||
|
|
(defmacro haskell-with-overlay-properties (proplist ovl &rest body)
|
|||
|
|
"Evaluate BODY with names in PROPLIST bound to the values of
|
|||
|
|
correspondingly-named overlay properties of OVL."
|
|||
|
|
(let ((ovlvar (cl-gensym "OVL-")))
|
|||
|
|
`(let* ((,ovlvar ,ovl)
|
|||
|
|
,@(mapcar (lambda (p) `(,p (overlay-get ,ovlvar ',p))) proplist))
|
|||
|
|
,@body)))
|
|||
|
|
|
|||
|
|
(defun haskell-overlay-start> (o1 o2)
|
|||
|
|
(> (overlay-start o1) (overlay-start o2)))
|
|||
|
|
(defun haskell-overlay-start< (o1 o2)
|
|||
|
|
(< (overlay-start o1) (overlay-start o2)))
|
|||
|
|
|
|||
|
|
(defun haskell-first-overlay-in-if (test beg end)
|
|||
|
|
(let ((ovls (cl-remove-if-not test (overlays-in beg end))))
|
|||
|
|
(cl-first (sort (cl-copy-list ovls) 'haskell-overlay-start<))))
|
|||
|
|
|
|||
|
|
(defun haskell-last-overlay-in-if (test beg end)
|
|||
|
|
(let ((ovls (cl-remove-if-not test (overlays-in beg end))))
|
|||
|
|
(cl-first (sort (cl-copy-list ovls) 'haskell-overlay-start>))))
|
|||
|
|
|
|||
|
|
(defun haskell-error-overlay-briefly (ovl)
|
|||
|
|
(haskell-with-overlay-properties
|
|||
|
|
(haskell-msg haskell-msg-type) ovl
|
|||
|
|
(cond
|
|||
|
|
((not (eq haskell-msg-type 'warning))
|
|||
|
|
haskell-msg)
|
|||
|
|
((string-prefix-p "[Ww]arning:\n " haskell-msg)
|
|||
|
|
(cl-subseq haskell-msg 13))
|
|||
|
|
(t
|
|||
|
|
(error
|
|||
|
|
"Invariant failed: a warning message from GHC has unexpected form: %s."
|
|||
|
|
haskell-msg)))))
|
|||
|
|
|
|||
|
|
(defun haskell-goto-error-overlay (ovl)
|
|||
|
|
(cond (ovl
|
|||
|
|
(goto-char (overlay-start ovl))
|
|||
|
|
(haskell-mode-message-line (haskell-error-overlay-briefly ovl)))
|
|||
|
|
(t
|
|||
|
|
(message "No further notes from Haskell compiler."))))
|
|||
|
|
|
|||
|
|
(defun haskell-goto-first-error ()
|
|||
|
|
(interactive)
|
|||
|
|
(haskell-goto-error-overlay
|
|||
|
|
(haskell-first-overlay-in-if 'haskell-check-overlay-p
|
|||
|
|
(buffer-end 0) (buffer-end 1))))
|
|||
|
|
|
|||
|
|
(defun haskell-goto-prev-error ()
|
|||
|
|
(interactive)
|
|||
|
|
(haskell-goto-error-overlay
|
|||
|
|
(let ((ovl-at
|
|||
|
|
(cl-first (haskell-check-filter-overlays (overlays-at (point))))))
|
|||
|
|
(or (haskell-last-overlay-in-if 'haskell-check-overlay-p
|
|||
|
|
(point-min)
|
|||
|
|
(if ovl-at (overlay-start ovl-at) (point)))
|
|||
|
|
ovl-at))))
|
|||
|
|
|
|||
|
|
(defun haskell-goto-next-error ()
|
|||
|
|
(interactive)
|
|||
|
|
(haskell-goto-error-overlay
|
|||
|
|
(let ((ovl-at
|
|||
|
|
(cl-first (haskell-check-filter-overlays (overlays-at (point))))))
|
|||
|
|
(or (haskell-first-overlay-in-if
|
|||
|
|
'haskell-check-overlay-p
|
|||
|
|
(if ovl-at (overlay-end ovl-at) (point)) (point-max))
|
|||
|
|
ovl-at))))
|
|||
|
|
|
|||
|
|
(defun haskell-check-paint-overlay
|
|||
|
|
(buffer error-from-this-file-p line msg file type hole coln)
|
|||
|
|
(with-current-buffer buffer
|
|||
|
|
(let (beg end)
|
|||
|
|
(goto-char (point-min))
|
|||
|
|
;; XXX: we can avoid excess buffer walking by relying on the maybe-fact
|
|||
|
|
;; that GHC sorts error messages by line number, maybe.
|
|||
|
|
(cond
|
|||
|
|
(error-from-this-file-p
|
|||
|
|
(forward-line (1- line))
|
|||
|
|
(forward-char (1- coln))
|
|||
|
|
(setq beg (point))
|
|||
|
|
(if (eq type 'hole)
|
|||
|
|
(forward-char (length hole))
|
|||
|
|
(skip-chars-forward "^[:space:]" (line-end-position)))
|
|||
|
|
(setq end (point)))
|
|||
|
|
(t
|
|||
|
|
(setq beg (point))
|
|||
|
|
(forward-line)
|
|||
|
|
(setq end (point))))
|
|||
|
|
(let ((ovl (make-overlay beg end)))
|
|||
|
|
(overlay-put ovl 'haskell-check t)
|
|||
|
|
(overlay-put ovl 'haskell-file file)
|
|||
|
|
(overlay-put ovl 'haskell-msg msg)
|
|||
|
|
(overlay-put ovl 'haskell-msg-type type)
|
|||
|
|
(overlay-put ovl 'help-echo msg)
|
|||
|
|
(overlay-put ovl 'haskell-hole hole)
|
|||
|
|
(cl-destructuring-bind
|
|||
|
|
(face fringe)
|
|||
|
|
(cl-case type
|
|||
|
|
(warning
|
|||
|
|
(list 'haskell-warning-face haskell-check-warning-fringe))
|
|||
|
|
(hole
|
|||
|
|
(list 'haskell-hole-face haskell-check-hole-fringe))
|
|||
|
|
(error
|
|||
|
|
(list 'haskell-error-face haskell-check-error-fringe)))
|
|||
|
|
(overlay-put ovl 'before-string fringe)
|
|||
|
|
(overlay-put ovl 'face face))))))
|
|||
|
|
|
|||
|
|
(defun haskell-process-errors-warnings
|
|||
|
|
(module-buffer session process buffer &optional return-only)
|
|||
|
|
"Trigger handling type errors or warnings.
|
|||
|
|
Either prints the messages in the interactive buffer or if CONT
|
|||
|
|
is specified, passes the error onto that.
|
|||
|
|
|
|||
|
|
When MODULE-BUFFER is non-NIL, paint error overlays."
|
|||
|
|
(save-excursion
|
|||
|
|
(cond
|
|||
|
|
((haskell-process-consume
|
|||
|
|
process
|
|||
|
|
"\\(Module imports form a cycle:[ \n]+module [^ ]+ ([^)]+)[[:unibyte:][:nonascii:]]+?\\)\nFailed")
|
|||
|
|
(let ((err (match-string 1 buffer)))
|
|||
|
|
(if (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)))
|
|||
|
|
(unless return-only
|
|||
|
|
(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)))
|
|||
|
|
(list :file file :line 1 :col 0 :msg err :type 'error))
|
|||
|
|
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-raw (match-string 2 buffer))
|
|||
|
|
(error-msg (match-string 3 buffer))
|
|||
|
|
(type (cond ((string-match "^[Ww]arning:" error-msg) 'warning)
|
|||
|
|
((string-match "^Splicing " error-msg) 'splice)
|
|||
|
|
(t 'error)))
|
|||
|
|
(critical (not (eq type 'warning)))
|
|||
|
|
;; XXX: extract hole information, pass down to
|
|||
|
|
;; `haskell-check-paint-overlay'
|
|||
|
|
(final-msg (format "%s:%s: %s"
|
|||
|
|
(haskell-session-strip-dir session file)
|
|||
|
|
location-raw
|
|||
|
|
error-msg))
|
|||
|
|
(location (haskell-process-parse-error
|
|||
|
|
(concat file ":" location-raw ": x")))
|
|||
|
|
(line (plist-get location :line))
|
|||
|
|
(col1 (plist-get location :col)))
|
|||
|
|
(when (and module-buffer haskell-process-show-overlays)
|
|||
|
|
(haskell-check-paint-overlay
|
|||
|
|
module-buffer
|
|||
|
|
(string= (file-truename (buffer-file-name module-buffer))
|
|||
|
|
(file-truename file))
|
|||
|
|
line error-msg file type nil col1))
|
|||
|
|
(if return-only
|
|||
|
|
(list :file file :line line :col col1 :msg error-msg :type type)
|
|||
|
|
(progn (funcall (cl-case type
|
|||
|
|
(warning 'haskell-interactive-mode-compile-warning)
|
|||
|
|
(splice 'haskell-interactive-mode-compile-splice)
|
|||
|
|
(error 'haskell-interactive-mode-compile-error))
|
|||
|
|
session final-msg)
|
|||
|
|
(when critical
|
|||
|
|
(haskell-mode-message-line final-msg))
|
|||
|
|
(haskell-process-trigger-suggestions
|
|||
|
|
session
|
|||
|
|
error-msg
|
|||
|
|
file
|
|||
|
|
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))))
|
|||
|
|
|
|||
|
|
;;;###autoload
|
|||
|
|
(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)
|
|||
|
|
(haskell-mode-toggle-interactive-prompt-state)
|
|||
|
|
(unwind-protect
|
|||
|
|
(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."))))))))))
|
|||
|
|
(haskell-mode-toggle-interactive-prompt-state t)))
|
|||
|
|
|
|||
|
|
(provide 'haskell-load)
|
|||
|
|
;;; haskell-load.el ends here
|