intero 0.1.24 → 0.1.25
raw patch · 5 files changed
+452/−152 lines, 5 filesdep +networkdep +random
Dependencies added: network, random
Files
- README.md +1/−1
- elisp/intero.el +267/−54
- intero.cabal +4/−2
- src/GhciMonad.hs +9/−8
- src/InteractiveUI.hs +171/−87
README.md view
@@ -1,4 +1,4 @@-# <img src="https://github.com/commercialhaskell/intero/raw/master/images/intero.svg" height=25> intero [](https://travis-ci.org/commercialhaskell/intero) [](https://melpa.org/#/intero) [](https://stable.melpa.org/#/intero) [](https://ci.appveyor.com/project/commercialhaskell/intero)+# <img src="https://github.com/commercialhaskell/intero/raw/master/images/intero.svg" height=25> 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
elisp/intero.el view
@@ -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 "^<interactive>" optimistic-result)+ (if (string-match-p "^<interactive>" 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...).
intero.cabal view
@@ -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:
src/GhciMonad.hs view
@@ -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
src/InteractiveUI.hs view
@@ -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:- -- <progname>: <exception>- 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:+ -- <progname>: <exception>+ 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 <cmd>" 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 <cmd>" 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 [<line> | <module> <line> | <identifier>]"@@ -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 }