From 0b463f30c4ab5c31cc978adbdb72d240fbc55602 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=D0=90=D1=80=D1=82=D1=83=D1=80=20=D0=A4=D0=B0=D0=B8=CC=86?= =?UTF-8?q?=D0=B7=D1=80=D0=B0=D1=85=D0=BC=D0=B0=D0=BD=D0=BE=D0=B2?= Date: Sat, 9 May 2015 22:02:16 +0500 Subject: [PATCH 1/4] Define few helper functions + hs-utils/capture-expr-bounds + hs-utils/compose-type-at-command + hs-utils/reduce-string + hs-utils/insert-type-signature + hs-utils/echo-or-present --- haskell-commands.el | 65 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 65 insertions(+) diff --git a/haskell-commands.el b/haskell-commands.el index 49b6c4743..534de5596 100644 --- a/haskell-commands.el +++ b/haskell-commands.el @@ -856,4 +856,69 @@ the :uses command from GHCi." (error (propertize "No reply. Is :uses supported?" 'face 'compilation-error))))))) +(defun hs-utils/capture-expr-bounds () + "Capture position bounds of expression at point. +If there is an active region then it returns region +bounds. Otherwise it uses `haskell-spanable-pos-at-point` to +capture identifier bounds. If latter function returns NIL this function +will return cons cell where min and max positions both are equal +to point." + (or (when (region-active-p) + (cons (region-beginning) + (region-end))) + (haskell-spanable-pos-at-point) + (cons (point) (point)))) + +(defun hs-utils/compose-type-at-command (pos) + "Prepare :type-at command to be send to haskell process. +POS is a cons cell containing min and max positions, i.e. target +expression bounds." + (replace-regexp-in-string + "\n$" + "" + (format ":type-at %s %d %d %d %d %s" + (buffer-file-name) + (progn (goto-char (car pos)) + (line-number-at-pos)) + (1+ (current-column)) + (progn (goto-char (cdr pos)) + (line-number-at-pos)) + (1+ (current-column)) + (buffer-substring-no-properties (car pos) + (cdr pos))))) + +(defun hs-utils/reduce-string (s) + "Remove newlines ans extra whitespace from S. +Removes all extra whitespace at the beginning of each line leaving +only single one. Then removes all newlines." + (let ((s_ (replace-regexp-in-string "^\s+" " " s))) + (replace-regexp-in-string "\n" "" s_))) + +(defun hs-utils/insert-type-signature (signature) + "Insert type signature. +In case of active region is present, wrap it by parentheses and +append SIGNATURE to original expression. Otherwise tries to +carefully insert SIGNATURE above identifier at point. Removes +newlines and extra whitespace in signature before insertion." + (let* ((ident-pos (or (haskell-ident-pos-at-point) + (cons (point) (point)))) + (min-pos (car ident-pos)) + (sig (hs-utils/reduce-string signature))) + (save-excursion + (goto-char min-pos) + (let ((col (current-column))) + (insert sig "\n") + (indent-to col))))) + +(defun hs-utils/echo-or-present (msg &optional name) + "Present message in some manner depending on configuration. +If variable `haskell-process-use-presentation-mode' is NIL it will output +modified message MSG to echo area. +Optinal NAME will be used as presentation mode buffer name." + (if haskell-process-use-presentation-mode + (let ((bufname (or name "*Haskell Presentation*")) + (session (haskell-process-session (haskell-interactive-process)))) + (haskell-present bufname session msg)) + (let (m (hs-utils/reduce-string msg)) + (message m)))) (provide 'haskell-commands) From 789f2a1df923ee6bc6240fbcf9b993a04c14ca84 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=D0=90=D1=80=D1=82=D1=83=D1=80=20=D0=A4=D0=B0=D0=B8=CC=86?= =?UTF-8?q?=D0=B7=D1=80=D0=B0=D1=85=D0=BC=D0=B0=D0=BD=D0=BE=D0=B2?= Date: Sat, 9 May 2015 22:03:14 +0500 Subject: [PATCH 2/4] Watch changes using special flag Defined buffer local flag `hs-utils/async-post-command-flag` Defined flag related functions: + hs-utils/async-update-post-command-flag + hs-utils/async-watch-changes + hs-utils/async-stop-watching-changes --- haskell-commands.el | 35 +++++++++++++++++++++++++++++++++++ 1 file changed, 35 insertions(+) diff --git a/haskell-commands.el b/haskell-commands.el index 534de5596..402a1c240 100644 --- a/haskell-commands.el +++ b/haskell-commands.el @@ -614,6 +614,10 @@ command from GHCi." (string-match "^" response)) (haskell-mode-message-line response))))))) +(defvar hs-utils/async-post-command-flag nil + "Non-nil means some commands were triggered during async function execution.") +(make-variable-buffer-local 'hs-utils/async-post-command-flag) + ;;;###autoload (defun haskell-mode-show-type-at (&optional insert-value) "Show the type of the thing at point." @@ -921,4 +925,35 @@ Optinal NAME will be used as presentation mode buffer name." (haskell-present bufname session msg)) (let (m (hs-utils/reduce-string msg)) (message m)))) + +(defun hs-utils/async-update-post-command-flag () + "A special hook which collects triggered commands during async execution. +This hook pushes value of variable `this-command' to flag variable +`hs-utils/async-post-command-flag'." + (let* ((cmd this-command) + (updated-flag (cons cmd hs-utils/async-post-command-flag))) + (setq hs-utils/async-post-command-flag updated-flag))) + +(defun hs-utils/async-watch-changes () + "Watch for triggered commands during async operation execution. +Resets flag variable +`hs-utils/async-update-post-command-flag' to NIL. By chanhges it is +assumed that nothing happened, e.g. nothing was inserted in +buffer, point was not moved, etc. To collect data `post-command-hook' is used." + (setq hs-utils/async-post-command-flag nil) + (add-hook + 'post-command-hook #'hs-utils/async-update-post-command-flag nil t)) + +(defun hs-utils/async-stop-watching-changes (buffer) + "Clean up after async operation finished. +This function takes care about cleaning up things made by +`hs-utils/async-watch-changes'. The BUFFER argument is a buffer where +`post-command-hook' should be disabled. This is neccessary, because +it is possible that user will change buffer during async function +execusion." + (with-current-buffer buffer + (setq hs-utils/async-post-command-flag nil) + (remove-hook + 'post-command-hook #'hs-utils/async-update-post-command-flag t))) + (provide 'haskell-commands) From 2ba1d10950f7cdd33ae75a074d460c6b4493da3e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=D0=90=D1=80=D1=82=D1=83=D1=80=20=D0=A4=D0=B0=D0=B8=CC=86?= =?UTF-8?q?=D0=B7=D1=80=D0=B0=D1=85=D0=BC=D0=B0=D0=BD=D0=BE=D0=B2?= Date: Sat, 9 May 2015 22:05:22 +0500 Subject: [PATCH 3/4] Rewrite core functionality of `haskell-mode-show-type-at` Make function asyncronous, remove unnecessary synchronous `haskell-mode-type-at` function. Insert type signature only if nothing changed and there was valid response. Present result in case of presentation mode, otherwise put it in echo area. Do not present result if asked to insert result. --- haskell-commands.el | 120 +++++++++++++++++++++++--------------------- 1 file changed, 64 insertions(+), 56 deletions(-) diff --git a/haskell-commands.el b/haskell-commands.el index 402a1c240..177f3bece 100644 --- a/haskell-commands.el +++ b/haskell-commands.el @@ -495,36 +495,6 @@ GHCi." (error (propertize "No reply. Is :loc-at supported?" 'face 'compilation-error))))))) -(defun haskell-mode-type-at () - "Get the type of the thing at point. Requires the :type-at -command from GHCi." - (let ((pos (or (when (region-active-p) - (cons (region-beginning) - (region-end))) - (haskell-spanable-pos-at-point) - (cons (point) - (point))))) - (when pos - (replace-regexp-in-string - "\n$" - "" - (save-excursion - (haskell-process-queue-sync-request - (haskell-interactive-process) - (replace-regexp-in-string - "\n" - " " - (format ":type-at %s %d %d %d %d %s" - (buffer-file-name) - (progn (goto-char (car pos)) - (line-number-at-pos)) - (1+ (current-column)) - (progn (goto-char (cdr pos)) - (line-number-at-pos)) - (1+ (current-column)) - (buffer-substring-no-properties (car pos) - (cdr pos)))))))))) - ;;;###autoload (defun haskell-process-cd (&optional not-interactive) "Change directory." @@ -620,33 +590,71 @@ command from GHCi." ;;;###autoload (defun haskell-mode-show-type-at (&optional insert-value) - "Show the type of the thing at point." + "Show type of the thing at point or within active region asynchronously. +Optional argument INSERT-VALUE indicates that recieved type signature should be +inserted (but only if nothing happened since function invocation). +This function requires GHCi-ng (see +https://github.com/chrisdone/ghci-ng#using-with-haskell-mode for instructions)." (interactive "P") - (let ((ty (haskell-mode-type-at)) - (orig (point))) - (unless (= (aref ty 0) ?\n) - ;; That seems to be what happens when `haskell-mode-type-at` fails - (if insert-value - (let ((ident-pos (or (haskell-ident-pos-at-point) - (cons (point) (point))))) - (cond - ((region-active-p) - (delete-region (region-beginning) - (region-end)) - (insert "(" ty ")") - (goto-char (1+ orig))) - ((= (line-beginning-position) (car ident-pos)) - (goto-char (line-beginning-position)) - (insert (haskell-fontify-as-mode ty 'haskell-mode) - "\n")) - (t - (save-excursion - (goto-char (car ident-pos)) - (let ((col (current-column))) - (save-excursion (insert "\n") - (indent-to col)) - (insert (haskell-fontify-as-mode ty 'haskell-mode))))))) - (message "%s" (haskell-fontify-as-mode ty 'haskell-mode)))))) + (let* ((pos (hs-utils/capture-expr-bounds)) + (req (hs-utils/compose-type-at-command pos)) + (process (haskell-interactive-process)) + (buf (current-buffer)) + (pos-reg (cons pos (region-active-p)))) + (haskell-process-queue-command + process + (make-haskell-command + :state (list process req buf insert-value pos-reg) + :go + (lambda (state) + (let* ((prc (car state)) + (req (nth 1 state))) + (hs-utils/async-watch-changes) + (haskell-process-send-string prc req))) + :complete + (lambda (state response) + (let* ((init-buffer (nth 2 state)) + (insert-value (nth 3 state)) + (pos-reg (nth 4 state)) + (wrap (cdr pos-reg)) + (min-pos (caar pos-reg)) + (max-pos (cdar pos-reg)) + (sig (hs-utils/reduce-string response)) + (split (split-string sig "\\W::\\W" t)) + (is-error (not (= (length split) 2)))) + + (if is-error + ;; neither popup presentation buffer + ;; nor insert response in error case + (message "Wrong REPL response: %s" sig) + (if insert-value + ;; Only insert type signature and do not present it + (if (= (length hs-utils/async-post-command-flag) 1) + (if wrap + ;; Handle region case + (progn + (deactivate-mark) + (save-excursion + (delete-region min-pos max-pos) + (goto-char min-pos) + (insert (concat "(" sig ")")))) + ;; Non-region cases + (hs-utils/insert-type-signature sig)) + ;; Some commands registered, prevent insertion + (let* ((rev (reverse hs-utils/async-post-command-flag)) + (cs (format "%s" (cdr rev)))) + (message + (concat + "Type signature insertion was prevented. " + "These commands were registered:" + cs)))) + ;; Present the result only when response is valid and not asked to + ;; insert result + (let* ((expr (car split)) + (buf-name (concat ":type " expr))) + (hs-utils/echo-or-present response buf-name)))) + + (hs-utils/async-stop-watching-changes init-buffer))))))) ;;;###autoload (defun haskell-process-generate-tags (&optional and-then-find-this-tag) From 0034b0a66d34f2bcb356e8cbcfcefebffe23b22e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=D0=90=D1=80=D1=82=D1=83=D1=80=20=D0=A4=D0=B0=D0=B8=CC=86?= =?UTF-8?q?=D0=B7=D1=80=D0=B0=D1=85=D0=BC=D0=B0=D0=BD=D0=BE=D0=B2?= Date: Sat, 9 May 2015 22:08:33 +0500 Subject: [PATCH 4/4] Fix commentary and footer warnings --- haskell-commands.el | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/haskell-commands.el b/haskell-commands.el index 177f3bece..0682c8ace 100644 --- a/haskell-commands.el +++ b/haskell-commands.el @@ -1,5 +1,11 @@ ;;; haskell-commands.el --- Commands that can be run on the process +;;; Commentary: + +;;; This module provides varoius `haskell-mode' and `haskell-interactive-mode' +;;; specific commands such as show type signature, show info, haskell process +;;; commands and etc. + ;; Copyright (c) 2014 Chris Done. All rights reserved. ;; This file is free software; you can redistribute it and/or modify @@ -965,3 +971,4 @@ execusion." 'post-command-hook #'hs-utils/async-update-post-command-flag t))) (provide 'haskell-commands) +;;; haskell-commands.el ends here