HaRe 0.7.0.0 → 0.7.0.1
raw patch · 6 files changed
+216/−45 lines, 6 files
Files
- HaRe.cabal +1/−1
- elisp/hare.el +16/−14
- elisp/read-char-spec.el +175/−0
- src/Language/Haskell/Refact/Case.hs +0/−1
- src/Language/Haskell/Refact/Utils/TokenUtilsTypes.hs +9/−1
- src/Language/Haskell/Refact/Utils/TypeUtils.hs +15/−28
HaRe.cabal view
@@ -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
elisp/hare.el view
@@ -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))) ;; )--
+ elisp/read-char-spec.el view
@@ -0,0 +1,175 @@+;;; read-char-spec.el --- Generalized `y-or-n-p'.++;; Copyright (C) 2009 Edward O'Connor++;; Author: Edward O'Connor <hober0@gmail.com>+;; 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
src/Language/Haskell/Refact/Case.hs view
@@ -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
src/Language/Haskell/Refact/Utils/TokenUtilsTypes.hs view
@@ -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++ -}
src/Language/Haskell/Refact/Utils/TypeUtils.hs view
@@ -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'))