diff options
Diffstat (limited to 'configs/shared/emacs/.emacs.d/elpa/haskell-mode-20180913.348/haskell-load.el')
| -rw-r--r-- | configs/shared/emacs/.emacs.d/elpa/haskell-mode-20180913.348/haskell-load.el | 636 |
1 files changed, 636 insertions, 0 deletions
diff --git a/configs/shared/emacs/.emacs.d/elpa/haskell-mode-20180913.348/haskell-load.el b/configs/shared/emacs/.emacs.d/elpa/haskell-mode-20180913.348/haskell-load.el new file mode 100644 index 000000000000..3f7e9c0ad9fb --- /dev/null +++ b/configs/shared/emacs/.emacs.d/elpa/haskell-mode-20180913.348/haskell-load.el @@ -0,0 +1,636 @@ +;;; 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 + "Ok, \\(?:[a-z]+\\) module loaded\\.$") ;; for ghc 8.4 + 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 |