diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -1,4 +1,4 @@
-# 
intero [](https://travis-ci.org/commercialhaskell/intero) [](https://melpa.org/#/intero) [](https://stable.melpa.org/#/intero) [](https://ci.appveyor.com/project/commercialhaskell/intero)
+# intero [](https://travis-ci.org/commercialhaskell/intero) [](https://melpa.org/#/intero) [](https://stable.melpa.org/#/intero) [](https://ci.appveyor.com/project/commercialhaskell/intero)
Complete interactive development program for Haskell
diff --git a/elisp/intero.el b/elisp/intero.el
--- a/elisp/intero.el
+++ b/elisp/intero.el
@@ -70,7 +70,7 @@
:group 'haskell)
(defcustom intero-package-version
- "0.1.24"
+ "0.1.25"
"Package version to auto-install.
This version does not necessarily have to be the latest version
@@ -135,6 +135,22 @@
:group 'intero
:type 'boolean)
+(defcustom intero-extra-ghc-options nil
+ "Extra GHC options to pass to intero executable.
+
+For example, this variable can be used to run intero with extra
+warnings and perform more checks via flycheck error reporting."
+ :group 'intero
+ :type '(repeat string))
+
+(defcustom intero-extra-ghci-options nil
+ "Extra options to pass to GHCi when running `intero-repl'.
+
+For example, this variable can be used to enable some ghci extensions
+by default."
+ :group 'intero
+ :type '(repeat string))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Modes
@@ -244,6 +260,21 @@
"List of callbacks waiting for output.
LIST is a FIFO.")
+(defvar-local intero-async-network-cmd nil
+ "Command to send to the async network process when we connect.")
+
+(defvar-local intero-async-network-connected nil
+ "Did we successfully connect to the intero service?")
+
+(defvar-local intero-async-network-state nil
+ "State to pass to the callback once we get a response.")
+
+(defvar-local intero-async-network-worker nil
+ "The worker we're associated with.")
+
+(defvar-local intero-async-network-callback nil
+ "Callback to call when the connection is closed.")
+
(defvar-local intero-arguments (list)
"Arguments used to call the stack process.")
@@ -279,6 +310,9 @@
(defvar-local intero-starting nil
"When non-nil, indicates that the intero process starting up.")
+(defvar-local intero-service-port nil
+ "Port that the intero process is listening on for asynchronous commands.")
+
(defvar-local intero-hoogle-port nil
"Port that hoogle server is listening on.")
@@ -344,7 +378,7 @@
(interactive)
(let ((buffers (cl-remove-if-not
(lambda (buffer)
- (string-match " intero:" (buffer-name buffer)))
+ (string-match-p " intero:" (buffer-name buffer)))
(buffer-list))))
(if buffers
(display-buffer
@@ -518,7 +552,7 @@
(forward-char 1)
(looking-back "$(" 1))
(+ 2 (current-column))
- (if (looking-at "$(")
+ (if (looking-at-p "$(")
(+ 3 (current-column))
(1+ (current-column)))))
(expansion-msg
@@ -632,7 +666,7 @@
":load DevelMain"
(current-buffer)
(lambda (buffer reply)
- (if (string-match "^O[Kk], modules loaded" reply)
+ (if (string-match-p "^O[Kk], modules loaded" reply)
(intero-async-call
'backend
"DevelMain.update"
@@ -747,14 +781,19 @@
(match-string 3))) ;; Replace gross bullet points.
(type (cond ((string-match "^Warning:" msg)
(setq msg (replace-regexp-in-string "^Warning: *" "" msg))
- (if (or (string-match "^\\[-Wdeferred-type-errors\\]" msg)
- (string-match "^\\[-Wdeferred-out-of-scope-variables\\]" msg)
- (string-match "^\\[-Wtyped-holes\\]" msg))
+ (if (string-match-p
+ (rx bol
+ "["
+ (or "-Wdeferred-type-errors"
+ "-Wdeferred-out-of-scope-variables"
+ "-Wtyped-holes")
+ "]")
+ msg)
(progn (setq found-error-as-warning t)
'error)
'warning))
- ((string-match "^Splicing " msg) 'splice)
- (t 'error)))
+ ((string-match-p "^Splicing " msg) 'splice)
+ (t 'error)))
(location (intero-parse-error
(concat local-file ":" location-raw ": x")))
(line (plist-get location :line))
@@ -796,19 +835,18 @@
(defun intero-parse-error (string)
"Parse the line number from the error in STRING."
- (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))
+ (save-match-data
+ (when (string-match (mapconcat #'car intero-error-regexp-alist "\\|")
+ string)
+ (let ((string3 (match-string 3 string))
+ (string5 (match-string 5 string)))
+ (list :file (match-string 1 string)
+ :line (string-to-number (match-string 2 string))
+ :col (string-to-number (match-string 4 string))
+ :line2 (when string3
+ (string-to-number string3))
+ :col2 (when string5
+ (string-to-number string5)))))))
(defun intero-call-in-buffer (buffer func &rest args)
"In BUFFER, call FUNC with ARGS."
@@ -893,7 +931,7 @@
(funcall cont
(cl-remove-if-not
(lambda (candidate)
- (string-match (concat "^" prefix) candidate))
+ (string-prefix-p prefix candidate))
intero-pragmas))
t)))
(intero-get-repl-completions source-buffer prefix cont))))
@@ -904,6 +942,7 @@
considered."
(when (intero-completions-can-grab-prefix)
(let ((prefix (cond
+ ((intero-completions-grab-ghci-command))
((intero-completions-grab-pragma-prefix))
((intero-completions-grab-identifier-prefix)))))
(cond ((and minlen prefix)
@@ -920,6 +959,24 @@
(backward-char)
(not (looking-at-p (rx (| space line-end)))))))))
+(defun intero-completions-grab-ghci-command ()
+ "Grab prefix for a ghci command like :set.
+Returns (prefix-start-position prefix-end-position prefix-value prefix-type)"
+ (when (derived-mode-p 'intero-repl-mode)
+ (save-excursion
+ (let ((end (point)))
+ (when (save-excursion
+ (beginning-of-line)
+ (looking-at-p (rx (* " ")
+ ":set"
+ (* " "))))
+ (skip-syntax-backward "^ >")
+ (let ((start (point)))
+ (list start
+ end
+ (concat ":set " (buffer-substring-no-properties start end))
+ 'haskell-completions-repl-command)))))))
+
(defun intero-completions-grab-identifier-prefix ()
"Grab identifier prefix."
(let ((pos-at-point (intero-ident-pos-at-point))
@@ -1251,6 +1308,7 @@
stack-yaml
(buffer-local-value 'intero-stack-yaml backend-buffer)))
(arguments (intero-make-options-list
+ "ghci"
(or targets
(let ((package-name (buffer-local-value 'intero-package-name
backend-buffer)))
@@ -1269,6 +1327,7 @@
(insert ":set prompt \"\"
:set -fbyte-code
:set -fdefer-type-errors
+:set -fdiagnostics-color=never
:set prompt \"\\4 \"
")
(basic-save-buffer)
@@ -1282,7 +1341,8 @@
(append arguments
(list "--verbosity" "silent")
(list "--ghci-options"
- (concat "-ghci-script=" script)))))))
+ (concat "-ghci-script=" script))
+ (cl-mapcan (lambda (x) (list "--ghci-options" x)) intero-extra-ghci-options))))))
(when (process-live-p process)
(set-process-query-on-exit-flag process nil)
(message "Started Intero process for REPL.")
@@ -1386,7 +1446,7 @@
;; First, skip whitespace if we're on it, moving point to last
;; identifier char. That way, if we're at "map ", we'll see the word
;; "map".
- (when (and (looking-at (rx eol))
+ (when (and (looking-at-p (rx eol))
(not (bolp)))
(backward-char))
(when (and (not (eobp))
@@ -1426,7 +1486,7 @@
;; Try to slurp qualification part first.
(skip-syntax-forward "w_")
(setq end (point))
- (while (and (looking-at (rx "." upper))
+ (while (and (looking-at-p (rx "." upper))
(not (zerop (progn (forward-char)
(skip-syntax-forward "w_")))))
(setq end (point)))
@@ -1450,14 +1510,14 @@
Expects point stands *after* delimiting dot.
Returns beginning position of qualified part or nil if no qualified part found."
(when (not (and (bobp)
- (looking-at (rx bol))))
+ (looking-at-p (rx bol))))
(let ((case-fold-search nil)
pos)
(while (and (eq (char-before) ?.)
(progn (backward-char)
(not (zerop (skip-syntax-backward "w'"))))
(skip-syntax-forward "'")
- (looking-at "[[:upper:]]"))
+ (looking-at-p "[[:upper:]]"))
(setq pos (point)))
pos)))
@@ -1503,7 +1563,7 @@
(host (tramp-file-name-host dissection))
(localname (tramp-file-name-localname dissection)))
(concat host ":" localname))
- path))))
+ (expand-file-name path)))))
(string= (funcall simplify-path path-1) (funcall simplify-path path-2))))
(defun intero-buffer-host (&optional buffer)
@@ -1633,12 +1693,28 @@
(defun intero-get-all-types ()
"Get all types in all expressions in all modules."
- (intero-blocking-call 'backend ":all-types"))
+ (intero-blocking-network-call 'backend ":all-types"))
(defun intero-get-type-at (beg end)
"Get the type at the given region denoted by BEG and END."
+ (let ((result (intero-get-type-at-helper beg end)))
+ (if (string-match (regexp-quote "Couldn't guess that module name. Does it exist?")
+ result)
+ (progn (flycheck-buffer)
+ (message "No type information yet, compiling module ...")
+ (intero-get-type-at-helper-process beg end))
+ result)))
+
+(defun intero-get-type-at-helper (beg end)
(replace-regexp-in-string
"\n$" ""
+ (intero-blocking-network-call
+ 'backend
+ (intero-format-get-type-at beg end))))
+
+(defun intero-get-type-at-helper-process (beg end)
+ (replace-regexp-in-string
+ "\n$" ""
(intero-blocking-call
'backend
(intero-format-get-type-at beg end))))
@@ -1647,7 +1723,7 @@
"Call CONT with type of the region denoted by BEG and END.
CONT is called within the current buffer, with BEG, END and the
type as arguments."
- (intero-async-call
+ (intero-async-network-call
'backend
(intero-format-get-type-at beg end)
(list :cont cont
@@ -1683,7 +1759,7 @@
(intero-blocking-call
'backend
(format ":info %s" thing)))))
- (if (string-match "^" optimistic-result)
+ (if (string-match-p "^" optimistic-result)
;; Load the module Interpreted so that we get information,
;; then restore bytecode.
(progn (intero-async-call
@@ -1705,10 +1781,40 @@
(format ":info %s" thing))))
optimistic-result)))
+(defconst intero-unloaded-module-string "Couldn't guess that module name. Does it exist?")
+
(defun intero-get-loc-at (beg end)
"Get the location of the identifier denoted by BEG and END."
+ (let ((result (intero-get-loc-at-helper beg end)))
+ (if (string-match (regexp-quote intero-unloaded-module-string)
+ result)
+ (progn (flycheck-buffer)
+ (message "No location information yet, compiling module ...")
+ (intero-get-loc-at-helper-process beg end))
+ result)))
+
+(defun intero-get-loc-at-helper (beg end)
+ "Make the blocking call to the process."
(replace-regexp-in-string
"\n$" ""
+ (intero-blocking-network-call
+ 'backend
+ (format ":loc-at %S %d %d %d %d %S"
+ (intero-localize-path (intero-temp-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-loc-at-helper-process (beg end)
+ "Make the blocking call to the process."
+ (replace-regexp-in-string
+ "\n$" ""
(intero-blocking-call
'backend
(format ":loc-at %S %d %d %d %d %S"
@@ -1725,8 +1831,36 @@
(defun intero-get-uses-at (beg end)
"Return usage list for identifier denoted by BEG and END."
+ (let ((result (intero-get-uses-at-helper beg end)))
+ (if (string-match (regexp-quote intero-unloaded-module-string)
+ result)
+ (progn (flycheck-buffer)
+ (message "No use information yet, compiling module ...")
+ (intero-get-uses-at-helper-process beg end))
+ result)))
+
+(defun intero-get-uses-at-helper (beg end)
+ "Return usage list for identifier denoted by BEG and END."
(replace-regexp-in-string
"\n$" ""
+ (intero-blocking-network-call
+ 'backend
+ (format ":uses %S %d %d %d %d %S"
+ (intero-localize-path (intero-temp-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-helper-process (beg end)
+ "Return usage list for identifier denoted by BEG and END."
+ (replace-regexp-in-string
+ "\n$" ""
(intero-blocking-call
'backend
(format ":uses %S %d %d %d %d %S"
@@ -1745,7 +1879,7 @@
"Get completions and send to SOURCE-BUFFER.
Prefix is marked by positions BEG and END. Completions are
passed to CONT in SOURCE-BUFFER."
- (intero-async-call
+ (intero-async-network-call
'backend
(format ":complete-at %S %d %d %d %d %S"
(intero-localize-path (intero-temp-file-name))
@@ -1768,7 +1902,7 @@
(defun intero-completion-response-to-list (reply)
"Convert the REPLY from a backend completion to a list."
- (if (string-match "^*** Exception" reply)
+ (if (string-match-p "^*** Exception" reply)
(list)
(mapcar
(lambda (x)
@@ -1839,6 +1973,76 @@
(sleep-for 0.0001)))
(car result)))
+(defun intero-blocking-network-call (worker cmd)
+ "Send WORKER the command string CMD via the network and block pending its result."
+ (let ((result (list nil)))
+ (intero-async-network-call
+ worker
+ cmd
+ result
+ (lambda (result reply)
+ (setf (car result) reply)))
+ (while (eq (car result) nil)
+ (sleep-for 0.0001))
+ (car result)))
+
+(defun intero-async-network-call (worker cmd &optional state callback)
+ "Send WORKER the command string CMD, via a network connection.
+The result, along with the given STATE, is passed to CALLBACK
+as (CALLBACK STATE REPLY)."
+ (let ((buffer (intero-buffer worker)))
+ (if (and buffer (process-live-p (get-buffer-process buffer)))
+ (with-current-buffer buffer
+ (if intero-service-port
+ (let* ((buffer (generate-new-buffer (format " intero-network:%S" worker)))
+ (process
+ (make-network-process
+ :name (format "%S" worker)
+ :buffer buffer
+ :host 'local
+ :service intero-service-port
+ :family 'ipv4
+ :nowait t
+ :noquery t
+ :sentinel 'intero-network-call-sentinel)))
+ (with-current-buffer buffer
+ (setq intero-async-network-cmd cmd)
+ (setq intero-async-network-state state)
+ (setq intero-async-network-worker worker)
+ (setq intero-async-network-callback callback)))
+ (progn (when intero-debug (message "No `intero-service-port', falling back ..."))
+ (intero-async-call worker cmd state callback))))
+ (error "Intero process is not running: run M-x intero-restart to start it"))))
+
+(defun intero-network-call-sentinel (process event)
+ (with-current-buffer (process-buffer process)
+ (if (string= "open\n" event)
+ (progn
+ (when intero-debug (message "Connected to service, sending %S" intero-async-network-cmd))
+ (setq intero-async-network-connected t)
+ (if intero-async-network-cmd
+ (process-send-string process (concat intero-async-network-cmd "\n"))
+ (delete-process process)))
+ (progn
+ (if intero-async-network-connected
+ (when intero-async-network-callback
+ (when intero-debug (message "Calling callback with %S" (buffer-string)))
+ (funcall intero-async-network-callback
+ intero-async-network-state
+ (buffer-string)))
+ ;; We didn't successfully connect, so let's fallback to the
+ ;; process pipe.
+ (when intero-async-network-callback
+ (when intero-debug (message "Failed to connect, falling back ... "))
+ (setq intero-async-network-callback nil)
+ (intero-async-call
+ intero-async-network-worker
+ intero-async-network-cmd
+ intero-async-network-state
+ intero-async-network-callback)))
+ ;; In any case we clean up the connection.
+ (delete-process process)))))
+
(defun intero-async-call (worker cmd &optional state callback)
"Send WORKER the command string CMD.
The result, along with the given STATE, is passed to CALLBACK
@@ -1909,7 +2113,8 @@
(if (string= package-name "intero")
"intero"
(concat "intero-" intero-package-version))))
- "ghc-paths" "syb")
+ "ghc-paths" "syb"
+ "--flag" "haskeline:-terminfo")
(0
(message "Installed successfully! Starting Intero in a moment ...")
(bury-buffer buffer)
@@ -1943,6 +2148,7 @@
buffer
(let* ((options
(intero-make-options-list
+ "intero"
(or targets
(let ((package-name (buffer-local-value 'intero-package-name buffer)))
(unless (equal "" package-name)
@@ -1962,6 +2168,7 @@
(set-process-query-on-exit-flag process nil)
(process-send-string process ":set -fobject-code\n")
(process-send-string process ":set -fdefer-type-errors\n")
+ (process-send-string process ":set -fdiagnostics-color=never\n")
(process-send-string process ":set prompt \"\\4\"\n")
(with-current-buffer buffer
(erase-buffer)
@@ -1975,10 +2182,12 @@
(setq intero-callbacks
(list (list (cons source-buffer
buffer)
- (lambda (buffers _msg)
+ (lambda (buffers msg)
(let ((source-buffer (car buffers))
(process-buffer (cdr buffers)))
(with-current-buffer process-buffer
+ (when (string-match "^Intero-Service-Port: \\([0-9]+\\)\n" msg)
+ (setq intero-service-port (string-to-number (match-string 1 msg))))
(setq-local intero-starting nil))
(when source-buffer
(with-current-buffer source-buffer
@@ -2002,7 +2211,7 @@
(let ((last-line (buffer-substring-no-properties
(line-beginning-position)
(line-end-position))))
- (if (string-match "^Progress" last-line)
+ (if (string-match-p "^Progress" last-line)
(message "Booting up intero (building dependencies: %s)"
(downcase
(or (car (split-string (replace-regexp-in-string
@@ -2022,7 +2231,7 @@
(flycheck-mode)
(flycheck-buffer))
-(defun intero-make-options-list (targets no-build no-load ignore-dot-ghci stack-yaml)
+(defun intero-make-options-list (with-ghc targets no-build no-load ignore-dot-ghci stack-yaml)
"Make the stack ghci options list.
TARGETS are the build targets. When non-nil, NO-BUILD and
NO-LOAD enable the correspondingly-named stack options. When
@@ -2032,7 +2241,7 @@
(append (when stack-yaml
(list "--stack-yaml" stack-yaml))
(list "--with-ghc"
- "intero"
+ with-ghc
"--docker-run-args=--interactive=true --tty=false"
)
(when no-build
@@ -2041,6 +2250,7 @@
(list "--no-load"))
(when ignore-dot-ghci
(list "--ghci-options" "-ignore-dot-ghci"))
+ (cl-mapcan (lambda (x) (list "--ghci-options" x)) intero-extra-ghc-options)
(let ((dir (intero-localize-path (intero-make-temp-file "intero" t))))
(list "--ghci-options"
(concat "-odir=" dir)
@@ -2270,7 +2480,7 @@
(0
(cl-remove-if-not
(lambda (line)
- (string-match "^[A-Za-z0-9-:_]+$" line))
+ (string-match-p "^[A-Za-z0-9-:_]+$" line))
(split-string (buffer-string) "[\r\n]" t)))
(1 nil)))))
@@ -2323,9 +2533,10 @@
;; 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\\'")))))
+ (cl-remove-if (lambda (path)
+ (or (file-directory-p path)
+ (not (file-exists-p path))))
+ (directory-files dir t ".\\.cabal\\'" t))))
(cond
((= (length cabal-files) 1) (car cabal-files)) ;; exactly one candidate found
(allow-multiple cabal-files) ;; pass-thru multiple candidates
@@ -2334,6 +2545,13 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Multiselection
+(defvar intero-multiswitch-keymap
+ (let ((map (copy-keymap widget-keymap)))
+ (define-key map (kbd "C-c C-c") 'exit-recursive-edit)
+ (define-key map (kbd "C-c C-k") 'abort-recursive-edit)
+ (define-key map (kbd "C-g") 'abort-recursive-edit)
+ map))
+
(defun intero-multiswitch (title options)
"Displaying TITLE, read multiple flags from a list of OPTIONS.
Each option is a plist of (:key :default :title) wherein:
@@ -2380,12 +2598,7 @@
(select-window (split-window-below))
(switch-to-buffer me)
(goto-char (point-min)))
- (use-local-map
- (let ((map (copy-keymap widget-keymap)))
- (define-key map (kbd "C-c C-c") 'exit-recursive-edit)
- (define-key map (kbd "C-c C-k") 'abort-recursive-edit)
- (define-key map (kbd "C-g") 'abort-recursive-edit)
- map))
+ (use-local-map intero-multiswitch-keymap)
(widget-setup)
(recursive-edit)
(kill-buffer me)
@@ -2845,10 +3058,10 @@
(forward-line (1- (plist-get suggestion :line)))
(when (and (search-forward (plist-get suggestion :module) nil t 1)
(search-forward "(" nil t 1))
- (insert (if (string-match "^[_a-zA-Z]" (plist-get suggestion :ident))
+ (insert (if (string-match-p "^[_a-zA-Z]" (plist-get suggestion :ident))
(plist-get suggestion :ident)
(concat "(" (plist-get suggestion :ident) ")")))
- (unless (looking-at "[:space:]*)")
+ (unless (looking-at-p "[:space:]*)")
(insert ", ")))))
(redundant-import-item
(save-excursion
@@ -2865,7 +3078,7 @@
"\\("
(mapconcat
(lambda (ident)
- (if (string-match "^[_a-zA-Z]" ident)
+ (if (string-match-p "^[_a-zA-Z]" ident)
(concat "\\<" (regexp-quote ident) "\\> ?" "\\("(regexp-quote "(..)") "\\)?")
(concat "(" (regexp-quote ident) ")")))
(plist-get suggestion :idents)
@@ -2964,8 +3177,8 @@
(defun intero-skip-shebangs ()
"Skip #! and -- shebangs used in Haskell scripts."
- (when (looking-at "#!") (forward-line 1))
- (when (looking-at "-- stack ") (forward-line 1)))
+ (when (looking-at-p "#!") (forward-line 1))
+ (when (looking-at-p "-- stack ") (forward-line 1)))
(defun intero--warn (message &rest args)
"Display a warning message made from (format MESSAGE ARGS...).
diff --git a/intero.cabal b/intero.cabal
--- a/intero.cabal
+++ b/intero.cabal
@@ -1,7 +1,7 @@
name:
intero
version:
- 0.1.24
+ 0.1.25
synopsis:
Complete interactive development program for Haskell
license:
@@ -80,7 +80,9 @@
transformers,
syb,
containers,
- time
+ time,
+ network,
+ random
if impl(ghc>=8.0.1)
build-depends:
diff --git a/src/GhciMonad.hs b/src/GhciMonad.hs
--- a/src/GhciMonad.hs
+++ b/src/GhciMonad.hs
@@ -21,6 +21,7 @@
BreakLocation(..),
TickArray,
getDynFlags,
+ reifyGHCi,reflectGHCi,
runStmt, runDecls, resume, timeIt, recordBreak, revertCAFs,
printForUserNeverQualify, printForUserModInfo,
@@ -195,8 +196,8 @@
-- f'' :: IORef GHCiState -> Session -> IO a
f'' gs s = f (s, gs)
-startGHCi :: GHCi a -> GHCiState -> Ghc a
-startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref
+startGHCi :: GHCi a -> IORef GHCiState -> Ghc a
+startGHCi g ref = unGHCi g ref
instance Functor GHCi where
fmap = liftM
@@ -279,18 +280,18 @@
dflags <- getDynFlags
liftIO $ Outputable.printForUser dflags stdout neverQualify doc
-printForUserModInfo :: GhcMonad m => GHC.ModuleInfo -> SDoc -> m ()
-printForUserModInfo info doc = do
+printForUserModInfo :: GhcMonad m => Handle -> GHC.ModuleInfo -> SDoc -> m ()
+printForUserModInfo h info doc = do
dflags <- getDynFlags
mUnqual <- GHC.mkPrintUnqualifiedForModule info
unqual <- maybe GHC.getPrintUnqual return mUnqual
- liftIO $ Outputable.printForUser dflags stdout unqual doc
+ liftIO $ Outputable.printForUser dflags h unqual doc
-printForUser :: GhcMonad m => SDoc -> m ()
-printForUser doc = do
+printForUser :: GhcMonad m => Handle -> SDoc -> m ()
+printForUser h doc = do
unqual <- GHC.getPrintUnqual
dflags <- getDynFlags
- liftIO $ Outputable.printForUser dflags stdout unqual doc
+ liftIO $ Outputable.printForUser dflags h unqual doc
printForUserPartWay :: SDoc -> GHCi ()
printForUserPartWay doc = do
diff --git a/src/InteractiveUI.hs b/src/InteractiveUI.hs
--- a/src/InteractiveUI.hs
+++ b/src/InteractiveUI.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
@@ -52,6 +53,7 @@
import Debugger
-- The GHC interface
+import Data.IORef
import DynFlags
import GhcMonad ( modifySession )
import qualified GHC
@@ -105,12 +107,14 @@
-- Haskell Libraries
import System.Console.Haskeline as Haskeline
-
+import Network.Socket
+import qualified Network
+import Network.BSD
import Control.Applicative hiding (empty)
import Control.Monad as Monad
import Control.Monad.Trans.Class
import Control.Monad.IO.Class
-import Control.Concurrent (threadDelay)
+import Control.Concurrent (threadDelay, forkIO)
#if MIN_VERSION_directory(1,2,3)
import Data.Time (getCurrentTime)
#endif
@@ -121,7 +125,7 @@
import Data.Function
import Data.IORef ( IORef, readIORef, writeIORef )
import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,
- partition, sort, sortBy )
+ partition, sort, sortBy)
import Data.Maybe
#if __GLASGOW_HASKELL__ >= 802
import qualified Data.Set as Set
@@ -281,18 +285,28 @@
("step", keepGoing stepCmd, completeIdentifier),
("steplocal", keepGoing stepLocalCmd, completeIdentifier),
("stepmodule",keepGoing stepModuleCmd, completeIdentifier),
- ("type", keepGoing' typeOfExpr, completeExpression),
- ("type-at", keepGoing' typeAt, noCompletion),
- ("all-types", keepGoing' allTypes, noCompletion),
- ("uses", keepGoing' findAllUses, noCompletion),
- ("loc-at", keepGoing' locationAt, noCompletion),
- ("complete-at", keepGoing' completeAt, noCompletion),
+ ("type", keepGoing' (lifted typeOfExpr), completeExpression),
+ ("type-at", keepGoing' (lifted typeAt), noCompletion),
+ ("all-types", keepGoing' (lifted allTypes), noCompletion),
+ ("uses", keepGoing' (lifted findAllUses), noCompletion),
+ ("loc-at", keepGoing' (lifted locationAt), noCompletion),
+ ("complete-at", keepGoing' (lifted completeAt), noCompletion),
("trace", keepGoing traceCmd, completeExpression),
("undef", keepGoing undefineMacro, completeMacro),
("unset", keepGoing unsetOptions, completeSetOptions)
]
+ where lifted m = \str -> lift (m stdout str)
+readOnlyCommands :: [(String, Handle -> String -> GHCi ())]
+readOnlyCommands =
+ [ ("type-at", typeAt)
+ , ("all-types", allTypes)
+ , ("uses", findAllUses)
+ , ("loc-at", locationAt)
+ , ("complete-at", completeAt)
+ ]
+
-- We initialize readline (in the interactiveUI function) to use
-- word_break_chars as the default set of completion word break characters.
-- This can be overridden for a particular command (for example, filename
@@ -578,7 +592,7 @@
default_editor <- liftIO $ findEditor
current_directory <- liftIO $ getCurrentDirectory
- startGHCi (runGHCi srcs maybe_exprs)
+ ref <- liftIO $newIORef
GHCiState{ progname = default_progname,
GhciMonad.args = default_args,
prompt = defPrompt config,
@@ -603,9 +617,73 @@
ghci_work_directory = current_directory,
ghc_work_directory = current_directory
}
+ -- Start the GHCI interactive main loop. This loop handles all
+ -- types of commands, including loading modules and modifying the
+ -- GHCi state.
+ startGHCi (do runServer
+ runGHCi srcs maybe_exprs)
+ ref
- return ()
+runServer :: GHCi ()
+runServer = do
+ sock <-
+ liftIO
+ (withSocketsDo
+ (do sock <- listenOnLoopback
+ port <- fmap fromIntegral (socketPort sock) :: IO Int
+ putStrLn ("Intero-Service-Port: " ++ show port)
+ return sock))
+ GhciMonad.reifyGHCi
+ (\state -> do
+ _ <-
+ forkIO
+ (let loop = do
+ (h, _, _) <- Network.accept sock
+ hSetBuffering h NoBuffering
+ _ <-
+ forkIO
+ (Exception.finally
+ (do str <-
+ fmap
+ (reverse . dropWhile isSpace . reverse)
+ (hGetLine h)
+ -- putStrLn ("Got line: " ++ str)
+ GhciMonad.reflectGHCi
+ state
+ (do let (cmd, rest) = break isSpace str
+ args = dropWhile isSpace rest
+ case lookup
+ (dropWhile (== ':') cmd)
+ readOnlyCommands of
+ Just c
+ -- liftIO (hPutStrLn h "Found command, running ...")
+ -> do
+ _ <- c h args
+ -- liftIO (hPutStrLn h "Command ran.")
+ pure ()
+ Nothing -> do
+ liftIO (hPutStrLn h "No such command!")
+ pure ())
+ return ())
+ (hClose h))
+ loop
+ in loop)
+ return ())
+listenOnLoopback :: IO Socket
+listenOnLoopback = do
+ proto <- getProtocolNumber "tcp"
+ bracketOnError
+ (socket AF_INET Stream proto)
+ close
+ (\sock -> do
+ setSocketOption sock ReuseAddr 1
+ setSocketOption sock UseLoopBack 1
+ address <- getHostByName "127.0.0.1"
+ bind sock (SockAddrInet aNY_PORT (hostAddress address))
+ listen sock maxListenQueue
+ return sock)
+
withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
withGhcAppData right left = do
either_dir <- tryIO (getAppUserDataDirectory "ghc")
@@ -697,25 +775,29 @@
do
-- enter the interactive loop
runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
- Just exprs -> do
- -- just evaluate the expression we were given
- enqueueCommands exprs
- let hdle e = do st <- getGHCiState
- -- flush the interpreter's stdout/stderr on exit (#3890)
- flushInterpBuffers
- -- Jump through some hoops to get the
- -- current progname in the exception text:
- -- :
- liftIO $ withProgName (progname st)
- $ topHandler e
- -- this used to be topHandlerFastExit, see #2228
- runInputTWithPrefs defaultPrefs defaultSettings $ do
- -- make `ghc -e` exit nonzero on invalid input, see Trac #7962
- runCommands' hdle (Just $ hdle (toException $ ExitFailure 1) >> return ()) (return Nothing)
+ Just exprs ->
+ runSingleInput (\hdle -> Just $ hdle (toException $ ExitFailure 1) >> return ()) exprs
-- and finally, exit
liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
+runSingleInput :: ((SomeException -> GHCi b) -> Maybe (GHCi ())) -> [String] -> GHCi ()
+runSingleInput errorHandler exprs = do
+ -- just evaluate the expression we were given
+ enqueueCommands exprs
+ let hdle e = do st <- getGHCiState
+ -- flush the interpreter's stdout/stderr on exit (#3890)
+ flushInterpBuffers
+ -- Jump through some hoops to get the
+ -- current progname in the exception text:
+ -- :
+ liftIO $ withProgName (progname st)
+ $ topHandler e
+ -- this used to be topHandlerFastExit, see #2228
+ runInputTWithPrefs defaultPrefs defaultSettings $ do
+ -- make `ghc -e` exit nonzero on invalid input, see Trac #7962
+ runCommands' hdle (errorHandler hdle) (return Nothing)
+
runGHCiInput :: InputT GHCi a -> GHCi a
runGHCiInput f = do
dflags <- getDynFlags
@@ -1156,7 +1238,7 @@
printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
printStoppedAtBreakInfo res names = do
- printForUser $ ptext (sLit "Stopped at") <+>
+ printForUser stdout $ ptext (sLit "Stopped at") <+>
ppr (GHC.resumeSpan res)
-- printTypeOfNames session names
let namesSorted = sortBy compareNames names
@@ -1281,8 +1363,8 @@
withSandboxOnly cmd this = do
dflags <- getDynFlags
if not (gopt Opt_GhciSandbox dflags)
- then printForUser (text cmd <+>
- ptext (sLit "is not supported with -fno-ghci-sandbox"))
+ then printForUser stdout (text cmd <+>
+ ptext (sLit "is not supported with -fno-ghci-sandbox"))
else this
-----------------------------------------------------------------------------
@@ -1796,8 +1878,9 @@
-----------------------------------------------------------------------------
-- :type
-typeOfExpr :: String -> InputT GHCi ()
-typeOfExpr str
+typeOfExpr :: Handle -> String -> GHCi ()
+typeOfExpr
+ h str
= handleSourceError GHC.printException
$ do
#if __GLASGOW_HASKELL__ >= 802
@@ -1805,51 +1888,51 @@
#else
ty <- GHC.exprType str
#endif
- printForUser $ sep [text str, nest 2 (dcolon <+> pprTypeForUser ty)]
+ printForUser h $ sep [text str, nest 2 (dcolon <+> pprTypeForUser ty)]
-----------------------------------------------------------------------------
-- :type-at
-typeAt :: String -> InputT GHCi ()
-typeAt str =
+typeAt :: Handle -> String -> GHCi ()
+typeAt h str =
handleSourceError
GHC.printException
(case parseSpan str of
- Left err -> liftIO (putStr err)
+ Left err -> liftIO (hPutStrLn h err)
Right (fp,sl,sc,el,ec,sample) ->
- do infos <- fmap mod_infos (lift getGHCiState)
+ do infos <- fmap mod_infos getGHCiState
result <- findType infos fp sample sl sc el ec
case result of
- FindTypeFail err -> liftIO (putStrLn err)
+ FindTypeFail err -> liftIO (hPutStrLn h err)
FindType info' ty ->
- printForUserModInfo
+ printForUserModInfo h
(modinfoInfo info')
(sep [text sample,nest 2 (dcolon <+> ppr ty)])
FindTyThing info' tything ->
- printForUserModInfo (modinfoInfo info')
- (pprTyThing' tything))
+ printForUserModInfo h (modinfoInfo info')
+ (pprTyThing' tything))
-----------------------------------------------------------------------------
-- :uses
-findAllUses :: String -> InputT GHCi ()
-findAllUses str =
+findAllUses :: Handle -> String -> GHCi ()
+findAllUses h str =
handleSourceError GHC.printException $
case parseSpan str of
- Left err -> liftIO (putStr err)
+ Left err -> liftIO (hPutStrLn h err)
Right (fp,sl,sc,el,ec,sample) ->
- do infos <- fmap mod_infos (lift getGHCiState)
+ do infos <- fmap mod_infos getGHCiState
result <- findNameUses infos fp sample sl sc el ec
case result of
- Left err -> liftIO (putStrLn err)
+ Left err -> liftIO (hPutStrLn h err)
Right uses ->
forM_ uses
(\sp ->
case sp of
RealSrcSpan rs ->
- liftIO (putStrLn (showSpan rs))
+ liftIO (hPutStrLn h (showSpan rs))
UnhelpfulSpan fs ->
- liftIO (putStrLn (unpackFS fs)))
+ liftIO (hPutStrLn h (unpackFS fs)))
where showSpan span' =
unpackFS (srcSpanFile span') ++
":(" ++
@@ -1865,11 +1948,11 @@
-----------------------------------------------------------------------------
-- :all-types
-allTypes :: String -> InputT GHCi ()
-allTypes _ =
+allTypes :: Handle -> String -> GHCi ()
+allTypes h _ =
handleSourceError
GHC.printException
- (do infos <- fmap mod_infos (lift getGHCiState)
+ (do infos <- fmap mod_infos getGHCiState
forM_ (M.elems infos)
(\mi ->
forM_ (modinfoSpans mi) (printSpan mi)))
@@ -1881,7 +1964,7 @@
Nothing -> return ()
Just ty ->
liftIO
- (putStrLn
+ (hPutStrLn h
(concat [fp ++":"
-- GHC exposes a 1-based column number because reasons.
,"(" ++ show sl ++ "," ++ show (1+sc) ++ ")-(" ++
@@ -1900,22 +1983,22 @@
-----------------------------------------------------------------------------
-- :loc-at
-locationAt :: String -> InputT GHCi ()
-locationAt str =
+locationAt :: Handle -> String -> GHCi ()
+locationAt h str =
handleSourceError GHC.printException $
case parseSpan str of
- Left err -> liftIO (putStr err)
+ Left err -> liftIO (hPutStrLn h err)
Right (fp,sl,sc,el,ec,sample) ->
- do infos <- fmap mod_infos (lift getGHCiState)
+ do infos <- fmap mod_infos getGHCiState
result <- findLoc infos fp sample sl sc el ec
case result of
- Left err -> liftIO (putStrLn err)
+ Left err -> liftIO (hPutStrLn h err)
Right sp ->
case sp of
RealSrcSpan rs ->
- liftIO (putStrLn (showSpan rs))
+ liftIO (hPutStrLn h (showSpan rs))
UnhelpfulSpan fs ->
- liftIO (putStrLn (unpackFS fs))
+ liftIO (hPutStrLn h (unpackFS fs))
where showSpan span' =
unpackFS (srcSpanFile span') ++ ":(" ++
show (srcSpanStartLine span') ++ "," ++
@@ -1927,18 +2010,18 @@
-----------------------------------------------------------------------------
-- :complete-at
-completeAt :: String -> InputT GHCi ()
-completeAt str =
+completeAt :: Handle -> String -> GHCi ()
+completeAt h str =
handleSourceError GHC.printException $
case parseSpan str of
- Left err -> liftIO (putStr err)
+ Left err -> liftIO (hPutStrLn h err)
Right (fp,sl,sc,el,ec,sample) | not (null str) ->
- do infos <- fmap mod_infos (lift getGHCiState)
+ do infos <- fmap mod_infos getGHCiState
result <- findCompletions infos fp sample sl sc el ec
case result of
Left err -> error err
Right completions' ->
- liftIO (mapM_ putStrLn completions')
+ liftIO (mapM_ (hPutStrLn h ) completions')
_ -> return ()
-----------------------------------------------------------------------------
@@ -1984,8 +2067,8 @@
= handleSourceError GHC.printException
$ do
(ty, kind) <- GHC.typeKind norm str
- printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser kind
- , ppWhen norm $ equals <+> ppr ty ]
+ printForUser stdout $ vcat [ text str <+> dcolon <+> pprTypeForUser kind
+ , ppWhen norm $ equals <+> ppr ty ]
-----------------------------------------------------------------------------
@@ -2624,8 +2707,8 @@
st <- getGHCiState
let old_breaks = breaks st
if all ((/= nm) . fst) old_breaks
- then printForUser (text "Breakpoint" <+> ppr nm <+>
- text "does not exist")
+ then printForUser stdout (text "Breakpoint" <+> ppr nm <+>
+ text "does not exist")
else do
let new_breaks = map fn old_breaks
fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
@@ -2881,17 +2964,17 @@
printTyThing :: TyThing -> GHCi ()
-printTyThing tyth = printForUser (pprTyThing' tyth)
+printTyThing tyth = printForUser stdout (pprTyThing' tyth)
showBkptTable :: GHCi ()
showBkptTable = do
st <- getGHCiState
- printForUser $ prettyLocations (breaks st)
+ printForUser stdout $ prettyLocations (breaks st)
showContext :: GHCi ()
showContext = do
resumes <- GHC.getResumeContext
- printForUser $ vcat (map pp_resume (reverse resumes))
+ printForUser stdout $ vcat (map pp_resume (reverse resumes))
where
pp_resume res =
ptext (sLit "--> ") <> text (GHC.resumeStmt res)
@@ -3187,8 +3270,8 @@
forceCmd = pprintCommand False True
pprintCommand :: Bool -> Bool -> String -> GHCi ()
-pprintCommand bind force str = do
- pprintClosureCommand bind force str
+pprintCommand b force str = do
+ pprintClosureCommand b force str
stepCmd :: String -> GHCi ()
stepCmd arg = withSandboxOnly ":step" $ step arg
@@ -3295,7 +3378,8 @@
pans <- mapM GHC.getHistorySpan took
let nums = map (printf "-%-3d:") [(1::Int)..]
names = map GHC.historyEnclosingDecls took
- printForUser (vcat(zipWith3
+ printForUser stdout
+ (vcat(zipWith3
(\x y z -> x <+> y <+> z)
(map text nums)
(map (bold . hcat . punctuate colon . map text) names)
@@ -3313,7 +3397,7 @@
#else
(names, _, pan, _) <- GHC.back 1
#endif
- printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr pan
+ printForUser stdout $ ptext (sLit "Logged breakpoint at") <+> ppr pan
printTypeOfNames names
-- run the command set with ":set stop "
st <- getGHCiState
@@ -3326,9 +3410,9 @@
#else
(names, ix, pan) <- GHC.forward
#endif
- printForUser $ (if (ix == 0)
- then ptext (sLit "Stopped at")
- else ptext (sLit "Logged breakpoint at")) <+> ppr pan
+ printForUser stdout $ (if (ix == 0)
+ then ptext (sLit "Stopped at")
+ else ptext (sLit "Logged breakpoint at")) <+> ppr pan
printTypeOfNames names
-- run the command set with ":set stop "
st <- getGHCiState
@@ -3366,7 +3450,7 @@
UnhelpfulLoc _ ->
noCanDo name $ text "can't find its location: " <> ppr loc
where
- noCanDo n why = printForUser $
+ noCanDo n why = printForUser stdout $
text "cannot set breakpoint on " <> ppr n <> text ": " <> why
breakByModule :: Module -> [String] -> GHCi ()
@@ -3404,14 +3488,14 @@
, breakTick = tick
, onBreakCmd = ""
}
- printForUser $
+ printForUser stdout $
text "Breakpoint " <> ppr nm <>
if alreadySet
then text " was already set at " <> ppr pan
else text " activated at " <> ppr pan
else do
- printForUser $ text "Breakpoint could not be activated at"
- <+> ppr pan
+ printForUser stdout $ text "Breakpoint could not be activated at"
+ <+> ppr pan
-- When a line number is specified, the current policy for choosing
-- the best breakpoint is this:
@@ -3490,7 +3574,7 @@
mb_span <- lift getCurrentBreakSpan
case mb_span of
Nothing ->
- printForUser $ text "Not stopped at a breakpoint; nothing to list"
+ printForUser stdout $ text "Not stopped at a breakpoint; nothing to list"
Just (RealSrcSpan pan) ->
listAround pan True
Just pan@(UnhelpfulSpan _) ->
@@ -3502,8 +3586,8 @@
[] -> text "rerunning with :trace,"
_ -> empty
doWhat = traceIt <+> text ":back then :list"
- printForUser (text "Unable to list source for" <+>
- ppr pan
+ printForUser stdout (text "Unable to list source for" <+>
+ ppr pan
$$ text "Try" <+> doWhat)
listCmd' str = list2 (words str)
@@ -3536,7 +3620,7 @@
noCanDo name $ text "can't find its location: " <>
ppr loc
where
- noCanDo n why = printForUser $
+ noCanDo n why = printForUser stdout $
text "cannot list source code for " <> ppr n <> text ": " <> why
list2 _other =
liftIO $ putStrLn "syntax: :list [ | | ]"
@@ -3673,8 +3757,8 @@
let oldLocations = breaks st
(this,rest) = partition (\loc -> fst loc == identity) oldLocations
if null this
- then printForUser (text "Breakpoint" <+> ppr identity <+>
- text "does not exist")
+ then printForUser stdout (text "Breakpoint" <+> ppr identity <+>
+ text "does not exist")
else do
mapM_ (turnOffBreak.snd) this
setGHCiState $ st { breaks = rest }