Mercurial > hg > Members > kokubo > emacs
comparison .emacs.d/haskell-mode/haskell-process.el @ 0:2764b4f45f9f
1st commit
| author | Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp> |
|---|---|
| date | Mon, 21 Apr 2014 04:30:59 +0900 |
| parents | |
| children |
comparison
equal
deleted
inserted
replaced
| -1:000000000000 | 0:2764b4f45f9f |
|---|---|
| 1 ;;; haskell-process.el --- Communicating with the inferior Haskell process | |
| 2 | |
| 3 ;; Copyright (C) 2011-2012 Chris Done | |
| 4 | |
| 5 ;; Author: Chris Done <chrisdone@gmail.com> | |
| 6 | |
| 7 ;; This file is not part of GNU Emacs. | |
| 8 | |
| 9 ;; This file is free software; you can redistribute it and/or modify | |
| 10 ;; it under the terms of the GNU General Public License as published by | |
| 11 ;; the Free Software Foundation; either version 3, or (at your option) | |
| 12 ;; any later version. | |
| 13 | |
| 14 ;; This file is distributed in the hope that it will be useful, | |
| 15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| 17 ;; GNU General Public License for more details. | |
| 18 | |
| 19 ;; You should have received a copy of the GNU General Public License | |
| 20 ;; along with GNU Emacs; see the file COPYING. If not, write to | |
| 21 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, | |
| 22 ;; Boston, MA 02110-1301, USA. | |
| 23 | |
| 24 ;;; Commentary: | |
| 25 | |
| 26 ;;; Todo: | |
| 27 | |
| 28 ;;; Code: | |
| 29 | |
| 30 (require 'haskell-mode) | |
| 31 (require 'haskell-session) | |
| 32 (require 'haskell-compat) | |
| 33 (require 'haskell-str) | |
| 34 (require 'haskell-utils) | |
| 35 (require 'haskell-presentation-mode) | |
| 36 (require 'haskell-navigate-imports) | |
| 37 (with-no-warnings (require 'cl)) | |
| 38 | |
| 39 ;; FIXME: haskell-process shouldn't depend on haskell-interactive-mode to avoid module-dep cycles | |
| 40 (declare-function haskell-interactive-mode-echo "haskell-interactive-mode" (session message &optional mode)) | |
| 41 (declare-function haskell-interactive-mode-compile-error "haskell-interactive-mode" (session message)) | |
| 42 (declare-function haskell-interactive-mode-compile-warning "haskell-interactive-mode" (session message)) | |
| 43 (declare-function haskell-interactive-mode-insert "haskell-interactive-mode" (session message)) | |
| 44 (declare-function haskell-interactive-mode-reset-error "haskell-interactive-mode" (session)) | |
| 45 (declare-function haskell-interactive-show-load-message "haskell-interactive-mode" (session type module-name file-name echo)) | |
| 46 | |
| 47 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 48 ;; Configuration | |
| 49 (defgroup haskell-interactive nil | |
| 50 "Settings for REPL interaction via `haskell-interactive-mode'" | |
| 51 :link '(custom-manual "(haskell-mode)haskell-interactive-mode") | |
| 52 :group 'haskell) | |
| 53 | |
| 54 (defcustom haskell-process-path-ghci | |
| 55 "ghci" | |
| 56 "The path for starting ghci." | |
| 57 :group 'haskell-interactive | |
| 58 :type '(choice string (repeat string))) | |
| 59 | |
| 60 (defcustom haskell-process-path-cabal | |
| 61 "cabal" | |
| 62 "Path to the `cabal' executable." | |
| 63 :group 'haskell-interactive | |
| 64 :type '(choice string (repeat string))) | |
| 65 | |
| 66 (defcustom haskell-process-path-cabal-ghci | |
| 67 "cabal-ghci" | |
| 68 "The path for starting cabal-ghci." | |
| 69 :group 'haskell-interactive | |
| 70 :type '(choice string (repeat string))) | |
| 71 | |
| 72 (defcustom haskell-process-path-cabal-dev | |
| 73 "cabal-dev" | |
| 74 "The path for starting cabal-dev." | |
| 75 :group 'haskell-interactive | |
| 76 :type '(choice string (repeat string))) | |
| 77 | |
| 78 (defcustom haskell-process-args-ghci | |
| 79 '("-ferror-spans") | |
| 80 "Any arguments for starting ghci." | |
| 81 :group 'haskell-interactive | |
| 82 :type '(repeat (string :tag "Argument"))) | |
| 83 | |
| 84 (defcustom haskell-process-args-cabal-repl | |
| 85 '("--ghc-option=-ferror-spans") | |
| 86 "Additional arguments to for `cabal repl' invocation. | |
| 87 Note: The settings in `haskell-process-path-ghci' and | |
| 88 `haskell-process-args-ghci' are not automatically reused as `cabal repl' | |
| 89 currently invokes `ghc --interactive'. Use | |
| 90 `--with-ghc=<path-to-executable>' if you want to use a different | |
| 91 interactive GHC frontend; use `--ghc-option=<ghc-argument>' to | |
| 92 pass additional flags to `ghc'." | |
| 93 :group 'haskell-interactive | |
| 94 :type '(repeat (string :tag "Argument"))) | |
| 95 | |
| 96 (defcustom haskell-process-do-cabal-format-string | |
| 97 ":!cd %s && %s" | |
| 98 "The way to run cabal comands. It takes two arguments -- the directory and the command. | |
| 99 See `haskell-process-do-cabal' for more details." | |
| 100 :group 'haskell-interactive | |
| 101 :type 'string) | |
| 102 | |
| 103 (defcustom haskell-process-type | |
| 104 'ghci | |
| 105 "The inferior Haskell process type to use." | |
| 106 :type '(choice (const ghci) (const cabal-repl) (const cabal-dev) (const cabal-ghci)) | |
| 107 :group 'haskell-interactive) | |
| 108 | |
| 109 (defcustom haskell-process-log | |
| 110 nil | |
| 111 "Enable debug logging to \"*haskell-process-log*\" buffer." | |
| 112 :type 'boolean | |
| 113 :group 'haskell-interactive) | |
| 114 | |
| 115 (defcustom haskell-process-show-debug-tips | |
| 116 t | |
| 117 "Show debugging tips when starting the process." | |
| 118 :type 'boolean | |
| 119 :group 'haskell-interactive) | |
| 120 | |
| 121 (defcustom haskell-notify-p | |
| 122 nil | |
| 123 "Notify using notifications.el (if loaded)?" | |
| 124 :type 'boolean | |
| 125 :group 'haskell-interactive) | |
| 126 | |
| 127 (defcustom haskell-process-suggest-no-warn-orphans | |
| 128 t | |
| 129 "Suggest adding -fno-warn-orphans pragma to file when getting orphan warnings." | |
| 130 :type 'boolean | |
| 131 :group 'haskell-interactive) | |
| 132 | |
| 133 (defcustom haskell-process-suggest-hoogle-imports | |
| 134 nil | |
| 135 "Suggest to add import statements using Hoogle as a backend." | |
| 136 :type 'boolean | |
| 137 :group 'haskell-interactive) | |
| 138 | |
| 139 (defcustom haskell-process-suggest-add-package | |
| 140 t | |
| 141 "Suggest to add packages to your .cabal file when Cabal says it | |
| 142 is a member of the hidden package, blah blah." | |
| 143 :type 'boolean | |
| 144 :group 'haskell-interactive) | |
| 145 | |
| 146 (defcustom haskell-process-suggest-language-pragmas | |
| 147 t | |
| 148 "Suggest adding LANGUAGE pragmas recommended by GHC." | |
| 149 :type 'boolean | |
| 150 :group 'haskell-interactive) | |
| 151 | |
| 152 (defcustom haskell-process-suggest-remove-import-lines | |
| 153 nil | |
| 154 "Suggest removing import lines as warned by GHC." | |
| 155 :type 'boolean | |
| 156 :group 'haskell-interactive) | |
| 157 | |
| 158 (defcustom haskell-process-suggest-overloaded-strings | |
| 159 t | |
| 160 "Suggest adding OverloadedStrings pragma to file when getting type mismatches with [Char]." | |
| 161 :type 'boolean | |
| 162 :group 'haskell-interactive) | |
| 163 | |
| 164 (defcustom haskell-process-check-cabal-config-on-load | |
| 165 t | |
| 166 "Check changes cabal config on loading Haskell files and | |
| 167 restart the GHCi process if changed.." | |
| 168 :type 'boolean | |
| 169 :group 'haskell-interactive) | |
| 170 | |
| 171 (defcustom haskell-process-prompt-restart-on-cabal-change | |
| 172 t | |
| 173 "Ask whether to restart the GHCi process when the Cabal file | |
| 174 has changed?" | |
| 175 :type 'boolean | |
| 176 :group 'haskell-interactive) | |
| 177 | |
| 178 (defcustom haskell-process-auto-import-loaded-modules | |
| 179 nil | |
| 180 "Auto import the modules reported by GHC to have been loaded?" | |
| 181 :type 'boolean | |
| 182 :group 'haskell-interactive) | |
| 183 | |
| 184 (defcustom haskell-process-reload-with-fbytecode | |
| 185 nil | |
| 186 "When using -fobject-code, auto reload with -fbyte-code (and | |
| 187 then restore the -fobject-code) so that all module info and | |
| 188 imports become available?" | |
| 189 :type 'boolean | |
| 190 :group 'haskell-interactive) | |
| 191 | |
| 192 (defcustom haskell-process-use-presentation-mode | |
| 193 nil | |
| 194 "Use presentation mode to show things like type info instead of | |
| 195 printing to the message area." | |
| 196 :type 'boolean | |
| 197 :group 'haskell-interactive) | |
| 198 | |
| 199 (defvar haskell-imported-suggested nil) | |
| 200 (defvar haskell-process-prompt-regex "\\(^[> ]*> $\\|\n[> ]*> $\\)") | |
| 201 (defvar haskell-reload-p nil) | |
| 202 | |
| 203 (defvar haskell-process-greetings | |
| 204 (list "Hello, Haskell!" | |
| 205 "The lambdas must flow." | |
| 206 "Hours of hacking await!" | |
| 207 "The next big Haskell project is about to start!" | |
| 208 "Your wish is my IO ().") | |
| 209 "Greetings for when the Haskell process starts up.") | |
| 210 | |
| 211 (defconst haskell-process-logo | |
| 212 (expand-file-name "logo.svg" haskell-mode-pkg-base-dir) | |
| 213 "Haskell logo for notifications.") | |
| 214 | |
| 215 | |
| 216 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 217 ;; Accessing commands -- using cl 'defstruct' | |
| 218 (defstruct haskell-command | |
| 219 "Data structure representing a command to be executed when with | |
| 220 a custom state and three callback." | |
| 221 ;; hold the custom command state | |
| 222 ;; state :: a | |
| 223 state | |
| 224 ;; called when to execute a command | |
| 225 ;; go :: a -> () | |
| 226 go | |
| 227 ;; called whenever output was collected from the haskell process | |
| 228 ;; live :: a -> Response -> Bool | |
| 229 live | |
| 230 ;; called when the output from the haskell process indicates that the command | |
| 231 ;; is complete | |
| 232 ;; complete :: a -> Response -> () | |
| 233 complete) | |
| 234 | |
| 235 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 236 ;; Accessing commands | |
| 237 | |
| 238 | |
| 239 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 240 ;; Specialised commands | |
| 241 | |
| 242 ;;;###autoload | |
| 243 (defun haskell-process-generate-tags (&optional and-then-find-this-tag) | |
| 244 "Regenerate the TAGS table." | |
| 245 (interactive) | |
| 246 (let ((process (haskell-process))) | |
| 247 (haskell-process-queue-command | |
| 248 process | |
| 249 (make-haskell-command | |
| 250 :state (cons process and-then-find-this-tag) | |
| 251 :go (lambda (state) | |
| 252 (haskell-process-send-string | |
| 253 (car state) | |
| 254 (format ":!cd %s && %s | %s | %s" | |
| 255 (haskell-session-cabal-dir | |
| 256 (haskell-process-session (car state))) | |
| 257 "find . -name '*.hs*'" | |
| 258 "grep -v '#'" ; To avoid Emacs back-up files. Yeah. | |
| 259 "xargs hasktags -e -x"))) | |
| 260 :complete (lambda (state response) | |
| 261 (when (cdr state) | |
| 262 (let ((tags-file-name | |
| 263 (haskell-session-tags-filename | |
| 264 (haskell-process-session (car state))))) | |
| 265 (find-tag (cdr state)))) | |
| 266 (haskell-mode-message-line "Tags generated.")))))) | |
| 267 | |
| 268 ;;;###autoload | |
| 269 (defun haskell-process-do-type (&optional insert-value) | |
| 270 "Print the type of the given expression." | |
| 271 (interactive "P") | |
| 272 (if insert-value | |
| 273 (haskell-process-insert-type) | |
| 274 (haskell-process-do-simple-echo | |
| 275 (let ((ident (haskell-ident-at-point))) | |
| 276 ;; TODO: Generalize all these `string-match' of ident calls into | |
| 277 ;; one function. | |
| 278 (format (if (string-match "^[_[:lower:][:upper:]]" ident) | |
| 279 ":type %s" | |
| 280 ":type (%s)") | |
| 281 ident)) | |
| 282 'haskell-mode))) | |
| 283 | |
| 284 (defun haskell-process-insert-type () | |
| 285 "Get the identifer at the point and insert its type, if | |
| 286 possible, using GHCi's :type." | |
| 287 (let ((process (haskell-process)) | |
| 288 (query (let ((ident (haskell-ident-at-point))) | |
| 289 (format (if (string-match "^[_[:lower:][:upper:]]" ident) | |
| 290 ":type %s" | |
| 291 ":type (%s)") | |
| 292 ident)))) | |
| 293 (haskell-process-queue-command | |
| 294 process | |
| 295 (make-haskell-command | |
| 296 :state (list process query (current-buffer)) | |
| 297 :go (lambda (state) | |
| 298 (haskell-process-send-string (nth 0 state) | |
| 299 (nth 1 state))) | |
| 300 :complete (lambda (state response) | |
| 301 (cond | |
| 302 ;; TODO: Generalize this into a function. | |
| 303 ((or (string-match "^Top level" response) | |
| 304 (string-match "^<interactive>" response)) | |
| 305 (message response)) | |
| 306 (t | |
| 307 (with-current-buffer (nth 2 state) | |
| 308 (goto-char (line-beginning-position)) | |
| 309 (insert (format "%s\n" response)))))))))) | |
| 310 | |
| 311 ;;;###autoload | |
| 312 (defun haskell-process-do-info (&optional prompt-value) | |
| 313 "Print info on the identifier at point. | |
| 314 If PROMPT-VALUE is non-nil, request identifier via mini-buffer." | |
| 315 (interactive "P") | |
| 316 (haskell-process-do-simple-echo | |
| 317 (let ((ident (if prompt-value | |
| 318 (read-from-minibuffer "Info: " (haskell-ident-at-point)) | |
| 319 (haskell-ident-at-point))) | |
| 320 (modname (unless prompt-value | |
| 321 (haskell-utils-parse-import-statement-at-point)))) | |
| 322 (if modname | |
| 323 (format ":browse! %s" modname) | |
| 324 (format (if (string-match "^[a-zA-Z_]" ident) | |
| 325 ":info %s" | |
| 326 ":info (%s)") | |
| 327 (or ident | |
| 328 (haskell-ident-at-point))))) | |
| 329 'haskell-mode)) | |
| 330 | |
| 331 (defun haskell-process-do-try-info (sym) | |
| 332 "Get info of `sym' and echo in the minibuffer." | |
| 333 (let ((process (haskell-process))) | |
| 334 (haskell-process-queue-command | |
| 335 process | |
| 336 (make-haskell-command | |
| 337 :state (cons process sym) | |
| 338 :go (lambda (state) | |
| 339 (haskell-process-send-string | |
| 340 (car state) | |
| 341 (if (string-match "^[A-Za-z_]" (cdr state)) | |
| 342 (format ":info %s" (cdr state)) | |
| 343 (format ":info (%s)" (cdr state))))) | |
| 344 :complete (lambda (state response) | |
| 345 (unless (or (string-match "^Top level" response) | |
| 346 (string-match "^<interactive>" response)) | |
| 347 (haskell-mode-message-line response))))))) | |
| 348 | |
| 349 (defun haskell-process-do-simple-echo (line &optional mode) | |
| 350 "Send LINE to the GHCi process and echo the result in some | |
| 351 fashion, such as printing in the minibuffer, or using | |
| 352 haskell-present, depending on configuration." | |
| 353 (let ((process (haskell-process))) | |
| 354 (haskell-process-queue-command | |
| 355 process | |
| 356 (make-haskell-command | |
| 357 :state (list process line mode) | |
| 358 :go (lambda (state) | |
| 359 (haskell-process-send-string (car state) (cadr state))) | |
| 360 :complete (lambda (state response) | |
| 361 ;; TODO: TBD: don't do this if | |
| 362 ;; `haskell-process-use-presentation-mode' is t. | |
| 363 (haskell-interactive-mode-echo | |
| 364 (haskell-process-session (car state)) | |
| 365 response | |
| 366 (caddr state)) | |
| 367 (if haskell-process-use-presentation-mode | |
| 368 (progn (haskell-present (cadr state) | |
| 369 (haskell-process-session (car state)) | |
| 370 response) | |
| 371 (haskell-session-assign | |
| 372 (haskell-process-session (car state)))) | |
| 373 (haskell-mode-message-line response))))))) | |
| 374 | |
| 375 (defun haskell-process-look-config-changes (session) | |
| 376 "Checks whether a cabal configuration file has | |
| 377 changed. Restarts the process if that is the case." | |
| 378 (let ((current-checksum (haskell-session-get session 'cabal-checksum)) | |
| 379 (new-checksum (haskell-cabal-compute-checksum | |
| 380 (haskell-session-get session 'cabal-dir)))) | |
| 381 (when (not (string= current-checksum new-checksum)) | |
| 382 (haskell-interactive-mode-echo session (format "Cabal file changed: %s" new-checksum)) | |
| 383 (haskell-session-set-cabal-checksum session | |
| 384 (haskell-session-get session 'cabal-dir)) | |
| 385 (unless (and haskell-process-prompt-restart-on-cabal-change | |
| 386 (not (y-or-n-p "Cabal file changed; restart GHCi process? "))) | |
| 387 (haskell-process-start (haskell-session)))))) | |
| 388 | |
| 389 ;;;###autoload | |
| 390 (defun haskell-process-load-file () | |
| 391 "Load the current buffer file." | |
| 392 (interactive) | |
| 393 (save-buffer) | |
| 394 (haskell-interactive-mode-reset-error (haskell-session)) | |
| 395 (haskell-process-file-loadish (concat "load " (buffer-file-name)) | |
| 396 nil | |
| 397 (current-buffer))) | |
| 398 | |
| 399 ;;;###autoload | |
| 400 (defun haskell-process-reload-file () | |
| 401 "Re-load the current buffer file." | |
| 402 (interactive) | |
| 403 (save-buffer) | |
| 404 (haskell-interactive-mode-reset-error (haskell-session)) | |
| 405 (haskell-process-file-loadish "reload" t nil)) | |
| 406 | |
| 407 ;;;###autoload | |
| 408 (defun haskell-process-load-or-reload (&optional toggle) | |
| 409 "Load or reload. Universal argument toggles which." | |
| 410 (interactive "P") | |
| 411 (if toggle | |
| 412 (progn (setq haskell-reload-p (not haskell-reload-p)) | |
| 413 (message "%s (No action taken this time)" | |
| 414 (if haskell-reload-p | |
| 415 "Now running :reload." | |
| 416 "Now running :load <buffer-filename>."))) | |
| 417 (if haskell-reload-p (haskell-process-reload-file) (haskell-process-load-file)))) | |
| 418 | |
| 419 (defun haskell-process-file-loadish (command reload-p module-buffer) | |
| 420 "Run a loading-ish COMMAND that wants to pick up type errors | |
| 421 and things like that. RELOAD-P indicates whether the notification | |
| 422 should say 'reloaded' or 'loaded'. MODULE-BUFFER may be used | |
| 423 for various things, but is optional." | |
| 424 (let ((session (haskell-session))) | |
| 425 (haskell-session-current-dir session) | |
| 426 (when haskell-process-check-cabal-config-on-load | |
| 427 (haskell-process-look-config-changes session)) | |
| 428 (let ((process (haskell-process))) | |
| 429 (haskell-process-queue-command | |
| 430 process | |
| 431 (make-haskell-command | |
| 432 :state (list session process command reload-p module-buffer) | |
| 433 :go (lambda (state) | |
| 434 (haskell-process-send-string | |
| 435 (cadr state) (format ":%s" (caddr state)))) | |
| 436 :live (lambda (state buffer) | |
| 437 (haskell-process-live-build | |
| 438 (cadr state) buffer nil)) | |
| 439 :complete (lambda (state response) | |
| 440 (haskell-process-load-complete | |
| 441 (car state) | |
| 442 (cadr state) | |
| 443 response | |
| 444 (cadddr state) | |
| 445 (cadddr (cdr state))))))))) | |
| 446 | |
| 447 ;;;###autoload | |
| 448 (defun haskell-process-cabal-build () | |
| 449 "Build the Cabal project." | |
| 450 (interactive) | |
| 451 (haskell-process-do-cabal "build") | |
| 452 (haskell-process-add-cabal-autogen)) | |
| 453 | |
| 454 ;;;###autoload | |
| 455 (defun haskell-process-cabal () | |
| 456 "Prompts for a Cabal command to run." | |
| 457 (interactive) | |
| 458 (haskell-process-do-cabal | |
| 459 (funcall haskell-completing-read-function "Cabal command: " | |
| 460 haskell-cabal-commands))) | |
| 461 | |
| 462 (defun haskell-process-add-cabal-autogen () | |
| 463 "Add <cabal-project-dir>/dist/build/autogen/ to the ghci search | |
| 464 path. This allows modules such as 'Path_...', generated by cabal, | |
| 465 to be loaded by ghci." | |
| 466 (unless (eq 'cabal-repl haskell-process-type) ;; redundant with "cabal repl" | |
| 467 (let* | |
| 468 ((session (haskell-session)) | |
| 469 (cabal-dir (haskell-session-cabal-dir session)) | |
| 470 (ghci-gen-dir (format "%sdist/build/autogen/" cabal-dir))) | |
| 471 (haskell-process-queue-without-filters | |
| 472 (haskell-process) | |
| 473 (format ":set -i%s" ghci-gen-dir))))) | |
| 474 | |
| 475 (defun haskell-process-do-cabal (command) | |
| 476 "Run a Cabal command." | |
| 477 (let ((process (haskell-process))) | |
| 478 (haskell-process-queue-command | |
| 479 process | |
| 480 (make-haskell-command | |
| 481 :state (list (haskell-session) process command 0) | |
| 482 | |
| 483 :go | |
| 484 (lambda (state) | |
| 485 (haskell-process-send-string | |
| 486 (cadr state) | |
| 487 (format haskell-process-do-cabal-format-string | |
| 488 (haskell-session-cabal-dir (car state)) | |
| 489 (format "%s %s" | |
| 490 (ecase haskell-process-type | |
| 491 ('ghci "cabal") | |
| 492 ('cabal-repl "cabal") | |
| 493 ('cabal-ghci "cabal") | |
| 494 ('cabal-dev "cabal-dev")) | |
| 495 (caddr state))))) | |
| 496 | |
| 497 :live | |
| 498 (lambda (state buffer) | |
| 499 (let ((cmd (replace-regexp-in-string "^\\([a-z]+\\).*" | |
| 500 "\\1" | |
| 501 (caddr state)))) | |
| 502 (cond ((or (string= cmd "build") | |
| 503 (string= cmd "install")) | |
| 504 (haskell-process-live-build (cadr state) buffer t)) | |
| 505 (t | |
| 506 (haskell-process-cabal-live state buffer))))) | |
| 507 | |
| 508 :complete | |
| 509 (lambda (state response) | |
| 510 (let* ((process (cadr state)) | |
| 511 (session (haskell-process-session process)) | |
| 512 (message-count 0) | |
| 513 (cursor (haskell-process-response-cursor process)) | |
| 514 (haskell-imported-suggested (list))) | |
| 515 (haskell-process-set-response-cursor process 0) | |
| 516 (while (haskell-process-errors-warnings session process response) | |
| 517 (setq message-count (1+ message-count))) | |
| 518 (haskell-process-set-response-cursor process cursor) | |
| 519 (let ((msg (format "Complete: cabal %s (%s compiler messages)" | |
| 520 (caddr state) | |
| 521 message-count))) | |
| 522 (haskell-interactive-mode-echo session msg) | |
| 523 (haskell-mode-message-line msg) | |
| 524 (when (and haskell-notify-p | |
| 525 (fboundp 'notifications-notify)) | |
| 526 (notifications-notify | |
| 527 :title (format "*%s*" (haskell-session-name (car state))) | |
| 528 :body msg | |
| 529 :app-name (ecase haskell-process-type | |
| 530 ('ghci "cabal") | |
| 531 ('cabal-repl "cabal") | |
| 532 ('cabal-ghci "cabal") | |
| 533 ('cabal-dev "cabal-dev")) | |
| 534 :app-icon haskell-process-logo | |
| 535 ))))))))) | |
| 536 | |
| 537 (defun haskell-process-cabal-live (state buffer) | |
| 538 "Do live updates for Cabal processes." | |
| 539 (haskell-interactive-mode-insert | |
| 540 (haskell-process-session (cadr state)) | |
| 541 (replace-regexp-in-string | |
| 542 haskell-process-prompt-regex | |
| 543 "" | |
| 544 (substring buffer (cadddr state)))) | |
| 545 (setf (cdddr state) (list (length buffer))) | |
| 546 nil) | |
| 547 | |
| 548 (defun haskell-process-load-complete (session process buffer reload module-buffer &optional cont) | |
| 549 "Handle the complete loading response. BUFFER is the string of | |
| 550 text being sent over the process pipe. MODULE-BUFFER is the | |
| 551 actual Emacs buffer of the module being loaded." | |
| 552 (cond ((haskell-process-consume process "Ok, modules loaded: \\(.+\\)\\.$") | |
| 553 (let* ((modules (haskell-process-extract-modules buffer)) | |
| 554 (cursor (haskell-process-response-cursor process))) | |
| 555 (haskell-process-set-response-cursor process 0) | |
| 556 (let ((warning-count 0)) | |
| 557 (while (haskell-process-errors-warnings session process buffer) | |
| 558 (setq warning-count (1+ warning-count))) | |
| 559 (haskell-process-set-response-cursor process cursor) | |
| 560 (if (and (not reload) | |
| 561 haskell-process-reload-with-fbytecode) | |
| 562 (haskell-process-reload-with-fbytecode process module-buffer) | |
| 563 (haskell-process-import-modules process (car modules))) | |
| 564 (haskell-mode-message-line | |
| 565 (if reload "Reloaded OK." "OK.")) | |
| 566 (when cont | |
| 567 (funcall cont t))))) | |
| 568 ((haskell-process-consume process "Failed, modules loaded: \\(.+\\)\\.$") | |
| 569 (let* ((modules (haskell-process-extract-modules buffer)) | |
| 570 (cursor (haskell-process-response-cursor process)) | |
| 571 (haskell-imported-suggested (list))) | |
| 572 (haskell-process-set-response-cursor process 0) | |
| 573 (while (haskell-process-errors-warnings session process buffer)) | |
| 574 (haskell-process-set-response-cursor process cursor) | |
| 575 (if (and (not reload) haskell-process-reload-with-fbytecode) | |
| 576 (haskell-process-reload-with-fbytecode process module-buffer) | |
| 577 (haskell-process-import-modules process (car modules))) | |
| 578 (haskell-interactive-mode-compile-error session "Compilation failed.") | |
| 579 (when cont | |
| 580 (funcall cont nil)))))) | |
| 581 | |
| 582 (defun haskell-process-reload-with-fbytecode (process module-buffer) | |
| 583 "Reload FILE-NAME with -fbyte-code set, and then restore -fobject-code." | |
| 584 (haskell-process-queue-without-filters process ":set -fbyte-code") | |
| 585 (haskell-process-touch-buffer process module-buffer) | |
| 586 (haskell-process-queue-without-filters process ":reload") | |
| 587 (haskell-process-queue-without-filters process ":set -fobject-code")) | |
| 588 | |
| 589 (defun haskell-process-touch-buffer (process buffer) | |
| 590 "Updates mtime on the file for BUFFER by queing a touch on | |
| 591 PROCESS." | |
| 592 (interactive) | |
| 593 (haskell-process-queue-command | |
| 594 process | |
| 595 (make-haskell-command | |
| 596 :state (cons process buffer) | |
| 597 :go (lambda (state) | |
| 598 (haskell-process-send-string | |
| 599 (car state) | |
| 600 (format ":!%s %s" | |
| 601 "touch" | |
| 602 (shell-quote-argument (buffer-file-name | |
| 603 (cdr state)))))) | |
| 604 :complete (lambda (state _) | |
| 605 (with-current-buffer (cdr state) | |
| 606 (clear-visited-file-modtime)))))) | |
| 607 | |
| 608 (defun haskell-process-extract-modules (buffer) | |
| 609 "Extract the modules from the process buffer." | |
| 610 (let* ((modules-string (match-string 1 buffer)) | |
| 611 (modules (split-string modules-string ", "))) | |
| 612 (cons modules modules-string))) | |
| 613 | |
| 614 (defun haskell-process-import-modules (process modules) | |
| 615 "Import `modules' with :m +, and send any import statements | |
| 616 from `module-buffer'." | |
| 617 (when haskell-process-auto-import-loaded-modules | |
| 618 (haskell-process-queue-command | |
| 619 process | |
| 620 (make-haskell-command | |
| 621 :state (cons process modules) | |
| 622 :go (lambda (state) | |
| 623 (haskell-process-send-string | |
| 624 (car state) | |
| 625 (format ":m + %s" (mapconcat 'identity (cdr state) " ")))))))) | |
| 626 | |
| 627 (defun haskell-process-live-build (process buffer echo-in-repl) | |
| 628 "Show live updates for loading files." | |
| 629 (cond ((haskell-process-consume | |
| 630 process | |
| 631 (concat "\\[[ ]*\\([0-9]+\\) of \\([0-9]+\\)\\]" | |
| 632 " Compiling \\([^ ]+\\)[ ]+" | |
| 633 "( \\([^ ]+\\), \\([^ ]+\\) )[^\r\n]*[\r\n]+")) | |
| 634 (let ((session (haskell-process-session process)) | |
| 635 (module-name (match-string 3 buffer)) | |
| 636 (file-name (match-string 4 buffer))) | |
| 637 (haskell-interactive-show-load-message | |
| 638 session | |
| 639 'compiling | |
| 640 module-name | |
| 641 (haskell-session-strip-dir session file-name) | |
| 642 echo-in-repl)) | |
| 643 t) | |
| 644 ((haskell-process-consume process "Loading package \\([^ ]+\\) ... linking ... done.\n") | |
| 645 (haskell-mode-message-line | |
| 646 (format "Loading: %s" | |
| 647 (match-string 1 buffer))) | |
| 648 t) | |
| 649 ((haskell-process-consume | |
| 650 process | |
| 651 "^Preprocessing executables for \\(.+?\\)\\.\\.\\.") | |
| 652 (let ((msg (format "Preprocessing: %s" (match-string 1 buffer)))) | |
| 653 (haskell-interactive-mode-echo | |
| 654 (haskell-process-session process) | |
| 655 msg) | |
| 656 (haskell-mode-message-line msg))) | |
| 657 ((haskell-process-consume process "Linking \\(.+?\\) \\.\\.\\.") | |
| 658 (let ((msg (format "Linking: %s" (match-string 1 buffer)))) | |
| 659 (haskell-interactive-mode-echo (haskell-process-session process) msg) | |
| 660 (haskell-mode-message-line msg))) | |
| 661 ((haskell-process-consume process "\nBuilding \\(.+?\\)\\.\\.\\.") | |
| 662 (let ((msg (format "Building: %s" (match-string 1 buffer)))) | |
| 663 (haskell-interactive-mode-echo | |
| 664 (haskell-process-session process) | |
| 665 msg) | |
| 666 (haskell-mode-message-line msg))))) | |
| 667 | |
| 668 (defun haskell-process-errors-warnings (session process buffer) | |
| 669 "Trigger handling type errors or warnings." | |
| 670 (cond | |
| 671 ((haskell-process-consume | |
| 672 process | |
| 673 (concat "[\r\n]\\([^ \r\n:][^:\n\r]+\\):\\([0-9]+\\):\\([0-9]+\\)\\(-[0-9]+\\)?:" | |
| 674 "[ \n\r]+\\([[:unibyte:][:nonascii:]]+?\\)\n[^ ]")) | |
| 675 (haskell-process-set-response-cursor process | |
| 676 (- (haskell-process-response-cursor process) 1)) | |
| 677 (let* ((buffer (haskell-process-response process)) | |
| 678 (file (match-string 1 buffer)) | |
| 679 (line (string-to-number (match-string 2 buffer))) | |
| 680 (col (match-string 3 buffer)) | |
| 681 (col2 (match-string 4 buffer)) | |
| 682 (error-msg (match-string 5 buffer)) | |
| 683 (warning (string-match "^Warning:" error-msg)) | |
| 684 (final-msg (format "%s:%s:%s%s: %s" | |
| 685 (haskell-session-strip-dir session file) | |
| 686 line | |
| 687 col (or col2 "") | |
| 688 error-msg))) | |
| 689 (funcall (if warning | |
| 690 'haskell-interactive-mode-compile-warning | |
| 691 'haskell-interactive-mode-compile-error) | |
| 692 session final-msg) | |
| 693 (unless warning | |
| 694 (haskell-mode-message-line final-msg)) | |
| 695 (haskell-process-trigger-suggestions session error-msg file line)) | |
| 696 t))) | |
| 697 | |
| 698 (defun haskell-process-trigger-suggestions (session msg file line) | |
| 699 "Trigger prompting to add any extension suggestions." | |
| 700 (cond ((let ((case-fold-search nil)) (string-match " -X\\([A-Z][A-Za-z]+\\)" msg)) | |
| 701 (when haskell-process-suggest-language-pragmas | |
| 702 (haskell-process-suggest-pragma session "LANGUAGE" (match-string 1 msg) file))) | |
| 703 ((string-match " The \\(qualified \\)?import of[ ]`\\([^ ]+\\)' is redundant" msg) | |
| 704 (when haskell-process-suggest-remove-import-lines | |
| 705 (haskell-process-suggest-remove-import session | |
| 706 file | |
| 707 (match-string 2 msg) | |
| 708 line))) | |
| 709 ((string-match "Warning: orphan instance: " msg) | |
| 710 (when haskell-process-suggest-no-warn-orphans | |
| 711 (haskell-process-suggest-pragma session "OPTIONS" "-fno-warn-orphans" file))) | |
| 712 ((string-match "against inferred type `\\[Char\\]'" msg) | |
| 713 (when haskell-process-suggest-overloaded-strings | |
| 714 (haskell-process-suggest-pragma session "LANGUAGE" "OverloadedStrings" file))) | |
| 715 ((string-match "^Not in scope: .*`\\(.+\\)'$" msg) | |
| 716 (when haskell-process-suggest-hoogle-imports | |
| 717 (haskell-process-suggest-hoogle-imports session msg file))) | |
| 718 ((string-match "^[ ]+It is a member of the hidden package `\\(.+\\)'.$" msg) | |
| 719 (when haskell-process-suggest-add-package | |
| 720 (haskell-process-suggest-add-package session msg))))) | |
| 721 | |
| 722 (defun haskell-process-suggest-add-package (session msg) | |
| 723 "Add the (matched) module to your cabal file." | |
| 724 (let* ((suggested-package (match-string 1 msg)) | |
| 725 (package-name (replace-regexp-in-string "-[^-]+$" "" suggested-package)) | |
| 726 (version (progn (string-match "\\([^-]+\\)$" suggested-package) | |
| 727 (match-string 1 suggested-package))) | |
| 728 (cabal-file (concat (haskell-session-name session) | |
| 729 ".cabal"))) | |
| 730 (when (y-or-n-p | |
| 731 (format "Add `%s' to %s?" | |
| 732 package-name | |
| 733 cabal-file)) | |
| 734 (haskell-process-add-dependency package-name version)))) | |
| 735 | |
| 736 (defun haskell-process-add-dependency (package &optional version no-prompt) | |
| 737 "Add PACKAGE (and optionally suffix -VERSION) to the cabal | |
| 738 file. Prompts the user before doing so." | |
| 739 (interactive | |
| 740 (list (read-from-minibuffer "Package entry: ") | |
| 741 nil | |
| 742 t)) | |
| 743 (let ((buffer (current-buffer))) | |
| 744 (find-file (haskell-cabal-find-file)) | |
| 745 (let ((entry (if no-prompt | |
| 746 package | |
| 747 (read-from-minibuffer "Package entry: " | |
| 748 (concat package | |
| 749 (if version | |
| 750 (concat " >= " | |
| 751 version) | |
| 752 "")))))) | |
| 753 (save-excursion | |
| 754 (goto-char (point-min)) | |
| 755 (when (search-forward-regexp "^library$" nil t 1) | |
| 756 (search-forward-regexp "build-depends:[ ]+") | |
| 757 (let ((column (current-column))) | |
| 758 (when (y-or-n-p "Add to library?") | |
| 759 (insert entry ",\n") | |
| 760 (indent-to column)))) | |
| 761 (goto-char (point-min)) | |
| 762 (while (search-forward-regexp "^executable " nil t 1) | |
| 763 (let ((name (buffer-substring-no-properties (point) (line-end-position)))) | |
| 764 (search-forward-regexp "build-depends:[ ]+") | |
| 765 (let ((column (current-column))) | |
| 766 (when (y-or-n-p (format "Add to executable `%s'?" name)) | |
| 767 (insert entry ",\n") | |
| 768 (indent-to column))))) | |
| 769 (save-buffer) | |
| 770 (switch-to-buffer buffer))))) | |
| 771 | |
| 772 (defun haskell-process-suggest-hoogle-imports (session msg file) | |
| 773 "Given an out of scope identifier, Hoogle for that identifier, | |
| 774 and if a result comes back, suggest to import that identifier | |
| 775 now." | |
| 776 (let* ((ident (let ((i (match-string 1 msg))) | |
| 777 (if (string-match "^[A-Z]\\.\\(.+\\)$" i) | |
| 778 (match-string 1 i) | |
| 779 i))) | |
| 780 (modules (haskell-process-hoogle-ident ident)) | |
| 781 (module | |
| 782 (cond | |
| 783 ((> (length modules) 1) | |
| 784 (when (y-or-n-p (format "Identifier `%s' not in scope, choose module to import?" | |
| 785 ident)) | |
| 786 (funcall haskell-completing-read-function "Module: " modules))) | |
| 787 ((= (length modules) 1) | |
| 788 (when (y-or-n-p (format "Identifier `%s' not in scope, import `%s'?" | |
| 789 ident | |
| 790 (car modules))) | |
| 791 (car modules)))))) | |
| 792 (when module | |
| 793 (unless (member module haskell-imported-suggested) | |
| 794 (push module haskell-imported-suggested) | |
| 795 (haskell-process-find-file session file) | |
| 796 (save-excursion | |
| 797 (goto-char (point-max)) | |
| 798 (haskell-navigate-imports) | |
| 799 (insert (read-from-minibuffer "Import line: " (concat "import " module)) | |
| 800 "\n") | |
| 801 (haskell-sort-imports) | |
| 802 (haskell-align-imports)))))) | |
| 803 | |
| 804 (defun haskell-process-hoogle-ident (ident) | |
| 805 "Hoogle for IDENT, returns a list of modules." | |
| 806 (with-temp-buffer | |
| 807 (call-process "hoogle" nil t nil "search" "--exact" ident) | |
| 808 (goto-char (point-min)) | |
| 809 (unless (or (looking-at "^No results found") | |
| 810 (looking-at "^package ")) | |
| 811 (while (re-search-forward "^\\([^ ]+\\).*$" nil t) | |
| 812 (replace-match "\\1" nil nil)) | |
| 813 (remove-if (lambda (a) (string= "" a)) | |
| 814 (split-string (buffer-string) | |
| 815 "\n"))))) | |
| 816 | |
| 817 (defun haskell-process-suggest-remove-import (session file import line) | |
| 818 "Suggest removing or commenting out IMPORT on LINE." | |
| 819 (case (read-key (propertize (format "The import line `%s' is redundant. Remove? (y, n, c: comment out) " | |
| 820 import) | |
| 821 'face 'minibuffer-prompt)) | |
| 822 (?y | |
| 823 (haskell-process-find-file session file) | |
| 824 (save-excursion | |
| 825 (goto-char (point-min)) | |
| 826 (forward-line (1- line)) | |
| 827 (goto-char (line-beginning-position)) | |
| 828 (delete-region (line-beginning-position) | |
| 829 (line-end-position)))) | |
| 830 (?c | |
| 831 (haskell-process-find-file session file) | |
| 832 (save-excursion | |
| 833 (goto-char (point-min)) | |
| 834 (forward-line (1- line)) | |
| 835 (goto-char (line-beginning-position)) | |
| 836 (insert "-- "))))) | |
| 837 | |
| 838 (defun haskell-process-suggest-pragma (session pragma extension file) | |
| 839 "Suggest to add something to the top of the file." | |
| 840 (let ((string (format "{-# %s %s #-}" pragma extension))) | |
| 841 (when (y-or-n-p (format "Add %s to the top of the file? " string)) | |
| 842 (haskell-process-find-file session file) | |
| 843 (save-excursion | |
| 844 (goto-char (point-min)) | |
| 845 (insert (concat string "\n")))))) | |
| 846 | |
| 847 (defun haskell-process-find-file (session file) | |
| 848 "Find the given file in the project." | |
| 849 (find-file (cond ((file-exists-p (concat (haskell-session-current-dir session) "/" file)) | |
| 850 (concat (haskell-session-current-dir session) "/" file)) | |
| 851 ((file-exists-p (concat (haskell-session-cabal-dir session) "/" file)) | |
| 852 (concat (haskell-session-cabal-dir session) "/" file)) | |
| 853 (t file)))) | |
| 854 | |
| 855 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 856 ;; Building the process | |
| 857 | |
| 858 ;;;###autoload | |
| 859 (defun haskell-process-start (session) | |
| 860 "Start the inferior Haskell process." | |
| 861 (let ((existing-process (get-process (haskell-session-name (haskell-session))))) | |
| 862 (when (processp existing-process) | |
| 863 (haskell-interactive-mode-echo session "Restarting process ...") | |
| 864 (haskell-process-set (haskell-session-process session) 'is-restarting t) | |
| 865 (delete-process existing-process))) | |
| 866 (let ((process (or (haskell-session-process session) | |
| 867 (haskell-process-make (haskell-session-name session)))) | |
| 868 (old-queue (haskell-process-get (haskell-session-process session) | |
| 869 'command-queue))) | |
| 870 (haskell-session-set-process session process) | |
| 871 (haskell-process-set-session process session) | |
| 872 (haskell-process-set-cmd process nil) | |
| 873 (haskell-process-set (haskell-session-process session) 'is-restarting nil) | |
| 874 (let ((default-directory (haskell-session-cabal-dir session))) | |
| 875 (haskell-session-pwd session) | |
| 876 (haskell-process-set-process | |
| 877 process | |
| 878 (ecase haskell-process-type | |
| 879 ('ghci | |
| 880 (haskell-process-log (format "Starting inferior GHCi process %s ..." | |
| 881 haskell-process-path-ghci)) | |
| 882 (apply #'start-process | |
| 883 (append (list (haskell-session-name session) | |
| 884 nil | |
| 885 haskell-process-path-ghci) | |
| 886 haskell-process-args-ghci))) | |
| 887 ('cabal-repl | |
| 888 (haskell-process-log (format "Starting inferior `cabal repl' process using %s ..." | |
| 889 haskell-process-path-cabal)) | |
| 890 | |
| 891 (apply #'start-process | |
| 892 (append (list (haskell-session-name session) | |
| 893 nil | |
| 894 haskell-process-path-cabal) | |
| 895 '("repl") haskell-process-args-cabal-repl | |
| 896 (let ((target (haskell-session-target session))) | |
| 897 (if target (list target) nil))))) | |
| 898 ('cabal-ghci | |
| 899 (haskell-process-log (format "Starting inferior cabal-ghci process using %s ..." | |
| 900 haskell-process-path-cabal-ghci)) | |
| 901 (start-process (haskell-session-name session) | |
| 902 nil | |
| 903 haskell-process-path-cabal-ghci)) | |
| 904 ('cabal-dev | |
| 905 (let ((dir (concat (haskell-session-cabal-dir session) | |
| 906 "/cabal-dev"))) | |
| 907 (haskell-process-log (format "Starting inferior cabal-dev process %s -s %s ..." | |
| 908 haskell-process-path-cabal-dev | |
| 909 dir)) | |
| 910 (start-process (haskell-session-name session) | |
| 911 nil | |
| 912 haskell-process-path-cabal-dev | |
| 913 "ghci" | |
| 914 "-s" | |
| 915 dir)))))) | |
| 916 (progn (set-process-sentinel (haskell-process-process process) 'haskell-process-sentinel) | |
| 917 (set-process-filter (haskell-process-process process) 'haskell-process-filter)) | |
| 918 (haskell-process-send-startup process) | |
| 919 (unless (eq 'cabal-repl haskell-process-type) ;; "cabal repl" sets the proper CWD | |
| 920 (haskell-process-change-dir session | |
| 921 process | |
| 922 (haskell-session-current-dir session))) | |
| 923 (haskell-process-set process 'command-queue | |
| 924 (append (haskell-process-get (haskell-session-process session) | |
| 925 'command-queue) | |
| 926 old-queue)) | |
| 927 process)) | |
| 928 | |
| 929 (defun haskell-process-clear () | |
| 930 "Clear the current process." | |
| 931 (interactive) | |
| 932 (haskell-process-reset (haskell-process)) | |
| 933 (haskell-process-set (haskell-process) 'command-queue nil)) | |
| 934 | |
| 935 (defun haskell-process-restart () | |
| 936 "Restart the inferior Haskell process." | |
| 937 (interactive) | |
| 938 (haskell-process-reset (haskell-process)) | |
| 939 (haskell-process-set (haskell-process) 'command-queue nil) | |
| 940 (haskell-process-start (haskell-session))) | |
| 941 | |
| 942 (defun haskell-kill-session-process (&optional session) | |
| 943 "Kill the process." | |
| 944 (interactive) | |
| 945 (let* ((session (or session (haskell-session))) | |
| 946 (existing-process (get-process (haskell-session-name session)))) | |
| 947 (when (processp existing-process) | |
| 948 (haskell-interactive-mode-echo session "Killing process ...") | |
| 949 (haskell-process-set (haskell-session-process session) 'is-restarting t) | |
| 950 (delete-process existing-process)))) | |
| 951 | |
| 952 (defun haskell-process-make (name) | |
| 953 "Make an inferior Haskell process." | |
| 954 (list (cons 'name name))) | |
| 955 | |
| 956 ;;;###autoload | |
| 957 (defun haskell-process () | |
| 958 "Get the current process from the current session." | |
| 959 (haskell-session-process (haskell-session))) | |
| 960 | |
| 961 (defun haskell-process-interrupt () | |
| 962 "Interrupt the process (SIGINT)." | |
| 963 (interactive) | |
| 964 (interrupt-process (haskell-process-process (haskell-process)))) | |
| 965 | |
| 966 (defun haskell-process-cd (&optional not-interactive) | |
| 967 "Change directory." | |
| 968 (interactive) | |
| 969 (let* ((session (haskell-session)) | |
| 970 (dir (haskell-session-pwd session t))) | |
| 971 (haskell-process-log (format "Changing directory to %s ...\n" dir)) | |
| 972 (haskell-process-change-dir session | |
| 973 (haskell-process) | |
| 974 dir))) | |
| 975 | |
| 976 (defun haskell-session-pwd (session &optional change) | |
| 977 "Prompt for the current directory." | |
| 978 (or (unless change | |
| 979 (haskell-session-get session 'current-dir)) | |
| 980 (progn (haskell-session-set-current-dir | |
| 981 session | |
| 982 (haskell-utils-read-directory-name | |
| 983 (if change "Change directory: " "Set current directory: ") | |
| 984 (or (haskell-session-get session 'current-dir) | |
| 985 (haskell-session-get session 'cabal-dir) | |
| 986 (if (buffer-file-name) | |
| 987 (file-name-directory (buffer-file-name)) | |
| 988 "~/")))) | |
| 989 (haskell-session-get session 'current-dir)))) | |
| 990 | |
| 991 (defun haskell-process-change-dir (session process dir) | |
| 992 "Change the directory of the current process." | |
| 993 (haskell-process-queue-command | |
| 994 process | |
| 995 (make-haskell-command | |
| 996 :state (list session process dir) | |
| 997 | |
| 998 :go | |
| 999 (lambda (state) | |
| 1000 (haskell-process-send-string | |
| 1001 (cadr state) (format ":cd %s" (caddr state)))) | |
| 1002 | |
| 1003 :complete | |
| 1004 (lambda (state _) | |
| 1005 (haskell-session-set-current-dir (car state) (caddr state)) | |
| 1006 (haskell-interactive-mode-echo (car state) | |
| 1007 (format "Changed directory: %s" | |
| 1008 (caddr state))))))) | |
| 1009 | |
| 1010 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1011 ;; Process communication | |
| 1012 | |
| 1013 (defun haskell-process-send-startup (process) | |
| 1014 "Send the necessary start messages." | |
| 1015 (haskell-process-queue-command | |
| 1016 process | |
| 1017 (make-haskell-command | |
| 1018 :state process | |
| 1019 | |
| 1020 :go (lambda (process) | |
| 1021 (haskell-process-send-string process ":set prompt \"> \"") | |
| 1022 (haskell-process-send-string process "Prelude.putStrLn \"\"") | |
| 1023 (haskell-process-send-string process ":set -v1")) | |
| 1024 | |
| 1025 :live (lambda (process buffer) | |
| 1026 (when (haskell-process-consume | |
| 1027 process | |
| 1028 "^\*\*\* WARNING: \\(.+\\) is writable by someone else, IGNORING!$") | |
| 1029 (let ((path (match-string 1 buffer))) | |
| 1030 (haskell-session-modify | |
| 1031 (haskell-process-session process) | |
| 1032 'ignored-files | |
| 1033 (lambda (files) | |
| 1034 (remove-duplicates (cons path files) :test 'string=))) | |
| 1035 (haskell-interactive-mode-compile-warning | |
| 1036 (haskell-process-session process) | |
| 1037 (format "GHCi is ignoring: %s (run M-x haskell-process-unignore)" | |
| 1038 path))))) | |
| 1039 | |
| 1040 :complete (lambda (process _) | |
| 1041 (haskell-interactive-mode-echo | |
| 1042 (haskell-process-session process) | |
| 1043 (concat (nth (random (length haskell-process-greetings)) | |
| 1044 haskell-process-greetings) | |
| 1045 (when haskell-process-show-debug-tips | |
| 1046 " | |
| 1047 If I break, you can: | |
| 1048 1. Restart: M-x haskell-process-restart | |
| 1049 2. Configure logging: C-h v haskell-process-log (useful for debugging) | |
| 1050 3. General config: M-x customize-mode | |
| 1051 4. Hide these tips: C-h v haskell-process-show-debug-tips"))))))) | |
| 1052 | |
| 1053 (defun haskell-process-sentinel (proc event) | |
| 1054 "The sentinel for the process pipe." | |
| 1055 (let ((session (haskell-process-project-by-proc proc))) | |
| 1056 (when session | |
| 1057 (let* ((process (haskell-session-process session))) | |
| 1058 (unless (haskell-process-restarting process) | |
| 1059 (haskell-process-log (format "Event: %S\n" event)) | |
| 1060 (haskell-process-log "Process reset.\n") | |
| 1061 (haskell-process-prompt-restart process)))))) | |
| 1062 | |
| 1063 (defun haskell-process-filter (proc response) | |
| 1064 "The filter for the process pipe." | |
| 1065 (haskell-process-log (format "<- %S\n" response)) | |
| 1066 (let ((session (haskell-process-project-by-proc proc))) | |
| 1067 (when session | |
| 1068 (when (haskell-process-cmd (haskell-session-process session)) | |
| 1069 (haskell-process-collect session | |
| 1070 response | |
| 1071 (haskell-session-process session)))))) | |
| 1072 | |
| 1073 (defun haskell-process-log (msg) | |
| 1074 "Write MSG to the process log (if enabled)." | |
| 1075 (when haskell-process-log | |
| 1076 (with-current-buffer (get-buffer-create "*haskell-process-log*") | |
| 1077 (goto-char (point-max)) | |
| 1078 (insert msg)))) | |
| 1079 | |
| 1080 (defun haskell-process-project-by-proc (proc) | |
| 1081 "Find project by process." | |
| 1082 (find-if (lambda (project) | |
| 1083 (string= (haskell-session-name project) | |
| 1084 (process-name proc))) | |
| 1085 haskell-sessions)) | |
| 1086 | |
| 1087 (defun haskell-process-collect (session response process) | |
| 1088 "Collect input for the response until receives a prompt." | |
| 1089 (haskell-process-set-response process | |
| 1090 (concat (haskell-process-response process) response)) | |
| 1091 (while (haskell-process-live-updates process)) | |
| 1092 (when (string-match haskell-process-prompt-regex | |
| 1093 (haskell-process-response process)) | |
| 1094 (haskell-command-exec-complete | |
| 1095 (haskell-process-cmd process) | |
| 1096 (replace-regexp-in-string | |
| 1097 haskell-process-prompt-regex | |
| 1098 "" | |
| 1099 (haskell-process-response process))) | |
| 1100 (haskell-process-reset process) | |
| 1101 (haskell-process-trigger-queue process))) | |
| 1102 | |
| 1103 (defun haskell-process-reset (process) | |
| 1104 "Reset the process's state, ready for the next send/reply." | |
| 1105 (progn (haskell-process-set-response-cursor process 0) | |
| 1106 (haskell-process-set-response process "") | |
| 1107 (haskell-process-set-cmd process nil))) | |
| 1108 | |
| 1109 (defun haskell-process-consume (process regex) | |
| 1110 "Consume a regex from the response and move the cursor along if succeed." | |
| 1111 (when (string-match regex | |
| 1112 (haskell-process-response process) | |
| 1113 (haskell-process-response-cursor process)) | |
| 1114 (haskell-process-set-response-cursor process (match-end 0)) | |
| 1115 t)) | |
| 1116 | |
| 1117 (defun haskell-process-send-string (process string) | |
| 1118 "Try to send a string to the process's process. Ask to restart if it's not running." | |
| 1119 (let ((child (haskell-process-process process))) | |
| 1120 (if (equal 'run (process-status child)) | |
| 1121 (let ((out (concat string "\n"))) | |
| 1122 (haskell-process-log (format "-> %S\n" out)) | |
| 1123 (process-send-string child out)) | |
| 1124 (unless (haskell-process-restarting process) | |
| 1125 (haskell-process-prompt-restart process))))) | |
| 1126 | |
| 1127 (defun haskell-process-prompt-restart (process) | |
| 1128 "Prompt to restart the died process." | |
| 1129 (when (y-or-n-p (format "The Haskell process `%s' has died. Restart? " | |
| 1130 (haskell-process-name process))) | |
| 1131 (haskell-process-start (haskell-process-session process)))) | |
| 1132 | |
| 1133 (defun haskell-process-live-updates (process) | |
| 1134 "Process live updates." | |
| 1135 (haskell-command-exec-live (haskell-process-cmd process) | |
| 1136 (haskell-process-response process))) | |
| 1137 | |
| 1138 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1139 ;; Making commands | |
| 1140 | |
| 1141 (defun haskell-process-queue-without-filters (process line) | |
| 1142 "Queue LINE to be sent to PROCESS without bothering to look at | |
| 1143 the response." | |
| 1144 (haskell-process-queue-command | |
| 1145 process | |
| 1146 (make-haskell-command | |
| 1147 :state (cons process line) | |
| 1148 :go (lambda (state) | |
| 1149 (haskell-process-send-string (car state) | |
| 1150 (cdr state)))))) | |
| 1151 | |
| 1152 (defun haskell-process-queue-command (process command) | |
| 1153 "Add a command to the process command queue." | |
| 1154 (haskell-process-cmd-queue-add process command) | |
| 1155 (haskell-process-trigger-queue process)) | |
| 1156 | |
| 1157 (defun haskell-process-trigger-queue (process) | |
| 1158 "Trigger the next command in the queue to be ran if there is no current command." | |
| 1159 (if (and (haskell-process-process process) | |
| 1160 (process-live-p (haskell-process-process process))) | |
| 1161 (unless (haskell-process-cmd process) | |
| 1162 (let ((cmd (haskell-process-cmd-queue-pop process))) | |
| 1163 (when cmd | |
| 1164 (haskell-process-set-cmd process cmd) | |
| 1165 (haskell-command-exec-go cmd)))) | |
| 1166 (progn (haskell-process-reset process) | |
| 1167 (haskell-process-set (haskell-process) 'command-queue nil) | |
| 1168 (haskell-process-prompt-restart process)))) | |
| 1169 | |
| 1170 (defun haskell-process-queue-flushed-p (process) | |
| 1171 "Return t if command queue has been completely processed." | |
| 1172 (not (or (haskell-process-cmd-queue process) | |
| 1173 (haskell-process-cmd process)))) | |
| 1174 | |
| 1175 (defun haskell-process-queue-flush (process) | |
| 1176 "Block till PROCESS' command queue has been completely processed. | |
| 1177 This uses `accept-process-output' internally." | |
| 1178 (while (not (haskell-process-queue-flushed-p process)) | |
| 1179 (haskell-process-trigger-queue process) | |
| 1180 (accept-process-output (haskell-process-process process) 1))) | |
| 1181 | |
| 1182 (defun haskell-process-queue-sync-request (process reqstr) | |
| 1183 "Queue submitting REQSTR to PROCESS and return response blockingly." | |
| 1184 (let ((cmd (make-haskell-command | |
| 1185 :state (cons nil process) | |
| 1186 :go `(lambda (s) (haskell-process-send-string (cdr s) ,reqstr)) | |
| 1187 :complete 'setcar))) | |
| 1188 (haskell-process-queue-command process cmd) | |
| 1189 (haskell-process-queue-flush process) | |
| 1190 (car-safe (haskell-command-state cmd)))) | |
| 1191 | |
| 1192 (defun haskell-process-get-repl-completions (process inputstr) | |
| 1193 "Perform `:complete repl ...' query for INPUTSTR using PROCESS." | |
| 1194 (let* ((reqstr (concat ":complete repl " | |
| 1195 (haskell-str-literal-encode inputstr))) | |
| 1196 (rawstr (haskell-process-queue-sync-request process reqstr))) | |
| 1197 (if (string-prefix-p "unknown command " rawstr) | |
| 1198 (error "GHCi lacks `:complete' support") | |
| 1199 (let* ((s1 (split-string rawstr "\r?\n")) | |
| 1200 (cs (mapcar #'haskell-str-literal-decode (cdr s1))) | |
| 1201 (h0 (car s1))) ;; "<cnt1> <cnt2> <quoted-str>" | |
| 1202 (unless (string-match "\\`\\([0-9]+\\) \\([0-9]+\\) \\(\".*\"\\)\\'" h0) | |
| 1203 (error "Invalid `:complete' response")) | |
| 1204 (let ((cnt1 (match-string 1 h0)) | |
| 1205 (h1 (haskell-str-literal-decode (match-string 3 h0)))) | |
| 1206 (unless (= (string-to-number cnt1) (length cs)) | |
| 1207 (error "Lengths inconsistent in `:complete' reponse")) | |
| 1208 (cons h1 cs)))))) | |
| 1209 | |
| 1210 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1211 ;; Accessing the process | |
| 1212 | |
| 1213 (defun haskell-process-get (process key) | |
| 1214 "Get the PROCESS's KEY value. | |
| 1215 Returns nil if KEY not set." | |
| 1216 (cdr (assq key process))) | |
| 1217 | |
| 1218 (defun haskell-process-set (process key value) | |
| 1219 "Set the PROCESS's KEY to VALUE. | |
| 1220 Returns newly set VALUE." | |
| 1221 (if process | |
| 1222 (let ((cell (assq key process))) | |
| 1223 (if cell | |
| 1224 (setcdr cell value) ; modify cell in-place | |
| 1225 (setcdr process (cons (cons key value) (cdr process))) ; new cell | |
| 1226 value)) | |
| 1227 (display-warning 'haskell-interactive | |
| 1228 "`haskell-process-set' called with nil process"))) | |
| 1229 | |
| 1230 ;; Wrappers using haskell-process-{get,set} | |
| 1231 | |
| 1232 (defun haskell-process-set-process (p v) | |
| 1233 "Set the process's inferior process." | |
| 1234 (haskell-process-set p 'inferior-process v)) | |
| 1235 | |
| 1236 (defun haskell-process-process (p) | |
| 1237 "Get the process child." | |
| 1238 (haskell-process-get p 'inferior-process)) | |
| 1239 | |
| 1240 (defun haskell-process-name (p) | |
| 1241 "Get the process name." | |
| 1242 (haskell-process-get p 'name)) | |
| 1243 | |
| 1244 (defun haskell-process-cmd (p) | |
| 1245 "Get the process's current command. | |
| 1246 Return nil if no current command." | |
| 1247 (haskell-process-get p 'current-command)) | |
| 1248 | |
| 1249 (defun haskell-process-set-cmd (p v) | |
| 1250 "Set the process's current command." | |
| 1251 (haskell-process-set p 'current-command v)) | |
| 1252 | |
| 1253 (defun haskell-process-response (p) | |
| 1254 "Get the process's current response." | |
| 1255 (haskell-process-get p 'current-response)) | |
| 1256 | |
| 1257 (defun haskell-process-session (p) | |
| 1258 "Get the process's current session." | |
| 1259 (haskell-process-get p 'session)) | |
| 1260 | |
| 1261 (defun haskell-process-set-response (p v) | |
| 1262 "Set the process's current response." | |
| 1263 (haskell-process-set p 'current-response v)) | |
| 1264 | |
| 1265 (defun haskell-process-set-session (p v) | |
| 1266 "Set the process's current session." | |
| 1267 (haskell-process-set p 'session v)) | |
| 1268 | |
| 1269 (defun haskell-process-response-cursor (p) | |
| 1270 "Get the process's current response cursor." | |
| 1271 (haskell-process-get p 'current-response-cursor)) | |
| 1272 | |
| 1273 (defun haskell-process-set-response-cursor (p v) | |
| 1274 "Set the process's response cursor." | |
| 1275 (haskell-process-set p 'current-response-cursor v)) | |
| 1276 | |
| 1277 ;; low-level command queue operations | |
| 1278 | |
| 1279 (defun haskell-process-restarting (process) | |
| 1280 "Is the PROCESS restarting?" | |
| 1281 (haskell-process-get process 'is-restarting)) | |
| 1282 | |
| 1283 (defun haskell-process-cmd-queue (process) | |
| 1284 "Get the PROCESS' command queue. | |
| 1285 New entries get added to the end of the list. Use | |
| 1286 `haskell-process-cmd-queue-add' and | |
| 1287 `haskell-process-cmd-queue-pop' to modify the command queue." | |
| 1288 (haskell-process-get process 'command-queue)) | |
| 1289 | |
| 1290 (defun haskell-process-cmd-queue-add (process cmd) | |
| 1291 "Add CMD to end of PROCESS's command queue." | |
| 1292 (check-type cmd haskell-command) | |
| 1293 (haskell-process-set process | |
| 1294 'command-queue | |
| 1295 (append (haskell-process-cmd-queue process) | |
| 1296 (list cmd)))) | |
| 1297 | |
| 1298 (defun haskell-process-cmd-queue-pop (process) | |
| 1299 "Pop the PROCESS' next entry from command queue. | |
| 1300 Returns nil if queue is empty." | |
| 1301 (let ((queue (haskell-process-cmd-queue process))) | |
| 1302 (when queue | |
| 1303 (haskell-process-set process 'command-queue (cdr queue)) | |
| 1304 (car queue)))) | |
| 1305 | |
| 1306 (defun haskell-process-unignore () | |
| 1307 "Unignore any files that were specified as being ignored by the | |
| 1308 inferior GHCi process." | |
| 1309 (interactive) | |
| 1310 (let ((session (haskell-session)) | |
| 1311 (changed nil)) | |
| 1312 (if (null (haskell-session-get session | |
| 1313 'ignored-files)) | |
| 1314 (message "Nothing to unignore!") | |
| 1315 (loop for file in (haskell-session-get session | |
| 1316 'ignored-files) | |
| 1317 do (case (read-key | |
| 1318 (propertize (format "Set permissions? %s (y, n, v: stop and view file)" | |
| 1319 file) | |
| 1320 'face 'minibuffer-prompt)) | |
| 1321 (?y | |
| 1322 (haskell-process-unignore-file session file) | |
| 1323 (setq changed t)) | |
| 1324 (?v | |
| 1325 (find-file file) | |
| 1326 (return)))) | |
| 1327 (when (and changed | |
| 1328 (y-or-n-p "Restart GHCi process now? ")) | |
| 1329 (haskell-process-restart))))) | |
| 1330 | |
| 1331 (defun haskell-process-reload-devel-main () | |
| 1332 "Reload the module `DevelMain' and then run | |
| 1333 `DevelMain.update'. This is for doing live update of the code of | |
| 1334 servers or GUI applications. Put your development version of the | |
| 1335 program in `DevelMain', and define `update' to auto-start the | |
| 1336 program on a new thread, and use the `foreign-store' package to | |
| 1337 access the running context across :load/:reloads in GHCi." | |
| 1338 (interactive) | |
| 1339 (with-current-buffer (get-buffer "DevelMain.hs") | |
| 1340 (let ((session (haskell-session))) | |
| 1341 (let ((process (haskell-process))) | |
| 1342 (haskell-process-queue-command | |
| 1343 process | |
| 1344 (make-haskell-command | |
| 1345 :state (list :session session | |
| 1346 :process process | |
| 1347 :buffer (current-buffer)) | |
| 1348 :go (lambda (state) | |
| 1349 (haskell-process-send-string (plist-get state ':process) | |
| 1350 ":l DevelMain")) | |
| 1351 :live (lambda (state buffer) | |
| 1352 (haskell-process-live-build (plist-get state ':process) | |
| 1353 buffer | |
| 1354 nil)) | |
| 1355 :complete (lambda (state response) | |
| 1356 (haskell-process-load-complete | |
| 1357 (plist-get state ':session) | |
| 1358 (plist-get state ':process) | |
| 1359 response | |
| 1360 nil | |
| 1361 (plist-get state ':buffer) | |
| 1362 (lambda (ok) | |
| 1363 (when ok | |
| 1364 (haskell-process-queue-without-filters | |
| 1365 (haskell-process) | |
| 1366 "DevelMain.update") | |
| 1367 (message "DevelMain updated."))))))))))) | |
| 1368 | |
| 1369 (defun haskell-process-unignore-file (session file) | |
| 1370 " | |
| 1371 | |
| 1372 Note to Windows Emacs hackers: | |
| 1373 | |
| 1374 chmod is how to change the mode of files in POSIX | |
| 1375 systems. This will not work on your operating | |
| 1376 system. | |
| 1377 | |
| 1378 There is a command a bit like chmod called \"Calcs\" | |
| 1379 that you can try using here: | |
| 1380 | |
| 1381 http://technet.microsoft.com/en-us/library/bb490872.aspx | |
| 1382 | |
| 1383 If it works, you can submit a patch to this | |
| 1384 function and remove this comment. | |
| 1385 " | |
| 1386 (shell-command (read-from-minibuffer "Permissions command: " | |
| 1387 (concat "chmod 700 " | |
| 1388 file))) | |
| 1389 (haskell-session-modify | |
| 1390 (haskell-session) | |
| 1391 'ignored-files | |
| 1392 (lambda (files) | |
| 1393 (remove-if (lambda (path) | |
| 1394 (string= path file)) | |
| 1395 files)))) | |
| 1396 | |
| 1397 (defun haskell-command-exec-go (command) | |
| 1398 "Call the command's go function." | |
| 1399 (let ((go-func (haskell-command-go command))) | |
| 1400 (when go-func | |
| 1401 (funcall go-func (haskell-command-state command))))) | |
| 1402 | |
| 1403 (defun haskell-command-exec-complete (command response) | |
| 1404 "Call the command's complete function." | |
| 1405 (let ((comp-func (haskell-command-complete command))) | |
| 1406 (when comp-func | |
| 1407 (funcall comp-func | |
| 1408 (haskell-command-state command) | |
| 1409 response)))) | |
| 1410 | |
| 1411 (defun haskell-command-exec-live (command response) | |
| 1412 "Trigger the command's live updates callback." | |
| 1413 (let ((live-func (haskell-command-live command))) | |
| 1414 (when live-func | |
| 1415 (funcall live-func | |
| 1416 (haskell-command-state command) | |
| 1417 response)))) | |
| 1418 | |
| 1419 (provide 'haskell-process) | |
| 1420 | |
| 1421 ;; Local Variables: | |
| 1422 ;; byte-compile-warnings: (not cl-functions) | |
| 1423 ;; End: | |
| 1424 | |
| 1425 ;;; haskell-process.el ends here |