diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,10 @@ +0.1.9: + * Support GHC 8 + * Fix completion before any module is loaded (https://github.com/chrisdone/intero/issues/34) + * Add completion for custom commands + * Add data-files entry for Emacs Lisp code + * Collect type-info whenever anything is loaded (https://github.com/chrisdone/intero/issues/37) + 0.1.8: * Don't use -dynamic on Windows. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,6 +2,13 @@ Complete interactive development program for Haskell +## Supported GHCs + +* GHC 8.0.1 +* GHC 7.10.3 +* GHC 7.10.2 +* GHC 7.8.4 + ## Features It's basically GHCi plus extra features. Those are: diff --git a/elisp/haskell-simple-indent.el b/elisp/haskell-simple-indent.el new file mode 100644 --- /dev/null +++ b/elisp/haskell-simple-indent.el @@ -0,0 +1,273 @@ +;;; haskell-simple-indent.el --- Simple indentation module for Haskell Mode -*- lexical-binding: t -*- + +;; Copyright (C) 1998 Heribert Schuetz, Graeme E Moss + +;; Author: Heribert Schuetz +;; Graeme E Moss +;; Keywords: indentation files Haskell + +;; This file is not part of GNU Emacs. + +;; 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 . + +;;; Commentary: + +;; Purpose: +;; +;; To support simple indentation of Haskell scripts. +;; +;; +;; Installation: +;; +;; To bind TAB to the indentation command for all Haskell buffers, add +;; this to .emacs: +;; +;; (add-hook 'haskell-mode-hook 'turn-on-haskell-simple-indent) +;; +;; Otherwise, call `turn-on-haskell-simple-indent'. +;; +;; +;; Customisation: +;; +;; None supported. +;; +;; +;; History: +;; +;; If you have any problems or suggestions, after consulting the list +;; below, email gem@cs.york.ac.uk quoting the version of you are +;; using, the version of Emacs you are using, and a small example of +;; the problem or suggestion. +;; +;; Version 1.0: +;; Brought over from Haskell mode v1.1. +;; +;; Present Limitations/Future Work (contributions are most welcome!): +;; +;; (None so far.) + +;;; Code: + +;; All functions/variables start with +;; `(turn-(on/off)-)haskell-simple-indent'. + +(require 'haskell-mode) + +;;;###autoload +(defgroup haskell-simple-indent nil + "Simple Haskell indentation." + :link '(custom-manual "(haskell-mode)Indentation") + :group 'haskell + :prefix "haskell-simple-indent-") + +;; Version. +(defconst haskell-simple-indent-version "1.2" + "`haskell-simple-indent' version number.") +(defun haskell-simple-indent-version () + "Echo the current version of `haskell-simple-indent' in the minibuffer." + (interactive) + (message "Using haskell-simple-indent version %s" + haskell-simple-indent-version)) + +;; Partly stolen from `indent-relative' in indent.el: +(defun haskell-simple-indent () + "Space out to under next visible indent point. + +Indent points are positions of non-whitespace following +whitespace in lines preceeding point. Example: + +func arg cx = when (isTrue) $ do + print 42 +^ ^ ^ ^ ^ ^ ^ ^ ^ ^ + +A position is visible if it is to the left of the first +non-whitespace (indentation) of every nonblank line between the +position and the current line. If there is no visible indent +point beyond the current column, position given by +`indent-next-tab-stop' is used instead." + (interactive) + (let* ((start-column (or (save-excursion + (back-to-indentation) + (if (not (eolp)) + (current-column))) + (current-column))) + (invisible-from nil) ; `nil' means infinity here + (found) + (indent)) + (save-excursion + ;; Loop stops if there no more lines above this one or when has + ;; found a line starting at first column. + (while (and (not found) + (or (not invisible-from) + (not (zerop invisible-from))) + (zerop (forward-line -1))) + ;; Ignore empty lines. + (if (not (looking-at "[ \t]*\n")) + (let ((this-indentation (current-indentation))) + ;; Is this line so indented that it cannot have + ;; influence on indentation points? + (if (or (not invisible-from) + (< this-indentation invisible-from)) + (if (> this-indentation start-column) + (setq invisible-from this-indentation) + (let ((end (line-end-position))) + (move-to-column start-column) + ;; Is start-column inside a tab on this line? + (if (> (current-column) start-column) + (backward-char 1)) + ;; Skip to the end of non-whitespace. + (skip-chars-forward "^ \t" end) + ;; Skip over whitespace. + (skip-chars-forward " \t" end) + ;; Indentation point found if not at the end of + ;; line and if not covered by any line below + ;; this one. In that case use invisible-from. + (setq indent (if (or (= (point) end) + (and invisible-from + (> (current-column) invisible-from))) + invisible-from + (current-column))) + ;; Signal that solution is found. + (setq found t)))))))) + + + (let ((opoint (point-marker))) + ;; Indent to the calculated indent or last know invisible-from + ;; or use tab-to-tab-stop. Try hard to keep cursor in the same + ;; place or move it to the indentation if it was before it. And + ;; keep content of the line intact. + (setq indent (or indent + invisible-from + (if (fboundp 'indent-next-tab-stop) + (indent-next-tab-stop start-column)) + (let ((tabs tab-stop-list)) + (while (and tabs (>= start-column (car tabs))) + (setq tabs (cdr tabs))) + (if tabs (car tabs))) + (* (/ (+ start-column tab-width) tab-width) tab-width))) + (indent-line-to indent) + (if (> opoint (point)) + (goto-char opoint)) + (set-marker opoint nil)))) + +(defun haskell-simple-indent-backtab () + "Indent backwards. Dual to `haskell-simple-indent'." + (interactive) + (let ((saved-column (or (save-excursion + (back-to-indentation) + (if (not (eolp)) + (current-column))) + (current-column))) + (i 0) + (x 0)) + + (save-excursion + (back-to-indentation) + (delete-region (line-beginning-position) (point))) + (while (< (or (save-excursion + (back-to-indentation) + (if (not (eolp)) + (current-column))) + (current-column)) saved-column) + (haskell-simple-indent) + (setq i (+ i 1))) + + (save-excursion + (back-to-indentation) + (delete-region (line-beginning-position) (point))) + (while (< x (- i 1)) + (haskell-simple-indent) + (setq x (+ x 1))))) + +(defun haskell-simple-indent-newline-same-col () + "Make a newline and go to the same column as the current line." + (interactive) + (let ((start-end + (save-excursion + (let* ((start (line-beginning-position)) + (end (progn (goto-char start) + (search-forward-regexp + "[^ ]" (line-end-position) t 1)))) + (when end (cons start (1- end))))))) + (if start-end + (progn (newline) + (insert (buffer-substring-no-properties + (car start-end) (cdr start-end)))) + (newline)))) + +(defun haskell-simple-indent-newline-indent () + "Make a newline on the current column and indent on step." + (interactive) + (haskell-simple-indent-newline-same-col) + (insert (make-string haskell-indent-spaces ? ))) + +(defun haskell-simple-indent-comment-indent-function () + "Haskell version of `comment-indent-function'." + ;; This is required when filladapt is turned off. Without it, when + ;; filladapt is not used, comments which start in column zero + ;; cascade one character to the right + (save-excursion + (beginning-of-line) + (let ((eol (line-end-position))) + (and comment-start-skip + (re-search-forward comment-start-skip eol t) + (setq eol (match-beginning 0))) + (goto-char eol) + (skip-chars-backward " \t") + (max comment-column (+ (current-column) (if (bolp) 0 1)))))) + +;;;###autoload +(define-minor-mode haskell-simple-indent-mode + "Simple Haskell indentation mode that uses simple heuristic. +In this minor mode, `indent-for-tab-command' (bound to by +default) will move the cursor to the next indent point in the +previous nonblank line, whereas `haskell-simple-indent-backtab' +\ (bound to by default) will move the cursor the +previous indent point. An indent point is a non-whitespace +character following whitespace. + +Runs `haskell-simple-indent-hook' on activation." + :lighter " Ind" + :group 'haskell-simple-indent + :keymap '(([backtab] . haskell-simple-indent-backtab)) + (kill-local-variable 'comment-indent-function) + (kill-local-variable 'indent-line-function) + (when haskell-simple-indent-mode + (when (and (bound-and-true-p haskell-indentation-mode) + (fboundp 'haskell-indentation-mode)) + (haskell-indentation-mode 0)) + (set (make-local-variable 'comment-indent-function) #'haskell-simple-indent-comment-indent-function) + (set (make-local-variable 'indent-line-function) 'haskell-simple-indent) + (run-hooks 'haskell-simple-indent-hook))) + +;; The main functions. +;;;###autoload +(defun turn-on-haskell-simple-indent () + "Turn on function `haskell-simple-indent-mode'." + (interactive) + (haskell-simple-indent-mode)) +(make-obsolete 'turn-on-haskell-simple-indent + 'haskell-simple-indent-mode + "2015-07-23") + +(defun turn-off-haskell-simple-indent () + "Turn off function `haskell-simple-indent-mode'." + (interactive) + (haskell-simple-indent-mode 0)) + +;; Provide ourselves: + +(provide 'haskell-simple-indent) + +;;; haskell-simple-indent.el ends here diff --git a/elisp/intero.el b/elisp/intero.el new file mode 100644 --- /dev/null +++ b/elisp/intero.el @@ -0,0 +1,944 @@ +;;; intero.el --- Complete development mode for Haskell + +;; Copyright (c) 2016 Chris Done +;; Copyright (c) 2015 Athur Fayzrakhmanov +;; Copyright (c) 2013 Herbert Valerio Riedel +;; Copyright (c) 2007 Stefan Monnier + +;; Package-Requires: ((flycheck "26") (company "0.9.0")) + +;; 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 GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: +;; +;; Mode that enables: +;; +;; * Flycheck type checking ✓ +;; * Company mode completion ✓ +;; * Go to definition ✓ +;; * Type of selection ✓ +;; * Info ✓ +;; * REPL +;; * Find uses +;; * List all types in all expressions + +;;; Code: + +(require 'flycheck) +(require 'cl-lib) +(require 'company) +(require 'comint) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Configuration + +(defconst intero-package-version "intero-0.1.8" + "Package version to auto-install.") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Modes + +(defvar intero-mode-map (make-sparse-keymap) + "Intero minor mode's map.") + +(define-minor-mode intero-mode "Minor mode for Intero" + :lighter " Intero" + :keymap intero-mode-map + (when (buffer-file-name) + (if intero-mode + (progn (flycheck-select-checker 'intero) + (flycheck-mode) + (add-to-list (make-local-variable 'company-backends) 'company-intero) + (company-mode)) + (message "Intero mode disabled.")))) + +(define-key intero-mode-map (kbd "C-c C-t") 'intero-type-at) +(define-key intero-mode-map (kbd "C-c C-i") 'intero-info) +(define-key intero-mode-map (kbd "M-.") 'intero-goto-definition) +(define-key intero-mode-map (kbd "C-c C-l") 'intero-repl-load) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Buffer-local variables/state + +(defvar intero-callbacks (list) + "List of callbacks waiting for output. FIFO.") +(make-variable-buffer-local 'intero-callbacks) + +(defvar intero-arguments (list) + "Arguments used to call the stack process.") +(make-variable-buffer-local 'intero-arguments) + +(defvar intero-targets (list) + "Targets used for the stack process.") +(make-variable-buffer-local 'intero-targets) + +(defvar intero-project-root nil + "The project root of the current buffer.") +(make-variable-buffer-local 'intero-project-root) + +(defvar intero-package-name nil + "The package name associated with the current buffer.") +(make-variable-buffer-local 'intero-package-name) + +(defvar intero-deleting nil + "The process of the buffer is being deleted.") +(make-variable-buffer-local 'intero-deleting) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Interactive commands + +(defun intero-cd () + "Change directory in the backend process." + (interactive) + (intero-async-call + 'backend + (concat ":cd " + (read-directory-name "Change Intero directory: ")))) + +(defun intero-type-at (insert) + "Get the type of the thing or selection at point." + (interactive "P") + (let ((ty (apply #'intero-get-type-at (intero-thing-at-point)))) + (if insert + (save-excursion + (goto-char (line-beginning-position)) + (insert + (format "%s\n" + (with-temp-buffer + (when (fboundp 'haskell-mode) + (haskell-mode)) + (insert ty) + (font-lock-fontify-buffer) + (buffer-string))))) + (message + "%s" + (with-temp-buffer + (when (fboundp 'haskell-mode) + (haskell-mode)) + (insert ty) + (font-lock-fontify-buffer) + (buffer-string)))))) + +(defun intero-info (insert) + "Get the info of the thing at point." + (interactive "P") + (let ((info (intero-get-info-of (intero-ident-at-point)))) + (message + "%s" + (with-temp-buffer + (when (fboundp 'haskell-mode) + (haskell-mode)) + (insert info) + (font-lock-fontify-buffer) + (buffer-string))))) + +(defun intero-goto-definition () + "Jump to the definition of the thing at point." + (interactive) + (let ((result (apply #'intero-get-loc-at (intero-thing-at-point)))) + (when (string-match "\\(.*?\\):(\\([0-9]+\\),\\([0-9]+\\))-(\\([0-9]+\\),\\([0-9]+\\))$" + result) + (let ((file (match-string 1 result)) + (line (string-to-number (match-string 2 result))) + (col (string-to-number (match-string 3 result)))) + (find-file file) + (pop-mark) + (goto-char (point-min)) + (forward-line (1- line)) + (forward-char (1- col)))))) + +(defun intero-restart () + "Simply restart the process with the same configuration as before." + (interactive) + (when (intero-buffer-p 'backend) + (let ((targets (with-current-buffer (intero-buffer 'backend) + intero-targets))) + (intero-destroy 'backend) + (intero-get-worker-create 'backend targets (current-buffer))))) + +(defun intero-targets () + "Set the targets to use for stack ghci." + (interactive) + (let ((targets (split-string (read-from-minibuffer "Targets: ") + " " + t))) + (intero-destroy) + (intero-get-worker-create 'backend targets (current-buffer)))) + +(defun intero-destroy (&optional worker) + "Stop the current worker process and kill its associated." + (interactive) + (if worker + (intero-delete-worker worker) + (intero-delete-worker 'backend))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; DevelMain integration + +(defun intero-devel-reload () + "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 Intero." + (interactive) + (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."))) + (message "Reloading ...") + (intero-async-call + 'backend + ":l DevelMain" + (current-buffer) + (lambda (buffer reply) + (if (string-match "^OK, modules loaded" reply) + (intero-async-call + 'backend + "DevelMain.update" + buffer + (lambda (_buffer reply) + (message "DevelMain updated. Output was:\n%s" + reply))) + (progn + (message "DevelMain FAILED. Switch to DevelMain.hs and compile that.") + (switch-to-buffer buffer) + (flycheck-buffer) + (flycheck-list-errors)))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Flycheck integration + +(defun intero-check (checker cont) + "Run a check and pass the status onto CONT." + (let ((file-buffer (current-buffer))) + (write-region (point-min) (point-max) (buffer-file-name)) + (clear-visited-file-modtime) + (intero-async-call + 'backend + (concat ":l " (buffer-file-name)) + (list :cont cont + :file-buffer file-buffer + :checker checker) + (lambda (state string) + (with-current-buffer (plist-get state :file-buffer) + (funcall (plist-get state :cont) + 'finished + (intero-parse-errors-warnings + (plist-get state :checker) + (current-buffer) + string)) + (when (string-match "OK, modules loaded: \\(.*\\)\\.$" string) + (let ((modules (match-string 1 string))) + (intero-async-call 'backend + (concat ":m + " + (replace-regexp-in-string modules "," "")) + nil + (lambda (_st _)))))))))) + +(flycheck-define-generic-checker 'intero + "A syntax and type checker for Haskell using an Intero worker +process." + :start 'intero-check + :modes '(haskell-mode) + :next-checkers '((warning . haskell-hlint))) + +(add-to-list 'flycheck-checkers 'intero) + +(defun intero-parse-errors-warnings (checker buffer string) + "Parse from the given STRING a list of flycheck errors and +warnings, adding CHECKER and BUFFER to each one." + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (let ((messages (list))) + (while (search-forward-regexp + (concat "[\r\n]\\([A-Z]?:?[^ \r\n:][^:\n\r]+\\):\\([0-9()-:]+\\):" + "[ \n\r]+\\([[:unibyte:][:nonascii:]]+?\\)\n[^ ]") + nil t 1) + (let* ((file (match-string 1)) + (location-raw (match-string 2)) + (msg (match-string 3)) + (type (cond ((string-match "^Warning:" msg) + (setq msg (replace-regexp-in-string "^Warning: *" "" msg)) + 'warning) + ((string-match "^Splicing " msg) 'splice) + (t 'error))) + (location (intero-parse-error + (concat file ":" location-raw ": x"))) + (line (plist-get location :line)) + (column (plist-get location :col))) + (setq messages + (cons (flycheck-error-new-at + line column type msg + :checker checker + :buffer (when (string= (buffer-file-name buffer) + file) + buffer) + :filename file) + messages)))) + messages))) + +(defconst intero-error-regexp-alist + `((,(concat + "^ *\\(?1:[^\t\r\n]+?\\):" + "\\(?:" + "\\(?2:[0-9]+\\):\\(?4:[0-9]+\\)\\(?:-\\(?5:[0-9]+\\)\\)?" ;; "121:1" & "12:3-5" + "\\|" + "(\\(?2:[0-9]+\\),\\(?4:[0-9]+\\))-(\\(?3:[0-9]+\\),\\(?5:[0-9]+\\))" ;; "(289,5)-(291,36)" + "\\)" + ":\\(?6: Warning:\\)?") + 1 (2 . 3) (4 . 5) (6 . nil)) ;; error/warning locus + + ;; multiple declarations + ("^ \\(?:Declared at:\\| \\) \\(?1:[^ \t\r\n]+\\):\\(?2:[0-9]+\\):\\(?4:[0-9]+\\)$" + 1 2 4 0) ;; info locus + + ;; this is the weakest pattern as it's subject to line wrapping et al. + (" at \\(?1:[^ \t\r\n]+\\):\\(?2:[0-9]+\\):\\(?4:[0-9]+\\)\\(?:-\\(?5:[0-9]+\\)\\)?[)]?$" + 1 2 (4 . 5) 0)) ;; info locus + "Regexps used for matching GHC compile messages.") + +(defun intero-parse-error (string) + "Parse the line number from the error." + (let ((span nil)) + (cl-loop for regex + in intero-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 intero-call-in-buffer (buffer func &rest args) + "Utility function which calls FUNC in BUFFER with ARGS." + (with-current-buffer buffer + (apply func args))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Company integration (auto-completion) + +(defun company-intero (command &optional arg &rest ignored) + (interactive (list 'interactive)) + (cl-case command + (interactive (company-begin-backend 'company-intero)) + (prefix (let ((prefix-info (intero-completions-grab-prefix))) + (when prefix-info + (cl-destructuring-bind + (_beg _end prefix _type) prefix-info + prefix)))) + (candidates (intero-get-completions arg)))) + +(defun intero-completions-grab-prefix (&optional minlen) + "Grab prefix at point for possible completion." + (when (intero-completions-can-grab-prefix) + (let ((prefix (cond + ((intero-completions-grab-identifier-prefix))))) + (cond ((and minlen prefix) + (when (>= (length (nth 2 prefix)) minlen) + prefix)) + (prefix prefix))))) + +(defun intero-completions-can-grab-prefix () + "Check if the case is appropriate for grabbing completion prefix." + (when (not (region-active-p)) + (when (looking-at-p (rx (| space line-end punct))) + (when (not (bobp)) + (save-excursion + (backward-char) + (not (looking-at-p (rx (| space line-end))))))))) + +(defun intero-completions-grab-identifier-prefix () + "Grab identifier prefix." + (let ((pos-at-point (intero-ident-pos-at-point)) + (p (point))) + (when pos-at-point + (let* ((start (car pos-at-point)) + (end (cdr pos-at-point)) + (type 'haskell-completions-identifier-prefix) + (case-fold-search nil) + value) + (when (<= p end) + (setq end p) + (setq value (buffer-substring-no-properties start end)) + (when (string-match-p (rx bos upper) value) + (save-excursion + (goto-char (line-beginning-position)) + (when (re-search-forward + (rx "import" + (? (1+ space) "qualified") + (1+ space) + upper + (1+ (| alnum "."))) + p ;; bound + t) ;; no-error + (if (equal p (point)) + (setq type 'haskell-completions-module-name-prefix) + (when (re-search-forward + (rx (| " as " "(")) + start + t) + (setq type 'haskell-completions-identifier-prefix)))))) + (when (nth 8 (syntax-ppss)) + (setq type 'haskell-completions-general-prefix)) + (when value (list start end value type))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; REPL + +(defconst intero-prompt-regexp "^\4 ") + +(defun intero-repl-load () + "Load the current file in the REPL." + (interactive) + (let ((file (buffer-file-name)) + (repl-buffer (intero-repl-buffer))) + (with-current-buffer repl-buffer + (comint-send-string + (get-buffer-process (current-buffer)) + (concat ":l " file "\n"))) + (pop-to-buffer repl-buffer))) + +(defun intero-repl () + "Start up the REPL for this stack project." + (interactive) + (switch-to-buffer (intero-repl-buffer))) + +(defun intero-repl-buffer () + (let* ((root (intero-project-root)) + (package-name (intero-package-name)) + (name (format "*intero:%s:%s:repl*" + (file-name-nondirectory root) + package-name))) + (if (get-buffer name) + (get-buffer name) + (with-current-buffer + (get-buffer-create name) + (cd root) + (intero-repl-mode) + (current-buffer))))) + +(define-derived-mode intero-repl-mode comint-mode "Intero-REPL" + "Interactive prompt for Intero." + (when (and (not (eq major-mode 'fundamental-mode)) + (eq this-command 'intero-repl-mode)) + (error "You probably meant to run: M-x intero-repl")) + (set (make-local-variable 'comint-prompt-regexp) intero-prompt-regexp) + (let ((arguments (intero-make-options-list intero-targets))) + (insert (propertize + (format "Starting:\n stack ghci %s\n" (mapconcat #'identity arguments " ")) + 'face 'font-lock-comment-face)) + (let ((script (with-current-buffer (find-file-noselect (make-temp-file "intero-script")) + (insert ":set prompt \"\" +:set -fobject-code +:set prompt \"\\4 \" +") + (basic-save-buffer) + (buffer-file-name)))) + (let ((process (apply #'start-process "intero" (current-buffer) "stack" "ghci" + (append arguments + (list "--verbosity" "silent") + (list "--ghci-options" + (concat "-ghci-script=" script)))))) + (when (process-live-p process) + (message "Started Intero process for REPL.")))))) + +(font-lock-add-keywords + 'intero-repl-mode + '(("\\(\4\\)" + (0 (prog1 () + (compose-region (match-beginning 1) + (match-end 1) + ?λ)))))) + +(define-key intero-repl-mode-map [remap move-beginning-of-line] 'intero-repl-beginning-of-line) +(define-key intero-repl-mode-map [remap delete-backward-char] 'intero-repl-delete-backward-char) + +(defun intero-repl-delete-backward-char () + "Delete backwards, excluding the prompt." + (interactive) + (unless (looking-back intero-prompt-regexp) + (call-interactively 'delete-backward-char))) + +(defun intero-repl-beginning-of-line () + "Go to the beginning of the line, excluding the prompt." + (interactive) + (if (search-backward-regexp intero-prompt-regexp (line-beginning-position) t 1) + (goto-char (+ 2 (line-beginning-position))) + (call-interactively 'move-beginning-of-line))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Buffer operations + +(defun intero-thing-at-point () + "Return (list START END) of something at the point." + (if (region-active-p) + (list (region-beginning) + (region-end)) + (let ((pos (intero-ident-pos-at-point))) + (if pos + (list (car pos) (cdr pos)) + (list (point) (point)))))) + +(defun intero-ident-at-point () + "Return the identifier under point, or nil if none found. +May return a qualified name." + (let ((reg (intero-ident-pos-at-point))) + (when reg + (buffer-substring-no-properties (car reg) (cdr reg))))) + +(defun intero-ident-pos-at-point () + "Return the span of the identifier under point, or nil if none found. +May return a qualified name." + (save-excursion + ;; Skip whitespace if we're on it. That way, if we're at "map ", we'll + ;; see the word "map". + (if (and (not (eobp)) + (eq ? (char-syntax (char-after)))) + (skip-chars-backward " \t")) + + (let ((case-fold-search nil)) + (cl-multiple-value-bind (start end) + (list + (progn (skip-syntax-backward "w_") (point)) + (progn (skip-syntax-forward "w_") (point))) + ;; If we're looking at a module ID that qualifies further IDs, add + ;; those IDs. + (goto-char start) + (while (and (looking-at "[[:upper:]]") (eq (char-after end) ?.) + ;; It's a module ID that qualifies further IDs. + (goto-char (1+ end)) + (save-excursion + (when (not (zerop (skip-syntax-forward + (if (looking-at "\\s_") "_" "w'")))) + (setq end (point)))))) + ;; If we're looking at an ID that's itself qualified by previous + ;; module IDs, add those too. + (goto-char start) + (if (eq (char-after) ?.) (forward-char 1)) ;Special case for "." + (while (and (eq (char-before) ?.) + (progn (forward-char -1) + (not (zerop (skip-syntax-backward "w'")))) + (skip-syntax-forward "'") + (looking-at "[[:upper:]]")) + (setq start (point))) + ;; This is it. + (unless (= start end) + (cons start end)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Query/commands + +(defun intero-get-all-types () + "Get all types in all expressions in all modules." + (intero-blocking-call 'backend ":all-types")) + +(defun intero-get-type-at (beg end) + "Get the type at the given region denoted by BEG and END." + (replace-regexp-in-string + "\n$" "" + (intero-blocking-call + 'backend + (format ":type-at %S %d %d %d %d %S" + (buffer-file-name) + (save-excursion (goto-char beg) + (line-number-at-pos)) + (save-excursion (goto-char beg) + (1+ (current-column))) + (save-excursion (goto-char end) + (line-number-at-pos)) + (save-excursion (goto-char end) + (1+ (current-column))) + (buffer-substring-no-properties beg end))))) + +(defun intero-get-info-of (thing) + "Get info for the thing." + (replace-regexp-in-string + "\n$" "" + (intero-blocking-call + 'backend + (format ":i %s" thing)))) + +(defun intero-get-loc-at (beg end) + "Get the location of the identifier denoted by BEG and END." + (replace-regexp-in-string + "\n$" "" + (intero-blocking-call + 'backend + (format ":loc-at %S %d %d %d %d %S" + (buffer-file-name) + (save-excursion (goto-char beg) + (line-number-at-pos)) + (save-excursion (goto-char beg) + (1+ (current-column))) + (save-excursion (goto-char end) + (line-number-at-pos)) + (save-excursion (goto-char end) + (1+ (current-column))) + (buffer-substring-no-properties beg end))))) + +(defun intero-get-uses-at (beg end) + "Get the uses of the identifier denoted by BEG and END." + (replace-regexp-in-string + "\n$" "" + (intero-blocking-call + 'backend + (format ":uses %S %d %d %d %d %S" + (buffer-file-name) + (save-excursion (goto-char beg) + (line-number-at-pos)) + (save-excursion (goto-char beg) + (1+ (current-column))) + (save-excursion (goto-char end) + (line-number-at-pos)) + (save-excursion (goto-char end) + (1+ (current-column))) + (buffer-substring-no-properties beg end))))) + +(defun intero-get-completions (prefix) + "Get completions for a PREFIX." + (mapcar #'read + (cdr (split-string + (intero-blocking-call + 'backend + (format ":complete repl %S" prefix)) + "\n" + t)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Process communication + +(defun intero-delete-worker (worker) + "Delete the given worker." + (when (intero-buffer-p worker) + (with-current-buffer (intero-get-buffer-create worker) + (when (get-buffer-process (current-buffer)) + (setq intero-deleting t) + (kill-process (get-buffer-process (current-buffer))) + (delete-process (get-buffer-process (current-buffer)))) + (kill-buffer (current-buffer))))) + +(defun intero-blocking-call (worker cmd) + "Make a synchronous call of CMD to the process." + (let ((result (list nil))) + (intero-async-call + worker + cmd + result + (lambda (result reply) + (setf (car result) reply))) + (with-current-buffer (intero-buffer worker) + (while (not (null intero-callbacks)) + (sleep-for 0.0001))) + (car result))) + +(defun intero-async-call (worker cmd &optional state callback) + "Make an asynchronous call of CMD (string) to the process, +calling CALLBACK as (CALLBACK STATE REPLY)." + (with-current-buffer (intero-buffer worker) + (setq intero-callbacks + (append intero-callbacks + (list (list state + (or callback #'ignore) + cmd))))) + (process-send-string (intero-process worker) + (concat cmd "\n"))) + +(defun intero-buffer (worker) + "Get the worker buffer for the current directory." + (let ((buffer (intero-get-buffer-create worker))) + (if (get-buffer-process buffer) + buffer + (intero-get-worker-create worker nil (current-buffer))))) + +(defun intero-process (worker) + "Get the worker process for the current directory." + (get-buffer-process (intero-buffer worker))) + +(defun intero-get-worker-create (worker &optional targets source-buffer) + "Start an Intero worker." + (let* ((buffer (intero-get-buffer-create worker))) + (if (get-buffer-process buffer) + buffer + (if (intero-installed-p) + (intero-start-process-in-buffer buffer targets source-buffer) + (intero-auto-install buffer targets source-buffer))))) + +(defun intero-auto-install (buffer &optional targets source-buffer) + "Automatically install Intero." + (let ((source-buffer (or source-buffer (current-buffer)))) + (switch-to-buffer buffer) + (erase-buffer) + (insert "Intero is not installed in the Stack environment. + +Installing automatically ... + +") + (redisplay) + (cl-case (call-process "stack" nil (current-buffer) t "build" intero-package-version) + (0 + (message "Installed successfully! Starting Intero in a moment ...") + (bury-buffer buffer) + (switch-to-buffer source-buffer) + (intero-start-process-in-buffer buffer targets source-buffer)) + (1 (insert (propertize "Could not install Intero! + +We don't know why it failed. Please read the above output and try +installing manually. If that doesn't work, report this as a +problem. +" + 'face 'compilation-error)))))) + +(defun intero-start-process-in-buffer (buffer &optional targets source-buffer) + "Start an Intero worker in BUFFER for TARGETS, automatically +performing a initial actions in SOURCE-BUFFER, if specified." + (let* ((options + (intero-make-options-list + (or targets + (list (buffer-local-value 'intero-package-name buffer))))) + (arguments options) + (process (with-current-buffer buffer + (when debug-on-error + (message "Intero arguments: %S" arguments)) + (message "Booting up intero ...") + (apply #'start-process "stack" buffer "stack" "ghci" + arguments)))) + (process-send-string process ":set -fobject-code\n") + (process-send-string process ":set prompt \"\\4\"\n") + (with-current-buffer buffer + (erase-buffer) + (setq intero-targets targets) + (setq intero-arguments arguments) + (setq intero-callbacks + (list (list source-buffer + (lambda (source-buffer _msg) + (when source-buffer + (with-current-buffer source-buffer + (when flycheck-mode + (run-with-timer 0 nil + 'intero-call-in-buffer + (current-buffer) + 'flycheck-buffer)))) + (message "Booted up intero!")))))) + (set-process-filter process + (lambda (process string) + (when (buffer-live-p (process-buffer process)) + (with-current-buffer (process-buffer process) + (goto-char (point-max)) + (insert string) + (intero-read-buffer))))) + (set-process-sentinel process 'intero-sentinel) + buffer)) + +(defun intero-make-options-list (targets) + "Make the stack ghci options list." + (append (list "--with-ghc" + "intero" + "--docker-run-args=--interactive=true --tty=false" + "--no-load" + "--no-build") + (let ((dir (make-temp-file "intero" t))) + (list "--ghci-options" + (format "%S" (concat "-odir=" dir)) + "--ghci-options" + (format "%S" (concat "-hidir=" dir)))) + targets)) + +(defun intero-sentinel (process change) + "Handle a CHANGE to the PROCESS." + (when (buffer-live-p (process-buffer process)) + (when (and (not (process-live-p process))) + (if (with-current-buffer (process-buffer process) + intero-deleting) + (message "Intero process deleted.") + (intero-show-process-problem process change))))) + +(defun intero-installed-p () + "Is intero installed in the stack environment?" + (redisplay) + (= 0 (call-process "stack" nil nil nil "exec" "--" "intero" "--version"))) + +(defun intero-show-process-problem (process change) + "Show the user that a CHANGE occurred on PROCESS, causing it to +end." + (message "Problem with Intero!") + (switch-to-buffer (process-buffer process)) + (goto-char (point-max)) + (insert "\n---\n\n") + (insert + (propertize + (concat + "This is the buffer where Emacs talks to intero. It's normally hidden, +but a problem occcured. + +It may be obvious if there is some text above this message +indicating a problem. + +The process ended. Here is the reason that Emacs gives us: + +" + " " change + "\n" + "For troubleshooting purposes, here are the arguments used to launch intero: + +" + (format " stack ghci %s" + (mapconcat #'identity + intero-arguments + " ")) + " + +After fixing this problem, you could switch back to your code and +run M-x intero-restart to try again. + +You can kill this buffer when you're done reading it.\n") + 'face 'compilation-error))) + +(defun intero-read-buffer () + "In the process buffer, we read what's in it." + (let ((repeat t)) + (while repeat + (setq repeat nil) + (goto-char (point-min)) + (when (search-forward "\4" (point-max) t 1) + (let* ((next-callback (pop intero-callbacks)) + (state (nth 0 next-callback)) + (func (nth 1 next-callback))) + (let ((string (buffer-substring (point-min) (1- (point))))) + (if next-callback + (progn (with-temp-buffer + (funcall func state string)) + (setq repeat t)) + (when debug-on-error + (warn "Received output but no callback in `intero-callbacks': %S" + string))))) + (delete-region (point-min) (point)))))) + +(defun intero-get-buffer-create (worker) + "Get or create the stack buffer for this current directory and +the given targets." + (let* ((cabal-file (intero-cabal-find-file)) + (package-name (intero-package-name cabal-file)) + (buffer-name (intero-buffer-name worker)) + (default-directory (file-name-directory cabal-file))) + (with-current-buffer + (get-buffer-create buffer-name) + (setq intero-package-name package-name) + (cd default-directory) + (current-buffer)))) + +(defun intero-buffer-p (worker) + "Does a buffer exist for a given worker?" + (get-buffer (intero-buffer-name worker))) + +(defun intero-buffer-name (worker) + "For a given WORKER, create a buffer name." + (let* ((root (intero-project-root)) + (package-name (intero-package-name))) + (concat " intero:" + (format "%s" worker) + ":" + package-name + " " + root))) + +(defun intero-project-root () + "Get the directory where the stack.yaml is placed for this +project, or the global one." + (if intero-project-root + intero-project-root + (setq intero-project-root + (with-temp-buffer + (save-excursion + (call-process "stack" nil + (current-buffer) + nil + "path" + "--project-root" + "--verbosity" "silent")) + (buffer-substring (line-beginning-position) (line-end-position)))))) + +(defun intero-package-name (&optional cabal-file) + "Get the current package name from a nearby .cabal file. If +there is none, return empty string." + (or intero-package-name + (setq intero-package-name + (let ((cabal-file (or cabal-file + (intero-cabal-find-file)))) + (if cabal-file + (replace-regexp-in-string + ".cabal$" "" + (file-name-nondirectory cabal-file)) + ""))))) + +(defun intero-cabal-find-file (&optional dir) + "Search for package description file upwards starting from DIR. +If DIR is nil, `default-directory' is used as starting point for +directory traversal. Upward traversal is aborted if file owner +changes. Uses `intero-cabal-find-pkg-desc' internally." + (let ((use-dir (or dir default-directory))) + (while (and use-dir (not (file-directory-p use-dir))) + (setq use-dir (file-name-directory (directory-file-name use-dir)))) + (when use-dir + (catch 'found + (let ((user (nth 2 (file-attributes use-dir))) + ;; Abbreviate, so as to stop when we cross ~/. + (root (abbreviate-file-name use-dir))) + ;; traverse current dir up to root as long as file owner doesn't change + (while (and root (equal user (nth 2 (file-attributes root)))) + (let ((cabal-file (intero-cabal-find-pkg-desc root))) + (when cabal-file + (throw 'found cabal-file))) + + (let ((proot (file-name-directory (directory-file-name root)))) + (if (equal proot root) ;; fix-point reached? + (throw 'found nil) + (setq root proot)))) + nil))))) + +(defun intero-cabal-find-pkg-desc (dir &optional allow-multiple) + "Find a package description file in the directory DIR. +Returns nil if none or multiple \".cabal\" files were found. If +ALLOW-MULTIPLE is non nil, in case of multiple \".cabal\" files, +a list is returned instead of failing with a nil result." + ;; This is basically a port of Cabal's + ;; Distribution.Simple.Utils.findPackageDesc function + ;; http://hackage.haskell.org/packages/archive/Cabal/1.16.0.3/doc/html/Distribution-Simple-Utils.html + ;; but without the exception throwing. + (let* ((cabal-files + (cl-remove-if 'file-directory-p + (cl-remove-if-not 'file-exists-p + (directory-files dir t ".\\.cabal\\'"))))) + (cond + ((= (length cabal-files) 1) (car cabal-files)) ;; exactly one candidate found + (allow-multiple cabal-files) ;; pass-thru multiple candidates + (t nil)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide 'intero) + +;;; intero.el ends here diff --git a/intero.cabal b/intero.cabal --- a/intero.cabal +++ b/intero.cabal @@ -1,7 +1,7 @@ name: intero version: - 0.1.8 + 0.1.9 synopsis: Complete interactive development program for Haskell license: @@ -32,6 +32,8 @@ cbits/PosixSource.h CHANGELOG README.md +data-files: + elisp/*.el source-repository head type: git @@ -66,7 +68,7 @@ bytestring, directory, filepath, - ghc >= 7.8 && <= 7.10.3, + ghc >= 7.8 && <= 8.0.1, ghc-paths, haskeline, process, @@ -74,6 +76,12 @@ syb, containers, time + + if impl(ghc>=8.0.1) + build-depends: + ghci, + ghc-boot-th + if os(windows) build-depends: Win32 @@ -98,4 +106,5 @@ temporary, process, transformers, - directory + directory, + regex-compat diff --git a/src/GhciFind.hs b/src/GhciFind.hs --- a/src/GhciFind.hs +++ b/src/GhciFind.hs @@ -9,6 +9,7 @@ (findType,FindType(..),findLoc,findNameUses) where +import Module import Control.Exception import Data.List import Data.Map (Map) @@ -184,7 +185,9 @@ Just modL -> do case M.lookup (moduleName modL) infos of Nothing -> -#if __GLASGOW_HASKELL__ >= 709 +#if __GLASGOW_HASKELL__ >= 800 + do (return (Left (unitIdString (moduleUnitId modL) ++ ":" ++ +#elif __GLASGOW_HASKELL__ >= 709 do (return (Left (showppr d (modulePackageKey modL) ++ ":" ++ #else do (return (Left (showppr d (modulePackageId modL) ++ ":" ++ diff --git a/src/GhciInfo.hs b/src/GhciInfo.hs --- a/src/GhciInfo.hs +++ b/src/GhciInfo.hs @@ -133,7 +133,11 @@ Nothing -> return Nothing Just expr -> return (Just (case unwrapVar (unLoc e) of +#if __GLASGOW_HASKELL__ >= 800 + HsVar (L _ i) -> Just i +#else HsVar i -> Just i +#endif _ -> Nothing ,getLoc e ,CoreUtils.exprType expr)) @@ -145,8 +149,13 @@ => TypecheckedModule -> LPat Id -> m (Maybe (Maybe Id,SrcSpan,Type)) getTypeLPat _ (L spn pat) = return (Just (getMaybeId pat,spn,hsPatType pat)) - where getMaybeId (VarPat vid) = Just vid - getMaybeId _ = Nothing + where +#if __GLASGOW_HASKELL__ >= 800 + getMaybeId (VarPat (L _ vid)) = Just vid +#else + getMaybeId (VarPat vid) = Just vid +#endif + getMaybeId _ = Nothing -- | Get ALL source spans in the source. listifyAllSpans :: Typeable a diff --git a/src/GhciMonad.hs b/src/GhciMonad.hs --- a/src/GhciMonad.hs +++ b/src/GhciMonad.hs @@ -2,7 +2,7 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-cse -fno-warn-orphans -fno-warn-warnings-deprecations #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly ----------------------------------------------------------------------------- @@ -34,7 +34,6 @@ -- ghci-ng import GhciTypes import Data.Map.Strict (Map) - import qualified GHC import GhcMonad hiding (liftIO) import Outputable hiding (printForUser, printForUserPartWay) @@ -44,7 +43,12 @@ import HscTypes import SrcLoc import Module +#if __GLASGOW_HASKELL__ >= 800 +import GHCi.ObjLink as ObjLink +import GHC (BreakIndex) +#else import ObjLink +#endif import Linker import Exception @@ -383,9 +387,17 @@ initInterpBuffering :: Ghc () initInterpBuffering = do -- make sure these are linked +#if __GLASGOW_HASKELL__ < 800 dflags <- GHC.getSessionDynFlags +#else + hscEnv <- getSession +#endif liftIO $ do +#if __GLASGOW_HASKELL__ >= 800 + initDynLinker hscEnv +#else initDynLinker dflags +#endif -- ToDo: we should really look up these names properly, but -- it's a fiddle and not all the bits are exposed via the GHC diff --git a/src/InteractiveUI.hs b/src/InteractiveUI.hs --- a/src/InteractiveUI.hs +++ b/src/InteractiveUI.hs @@ -26,6 +26,10 @@ #include "HsVersions.h" -- Intero +#if __GLASGOW_HASKELL__ >= 800 +import GHCi +import GHCi.RemoteTypes +#endif import qualified Paths_intero import Data.Version (showVersion) import qualified Data.Map as M @@ -35,100 +39,109 @@ import GHC (getModuleGraph) -- GHCi +#if __GLASGOW_HASKELL__ >= 800 +import GHC.LanguageExtensions.Type +import GHCi.BreakArray as GHC +#endif import qualified GhciMonad ( args, runStmt ) -import GhciMonad hiding ( args, runStmt ) -import GhciTags -import Debugger +import GhciMonad hiding ( args, runStmt ) +import GhciTags +import Debugger -- The GHC interface -import DynFlags -import GhcMonad ( modifySession ) +import DynFlags +import GhcMonad ( modifySession ) import qualified GHC import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..), TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc, handleSourceError ) -import HsImpExp +import HsImpExp import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC, setInteractivePrintName ) -import Module -import Name +import Module +import Name #if __GLASGOW_HASKELL__ < 709 -import Packages ( trusted, getPackageDetails, exposed, exposedModules, pkgIdMap ) +import Packages ( trusted, getPackageDetails, exposed, exposedModules, pkgIdMap ) #else -import Packages ( trusted, getPackageDetails, listVisibleModuleNames ) +import Packages ( trusted, getPackageDetails, listVisibleModuleNames ) #endif -import PprTyThing -import RdrName ( getGRE_NameQualifier_maybes ) -import SrcLoc +import PprTyThing +import RdrName ( getGRE_NameQualifier_maybes ) +import SrcLoc import qualified Lexer -import StringBuffer +import StringBuffer #if __GLASGOW_HASKELL__ < 709 -import UniqFM ( eltsUFM ) +import UniqFM ( eltsUFM ) #endif -import Outputable hiding ( printForUser, printForUserPartWay, bold ) +import Outputable hiding ( printForUser, printForUserPartWay, bold ) -- Other random utilities -import BasicTypes hiding ( isTopLevel ) -import Config -import Digraph -import Encoding -import FastString -import Linker -import Maybes ( orElse, expectJust ) -import NameSet -import Panic hiding ( showException ) -import Util +import BasicTypes hiding ( isTopLevel ) +import Config +import Digraph +import Encoding +import FastString +import Linker +import Maybes ( orElse, expectJust ) +import NameSet +import Panic hiding ( showException ) +import Util -- Haskell Libraries -import System.Console.Haskeline as Haskeline +import System.Console.Haskeline as Haskeline -import Control.Applicative hiding (empty) -import Control.Monad as Monad -import Control.Monad.Trans.Class -import Control.Monad.IO.Class +import Control.Applicative hiding (empty) +import Control.Monad as Monad +import Control.Monad.Trans.Class +import Control.Monad.IO.Class -import Data.Array +import Data.Array import qualified Data.ByteString.Char8 as BS -import Data.Char -import Data.Function -import Data.IORef ( IORef, readIORef, writeIORef ) +import Data.Char +import Data.Function +import Data.IORef ( IORef, readIORef, writeIORef ) import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub, partition, sort, sortBy ) -import Data.Maybe +import Data.Maybe -import Exception hiding (catch) +import Exception hiding (catch) -import Foreign.C +import Foreign.C #if __GLASGOW_HASKELL__ < 709 -import Foreign.Safe +import Foreign.Safe #else -import Foreign +import Foreign #endif -import System.Directory -import System.Environment -import System.Exit ( exitWith, ExitCode(..) ) -import System.FilePath -import System.IO -import System.IO.Error -import System.IO.Unsafe ( unsafePerformIO ) -import System.Process -import Text.Printf -import Text.Read ( readMaybe ) +import System.Directory +import System.Environment +import System.Exit ( exitWith, ExitCode(..) ) +import System.FilePath +import System.IO +import System.IO.Error +import System.IO.Unsafe ( unsafePerformIO ) +import System.Process +import Text.Printf +import Text.Read ( readMaybe ) #ifndef mingw32_HOST_OS -import System.Posix hiding ( getEnv ) +import System.Posix hiding ( getEnv ) #else import qualified System.Win32 #endif -import GHC.Exts ( unsafeCoerce# ) -import GHC.IO.Exception ( IOErrorType(InvalidArgument) ) -import GHC.IO.Handle ( hFlushAll ) -import GHC.TopHandler ( topHandler ) +import GHC.Exts ( unsafeCoerce# ) +import GHC.IO.Exception ( IOErrorType(InvalidArgument) ) +import GHC.IO.Handle ( hFlushAll ) +import GHC.TopHandler ( topHandler ) -#if __GLASGOW_HASKELL__ < 709 +#if __GLASGOW_HASKELL__ >= 800 +packageString :: UnitId -> String +packageString = unitIdString +modulePackage :: Module -> UnitId +modulePackage = moduleUnitId +#elif __GLASGOW_HASKELL__ < 709 packageString :: PackageId -> String packageString = packageIdString modulePackage :: Module -> PackageId @@ -405,6 +418,47 @@ default_args :: [String] default_args = [] + +#if __GLASGOW_HASKELL__ >= 800 +compat_ExtendedDefaultRules :: Extension +compat_ExtendedDefaultRules = + ExtendedDefaultRules +#else +compat_ExtendedDefaultRules :: ExtensionFlag +compat_ExtendedDefaultRules = + Opt_ExtendedDefaultRules +#endif + +#if __GLASGOW_HASKELL__ >= 800 +compat_AlternativeLayoutRule :: Extension +compat_AlternativeLayoutRule = + AlternativeLayoutRule +#else +compat_AlternativeLayoutRule :: ExtensionFlag +compat_AlternativeLayoutRule = + Opt_AlternativeLayoutRule +#endif + +#if __GLASGOW_HASKELL__ >= 800 +compat_ImplicitPrelude :: Extension +compat_ImplicitPrelude = + ImplicitPrelude +#else +compat_ImplicitPrelude :: ExtensionFlag +compat_ImplicitPrelude = + Opt_ImplicitPrelude +#endif + +#if __GLASGOW_HASKELL__ >= 800 +compat_MonomorphismRestriction :: Extension +compat_MonomorphismRestriction = + MonomorphismRestriction +#else +compat_MonomorphismRestriction :: ExtensionFlag +compat_MonomorphismRestriction = + Opt_MonomorphismRestriction +#endif + interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc () interactiveUI config srcs maybe_exprs = do @@ -434,8 +488,8 @@ -- as the global DynFlags, plus -XExtendedDefaultRules and -- -XNoMonomorphismRestriction. dflags <- getDynFlags - let dflags' = (`xopt_set` Opt_ExtendedDefaultRules) - . (`xopt_unset` Opt_MonomorphismRestriction) + let dflags' = (`xopt_set` compat_ExtendedDefaultRules) + . (`xopt_unset` compat_MonomorphismRestriction) $ dflags GHC.setInteractiveDynFlags dflags' @@ -451,8 +505,8 @@ -- intended for the program, so unbuffer stdin. hSetBuffering stdin NoBuffering hSetBuffering stderr NoBuffering -#if defined(mingw32_HOST_OS) -- On Unix, stdin will use the locale encoding. The IO library +#if defined(mingw32_HOST_OS) -- doesn't do this on Windows (yet), so for now we use UTF-8, -- for consistency with GHC 6.10 and to make the tests work. hSetEncoding stdin utf8 @@ -460,7 +514,6 @@ default_editor <- liftIO $ findEditor - names <- GHC.getRdrNamesInScope startGHCi (runGHCi srcs maybe_exprs) GHCiState{ progname = default_progname, GhciMonad.args = default_args, @@ -482,7 +535,7 @@ short_help = shortHelpText config, long_help = fullHelpText config, mod_infos = M.empty, - rdrNamesInScope = names + rdrNamesInScope = [] } return () @@ -569,6 +622,10 @@ -- reset line number getGHCiState >>= \st -> setGHCiState st{line_number=1} + -- Get the names in scope + names <- GHC.getRdrNamesInScope + modifyGHCiState (\s -> s { rdrNamesInScope = names }) + case maybe_exprs of Nothing -> do @@ -867,7 +924,7 @@ -> InputT GHCi (Maybe String) checkInputForLayout stmt getStmt = do dflags' <- lift $ getDynFlags - let dflags = xopt_set dflags' Opt_AlternativeLayoutRule + let dflags = xopt_set dflags' compat_AlternativeLayoutRule st0 <- lift $ getGHCiState let buf' = stringToStringBuffer stmt loc = mkRealSrcLoc (fsLit (progname st0)) (line_number st0) 1 @@ -1536,20 +1593,32 @@ setGHCContextFromGHCiState +-- keepPackageImports :: [InteractiveImport] -> GHCi [InteractiveImport] +-- keepPackageImports = filterM is_pkg_import +-- where +-- is_pkg_import :: InteractiveImport -> GHCi Bool +-- is_pkg_import (IIModule _) = return False +-- is_pkg_import (IIDecl d) +-- = do e <- gtry $ GHC.findModule mod_name (ideclPkgQual d) +-- case e :: Either SomeException Module of +-- Left _ -> return False +-- Right m -> return (not (isHomeModule m)) +-- where +-- mod_name = unLoc (ideclName d) + keepPackageImports :: [InteractiveImport] -> GHCi [InteractiveImport] keepPackageImports = filterM is_pkg_import where is_pkg_import :: InteractiveImport -> GHCi Bool is_pkg_import (IIModule _) = return False is_pkg_import (IIDecl d) - = do e <- gtry $ GHC.findModule mod_name (ideclPkgQual d) + = do e <- gtry $ GHC.findModule mod_name (fmap sl_fs $ ideclPkgQual d) case e :: Either SomeException Module of Left _ -> return False Right m -> return (not (isHomeModule m)) where mod_name = unLoc (ideclName d) - modulesLoadedMsg :: SuccessFlag -> [Module] -> InputT GHCi () modulesLoadedMsg ok mods = do dflags <- getDynFlags @@ -1873,13 +1942,26 @@ -- Guess which module the user wants to browse. Pick -- modules that are interpreted first. The most -- recently-added module occurs last, it seems. +-- guessCurrentModule cmd +-- = do imports <- GHC.getContext +-- when (null imports) $ throwGhcException $ +-- CmdLineError (':' : cmd ++ ": no current module") +-- case (head imports) of +-- IIModule m -> GHC.findModule m Nothing +-- IIDecl d -> GHC.findModule (unLoc (ideclName d)) (ideclPkgQual d) + + +-- Guess which module the user wants to browse. Pick +-- modules that are interpreted first. The most +-- recently-added module occurs last, it seems. guessCurrentModule cmd = do imports <- GHC.getContext when (null imports) $ throwGhcException $ CmdLineError (':' : cmd ++ ": no current module") case (head imports) of IIModule m -> GHC.findModule m Nothing - IIDecl d -> GHC.findModule (unLoc (ideclName d)) (ideclPkgQual d) + IIDecl d -> GHC.findModule (unLoc (ideclName d)) + (fmap sl_fs $ ideclPkgQual d) -- without bang, show items in context of their parents and omit children -- with bang, show class methods and data constructors separately, and @@ -2065,6 +2147,22 @@ -- Validate a module that we want to add to the context checkAdd :: InteractiveImport -> GHCi () +-- checkAdd ii = do +-- dflags <- getDynFlags +-- let safe = safeLanguageOn dflags +-- case ii of +-- IIModule modname +-- | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell" +-- | otherwise -> wantInterpretedModuleName modname >> return () + +-- IIDecl d -> do +-- let modname = unLoc (ideclName d) +-- pkgqual = ideclPkgQual d +-- m <- GHC.lookupModule modname pkgqual +-- when safe $ do +-- t <- GHC.isModuleTrusted m +-- when (not t) $ throwGhcException $ ProgramError $ "" + checkAdd ii = do dflags <- getDynFlags let safe = safeLanguageOn dflags @@ -2076,7 +2174,7 @@ IIDecl d -> do let modname = unLoc (ideclName d) pkgqual = ideclPkgQual d - m <- GHC.lookupModule modname pkgqual + m <- GHC.lookupModule modname (fmap sl_fs pkgqual) when safe $ do t <- GHC.isModuleTrusted m when (not t) $ throwGhcException $ ProgramError $ "" @@ -2108,7 +2206,7 @@ iidecls <- filterM (tryBool.checkAdd) (transient_ctx st ++ remembered_ctx st) dflags <- GHC.getSessionDynFlags GHC.setContext $ - if xopt Opt_ImplicitPrelude dflags && not (any isPreludeImport iidecls) + if xopt compat_ImplicitPrelude dflags && not (any isPreludeImport iidecls) then iidecls ++ [implicitPreludeImport] else iidecls -- XXX put prel at the end, so that guessCurrentModule doesn't pick it up. @@ -2251,7 +2349,7 @@ nest 2 (vcat (map (setting gopt) others)) putStrLn $ showSDoc dflags $ text "warning settings:" $$ - nest 2 (vcat (map (setting wopt) DynFlags.fWarningFlags)) + nest 2 (vcat (map (setting wopt) compat_warningFlags)) where #if __GLASGOW_HASKELL__ < 709 setting test (str, f, _) @@ -2282,6 +2380,11 @@ , Opt_BreakOnError , Opt_PrintEvldWithShow ] +#if __GLASGOW_HASKELL__ < 800 + compat_warningFlags = DynFlags.fWarningFlags +#else + compat_warningFlags = DynFlags.wWarningFlags +#endif setArgs, setOptions :: [String] -> GHCi () setProg, setEditor, setStop :: String -> GHCi () @@ -2380,7 +2483,12 @@ "package flags have changed, resetting and loading new packages..." GHC.setTargets [] _ <- GHC.load LoadAllTargets - liftIO $ linkPackages dflags2 new_pkgs +#if __GLASGOW_HASKELL__ < 800 + linkinfo <- return dflags2 +#else + linkinfo <- GHC.getSession +#endif + liftIO $ linkPackages linkinfo new_pkgs -- package flags changed, we can't re-use any of the old context setContextAfterLoad False [] -- and copy the package state to the interactive DynFlags @@ -2509,7 +2617,7 @@ prel_imp | any isPreludeImport (rem_ctx ++ trans_ctx) = [] - | not (xopt Opt_ImplicitPrelude dflags) = [] + | not (xopt compat_ImplicitPrelude dflags) = [] | otherwise = ["import Prelude -- implicit"] trans_comment s = s ++ " -- added automatically" @@ -2585,16 +2693,24 @@ -- This flag now has more info about module renaming. -- @see -- https://downloads.haskell.org/~ghc/latest/docs/html/libraries/ghc-7.10.1/DynFlags.html#v:ExposePackage +#if __GLASGOW_HASKELL__ >= 800 + showFlag (ExposePackage _str arg _mr) = text $ " -package " ++ show arg +#else showFlag (ExposePackage arg mr) = text $ " -package " ++ show arg ++ " " ++ show mr #endif +#endif showFlag (HidePackage p) = text $ " -hide-package " ++ p +#if __GLASGOW_HASKELL__ < 800 showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p +#endif #if __GLASGOW_HASKELL__ < 709 -- This flag just isn't in the 7.10 API showFlag (ExposePackageId p) = text $ " -package-id " ++ p #endif +#if __GLASGOW_HASKELL__ < 800 showFlag (TrustPackage p) = text $ " -trust " ++ p showFlag (DistrustPackage p) = text $ " -distrust " ++ p +#endif showPaths :: GHCi () showPaths = do @@ -2763,11 +2879,11 @@ completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do return (filter (w `isPrefixOf`) opts) where opts = "args":"prog":"prompt":"prompt2":"editor":"stop":flagList - flagList = map head $ group $ sort allFlags + flagList = map head $ group $ sort compat_allFlags completeSeti = wrapCompleter flagWordBreakChars $ \w -> do return (filter (w `isPrefixOf`) flagList) - where flagList = map head $ group $ sort allFlags + where flagList = map head $ group $ sort compat_allFlags completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do return (filter (w `isPrefixOf`) opts) @@ -2945,7 +3061,11 @@ backCmd :: String -> GHCi () backCmd = noArgs $ withSandboxOnly ":back" $ do +#if __GLASGOW_HASKELL__ < 800 (names, _, pan) <- GHC.back +#else + (names, _, pan, _) <- GHC.back 1 +#endif printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr pan printTypeOfNames names -- run the command set with ":set stop " @@ -2954,7 +3074,11 @@ forwardCmd :: String -> GHCi () forwardCmd = noArgs $ withSandboxOnly ":forward" $ do +#if __GLASGOW_HASKELL__ >= 800 + (names, ix, pan, _ ) <- GHC.forward 1 +#else (names, ix, pan) <- GHC.forward +#endif printForUser $ (if (ix == 0) then ptext (sLit "Stopped at") else ptext (sLit "Logged breakpoint at")) <+> ppr pan @@ -3023,7 +3147,7 @@ case lookupTickTree tickArray of Nothing -> liftIO $ putStrLn $ "No breakpoints found at that location." Just (tick, pan) -> do - success <- liftIO $ setBreakFlag dflags True breakArray tick + success <- setBreakFlag dflags True breakArray tick if success then do (alreadySet, nm) <- @@ -3308,9 +3432,13 @@ turnOffBreak loc = do dflags <- getDynFlags (arr, _) <- getModBreak (breakModule loc) - liftIO $ setBreakFlag dflags False arr (breakTick loc) + setBreakFlag dflags False arr (breakTick loc) -getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan) +#if __GLASGOW_HASKELL__ >= 800 +getModBreak :: Module -> GHCi (ForeignRef BreakArray, Array Int SrcSpan) +#else +getModBreak :: GHC.GhcMonad m => Module -> m (GHC.BreakArray, Array BreakIndex SrcSpan) +#endif getModBreak m = do Just mod_info <- GHC.getModuleInfo m let modBreaks = GHC.modInfoModBreaks mod_info @@ -3318,10 +3446,18 @@ let ticks = GHC.modBreaks_locs modBreaks return (arr, ticks) -setBreakFlag :: DynFlags -> Bool -> GHC.BreakArray -> Int -> IO Bool +#if __GLASGOW_HASKELL__ >= 800 +setBreakFlag :: DynFlags -> Bool -> ForeignRef BreakArray -> Int -> GHCi Bool +setBreakFlag _ toggle arr i = do + hsc_env <- GHC.getSession + liftIO $ enableBreakpoint hsc_env arr i toggle + return True +#else +setBreakFlag :: DynFlags -> Bool -> GHC.BreakArray -> Int -> GHCi Bool setBreakFlag dflags toggle arr i - | toggle = GHC.setBreakOn dflags arr i - | otherwise = GHC.setBreakOff dflags arr i + | toggle = liftIO $ GHC.setBreakOn dflags arr i + | otherwise = liftIO $ GHC.setBreakOff dflags arr i +#endif -- --------------------------------------------------------------------------- @@ -3350,7 +3486,7 @@ -- omit the location for CmdLineError: Just (CmdLineError s) -> putException s -- ditto: - Just ph@(PhaseFailed {}) -> putException (showGhcException ph "") + -- Just ph@(PhaseFailed {}) -> putException (showGhcException ph "") Just other_ghc_ex -> putException (show other_ghc_ex) Nothing -> case fromException se of @@ -3392,7 +3528,9 @@ lookupModuleName mName = GHC.lookupModule mName Nothing isHomeModule :: Module -> Bool -#if __GLASGOW_HASKELL__ < 709 +#if __GLASGOW_HASKELL__ >= 800 +isHomeModule m = modulePackage m == mainUnitId +#elif __GLASGOW_HASKELL__ < 709 isHomeModule m = modulePackage m == mainPackageId #else isHomeModule m = modulePackage m == mainPackageKey @@ -3448,3 +3586,16 @@ then noCanDo n $ text "module " <> ppr modl <> text " is not interpreted" else and_then n + +#if __GLASGOW_HASKELL__ < 800 +sl_fs :: a -> a +sl_fs = id +#endif + + +compat_allFlags :: [String] +#if __GLASGOW_HASKELL__ < 800 +compat_allFlags = allFlags +#else +compat_allFlags = allNonDeprecatedFlags +#endif diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,6 +1,6 @@ {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE CPP #-} -{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} +{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE -fno-warn-warnings-deprecations #-} {-# LANGUAGE ForeignFunctionInterface #-} ----------------------------------------------------------------------------- @@ -661,7 +661,7 @@ haskellish (f,Nothing) = looksLikeModuleName f || isHaskellUserSrcFilename f || '.' `notElem` f haskellish (_,Just phase) = - phase `notElem` [as True, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn] + phase `notElem` [as True, Cc, Cobjc, CmmCpp, Cmm, StopLn] hsc_env <- GHC.getSession @@ -853,7 +853,7 @@ where oneError f = "unrecognised flag: " ++ f ++ "\n" ++ - (case fuzzyMatch f (nub allFlags) of + (case fuzzyMatch f (nub compat_allFlags) of [] -> "" suggs -> "did you mean one of:\n" ++ unlines (map (" " ++) suggs)) @@ -886,4 +886,11 @@ as = As #else as _ = As +#endif + +compat_allFlags :: [String] +#if __GLASGOW_HASKELL__ < 800 +compat_allFlags = allFlags +#else +compat_allFlags = allNonDeprecatedFlags #endif diff --git a/src/test/Main.hs b/src/test/Main.hs --- a/src/test/Main.hs +++ b/src/test/Main.hs @@ -10,6 +10,7 @@ import System.IO.Temp import System.Process import Test.Hspec +import Text.Regex -- | Main entry point. main :: IO () @@ -29,6 +30,7 @@ use definition bytecode + completion -- | Argument parsing should be user-friendly. argsparser :: Spec @@ -49,9 +51,13 @@ basics :: Spec basics = describe "Basics" - (do it ":t 1" (eval ":t 1" "1 :: Num a => a\n") + (do it ":t 1" (eval ":t 1 :: Num a => a" "1 :: Num a => a :: Num a => a\n") it ":i Nothing" - (eval ":i Nothing" "data Maybe a = Nothing | ... \t-- Defined in ‘GHC.Base’\n") + (do reply <- + withIntero [] + (\_ repl -> repl ":i Nothing") + shouldBe (subRegex (mkRegex "Data.Maybe") reply "GHC.Base") + "data Maybe a = Nothing | ... \t-- Defined in ‘GHC.Base’\n") it ":k Just" (eval ":k Maybe" "Maybe :: * -> *\n")) -- | Loading files and seeing the results. @@ -73,9 +79,11 @@ (do result <- withIntero [] (\_ repl -> repl (":l NonExistent.hs")) - shouldBe result (unlines ["Failed, modules loaded: none." - ,"" - ,": can't find file: NonExistent.hs"]))) + shouldBe (stripError result) + (unlines ["Failed, modules loaded: none." + ,"" + ,": can't find file: NonExistent.hs"]))) + where stripError = \i -> subRegex (mkRegex "error: ") i "" -- | Check things when in -fbyte-code mode. bytecode :: Spec @@ -175,20 +183,24 @@ (do it ":uses X.hs 1 1 1 1 x -- from definition site" (uses "x = 'a' : x" (1,1,1,1,"x") + id (unlines ["X.hs:(1,1)-(1,2)" ,"X.hs:(1,1)-(1,2)" ,"X.hs:(1,11)-(1,12)"])) it ":uses X.hs 1 11 1 12 x -- from use site" (uses "x = 'a' : x" (1,11,1,12,"x") + id (unlines ["X.hs:(1,1)-(1,2)","X.hs:(1,11)-(1,12)"])) it ":uses X.hs 1 5 1 6 id -- package definition" (uses "x = id" (1,5,1,6,"id") - (unlines ["base-4.8.2.0:GHC.Base"])) + (\i -> subRegex (mkRegex "-[0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+") i "") + (unlines ["base:GHC.Base"])) it ":uses X.hs 1 5 1 6 id -- shadowed package definition" (uses "x = id where id = ()" (1,5,1,7,"id") + id (unlines ["X.hs:(1,14)-(1,16)" ,"X.hs:(1,14)-(1,16)" ,"X.hs:(1,5)-(1,7)"]))) @@ -214,6 +226,18 @@ (1,20,1,21,"x") (unlines ["X.hs:(1,9)-(1,10)"]))) +-- | Test interactive completions. +completion :: Spec +completion = + describe "Complete basic Prelude identifiers" + (issue ":complete repl \"put\"" + "https://github.com/chrisdone/intero/issues/34" + (eval ":complete repl \"put\"" + (unlines ["3 3 \"\"" + ,"\"putChar\"" + ,"\"putStr\"" + ,"\"putStrLn\""]))) + -------------------------------------------------------------------------------- -- Combinators for running and interacting with intero @@ -235,8 +259,8 @@ -- | Find use-sites for the given place. uses - :: String -> (Int,Int,Int,Int,String) -> String -> Expectation -uses file (line,col,line',col',name) expected = + :: String -> (Int,Int,Int,Int,String) -> (String -> String) -> String -> Expectation +uses file (line,col,line',col',name) preprocess expected = do result <- withIntero [] @@ -245,7 +269,7 @@ _ <- repl (":l X.hs") repl (":uses X.hs " ++ unwords (map show [line,col,line',col']) ++ " " ++ name)) - shouldBe result expected + shouldBe (preprocess result) expected -- | Test the type at the given place. typeAt