diff --git a/HaRe.cabal b/HaRe.cabal --- a/HaRe.cabal +++ b/HaRe.cabal @@ -1,5 +1,5 @@ Name: HaRe -Version: 0.7.0.0 +Version: 0.7.0.1 Author: Chris Brown, Huiqing Li, Simon Thompson, Alan Zimmerman Maintainer: Alan Zimmerman Stability: Alpha diff --git a/elisp/hare.el b/elisp/hare.el --- a/elisp/hare.el +++ b/elisp/hare.el @@ -21,7 +21,7 @@ ;; (require 'vc) ;; (require 'erlang) ;; (require 'distel) -;; (require 'read-char-spec) +(require 'read-char-spec) (if (eq (substring emacs-version 0 4) "22.2") (require 'ediff-init1) @@ -119,6 +119,10 @@ (hare-init-menu) ) +(defconst erlang-xemacs-p (string-match "Lucid\\|XEmacs" emacs-version) + "Non-nil when running under XEmacs or Lucid Emacs.") + + (defun hare-menu-remove() (interactive) ;; code to remove the whole menu panel @@ -768,17 +772,17 @@ (load hare_ext) nil) -(defun hare-menu-remove() - "Remove HaRe menus." - (interactive) - (define-key erlang-mode-map "\C-c\C-w\C-_" nil) - (define-key erlang-mode-map "\C-c\C-w\C-b" nil) - (define-key erlang-mode-map "\C-c\C-w\C-e" nil) - (cond (erlang-xemacs-p - (erlang-menu-uninstall '("HaRe") wrangler-menu-items erlang-mode-map t)) - (t - (erlang-menu-uninstall "HaRe" wrangler-menu-items erlang-mode-map t)) - )) +;; (defun hare-menu-remove() +;; "Remove HaRe menus." +;; (interactive) +;; (define-key erlang-mode-map "\C-c\C-w\C-_" nil) +;; (define-key erlang-mode-map "\C-c\C-w\C-b" nil) +;; (define-key erlang-mode-map "\C-c\C-w\C-e" nil) +;; (cond (erlang-xemacs-p +;; (erlang-menu-uninstall '("HaRe") wrangler-menu-items erlang-mode-map t)) +;; (t +;; (erlang-menu-uninstall "HaRe" wrangler-menu-items erlang-mode-map t)) +;; )) (defun erlang-menu-uninstall (name items keymap &optional popup) "UnInstall a menu in Emacs or XEmacs based on an abstract description." @@ -1412,8 +1416,6 @@ ;; nil)) ;; (setq args (cdr args))) ;; ) - - diff --git a/elisp/read-char-spec.el b/elisp/read-char-spec.el new file mode 100644 --- /dev/null +++ b/elisp/read-char-spec.el @@ -0,0 +1,175 @@ +;;; read-char-spec.el --- Generalized `y-or-n-p'. + +;; Copyright (C) 2009 Edward O'Connor + +;; Author: Edward O'Connor +;; Keywords: convenience + +;; This file is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by the +;; Free Software Foundation; either version 3, or (at your option) any +;; later version. + +;; This file is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, +;; MA 02110-1301, USA. + +;;; Commentary: + +;; Provides a generalization of the `y-or-n-p' UI for when you have +;; other possible answers. `read-char-spec' is to `read-char' as +;; `format-spec' is to `format'. Here's how you would re-implement +;; `y-or-n-p' with `read-char-spec': +;; +;; (defun example-y-or-n-p (prompt) +;; "Copy of `y-or-n-p', as an example use of `read-char-spec'. +;; PROMPT is as for `y-or-n-p'." +;; (read-char-spec prompt '((?y t "Answer in the affirmative") +;; (?n nil "Answer in the negative")))) +;; +;; Compared to using `interactive's "c" spec, I think the programmatic +;; interface for `read-char-spec' is simpler, it keeps prompting until +;; you really type one of the characters in the spec, and it provides +;; for interactive help for the user (by typing "?"). + +;;; History: +;; 20009-06-17: Initial version, inspired by a conversation with ngirard +;; in #emacs. + +;;; Code: + +(defun read-char-spec (prompt specification + &optional inherit-input-method seconds) + "Ask the user a question with multiple possible answers. +No confirmation of the answer is requested; a single character is +enough. + +PROMPT is the string to display to ask the question. It should end in a +space; `read-char-spec' adds help text to the end of it. + +SPECIFICATION is a list of key specs, each of the form (KEY VALUE +HELP-TEXT). + +Arguments INHERIT-INPUT-METHOD and SECONDS are as in `read-char', which +see." + (let* ((spec-with-help + (append (list (list ?? read-char-spec-help-cmd + "Get help")) + specification)) + (keys (mapconcat (lambda (cell) + (read-char-spec-format-key (car cell))) + specification + ", ")) + (prompt-with-keys (format "%s (%s, or ? for help) " + prompt keys)) + char-read + (current read-char-spec-not-found)) + ;; Loop until the user types a char actually in `specification' + (while (eq current read-char-spec-not-found) + (if (fboundp 'next-command-event) ; XEmacs + (setq event (next-command-event nil prompt-with-keys) + char-read (and (fboundp 'event-to-character) + (event-to-character event))) + (setq char-read (string-to-char (read-string prompt-with-keys)))) + (let ((entry (assoc char-read spec-with-help))) + (when entry + (setq current (cadr entry)))) + + ;; Provide help when requested + (when (eq current read-char-spec-help-cmd) + (read-char-spec-generate-help prompt specification) + (setq current read-char-spec-not-found)) + + (setq prompt-with-keys + (format "Please answer %s. %s (%s, or ? for help) " + keys prompt keys))) + + current)) + + +(defun read-char-spec-1 (prompt specification + &optional inherit-input-method seconds) + "Ask the user a question with multiple possible answers. +No confirmation of the answer is requested; a single character is +enough. + +PROMPT is the string to display to ask the question. It should end in a +space; `read-char-spec' adds help text to the end of it. + +SPECIFICATION is a list of key specs, each of the form (KEY VALUE +HELP-TEXT). + +Arguments INHERIT-INPUT-METHOD and SECONDS are as in `read-char', which +see." + (let* ((spec-with-help + (append (list (list ?? read-char-spec-help-cmd + "Get help")) + specification)) + (keys (mapconcat (lambda (cell) + (read-char-spec-format-key (car cell))) + specification + ", ")) + (prompt-with-keys (format "%s (%s, or ? for help) " + prompt keys)) + char-read + (current read-char-spec-not-found)) + ;; Loop until the user types a char actually in `specification' + (while (eq current read-char-spec-not-found) + (if (fboundp 'next-command-event) ; XEmacs + (setq event (next-command-event nil prompt-with-keys) + char-read (and (fboundp 'event-to-character) + (event-to-character event))) + (setq char-read (read-event prompt-with-keys))) + (let ((entry (assoc char-read spec-with-help))) + (when entry + (setq current (cadr entry)))) + + ;; Provide help when requested + (when (eq current read-char-spec-help-cmd) + (read-char-spec-generate-help prompt specification) + (setq current read-char-spec-not-found)) + + (setq prompt-with-keys + (format "Please answer %s. %s (%s, or ? for help) " + keys prompt keys))) + + current)) + +;;; There be dragons here + +(defconst read-char-spec-not-found + (make-symbol "read-char-spec-not-found") + "Dummy value for when user types character not in the spec provided.") +(defconst read-char-spec-help-cmd + (make-symbol "read-char-spec-help-cmd") + "Dummy value for when user types `?' to produce help.") + +(autoload 'edmacro-format-keys "edmacro") +(autoload 'comment-string-strip "newcomment") + +(defun read-char-spec-format-key (key) + "Format KEY like input for the `kbd' macro." + (edmacro-format-keys (vector key))) + +(defun read-char-spec-generate-help (prompt specification) + "Generate help text for PROMPT, based on SPECIFICATION." + (with-output-to-temp-buffer (help-buffer) + (help-setup-xref (list #'read-char-spec) nil) + (princ (format "Help for \"%s\":\n\n" + (comment-string-strip prompt t t))) + (princ (mapconcat (lambda (cell) + (format "%s - %s" + (read-char-spec-format-key + (car cell)) + (caddr cell))) + specification "\n")) + (print-help-return-message))) + +(provide 'read-char-spec) +;;; read-char-spec.el ends here diff --git a/src/Language/Haskell/Refact/Case.hs b/src/Language/Haskell/Refact/Case.hs --- a/src/Language/Haskell/Refact/Case.hs +++ b/src/Language/Haskell/Refact/Case.hs @@ -7,7 +7,6 @@ import qualified GHC import Language.Haskell.GhcMod --- import Language.Haskell.GhcMod.Internal import Language.Haskell.Refact.Utils import Language.Haskell.Refact.Utils.GhcUtils import Language.Haskell.Refact.Utils.LocUtils diff --git a/src/Language/Haskell/Refact/Utils/TokenUtilsTypes.hs b/src/Language/Haskell/Refact/Utils/TokenUtilsTypes.hs --- a/src/Language/Haskell/Refact/Utils/TokenUtilsTypes.hs +++ b/src/Language/Haskell/Refact/Utils/TokenUtilsTypes.hs @@ -38,13 +38,21 @@ SrcSpans are nested in one another according to the structure of the AST. -Store it in some kind of tree structure, memoised. +Store it in some kind of tree structure. Invariants: 1. For each tree, either the rootLabel has a SrcSpan only, or the subForest /= []. 2. The trees making up the subForest of a given node fully include the parent SrcSpan. i.e. the leaves contain all the tokens for a given SrcSpan. 3. A given SrcSpan can only appear (or be included) in a single tree of the forest. + +There are conflicting requirements for access to the tokens. On the +one hand the tokens need to be moved around (mainly in columns) to +support changing layout as e.g. a token is renamed. On the other, the +originals need to be preserved, so they can tie up with the positions +in the SrcSpans and for renaming. + +Question: is the latter statement valid? ++AZ++ -} diff --git a/src/Language/Haskell/Refact/Utils/TypeUtils.hs b/src/Language/Haskell/Refact/Utils/TypeUtils.hs --- a/src/Language/Haskell/Refact/Utils/TypeUtils.hs +++ b/src/Language/Haskell/Refact/Utils/TypeUtils.hs @@ -3757,24 +3757,12 @@ e' <- renamePNworker oldPN newName updateTokens useQual e return (g,i',e',d) - -- TODO: no need to do the subelements, just rename the whole group renameGroup :: (GHC.HsGroup GHC.Name) -> RefactGhc (GHC.HsGroup GHC.Name) - renameGroup (GHC.HsGroup vals typs inst deriv fixs def for war ann rule vect doc) + renameGroup g = do logm $ "renamePN:renameGroup" - vals' <- renamePNworker oldPN newName updateTokens useQual vals - typs' <- renamePNworker oldPN newName updateTokens useQual typs - inst' <- renamePNworker oldPN newName updateTokens useQual inst - deriv' <- renamePNworker oldPN newName updateTokens useQual deriv - fixs' <- renamePNworker oldPN newName updateTokens useQual fixs - def' <- renamePNworker oldPN newName updateTokens useQual def - for' <- renamePNworker oldPN newName updateTokens useQual for - war' <- renamePNworker oldPN newName updateTokens useQual war - ann' <- renamePNworker oldPN newName updateTokens useQual ann - rule' <- renamePNworker oldPN newName updateTokens useQual rule - vect' <- renamePNworker oldPN newName updateTokens useQual vect - doc' <- renamePNworker oldPN newName updateTokens useQual doc - return (GHC.HsGroup vals' typs' inst' deriv' fixs' def' for' war' ann' rule' vect' doc') + g' <- renamePNworker oldPN newName updateTokens useQual g + return g' renameGroup x = return x -- --------------------------------------------------------------------- @@ -3794,7 +3782,7 @@ ->t -- ^ The syntax phrase ->RefactGhc t renamePNworker oldPN newName updateTokens useQual t = do - -- logm $ "renamePNworker: (oldPN,newName)=" ++ (showGhc (oldPN,newName)) + -- logm $ "renamePN: (oldPN,newName)=" ++ (showGhc (oldPN,newName)) -- Note: bottom-up traversal (no ' at end) everywhereMStaged SYB.Renamer (SYB.mkM rename -- everywhereMStaged' SYB.Renamer (SYB.mkM rename @@ -3810,7 +3798,7 @@ rename (GHC.L l n) | (GHC.nameUnique n == GHC.nameUnique oldPN) = do - logm $ "renamePN:rename at :" ++ (show l) ++ (showSrcSpanF l) + logm $ "renamePNworker:rename at :" ++ (show l) ++ (showSrcSpanF l) worker useQual l n return (GHC.L l newName) rename x = return x @@ -3819,7 +3807,7 @@ renameVar (GHC.L l (GHC.HsVar n)) | (GHC.nameUnique n == GHC.nameUnique oldPN) = do - -- logm $ "renamePN:renameVar at :" ++ (show (row,col)) + -- logm $ "renamePNworker:renameVar at :" ++ (show (row,col)) worker useQual l n return (GHC.L l (GHC.HsVar newName)) renameVar x = return x @@ -3829,7 +3817,7 @@ renameTyVar (GHC.L l (GHC.HsTyVar n)) | (GHC.nameUnique n == GHC.nameUnique oldPN) = do - -- logm $ "renamePN:renameTyVar at :" ++ (show (row,col)) + -- logm $ "renamePNworker:renameTyVar at :" ++ (show (row,col)) worker useQual l n return (GHC.L l (GHC.HsTyVar newName)) renameTyVar x = return x @@ -3843,7 +3831,7 @@ #endif | (GHC.nameUnique n == GHC.nameUnique oldPN) = do - -- logm $ "renamePN:renameHsTyVarBndr at :" ++ (show (row,col)) + -- logm $ "renamePNworker:renameHsTyVarBndr at :" ++ (show (row,col)) worker useQual l n #if __GLASGOW_HASKELL__ > 704 return (GHC.L l (GHC.UserTyVar newName)) @@ -3852,12 +3840,11 @@ #endif renameHsTyVarBndr x = return x - renameLIE :: (GHC.LIE GHC.Name) -> RefactGhc (GHC.LIE GHC.Name) renameLIE (GHC.L l (GHC.IEVar n)) | (GHC.nameUnique n == GHC.nameUnique oldPN) = do - -- logm $ "renamePN:renameLIE at :" ++ (show (row,col)) + -- logm $ "renamePNworker:renameLIE at :" ++ (show (row,col)) worker useQual l n return (GHC.L l (GHC.IEVar newName)) renameLIE x = return x @@ -3866,7 +3853,7 @@ renameLPat (GHC.L l (GHC.VarPat n)) | (GHC.nameUnique n == GHC.nameUnique oldPN) = do - -- logm $ "renamePN:renameLPat at :" ++ (show (row,col)) + -- logm $ "renamePNworker:renameLPat at :" ++ (show (row,col)) worker False l n return (GHC.L l (GHC.VarPat newName)) renameLPat x = return x @@ -3882,10 +3869,10 @@ -- logm $ "renamePNWorker.renameFunBind" worker False l n -- Now do (b) - -- logm $ "renamePNworker.renameFunBind:starting matches" + -- logm $ "renamePNWorker.renameFunBind.renameFunBind:starting matches" let w (GHC.L lm _match) = worker False lm n mapM w $ tail matches - -- logm $ "renamePNworker.renameFunBind:matches done" + -- logm $ "renamePNWorker.renameFunBind.renameFunBind.renameFunBind:matches done" return (GHC.L l (GHC.FunBind (GHC.L ln newName) fi (GHC.MatchGroup matches typ) co fvs tick)) renameFunBind x = return x @@ -3893,10 +3880,10 @@ renameTypeSig (GHC.L l (GHC.TypeSig ns typ)) = do -- logm $ "renamePNWorker:renameTypeSig" - _ns' <- renamePNworker oldPN newName updateTokens False ns + _ns' <- renamePN oldPN newName updateTokens False ns -- Has already been renamed, make sure qualifier is removed - ns' <- renamePNworker newName newName updateTokens False ns - typ' <- renamePNworker oldPN newName updateTokens False typ + ns' <- renamePN newName newName updateTokens False ns + typ' <- renamePN oldPN newName updateTokens False typ -- logm $ "renamePNWorker:renameTypeSig done" return (GHC.L l (GHC.TypeSig ns' typ'))