diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,6 @@ +2016-08-03 v0.8.3.0 + * Update for GHC 8.0.1 + * Use ghc-mod version to 5.6 now it is released 2016-01-20 v0.8.2.3 * Use ghc-mod version to 5.5 now it is released * Expose commands working in RefactGhc, so the ghc-mod session can diff --git a/HaRe.cabal b/HaRe.cabal --- a/HaRe.cabal +++ b/HaRe.cabal @@ -1,7 +1,7 @@ Name: HaRe -Version: 0.8.2.3 +Version: 0.8.3.0 Author: Chris Brown, Huiqing Li, Simon Thompson, Alan Zimmerman -Maintainer: Alan Zimmerman +Maintainer: Alan Zimmerman (alan.zimm@gmail.com) Stability: Alpha Bug-Reports: http://github.com/RefactoringTools/HaRe/issues License: BSD3 @@ -17,8 +17,10 @@ . From version 0.8.0.0, GHC 7.10.2 is supported. . - It is tested against GHC 7.10.2 (via travis-ci.org) + From version 0.8.3.0, GHC 8.0.1 is supported. . + It is tested against GHC 7.10.3 and GHC 8.0.1 (via travis-ci.org) + . It currently only has emacs integration built in, community input welcome for others. . @@ -40,12 +42,14 @@ Cabal-Version: >= 1.8 Build-Type: Simple -tested-with: GHC == 7.10.2, GHC == 7.10.3 +tested-with: GHC == 7.10.3, GHC == 8.0.1 data-files: elisp/*.el configure.sh test/testdata/*.cabal test/testdata/*.hs + test/testdata/AddOneParameter/*.hs + test/testdata/AddOneParameter/*.expected.hs test/testdata/Case/*.hs test/testdata/Case/*.hs.expected test/testdata/Case/*.hs.expected.dd @@ -72,6 +76,8 @@ test/testdata/Renaming/*.expected.hs test/testdata/Renaming/*.hs test/testdata/Renaming/*.hs.expected + test/testdata/RmOneParameter/*.expected.hs + test/testdata/RmOneParameter/*.hs test/testdata/Simple/*.hs test/testdata/Simple/*.hs.expected test/testdata/SwapArgs/*.hs @@ -108,7 +114,7 @@ Library -- GHC 7.10.2 ships with base 4.8.1.0 - Build-Depends: base >= 4.8.1.0 && < 4.9 + Build-Depends: base >= 4.8.1.0 && < 5 , containers , directory @@ -121,7 +127,7 @@ , ghc-paths , ghc-prim , ghc-syb-utils - , ghc-mod >= 5.5.0.0 + , ghc-mod >= 5.6.0.0 , mtl , old-time , pretty @@ -133,7 +139,7 @@ , time , Strafunski-StrategyLib , syz - , ghc-exactprint >= 0.5.0.1 + , ghc-exactprint >= 0.5.2.1 , monad-control , Cabal >= 1.22 @@ -151,7 +157,6 @@ , Language.Haskell.Refact.Refactoring.RoundTrip , Language.Haskell.Refact.Refactoring.Simple , Language.Haskell.Refact.Refactoring.SwapArgs - , Language.Haskell.Refact.Utils.Binds , Language.Haskell.Refact.Utils.ExactPrint , Language.Haskell.Refact.Utils.GhcBugWorkArounds , Language.Haskell.Refact.Utils.GhcModuleGraph @@ -179,7 +184,7 @@ ./src -- GHC 7.10.2 ships with base 4.8.1.0 - Build-Depends: base >= 4.8.1.0 && < 4.9 + Build-Depends: base >= 4.8.1.0 && < 5 , array , containers , directory @@ -193,8 +198,11 @@ , ghc-paths , ghc-prim , ghc-syb-utils - , ghc-mod >= 5.5.0.0 + , gitrev >= 1.1 + , ghc-mod >= 5.6.0.0 , mtl + , optparse-applicative + , optparse-simple , old-time , parsec >= 3.1.6 , pretty @@ -206,7 +214,7 @@ , hslogger , Strafunski-StrategyLib , syz - , ghc-exactprint >= 0.5.0.1 + , ghc-exactprint >= 0.5.2.1 , monad-control , Cabal >= 1.22 -- , Paths_HaRe @@ -233,7 +241,8 @@ src test other-modules: - CaseSpec + AddRmParamSpec + , CaseSpec , DupDefSpec , GhcUtilsSpec , LocUtilsSpec @@ -252,7 +261,6 @@ -- , Language.Haskell.Refact.Refactoring.AddRmParam -- , Language.Haskell.Refact.Refactoring.Case -- , Language.Haskell.Refact.Refactoring.RoundTrip - -- , Language.Haskell.Refact.Utils.Binds -- , Language.Haskell.Refact.Utils.ExactPrint -- , Language.Haskell.Refact.Utils.GhcModuleGraph -- , Language.Haskell.Refact.Utils.GhcUtils @@ -268,7 +276,7 @@ -- , Paths_HaRe build-depends: -- GHC 7.10.2 ships with base 4.8.1.0 - base >= 4.8.1.0 && < 4.9 + base >= 4.8.1.0 && < 5 , Diff >= 0.3.0 , HUnit , QuickCheck >= 2.5 @@ -285,7 +293,7 @@ , ghc-paths , ghc-prim , ghc-syb-utils - , ghc-mod >= 5.5.0.0 + , ghc-mod >= 5.6.0.0 , hspec , mtl , old-time @@ -300,7 +308,7 @@ , hslogger , Strafunski-StrategyLib , syz - , ghc-exactprint >= 0.5.0.1 + , ghc-exactprint >= 0.5.2.1 , monad-control , Cabal >= 1.22 -- , Paths_HaRe diff --git a/elisp/hare.el b/elisp/hare.el --- a/elisp/hare.el +++ b/elisp/hare.el @@ -382,37 +382,37 @@ ;; )))))) (defun current-time-suffix() - "Generate a time stamp suffix in ISO 8601 format for backed up - files, including a leading '.'" - (format-time-string ".%Y-%m-%dT%T%z") + "Generate a time stamp suffix for backed up files, including a leading '.'" + (format-time-string ".%Y%m%d%H%M%S") ) (defun delete-swp-file-and-buffers (files) - "delete those .refactored file and buffers generated by the refactorer. NOTE:also renames the files" - (dolist (f files) - (let (old-file-name new-file-name swp-file-name) - (setq old-file-name (elt f 0)) - (setq new-file-name (elt f 1)) - (setq swp-file-name (elt f 2)) + "delete those .refactored file and buffers generated by the refactorer. NOTE:also renames the files" + (let ((suf (current-time-suffix))) + (dolist (f files) + (let (old-file-name new-file-name swp-file-name) + (setq old-file-name (elt f 0)) + (setq new-file-name (elt f 1)) + (setq swp-file-name (elt f 2)) - ;; At this stage there are no file renaming operations, so we - ;; simply need to replace old-file-name with swp-file-name - (rename-file old-file-name (concat old-file-name (current-time-suffix))) - (rename-file swp-file-name old-file-name) + ;; At this stage there are no file renaming operations, so we + ;; simply need to replace old-file-name with swp-file-name + (rename-file old-file-name (concat old-file-name suf)) + (rename-file swp-file-name old-file-name) - (let ((swp-buff (get-file-buffer-1 swp-file-name))) - (if swp-buff (kill-buffer swp-buff) - nil)) - ;(delete-file swp-file-name) - (let ((buffer (get-file-buffer-1 old-file-name))) - (if buffer - (if (equal old-file-name new-file-name) - (with-current-buffer buffer (revert-buffer nil t t)) - (with-current-buffer buffer - (set-visited-file-name new-file-name) - ;;(delete-file old-file-name) - (revert-buffer nil t t))) - nil))))) + (let ((swp-buff (get-file-buffer-1 swp-file-name))) + (if swp-buff (kill-buffer swp-buff) + nil)) + ;(delete-file swp-file-name) + (let ((buffer (get-file-buffer-1 old-file-name))) + (if buffer + (if (equal old-file-name new-file-name) + (with-current-buffer buffer (revert-buffer nil t t)) + (with-current-buffer buffer + (set-visited-file-name new-file-name) + ;;(delete-file old-file-name) + (revert-buffer nil t t))) + nil)))))) (defun abort-changes() "abort the refactoring results" diff --git a/src/Language/Haskell/Refact/API.hs b/src/Language/Haskell/Refact/API.hs --- a/src/Language/Haskell/Refact/API.hs +++ b/src/Language/Haskell/Refact/API.hs @@ -20,6 +20,8 @@ , logm , logDataWithAnns + , logExactprint + , logParsedSource -- * from `Language.Haskell.Refact.Utils.Utils` @@ -40,7 +42,9 @@ , clientModsAndFiles , serverModsAndFiles + , stripCallStack + -- * from `Language.Haskell.Refact.Utils.MonadFunctions` -- ** Conveniences for state access @@ -75,6 +79,9 @@ , setStateStorage , getStateStorage + -- * Parsing source + , parseDeclWithAnns + -- , logm @@ -104,45 +111,40 @@ , inScopeInfo, isInScopeAndUnqualified, isInScopeAndUnqualifiedGhc, inScopeNames , isExported, isExplicitlyExported, modIsExported , equivalentNameInNewMod + , hsQualifier -- *** Variable analysis , isFieldName , isClassName , isInstanceName - , hsPNs - , hsBinds - , HsValBinds(..) - ,isDeclaredIn,isDeclaredInRdr - ,FreeNames(..),DeclaredNames(..) - ,hsFreeAndDeclaredPNsOld, hsFreeAndDeclaredNameStrings - ,hsFreeAndDeclaredRdr - ,hsFreeAndDeclaredPNs - ,hsFreeAndDeclaredGhc - ,getDeclaredTypes - ,getFvs, getFreeVars, getDeclaredVars -- These two should replace hsFreeAndDeclaredPNs + , hsTypeVbls + , hsNamessRdr + , isDeclaredInRdr + , FreeNames(..),DeclaredNames(..) + , hsFreeAndDeclaredNameStrings + , hsFreeAndDeclaredRdr + , hsFreeAndDeclaredPNs + , getDeclaredVarsRdr - ,hsVisiblePNs, hsVisiblePNsRdr, hsVisibleNames - ,hsVisibleNamesRdr - ,hsFDsFromInsideRdr, hsFDNamesFromInsideRdr - ,hsFDsFromInside, hsFDNamesFromInside - ,hsVisibleDs - ,rdrName2Name, rdrName2NamePure + , hsVisibleNamesRdr + , hsFDsFromInsideRdr, hsFDNamesFromInsideRdr, hsFDNamesFromInsideRdrPure + , hsVisibleDsRdr + , rdrName2Name, rdrName2NamePure -- *** Property checking ,isVarId,isConId,isOperator,isTopLevelPN,isLocalPN,isNonLibraryName -- ,isTopLevelPNT ,isQualifiedPN, isFunOrPatName,isTypeSig ,isFunBindP,isFunBindR,isPatBindP,isPatBindR,isSimplePatBind,isSimplePatDecl ,isComplexPatBind,isComplexPatDecl,isFunOrPatBindP,isFunOrPatBindR - ,usedWithoutQualR,isUsedInRhs + ,usedWithoutQualR ,findNameInRdr - ,findPNT,findPN,findAllNameOccurences - ,findPNs, findNamesRdr, findEntity, findEntity' + ,findNamesRdr, findEntity, findEntity' ,sameOccurrence , findIdForName , getTypeForName - ,defines, definesP,definesTypeSig - ,sameBind,sameBindRdr - ,UsedByRhs(..) + , definesTypeSigRdr,definesSigDRdr + , sameBindRdr + , UsedByRhs(..) -- *** Modules and files , isMainModule @@ -150,34 +152,37 @@ -- *** Locations ,defineLoc, useLoc, locToExp - ,locToName, locToRdrName + ,findLRdrName + -- ,locToName + ,locToNameRdrPure + ,locToRdrName ,getName -- * Program transformation -- *** Adding ,addDecl, addItemsToImport, addItemsToExport, addHiding - ,addParamsToDecls, addActualParamsToRhs, addImportDecl, duplicateDecl -- , moveDecl + ,addParamsToDecls, addParamsToSigs, addActualParamsToRhs, addImportDecl, duplicateDecl + -- *** Removing ,rmDecl, rmTypeSig, rmTypeSigs -- *** Updating -- ,Update(update) - ,rmQualifier,qualifyToplevelName,renamePN,autoRenameLocalVar + ,rmQualifier,qualifyToplevelName,renamePN, HowToQual(..), autoRenameLocalVar -- *** Identifiers, expressions, patterns and declarations - ,ghcToPN,lghcToPN, expToName, expToNameRdr - ,patToNameRdr - ,nameToString - ,patToPNT ,pNtoPat - , definedPNs, definedPNsRdr,definedNamesRdr + , expToNameRdr + , patToNameRdr + , nameToString + , pNtoPat + , definedPNsRdr,definedNamesRdr , definingDeclsRdrNames, definingDeclsRdrNames', definingSigsRdrNames - , definingDeclsNames, definingDeclsNames', definingSigsNames , definingTyClDeclsNames - , allNames -- *** Others , divideDecls - , mkRdrName,mkNewGhcName,mkNewName,mkNewToplevelName + , mkRdrName,mkQualifiedRdrName,mkNewGhcName,mkNewName,mkNewToplevelName + , registerRdrName -- The following functions are not in the the API yet. , causeNameClashInExports @@ -187,18 +192,11 @@ -- ** Typed AST traversals (added by CMB) -- ** Miscellous - -- ** Debug stuff - , getParsedForRenamedLPat - , getParsedForRenamedName - , getParsedForRenamedLocated - , stripLeadingSpaces - -- ** from `Language.Haskell.Refact.Utils.GhcUtils` -- ** SYB versions , everywhereMStaged' , everywhereStaged , everywhereStaged' - , onelayerStaged , listifyStaged -- ** Scrap Your Zipper versions @@ -225,12 +223,15 @@ , NameMap -- * from `Language.Haskell.Refact.Utils.ExactPrint'` - , replace - , setRefactAnns + , replace + , setRefactAnns + , setAnnKeywordDP + , copyAnn + , clearPriorComments + , balanceAllComments ) where -import Language.Haskell.Refact.Utils.Binds import Language.Haskell.Refact.Utils.ExactPrint import Language.Haskell.Refact.Utils.GhcUtils import Language.Haskell.Refact.Utils.GhcVersionSpecific diff --git a/src/Language/Haskell/Refact/HaRe.hs b/src/Language/Haskell/Refact/HaRe.hs --- a/src/Language/Haskell/Refact/HaRe.hs +++ b/src/Language/Haskell/Refact/HaRe.hs @@ -11,24 +11,21 @@ , GM.defaultOptions -- * Refactorings - , ifToCase - , compIfToCase - , duplicateDef - , compDuplicateDef - , liftToTopLevel - , compLiftToTopLevel - , liftOneLevel - , compLiftOneLevel - , demote - , compDemote - , rename - , compRename + , ifToCase, compIfToCase + , duplicateDef, compDuplicateDef + , liftToTopLevel, compLiftToTopLevel + , liftOneLevel, compLiftOneLevel + , demote, compDemote + , rename, compRename + , addOneParameter, compAddOneParameter + , rmOneParameter, compRmOneParameter -- , swapArgs , roundTrip ) where +import Language.Haskell.Refact.Refactoring.AddRmParam import Language.Haskell.Refact.Refactoring.Case import Language.Haskell.Refact.Refactoring.DupDef import Language.Haskell.Refact.Refactoring.MoveDef diff --git a/src/Language/Haskell/Refact/Refactoring/AddRmParam.hs b/src/Language/Haskell/Refact/Refactoring/AddRmParam.hs --- a/src/Language/Haskell/Refact/Refactoring/AddRmParam.hs +++ b/src/Language/Haskell/Refact/Refactoring/AddRmParam.hs @@ -1,586 +1,855 @@ -{-# LANGUAGE ScopedTypeVariables #-} --- module Language.Haskell.Refact.Refactoring.AddRmParam(addOneParameter,rmOneParameter) where -module Language.Haskell.Refact.Refactoring.AddRmParam(addOneParameter) where - --- import PosSyntax --- import TypedIds --- import UniqueNames hiding (srcLoc) --- import PNT --- import TiPNT - -import qualified Data.Generics as SYB -import qualified GHC.SYB.Utils as SYB - -import qualified GHC -import qualified RdrName as GHC - -import qualified Language.Haskell.GhcMod as GM -import Language.Haskell.GhcMod.Internal as GM -import Language.Haskell.Refact.API - -import Language.Haskell.GHC.ExactPrint.Types -import Language.Haskell.GHC.ExactPrint.Transform - -import System.Directory -import Data.Maybe -import Data.List hiding (delete) --- import RefacUtils --- import Data.Char - -import Data.Generics.Strafunski.StrategyLib.StrategyLib - -import Control.Exception - ------------------------------------------------------------------------------------------------------ -{- An argument can be added to the definition of a function or constant. Adding an argument to a constant - definition will change the constant definition to a function definition. The new parameter is always - added as the first parameter of the function. A default parameter will be added as the first argument - to each of the function's call site. Suppose a new parameter named 'p' is added to function 'f', - then default parameter will be defined automatically as p_f_i=undefined, where 'i' is an integer. - To ensure that the default parameter name does not cause name clash in the client modules, we take the - visble names both in the current module and in the client modules into account when creating the - name. - --} ------------------------------------------------------------------------------------------------------ - -addOneParameter :: RefactSettings -> GM.Options -> FilePath -> String -> SimpPos -> IO [FilePath] -addOneParameter settings opts fileName paramName (row,col) = do - absFileName <- canonicalizePath fileName - runRefacSession settings opts (compAdd absFileName paramName (row,col)) - -compAdd :: FilePath -> String -> SimpPos -> RefactGhc [ApplyRefacResult] -compAdd fileName paramName (row, col) = do - if isVarId paramName - then - do - parseSourceFileGhc fileName - renamed <- getRefactRenamed - parsed <- getRefactParsed - targetModule <- getRefactTargetModule - logm $ "AddRmParam.compAdd:got targetModule" - let (Just (modName,_)) = getModuleName parsed - let maybePn = locToName (row, col) renamed - case maybePn of - Just pnt@(GHC.L _ pn) -> - do - logm $ "AddRmParam.compAdd:about to applyRefac for:pn=" ++ SYB.showData SYB.Parser 0 pn - -- make sure this name is defined in this module - if isFunOrPatName pn renamed - then do - exported <- isExported pn - if exported - then do - assert False undefined - else do - (refactoredMod,_) <- applyRefac (doAddingParam undefined modName pn paramName Nothing False) (RSFile fileName) - return [refactoredMod] - - else error "Invalid cursor position or identifier is not a function/pattern name defined in this module!\n" - Nothing -> error "Invalid cursor position or identifier is not a function/pattern name defined in this module!\n" - else error $ "Invalid parameter name:" ++ paramName ++ "!" - -{- -addOneParameter args - = let fileName = args!!0 - paramName= args!!1 - row = read (args!!2)::Int - col = read (args!!3)::Int - in if isVarId paramName - then do modName <-fileNameToModName fileName - (inscps, exps, mod, tokList)<-parseSourceFile fileName - let pnt@(PNT pn _ _)=locToPNT fileName (row, col) mod - --make sure this name is defined in this module - if pn /= defaultPN && isFunOrPatName pn mod - then if isExported pnt exps - then do clients <- clientModsAndFiles modName - info <- mapM parseSourceFile $ map snd clients - defaultArg <-mkTopLevelDefaultArgName pn paramName fileName modName - ( map (\(x, _,_,_)->x) (concatMap inScopeInfo (map myfst info))) (hsDecls mod) - (mod',((ts',m), _))<-doAddingParam fileName modName pn paramName - (Just defaultArg) True mod tokList - refactoredClients<-mapM (addArgInClientMod pnt defaultArg modName) $ zip info (map snd clients) - writeRefactoredFiles False $ ((fileName,m),(ts',mod')):refactoredClients - else do (mod',((ts',m),_))<-doAddingParam fileName modName pn paramName Nothing False mod tokList - writeRefactoredFiles False [((fileName,m),(ts',mod'))] - else error "Invalid cursor position or identifier is not a function/pattern name defined in this module!\n" - else error "Invalid parameter name!\n" --} - --- --------------------------------------------------------------------- - -doAddingParam :: FilePath -> GHC.ModuleName -> GHC.Name -> String -> Maybe String -> Bool - -> RefactGhc () -doAddingParam fileName modName pn newParam defaultArg isExported = do - assert False undefined - {- - parsed <- getRefactParsed - r <- applyTP (once_tdTP (failTP `adhocTP` inMod - -- `adhocTP` inMatch - -- `adhocTP` inPat - -- `adhocTP` inLet - -- `adhocTP` inAlt - -- `adhocTP` inLetStmt - ) - `choiceTP` failure) parsed - putRefactParsed r emptyAnns - return () - where - --1.pn is declared in top level - -- inMod (mod@(HsModule loc name exps imps ds):: HsModuleP) - -- | definingDecls [pn] ds False False/=[] - -- = do mod'<-doAdding mod ds - -- if isExported && isExplicitlyExported pn mod - -- then addItemsToExport mod' (Just pn) False (Left [pNtoName (fromJust defaultArg)]) - -- else return mod' - -- inMod _ = mzero - inMod (modu :: GHC.HsModule GHC.RdrName) = do - nm <- getRefactNameMap - if definingDeclsRdrNames nm [pn] modu /= [] - then - do - ds <- liftT $ hsDecls modu - modu' <- doAdding modu ds - if isExported && isExplicitlyExported pn modu - then addItemsToExport modu' (Just pn) False (Left [(fromJust defaultArg)]) - else return modu' - else return mzero - -{- - --2. pn is declared locally in the where clause of a match. - inMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP) - | definingDecls [pn] ds False False/=[] = doAdding match ds - inMatch _ = mzero - - --3. pn is declared locally in the where clause of a pattern binding. - inPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP) - | definingDecls [pn] ds False False/=[] = doAdding pat ds - inPat _ = mzero - - --4: pn is declared locally in a Let expression - inLet (letExp@(Exp (HsLet ds e))::HsExpP) - | definingDecls [pn] ds False False /=[] = doAdding letExp ds - inLet _ = mzero - - --5. pn is declared locally in a case alternative. - inAlt (alt@(HsAlt loc p rhs ds)::HsAltP) - | definingDecls [pn] ds False False/=[] = doAdding alt ds - inAlt _ = mzero - - --6.pn is declared locally in a let statement. - inLetStmt (letStmt@(HsLetStmt ds stmts):: HsStmtP) - | definingDecls [pn] ds False False/=[] = doAdding letStmt ds - inLetStmt _ = mzero --} - failure = idTP `adhocTP` mod - where modu (m::GHC.ParsedSource) = error "Refactoring failed" - - doAdding parent ds - = if paramNameOk pn newParam ds - then - do ds' <- addParamsToDecls ds pn [mkRdrName newParam] True --addFormalParam pn newParam ds - defaultParamPName <-if isNothing defaultArg - then mkLocalDefaultArgName pn newParam modName parent - else return (fromJust defaultArg) - parent' <- addDefaultActualArg False pn defaultParamPName (replaceDecls parent ds') - parent''<- addDefaultActualArgDecl defaultParamPName parent' pn isExported - ds'' <- addArgToSig pn (hsDecls parent'') - return (replaceDecls parent'' ds'') - else error " Refactoring failed." --} --- --------------------------------------------------------------------- -{- -doAddingParam fileName modName pn newParam defaultArg isExported mod tokList - = runStateT (applyTP (once_tdTP (failTP `adhocTP` inMod - `adhocTP` inMatch - `adhocTP` inPat - `adhocTP` inLet - `adhocTP` inAlt - `adhocTP` inLetStmt) - `choiceTP` failure) mod) ((tokList,unmodified),(-1000,0)) - where - --1.pn is declared in top level - inMod (mod@(HsModule loc name exps imps ds):: HsModuleP) - | definingDecls [pn] ds False False/=[] - = do mod'<-doAdding mod ds - if isExported && isExplicitlyExported pn mod - then addItemsToExport mod' (Just pn) False (Left [pNtoName (fromJust defaultArg)]) - else return mod' - - inMod _ = mzero - - --2. pn is declared locally in the where clause of a match. - inMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP) - | definingDecls [pn] ds False False/=[] = doAdding match ds - inMatch _ = mzero - - --3. pn is declared locally in the where clause of a pattern binding. - inPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP) - | definingDecls [pn] ds False False/=[] = doAdding pat ds - inPat _ = mzero - - --4: pn is declared locally in a Let expression - inLet (letExp@(Exp (HsLet ds e))::HsExpP) - | definingDecls [pn] ds False False /=[] = doAdding letExp ds - inLet _ = mzero - - --5. pn is declared locally in a case alternative. - inAlt (alt@(HsAlt loc p rhs ds)::HsAltP) - | definingDecls [pn] ds False False/=[] = doAdding alt ds - inAlt _ = mzero - - --6.pn is declared locally in a let statement. - inLetStmt (letStmt@(HsLetStmt ds stmts):: HsStmtP) - | definingDecls [pn] ds False False/=[] = doAdding letStmt ds - inLetStmt _ = mzero - - failure = idTP `adhocTP` mod - where mod (m::HsModuleP) = error "Refactoring failed" - - doAdding parent ds - = if paramNameOk pn newParam ds - then - do ds' <- addParamsToDecls ds pn [nameToPN newParam] True --addFormalParam pn newParam ds - defaultParamPName <-if isNothing defaultArg - then mkLocalDefaultArgName pn newParam modName parent - else return (fromJust defaultArg) - parent' <- addDefaultActualArg False pn defaultParamPName (replaceDecls parent ds') - parent''<- addDefaultActualArgDecl defaultParamPName parent' pn isExported - ds'' <- addArgToSig pn (hsDecls parent'') - return (replaceDecls parent'' ds'') - else error " Refactoring failed." --} - --- --------------------------------------------------------------------- - -paramNameOk = assert False undefined -{- - --- check whether the new parameter is a legal. - -paramNameOk pn newParam t = (fromMaybe True) (applyTU (once_tdTU (failTU `adhocTU` decl)) t) - where - decl ((Dec (HsFunBind _ matches@((HsMatch _ fun pats rhs ds):ms)))::HsDeclP) - | pNTtoPN fun == pn - = do results'<-mapM checkInMatch matches - Just (all (==True) results') - decl pat@(Dec (HsPatBind loc p rhs ds)) - | patToPN p == pn - = do (f,d) <- hsFDNamesFromInside pat - if elem newParam (f `union` d) - then error "The new parameter name will cause name clash or semantics change, please select another name!" - else Just True - decl (Dec (HsPatBind _ p _ _)) - | patToPN p /= pn && elem pn (hsPNs p) - = error "Parameter can not be added to complex pattern binding" - decl _=mzero - - checkInMatch match - = do (f,d) <- hsFDNamesFromInside match - if elem newParam (f `union` d) - then error "The new parameter name will cause name clash or semantics change, please choose another name!" - else return True --} --- --------------------------------------------------------------------- -addDefaultActualArgDecl = assert False undefined -{- ---add the default argument declaration right after the declaration defining pn -addDefaultActualArgDecl defaultParamPName parent pn isExported - =if not (findEntity pn parent) && not isExported - then return parent - else addDecl parent (Just pn) (defaultArgDecl,Nothing) True - where - defaultArgDecl= [Dec (HsPatBind loc0 (nameToPat (pNtoName defaultParamPName))(HsBody (nameToExp "undefined"))[])] - --} --- --------------------------------------------------------------------- - -mkLocalDefaultArgName = assert False undefined -{- ---suppose function name is f, parameter name is p, then the default argument name is like f_p. -mkLocalDefaultArgName fun paramName modName t - =do (f,d)<-hsFDNamesFromInside t - vs<-hsVisibleNames fun t - let name=mkNewName ((pNtoName fun)++"_"++paramName) (nub (f `union` d `union` vs)) 0 - return (PN (UnQual name) (S loc0)) - --} --- --------------------------------------------------------------------- -{- -mkTopLevelDefaultArgName fun paramName fileName modName inscopeNames t - =do (f,d)<-hsFDNamesFromInside t - let name=mkNewName ((pNtoName fun)++"_"++paramName) (nub (f `union` d `union` inscopeNames)) 0 - let loc = SrcLoc fileName 0 (-1000) (-1000) - return (PN (UnQual name) (G modName name (N (Just loc)))) - --} --- --------------------------------------------------------------------- -addDefaultActualArg = assert False undefined -{- - -addDefaultActualArg recursion pn argPName - = if recursion then applyTP (stop_tdTP (failTP `adhocTP` funApp)) - else applyTP (stop_tdTP (failTP `adhocTP` inDecl - `adhocTP` funApp)) - where - inDecl (fun@(Dec (HsFunBind _ ((HsMatch _ (PNT pname _ _) _ _ _):ms)))::HsDeclP) - | pn == pname - = return fun - - inDecl (pat@(Dec (HsPatBind loc1 ps rhs ds))::HsDeclP) - | pn == patToPN ps - = return pat - inDecl _ = mzero - - funApp (exp@(Exp (HsId (HsVar (PNT pname _ _))))::HsExpP) - |pname==pn - = update exp (Exp (HsParen (Exp (HsApp exp (pNtoExp argPName))))) exp - - funApp _ = mzero - --} --- --------------------------------------------------------------------- - -addArgToSig = assert False undefined -{- ---Add type arg to type siginature -addArgToSig pn decls - = let (before,after)=break (\d ->definesTypeSig pn d) decls - in if after==[] - then return decls - else do newSig<-addArgToSig' [(head after)] --no problem with head. - return (before++newSig++(tail after)) - - where - addArgToSig' sig@[(Dec (HsTypeSig loc is c tp))] - =do let tVar=mkNewTypeVarName sig - typeVar=newTypeVar tVar tp - let newSig=if length is==1 - then --the type sig only defines the type for pn - [Dec (HsTypeSig loc is c typeVar)] - else --otherwise, seperate it into two type signatures. - [Dec (HsTypeSig loc (filter (\x->pNTtoPN x/=pn) is) c tp), - Dec (HsTypeSig loc (filter (\x->pNTtoPN x==pn) is) c typeVar)] - update sig newSig sig - - --compose a type application using type expressions tv and tp - newTypeVar tVar tp - =(Typ (HsTyFun (Typ (HsTyVar (PNT (PN (UnQual tVar) (S loc0)) - (Type (TypeInfo {defType=Nothing, constructors=[], fields=[]})) (N (Just loc0))))) tp)) - - {- make a fresh type variable name. the new name is the first letter in the alphabet which is not - used in the type signature. -} - mkNewTypeVarName sig - =mkNewName "a" $ map pNtoName $ (snd.hsTypeVbls) sig - where mkNewName initName v - =if elem initName v - then mkNewName ((intToDigit (digitToInt(head initName)+1)):tail initName) v - else initName - -addArgInClientMod pnt defaultArg serverModName ((inscps, exps, mod,ts), fileName) - = let qual = hsQualifier pnt inscps - pn = pNTtoPN pnt - in if qual == [] - then return ((fileName,unmodified), (ts,mod)) - else do (mod',((ts',m), _))<- - runStateT (do mod'<-addItemsToImport serverModName (Just pn) (Left [pNtoName defaultArg]) mod - mod''<-addItemsToExport mod (Just pn) False (Left [pNtoName defaultArg]) - if isInScopeAndUnqualified (pNtoName pn) inscps - then addDefaultActualArgInClientMod pn (head qual) defaultArg False mod'' - else addDefaultActualArgInClientMod pn (head qual) defaultArg True mod'') - ((ts,unmodified), (-1000,0)) - return ((fileName,m),(ts',mod')) - - ---add default actual argument to pn in all the calling places. -addDefaultActualArgInClientMod pn qual argPName toBeQualified t - = applyTP (stop_tdTP (failTP `adhocTP` funApp)) t - where - funApp (exp@(Exp (HsId (HsVar pnt@(PNT pname _ _))))::HsExpP) - | pname == pn - = do vs <- hsVisibleNames pnt t - let argExp=if toBeQualified || elem (pNtoName argPName) vs - then pNtoExp (qualifyPName qual argPName) - else pNtoExp argPName - newExp =(Exp (HsParen (Exp (HsApp exp argExp)))) - update exp newExp exp - funApp _=mzero - -myfst (a,_,_,_) = a --------------------------------End of adding a parameter----------------------------------- - ------------------------------------------------------------------------------------------------------ -{-Refactoring: Remove a parameter - Description: The refactoring removes a user specified formal parameter in a function binding,and - the corresponding actual parameters in all calling places of this function. The - condition acompanying this refactoring is that the parameter to be removed is not being used. - - --To select a parameter, just stop the cursor at any position between the start and end position of this parameter. --} ------------------------------------------------------------------------------------------------------ - -rmOneParameter args - =do let fileName=args!!0 - row=read (args!!1)::Int - col=read (args!!2)::Int - (inscps, exps, mod, tokList)<-parseSourceFile fileName - --pn is the function names. - --nth is the nth paramter of pn is to be removed,index starts form 0. - let (pnt,nth)=getParam tokList (row,col) mod - pn=pNTtoPN pnt - if pn/=defaultPN - then do (mod',((ts',m), _))<-doRmParam pn nth mod fileName tokList - if isExported pnt exps - then do modName <- RefacUtils.fileNameToModName fileName - clients<-clientModsAndFiles modName - refactoredClients<-mapM (rmParamInClientMod pnt nth) clients - writeRefactoredFiles False $ ((fileName,m),(ts',mod')):refactoredClients - else writeRefactoredFiles False [((fileName,m), (ts',mod'))] - else error "Invalid cursor position!" - ---pn: function name; nth: the index of the parameter to be removed. -doRmParam pn nth mod fileName tokList - =runStateT (applyTP ((once_tdTP (failTP `adhocTP` inMod - `adhocTP` inMatch - `adhocTP` inPat - `adhocTP` inLet - `adhocTP` inAlt - `adhocTP` inLetStmt)) `choiceTP` failure) mod) - ((tokList,unmodified),(-1000,0)) - where - --1. pn is declared in top level. - inMod (mod@(HsModule loc name exps imps ds):: HsModuleP) - |definingDecls [pn] ds False False/=[] = doRemoving mod ds - inMod _ =mzero - - --2. pn is declared locally in the where clause of a match. - inMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP) - |definingDecls [pn] ds False False /=[] = doRemoving match ds - inMatch _ =mzero - - --3. pn is declared locally in the where clause of a pattern binding. - inPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP) - | definingDecls [pn] ds False False/=[] = doRemoving pat ds - inPat _=mzero - - --4: pn is declared locally in a Let expression - inLet (letExp@(Exp (HsLet ds e))::HsExpP) - | definingDecls [pn] ds False False/=[] = doRemoving letExp ds - inLet _=mzero - - --5. pn is declared locally in a case alternative. - inAlt (alt@(HsAlt loc p rhs ds)::HsAltP) - | definingDecls [pn] ds False False/=[] = doRemoving alt ds - inAlt _=mzero - - --6.pn is declared locally in a let statement. - inLetStmt (letStmt@(HsLetStmt ds stmts):: HsStmtP) - | definingDecls [pn] ds False False/=[] = doRemoving letStmt ds - inLetStmt _=mzero - - failure=idTP `adhocTP` mod - where mod (m::HsModuleP)=error "Refactoring failed" - - doRemoving parent ds --PROBLEM: How about doRemoving fails? - =do rmFormalArg pn nth False True =< fun " - else return e1 - funApp (exp@(Exp (HsApp e1 e2))::HsExpP) - |pn==(expToPN.(ghead "rmNthArgInFunCall").unfoldHsApp) exp --test if this application is a calling of fun pn. - =do let (before,after)=splitAt (nth+1) (unfoldHsApp exp) --remove the nth argument - if updateToks - then delete (ghead "rmNthArgInFunCall" after) exp - else return (foldHsApp (before++tail after)) --reconstruct the function application. - - funApp _=mzero - - --deconstruct a function application into a list of expressions. - unfoldHsApp exp= - case exp of - (Exp (HsApp e1 e2))->(unfoldHsApp e1)++[e2] - _ ->[exp] - --reconstruct a function application by a list of expressions. - foldHsApp exps=foldl1 (\e1 e2->(Exp (HsApp e1 e2))) exps - - -rmNthArgInSig pn nth decls - = let (before,after)=break (\d ->definesTypeSig pn d) decls - in if after==[] - then return decls - else do newSig<-rmNthArgInSig' nth [(head after)] --no problem with 'head' - return (before++newSig++(tail after)) - - where rmNthArgInSig' nth sig@[(Dec (HsTypeSig loc is c tp))] - =do let newSig=if length is ==1 - then --this type signature only defines the type of pn - [Dec (HsTypeSig loc is c (rmNth tp))] - else --this type signature also defines the type of other ids. - [Dec (HsTypeSig loc (filter (\x->pNTtoPN x/=pn) is) c tp), - Dec (HsTypeSig loc (filter (\x->pNTtoPN x==pn) is) c (rmNth tp))] - update sig newSig sig - - rmNth tp=let (before,after)=splitAt nth (unfoldHsTypApp tp) - in (foldHsTypApp (before ++ tail after)) - - --deconstruct a type application into a list of types - unfoldHsTypApp typ = - case typ of (Typ (HsTyFun t1 t2)) ->t1:unfoldHsTypApp t2 - _ ->[typ] - - --reconstruct a type application by a list of type expression. - foldHsTypApp ts=foldr1 (\t1 t2->(Typ (HsTyFun t1 t2))) ts - ---get the function name and the index of the parameter to be removed from the cursor position. -getParam toks pos - =(fromMaybe (defaultPNT, 0)).(applyTU (once_tdTU (failTU `adhocTU` inMatch))) - where - inMatch (match@(HsMatch loc fun pats rhs decls)::HsMatchP) - |inRange pos (getStartEndLoc toks pats) - =let paramPosRanges=map (getStartEndLoc toks) pats - elem=find (inRange pos) paramPosRanges - in if isNothing elem - then error "Invalid cursor position!" -- cursor doesn't stop at a parameter position. - else Just (fun, fromJust (elemIndex (fromJust elem) paramPosRanges)) - inMatch _=Nothing - - inRange pos (startPos,endPos)=pos>=startPos && pos<=endPos - -rmParamInClientMod pnt nth (m, fileName) - = do (inscps, exps, mod, ts) <-parseSourceFile fileName - let qualifier = hsQualifier pnt inscps - pn = pNTtoPN pnt - if qualifier == [] - then return ((fileName,unmodified), (ts,mod)) - else do (mod',((ts',m), _)) <- runStateT (rmNthArgInFunCall pn nth True mod) - ((ts,unmodified),(-1000,0)) - return ((fileName,m), (ts',mod')) - --} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Language.Haskell.Refact.Refactoring.AddRmParam + ( addOneParameter, compAddOneParameter + , rmOneParameter, compRmOneParameter + ) where + +import qualified Data.Generics as SYB +import qualified GHC.SYB.Utils as SYB + +import qualified GHC +import qualified Name as GHC +import qualified Outputable as GHC + +import qualified Language.Haskell.GhcMod as GM +import Language.Haskell.GhcMod.Internal as GM +import Language.Haskell.Refact.API + +import Language.Haskell.GHC.ExactPrint.Types +import Language.Haskell.GHC.ExactPrint.Transform +import Language.Haskell.GHC.ExactPrint.Utils + +import System.Directory +import Data.Char +import Data.Foldable +import Data.Maybe +import Data.List hiding (delete) + +import Data.Generics.Strafunski.StrategyLib.StrategyLib + +----------------------------------------------------------------------------------------------------- +{- An argument can be added to the definition of a function or constant. Adding an argument to a constant + definition will change the constant definition to a function definition. The new parameter is always + added as the first parameter of the function. A default parameter will be added as the first argument + to each of the function's call site. Suppose a new parameter named 'p' is added to function 'f', + then default parameter will be defined automatically as p_f_i=undefined, where 'i' is an integer. + To ensure that the default parameter name does not cause name clash in the client modules, we take the + visble names both in the current module and in the client modules into account when creating the + name. + +-} +----------------------------------------------------------------------------------------------------- + +addOneParameter :: RefactSettings -> GM.Options -> FilePath -> String -> SimpPos -> IO [FilePath] +addOneParameter settings opts fileName paramName (row,col) = do + absFileName <- canonicalizePath fileName + runRefacSession settings opts (compAddOneParameter absFileName paramName (row,col)) + +compAddOneParameter :: FilePath -> String -> SimpPos -> RefactGhc [ApplyRefacResult] +compAddOneParameter fileName paramName (row, col) = do + if isVarId paramName + then + do + parseSourceFileGhc fileName + parsed <- getRefactParsed + nm <- getRefactNameMap + logParsedSource "compAdd entry" + targetModule <- getRefactTargetModule + logm $ "AddRmParam.compAdd:got targetModule" + let maybePn = locToNameRdrPure nm (row, col) parsed + case maybePn of + Just pn -> + do + logm $ "AddRmParam.compAdd:about to applyRefac for:pn=" ++ SYB.showData SYB.Parser 0 pn + -- make sure this name is defined in this module + if isFunOrPatName nm pn parsed + then do + exported <- isExported pn + if exported + then do + clients <- clientModsAndFiles targetModule + decls <- liftT $ hsDecls parsed + let inscopes = [] + defaultArg <- mkTopLevelDefaultArgName pn paramName inscopes decls + logm $ "compAdd:defaultArg=" ++ showGhc defaultArg + (refactoredMod,_) <- applyRefac (doAddingParam pn paramName (Just defaultArg) True) RSAlreadyLoaded + refactoredClients <- mapM (addArgInClientMod pn defaultArg) clients + -- let refactoredClients = [] + return $ refactoredMod:refactoredClients + else do + logm $ "compAdd:not exported" + (refactoredMod,_) <- applyRefac (doAddingParam pn paramName Nothing False) (RSFile fileName) + return [refactoredMod] + + else error "Invalid cursor position or identifier is not a function/pattern name defined in this module!\n" + Nothing -> error "Invalid cursor position or identifier is not a function/pattern name defined in this module!\n" + else error $ "Invalid parameter name:" ++ paramName ++ "!" + + +-- --------------------------------------------------------------------- + +doAddingParam :: GHC.Name -> String -> Maybe (GHC.Located GHC.RdrName) -> Bool + -> RefactGhc () +doAddingParam pn newParam defaultArg isExported' = do + logm $ "doAddingParam entered:defaultArg=" ++ showGhc defaultArg + parsed <- getRefactParsed + -- logDataWithAnns "parsed" parsed + r <- applyTP (once_tdTP (failTP `adhocTP` inMod + `adhocTP` inMatch + -- `adhocTP` inPat + `adhocTP` inLet + -- `adhocTP` inAlt + `adhocTP` inLetStmt + ) + `choiceTP` failure) parsed + putRefactParsed r emptyAnns + return () + where + --1.pn is declared in top level + inMod :: GHC.ParsedSource -> RefactGhc GHC.ParsedSource + inMod modu = do + nm <- getRefactNameMap + decls <- liftT $ hsDecls modu + if not ( null (definingDeclsRdrNames nm [pn] decls False False)) + then + do + logm $ "doAddingParam.inMod doing it" + ds <- liftT $ hsDecls modu + modu' <- doAdding modu ds + if isExported' && isExplicitlyExported nm pn modu + then addItemsToExport modu' (Just pn) False (Left [GHC.unLoc (fromJust defaultArg)]) + else return modu' + else mzero + + --2. pn is declared locally in the where clause of a match. + inMatch ::GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName) + -> RefactGhc (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) + inMatch match + = do + nm <- getRefactNameMap + decls <- liftT $ hsDecls match + logm $ "doAddingParam.inMatch:decls=" ++ showGhc decls + if not ( null (definingDeclsRdrNames nm [pn] decls False False)) + then doAdding match decls + else mzero + +{- + --3. pn is declared locally in the where clause of a pattern binding. + inPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP) + | definingDecls [pn] ds False False/=[] = doAdding pat ds + inPat _ = mzero +-} + + --4: pn is declared locally in a Let expression + inLet (letExp@(GHC.L _ (GHC.HsLet _ds _e)) :: GHC.LHsExpr GHC.RdrName) + = do + nm <- getRefactNameMap + decls <- liftT $ hsDecls letExp + -- logm $ "doAddingParam.inLet:decls=" ++ showGhc decls + if not ( null (definingDeclsRdrNames nm [pn] decls False False)) + then doAdding letExp decls + else mzero +#if __GLASGOW_HASKELL__ <= 710 + inLet ((GHC.L l (GHC.HsDo ctx stmts ptt)) :: GHC.LHsExpr GHC.RdrName) +#else + inLet ((GHC.L l (GHC.HsDo ctx (GHC.L ls stmts) ptt)) :: GHC.LHsExpr GHC.RdrName) +#endif + = do + nm <- getRefactNameMap + -- logm $ "doAddingParam.inHsDo:stmts=" ++ showGhc stmts + if not ( null (definingDeclsRdrNames' nm [pn] stmts)) + then do + stmts' <- doAddingStmts stmts + stmts2 <- applyTP (once_tdTP (failTP `adhocTP` inMod + `adhocTP` inMatch + -- `adhocTP` inPat + `adhocTP` inLet + -- `adhocTP` inHsDo + -- `adhocTP` inAlt + `adhocTP` inLetStmt + ) + `choiceTP` failure) stmts' +#if __GLASGOW_HASKELL__ <= 710 + return (GHC.L l (GHC.HsDo ctx stmts2 ptt)) +#else + return (GHC.L l (GHC.HsDo ctx (GHC.L ls stmts2) ptt)) +#endif + else mzero + inLet _ = mzero + +{- + --5. pn is declared locally in a case alternative. + inAlt (alt@(HsAlt loc p rhs ds)::HsAltP) + | definingDecls [pn] ds False False/=[] = doAdding alt ds + inAlt _ = mzero +-} + + --6.pn is declared locally in a let statement. + inLetStmt (letStmt@(GHC.L _ (GHC.LetStmt _stmts)):: GHC.ExprLStmt GHC.RdrName) + = do + nm <- getRefactNameMap + decls <- liftT $ hsDecls letStmt + if not ( null (definingDeclsRdrNames nm [pn] decls False False)) + then doAdding letStmt decls + else mzero + inLetStmt _ = mzero + + failure = idTP `adhocTP` modu + where modu (_::GHC.ParsedSource) = error "Refactoring failed" + + + doAdding :: (HasDecls t) => t -> [GHC.LHsDecl GHC.RdrName] -> RefactGhc t + doAdding parent ds = do + nm <- getRefactNameMap + if paramNameOk nm pn newParam ds + then do + ds' <- addParamsToDecls ds pn [mkRdrName newParam] --addFormalParam pn newParam ds + defaultParamPName <-if isNothing defaultArg + then mkLocalDefaultArgName pn newParam parent + else return (gfromJust "doAdding" defaultArg) + parent1 <- liftT $ replaceDecls parent ds' + parent' <- addDefaultActualArg False pn defaultParamPName parent1 + parent''<- addDefaultActualArgDecl defaultParamPName parent' pn isExported' + ds2 <- liftT $ hsDecls parent'' + ds'' <- addArgToSig pn ds2 + parent3 <- liftT $ replaceDecls parent'' ds'' + return parent3 + else error " Refactoring failed." + + doAddingStmts :: [GHC.ExprLStmt GHC.RdrName] -> RefactGhc [GHC.ExprLStmt GHC.RdrName] + doAddingStmts stmts = do + logDataWithAnns "doAddingStmts:stmts:" stmts + nm <- getRefactNameMap + if paramNameOk nm pn newParam stmts + then do + defaultParamPName <-if isNothing defaultArg + then mkLocalDefaultArgName pn newParam stmts + else return (gfromJust "doAddingStmts" defaultArg) + stmts' <- addDefaultActualArg False pn defaultParamPName stmts + return stmts' + else error " Refactoring failed." + +-- --------------------------------------------------------------------- + +-- |check whether the new parameter is a legal. +paramNameOk :: (SYB.Data t) => NameMap -> GHC.Name -> String -> t -> Bool +paramNameOk nm pn newParam t + = (fromMaybe True) (applyTU (once_tdTU (failTU `adhocTU` decl + `adhocTU` bind)) t) + where + decl :: GHC.LHsDecl GHC.RdrName -> Maybe Bool + decl (GHC.L l (GHC.ValD d)) = bind (GHC.L l d) + decl _ = mzero + + bind :: GHC.LHsBind GHC.RdrName -> Maybe Bool +#if __GLASGOW_HASKELL__ <= 710 + bind (GHC.L _ (GHC.FunBind n _i (GHC.MG matches _a _ptt _o) _co _fvs _)) +#else + bind (GHC.L _ (GHC.FunBind n (GHC.MG matches _a _ptt _o) _co _fvs _)) +#endif + | rdrName2NamePure nm n == pn + = do results' <- mapM checkInMatch matches + Just (all (==True) results') + bind (GHC.L _ (GHC.PatBind _pat _rhs _ty _fvs _t)) + = error "Parameter can not be added to complex pattern binding" + bind _ = mzero + + checkInMatch match + = do let (f,d) = hsFDNamesFromInsideRdrPure nm match + if elem newParam (f `union` d) + then error "The new parameter name will cause name clash or semantics change, please choose another name!" + else return True + +-- --------------------------------------------------------------------- + +-- |add the default argument declaration right after the declaration defining pn +addDefaultActualArgDecl :: (SYB.Data t) => GHC.Located GHC.RdrName -> t -> GHC.Name -> Bool -> RefactGhc t +addDefaultActualArgDecl defaultParamPName parent pn isExported' = do + defaultArgDecl <- parseDeclWithAnns ((showGhc defaultParamPName) ++ " = undefined") + nm <- getRefactNameMap + let inParent = findLRdrName nm pn parent + if not inParent && not isExported' + then return parent + else addDecl parent (Just pn) ([defaultArgDecl],Nothing) + +-- --------------------------------------------------------------------- + +-- |suppose function name is f, parameter name is p, then the default argument +-- name is like f_p. +mkLocalDefaultArgName :: (SYB.Data t) + => GHC.Name -> String -> t -> RefactGhc (GHC.Located GHC.RdrName) +mkLocalDefaultArgName fun paramName t = do + logm $ "mkLocalDefaultArgName" + (f,d) <- hsFDNamesFromInsideRdr t + vs <- hsVisibleNamesRdr fun t -- ++AZ++ TODO : FindEntity on fun will fail in a RdrName AST + let name = mkNewName ((showGhc fun)++"_"++paramName) (nub (f `union` d `union` vs)) 0 + loc <- liftT $ uniqueSrcSpanT + let vn = (GHC.L loc (mkRdrName name)) + liftT $ addSimpleAnnT vn (DP (0,1)) [((G GHC.AnnVal),DP (0,0))] + return vn + +-- --------------------------------------------------------------------- + +mkTopLevelDefaultArgName :: (SYB.Data t,GHC.Outputable a) + => a -> String -> [String] -> t + -> RefactGhc (GHC.Located GHC.RdrName) +mkTopLevelDefaultArgName fun paramName inscopeNames t = do + (f,d) <- hsFDNamesFromInsideRdr t + let name = mkNewName ((showGhc fun)++"_"++paramName) (nub (f `union` d `union` inscopeNames)) 0 + loc <- liftT $ uniqueSrcSpanT + let vn = (GHC.L loc (mkRdrName name)) + liftT $ addSimpleAnnT vn (DP (0,1)) [((G GHC.AnnVal),DP (0,0))] + return vn + +-- --------------------------------------------------------------------- + +-- |Add the default argument to each call site of the function receiving the new parameter (AZ) +addDefaultActualArg :: (SYB.Data t) + => Bool -- ^If True recursively add the parameter to all + -- occurences of the function call site. If False, + -- stop the recursion when hitting the function + -- itself. + -> GHC.Name -- ^ The function name to receive the new parameter + -> GHC.Located GHC.RdrName -- ^The new parameter name + -- ++AZ++: why is it located? + -> t -- ^The AST fragment to be updated + -> RefactGhc t +addDefaultActualArg recursion pn argPName t = do + logm $ "addDefaultActualArg:(recursion,pn,argPName):" ++ showGhc (recursion,pn,argPName) + logDataWithAnns "addDefaultActualArg:t=:" t + nm <- getRefactNameMap + if recursion then (applyTP (stop_tdTP (failTP `adhocTP` (funApp nm)))) t + else (applyTP (stop_tdTP (failTP `adhocTP` (inDecl nm) + `adhocTP` (funApp nm)))) t + where + inDecl :: NameMap -> GHC.LHsDecl GHC.RdrName -> RefactGhc (GHC.LHsDecl GHC.RdrName) +#if __GLASGOW_HASKELL__ <= 710 + inDecl nm fun@(GHC.L _ (GHC.ValD (GHC.FunBind n _i _ _co _fvs _))) +#else + inDecl nm fun@(GHC.L _ (GHC.ValD (GHC.FunBind n _ _co _fvs _))) +#endif + | rdrName2NamePure nm n == pn + = return fun -- Stop the recursion by not returning mzero + + -- inDecl (pat@(Dec (HsPatBind loc1 ps rhs ds))::HsDeclP) + -- | pn == patToPN ps + -- = return pat + inDecl _ _ = mzero + + funApp :: NameMap -> GHC.LHsExpr GHC.RdrName -> RefactGhc (GHC.LHsExpr GHC.RdrName) +#if __GLASGOW_HASKELL__ <= 710 + funApp nm (expr@(GHC.L l (GHC.HsVar n))::GHC.LHsExpr GHC.RdrName) +#else + funApp nm (expr@(GHC.L l (GHC.HsVar (GHC.L _ n)))::GHC.LHsExpr GHC.RdrName) +#endif + | rdrName2NamePure nm (GHC.L l n) == pn = do + logm $ "addDefaultActualArg.funApp:expr=" ++ showGhc expr + addParamToExp expr (GHC.unLoc argPName) + + funApp _ _ = mzero + + +-- --------------------------------------------------------------------- + +-- | Add a parameter to a 'GHC.HsVar' expression +addParamToExp :: GHC.LHsExpr GHC.RdrName -> GHC.RdrName + -> RefactGhc (GHC.LHsExpr GHC.RdrName) +addParamToExp (expr@(GHC.L _ (GHC.HsVar _))) argPName = do + lp <- liftT uniqueSrcSpanT + la <- liftT uniqueSrcSpanT + lv <- liftT uniqueSrcSpanT +#if __GLASGOW_HASKELL__ <= 710 + let e2 = GHC.L lv (GHC.HsVar argPName) + liftT $ addSimpleAnnT e2 (DP (0,1)) [((G GHC.AnnVal),DP (0,0))] +#else + let lname = GHC.L lv argPName + let e2 = GHC.L lv (GHC.HsVar lname) + liftT $ addSimpleAnnT e2 (DP (0,1)) [((G GHC.AnnVal),DP (0,0))] +#endif + let ret = GHC.L lp (GHC.HsPar (GHC.L la (GHC.HsApp expr e2))) + liftT $ addSimpleAnnT ret (DP (0,0)) [((G GHC.AnnOpenP),DP (0,0)),((G GHC.AnnCloseP),DP (0,0))] + liftT $ transferEntryDPT expr ret + liftT $ setEntryDPT expr (DP (0,0)) + return ret +addParamToExp x _ + = error $ "AddRmParam.addParamToExp: can only add param to HsVar, got:" ++ showGhc x + +-- --------------------------------------------------------------------- + +-- |Add type arg to type siginature +addArgToSig :: GHC.Name -> [GHC.LHsDecl GHC.RdrName] -> RefactGhc [GHC.LHsDecl GHC.RdrName] +addArgToSig pn decls = do + nm <- getRefactNameMap + let (before,after) = break (\d -> definesSigDRdr nm pn d) decls + in if null after + then return decls + else do newSig<-addArgToSig' [(head after)] --no problem with head. + return (before++newSig++(tail after)) + + where + addArgToSig' :: [GHC.LHsDecl GHC.RdrName] -> RefactGhc [GHC.LHsDecl GHC.RdrName] +#if __GLASGOW_HASKELL__ <= 710 + addArgToSig' sig@[(GHC.L l (GHC.SigD (GHC.TypeSig is tp pr)))] = do +#else + addArgToSig' sig@[(GHC.L l (GHC.SigD (GHC.TypeSig is typ@(GHC.HsIB ivs (GHC.HsWC wcs mwc tp)))))] = do +#endif + nm <- getRefactNameMap + let tVar = mkNewTypeVarName sig +#if __GLASGOW_HASKELL__ <= 710 + typeVar <- newTypeVar tVar tp +#else + typeVar' <- newTypeVar tVar tp + let typeVar = GHC.HsIB ivs (GHC.HsWC wcs mwc typeVar') +#endif + let newSig=if length is==1 +#if __GLASGOW_HASKELL__ <= 710 + then --the type sig only defines the type for pn + [GHC.L l (GHC.SigD (GHC.TypeSig is typeVar pr))] + else --otherwise, seperate it into two type signatures. + [GHC.L l (GHC.SigD (GHC.TypeSig (filter (\x->rdrName2NamePure nm x/=pn) is) tp pr)), + GHC.L l (GHC.SigD (GHC.TypeSig (filter (\x->rdrName2NamePure nm x==pn) is) typeVar pr))] +#else + then --the type sig only defines the type for pn + [GHC.L l (GHC.SigD (GHC.TypeSig is typeVar))] + else --otherwise, seperate it into two type signatures. + [GHC.L l (GHC.SigD (GHC.TypeSig (filter (\x->rdrName2NamePure nm x/=pn) is) typ)), + GHC.L l (GHC.SigD (GHC.TypeSig (filter (\x->rdrName2NamePure nm x==pn) is) typeVar))] +#endif + return newSig + addArgToSig' sig = do + logm $ "addArgToSig':not processing " ++ showGhc sig + return sig + + + -- compose a type application using type expressions tv and tp + newTypeVar :: String -> GHC.LHsType GHC.RdrName -> RefactGhc (GHC.LHsType GHC.RdrName) + newTypeVar tVar tp = do + ls <- liftT $ uniqueSrcSpanT + lv <- liftT $ uniqueSrcSpanT +#if __GLASGOW_HASKELL__ <= 710 + let tv = GHC.L lv (GHC.HsTyVar (mkRdrName tVar)) + liftT $ addSimpleAnnT tv (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] +#else + let lname = GHC.L lv (mkRdrName tVar) + let tv = GHC.L lv (GHC.HsTyVar lname) + liftT $ addSimpleAnnT lname (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] +#endif + let typ = GHC.L ls (GHC.HsFunTy tv tp) + liftT $ addSimpleAnnT typ (DP (0,1)) [((G GHC.AnnRarrow),DP (0,1))] + return typ + + -- make a fresh type variable name. the new name is the first letter in + -- the alphabet which is not used in the type signature. + mkNewTypeVarName :: [GHC.LHsDecl GHC.RdrName] -> String + mkNewTypeVarName sig + =mkANewName "a" $ map showGhc $ (snd.hsTypeVbls) sig + where mkANewName initName v + =if elem initName v + then mkANewName ((intToDigit (digitToInt(head initName)+1)):tail initName) v + else initName + +-- --------------------------------------------------------------------- + +addArgInClientMod :: GHC.Name -> GHC.Located GHC.RdrName -> TargetModule -> RefactGhc ApplyRefacResult +addArgInClientMod pnt defaultArg serverModName = do + (r,_) <- applyRefac (addArgInClientMod' pnt defaultArg (GM.mpModule serverModName)) (RSTarget serverModName) + return r + + +addArgInClientMod' :: GHC.Name -> GHC.Located GHC.RdrName -> GHC.ModuleName -> RefactGhc () +addArgInClientMod' pnt defaultArg serverModName = do + parsed <- getRefactParsed + let pn = pnt + qual <- hsQualifier pnt + if qual == [] + then return () + else do + mod' <- addItemsToImport serverModName (Just pn) (Left [GHC.unLoc defaultArg]) parsed + mod'' <- addItemsToExport mod' (Just pn) False (Left [GHC.unLoc defaultArg]) + mod3 <- addDefaultActualArgInClientMod pn defaultArg mod'' + putRefactParsed mod3 emptyAnns + return () + + +-- --------------------------------------------------------------------- + +-- |Add default actual argument to pn in all the calling places. +addDefaultActualArgInClientMod :: (SYB.Data t) + => GHC.Name -> GHC.Located GHC.RdrName -> t + -> RefactGhc t +addDefaultActualArgInClientMod pn argPName t = do + logm $ "addDefaultActualArgInClientMod entered:argPName=" ++ showGhc argPName + nm <- getRefactNameMap + r <- applyTP (stop_tdTP (failTP `adhocTP` (funApp nm))) t + return r + where +#if __GLASGOW_HASKELL__ <= 710 + funApp nm (expr@((GHC.L l (GHC.HsVar pname )))::GHC.LHsExpr GHC.RdrName) +#else + funApp nm (expr@((GHC.L l (GHC.HsVar (GHC.L _ pname) )))::GHC.LHsExpr GHC.RdrName) +#endif + | GHC.nameUnique (rdrName2NamePure nm (GHC.L l pname)) == GHC.nameUnique pn + = do + logm $ "addDefaultActualArgInClientMod:hit" + -- vs <- hsVisibleNamesRdr (GHC.L l pname) t + let argExp = GHC.unLoc argPName + addParamToExp expr argExp + funApp _ _ = mzero + +-------------------------------End of adding a parameter----------------------------------- + +----------------------------------------------------------------------------------------------------- +{-Refactoring: Remove a parameter + Description: The refactoring removes a user specified formal parameter in a function binding,and + the corresponding actual parameters in all calling places of this function. The + condition acompanying this refactoring is that the parameter to be removed is not being used. + + --To select a parameter, just stop the cursor at any position between the start and end position of this parameter. +-} +----------------------------------------------------------------------------------------------------- + +-- |The refactoring removes a user specified formal parameter in a function +-- binding,and the corresponding actual parameters in all calling places of this +-- function. The condition acompanying this refactoring is that the parameter to +-- be removed is not being used. +-- The @SimpPos@ should be somwewhere inside the parameter to be removed +rmOneParameter :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> IO [FilePath] +rmOneParameter settings opts fileName (row,col) = do + absFileName <- canonicalizePath fileName + runRefacSession settings opts (compRmOneParameter absFileName (row,col)) + +compRmOneParameter :: FilePath -> SimpPos -> RefactGhc [ApplyRefacResult] +compRmOneParameter fileName (row, col) = do + parseSourceFileGhc fileName + -- logParsedSource "compRm entry" + -- pn is the function names. + -- nth is the nth paramter of pn is to be removed,index starts from 0. + mp <- getParam (row,col) + case mp of + Nothing -> error "Invalid cursor position!" -- cursor doesn't stop at a parameter position. + Just (pn,pnth) -> do + logm $ "compRm:(pn,pnth)=" ++ showGhc (pn,pnth) + exported <- isExported pn + if exported + then do + logm $ "compRm: exported" + (refactoredMod,_) <- applyRefac (doRmParam pn pnth) (RSFile fileName) + targetModule <- getRefactTargetModule + clients <- clientModsAndFiles targetModule + logm $ "compRm: clients:" ++ showGhc clients + refactoredClients <- mapM (rmParamInClientMod pn pnth) clients + -- let refactoredClients = [] + return $ refactoredMod:refactoredClients + else do + logm $ "compRm:not exported" + (refactoredMod,_) <- applyRefac (doRmParam pn pnth) (RSFile fileName) + return [refactoredMod] + + +-- --------------------------------------------------------------------- + +--pn: function name; nth: the index of the parameter to be removed. +doRmParam :: GHC.Name -> Int -> RefactGhc () +doRmParam pn nTh = do + logm $ "doRmParam entered:(pn,nth)=" ++ showGhc (pn,nTh) + parsed <- getRefactParsed + r <- applyTP ((once_tdTP (failTP `adhocTP` inMod + `adhocTP` inMatch + -- `adhocTP` inPat + `adhocTP` inLet + -- `adhocTP` inAlt + `adhocTP` inLetStmt + )) + `choiceTP` failure) parsed + logm $ "doRmParam after applyTP" + putRefactParsed r emptyAnns + logParsedSource "doRmParam:parsed after" + return () + where + --1. pn is declared in top level. + inMod :: GHC.ParsedSource -> RefactGhc GHC.ParsedSource + inMod modu = doRemoving' modu + + -- --2. pn is declared locally in the where clause of a match. + inMatch :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> RefactGhc (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) +#if __GLASGOW_HASKELL__ <= 710 + inMatch match@(GHC.L _ (GHC.Match (Just (_fun,_)) _pats _mtyp (GHC.GRHSs _rhs _ds))) +#else + inMatch match@(GHC.L _ (GHC.Match (GHC.FunBindMatch _fun _) _pats _mtyp (GHC.GRHSs _rhs _ds))) +#endif + = doRemoving' match + inMatch _ = mzero + + -- --3. pn is declared locally in the where clause of a pattern binding. + -- inPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP) + -- | definingDecls [pn] ds False False/=[] = doRemoving pat ds + -- inPat _=mzero + + -- --4: pn is declared locally in a Let expression + inLet :: GHC.LHsExpr GHC.RdrName -> RefactGhc (GHC.LHsExpr GHC.RdrName) + inLet letExp@(GHC.L _ (GHC.HsLet _bs _e)) + = doRemoving' letExp +#if __GLASGOW_HASKELL__ <= 710 + inLet (GHC.L l (GHC.HsDo ctx stmts ptt)) +#else + inLet (GHC.L l (GHC.HsDo ctx (GHC.L ls stmts) ptt)) +#endif + = do + nm <- getRefactNameMap + if not ( null (definingDeclsRdrNames' nm [pn] stmts)) + then do + stmts' <- doRemovingStmts stmts +#if __GLASGOW_HASKELL__ <= 710 + return (GHC.L l (GHC.HsDo ctx stmts' ptt)) +#else + return (GHC.L l (GHC.HsDo ctx (GHC.L ls stmts') ptt)) +#endif + else mzero + inLet _ = mzero + + -- --5. pn is declared locally in a case alternative. + -- inAlt (alt@(HsAlt loc p rhs ds)::HsAltP) + -- | definingDecls [pn] ds False False/=[] = doRemoving alt ds + -- inAlt _=mzero + + -- --6.pn is declared locally in a let statement. + inLetStmt :: GHC.ExprLStmt GHC.RdrName -> RefactGhc (GHC.ExprLStmt GHC.RdrName) + inLetStmt letStmt@(GHC.L _ (GHC.LetStmt _)) + = doRemoving' letStmt + inLetStmt _ = mzero + + failure = idTP `adhocTP` modu + where modu (_m::GHC.ParsedSource) = error "Refactoring failed" + + -- ------------------------ + + doRemoving' parent = do + nm <- getRefactNameMap + decls <- liftT $ hsDecls parent + if not ( null (definingDeclsRdrNames nm [pn] decls False False)) + then doRemoving parent decls + else mzero + + doRemoving :: (HasDecls t) => t -> [GHC.LHsDecl GHC.RdrName] -> RefactGhc t + doRemoving parent ds --PROBLEM: How about doRemoving fails? + =do + -- Check the preconditions, will error on failure + void $ rmFormalArg pn nTh False True =<< rmNthArgInFunCall pn nTh ds + + -- preconditions passed, do the transformation + ds' <- rmNthArgInSig pn nTh =<< rmFormalArg pn nTh True False ds + ds'' <- liftT $ replaceDecls parent ds' + rmNthArgInFunCall pn nTh ds'' + + doRemovingStmts :: [GHC.ExprLStmt GHC.RdrName] -> RefactGhc [GHC.ExprLStmt GHC.RdrName] + doRemovingStmts stmts + =do + -- Check the preconditions, will error on failure + void $ rmFormalArg pn nTh False True =<< rmNthArgInFunCall pn nTh stmts + + -- preconditions passed, do the transformation + stmts' <- rmFormalArg pn nTh True False stmts + rmNthArgInFunCall pn nTh stmts' + + -- |Just remove the nth formal parameter. + rmFormalArg :: (SYB.Data t) => GHC.Name -> Int -> Bool -> Bool -> t -> RefactGhc t + rmFormalArg pn' nTh' updateToks checking t = do + logm $ "rmFormalArg:(pn,nTh,updateToks,checking)=" ++ showGhc (pn',nTh',updateToks,checking) + -- logDataWithAnns "rmFormalArg:t=" t + nm <- getRefactNameMap + applyTP (stop_tdTP (failTP `adhocTP` (rmInMatch nm))) t + + where + -- a formal parameter only exists in a match +#if __GLASGOW_HASKELL__ <= 710 + rmInMatch nm (match@(GHC.L l (GHC.Match (Just (fun,b)) pats typ (GHC.GRHSs rhs decls)))::GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) +#else + rmInMatch nm (match@(GHC.L l (GHC.Match (GHC.FunBindMatch fun b) pats typ (GHC.GRHSs rhs decls)))::GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) +#endif + | rdrName2NamePure nm fun == pn' = + let pat = pats!!nTh' --get the nth formal parameter + pats' = take nTh' pats ++ drop (nTh' + 1) pats + pNames = map (rdrName2NamePure nm) $ hsNamessRdr pat --get all the names in this pat. (the pat may be just be a variable) + in if checking && not ( all (==False) ((map (flip (findNameInRdr nm) rhs) pNames)) && --not used in rhs + all (==False) ((map (flip (findNameInRdr nm) decls) pNames))) --not used in the where clause + then error "This parameter can not be removed, as it is used!" + else do + -- If we have removed the last parametwer, make + -- sure the AnnEqual annotation takes its spacing + -- from the original parameter spacing + when (null pats') $ do + dp <- liftT $ getEntryDPT (ghead "rmFormalArg" pats) + logm $ "rmFormalArg.rmInMatch:dp=" ++ show dp + liftT $ setAnnKeywordDP match (G GHC.AnnEqual) dp +#if __GLASGOW_HASKELL__ <= 710 + return (GHC.L l (GHC.Match (Just (fun,b)) pats' typ (GHC.GRHSs rhs decls))) +#else + return (GHC.L l (GHC.Match (GHC.FunBindMatch fun b) pats' typ (GHC.GRHSs rhs decls))) +#endif + rmInMatch _ _ = mzero + +-- --------------------------------------------------------------------- + +-- |Remove the nth argument of function pn in all the calling places. The index +-- for the first argument is zero. +rmNthArgInFunCall :: (SYB.Data t) => GHC.Name -> Int -> t -> RefactGhc t +rmNthArgInFunCall pn nTh t = do + nm <- getRefactNameMap + applyTP (stop_tdTP (failTP `adhocTP` (funApp nm))) t + where + funApp nm (expr@(GHC.L _ (GHC.HsPar (GHC.L _ (GHC.HsApp e1 _e2))))::GHC.LHsExpr GHC.RdrName) + | nTh == 0 && Just pn == expToNameRdr nm e1 + = do + liftT $ transferEntryDPT expr e1 + return e1 -- handle the case like '(fun x) => fun " + funApp nm (expr@(GHC.L _ (GHC.HsApp _e1 _e2))) = do + --test if this application is a calling of fun pn. + let expu = unfoldHsApp expr + ed <- liftT $ getEntryDPT expr + if Just pn == (expToNameRdr nm.snd.(ghead "rmNthArgInFunCall")) expu + then do + let (before,after)=splitAt (nTh+1) expu --remove the nth argument + let exp' = (foldHsApp (before++tail after)) --reconstruct the function application. + liftT $ setEntryDPT exp' ed + return exp' + else mzero + + funApp _ _ = mzero + + -- |deconstruct a function application into a list of expressions. + unfoldHsApp :: GHC.LHsExpr GHC.RdrName -> [(GHC.SrcSpan, GHC.LHsExpr GHC.RdrName)] + unfoldHsApp expr = + case expr of + (GHC.L l (GHC.HsApp e1 e2)) -> unfoldHsApp e1 ++ [(l,e2)] + _ -> [(GHC.noSrcSpan,expr)] + + -- |reconstruct a function application by a list of expressions. + foldHsApp :: [(GHC.SrcSpan, GHC.LHsExpr GHC.RdrName)] -> GHC.LHsExpr GHC.RdrName + foldHsApp [] = error "foldHsApp:empty list" + foldHsApp exps = snd $ foldl1 (\(_l1,e1) (l2,e2) -> (l2,GHC.L l2 (GHC.HsApp e1 e2))) exps + + +-- --------------------------------------------------------------------- + +rmNthArgInSig :: GHC.Name -> Int -> [GHC.LHsDecl GHC.RdrName] -> RefactGhc [GHC.LHsDecl GHC.RdrName] +rmNthArgInSig pn nTh decls = do + nm <- getRefactNameMap + let (before,after)=break (\d ->definesSigDRdr nm pn d) decls + if null after + then return decls + else do newSig<-rmNthArgInSig' nm [(head after)] --no problem with 'head' + return (before++newSig++(tail after)) + + where +#if __GLASGOW_HASKELL__ <= 710 + rmNthArgInSig' nm [GHC.L l (GHC.SigD (GHC.TypeSig is typ@(GHC.L lt (GHC.HsForAllTy ex wc bnd ctx tp)) c))] +#else + -- rmNthArgInSig' nm [GHC.L l (GHC.SigD (GHC.TypeSig is typ@(GHC.HsIB ivs (GHC.HsWC wcs mwc (GHC.L lt (GHC.HsForAllTy bnd tp))))))] + rmNthArgInSig' nm [GHC.L l (GHC.SigD (GHC.TypeSig is typ@(GHC.HsIB ivs (GHC.HsWC wcs mwc tp))))] +#endif + =do + ed <- liftT $ getEntryDPT tp + let (GHC.L lp tp') = rmNth tp + lp' <- liftT uniqueSrcSpanT + liftT $ modifyAnnsT $ copyAnn (GHC.L lp tp') (GHC.L lp' tp') + liftT $ setEntryDPT (GHC.L lp' tp') ed +#if __GLASGOW_HASKELL__ <= 710 + let typ' = GHC.L lt (GHC.HsForAllTy ex wc bnd ctx (GHC.L lp' tp')) +#else + -- let typ' = GHC.HsIB ivs (GHC.HsWC wcs mwc (GHC.L lt (GHC.HsForAllTy bnd (GHC.L lp' tp')))) + let typ' = GHC.HsIB ivs (GHC.HsWC wcs mwc (GHC.L lp' tp')) +#endif + newSig <- liftT $ if length is ==1 + then --this type signature only defines the type of pn +#if __GLASGOW_HASKELL__ <= 710 + return [GHC.L l (GHC.SigD (GHC.TypeSig is typ' c))] +#else + return [GHC.L l (GHC.SigD (GHC.TypeSig is typ'))] +#endif + else do --this type signature also defines the type of other ids. + let otherNames = filter (\x->rdrName2NamePure nm x/=pn) is + [thisName] = filter (\x->rdrName2NamePure nm x==pn) is + removeTrailingCommaT thisName + removeTrailingCommaT (last otherNames) + ls <- uniqueSrcSpanT +#if __GLASGOW_HASKELL__ <= 710 + let otherSig = GHC.L l (GHC.SigD (GHC.TypeSig otherNames typ c)) + thisSig = GHC.L ls (GHC.SigD (GHC.TypeSig [thisName] typ' c)) +#else + let otherSig = GHC.L l (GHC.SigD (GHC.TypeSig otherNames typ)) + thisSig = GHC.L ls (GHC.SigD (GHC.TypeSig [thisName] typ')) +#endif + modifyAnnsT $ copyAnn otherSig thisSig + clearPriorComments thisSig + setEntryDPT thisSig (DP (2,0)) + return [otherSig,thisSig] + return newSig + rmNthArgInSig' _nm sig = return sig + + rmNth tp = let (before,after)=splitAt nTh (unfoldHsTypApp tp) + in (foldHsTypApp (before ++ tail after)) + + --deconstruct a type application into a list of types + unfoldHsTypApp :: GHC.LHsType GHC.RdrName -> [(GHC.SrcSpan,GHC.LHsType GHC.RdrName)] + unfoldHsTypApp typ = + case typ of (GHC.L l (GHC.HsFunTy t1 t2)) ->(l,t1):unfoldHsTypApp t2 + _ ->[(GHC.noSrcSpan,typ)] + + --reconstruct a type application by a list of type expression. + foldHsTypApp :: [(GHC.SrcSpan,GHC.LHsType GHC.RdrName)] -> GHC.LHsType GHC.RdrName + foldHsTypApp [] = error "foldHsTypApp:empty list" + foldHsTypApp ts=snd $ foldr1 (\(l1,t1) (_l2,t2)->(l1,GHC.L l1 (GHC.HsFunTy t1 t2))) ts + +-- --------------------------------------------------------------------- + +-- |Get the function name and the index of the parameter to be removed from the +-- cursor position. +getParam :: SimpPos -> RefactGhc (Maybe (GHC.Name,Int)) +getParam pos = do + nm <- getRefactNameMap + parsed <- getRefactParsed + let r = applyTU (once_tdTU (failTU `adhocTU` inMatch)) parsed + case r of + Nothing -> return Nothing + Just (ln,i) -> return $ Just (rdrName2NamePure nm ln,i) + where +#if __GLASGOW_HASKELL__ <= 710 + inMatch ((GHC.Match (Just (fun,_)) pats _mtyp _grhs)::GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName)) +#else + inMatch ((GHC.Match (GHC.FunBindMatch fun _) pats _mtyp _grhs)::GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName)) +#endif + = case locToRdrName pos pats of + Nothing -> Nothing + Just _ln -> if isNothing element + then error "Invalid cursor position!" -- cursor doesn't stop at a parameter position. + else Just (fun, fromJust (elemIndex (fromJust element) paramPosRanges)) + where + paramPosRanges = map GHC.getLoc pats + element = find (inRange pos) paramPosRanges + inMatch _ = Nothing + + inRange pos' ss = pos' >= startPos && pos'<=endPos + where (startPos,endPos) = (ss2pos ss,ss2posEnd ss) + +-- --------------------------------------------------------------------- + +rmParamInClientMod :: GHC.Name -> Int -> TargetModule -> RefactGhc ApplyRefacResult +rmParamInClientMod pn nTh serverModName = do + logm $ "rmParamInClientMod:serverModName" ++ showGhc serverModName + (r,_) <- applyRefac (rmNthArgInFunCallMod pn nTh) (RSTarget serverModName) + return r + +rmNthArgInFunCallMod :: GHC.Name -> Int -> RefactGhc () +rmNthArgInFunCallMod pn nTh = do + parsed <- getRefactParsed + newNames <- equivalentNameInNewMod pn + logm $ "rmNthArgInFunCallMod:(newNames)=" ++ showGhcQual newNames + case newNames of + [] -> return () + [_pnt] -> do + parsed' <- rmNthArgInFunCall pn nTh parsed + putRefactParsed parsed' emptyAnns + return () + _ns -> error "HaRe: rmParam: more than one name matches" + diff --git a/src/Language/Haskell/Refact/Refactoring/Case.hs b/src/Language/Haskell/Refact/Refactoring/Case.hs --- a/src/Language/Haskell/Refact/Refactoring/Case.hs +++ b/src/Language/Haskell/Refact/Refactoring/Case.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE StandaloneDeriving #-} module Language.Haskell.Refact.Refactoring.Case ( ifToCase @@ -82,13 +83,26 @@ falseLoc <- liftT uniqueSrcSpanT -- HaRe:-1:7 falseMatchLoc <- liftT uniqueSrcSpanT -- HaRe:-1:8 falseRhsLoc <- liftT uniqueSrcSpanT -- HaRe:-1:9 +#if __GLASGOW_HASKELL__ > 710 + matchesLoc <- liftT uniqueSrcSpanT -- HaRe:-1:10 + lbTrueLoc <- liftT uniqueSrcSpanT -- HaRe:-1:11 + lbFalseLoc <- liftT uniqueSrcSpanT -- HaRe:-1:11 +#endif let trueName = mkRdrName "True" let falseName = mkRdrName "False" let ret = GHC.L caseLoc (GHC.HsCase e1 (GHC.MG + ( +#if __GLASGOW_HASKELL__ > 710 + GHC.L matchesLoc +#endif [ (GHC.L trueMatchLoc $ GHC.Match +#if __GLASGOW_HASKELL__ <= 710 Nothing +#else + GHC.NonFunBindMatch +#endif [ GHC.L trueLoc1 $ GHC.ConPatIn (GHC.L trueLoc trueName) (GHC.PrefixCon []) ] @@ -96,10 +110,19 @@ (GHC.GRHSs [ GHC.L trueRhsLoc $ GHC.GRHS [] e2 - ] GHC.EmptyLocalBinds) + ] + ( +#if __GLASGOW_HASKELL__ > 710 + GHC.L lbTrueLoc +#endif + GHC.EmptyLocalBinds)) ) , (GHC.L falseMatchLoc $ GHC.Match - Nothing +#if __GLASGOW_HASKELL__ <= 710 + Nothing +#else + GHC.NonFunBindMatch +#endif [ GHC.L falseLoc1 $ GHC.ConPatIn (GHC.L falseLoc falseName) (GHC.PrefixCon []) ] @@ -107,9 +130,14 @@ (GHC.GRHSs [ GHC.L falseRhsLoc $ GHC.GRHS [] e3 - ] GHC.EmptyLocalBinds) + ] + ( +#if __GLASGOW_HASKELL__ > 710 + GHC.L lbFalseLoc +#endif + GHC.EmptyLocalBinds)) ) - ] [] GHC.placeHolderType GHC.FromSource)) + ]) [] GHC.placeHolderType GHC.FromSource)) oldAnns <- liftT $ getAnnsT let annIf = gfromJust "Case.annIf" $ getAnnotationEP li oldAnns diff --git a/src/Language/Haskell/Refact/Refactoring/DupDef.hs b/src/Language/Haskell/Refact/Refactoring/DupDef.hs --- a/src/Language/Haskell/Refact/Refactoring/DupDef.hs +++ b/src/Language/Haskell/Refact/Refactoring/DupDef.hs @@ -42,14 +42,17 @@ parseSourceFileGhc fileName renamed <- getRefactRenamed parsed <- getRefactParsed + nm <- getRefactNameMap targetModule <- getRefactTargetModule logm $ "DupDef.compDuplicateDef:got targetModule" let (Just (modName,_)) = getModuleName parsed - let maybePn = locToName (row, col) renamed + let maybePn = locToRdrName (row,col) parsed + -- let maybePn = locToNameRdrPure nm (row, col) parsed case maybePn of - Just pn -> + Just lr@(GHC.L l _) -> do + let pn = GHC.L l (rdrName2NamePure nm lr) logm $ "DupDef.compDuplicateDef:about to applyRefac for:pn=" ++ SYB.showData SYB.Parser 0 pn (refactoredMod,(isDone,nn)) <- applyRefac (doDuplicating pn newName) (RSFile fileName) logm $ "DupDef.com:isDone=" ++ show isDone @@ -171,7 +174,7 @@ doDuplicating'' :: (SYB.Data t) => GHC.Name -> t -> GHC.Located GHC.Name -> RefactGhc t doDuplicating'' newNameGhc parentr ln = do - logm $ "doDuplicating'':parentr=" ++ SYB.showData SYB.Parser 0 parentr + -- logm $ "doDuplicating'':parentr=" ++ SYB.showData SYB.Parser 0 parentr r <- hasDeclsSybTransform workerHsDecls workerBind parentr logm $ "doDuplicating'':done" return r @@ -208,13 +211,13 @@ --d: names that might clash with the new name logm $ "doDuplicating'':(f,d)=" ++ show (f,d) - dv <- hsVisiblePNsRdr nm ln declsp --dv: names may shadow new name + DN dv <- hsVisibleDsRdr nm n declsp --dv: names may shadow new name let vars = nub (f `union` d `union` map showGhc dv) -- TODO: Where definition is of form tup@(h,t), test each element of it for clashes, or disallow nameAlreadyInScope <- isInScopeAndUnqualifiedGhc newName Nothing - if elem newName vars || (nameAlreadyInScope && findEntity ln duplicatedDecls) + if elem newName vars || (nameAlreadyInScope && findNameInRdr nm n duplicatedDecls) then error ("The new name'"++newName++"' will cause name clash/capture or ambiguity problem after " ++ "duplicating, please select another name!") else do @@ -233,17 +236,17 @@ refactorInClientMod oldPN serverModName newPName targetModule = do logm ("refactorInClientMod: (oldPN,serverModName,newPName)=" ++ (showGhc (oldPN,serverModName,newPName))) - -- void $ activateModule targetModule getTargetGhc targetModule let fileName = GM.mpPath targetModule renamed <- getRefactRenamed - parsed <- getRefactParsed + parsed <- getRefactParsed + logm $ "refactorInClientMod:got newPName:" ++ showGhcQual newPName let modNames = willBeUnQualImportedBy serverModName renamed logm ("refactorInClientMod: (modNames)=" ++ (showGhc (modNames))) -- ++AZ++ debug - mustHide <- needToBeHided newPName renamed parsed + mustHide <- needToBeHided newPName parsed logm ("refactorInClientMod: (mustHide)=" ++ (showGhc (mustHide))) -- ++AZ++ debug if isJust modNames && mustHide then do @@ -251,11 +254,15 @@ return refactoredMod else return ((fileName,RefacUnmodifed),(emptyAnns,parsed)) where - needToBeHided :: GHC.Name -> GHC.RenamedSource -> GHC.ParsedSource -> RefactGhc Bool - needToBeHided name exps parsed = do + needToBeHided :: GHC.Name -> GHC.ParsedSource -> RefactGhc Bool + needToBeHided name parsed = do + -- logDataWithAnns "refactorInClientMod.needToBeHided:parsed" parsed + -- logm $ "refactorInClientMod.needToBeHided:name=" ++ showGhcQual name + nm <- getRefactNameMap + logm $ "refactorInClientMod.needToBeHided:nm=" ++ showGhcQual nm let usedUnqual = usedWithoutQualR name parsed logm ("refactorInClientMod: (usedUnqual)=" ++ (showGhc (usedUnqual))) -- ++AZ++ debug - return $ usedUnqual || causeNameClashInExports oldPN name serverModName exps + return $ usedUnqual || causeNameClashInExports nm oldPN name serverModName parsed doDuplicatingClient :: GHC.ModuleName -> [GHC.Name] -> RefactGhc () diff --git a/src/Language/Haskell/Refact/Refactoring/MoveDef.hs b/src/Language/Haskell/Refact/Refactoring/MoveDef.hs --- a/src/Language/Haskell/Refact/Refactoring/MoveDef.hs +++ b/src/Language/Haskell/Refact/Refactoring/MoveDef.hs @@ -16,17 +16,14 @@ import qualified Data.Generics as SYB import qualified GHC.SYB.Utils as SYB + import qualified Data.Generics.Zipper as Z import qualified Exception as GHC -import qualified FastString as GHC import qualified GHC as GHC import qualified Name as GHC import qualified RdrName as GHC -import qualified TyCon as GHC -import qualified TypeRep as GHC -import qualified Var as Var import Control.Exception import Control.Monad.State @@ -93,13 +90,13 @@ -> RefactGhc [ApplyRefacResult] compLiftToTopLevel fileName (row,col) = do parseSourceFileGhc fileName - renamed <- getRefactRenamed parsed <- getRefactParsed + nm <- getRefactNameMap let (Just (modName,_)) = getModuleName parsed - let maybePn = locToName (row, col) renamed + let maybePn = locToRdrName (row, col) parsed case maybePn of - Just pn -> liftToTopLevel' modName pn + Just ln@(GHC.L l _) -> liftToTopLevel' modName (GHC.L l (rdrName2NamePure nm ln)) _ -> error "\nInvalid cursor position!\n" @@ -139,9 +136,11 @@ -> RefactGhc [ApplyRefacResult] liftToTopLevel' modName pn@(GHC.L _ n) = do renamed <- getRefactRenamed + parsed <- getRefactParsed + nm <- getRefactNameMap targetModule <- getRefactTargetModule logm $ "liftToTopLevel':pn=" ++ (showGhc pn) - if isLocalFunOrPatName n renamed + if isLocalFunOrPatName nm n parsed then do (refactoredMod,declPns) <- applyRefac liftToMod RSAlreadyLoaded @@ -156,19 +155,22 @@ else error "\nThe identifier is not a local function/pattern name!" where - {-step1: divide the module's top level declaration list into three parts: - 'parent' is the top level declaration containing the lifted declaration, - 'before' and `after` are those declarations before and after 'parent'. + {-step1: divide the module's top level declaration list into three parts: 'parent' + is the top level declaration containing the lifted declaration, 'before' + and `after` are those declarations before and after 'parent'. step2: get the declarations to be lifted from parent, bind it to liftedDecls - step3: remove the lifted declarations from parent and extra arguments may be introduce. + step3: remove the lifted declarations from parent and extra arguments + may be introduced. step4. test whether there are any names need to be renamed. -} liftToMod = do - renamed <- getRefactRenamed - parsed <- getRefactParsed + parsed' <- getRefactParsed + parsed <- liftT $ balanceAllComments parsed' + nm <- getRefactNameMap + logDataWithAnns "parsed after balanceAllComments" parsed declsp <- liftT $ hsDecls parsed (before,parent,after) <- divideDecls declsp pn - {- ++AZ++ : hsBinds does not return class or instance definitions + {- ++AZ++TODO: reinstate this, hsDecls does : hsBinds does not return class or instance definitions when (isClassDecl $ ghead "liftToMod" parent) $ error "Sorry, the refactorer cannot lift a definition from a class declaration!" when (isInstDecl $ ghead "liftToMod" parent) @@ -188,7 +190,8 @@ pns <- pnsNeedRenaming parsed parent liftedDecls declaredPns logm $ "liftToMod:(pns needing renaming)=" ++ (showGhc pns) - let dd = getDeclaredVars $ hsBinds renamed + decls <- liftT $ hsDecls parsed' + let dd = getDeclaredVarsRdr nm decls logm $ "liftToMod:(ddd)=" ++ (showGhc dd) if pns == [] @@ -196,8 +199,8 @@ (parent',liftedDecls',mLiftedSigs') <- addParamsToParentAndLiftedDecl n dd parent liftedDecls mLiftedSigs let defName = (ghead "liftToMod" (definedNamesRdr nameMap (ghead "liftToMod2" parent'))) - parsed' <- liftT $ replaceDecls parsed (before++parent'++after) - parsed2 <- moveDecl1 parsed' (Just defName) [GHC.unLoc pn] liftedDecls' + parsed1 <- liftT $ replaceDecls parsed (before++parent'++after) + parsed2 <- moveDecl1 parsed1 (Just defName) [GHC.unLoc pn] liftedDecls' declaredPns mLiftedSigs' putRefactParsed parsed2 emptyAnns @@ -219,14 +222,14 @@ -> RefactGhc [ApplyRefacResult] compLiftOneLevel fileName (row,col) = do parseSourceFileGhc fileName - renamed <- getRefactRenamed parsed <- getRefactParsed + nm <- getRefactNameMap let (Just (modName,_)) = getModuleName parsed - let maybePn = locToName (row, col) renamed + let maybePn = locToRdrName (row, col) parsed case maybePn of - Just pn -> do - rs <- liftOneLevel' modName pn + Just ln@(GHC.L l _) -> do + rs <- liftOneLevel' modName (GHC.L l (rdrName2NamePure nm ln)) logm $ "compLiftOneLevel:rs=" ++ (show $ (refactDone rs,map (\((_,d),_) -> d) rs)) if (refactDone rs) then return rs @@ -319,8 +322,10 @@ liftOneLevel' modName pn@(GHC.L _ n) = do renamed <- getRefactRenamed + parsed <- getRefactParsed + nm <- getRefactNameMap targetModule <- getRefactTargetModule - if isLocalFunOrPatName n renamed + if isLocalFunOrPatName nm n parsed then do (refactoredMod,(b,pns)) <- applyRefac doLiftOneLevel RSAlreadyLoaded logm $ "liftOneLevel':main refactoring done:(p,pns)=" ++ showGhc (b,pns) @@ -392,7 +397,7 @@ -> GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> Maybe (SYB.Stage -> Z.Zipper a -> RefactGhc (Z.Zipper a)) liftToMatchQ nm ans (m@(GHC.L _ (GHC.Match _ _pats _mtyp (GHC.GRHSs _rhs ds)))::GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) - | (nonEmptyList (definingDeclsRdrNames nm [n] (getHsDecls ans ds) False False)) + | (nonEmptyList (definingDeclsRdrNames nm [n] (getHsDecls ans ds) False False)) = Just (doLiftZ m (getHsDecls ans ds)) | otherwise = Nothing @@ -562,15 +567,15 @@ -> RefactGhc [ApplyRefacResult] compDemote fileName (row,col) = do parseSourceFileGhc fileName - renamed <- getRefactRenamed parsed <- getRefactParsed + nm <- getRefactNameMap -- TODO: make the next one an API call, that also gets the -- parsed source let (Just (modName,_)) = getModuleName parsed - let maybePn = locToName (row, col) renamed + let maybePn = locToRdrName (row, col) parsed case maybePn of - Just pn -> demote' modName pn + Just pn@(GHC.L l _) -> demote' modName (GHC.L l (rdrName2NamePure nm pn)) _ -> error "\nInvalid cursor position!\n" -- --------------------------------------------------------------------- @@ -625,15 +630,16 @@ = do logm $ "MoveDef.pnsNeedRenaming' entered" nm <- getRefactNameMap - (FN f,DN d) <- hsFDsFromInsideRdr nm dest --f: free variable names that may be shadowed by pn - --d: declaread variables names that may clash with pn + let (FN f,DN d) = hsFDsFromInsideRdr nm dest --f: free variable names that may be shadowed by pn + --d: declaread variables names that may clash with pn logm $ "MoveDef.pnsNeedRenaming':(f,d)=" ++ showGhc (f,d) - vs <- hsVisiblePNsRdr nm pn parent --vs: declarad variables that may shadow pn + DN vs <- hsVisibleDsRdr nm pn parent --vs: declarad variables that may shadow pn logm $ "MoveDef.pnsNeedRenaming':vs=" ++ showGhc vs let vars = map pNtoName (nub (f `union` d `union` vs) \\ [pn]) -- `union` inscpNames isInScope <- isInScopeAndUnqualifiedGhc (pNtoName pn) Nothing logm $ "MoveDef.pnsNeedRenaming:(f,d,vs,vars,isInScope)=" ++ (showGhc (f,d,vs,vars,isInScope)) - if elem (pNtoName pn) vars || isInScope && findEntity pn dest + -- if elem (pNtoName pn) vars || isInScope && findEntity pn dest + if elem (pNtoName pn) vars || isInScope && findNameInRdr nm pn dest then return [pn] else return [] pNtoName = showGhc @@ -647,7 +653,11 @@ nm <- getRefactNameMap applyTP (full_buTP (idTP `adhocTP` (inExp nm))) t where +#if __GLASGOW_HASKELL__ <= 710 inExp nm (e@(GHC.L l (GHC.HsVar n)) :: GHC.LHsExpr GHC.RdrName) = do +#else + inExp nm (e@(GHC.L l (GHC.HsVar (GHC.L _ n))) :: GHC.LHsExpr GHC.RdrName) = do +#endif let ne = rdrName2NamePure nm (GHC.L l n) if GHC.nameUnique ne == GHC.nameUnique pn then addActualParamsToRhs pn params e @@ -723,7 +733,7 @@ -- |get the subset of 'pns', which need to be hided in the import -- declaration in module 'mod' -- Note: these are newly exported from the module, so we cannot use --- the GHC name resolution i nthis case. +-- the GHC name resolution in this case. namesNeedToBeHided :: GHC.Module -> [GHC.ModuleName] -> [GHC.Name] -> RefactGhc [GHC.Name] namesNeedToBeHided clientModule modNames pns = do @@ -785,19 +795,18 @@ -- --------------------------------------------------------------------- +-- |When liftOneLevel is complete, identify whether any new declarations have +-- been put at the top level liftedToTopLevel :: GHC.Located GHC.Name -> GHC.ParsedSource -> RefactGhc (Bool,[GHC.Name]) -liftedToTopLevel pnt@(GHC.L _ pn) parsed = do - -- logm $ "liftedToTopLevel entered" +liftedToTopLevel (GHC.L _ pn) parsed = do + logm $ "liftedToTopLevel entered:pn=" ++ showGhc pn nm <- getRefactNameMap - -- logm $ "liftedToTopLevel:got nm" decls <- liftT $ hsDecls parsed let topDecs = definingDeclsRdrNames nm [pn] decls False False -- ++AZ++ :TODO: we are not updating the nameMap to reflect moved decls if nonEmptyList topDecs then do - (_, parent,_) <- divideDecls decls pnt - let declsp = parent - let liftedDecls = definingDeclsRdrNames nm [pn] declsp False False + let liftedDecls = definingDeclsRdrNames nm [pn] topDecs False False declaredPns = nub $ concatMap (definedNamesRdr nm) liftedDecls return (True, declaredPns) else return (False, []) @@ -844,7 +853,7 @@ else return (parent,liftedDecls,mLiftedSigs) -- --------------------------------------------------------------------- - +{- -- TODO: perhaps move this to TypeUtils addParamsToSigs :: [GHC.Name] -> GHC.LSig GHC.RdrName -> RefactGhc (GHC.LSig GHC.RdrName) addParamsToSigs [] ms = return ms @@ -1036,6 +1045,7 @@ HsWrapTy HsTyWrapper (HsType name) -} +-} --------------------------------End of Lifting----------------------------------------- @@ -1063,11 +1073,13 @@ -> RefactGhc [ApplyRefacResult] demote' modName (GHC.L _ pn) = do renamed <- getRefactRenamed + parsed <- getRefactParsed + nm <- getRefactNameMap targetModule <- getRefactTargetModule - if isFunOrPatName pn renamed + if isFunOrPatName nm pn parsed then do isTl <- isTopLevelPN pn - if isTl && isExplicitlyExported pn renamed + if isTl && isExplicitlyExported nm pn parsed then error "This definition can not be demoted, as it is explicitly exported by the current module!" else do (refactoredMod,declaredPns) <- applyRefac (doDemoting pn) RSAlreadyLoaded @@ -1100,10 +1112,11 @@ doDemotingInClientMod :: [GHC.Name] -> GHC.Module -> RefactGhc () doDemotingInClientMod pns modName = do logm $ "doDemotingInClientMod:(pns,modName)=" ++ showGhc (pns,modName) - renamed@(_g,imps,exps,_docs) <- getRefactRenamed - if any (\pn->findPN pn (hsBinds renamed) || findPN pn (exps)) pns + (GHC.L _ p) <- getRefactParsed + nm <- getRefactNameMap + if any (\pn -> findNameInRdr nm pn (GHC.hsmodDecls p) || findNameInRdr nm pn (GHC.hsmodExports p)) pns then error $ "This definition can not be demoted, as it is used in the client module '"++(showGhc modName)++"'!" - else if any (\pn->findPN pn imps) pns + else if any (\pn->findNameInRdr nm pn (GHC.hsmodImports p)) pns -- TODO: reinstate this then do -- (mod',((ts',m),_))<-runStateT (rmItemsFromImport mod pns) ((ts,unmodified),(-1000,0)) return () @@ -1250,7 +1263,7 @@ logm $ "MoveDef:declaredPns=" ++ (showGhc declaredPns) -- ++AZ++ - dl <- mapM (flip declaredNamesInTargetPlace ds) declaredPns + dl <- mapM (flip (declaredNamesInTargetPlace nm) ds) declaredPns logm $ "mapM declaredNamesInTargetPlace done" --make sure free variable in 'f' do not clash with variables in 'dl', --otherwise do renaming. @@ -1263,14 +1276,6 @@ else --duplicate demoted declarations to the right place. do duplicateDecls declaredPns removedDecl demotedSigs t' - {- - logm $ "MoveDef: about to duplicateDecls" - dds <- liftT $ hsDecls t' - ds'' <- duplicateDecls declaredPns removedDecl demotedSigs dds - logm $ "MoveDef:duplicateDecls done" - t'' <- liftT $ replaceDecls t' ds'' - return t'' - -} _ ->error "\nThis function/pattern binding is used by more than one friend bindings\n" else error "This function can not be demoted as it is used in current level!\n" @@ -1285,7 +1290,11 @@ where used :: GHC.LHsDecl GHC.RdrName -> [Int] +#if __GLASGOW_HASKELL__ <= 710 used (GHC.L _ (GHC.ValD (GHC.FunBind _n _ (GHC.MG matches _ _ _) _ _ _))) +#else + used (GHC.L _ (GHC.ValD (GHC.FunBind _n (GHC.MG (GHC.L _ matches) _ _ _) _ _ _))) +#endif = concatMap (usedInMatch pns) matches used (GHC.L _ (GHC.ValD (GHC.PatBind pat rhs _ _ _))) @@ -1364,11 +1373,10 @@ --------------------------------------------------------------------- declaredNamesInTargetPlace :: (SYB.Data t) - => GHC.Name -> t - -- -> RefactGhc [GHC.Name] + => NameMap -> GHC.Name -> t -> RefactGhc [GHC.Name] - declaredNamesInTargetPlace pn' t' = do + declaredNamesInTargetPlace nm pn' t' = do logm $ "declaredNamesInTargetPlace:pn=" ++ (showGhc pn') res <- applyTU (stop_tdTU (failTU `adhocTU` inMatch @@ -1376,18 +1384,19 @@ logm $ "declaredNamesInTargetPlace:res=" ++ (showGhc res) return res where - inMatch ((GHC.Match _ _pats _ rhs) :: GHC.Match GHC.Name (GHC.LHsExpr GHC.Name)) - | findPN pn' rhs = do + inMatch ((GHC.Match _ _pats _ rhs) :: GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName)) + | findNameInRdr nm pn' rhs = do logm $ "declaredNamesInTargetPlace:inMatch" - fds <- hsFDsFromInside rhs - return $ snd fds + -- fds <- hsFDsFromInside rhs + let (_,DN ds) = hsFDsFromInsideRdr nm rhs + return ds inMatch _ = return mzero - inPat ((GHC.PatBind pat rhs _ _ _) :: GHC.HsBind GHC.Name) - |findPN pn' rhs = do + inPat ((GHC.PatBind pat rhs _ _ _) :: GHC.HsBind GHC.RdrName) + |findNameInRdr nm pn' rhs = do logm $ "declaredNamesInTargetPlace:inPat" - fds <- hsFDsFromInside pat - return $ snd fds + let (_,DN ds) = hsFDsFromInsideRdr nm pat + return ds inPat _= return mzero -- --------------------------------------------------------------------- @@ -1456,7 +1465,11 @@ where matchesInDecls :: GHC.LHsDecl GHC.RdrName -> [GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)] +#if __GLASGOW_HASKELL__ <= 710 matchesInDecls (GHC.L _ (GHC.ValD (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _))) = matches +#else + matchesInDecls (GHC.L _ (GHC.ValD (GHC.FunBind _ (GHC.MG (GHC.L _ matches) _ _ _) _ _ _))) = matches +#endif matchesInDecls _x = [] patsInMatch (GHC.L _ (GHC.Match _ pats' _ _)) = pats' @@ -1472,7 +1485,11 @@ nm <- getRefactNameMap SYB.everywhereMStaged SYB.Parser (SYB.mkM (worker nm) `SYB.extM` (workerBind nm)) decls where +#if __GLASGOW_HASKELL__ <= 710 worker nm (match'@(GHC.L _ (GHC.FunBind ln _ (GHC.MG _matches _ _ _) _ _ _)) :: GHC.LHsBind GHC.RdrName) +#else + worker nm (match'@(GHC.L _ (GHC.FunBind ln (GHC.MG _matches _ _ _) _ _ _)) :: GHC.LHsBind GHC.RdrName) +#endif = do logm $ "foldInDemotedDecls:rdrName2NamePure nm ln=" ++ show (rdrName2NamePure nm ln) if isJust (find (== rdrName2NamePure nm ln) pns') @@ -1628,8 +1645,9 @@ -> GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> RefactGhc [GHC.Name] getClashedNames nm oldNames newNames match' - = do (_f,DN d) <- hsFDsFromInsideRdr nm match' - ds' <- mapM (flip (hsVisiblePNsRdr nm) match') oldNames + = do let (_f,DN d) = hsFDsFromInsideRdr nm match' + ds'' <- mapM (flip (hsVisibleDsRdr nm) match') oldNames + let ds' = map (\(DN ds) -> ds) ds'' -- return clashed names return (filter (\x->elem ({- pNtoName -} x) newNames) --Attention: nub ( nub (d `union` (nub.concat) ds'))) @@ -1659,8 +1677,8 @@ everywhereMStaged' SYB.Parser (SYB.mkM worker) decls -- | return True if pn is a local function/pattern name -isLocalFunOrPatName :: SYB.Data t => GHC.Name -> t -> Bool -isLocalFunOrPatName pn scope - = isLocalPN pn && isFunOrPatName pn scope +isLocalFunOrPatName :: SYB.Data t => NameMap -> GHC.Name -> t -> Bool +isLocalFunOrPatName nm pn scope + = isLocalPN pn && isFunOrPatName nm pn scope -- EOF diff --git a/src/Language/Haskell/Refact/Refactoring/Renaming.hs b/src/Language/Haskell/Refact/Refactoring/Renaming.hs --- a/src/Language/Haskell/Refact/Refactoring/Renaming.hs +++ b/src/Language/Haskell/Refact/Refactoring/Renaming.hs @@ -3,8 +3,6 @@ , compRename ) where -import qualified Data.Generics.Schemes as SYB -import qualified Data.Generics.Aliases as SYB import qualified GHC.SYB.Utils as SYB import qualified GHC @@ -12,7 +10,6 @@ import qualified RdrName as GHC import Control.Monad -import Data.Maybe import Data.List import qualified Language.Haskell.GhcMod as GM (Options(..)) @@ -64,18 +61,22 @@ logm $ "Renaming.comp: (fileName,newName,(row,col))=" ++ show (fileName,newName,(row,col)) parseSourceFileGhc fileName - renamed <- getRefactRenamed parsed <- getRefactParsed modu <- getModule targetModule <- getRefactTargetModule + nm <- getRefactNameMap + -- logDataWithAnns "parsed" parsed + let modName = maybe (GHC.mkModuleName "Main") fst $ getModuleName parsed - maybePn = locToName (row, col) renamed + maybePn = locToRdrName (row, col) parsed logm $ "Renamed.comp:maybePn=" ++ showGhc maybePn -- ++AZ++ case maybePn of - Just pn@(GHC.L _ n) -> do + Just pn'@(GHC.L l _) -> do + let n = rdrName2NamePure nm pn' + pn = GHC.L l n logm $ "Renaming:(n,modu)=" ++ showGhc (n,modu) let (GHC.L _ rdrName) = gfromJust "Renaming.comp.2" $ locToRdrName (row, col) parsed @@ -124,25 +125,20 @@ --------Rename a value variable name-------------------------------- doRenaming pn@(GHC.L _ oldn) rdrNameStr newNameStr newNameGhc modName = do logm $ "doRenaming:(pn,rdrNameStr,newNameStr) = " ++ showGhc (pn,rdrNameStr,newNameStr) - renamed <- getRefactRenamed - void $ SYB.everywhereM (SYB.mkM renameInMod) renamed + renameTopLevelVarName oldn newNameStr newNameGhc modName True True logm "doRenaming done" isExported oldn - where - -- 1. The name is declared in a module(top level name) - renameInMod :: GHC.RenamedSource -> RefactGhc GHC.RenamedSource - renameInMod ren = do - logm "renameInMod" - renameTopLevelVarName oldn newNameStr newNameGhc modName ren True True -renameTopLevelVarName :: GHC.Name -> String -> GHC.Name -> GHC.ModuleName -> GHC.RenamedSource - -> Bool -> Bool -> RefactGhc GHC.RenamedSource -renameTopLevelVarName oldPN newName newNameGhc modName renamed existChecking exportChecking = do +renameTopLevelVarName :: GHC.Name -> String -> GHC.Name -> GHC.ModuleName + -> Bool -> Bool -> RefactGhc () +renameTopLevelVarName oldPN newName newNameGhc modName existChecking exportChecking = do logm $ "renameTopLevelVarName:(existChecking, exportChecking)=" ++ show (existChecking, exportChecking) causeAmbiguity <- causeAmbiguityInExports oldPN newNameGhc + parsed <- getRefactParsed + nm <- getRefactNameMap -- f' contains names imported from other modules; -- d' contains the top level names declared in this module; - (f', d') <- hsFDsFromInside renamed + let (FN f', DN d') = hsFDsFromInsideRdr nm parsed --filter those qualified free variables in f' -- let (f,d) = ((nub.map pNtoName.filter (not.isQualifiedPN)) f', (nub.map pNtoName) d') let (f, d) = (map nameToString f', map nameToString d') @@ -169,7 +165,7 @@ --the same name has been declared in this module. error $ mconcat ["Name '", newName, "' already exists in this module\n"] - when (exportChecking && causeNameClashInExports oldPN newNameGhc modName renamed) $ + when (exportChecking && causeNameClashInExports nm oldPN newNameGhc modName parsed) $ error "The new name will cause conflicting exports, please select another new name!" when (exportChecking && causeAmbiguity) . -- causeAmbiguityInExports oldPN newNameGhc {- inscps -} renamed error $ mconcat ["The new name will cause ambiguity in the exports of module '" @@ -182,17 +178,17 @@ isInScopeUnqual <- isInScopeAndUnqualifiedGhc newName (Just newNameGhc) logm "renameTopLevelVarName:after isInScopeUnqual" logm $ "renameTopLevelVarName:oldPN=" ++ showGhc oldPN - ds <- hsVisibleNames oldPN renamed + ds <- hsVisibleNamesRdr oldPN parsed logm $ "renameTopLevelVarName:ds computed=" ++ show ds when (existChecking && newName `elem` nub (ds `union` f) \\ [nameToString oldPN]) . error $ mconcat [ "Name '", newName, "' already exists, or renaming '", nameToString oldPN, "' to '" , newName, "' will change the program's semantics!\n"] logm "renameTopLevelVarName start..:should have qualified" - parsed <- renamePN oldPN newNameGhc (exportChecking && isInScopeUnqual) =<< getRefactParsed - putRefactParsed parsed mempty + let qual = if (exportChecking && isInScopeUnqual) then Qualify else PreserveQualify + parsed' <- renamePN oldPN newNameGhc qual parsed + putRefactParsed parsed' mempty logm "renameTopLevelVarName done:should have qualified" - getRefactRenamed ------------------------------------------------------------------------ @@ -203,8 +199,9 @@ logm $ "renameInClientMod:(newNameGhc module)=" ++ showGhc (GHC.nameModule newNameGhc) -- ++AZ++ getTargetGhc targetModule - renamed <- getRefactRenamed modName <- getRefactModuleName + parsed <- getRefactParsed + nm <- getRefactNameMap -- We need to find the old name in the module, and get it as a -- GHC.Name to know what to look for in the call to renamePN', as it @@ -224,14 +221,15 @@ -- logm $ "renameInClientMod:(uniques:newNames,oldPN)=" ++ showGhcQual (map GHC.nameUnique newNames,GHC.nameUnique oldPN) case newNames of [] -> return [] - [oldName] | findPN oldName renamed -> doRenameInClientMod oldName modName renamed + -- [oldName] | findPN oldName renamed -> doRenameInClientMod oldName modName renamed + [oldName] | findNameInRdr nm oldName parsed -> doRenameInClientMod nm oldName modName parsed | otherwise -> do logm "renameInClientMod: name not present in module, returning" return [] ns -> error $ "HaRe: renameInClientMod: could not find name to replace, got:" ++ showGhcQual ns where - doRenameInClientMod oldNameGhc modName renamed = do + doRenameInClientMod nm oldNameGhc modName parsed = do -- There are two different tests we need to do here -- 1. Does the new name clash with some existing name in the -- client mod, in which case it must be qualified @@ -244,11 +242,12 @@ if isInScopeUnqualNew -- ++AZ++: should this be negated? then do - (refactoredMod, _) <- applyRefac (refactRenameSimple oldNameGhc newName newNameGhc True) + -- (refactoredMod, _) <- applyRefac (refactRenameSimple oldNameGhc newName newNameGhc True) + (refactoredMod, _) <- applyRefac (refactRenameSimple oldNameGhc newName newNameGhc Qualify) RSAlreadyLoaded return [refactoredMod] else do - when (causeNameClashInExports oldPN newNameGhc modName renamed) . + when (causeNameClashInExports nm oldPN newNameGhc modName parsed) . error $ mconcat [ "The new name will cause conflicting exports in module" , show newName, ", please select another name!"] -- (refactoredMod,_) <- applyRefac (refactRenameComplex oldPN newName newNameGhc) RSAlreadyLoaded @@ -257,7 +256,7 @@ -- TODO: implement rest of this return [refactoredMod] - refactRenameSimple :: GHC.Name -> String -> GHC.Name -> Bool -> RefactGhc () + refactRenameSimple :: GHC.Name -> String -> GHC.Name -> HowToQual -> RefactGhc () refactRenameSimple old newStr new useQual = do logm $ "refactRenameSimple:(old,newStr,new,useQual)=" ++ showGhc (old, newStr, new, useQual) qualifyTopLevelVar newStr @@ -283,13 +282,16 @@ logm $ "renameInClientMod.worker:(oldPN',newName',newNameGhc')=" ++ showGhc (oldPN', newName', newNameGhc') isInScopeUnqualNew <- isInScopeAndUnqualifiedGhc newName' Nothing - vs <- hsVisibleNames oldPN' =<< getRefactRenamed -- Does this check names other than variable names? + vs <- hsVisibleNamesRdr oldPN' =<< getRefactParsed -- Does this check names other than variable names? logm $ "renameInClientMod.worker:(vs,oldPN',isInScopeUnqualNew)=" ++ showGhc (vs, oldPN', isInScopeUnqualNew) - parsed <- renamePN oldPN' newNameGhc' - (newName' `elem` (nub vs \\ [nameToString oldPN']) || isInScopeUnqualNew) - =<< getRefactParsed + -- logParsedSource "worker:parsed" + + let qual = if (newName' `elem` (nub vs \\ [nameToString oldPN']) || isInScopeUnqualNew) + then Qualify + else PreserveQualify + parsed <- renamePN oldPN' newNameGhc' qual =<< getRefactParsed putRefactParsed parsed mempty return () diff --git a/src/Language/Haskell/Refact/Refactoring/SwapArgs.hs b/src/Language/Haskell/Refact/Refactoring/SwapArgs.hs --- a/src/Language/Haskell/Refact/Refactoring/SwapArgs.hs +++ b/src/Language/Haskell/Refact/Refactoring/SwapArgs.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} module Language.Haskell.Refact.Refactoring.SwapArgs (swapArgs) where @@ -31,9 +32,10 @@ -> RefactGhc [ApplyRefacResult] comp fileName (row, col) = do parseSourceFileGhc fileName - renamed <- getRefactRenamed + parsed <- getRefactParsed + nm <- getRefactNameMap - let name = locToName (row, col) renamed + let name = locToNameRdrPure nm (row, col) parsed case name of -- (Just pn) -> do refactoredMod@(_, (_t, s)) <- applyRefac (doSwap pnt pn) (Just modInfo) fileName @@ -55,8 +57,8 @@ -- putStrLn "Completd" -doSwap :: (GHC.Located GHC.Name) -> RefactGhc () -doSwap (GHC.L _s n1) = do +doSwap :: GHC.Name -> RefactGhc () +doSwap n1 = do parsed <- getRefactParsed logm $ "doSwap:parsed=" ++ SYB.showData SYB.Parser 0 parsed nm <- getRefactNameMap @@ -71,11 +73,19 @@ where -- 1. The definition is at top level... +#if __GLASGOW_HASKELL__ <= 710 inMod nm ((GHC.FunBind ln2 infixity (GHC.MG matches p m1 m2) a locals tick)::GHC.HsBind GHC.RdrName) +#else + inMod nm ((GHC.FunBind ln2 (GHC.MG (GHC.L lm matches) p m1 m2) a locals tick)::GHC.HsBind GHC.RdrName) +#endif | GHC.nameUnique n1 == GHC.nameUnique (rdrName2NamePure nm ln2) = do logm ("inMatch>" ++ SYB.showData SYB.Parser 0 ln2 ++ "<") newMatches <- updateMatches matches +#if __GLASGOW_HASKELL__ <= 710 return (GHC.FunBind ln2 infixity (GHC.MG newMatches p m1 m2) a locals tick) +#else + return (GHC.FunBind ln2 (GHC.MG (GHC.L lm newMatches) p m1 m2) a locals tick) +#endif inMod _ func = return func -- 2. All call sites of the function... @@ -94,7 +104,11 @@ inExp _ e = return e -- 3. Type signature... +#if __GLASGOW_HASKELL__ <= 710 inType nm (GHC.L x (GHC.TypeSig [lname] types pns)::GHC.LSig GHC.RdrName) +#else + inType nm (GHC.L x (GHC.TypeSig [lname] (GHC.HsIB ivs (GHC.HsWC wcs mwc types)))::GHC.LSig GHC.RdrName) +#endif | GHC.nameUnique (rdrName2NamePure nm lname) == GHC.nameUnique n1 = do logm $ "doSwap.inType" @@ -103,9 +117,17 @@ -- t2' <- update t2 t1 t2 let t1' = t2 let t2' = t1 +#if __GLASGOW_HASKELL__ <= 710 return (GHC.L x (GHC.TypeSig [lname] (tyListToFun (t1':t2':ts)) pns)) +#else + return (GHC.L x (GHC.TypeSig [lname] (GHC.HsIB ivs (GHC.HsWC wcs mwc (tyListToFun (t1':t2':ts)))))) +#endif +#if __GLASGOW_HASKELL__ <= 710 inType nm (GHC.L _x (GHC.TypeSig (n:ns) _types _)::GHC.LSig GHC.RdrName) +#else + inType nm (GHC.L _x (GHC.TypeSig (n:ns) _types )::GHC.LSig GHC.RdrName) +#endif | GHC.nameUnique n1 `elem` (map (\n' -> GHC.nameUnique (rdrName2NamePure nm n')) (n:ns)) = error "Error in swapping arguments in type signature: signature bound to muliple entities!" @@ -116,7 +138,11 @@ return (GHC.L l (GHC.SigD s')) inTypeDecl _ x = return x +#if __GLASGOW_HASKELL__ <= 710 tyFunToList (GHC.L _ (GHC.HsForAllTy _ _ _ _ (GHC.L _ (GHC.HsFunTy t1 t2)))) = t1 : (tyFunToList t2) +#else + tyFunToList (GHC.L _ (GHC.HsForAllTy _ (GHC.L _ (GHC.HsFunTy t1 t2)))) = t1 : (tyFunToList t2) +#endif tyFunToList (GHC.L _ (GHC.HsFunTy t1 t2)) = t1 : (tyFunToList t2) tyFunToList t = [t] diff --git a/src/Language/Haskell/Refact/Utils/Binds.hs b/src/Language/Haskell/Refact/Utils/Binds.hs deleted file mode 100644 --- a/src/Language/Haskell/Refact/Utils/Binds.hs +++ /dev/null @@ -1,425 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE UndecidableInstances #-} -- for GHC.DataId - --------------------------------------------------------------------------------- --- Module : TypeUtils - --- Maintainer : refactor-fp\@kent.ac.uk --- | --- --- This module contains a collection of program analysis and --- transformation functions (the API) that work over the Type --- Decorated AST. Most of the functions defined in the module are --- taken directly from the API, but in some cases are modified to work --- with the type decorated AST. --- --- In particular some new functions have been added to make type --- decorated AST traversals easier. --- --- In HaRe, in order to preserve the comments and layout of refactored --- programs, a refactoring modifies not only the AST but also the --- token stream, and the program source after the refactoring is --- extracted from the token stream rather than the AST, for the --- comments and layout information is kept in the token steam instead --- of the AST. As a consequence, a program transformation function --- from this API modifies both the AST and the token stream (unless --- explicitly stated). So when you build your own program --- transformations, try to use the API to do the transformation, as --- this can liberate you from caring about the token stream. --- --- This type decorated API is still in development. Any suggestions --- and comments are very much welcome. - - --------------------------------------------------------------------------------- -module Language.Haskell.Refact.Utils.Binds - ( - hsBinds - , getValBindSigs - , HsValBinds(..) - ) where - -import Language.Haskell.GHC.ExactPrint.Utils - --- Modules from GHC -import qualified Bag as GHC -import qualified GHC as GHC -import qualified Outputable as GHC - -import Data.Generics - --- --------------------------------------------------------------------- - -bindsFromDecls :: [GHC.LHsDecl name] -> GHC.HsValBinds name -bindsFromDecls ds = GHC.ValBindsIn (GHC.listToBag binds) sigs - where - binds = concatMap goBind ds - goBind (GHC.L l (GHC.ValD d)) = [(GHC.L l d)] - goBind _ = [] - - sigs = concatMap goSig ds - goSig (GHC.L l (GHC.SigD d)) = [(GHC.L l d)] - goSig _ = [] - --- --------------------------------------------------------------------- - -getValBindSigs :: GHC.HsValBinds GHC.RdrName -> [GHC.LSig GHC.RdrName] -getValBindSigs binds = case binds of - GHC.ValBindsIn _ sigs -> sigs - GHC.ValBindsOut _ _sigs -> [] - -emptyValBinds :: GHC.HsValBinds name -emptyValBinds = GHC.ValBindsIn (GHC.listToBag []) [] - -unionBinds :: [GHC.HsValBinds name] -> GHC.HsValBinds name -unionBinds [] = emptyValBinds -unionBinds [x] = x -unionBinds (x1:x2:xs) = unionBinds ((mergeBinds x1 x2):xs) - where - mergeBinds :: GHC.HsValBinds name -> GHC.HsValBinds name -> GHC.HsValBinds name - mergeBinds (GHC.ValBindsIn b1 s1) (GHC.ValBindsIn b2 s2) = (GHC.ValBindsIn (GHC.unionBags b1 b2) (s1++s2)) - mergeBinds (GHC.ValBindsOut b1 s1) (GHC.ValBindsOut b2 s2) = (GHC.ValBindsOut (b1++b2) (s1++s2)) - mergeBinds y1@(GHC.ValBindsIn _ _) y2@(GHC.ValBindsOut _ _) = mergeBinds y2 y1 - mergeBinds (GHC.ValBindsOut _ _) (GHC.ValBindsIn _ _) = error $ "unionBinds:cannot merge ValBindsOut and ValBindsIn" - --- NOTE: ValBindsIn are found before the Renamer, ValBindsOut after - -hsBinds :: (HsValBinds t name) => t -> [GHC.LHsBind name] -hsBinds t = case hsValBinds t of - GHC.ValBindsIn binds _sigs -> GHC.bagToList binds - GHC.ValBindsOut bs _sigs -> concatMap (\(_,b) -> GHC.bagToList b) bs - --- This class replaces the HsDecls one -class (Data t,Data name) => HsValBinds t name | t -> name where - - -- | Return the binds that are directly enclosed in the - -- given syntax phrase. - -- hsValBinds :: t -> [GHC.LHsBind GHC.Name] - hsValBinds :: t -> GHC.HsValBinds name - - -- | Return the type class definitions that are directly enclosed - -- in the given syntax phrase. Note: only makes sense for - -- GHC.RenamedSource - hsTyDecls :: t -> [[GHC.LTyClDecl name]] - - -instance HsValBinds GHC.ParsedSource GHC.RdrName where - hsValBinds (GHC.L _ (GHC.HsModule _ _ _ ds _ _)) = bindsFromDecls ds - - -- hsTyDecls (grp,_,_,_) = map GHC.group_tyclds (GHC.hs_tyclds grp) - hsTyDecls (GHC.L _ (GHC.HsModule _ _ _ _ds _ _)) = [] - -instance HsValBinds GHC.RenamedSource GHC.Name where - hsValBinds (grp,_,_,_) = (GHC.hs_valds grp) - - hsTyDecls (grp,_,_,_) = map GHC.group_tyclds (GHC.hs_tyclds grp) - -instance (GHC.DataId name,Data name) - => HsValBinds (GHC.HsValBinds name) name where - hsValBinds vb = vb - hsTyDecls _ = [] - -instance (GHC.DataId name,Data name) - => HsValBinds (GHC.HsGroup name) name where - hsValBinds grp = (GHC.hs_valds grp) - - hsTyDecls _ = [] - -instance (GHC.DataId name,Data name) - => HsValBinds (GHC.HsLocalBinds name) name where - hsValBinds lb = case lb of - GHC.HsValBinds b -> b - GHC.HsIPBinds _ -> emptyValBinds - GHC.EmptyLocalBinds -> emptyValBinds - - hsTyDecls _ = [] - -instance (GHC.DataId name,Data name) - => HsValBinds (GHC.GRHSs name (GHC.LHsExpr name)) name where - hsValBinds (GHC.GRHSs _ lb) = hsValBinds lb - - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,Data name) - => HsValBinds (GHC.MatchGroup name (GHC.LHsExpr name)) name where - hsValBinds (GHC.MG matches _ _ _) = hsValBinds matches - - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,Data name) - => HsValBinds [GHC.LMatch name (GHC.LHsExpr name)] name where - hsValBinds ms = unionBinds $ map (\m -> hsValBinds $ GHC.unLoc m) ms - - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,Data name) - => HsValBinds (GHC.LMatch name (GHC.LHsExpr name)) name where - hsValBinds m = hsValBinds $ GHC.unLoc m - - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - - -instance (GHC.DataId name,Data name) - => HsValBinds (GHC.Match name (GHC.LHsExpr name)) name where - hsValBinds (GHC.Match _ _ _ grhs) = hsValBinds grhs - - hsTyDecls _ = [] - -instance (GHC.OutputableBndr name,GHC.DataId name,Data name) - => HsValBinds (GHC.HsBind name) name where - hsValBinds (GHC.PatBind _p rhs _typ _fvs _) = hsValBinds rhs - - -- TODO: ++AZ++ added for compatibility with hsDecls. - hsValBinds (GHC.FunBind _ _ matches _ _ _) = hsValBinds matches - hsValBinds other = error $ "hsValBinds (GHC.HsBind name) undefined for:" ++ (showGhc other) - - hsTyDecls _ = [] - -instance (GHC.OutputableBndr name,GHC.DataId name,Data name) - => HsValBinds (GHC.HsExpr name) name where - hsValBinds (GHC.HsLet ds _) = hsValBinds ds - hsValBinds x = error $ "TypeUtils.hsValBinds undefined for:" ++ showGhc x - - hsTyDecls _ = [] - -instance (GHC.OutputableBndr name,GHC.DataId name,Data name) - => HsValBinds (GHC.Stmt name (GHC.LHsExpr name)) name where - hsValBinds (GHC.LetStmt ds) = hsValBinds ds - hsValBinds other = error $ "hsValBinds (GHC.Stmt name) undefined for:" ++ (showGhc other) - - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.OutputableBndr name,GHC.DataId name,Data name) - => HsValBinds (GHC.LHsBinds name) name where - hsValBinds binds = hsValBinds $ GHC.bagToList binds - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.OutputableBndr name,GHC.DataId name,Data name) - => HsValBinds (GHC.LHsBind name) name where - hsValBinds (GHC.L _ (GHC.FunBind _ _ matches _ _ _)) = hsValBinds matches - hsValBinds (GHC.L _ (GHC.PatBind _ rhs _ _ _)) = hsValBinds rhs - hsValBinds (GHC.L _ (GHC.VarBind _ rhs _)) = hsValBinds rhs - hsValBinds (GHC.L _ (GHC.AbsBinds _ _ _ _ binds)) = hsValBinds binds - hsValBinds (GHC.L _ (GHC.PatSynBind _)) = error "hsValBinds: PaySynBind to implement" - - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,Data name) - => HsValBinds ([GHC.LHsBind name]) name where - -- hsValBinds xs = concatMap hsValBinds xs -- As in original - hsValBinds xs = GHC.ValBindsIn (GHC.listToBag xs) [] - - hsTyDecls _ = [] - -instance (GHC.OutputableBndr name,GHC.DataId name,Data name) - => HsValBinds (GHC.LHsExpr name) name where - hsValBinds (GHC.L _ (GHC.HsLet binds _ex)) = hsValBinds binds - hsValBinds _ = emptyValBinds - - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.OutputableBndr name,GHC.DataId name,Data name) - => HsValBinds [GHC.LGRHS name (GHC.LHsExpr name)] name where - hsValBinds xs = unionBinds $ map hsValBinds xs - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.OutputableBndr name,GHC.DataId name,Data name) - => HsValBinds (GHC.LGRHS name (GHC.LHsExpr name)) name where - hsValBinds (GHC.L _ (GHC.GRHS stmts _expr)) = hsValBinds stmts - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.OutputableBndr name,GHC.DataId name,Data name) - => HsValBinds [GHC.LStmt name (GHC.LHsExpr name)] name where - hsValBinds xs = unionBinds $ map hsValBinds xs - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.OutputableBndr name,GHC.DataId name,Data name) - => HsValBinds (GHC.LStmt name (GHC.LHsExpr name)) name where - hsValBinds (GHC.L _ (GHC.LetStmt binds)) = hsValBinds binds - hsValBinds _ = emptyValBinds - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.OutputableBndr name,GHC.DataId name,Data name) - => HsValBinds [GHC.LPat name] name where - hsValBinds _ = emptyValBinds - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.OutputableBndr name,GHC.DataId name,Data name) - => HsValBinds (GHC.LPat name) name where - hsValBinds _ = emptyValBinds - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - - -instance HsValBinds (GHC.Name) GHC.Name where - hsValBinds _ = emptyValBinds - hsTyDecls _ = [] - - --- --------------------------------------------------------------------- - -instance (GHC.OutputableBndr name,GHC.DataId name,Data name) - => HsValBinds [GHC.SyntaxExpr name] name where - hsValBinds _ = emptyValBinds - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.OutputableBndr name,GHC.DataId name,Data name) - => HsValBinds (GHC.TyClGroup name) name where - hsValBinds _ = emptyValBinds - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.OutputableBndr name,GHC.DataId name,Data name) - => HsValBinds [GHC.TyClGroup name] name where - hsValBinds _ = emptyValBinds - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.OutputableBndr name,GHC.DataId name,Data name) - => HsValBinds [[GHC.LTyClDecl name]] name where - hsValBinds _ = emptyValBinds - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.OutputableBndr name,GHC.DataId name,Data name) - => HsValBinds [GHC.LTyClDecl name] name where - hsValBinds _ = emptyValBinds - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.OutputableBndr name,GHC.DataId name,Data name) - => HsValBinds (GHC.LTyClDecl name) name where - hsValBinds _ = error $ "hsValBinds (GHC.LTyClDecl name) must pull out tcdMeths" - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.OutputableBndr name,GHC.DataId name,Data name) - => HsValBinds [GHC.LTyFamInstDecl name] name where - hsValBinds _ = error $ "hsValBinds [GHC.LTyFamInstDecl name] must pull out tcdMeths" - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.OutputableBndr name,GHC.DataId name,Data name) - => HsValBinds [GHC.LDataFamInstDecl name] name where - hsValBinds _ = error $ "hsValBinds [GHC.LDataFamInstDecl name] must pull out tcdMeths" - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,Data name) - => HsValBinds [GHC.LTyFamInstEqn name] name where - hsValBinds _ = error $ "hsValBinds [GHC.LTyFamInstEqn name] must pull out tcdMeths" - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,Data name) - => HsValBinds (GHC.LTyFamInstEqn name) name where - hsValBinds _ = error $ "hsValBinds (GHC.LTyFamInstEqn name) must pull out tcdMeths" - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.OutputableBndr name,GHC.DataId name,Data name) - => HsValBinds (GHC.HsDataDefn name) name where - hsValBinds _ = error $ "hsValBinds (GHC.HsDataDefn name) must pull out tcdMeths" - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.OutputableBndr name,GHC.DataId name,Data name) - => HsValBinds (GHC.HsTyPats name) name where - hsValBinds _ = error $ "hsValBinds (GHC.HsTyPats name) must pull out tcdMeths" - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.OutputableBndr name,GHC.DataId name,Data name) - => HsValBinds [GHC.LInstDecl name] name where - hsValBinds _ = emptyValBinds - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.OutputableBndr name,GHC.DataId name,Data name) - => HsValBinds (GHC.LInstDecl name) name where - hsValBinds _ = emptyValBinds - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.OutputableBndr name,GHC.DataId name,Data name) - => HsValBinds [GHC.LHsType name] name where - hsValBinds _ = emptyValBinds - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.OutputableBndr name,GHC.DataId name,Data name) - => HsValBinds (GHC.LHsType name) name where - hsValBinds _ = emptyValBinds - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.OutputableBndr name,GHC.DataId name,Data name) - => HsValBinds [GHC.LSig name] name where - hsValBinds _ = emptyValBinds - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.OutputableBndr name,GHC.DataId name,Data name) - => HsValBinds (GHC.LSig name) name where - hsValBinds _ = emptyValBinds - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance (GHC.OutputableBndr name,GHC.DataId name,Data name) - => HsValBinds (GHC.HsIPBinds name) name where - hsValBinds _ = emptyValBinds - hsTyDecls _ = [] - --- EOF - diff --git a/src/Language/Haskell/Refact/Utils/ExactPrint.hs b/src/Language/Haskell/Refact/Utils/ExactPrint.hs --- a/src/Language/Haskell/Refact/Utils/ExactPrint.hs +++ b/src/Language/Haskell/Refact/Utils/ExactPrint.hs @@ -8,18 +8,32 @@ replace , replaceAnnKey , copyAnn + + , setAnnKeywordDP + , clearPriorComments + , balanceAllComments ) where import qualified GHC as GHC import qualified Data.Generics as SYB +import Control.Monad + +import Language.Haskell.GHC.ExactPrint.Transform import Language.Haskell.GHC.ExactPrint.Types +-- import Language.Haskell.GHC.ExactPrint.Utils +import Language.Haskell.Refact.Utils.GhcUtils + import qualified Data.Map as Map -- --------------------------------------------------------------------- +-- ++AZ++:TODO: Move this to ghc-exactprint +-- |The annotations are keyed to the constructor, so if we replace a qualified +-- with an unqualified RdrName or vice versa we have to rebuild the key for the +-- appropriate annotation. replaceAnnKey :: (SYB.Data old,SYB.Data new) => GHC.Located old -> GHC.Located new -> Anns -> Anns replaceAnnKey old new ans = @@ -33,14 +47,13 @@ -- --------------------------------------------------------------------- +-- ++AZ++ TODO: migrate this to ghc-exactprint copyAnn :: (SYB.Data old,SYB.Data new) => GHC.Located old -> GHC.Located new -> Anns -> Anns copyAnn old new ans = case Map.lookup (mkAnnKey old) ans of Nothing -> ans - Just v -> anns' - where - anns' = Map.insert (mkAnnKey new) v ans + Just v -> Map.insert (mkAnnKey new) v ans -- --------------------------------------------------------------------- @@ -69,5 +82,81 @@ moveAnns [] xs = xs moveAnns ((_, dp): _) ((kw, _):xs) = (kw,dp) : xs moveAnns _ [] = [] + +-- --------------------------------------------------------------------- + +-- |Change the @DeltaPos@ for a given @KeywordId@ if it appears in the +-- annotation for the given item. +setAnnKeywordDP :: (SYB.Data a) => GHC.Located a -> KeywordId -> DeltaPos -> Transform () +setAnnKeywordDP la kw dp = modifyAnnsT changer + where + changer ans = case Map.lookup (mkAnnKey la) ans of + Nothing -> ans + Just an -> Map.insert (mkAnnKey la) (an {annsDP = map update (annsDP an)}) ans + update (kw',dp') + | kw == kw' = (kw',dp) + | otherwise = (kw',dp') + +-- --------------------------------------------------------------------- + +-- |Remove any preceding comments from the given item +clearPriorComments :: (SYB.Data a) => GHC.Located a -> Transform () +clearPriorComments la = do + edp <- getEntryDPT la + modifyAnnsT $ \ans -> + case Map.lookup (mkAnnKey la) ans of + Nothing -> ans + Just an -> Map.insert (mkAnnKey la) (an {annPriorComments = [] }) ans + setEntryDPT la edp + +-- --------------------------------------------------------------------- + +balanceAllComments :: SYB.Data a => GHC.Located a -> Transform (GHC.Located a) +balanceAllComments la + -- Must be top-down + = everywhereM' (SYB.mkM inMod + `SYB.extM` inExpr + `SYB.extM` inMatch + `SYB.extM` inStmt + ) la + where + inMod :: GHC.ParsedSource -> Transform (GHC.ParsedSource) + inMod m = doBalance m + + inExpr :: GHC.LHsExpr GHC.RdrName -> Transform (GHC.LHsExpr GHC.RdrName) + inExpr e = doBalance e + + inMatch :: (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) -> Transform (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) + inMatch m = doBalance m + + inStmt :: GHC.LStmt GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> Transform (GHC.LStmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) + inStmt s = doBalance s + + -- |Balance all comments between adjacent decls, as well as pushing all + -- trailing comments to the right place. + {- + e.g., for + + foo = do + return x + where + x = ['a'] -- do + + bar = undefined + + the "-- do" comment must end up in the trailing comments for "x = ['a']" + -} + doBalance t = do + decls <- hsDecls t + let + go [] = return [] + go [x] = return [x] + go (x1:x2:xs) = do + balanceComments x1 x2 + go (x2:xs) + _ <- go decls + -- replaceDecls t decls' + unless (null decls) $ moveTrailingComments t (last decls) + return t -- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/Refact/Utils/GhcModuleGraph.hs b/src/Language/Haskell/Refact/Utils/GhcModuleGraph.hs --- a/src/Language/Haskell/Refact/Utils/GhcModuleGraph.hs +++ b/src/Language/Haskell/Refact/Utils/GhcModuleGraph.hs @@ -1,4 +1,5 @@ {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE CPP #-} module Language.Haskell.Refact.Utils.GhcModuleGraph ( @@ -7,12 +8,16 @@ ) where -- GHC imports +#if __GLASGOW_HASKELL__ > 710 +import BasicTypes +#endif import Digraph import FastString import GHC import HscTypes import Panic + -- Other imports import qualified Data.Map as Map @@ -185,11 +190,13 @@ ++ [ (m,False) | m <- ms_home_imps s ] -} +#if __GLASGOW_HASKELL__ <= 710 home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName] home_imps imps = [ ideclName i | L _ i <- imps, isLocal (ideclPkgQual i) ] where isLocal Nothing = True isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special isLocal _ = False +#endif {- ms_home_allimps :: ModSummary -> [ModuleName] @@ -197,9 +204,17 @@ -} ms_home_srcimps :: ModSummary -> [Located ModuleName] +#if __GLASGOW_HASKELL__ <= 710 ms_home_srcimps = home_imps . ms_srcimps +#else +ms_home_srcimps ms = map snd $ ms_srcimps ms +#endif ms_home_imps :: ModSummary -> [Located ModuleName] +#if __GLASGOW_HASKELL__ <= 710 ms_home_imps = home_imps . ms_imps +#else +ms_home_imps ms = map snd $ ms_imps ms +#endif -- GHC source end diff --git a/src/Language/Haskell/Refact/Utils/GhcUtils.hs b/src/Language/Haskell/Refact/Utils/GhcUtils.hs --- a/src/Language/Haskell/Refact/Utils/GhcUtils.hs +++ b/src/Language/Haskell/Refact/Utils/GhcUtils.hs @@ -19,7 +19,6 @@ , everywhereMStaged' , everywhereStaged , everywhereStaged' - , onelayerStaged , listifyStaged -- ** SYB Utility @@ -143,7 +142,7 @@ -} -- --------------------------------------------------------------------- - +{- -- |Perform a query on the immediate subterms only, avoiding holes onelayerStaged :: SYB.Stage -> r -> SYB.GenericQ r -> SYB.GenericQ [r] onelayerStaged _stage _z f t = gmapQ stagedF t @@ -154,7 +153,7 @@ | checkItemStage stage x = z #endif | otherwise = f x - +-} -- --------------------------------------------------------------------- -- | Staged variation of SYB.listify diff --git a/src/Language/Haskell/Refact/Utils/Monad.hs b/src/Language/Haskell/Refact/Utils/Monad.hs --- a/src/Language/Haskell/Refact/Utils/Monad.hs +++ b/src/Language/Haskell/Refact/Utils/Monad.hs @@ -16,6 +16,7 @@ , RefactSettings(..) , RefactState(..) , RefactModule(..) + , RefacSource(..) , TargetModule , Targets , CabalGraph @@ -145,6 +146,11 @@ When HaRe needs a new SrcSpan, for this, it generates it from this field, to ensure uniqueness. -} + +data RefacSource = RSFile FilePath + | RSTarget TargetModule + | RSMod GHC.ModSummary + | RSAlreadyLoaded type TargetModule = GM.ModulePath -- From ghc-mod diff --git a/src/Language/Haskell/Refact/Utils/MonadFunctions.hs b/src/Language/Haskell/Refact/Utils/MonadFunctions.hs --- a/src/Language/Haskell/Refact/Utils/MonadFunctions.hs +++ b/src/Language/Haskell/Refact/Utils/MonadFunctions.hs @@ -4,6 +4,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE CPP #-} -- | @@ -41,6 +42,7 @@ , getRefactModule , getRefactModuleName , getRefactNameMap + , addToNameMap -- * New ghc-exactprint interfacing , liftT @@ -64,6 +66,7 @@ , logDataWithAnns , logAnns , logParsedSource + , logExactprint -- * For use by the tests only , initRefactModule @@ -79,10 +82,14 @@ import qualified Module as GHC import qualified Name as GHC import qualified Unique as GHC +#if __GLASGOW_HASKELL__ > 710 +import qualified Var +#endif import qualified Data.Generics as SYB import Language.Haskell.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint.Annotate import Language.Haskell.GHC.ExactPrint.Parsers import Language.Haskell.GHC.ExactPrint.Utils @@ -345,6 +352,20 @@ -- --------------------------------------------------------------------- +addToNameMap :: GHC.SrcSpan -> GHC.Name -> RefactGhc () +addToNameMap ss n = do + s <- get + let mtm = rsModule s + case mtm of + Nothing -> error $ "Hare.MonadFunctions.addToNameMap:no module loaded" + Just tm -> do + let nm = rsNameMap tm + nm' = Map.insert ss n nm + mtm' = Just tm { rsNameMap = nm'} + put s { rsModule = mtm'} + +-- --------------------------------------------------------------------- + getRefactDone :: RefactGhc Bool getRefactDone = do flags <- gets rsFlags @@ -384,6 +405,13 @@ -- --------------------------------------------------------------------- +logExactprint :: (Annotate a) => String -> GHC.Located a -> RefactGhc () +logExactprint str ast = do + anns <- getRefactAnns + logm $ str ++ "\n[" ++ exactPrint ast anns ++ "]" + +-- --------------------------------------------------------------------- + logAnns :: String -> RefactGhc () logAnns str = do anns <- getRefactAnns @@ -427,6 +455,9 @@ where parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module tm renamed = gfromJust "initRdrNameMap" $ GHC.tm_renamed_source tm +#if __GLASGOW_HASKELL__ > 710 + typechecked = GHC.tm_typechecked_source tm +#endif checkRdr :: GHC.Located GHC.RdrName -> Maybe [(GHC.SrcSpan,GHC.RdrName)] checkRdr (GHC.L l n@(GHC.Unqual _)) = Just [(l,n)] @@ -437,8 +468,26 @@ checkName ln = Just [ln] rdrNames = gfromJust "initRdrNameMap" $ SYB.everything mappend (nameSybQuery checkRdr ) parsed +#if __GLASGOW_HASKELL__ <= 710 names = gfromJust "initRdrNameMap" $ SYB.everything mappend (nameSybQuery checkName) renamed +#else + names1 = gfromJust "initRdrNameMap" $ SYB.everything mappend (nameSybQuery checkName) renamed + names2 = names1 ++ SYB.everything (++) ([] `SYB.mkQ` fieldOcc + `SYB.extQ` hsRecFieldN) renamed + names = names2 ++ SYB.everything (++) ([] `SYB.mkQ` hsRecFieldT) typechecked + fieldOcc :: GHC.FieldOcc GHC.Name -> [GHC.Located GHC.Name] + fieldOcc (GHC.FieldOcc (GHC.L l _) n) = [(GHC.L l n)] + + hsRecFieldN :: GHC.LHsExpr GHC.Name -> [GHC.Located GHC.Name] + hsRecFieldN (GHC.L _ (GHC.HsRecFld (GHC.Unambiguous (GHC.L l _) n) )) = [GHC.L l n] + hsRecFieldN _ = [] + + hsRecFieldT :: GHC.LHsExpr GHC.Id -> [GHC.Located GHC.Name] + hsRecFieldT (GHC.L _ (GHC.HsRecFld (GHC.Ambiguous (GHC.L l _) n) )) = [GHC.L l (Var.varName n)] + hsRecFieldT _ = [] +#endif + nameMap = Map.fromList $ map (\(GHC.L l n) -> (l,n)) names -- If the name does not exist (e.g. a TH Splice that has been expanded, make a new one) @@ -447,7 +496,11 @@ Just v -> v Nothing -> case n of GHC.Unqual u -> mkNewGhcNamePure 'h' i Nothing (GHC.occNameString u) +#if __GLASGOW_HASKELL__ <= 710 GHC.Qual q u -> mkNewGhcNamePure 'h' i (Just (GHC.Module (GHC.stringToPackageKey "") q)) (GHC.occNameString u) +#else + GHC.Qual q u -> mkNewGhcNamePure 'h' i (Just (GHC.Module (GHC.stringToUnitId "") q)) (GHC.occNameString u) +#endif _ -> error "initRdrNameMap:should not happen" r = Map.fromList $ map (\((l,n),i) -> (l,lookupName l n i)) $ zip rdrNames [1..] @@ -469,15 +522,18 @@ nameSybTransform changer = q where q = SYB.mkM worker +#if __GLASGOW_HASKELL__ <= 710 `SYB.extM` workerBind `SYB.extM` workerExpr `SYB.extM` workerLIE `SYB.extM` workerHsTyVarBndr `SYB.extM` workerLHsType +#endif worker (pnt :: (GHC.Located GHC.RdrName)) = changer pnt +#if __GLASGOW_HASKELL__ <= 710 workerBind (GHC.L l (GHC.VarPat name)) = do (GHC.L _ n) <- changer (GHC.L l name) @@ -507,6 +563,7 @@ (GHC.L _ n) <- changer (GHC.L l name) return (GHC.L l (GHC.HsTyVar n)) workerLHsType x = return x +#endif -- --------------------------------------------------------------------- @@ -515,15 +572,18 @@ nameSybQuery checker = q where q = Nothing `SYB.mkQ` worker +#if __GLASGOW_HASKELL__ <= 710 `SYB.extQ` workerBind `SYB.extQ` workerExpr - `SYB.extQ` workerLIE + -- `SYB.extQ` workerLIE `SYB.extQ` workerHsTyVarBndr `SYB.extQ` workerLHsType +#endif worker (pnt :: (GHC.Located a)) = checker pnt +#if __GLASGOW_HASKELL__ <= 710 workerBind (GHC.L l (GHC.VarPat name)) = checker (GHC.L l name) workerBind _ = Nothing @@ -532,9 +592,9 @@ = checker (GHC.L l name) workerExpr _ = Nothing - workerLIE ((GHC.L _l (GHC.IEVar (GHC.L ln name))) :: (GHC.LIE a)) - = checker (GHC.L ln name) - workerLIE _ = Nothing + -- workerLIE ((GHC.L _l (GHC.IEVar (GHC.L ln name))) :: (GHC.LIE a)) + -- = checker (GHC.L ln name) + -- workerLIE _ = Nothing workerHsTyVarBndr ((GHC.L l (GHC.UserTyVar name))) = checker (GHC.L l name) @@ -543,12 +603,15 @@ workerLHsType ((GHC.L l (GHC.HsTyVar name))) = checker (GHC.L l name) workerLHsType _ = Nothing +#endif -- --------------------------------------------------------------------- parseDeclWithAnns :: String -> RefactGhc (GHC.LHsDecl GHC.RdrName) parseDeclWithAnns src = do - let label = " parseDecl df label src) case r of Left err -> error (show err) diff --git a/src/Language/Haskell/Refact/Utils/TypeSyn.hs b/src/Language/Haskell/Refact/Utils/TypeSyn.hs --- a/src/Language/Haskell/Refact/Utils/TypeSyn.hs +++ b/src/Language/Haskell/Refact/Utils/TypeSyn.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} -- | This is a legacy module from the pre-GHC HaRe, and will disappear -- eventually. @@ -80,12 +81,13 @@ GHC.<+> GHC.ppr name GHC.<+> GHC.ppr typ GHC.<+> GHC.ppr doc - +#if __GLASGOW_HASKELL__ <= 710 instance GHC.Outputable (GHC.TyFamEqn GHC.Name (GHC.LHsTyVarBndrs GHC.Name)) where ppr (GHC.TyFamEqn name pats rhs) = GHC.text "TyFamEqn" GHC.<+> GHC.ppr name GHC.<+> GHC.ppr pats GHC.<+> GHC.ppr rhs +#endif -- --------------------------------------------------------------------- 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 @@ -43,2247 +43,2547 @@ inScopeInfo, isInScopeAndUnqualified, isInScopeAndUnqualifiedGhc, inScopeNames , isExported, isExplicitlyExported, modIsExported , equivalentNameInNewMod - - -- ** Property checking - ,isVarId,isConId,isOperator,isTopLevelPN,isLocalPN,isNonLibraryName - ,isQualifiedPN, isFunOrPatName, isTypeSig, isTypeSigDecl - ,isFunBindP,isFunBindR,isPatBindP,isPatBindR,isSimplePatBind,isSimplePatDecl - ,isComplexPatBind,isComplexPatDecl,isFunOrPatBindP,isFunOrPatBindR - ,usedWithoutQualR,isUsedInRhs - - -- ** Getting - ,findNameInRdr - ,findPNT,findPN,findAllNameOccurences - ,findPNs, findNamesRdr, findEntity, findEntity' - ,findIdForName - ,getTypeForName - - ,defines, definesP,definesTypeSig,definesTypeSigRdr - ,sameBind,sameBindRdr - ,UsedByRhs(..) - - -- ** Modules and files - -- ,clientModsAndFiles,serverModsAndFiles,isAnExistingMod - -- ,fileNameToModName, strToModName, modNameToStr - , isMainModule - , getModule - - -- ** Locations - ,defineLoc, useLoc, locToExp - ,locToName, locToRdrName - ,getName - - -- * Program transformation - -- ** Adding - ,addDecl, addItemsToImport, addItemsToExport, addHiding - ,addParamsToDecls, addActualParamsToRhs, addImportDecl, duplicateDecl - -- ** Removing - ,rmDecl, rmTypeSig, rmTypeSigs -- , commentOutTypeSig, rmParams - -- ,rmItemsFromExport, rmSubEntsFromExport, Delete(delete) - - -- ** Updating - , rmQualifier, qualifyToplevelName, renamePN, autoRenameLocalVar - - -- ** Identifiers, expressions, patterns and declarations - ,ghcToPN,lghcToPN, expToName, expToNameRdr - ,nameToString - ,patToNameRdr - , patToPNT, pNtoPat - - -- ** Others - , divideDecls - , mkRdrName,mkNewGhcName,mkNewName,mkNewToplevelName - - -- The following functions are not in the the API yet. - , causeNameClashInExports {- , inRegion , unmodified -} - - , declsSybTransform - - -- * Typed AST traversals (added by CMB) - -- * Miscellous - -- ,removeFromInts, getDataName, checkTypes, getPNs, getPN, getPNPats, mapASTOverTAST - - -- * Debug stuff - , getParsedForRenamedLPat - , getParsedForRenamedName - , getParsedForRenamedLocated - , rdrNameFromName - , stripLeadingSpaces - ) where - -import Control.Monad.State -import Data.Char -import Data.Foldable -import Data.List -import Data.Maybe -import Exception - -import Language.Haskell.Refact.Utils.ExactPrint -import Language.Haskell.Refact.Utils.GhcUtils -import Language.Haskell.Refact.Utils.GhcVersionSpecific -import Language.Haskell.Refact.Utils.LocUtils -import Language.Haskell.Refact.Utils.Monad -import Language.Haskell.Refact.Utils.MonadFunctions -import Language.Haskell.Refact.Utils.TypeSyn -import Language.Haskell.Refact.Utils.Types -import Language.Haskell.Refact.Utils.Variables - -import Language.Haskell.GHC.ExactPrint -import Language.Haskell.GHC.ExactPrint.Types -import Language.Haskell.GHC.ExactPrint.Utils - - --- Modules from GHC -import qualified Bag as GHC -import qualified FastString as GHC -import qualified GHC as GHC -import qualified Module as GHC -import qualified Name as GHC --- import qualified Outputable as GHC -import qualified RdrName as GHC -import qualified Unique as GHC -import qualified Var as GHC - -import qualified Data.Generics as SYB -import qualified GHC.SYB.Utils as SYB - -import qualified Data.Map as Map - -import Data.Generics.Strafunski.StrategyLib.StrategyLib hiding (liftIO,MonadPlus,mzero) - --- --------------------------------------------------------------------- --- |Process the inscope relation returned from the parsing and module --- analysis pass, and return a list of four-element tuples. Each tuple --- contains an identifier name, the identifier's namespace info, the --- identifier's defining module name and its qualifier name. --- --- The same identifier may have multiple entries in the result because --- it may have different qualifiers. This makes it easier to decide --- whether the identifier can be used unqualifiedly by just checking --- whether there is an entry for it with the qualifier field being --- Nothing. --- -inScopeInfo :: InScopes -- ^ The inscope relation . - ->[(String, GHC.NameSpace, GHC.ModuleName, Maybe GHC.ModuleName)] -- ^ The result -inScopeInfo names = nub $ map getEntInfo $ names - where - getEntInfo name - =(showGhc name, - GHC.occNameSpace $ GHC.nameOccName name, - GHC.moduleName $ GHC.nameModule name, - getQualMaybe $ GHC.nameRdrName name) - - getQualMaybe rdrName = case rdrName of - GHC.Qual modName _occName -> Just modName - _ -> Nothing - - --- --------------------------------------------------------------------- - --- | Return True if the identifier is inscope and can be used without --- a qualifier. -isInScopeAndUnqualified::String -- ^ The identifier name. - ->InScopes -- ^ The inscope relation - ->Bool -- ^ The result. -isInScopeAndUnqualified n names - = isJust $ find (\ (x, _,_, qual) -> x == n && isNothing qual ) $ inScopeInfo names - --- | Return True if the identifier is inscope and can be used without --- a qualifier. The identifier name string may have a qualifier --- already --- NOTE: may require qualification based on name clash with an --- existing identifier. -isInScopeAndUnqualifiedGhc :: - String -- ^ The identifier name. - -> (Maybe GHC.Name) -- ^ Existing name, to be excluded from test, if - -- known - -> RefactGhc Bool -- ^ The result. -isInScopeAndUnqualifiedGhc n maybeExising = do - names <- ghandle handler (GHC.parseName n) - logm $ "isInScopeAndUnqualifiedGhc:(n,(maybeExising,names))=" ++ (show n) ++ ":" ++ (showGhc (maybeExising,names)) - ctx <- GHC.getContext - logm $ "isInScopeAndUnqualifiedGhc:ctx=" ++ (showGhc ctx) - let nameList = case maybeExising of - Nothing -> names - Just n' -> filter (\x -> (showGhcQual x) /= (showGhcQual n')) names - logm $ "isInScopeAndUnqualifiedGhc:(n,nameList)=" ++ (show n) ++ ":" ++ (showGhc nameList) - return $ nameList /= [] - - where - handler:: SomeException -> RefactGhc [GHC.Name] - handler e = do - logm $ "isInScopeAndUnqualifiedGhc.handler e=" ++ (show e) - return [] - --- --------------------------------------------------------------------- - --- |Return all 'GHC.Name's that correspond to the given string, in the current --- module. - --- Note: this returns a list because TH constructor names do not have the --- correct namespace so the two variants are returned, constructor and --- non-constructor. I suspect that when this is looked up only one will ever --- come through. Hence we should only ever see 0 or 1 names here. -inScopeNames :: String -- ^ The identifier name. - -> RefactGhc [GHC.Name] -- ^ The result. -inScopeNames n = do - names <- ghandle handler (GHC.parseName n) - logm $ "inScopeNames:(n,names)=" ++ (show n) ++ ":" ++ (showGhc names) - return $ names - - where - handler:: SomeException -> RefactGhc [GHC.Name] - handler e = do - logm $ "inScopeNames.handler e=" ++ (show e) - return [] - --- --------------------------------------------------------------------- - --- |Given a 'GHC.Name' defined in one module, find the equivalent one in the --- currently loaded module. This is required otherwise name equality checking --- based on 'GHC.nameUnique' will fail. -equivalentNameInNewMod :: GHC.Name -> RefactGhc [GHC.Name] -equivalentNameInNewMod old = do - -- we have to do it this way otherwise names imported qualified will not be - -- detected - gnames <- GHC.getNamesInScope - let clientModule = GHC.nameModule old - let clientInscopes = filter (\n -> clientModule == GHC.nameModule n) gnames - let newNames = filter (\n -> showGhcQual n == showGhcQual old) clientInscopes - return newNames - --- --------------------------------------------------------------------- - --- TODO: get rid of this -defaultName :: GHC.Name -defaultName = n - where - un = GHC.mkUnique 'H' 0 -- H for HaRe :) - n = GHC.localiseName $ GHC.mkSystemName un (GHC.mkVarOcc "nothing") - --- --------------------------------------------------------------------- - --- |Make a simple unqualified 'GHC.RdrName' -mkRdrName :: String -> GHC.RdrName -mkRdrName s = GHC.mkVarUnqual (GHC.mkFastString s) - - --- | Make a new GHC.Name, using the Unique Int sequence stored in the --- RefactState. -mkNewGhcName :: Maybe GHC.Module -> String -> RefactGhc GHC.Name -mkNewGhcName maybeMod name = do - s <- get - u <- gets rsUniqState - put s { rsUniqState = (u+1) } - return (mkNewGhcNamePure 'H' (u + 1) maybeMod name) - - --- --------------------------------------------------------------------- - -mkNewToplevelName :: GHC.Module -> String -> GHC.SrcSpan -> RefactGhc GHC.Name -mkNewToplevelName modid name defLoc = do - s <- get - u <- gets rsUniqState - put s { rsUniqState = (u+1) } - - let un = GHC.mkUnique 'H' (u+1) -- H for HaRe :) - n = GHC.mkExternalName un modid (GHC.mkVarOcc name) defLoc - return n - ---------------------------------------------------------------------------- - - --- |Create a new name base on the old name. Suppose the old name is 'f', then --- the new name would be like 'f_i' where 'i' is an integer. -mkNewName::String -- ^ The old name - ->[String] -- ^ The set of names which the new name cannot take - ->Int -- ^ The posfix value - ->String -- ^ The result -mkNewName oldName fds suffix - =let newName=if suffix==0 then oldName - else oldName++"_"++ show suffix - in if elem newName fds - then mkNewName oldName fds (suffix+1) - else newName - --- --------------------------------------------------------------------- - --- | Return True if the current module is exported either by default --- or by specifying the module name in the export. -modIsExported:: GHC.ModuleName -- ^ The module name - -> GHC.RenamedSource -- ^ The AST of the module - -> Bool -- ^ The result -modIsExported modName (_g,_emps,mexps,_mdocs) - = let - modExported (GHC.L _ (GHC.IEModuleContents (GHC.L _ name))) = name == modName - modExported _ = False - - moduleExports = filter modExported $ fromMaybe [] mexps - - in if isNothing mexps - then True - else (nonEmptyList moduleExports) - --- --------------------------------------------------------------------- - --- | Return True if an identifier is exported by the module currently --- being refactored. -isExported :: GHC.Name -> RefactGhc Bool -isExported n = do - typechecked <- getTypecheckedModule - let modInfo = GHC.tm_checked_module_info typechecked - return $ GHC.modInfoIsExportedName modInfo n - --- --------------------------------------------------------------------- - --- | Return True if an identifier is explicitly exported by the module. -isExplicitlyExported::GHC.Name -- ^ The identifier - ->GHC.RenamedSource -- ^ The AST of the module - ->Bool -- ^ The result -isExplicitlyExported pn (_g,_imps,exps,_docs) - = findEntity pn exps - --- --------------------------------------------------------------------- - - --- | Check if the proposed new name will conflict with an existing export -causeNameClashInExports:: GHC.Name -- ^ The original name - -> GHC.Name -- ^ The new name - -> GHC.ModuleName -- ^ The identity of the module - -> GHC.RenamedSource -- ^ The AST of the module - -> Bool -- ^ The result - --- Note that in the abstract representation of exps, there is no qualified entities. -causeNameClashInExports pn newName modName renamed@(_g,imps,maybeExps,_doc) - = let exps = fromMaybe [] maybeExps - varExps = filter isImpVar exps - -- TODO: make withoutQual part of the API - withoutQual n = showGhc $ GHC.localiseName n - modNames=nub (concatMap (\(GHC.L _ (GHC.IEVar (GHC.L _ x)))->if withoutQual x== withoutQual newName - then [GHC.moduleName $ GHC.nameModule x] - else []) varExps) - res = (isExplicitlyExported pn renamed) && - ( any (modIsUnQualifedImported renamed) modNames - || elem modName modNames) - in res - where - isImpVar (GHC.L _ x) = case x of - GHC.IEVar _ -> True - _ -> False - - modIsUnQualifedImported _mod' modName' - =let - in isJust $ find (\(GHC.L _ (GHC.ImportDecl _ (GHC.L _ modName1) _qualify _source _safe isQualified _isImplicit _as _h)) - -> modName1 == modName' && (not isQualified)) imps - --- Original seems to be --- 1. pick up any module names in the export list with same unQual - -- part as the new name --- 2. Check if the old is exported explicitly --- 3. if so, if the new module is exported unqualified --- or belongs to the current module --- then it will cause a clash - --- --------------------------------------------------------------------- - --- | Given a RenamedSource LPAT, return the equivalent --- ParsedSource part. --- NOTE: returns pristine ParsedSource, since HaRe does not change it -getParsedForRenamedLPat :: GHC.ParsedSource -> GHC.LPat GHC.Name -> GHC.LPat GHC.RdrName -getParsedForRenamedLPat parsed lpatParam@(GHC.L l _pat) = r - where - mres = res parsed - r = case mres of - Just rr -> rr - Nothing -> error $ "HaRe error: could not find Parsed LPat for" - ++ (SYB.showData SYB.Renamer 0 lpatParam) - - res t = SYB.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` lpat) t - - lpat :: (GHC.LPat GHC.RdrName) -> (Maybe (GHC.LPat GHC.RdrName)) - lpat p@(GHC.L lp _) - | lp == l = Just p - lpat _ = Nothing - --- --------------------------------------------------------------------- - --- | Given a RenamedSource Located name, return the equivalent --- ParsedSource part. --- NOTE: returns pristine ParsedSource, since HaRe does not change it -getParsedForRenamedLocated :: ({- SYB.Typeable a, SYB.Data a, -} SYB.Typeable b {- , SYB.Data b -}) - => GHC.Located a -> RefactGhc (GHC.Located b) -getParsedForRenamedLocated (GHC.L l _n) = do - parsed <- getRefactParsed - let - mres = res parsed - r = case mres of - Just rr -> rr - Nothing -> error $ "HaRe error: could not find Parsed Location for" - ++ (showGhc l) - - res t = SYB.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` lname) t - - lname :: (GHC.Located b) -> (Maybe (GHC.Located b)) - lname p@(GHC.L lp _) - | lp == l = Just p - lname _ = Nothing - - return r - - --- | Given a RenamedSource Located name, return the equivalent --- ParsedSource part. --- NOTE: returns pristine ParsedSource, since HaRe does not change it -getParsedForRenamedName :: GHC.ParsedSource -> GHC.Located GHC.Name -> GHC.Located GHC.RdrName -getParsedForRenamedName parsed n@(GHC.L l _n) = r - where - mres = res parsed - r = case mres of - Just rr -> rr - Nothing -> error $ "HaRe error: could not find Parsed LPat for" - ++ (SYB.showData SYB.Renamer 0 n) - - res t = SYB.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` lname) t - - lname :: (GHC.Located GHC.RdrName) -> (Maybe (GHC.Located GHC.RdrName)) - lname p@(GHC.L lp _) - | lp == l = Just p - lname _ = Nothing - ------------------------------------------------------------------------- - --- | Return True if the identifier is unqualifiedly used in the given --- syntax phrase. --- usedWithoutQualR :: GHC.Name -> GHC.ParsedSource -> Bool -usedWithoutQualR :: (SYB.Data t) => GHC.Name -> t -> Bool -usedWithoutQualR name parsed = fromMaybe False res - where - res = SYB.somethingStaged SYB.Parser Nothing - (Nothing `SYB.mkQ` worker - `SYB.extQ` workerBind - `SYB.extQ` workerExpr - ) parsed - - worker (pname :: GHC.Located GHC.RdrName) = - checkName pname - - workerBind (GHC.L l (GHC.VarPat n) :: (GHC.Located (GHC.Pat GHC.RdrName))) = - checkName (GHC.L l n) - workerBind _ = Nothing - - workerExpr ((GHC.L l (GHC.HsVar n)) :: (GHC.Located (GHC.HsExpr GHC.RdrName))) - = checkName (GHC.L l n) - workerExpr _ = Nothing - - -- ---------------- - - checkName ((GHC.L l pn)::GHC.Located GHC.RdrName) - | ((GHC.rdrNameOcc pn) == (GHC.nameOccName name)) && - isUsedInRhs (GHC.L l name) parsed && - GHC.isUnqual pn = Just True - checkName _ = Nothing - - ------------------------------------------------------------------------------ - -getModule :: RefactGhc GHC.Module -getModule = do - typechecked <- getTypecheckedModule - return $ GHC.ms_mod $ GHC.pm_mod_summary $ GHC.tm_parsed_module typechecked - --- --------------------------------------------------------------------- - --- | Return True if a string is a lexically valid variable name. -isVarId :: String -> Bool -isVarId mid = isId mid && isSmall (ghead "isVarId" mid) - where isSmall c=isLower c || c=='_' - --- | Return True if a string is a lexically valid constructor name. -isConId :: String -> Bool -isConId mid = isId mid && isUpper (ghead "isConId" mid) - --- | Return True if a string is a lexically valid operator name. -isOperator :: String -> Bool -isOperator mid = mid /= [] && isOpSym (ghead "isOperator" mid) && - isLegalOpTail (tail mid) && not (isReservedOp mid) - where - isOpSym mid' = elem mid' opSymbols - where opSymbols = ['!', '#', '$', '%', '&', '*', '+','.','/','<','=','>','?','@','\'','^','|','-','~'] - - isLegalOpTail tail' = all isLegal tail' - where isLegal c = isOpSym c || c==':' - - isReservedOp mid' = elem mid' reservedOps - where reservedOps = ["..", ":","::","=","\"", "|","<-","@","~","=>"] - --- | Returns True if a string lexically is an identifier. --- *This function should not be exported.* -isId::String->Bool -isId mid = mid/=[] && isLegalIdTail (tail mid) && not (isReservedId mid) - where - isLegalIdTail tail' = all isLegal tail' - where isLegal c=isSmall c|| isUpper c || isDigit c || c=='\'' - - isReservedId mid' = elem mid' reservedIds - where reservedIds=["case", "class", "data", "default", "deriving","do","else" ,"if", - "import", "in", "infix","infixl","infixr","instance","let","module", - "newtype", "of","then","type","where","_"] - - isSmall c=isLower c || c=='_' - ------------------------------------------------------------------------------ - --- |Return True if a PName is a toplevel PName. -isTopLevelPN::GHC.Name -> RefactGhc Bool -isTopLevelPN n = do - typechecked <- getTypecheckedModule - let maybeNames = GHC.modInfoTopLevelScope $ GHC.tm_checked_module_info typechecked - let names = fromMaybe [] maybeNames - return $ n `elem` names - - --- |Return True if a PName is a local PName. -isLocalPN::GHC.Name -> Bool -isLocalPN = GHC.isInternalName - --- |Return True if the name has a @GHC.SrcSpan@, i.e. is declared in --- source we care about -isNonLibraryName :: GHC.Name -> Bool -isNonLibraryName n = case (GHC.nameSrcSpan n) of - GHC.UnhelpfulSpan _ -> False - _ -> True - - --- |Return True if a PName is a function\/pattern name defined in t. -isFunOrPatName::(SYB.Data t) => GHC.Name -> t -> Bool -isFunOrPatName pn - =isJust . SYB.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` worker) - where - worker (decl::GHC.LHsBind GHC.Name) - | defines pn decl = Just True - worker _ = Nothing - -------------------------------------------------------------------------------- --- |Return True if a PName is a qualified PName. --- AZ:NOTE: this tests the use instance, the underlying name may be qualified. --- e.g. used name is zip, GHC.List.zip --- NOTE2: not sure if this gives a meaningful result for a GHC.Name -isQualifiedPN :: GHC.Name -> RefactGhc Bool -isQualifiedPN name = return $ GHC.isQual $ GHC.nameRdrName name - - --- | Return True if a declaration is a type signature declaration. -isTypeSig :: GHC.LSig a -> Bool -isTypeSig (GHC.L _ (GHC.TypeSig _ _ _)) = True -isTypeSig _ = False - --- | Return True if a declaration is a type signature declaration. -isTypeSigDecl :: GHC.LHsDecl a -> Bool -isTypeSigDecl (GHC.L _ (GHC.SigD (GHC.TypeSig _ _ _))) = True -isTypeSigDecl _ = False - --- | Return True if a declaration is a function definition. -isFunBindP::HsDeclP -> Bool -isFunBindP (GHC.L _ (GHC.ValD (GHC.FunBind _ _ _ _ _ _))) = True -isFunBindP _ =False - -isFunBindR::GHC.LHsBind t -> Bool -isFunBindR (GHC.L _l (GHC.FunBind _ _ _ _ _ _)) = True -isFunBindR _ =False - --- | Returns True if a declaration is a pattern binding. -isPatBindP::HsDeclP->Bool -isPatBindP (GHC.L _ (GHC.ValD (GHC.PatBind _ _ _ _ _))) = True -isPatBindP _=False - -isPatBindR::GHC.LHsBind t -> Bool -isPatBindR (GHC.L _ (GHC.PatBind _ _ _ _ _)) = True -isPatBindR _=False - - --- | Return True if a declaration is a pattern binding which only --- defines a variable value. -isSimplePatDecl :: (GHC.DataId t) => GHC.LHsDecl t-> Bool -isSimplePatDecl decl = case decl of - (GHC.L _l (GHC.ValD (GHC.PatBind p _rhs _ty _fvs _))) -> hsPNs p /= [] - _ -> False - --- | Return True if a declaration is a pattern binding which only --- defines a variable value. -isSimplePatBind :: (GHC.DataId t) => GHC.LHsBind t-> Bool -isSimplePatBind decl = case decl of - (GHC.L _l (GHC.PatBind p _rhs _ty _fvs _)) -> hsPNs p /= [] - _ -> False - --- | Return True if a declaration is a pattern binding but not a simple one. -isComplexPatDecl::GHC.LHsDecl name -> Bool -isComplexPatDecl (GHC.L l (GHC.ValD decl)) = isComplexPatBind (GHC.L l decl) -isComplexPatDecl _ = False - --- | Return True if a LHsBin is a pattern binding but not a simple one. -isComplexPatBind::GHC.LHsBind name -> Bool -isComplexPatBind decl - = case decl of - (GHC.L _l (GHC.PatBind (GHC.L _ (GHC.VarPat _)) _rhs _ty _fvs _)) -> True - _ -> False - --- | Return True if a declaration is a function\/pattern definition. -isFunOrPatBindP :: HsDeclP -> Bool -isFunOrPatBindP decl = isFunBindP decl || isPatBindP decl - --- | Return True if a declaration is a function\/pattern definition. -isFunOrPatBindR :: GHC.LHsBind t -> Bool -isFunOrPatBindR decl = isFunBindR decl || isPatBindR decl - --- --------------------------------------------------------------------- - - --- | Returns True is a syntax phrase, say a, is part of another syntax --- phrase, say b. --- Expects to be at least Parser output -findEntity':: (SYB.Data a, SYB.Data b) - => a -> b -> Maybe (SimpPos,SimpPos) -findEntity' a b = res - where - -- ++AZ++ do a generic traversal, and see if it matches. - res = SYB.somethingStaged SYB.Parser Nothing worker b - - worker :: (SYB.Data c) - => c -> Maybe (SimpPos,SimpPos) - worker x = if SYB.typeOf a == SYB.typeOf x - -- then Just (getStartEndLoc b == getStartEndLoc a) - then Just (getStartEndLoc x) - else Nothing - --------------------------------------------------------------------------------- - -sameBindRdr :: NameMap -> GHC.LHsDecl GHC.RdrName -> GHC.LHsDecl GHC.RdrName -> Bool -sameBindRdr nm b1 b2 = (definedNamesRdr nm b1) == (definedNamesRdr nm b2) - -sameBind :: GHC.LHsBind GHC.Name -> GHC.LHsBind GHC.Name -> Bool -sameBind b1 b2 = (definedPNs b1) == (definedPNs b2) - --- --------------------------------------------------------------------- - --- TODO: is this the same is isUsedInRhs? -class (SYB.Data t) => UsedByRhs t where - - -- | Return True if any of the GHC.Name's appear in the given - -- syntax element - usedByRhs :: t -> [GHC.Name] -> Bool - usedByRhsRdr :: NameMap -> t -> [GHC.Name] -> Bool - -instance UsedByRhs GHC.RenamedSource where - - -- Not a meaningful question at this level - usedByRhs _renamed _pns = False - usedByRhsRdr _ _ = assert False undefined - -instance UsedByRhs (GHC.HsModule GHC.RdrName) where - - -- Not a meaningful question at this level - usedByRhsRdr _ _parsed _pns = False - usedByRhs _ _ = assert False undefined - --- ------------------------------------- - -instance (UsedByRhs a) => UsedByRhs (GHC.Located a) where - usedByRhsRdr nm (GHC.L _ d) pns = usedByRhsRdr nm d pns - -- usedByRhs _ _ = assert False undefined - usedByRhs _ la = error $ "usedByRhs:Located a=" ++ SYB.showData SYB.Parser 0 la - --- ------------------------------------- - -instance UsedByRhs [GHC.LHsDecl GHC.RdrName] where - usedByRhs _ _ = assert False undefined - usedByRhsRdr nm ds pns = or $ map (\d -> usedByRhsRdr nm d pns) ds - --- ------------------------------------- - -instance UsedByRhs (GHC.HsDecl GHC.RdrName) where - usedByRhs _ _ = assert False undefined - usedByRhsRdr nm de pns = - case de of - GHC.TyClD d -> f d - GHC.InstD d -> f d - GHC.DerivD d -> f d - GHC.ValD d -> f d - GHC.SigD d -> f d - GHC.DefD d -> f d - GHC.ForD d -> f d - GHC.WarningD d -> f d - GHC.AnnD d -> f d - GHC.RuleD d -> f d - GHC.VectD d -> f d - GHC.SpliceD d -> f d - GHC.DocD d -> f d - GHC.RoleAnnotD d -> f d -#if __GLASGOW_HASKELL__ < 711 - GHC.QuasiQuoteD d -> f d -#endif - where - f d' = usedByRhsRdr nm d' pns - --- ------------------------------------- - -instance UsedByRhs (GHC.TyClDecl GHC.RdrName) where - usedByRhsRdr = assert False undefined - usedByRhs _ _ = assert False undefined - -instance UsedByRhs (GHC.InstDecl GHC.RdrName) where - usedByRhsRdr = assert False undefined - usedByRhs _ _ = assert False undefined - -instance UsedByRhs (GHC.DerivDecl GHC.RdrName) where - usedByRhsRdr = assert False undefined - usedByRhs _ _ = assert False undefined - -instance UsedByRhs (GHC.ForeignDecl GHC.RdrName) where - usedByRhsRdr = assert False undefined - usedByRhs _ _ = assert False undefined - -instance UsedByRhs (GHC.WarnDecls GHC.RdrName) where - usedByRhsRdr = assert False undefined - usedByRhs _ _ = assert False undefined - -instance UsedByRhs (GHC.AnnDecl GHC.RdrName) where - usedByRhsRdr = assert False undefined - usedByRhs _ _ = assert False undefined - -instance UsedByRhs (GHC.RoleAnnotDecl GHC.RdrName) where - usedByRhsRdr = assert False undefined - usedByRhs _ _ = assert False undefined - -instance UsedByRhs (GHC.HsQuasiQuote GHC.RdrName) where - usedByRhsRdr = assert False undefined - usedByRhs _ _ = assert False undefined - -instance UsedByRhs (GHC.DefaultDecl GHC.RdrName) where - usedByRhsRdr = assert False undefined - usedByRhs _ _ = assert False undefined - -instance UsedByRhs (GHC.SpliceDecl GHC.RdrName) where - usedByRhsRdr = assert False undefined - usedByRhs _ _ = assert False undefined - -instance UsedByRhs (GHC.VectDecl GHC.RdrName) where - usedByRhsRdr = assert False undefined - usedByRhs _ _ = assert False undefined - -instance UsedByRhs (GHC.RuleDecls GHC.RdrName) where - usedByRhs _ _ = assert False undefined - usedByRhsRdr = assert False undefined - -instance UsedByRhs GHC.DocDecl where - usedByRhs _ _ = assert False undefined - usedByRhsRdr = assert False undefined - -instance UsedByRhs (GHC.Sig GHC.RdrName) where - usedByRhsRdr _ _ _ = False - usedByRhs _ = assert False undefined - --- ------------------------------------- - -instance UsedByRhs (GHC.LHsBinds GHC.Name) where - usedByRhs binds pns = or $ map (\b -> usedByRhs b pns) $ GHC.bagToList binds - usedByRhsRdr _ _ = assert False undefined - -instance UsedByRhs (GHC.HsValBinds GHC.Name) where - usedByRhs (GHC.ValBindsIn binds _sigs) pns = usedByRhs (GHC.bagToList binds) pns - usedByRhs (GHC.ValBindsOut binds _sigs) pns = or $ map (\(_,b) -> usedByRhs b pns) binds - usedByRhsRdr _ _ = assert False undefined - --- ------------------------------------- - -instance UsedByRhs (GHC.Match GHC.Name (GHC.LHsExpr GHC.Name)) where - usedByRhs (GHC.Match _ _ _ (GHC.GRHSs rhs _)) pns -- = usedByRhs (hsValBinds rhs) pns - = findPNs pns rhs - usedByRhsRdr _ _ = assert False undefined - - -instance UsedByRhs (GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where - usedByRhsRdr nm (GHC.Match _ _ _ (GHC.GRHSs rhs _)) pns - = findNamesRdr nm pns rhs - - usedByRhs _ _ = assert False undefined - --- ------------------------------------- - -instance UsedByRhs [GHC.LHsBind GHC.Name] where - usedByRhs binds pns = or $ map (\b -> usedByRhs b pns) binds - usedByRhsRdr _ _ = assert False undefined - -instance UsedByRhs (GHC.HsBind GHC.Name) where - usedByRhs (GHC.FunBind _ _ matches _ _ _) pns = findPNs pns matches - usedByRhs (GHC.PatBind _ rhs _ _ _) pns = findPNs pns rhs - usedByRhs (GHC.VarBind _ rhs _) pns = findPNs pns rhs - usedByRhs (GHC.AbsBinds _ _ _ _ _) _pns = False - usedByRhs (GHC.PatSynBind _) _pns = error "To implement: usedByRhs PaySynBind" - usedByRhsRdr _ _ = assert False undefined - --- ------------------------------------- - -instance UsedByRhs (GHC.HsBind GHC.RdrName) where - usedByRhs _ _ = assert False undefined - usedByRhsRdr nm (GHC.FunBind _ _ matches _ _ _) pns = findNamesRdr nm pns matches - usedByRhsRdr nm (GHC.PatBind _ rhs _ _ _) pns = findNamesRdr nm pns rhs - usedByRhsRdr nm (GHC.PatSynBind (GHC.PSB _ _ _ rhs _)) pns = findNamesRdr nm pns rhs - usedByRhsRdr nm (GHC.VarBind _ rhs _) pns = findNamesRdr nm pns rhs - usedByRhsRdr _nm (GHC.AbsBinds _ _ _ _ _) _pns = False - --- ------------------------------------- - -instance UsedByRhs (GHC.HsExpr GHC.Name) where - usedByRhs (GHC.HsLet _lb e) pns = findPNs pns e - usedByRhs e _pns = error $ "undefined usedByRhs:" ++ (showGhc e) - usedByRhsRdr _ _ = assert False undefined - -instance UsedByRhs (GHC.HsExpr GHC.RdrName) where - usedByRhsRdr nm (GHC.HsLet _lb e) pns = findNamesRdr nm pns e - usedByRhsRdr _ e _pns = error $ "undefined usedByRhsRdr:" ++ (showGhc e) - usedByRhs _ _ = assert False undefined - --- ------------------------------------- - -instance UsedByRhs (GHC.Stmt GHC.Name (GHC.LHsExpr GHC.Name)) where - usedByRhs (GHC.LetStmt lb) pns = findPNs pns lb - usedByRhs s _pns = error $ "undefined usedByRhs:" ++ (showGhc s) - usedByRhsRdr _ _ = assert False undefined - -instance UsedByRhs (GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where - usedByRhsRdr nm (GHC.LetStmt lb) pns = findNamesRdr nm pns lb - usedByRhsRdr _ s _pns = error $ "undefined usedByRhsRdr:" ++ (showGhc s) - usedByRhs _ _ = assert False undefined - --------------------------------------------------------------------------------- - --- |Find the identifier with the given name. This looks through the --- given syntax phrase for the first GHC.Name which matches. Because --- it is Renamed source, the GHC.Name will include its defining --- location. Returns Nothing if the name is not found. - -getName::(SYB.Data t)=> String -- ^ The name to find - -> t -- ^ The syntax phrase - -> Maybe GHC.Name -- ^ The result -getName str t - = res - where - res = SYB.somethingStaged SYB.Renamer Nothing - (Nothing `SYB.mkQ` worker `SYB.extQ` workerBind `SYB.extQ` workerExpr) t - - worker ((GHC.L _ n) :: (GHC.Located GHC.Name)) - | showGhcQual n == str = Just n - worker _ = Nothing - - workerBind (GHC.L _ (GHC.VarPat name) :: (GHC.Located (GHC.Pat GHC.Name))) - | showGhcQual name == str = Just name - workerBind _ = Nothing - - - workerExpr ((GHC.L _ (GHC.HsVar name)) :: (GHC.Located (GHC.HsExpr GHC.Name))) - | showGhcQual name == str = Just name - workerExpr _ = Nothing - --- --------------------------------------------------------------------- - --- | Add identifiers to the export list of a module. If the second argument is --- like: Just p, then do the adding only if p occurs in the export list, and the --- new identifiers are added right after p in the export list. Otherwise the new --- identifiers are add to the beginning of the export list. In the case that the --- export list is emport, then if the third argument is True, then create an --- explict export list to contain only the new identifiers, otherwise do --- nothing. - -addImportDecl :: - GHC.ParsedSource - -> GHC.ModuleName - -> Maybe GHC.FastString -- ^qualifier - -> Bool -> Bool -> Bool - -> Maybe String -- ^alias - -> Bool - -> [GHC.RdrName] - -> RefactGhc GHC.ParsedSource --- addImportDecl (groupedDecls,imp, b, c) modName pkgQual source safe qualify alias hide idNames -addImportDecl (GHC.L l p) modName pkgQual source safe qualify alias hide idNames - = do - let imp = GHC.hsmodImports p - impDecl <- mkImpDecl - newSpan <- liftT uniqueSrcSpanT - let newImp = GHC.L newSpan impDecl - liftT $ addSimpleAnnT newImp (DP (1,0)) [((G GHC.AnnImport),DP (0,0))] - return (GHC.L l p { GHC.hsmodImports = (imp++[newImp])}) - where - - alias' = case alias of - Just stringName -> Just $ GHC.mkModuleName stringName - _ -> Nothing - - mkImpDecl = do - newSpan1 <- liftT uniqueSrcSpanT - newSpan2 <- liftT uniqueSrcSpanT - newEnts <- mkNewEntList idNames - let lNewEnts = GHC.L newSpan2 newEnts - -- logm $ "addImportDecl.mkImpDecl:adding anns for:" ++ showGhc lNewEnts - liftT $ addSimpleAnnT lNewEnts (DP (0,1)) [((G GHC.AnnHiding),DP (0,0)),((G GHC.AnnOpenP),DP (0,1)),((G GHC.AnnCloseP),DP (0,0))] - let lmodname = GHC.L newSpan1 modName - liftT $ addSimpleAnnT lmodname (DP (0,1)) [((G GHC.AnnVal),DP (0,0))] - return $ GHC.ImportDecl - { GHC.ideclSourceSrc = Nothing - , GHC.ideclName = lmodname - , GHC.ideclPkgQual = pkgQual - , GHC.ideclSource = source - , GHC.ideclSafe = safe - , GHC.ideclQualified = qualify - , GHC.ideclImplicit = False - , GHC.ideclAs = alias' - , GHC.ideclHiding = - (if idNames == [] && hide == False then - Nothing - else - (Just (hide, lNewEnts))) - } - --- --------------------------------------------------------------------- - --- | Adding a declaration to the declaration list of the given syntax --- phrase. If the second argument is Nothing, then the declaration --- will be added to the beginning of the declaration list, but after --- the data type declarations is there is any. -addDecl:: (SYB.Data t,SYB.Typeable t) - => t -- ^The AST to be updated - -> Maybe GHC.Name -- ^If this is Just, then the declaration - -- will be added right after this - -- identifier's definition. - -> ([GHC.LHsDecl GHC.RdrName], Maybe Anns) - -- ^ The declaration with optional signatures to be added, together - -- with optional Annotations. - -> RefactGhc t - -addDecl parent pn (declSig, mDeclAnns) = do - logm $ "addDecl:declSig=" ++ showGhc declSig - case mDeclAnns of - Nothing -> return () - Just declAnns -> -- addRefactAnns declAnns - liftT $ modifyAnnsT (mergeAnns declAnns) - case pn of - Just pn' -> appendDecl parent pn' declSig - Nothing -> addLocalDecl parent declSig - where - setDeclSpacing newDeclSig n c = do - -- First clear any previous indentation - mapM_ (\d -> setPrecedingLinesDeclT d 1 0) newDeclSig - setPrecedingLinesT (ghead "addDecl" newDeclSig) n c - -- mapM_ (\d -> setPrecedingLinesT d 1 0) (gtail "addDecl" newDeclSig) - - appendDecl :: (SYB.Data t) - => t -- ^Original AST - -> GHC.Name -- ^Name to add the declaration after - -> [GHC.LHsDecl GHC.RdrName] -- ^declaration and maybe sig - -> RefactGhc t -- ^updated AST - appendDecl parent1 pn' newDeclSig = do - hasDeclsSybTransform workerHsDecls workerBind parent1 - where - workerHsDecls :: forall t. HasDecls t => t -> RefactGhc t - workerHsDecls parent' = do - -- logm $ "addDecl.appendDecl:(pn')=" ++ showGhc pn' - liftT $ setDeclSpacing newDeclSig 2 0 - nameMap <- getRefactNameMap - decls <- liftT $ hsDecls parent' - let - (before,after) = break (definesDeclRdr nameMap pn') decls - - -- logm $ "addDecl.appendDecl:(before,after)=" ++ showGhc (before,after) - let (decls1,decls2) = case after of - [] -> (before,[]) - _ -> (before ++ [ghead "appendDecl14" after], - gtail "appendDecl15" after) - liftT $ replaceDecls parent' (decls1++newDeclSig++decls2) - - workerBind :: (GHC.LHsBind GHC.RdrName -> RefactGhc (GHC.LHsBind GHC.RdrName)) - workerBind = assert False undefined - - addLocalDecl :: (SYB.Typeable t,SYB.Data t) - => t -> [GHC.LHsDecl GHC.RdrName] - -> RefactGhc t - addLocalDecl parent' newDeclSig = do - logm $ "addLocalDecl entered" - -- logDataWithAnns "addLocalDecl.parent'" parent' - hasDeclsSybTransform workerHasDecls workerBind parent' - where - workerDecls :: [GHC.LHsDecl GHC.RdrName] -> RefactGhc [GHC.LHsDecl GHC.RdrName] - workerDecls decls = do - logm $ "workerDecls entered" - case decls of - [] -> liftT $ setDeclSpacing newDeclSig 2 0 - ds -> do - DP (r,c) <- liftT (getEntryDPT (head ds)) - liftT $ setDeclSpacing newDeclSig r c - liftT $ setPrecedingLinesT (head ds) 2 0 - return (newDeclSig++decls) - - workerHasDecls :: (HasDecls t) => t -> RefactGhc t - workerHasDecls p = do - logm $ "workerHasDecls entered" - decls <- liftT (hsDecls p) - decls' <- workerDecls decls - r <- liftT $ replaceDecls p decls' - return r - - workerBind :: GHC.LHsBind GHC.RdrName -> RefactGhc (GHC.LHsBind GHC.RdrName) - workerBind b = do - logm $ "workerBind entered" - case b of - GHC.L l (GHC.FunBind n i (GHC.MG [match] a ptt o) co fvs t) -> do - match' <- workerHasDecls match - return (GHC.L l (GHC.FunBind n i (GHC.MG [match'] a ptt o) co fvs t)) - GHC.L _ (GHC.FunBind _ _ (GHC.MG _matches _ _ _) _ _ _) -> do - error "addDecl:Cannot add a local decl to a FunBind with multiple matches" - p@(GHC.L _ (GHC.PatBind _pat _rhs _ty _fvs _t)) -> do - logm $ "workerBind.PatBind entered" - decls <- liftT (hsDeclsPatBind p) - decls' <- workerDecls decls - r <- liftT $ replaceDeclsPatBind p decls' - return r - - x -> error $ "addLocalDecl.workerBind:not processing:" ++ SYB.showData SYB.Parser 0 x - --- --------------------------------------------------------------------- --- --- --------------------------------------------------------------------- - -rdrNameFromName :: Bool -> GHC.Name -> RefactGhc GHC.RdrName -rdrNameFromName useQual newName = do - mname <- case (GHC.nameModule_maybe newName) of - Just (GHC.Module _ mn) -> return mn - Nothing -> do - GHC.Module _ mn <- getRefactModule - return mn - - if useQual - then return $ GHC.mkRdrQual mname (GHC.nameOccName newName) - else return $ GHC.mkRdrUnqual (GHC.nameOccName newName) - --- --------------------------------------------------------------------- - --- |Take a list of strings and return a list with the longest prefix --- of spaces removed -stripLeadingSpaces :: [String] -> [String] -stripLeadingSpaces xs = map (drop n) xs - where - n = minimum $ map oneLen xs - - oneLen x = length prefix - where - (prefix,_) = break (/=' ') x - --- --------------------------------------------------------------------- - --- | add items to the hiding list of an import declaration which --- imports the specified module. -addHiding:: - GHC.ModuleName -- ^ The imported module name - -> GHC.ParsedSource -- ^ The current module - -> [GHC.RdrName] -- ^ The items to be added - -> RefactGhc GHC.ParsedSource -- ^ The result -addHiding mn p ns = do - logm $ "addHiding called for (module,names):" ++ showGhc (mn,ns) - p' <- addItemsToImport' mn p ns Hide - putRefactParsed p' emptyAnns - return p' - --- -------------------------------------------------------------------- - --- | Creates a new entity list for hiding a name in an ImportDecl. -mkNewEntList :: [GHC.RdrName] -> RefactGhc [GHC.LIE GHC.RdrName] -mkNewEntList idNames = do - case idNames of - [] -> return [] - _ -> do - newEntsInit <- mapM (mkNewEnt True) (init idNames) - newEntsLast <- mkNewEnt False (last idNames) - return (newEntsInit ++ [newEntsLast]) - --- | Creates a new entity for hiding a name in an ImportDecl. -mkNewEnt :: Bool -> GHC.RdrName -> RefactGhc (GHC.LIE GHC.RdrName) -mkNewEnt addCommaAnn pn = do - newSpan <- liftT uniqueSrcSpanT - let lpn = GHC.L newSpan pn - if addCommaAnn - then liftT $ addSimpleAnnT lpn (DP (0,0)) [((G GHC.AnnVal),DP (0,0)),((G GHC.AnnComma),DP (0,0))] - else liftT $ addSimpleAnnT lpn (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] - return (GHC.L newSpan (GHC.IEVar lpn)) - --- | Represents the operation type we want to select on addItemsToImport' -data ImportType = Hide -- ^ Used for addHiding - | Import -- ^ Used for addItemsToImport - --- | Add identifiers (given by the third argument) to the explicit entity list in the declaration importing the --- specified module name. This function does nothing if the import declaration does not have an explicit entity list. -addItemsToImport:: - GHC.ModuleName -- ^ The imported module name - ->GHC.ParsedSource -- ^ The current module - ->[GHC.RdrName] -- ^ The items to be added --- ->Maybe GHC.Name -- ^ The condition identifier. - ->RefactGhc GHC.ParsedSource -- ^ The result -addItemsToImport mn r ns = addItemsToImport' mn r ns Import - --- | Add identifiers (given by the third argument) to the explicit entity list in the declaration importing the --- specified module name. If the ImportType argument is Hide, then the items will be added to the "hiding" --- list. If it is Import, they will be added to the explicit import entries. This function does nothing if --- the import declaration does not have an explicit entity list and ImportType is Import. -addItemsToImport':: - GHC.ModuleName -- ^ The imported module name - -> GHC.ParsedSource -- ^ The current module - -> [GHC.RdrName] -- ^ The items to be added --- ->Maybe GHC.Name -- ^ The condition identifier. - -> ImportType -- ^ Whether to hide the names or import them. Uses special data for clarity. - -> RefactGhc GHC.ParsedSource -- ^ The result -addItemsToImport' serverModName (GHC.L l p) pns impType = do - let imps = GHC.hsmodImports p - imps' <- mapM inImport imps - return $ GHC.L l p {GHC.hsmodImports = imps'} - where - isHide = case impType of - Hide -> True - Import -> False - - inImport :: GHC.LImportDecl GHC.RdrName -> RefactGhc (GHC.LImportDecl GHC.RdrName) - inImport imp@(GHC.L _ (GHC.ImportDecl _st (GHC.L _ modName) _qualify _source _safe isQualified _isImplicit _as h)) - | serverModName == modName && not isQualified -- && (if isJust pn then findPN (gfromJust "addItemsToImport" pn) h else True) - = case h of - Nothing -> insertEnts imp [] True - Just (_isHide, (GHC.L _le ents)) -> insertEnts imp ents False - inImport x = return x - - insertEnts :: - GHC.LImportDecl GHC.RdrName - -> [GHC.LIE GHC.RdrName] - -> Bool -- True means there are already existing entities - -> RefactGhc ( GHC.LImportDecl GHC.RdrName ) - insertEnts imp ents isNew = do - logm $ "addItemsToImport':insertEnts:(imp,ents,isNew):" ++ showGhc (imp,ents,isNew) - if isNew && not isHide then return imp - else do - logm $ "addItemsToImport':insertEnts:doing stuff" - newSpan <- liftT uniqueSrcSpanT - newEnts <- mkNewEntList pns - let lNewEnts = GHC.L newSpan (ents++newEnts) - logm $ "addImportDecl.mkImpDecl:adding anns for:" ++ showGhc lNewEnts - if isHide - then - liftT $ addSimpleAnnT lNewEnts (DP (0,1)) [((G GHC.AnnHiding),DP (0,0)),((G GHC.AnnOpenP),DP (0,1)),((G GHC.AnnCloseP),DP (0,0))] - else - liftT $ addSimpleAnnT lNewEnts (DP (0,1)) [((G GHC.AnnOpenP),DP (0,0)),((G GHC.AnnCloseP),DP (0,0))] - when (not (null ents)) $ do liftT (addTrailingCommaT (last ents)) - return (replaceHiding imp (Just (isHide, lNewEnts))) - - - replaceHiding (GHC.L l1 (GHC.ImportDecl st mn q src safe isQ isImp as _h)) h1 = - (GHC.L l1 (GHC.ImportDecl st mn q src safe isQ isImp as h1)) - --- --------------------------------------------------------------------- - -addParamsToDecls:: - [GHC.LHsDecl GHC.RdrName] -- ^ A declaration list where the function is defined and\/or used. - -> GHC.Name -- ^ The function name. - -> [GHC.RdrName] -- ^ The parameters to be added. - -> RefactGhc [GHC.LHsDecl GHC.RdrName] -- ^ The result. - -addParamsToDecls decls pn paramPNames = do - -- logm $ "addParamsToDecls (pn,paramPNames,modifyToks)=" ++ (showGhc (pn,paramPNames,modifyToks)) - nameMap <- getRefactNameMap - if (paramPNames /= []) - then mapM (addParamToDecl nameMap) decls - else return decls - where - addParamToDecl :: NameMap -> GHC.LHsDecl GHC.RdrName -> RefactGhc (GHC.LHsDecl GHC.RdrName) - addParamToDecl nameMap (GHC.L l1 (GHC.ValD (GHC.FunBind lp@(GHC.L l2 pname) i (GHC.MG matches a ptt o) co fvs t))) - | eqRdrNamePure nameMap lp pn - = do - matches' <- mapM addParamtoMatch matches - return (GHC.L l1 (GHC.ValD (GHC.FunBind (GHC.L l2 pname) i (GHC.MG matches' a ptt o) co fvs t))) - where - addParamtoMatch (GHC.L l (GHC.Match fn1 pats mtyp rhs)) - = do - rhs' <- addActualParamsToRhs pn paramPNames rhs - pats' <- liftT $ mapM addParam paramPNames - return (GHC.L l (GHC.Match fn1 (pats'++pats) mtyp rhs')) - - -- TODO: The following will never match, as a PatBind only deals with complex patterns. - addParamToDecl _nameMap x@(GHC.L _l1 (GHC.ValD (GHC.PatBind _pat@(GHC.L _l2 (GHC.VarPat _p)) _rhs _ty _fvs _t))) - = return x - addParamToDecl _ x = return x - - addParam n = do - newSpan <- uniqueSrcSpanT - let vn = (GHC.L newSpan (pNtoPat n)) - addSimpleAnnT vn (DP (0,1)) [((G GHC.AnnVal),DP (0,0))] - return vn - --- --------------------------------------------------------------------- - -addItemsToExport :: - GHC.ParsedSource -- The module AST. - -> Maybe PName -- The condtion identifier. - -> Bool -- Create an explicit list or not - -> Either [String] [GHC.LIE GHC.RdrName] -- The identifiers to add in either String or HsExportEntP format. - -> RefactGhc GHC.ParsedSource -- The result. -addItemsToExport = assert False undefined -{- - --- | Add identifiers to the export list of a module. If the second argument is like: Just p, then do the adding only if p occurs --- in the export list, and the new identifiers are added right after p in the export list. Otherwise the new identifiers are add --- to the beginning of the export list. In the case that the export list is emport, then if the third argument is True, then create --- an explict export list to contain only the new identifiers, otherwise do nothing. -{- -addItemsToExport::( ) - => HsModuleP -- The module AST. - -> Maybe PName -- The condtion identifier. - -> Bool -- Create an explicit list or not - -> Either [String] [HsExportEntP] -- The identifiers to add in either String or HsExportEntP format. - -> m HsModuleP -- The result. --} - -addItemsToExport::(MonadState (([PosToken],Bool), t1) m) - => HsModuleP -- The module AST. - -> Maybe PName -- The condtion identifier. - -> Bool -- Create an explicit list or not - -> Either [String] [HsExportEntP] -- The identifiers to add in either String or HsExportEntP format. - -> m HsModuleP -- The result. - - -addItemsToExport mod _ _ (Left []) = return mod -addItemsToExport mod _ _ (Right []) = return mod -addItemsToExport mod@(HsModule loc modName exps imps ds) (Just pn) _ ids - = case exps of - Just ents ->let (e1,e2) = break (findEntity pn) ents - in if e2 /=[] - then do ((toks,_),others)<-get - let e = (ghead "addVarItemInExport" e2) - es = case ids of - (Left is' ) ->map (\x-> (EntE (Var (nameToPNT x)))) is' - (Right es') -> es' - let (_,endPos) = getStartEndLoc toks e - (t, (_,s)) = ghead "addVarItemInExport" $ getToks (endPos,endPos) toks - newToken = mkToken t endPos (s++","++ showEntities (render.ppi) es) - toks' = replaceToks toks endPos endPos [newToken] - put ((toks',modified),others) - return (HsModule loc modName (Just (e1++(e:es)++tail e2)) imps ds) - else return mod - Nothing -> return mod - -addItemsToExport mod@(HsModule _ _ (Just ents) _ _) Nothing createExp ids - = do ((toks,_),others)<-get - let es = case ids of - (Left is' ) ->map (\x-> (EntE (Var (nameToPNT x)))) is' - (Right es') -> es' - (t, (pos,s))=fromJust $ find isOpenBracket toks -- s is the '(' - newToken = if ents /=[] then (t, (pos,(s++showEntities (render.ppi) es++","))) - else (t, (pos,(s++showEntities (render.ppi) es))) - pos'= simpPos pos - toks' = replaceToks toks pos' pos' [newToken] - put ((toks',modified),others) - return mod {hsModExports=Just (es++ ents)} - -addItemsToExport mod@(HsModule _ (SN modName (SrcLoc _ c row col)) Nothing _ _) Nothing createExp ids - =case createExp of - True ->do ((toks,_),others)<-get - let es = case ids of - (Left is' ) ->map (\x-> (EntE (Var (nameToPNT x)))) is' - (Right es') -> es' - pos = (row,col) - newToken = mkToken Varid pos (modNameToStr modName++ "(" - ++ showEntities (render.ppi) es++")") - toks' = replaceToks toks pos pos [newToken] - put ((toks', modified), others) - return mod {hsModExports=Just es} - False ->return mod - --} --- --------------------------------------------------------------------- - -addActualParamsToRhs :: (SYB.Data t) => - GHC.Name -> [GHC.RdrName] -> t -> RefactGhc t -addActualParamsToRhs pn paramPNames rhs = do - logm $ "addActualParamsToRhs:entered:(pn,paramPNames)=" ++ showGhc (pn,paramPNames) - nameMap <- getRefactNameMap - let - worker :: (GHC.LHsExpr GHC.RdrName) -> RefactGhc (GHC.LHsExpr GHC.RdrName) - worker oldExp@(GHC.L l2 (GHC.HsVar pname)) - | eqRdrNamePure nameMap (GHC.L l2 pname) pn - = do - logDataWithAnns "addActualParamsToRhs:oldExp=" oldExp - newExp' <- liftT $ foldlM addParamToExp oldExp paramPNames - - edp <- liftT $ getEntryDPT oldExp - liftT $ setEntryDPT oldExp (DP (0,0)) - l2' <- liftT $ uniqueSrcSpanT - let newExp = (GHC.L l2' (GHC.HsPar newExp')) - liftT $ addSimpleAnnT newExp (DP (0,0)) [(G GHC.AnnOpenP,DP (0,0)),(G GHC.AnnCloseP,DP (0,0))] - liftT $ setEntryDPT newExp edp - return newExp - worker x = return x - - addParamToExp :: (GHC.LHsExpr GHC.RdrName) -> GHC.RdrName -> Transform (GHC.LHsExpr GHC.RdrName) - addParamToExp expr param = do - ss1 <- uniqueSrcSpanT - ss2 <- uniqueSrcSpanT - let var = GHC.L ss2 (GHC.HsVar param) - let expr' = GHC.L ss1 (GHC.HsApp expr var) - addSimpleAnnT var (DP (0,0)) [(G GHC.AnnVal,DP (0,1))] - addSimpleAnnT expr' (DP (0,0)) [] - return expr' - - r <- applyTP (full_buTP (idTP `adhocTP` worker)) rhs - return r - -{- - -The code - - sumSqu (x:xs) = (sq bar2) x + sumSquares xs - -results in - - (GRHSs - [ - ({ LiftToToplevel/D1.hs:(13,15)-(15,16) } - Just (Ann (DP (0,-1)) [] [] [] Nothing Nothing) - (GRHS - [] - ({ LiftToToplevel/D1.hs:13:17-43 } - Just (Ann (DP (0,1)) [] [] [] Nothing Nothing) - (OpApp - ({ LiftToToplevel/D1.hs:13:17-27 } - Just (Ann (DP (0,0)) [] [] [] Nothing Nothing) - (HsApp - ({ LiftToToplevel/D1.hs:13:17-25 } - Just (Ann (DP (0,0)) [] [] [((G AnnOpenP),DP (0,0)),((G AnnCloseP),DP (0,0))] Nothing Nothing) - (HsPar - ({ LiftToToplevel/D1.hs:13:18-24 } - Just (Ann (DP (0,0)) [] [] [] Nothing Nothing) - (HsApp - ({ LiftToToplevel/D1.hs:13:18-19 } - Just (Ann (DP (0,0)) [] [] [((G AnnVal),DP (0,0))] Nothing Nothing) - (HsVar - (Unqual {OccName: sq}))) - ({ LiftToToplevel/D1.hs:13:21-24 } - Just (Ann (DP (0,1)) [] [] [((G AnnVal),DP (0,0))] Nothing Nothing) - (HsVar - (Unqual {OccName: bar2}))))))) - ({ LiftToToplevel/D1.hs:13:27 } - Just (Ann (DP (0,1)) [] [] [((G AnnVal),DP (0,0))] Nothing Nothing) - (HsVar - (Unqual {OccName: x}))))) - ({ LiftToToplevel/D1.hs:13:29 } - Just (Ann (DP (0,1)) [] [] [((G AnnVal),DP (0,0))] Nothing Nothing) - (HsVar - (Unqual {OccName: +}))) - (PlaceHolder) - ({ LiftToToplevel/D1.hs:13:31-43 } - Just (Ann (DP (0,1)) [] [] [] Nothing Nothing) - (HsApp - ({ LiftToToplevel/D1.hs:13:31-40 } - Just (Ann (DP (0,0)) [] [] [((G AnnVal),DP (0,0))] Nothing Nothing) - (HsVar - (Unqual {OccName: sumSquares}))) - ({ LiftToToplevel/D1.hs:13:42-43 } - Just (Ann (DP (0,1)) [] [] [((G AnnVal),DP (0,0))] Nothing Nothing) - (HsVar - (Unqual {OccName: xs})))))))))] - --} -{- -Required end result : (sq pow) x + sumSquares xs - - (L {test/testdata/LiftToToplevel/D2.hs:6:21-46} - (OpApp - - (L {test/testdata/LiftToToplevel/D2.hs:6:21-30} - (HsApp - (L {test/testdata/LiftToToplevel/D2.hs:6:21-28} - (HsPar - (L {test/testdata/LiftToToplevel/D2.hs:6:22-27} - (HsApp - (L {test/testdata/LiftToToplevel/D2.hs:6:22-23} - (HsVar {Name: LiftToToplevel.D2.sq})) - (L {test/testdata/LiftToToplevel/D2.hs:6:25-27} - (HsVar {Name: pow})))))) - (L {test/testdata/LiftToToplevel/D2.hs:6:30} - (HsVar {Name: x})))) - - (L {test/testdata/LiftToToplevel/D2.hs:6:32} - (HsVar {Name: GHC.Num.+})) {Fixity: infixl 6} - (L {test/testdata/LiftToToplevel/D2.hs:6:34-46} - (HsApp - (L {test/testdata/LiftToToplevel/D2.hs:6:34-43} - (HsVar {Name: LiftToToplevel.D2.sumSquares})) - (L {test/testdata/LiftToToplevel/D2.hs:6:45-46} - (HsVar {Name: xs}))))))))] - -Alternate, no parens : sq pow x + sumSquares xs - - (L {test/testdata/LiftToToplevel/D2.hs:6:21-44} - (OpApp - - (L {test/testdata/LiftToToplevel/D2.hs:6:21-28} - (HsApp - (L {test/testdata/LiftToToplevel/D2.hs:6:21-26} - (HsApp - (L {test/testdata/LiftToToplevel/D2.hs:6:21-22} - (HsVar {Name: LiftToToplevel.D2.sq})) - (L {test/testdata/LiftToToplevel/D2.hs:6:24-26} - (HsVar {Name: pow})))) - (L {test/testdata/LiftToToplevel/D2.hs:6:28} - (HsVar {Name: x})))) - - - (L {test/testdata/LiftToToplevel/D2.hs:6:30} - (HsVar {Name: GHC.Num.+})) {Fixity: infixl 6} - (L {test/testdata/LiftToToplevel/D2.hs:6:32-44} - (HsApp - (L {test/testdata/LiftToToplevel/D2.hs:6:32-41} - (HsVar {Name: LiftToToplevel.D2.sumSquares})) - (L {test/testdata/LiftToToplevel/D2.hs:6:43-44} - (HsVar {Name: xs}))))))))] - - -Original : sq x + sumSquares xs - - (L {test/testdata/LiftToToplevel/D2.hs:6:21-40} - (OpApp - - (L {test/testdata/LiftToToplevel/D2.hs:6:21-24} - (HsApp - (L {test/testdata/LiftToToplevel/D2.hs:6:21-22} - (HsVar {Name: sq})) - (L {test/testdata/LiftToToplevel/D2.hs:6:24} - (HsVar {Name: x})))) - - - (L {test/testdata/LiftToToplevel/D2.hs:6:26} - (HsVar {Name: GHC.Num.+})) {Fixity: infixl 6} - (L {test/testdata/LiftToToplevel/D2.hs:6:28-40} - (HsApp - (L {test/testdata/LiftToToplevel/D2.hs:6:28-37} - (HsVar {Name: LiftToToplevel.D2.sumSquares})) - (L {test/testdata/LiftToToplevel/D2.hs:6:39-40} - (HsVar {Name: xs}))))))))] - --} - --- --------------------------------------------------------------------- - --- | Duplicate a function\/pattern binding declaration under a new name --- right after the original one. -duplicateDecl :: - [GHC.LHsDecl GHC.RdrName] -- ^ decls to be updated, containing the original decl (and sig) - ->GHC.Name -- ^ The identifier whose definition is to be duplicated - ->GHC.Name -- ^ The new name (possibly qualified) - ->RefactGhc [GHC.LHsDecl GHC.RdrName] -- ^ The result -duplicateDecl decls n newFunName - = do - logm $ "duplicateDecl entered:(decls,n,newFunName)=" ++ showGhc (decls,n,newFunName) - nm <- getRefactNameMap - let - declsToDup = definingDeclsRdrNames nm [n] decls True False - funBinding = filter isFunOrPatBindP declsToDup --get the fun binding. - typeSig = map wrapSig $ definingSigsRdrNames nm [n] decls - funBinding'' <- renamePN n newFunName False funBinding - typeSig'' <- renamePN n newFunName False typeSig - logm $ "duplicateDecl:funBinding''=" ++ showGhc funBinding'' - - funBinding3 <- mapM (\f@(GHC.L _ fb) -> do - newSpan <- liftT uniqueSrcSpanT - let fb' = GHC.L newSpan fb - liftT $ modifyAnnsT (copyAnn f fb') - return fb' - ) (typeSig'' ++ funBinding'') - when (not $ null funBinding3) $ do - liftT $ setEntryDPT (head funBinding3) (DP (2,0)) - liftT $ mapM_ (\d -> setEntryDPT d (DP (1,0))) (tail funBinding3) - let (decls1,decls2) = break (definesDeclRdr nm n) decls - (declsToDup',declsRest) = break (not . definesDeclRdr nm n) decls2 - -- logDataWithAnns "duplicateDecl:funBinding3" funBinding3 - return $ decls1 ++ declsToDup' ++ funBinding3 ++ declsRest - --- --------------------------------------------------------------------- --- |Divide a declaration list into three parts (before, parent, after) --- according to the PNT, where 'parent' is the first decl containing --- the PNT, 'before' are those decls before 'parent' and 'after' are --- those decls after 'parent'. - -divideDecls :: SYB.Data t => - [t] -> GHC.Located GHC.Name -> RefactGhc ([t], [t], [t]) -divideDecls ds (GHC.L _ pnt) = do - nm <- getRefactNameMap - let (before,after) = break (\x -> findNameInRdr nm pnt x) ds - return $ if (not $ emptyList after) - then (before, [ghead "divideDecls" after], gtail "divideDecls" after) - else (ds,[],[]) - --- --------------------------------------------------------------------- - --- | Remove the declaration (and the type signature is the second --- parameter is True) that defines the given identifier from the --- declaration list. -rmDecl:: (SYB.Data t) - => GHC.Name -- ^ The identifier whose definition is to be removed. - -> Bool -- ^ True means including the type signature. - -> t -- ^ The AST fragment containting the declarations, - -- originating from the ParsedSource - -> RefactGhc - (t, - GHC.LHsDecl GHC.RdrName, - Maybe (GHC.LSig GHC.RdrName)) -- ^ The result and the removed declaration - -- and the possibly removed siganture - -rmDecl pn incSig t = do - setStateStorage StorageNone - t' <- everywhereMStaged' SYB.Parser (SYB.mkM inModule - `SYB.extM` inLet - `SYB.extM` inMatch - ) t -- top down - -- applyTP (once_tdTP (failTP `adhocTP` inBinds)) t - storage <- getStateStorage - let decl' = case storage of - StorageDeclRdr decl -> decl - x -> error $ "rmDecl: unexpected value in StateStorage:" ++ (show x) - setStateStorage StorageNone - (t'',sig') <- if incSig - then rmTypeSig pn t' - else return (t', Nothing) - return (t'',decl',sig') - where - inModule (p :: GHC.ParsedSource) - = doRmDeclList p - - inMatch x@(((GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ _localDecls)))):: (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))) - = doRmDeclList x - - inLet :: GHC.LHsExpr GHC.RdrName -> RefactGhc (GHC.LHsExpr GHC.RdrName) - inLet letExpr@(GHC.L _ (GHC.HsLet _localDecls expr)) - = do - isDone <- getDone - if isDone - then return letExpr - else do - nameMap <- getRefactNameMap - -- decls <- liftT $ hsDecls localDecls - decls <- liftT $ hsDecls letExpr - let (decls1,decls2) = break (definesDeclRdr nameMap pn) decls - if not $ emptyList decls2 - then do - let decl = ghead "rmDecl" decls2 - setStateStorage (StorageDeclRdr decl) - case length decls of - 1 -> do -- Removing the last declaration - return expr - _ -> do - -- logm $ "rmDecl.inLet:length decls /= 1" - decls' <- doRmDecl decls1 decls2 - letExpr' <- liftT $ replaceDecls letExpr decls' - return letExpr' - else do - -- liftT $ replaceDecls localDecls decls - return letExpr - inLet x = return x - - -- --------------------------------- - - doRmDeclList parent - = do - isDone <- getDone - -- logm $ "doRmDeclList:isDone=" ++ show isDone - -- logm $ "doRmDeclList:parent=" ++ SYB.showData SYB.Parser 0 parent - if isDone - then return parent - else do - nameMap <- getRefactNameMap - decls <- liftT $ hsDecls parent - let (decls1,decls2) = break (definesDeclRdr nameMap pn) decls - if not $ emptyList decls2 - then do - -- logDataWithAnns "doRmDeclList:(parent)" (parent) - let decl = ghead "doRmDeclList" decls2 - setStateStorage (StorageDeclRdr decl) - decls' <- doRmDecl decls1 decls2 - parent' <- liftT $ replaceDecls parent decls' - -- logDataWithAnns "doRmDeclList:(parent')" (parent') - return parent' - else do - return parent - - -- --------------------------------- - - getDone = do - s <- getStateStorage - case s of - StorageNone -> return False - _ -> return True - --- --------------------------------------------------------------------- - --- ++AZ++ TODO: I think this has been superseded by hasDeclsSybTransform -declsSybTransform :: (SYB.Typeable a) - => (forall b. HasDecls b => b -> RefactGhc b) - -> a -> RefactGhc a -declsSybTransform transform = mt - where - mt = SYB.mkM inMatch - `SYB.extM` inPatDecl - `SYB.extM` inModule - `SYB.extM` inHsLet - - inModule :: GHC.ParsedSource -> RefactGhc GHC.ParsedSource - inModule (modu :: GHC.ParsedSource) - = transform modu - - inMatch :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> RefactGhc (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) - inMatch x@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ _localDecls))) - = transform x - - inPatDecl ::GHC.LHsDecl GHC.RdrName -> RefactGhc (GHC.LHsDecl GHC.RdrName) - inPatDecl x@(GHC.L _ (GHC.ValD (GHC.PatBind _ _ _ _ _))) - -- = transform x - = error $ "declsSybTransform:need to reimplement PatBind case" - inPatDecl x = return x - - inHsLet :: GHC.LHsExpr GHC.RdrName -> RefactGhc (GHC.LHsExpr GHC.RdrName) - inHsLet x@(GHC.L _ (GHC.HsLet{})) - = transform x - inHsLet x = return x - - --------------------------------------------------------------------- - --- |Utility function to remove a decl from the middle of a list, assuming the --- list has already been split into a (possibly empty) front before the decl, --- and a back where the head is the decl to be removed. -doRmDecl :: [GHC.LHsDecl GHC.RdrName] -> [GHC.LHsDecl GHC.RdrName] -> RefactGhc [GHC.LHsDecl GHC.RdrName] -doRmDecl decls1 decls2 - = do - let decls2' = gtail "doRmDecl 1" decls2 - declToRemove = head decls2 - - -- logDataWithAnns "doRmDecl:(decls1,decls2)" (decls1,decls2) - unless (null decls1) $ do liftT $ balanceComments (last decls1) declToRemove - unless (null decls2') $ do liftT $ balanceComments declToRemove (head decls2') - - when (not (null decls2') && null decls1) $ do liftT $ transferEntryDPT declToRemove (head decls2') - when (not (null decls2') && not (null decls1) && not (isTypeSigDecl (last decls1))) - $ do liftT $ transferEntryDPT declToRemove (head decls2') - - -- logDataWithAnns "doRmDecl:(decls2')" (decls2') - return $ (decls1 ++ decls2') - --- --------------------------------------------------------------------- - --- | Remove multiple type signatures -rmTypeSigs :: (SYB.Data t) => - [GHC.Name] -- ^ The identifiers whose type signatures are to be removed. - -> t -- ^ The declarations - -> RefactGhc (t,[GHC.LSig GHC.RdrName]) - -- ^ The result and removed signatures, if there - -- were any -rmTypeSigs pns t = do - (t',demotedSigsMaybe) <- foldM (\(tee,ds) n -> do { (tee',d) <- rmTypeSig n tee; return (tee', ds++[d])}) (t,[]) pns - return (t',catMaybes demotedSigsMaybe) - --- --------------------------------------------------------------------- - --- | Remove the type signature that defines the given identifier's --- type from the declaration list. -rmTypeSig :: (SYB.Data t) => - GHC.Name -- ^ The identifier whose type signature is to be removed. - -> t -- ^ The declarations - -> RefactGhc (t,Maybe (GHC.LSig GHC.RdrName)) - -- ^ The result and removed signature, if there - -- was one - - -- NOTE: It may have originated from a SigD, it is up - -- to the calling function to insert this if required -rmTypeSig pn t - = do - setStateStorage StorageNone - t' <- SYB.everywhereMStaged SYB.Renamer (SYB.mkM inMatch `SYB.extM` inPatDecl `SYB.extM` inModule) t - storage <- getStateStorage - let sig' = case storage of - StorageSigRdr sig -> Just sig - StorageNone -> Nothing - x -> error $ "rmTypeSig: unexpected value in StateStorage:" ++ (show x) - return (t',sig') - where - inModule :: GHC.ParsedSource -> RefactGhc GHC.ParsedSource - inModule (modu :: GHC.ParsedSource) - = doRmTypeSig modu - - -- Deals with the distrinct parts of a FunBind - inMatch :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName) - -> RefactGhc (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) - inMatch x@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ _localDecls))) - = doRmTypeSig x - - inPatDecl ::GHC.LHsDecl GHC.RdrName -> RefactGhc (GHC.LHsDecl GHC.RdrName) - inPatDecl x@(GHC.L _ (GHC.ValD (GHC.PatBind _ _ _ _ _))) = do - decls <- liftT $ hsDeclsPatBindD x - decls' <- doRmTypeSigDecls decls - liftT $ replaceDeclsPatBindD x decls' - - inPatDecl x = return x - - -- ---------------------------------- - - doRmTypeSig :: (HasDecls t) => t -> RefactGhc t - doRmTypeSig parent = do - decls <- liftT $ hsDecls parent - decls' <- doRmTypeSigDecls decls - liftT $ replaceDecls parent decls' - - - doRmTypeSigDecls :: [GHC.LHsDecl GHC.RdrName] -> RefactGhc [GHC.LHsDecl GHC.RdrName] - doRmTypeSigDecls decls = do - isDone <- getDone - if isDone - then return decls - else do - -- logDataWithAnns "doRmTypeSig:decls" decls - nameMap <- getRefactNameMap - let (decls1,decls2)= break (definesSigDRdr nameMap pn) decls - if not $ null decls2 - then do - -- logDataWithAnns "doRmTypeSig:parent" parent - let sig@(GHC.L sspan (GHC.SigD (GHC.TypeSig names typ p))) = ghead "rmTypeSig" decls2 - if length names > 1 - then do - let newNames = filter (\rn -> rdrName2NamePure nameMap rn /= pn) names - newSig = GHC.L sspan (GHC.SigD (GHC.TypeSig newNames typ p)) - - liftT $ removeTrailingCommaT (glast "doRmTypeSig" newNames) - - let pnt = ghead "rmTypeSig" (filter (\rn -> rdrName2NamePure nameMap rn == pn) names) - liftT $ removeTrailingCommaT pnt - - -- Construct the old signature, by keeping the - -- signature part but discarding the other names - newSpan <- liftT uniqueSrcSpanT - let oldSig = (GHC.L newSpan (GHC.TypeSig [pnt] typ p)) - liftT $ modifyAnnsT (copyAnn sig oldSig) - setStateStorage (StorageSigRdr oldSig) - - return (decls1++[newSig]++gtail "doRmTypeSig" decls2) - else do - let [oldSig] = decl2Sig sig - setStateStorage (StorageSigRdr oldSig) - decls' <- doRmDecl decls1 decls2 - return decls' - else do - return decls - - getDone = do - s <- getStateStorage - case s of - StorageNone -> return False - _ -> return True - --- --------------------------------------------------------------------- - --- TODO: Is this function needed with GHC? - --- | Remove the qualifier from the given identifiers in the given syntax phrase. -rmQualifier:: (SYB.Data t) - =>[GHC.Name] -- ^ The identifiers. - ->t -- ^ The syntax phrase. - ->RefactGhc t -- ^ The result. -rmQualifier pns t = do - nm <- getRefactNameMap - SYB.everywhereM (nameSybTransform (rename nm)) t - where - rename nm (ln@(GHC.L l pn)::GHC.Located GHC.RdrName) - | elem (rdrName2NamePure nm ln) pns - = do - case pn of - GHC.Qual _ n -> return (GHC.L l (GHC.Unqual n)) - _ -> return ln - rename _ x = return x - --- --------------------------------------------------------------------- - --- | Replace all occurences of a top level GHC.Name with a qualified version. -qualifyToplevelName :: GHC.Name -> RefactGhc () -qualifyToplevelName n = do - parsed <- getRefactParsed - parsed' <- renamePN n n True parsed - putRefactParsed parsed' emptyAnns - return () - --- --------------------------------------------------------------------- - -data HowToQual = Qualify | NoQualify | PreserveQualify - deriving (Show,Eq) - --- | Rename each occurrences of the identifier in the given syntax --- phrase with the new name. - --- TODO: the syntax phrase is required to be GHC.Located, not sure how --- to specify this without breaking the everywhereMStaged call - -renamePN::(SYB.Data t) - =>GHC.Name -- ^ The identifier to be renamed. - ->GHC.Name -- ^ The new name, including possible qualifier - ->Bool -- ^ True means use the qualified form for - -- the new name. - ->t -- ^ The syntax phrase - ->RefactGhc t -renamePN oldPN newName useQual t = do - -- logm $ "renamePN: (oldPN,newName)=" ++ (showGhc (oldPN,newName)) - -- logm $ "renamePN: t=" ++ (SYB.showData SYB.Parser 0 t) - nameMap <- getRefactNameMap - newNameQual <- rdrNameFromName True newName - newNameUnqual <- rdrNameFromName False newName - newNameRdr <- rdrNameFromName useQual newName - -- logm $ "renamePN: (newNameQual,newNameUnqual,newNameRdr)=" ++ showGhc (newNameQual,newNameUnqual,newNameRdr) - - let - cond :: GHC.Located GHC.RdrName -> Bool - cond (GHC.L ln _) = - case Map.lookup ln nameMap of - Nothing -> False - Just n -> GHC.nameUnique n == GHC.nameUnique oldPN - - -- Decision process for new names - newNameCalcBool :: Bool -> GHC.RdrName -> GHC.RdrName - newNameCalcBool True n = newNameCalc Qualify n - newNameCalcBool False n = newNameCalc NoQualify n - - newNameCalc :: HowToQual -> GHC.RdrName -> GHC.RdrName - newNameCalc uq old = newNameCalc' uq (GHC.isQual_maybe old) - where - newNameCalc' :: HowToQual -> (Maybe (GHC.ModuleName,GHC.OccName)) -> GHC.RdrName - newNameCalc' Qualify (Just (mn,_)) = GHC.Qual mn (GHC.occName newName) - newNameCalc' PreserveQualify (Just (mn,_)) = GHC.Qual mn (GHC.occName newName) - newNameCalc' NoQualify (Just (_n,_)) = GHC.Unqual (GHC.occName newName) - newNameCalc' uq' _ = if uq' == Qualify then newNameQual else newNameUnqual - - rename :: Bool -> GHC.Located GHC.RdrName -> Transform (GHC.Located GHC.RdrName) - rename useQual' old@(GHC.L l n) - | cond (GHC.L l n) - = do - logTr $ "renamePN:rename at :" ++ showGhc l - let nn = newNameCalcBool useQual' n - -- A RdrName Can have a number of constructors, which are used to - -- index the annotations associated with it. Make sure the annotation - -- lines up. - let new = (GHC.L l nn) - modifyAnnsT (replaceAnnKey old new) - - return new - rename _ x = return x - - renameVar :: Bool -> (GHC.Located (GHC.HsExpr GHC.RdrName)) -> Transform (GHC.Located (GHC.HsExpr GHC.RdrName)) - renameVar useQual' (GHC.L l (GHC.HsVar n)) - | cond (GHC.L l n) - = do - logTr $ "renamePN:renameVar at :" ++ (showGhc l) - -- logTr $ "renamePN:renameVar useQual' :" ++ (show useQual') - -- logTr $ "renamePN:renameVar ln :" ++ SYB.showData SYB.Parser 0 (GHC.L l (GHC.HsVar n)) - let - nn = if useQual' - then newNameCalcBool useQual' n - else newNameCalc PreserveQualify n - return (GHC.L l (GHC.HsVar nn)) - renameVar _ x = return x - - -- HsTyVar {Name: Renaming.D1.Tree})) - renameTyVar :: Bool -> (GHC.Located (GHC.HsType GHC.RdrName)) -> Transform (GHC.Located (GHC.HsType GHC.RdrName)) - renameTyVar useQual' (GHC.L l (GHC.HsTyVar n)) - | cond (GHC.L l n) - = do - logTr $ "renamePN:renameTyVar at :" ++ (showGhc l) - let nn = newNameCalcBool useQual' n - return (GHC.L l (GHC.HsTyVar nn)) - renameTyVar _ x = return x - - - renameHsTyVarBndr :: Bool -> GHC.LHsTyVarBndr GHC.RdrName -> Transform (GHC.LHsTyVarBndr GHC.RdrName) - renameHsTyVarBndr useQual' (GHC.L l (GHC.UserTyVar n)) - | cond (GHC.L l n) - = do - logTr $ "renamePN:renameHsTyVarBndr at :" ++ (showGhc l) - let nn = newNameCalcBool useQual' n - return (GHC.L l (GHC.UserTyVar nn)) - renameHsTyVarBndr _ x = return x - - -- --------------------------------- - - renameLIE :: Bool -> (GHC.LIE GHC.RdrName) -> Transform (GHC.LIE GHC.RdrName) - renameLIE useQual' (GHC.L l (GHC.IEVar old@(GHC.L ln n))) - | cond (GHC.L ln n) - = do - -- logTr $ "renamePN:renameLIE.IEVar at :" ++ (showGhc l) - let new = newNameCalcBool useQual' n - - let newn = (GHC.L ln new) - modifyAnnsT (replaceAnnKey old newn) - - return (GHC.L l (GHC.IEVar (GHC.L ln new))) - - renameLIE useQual' (GHC.L l (GHC.IEThingAbs old@(GHC.L ln n))) - | cond (GHC.L l n) - = do - -- logTr $ "renamePN:renameLIE.IEThingAbs at :" ++ (showGhc l) - let new = newNameCalcBool useQual' n - - let newn = (GHC.L ln new) - modifyAnnsT (replaceAnnKey old newn) - - return (GHC.L l (GHC.IEThingAbs (GHC.L ln new))) - - renameLIE useQual' (GHC.L l (GHC.IEThingAll old@(GHC.L ln n))) - | cond (GHC.L ln n) - = do - -- logTr $ "renamePN:renameLIE.IEThingAll at :" ++ (showGhc l) - let new = newNameCalcBool useQual' n - - let newn = (GHC.L ln new) - modifyAnnsT (replaceAnnKey old newn) - - return (GHC.L l (GHC.IEThingAll (GHC.L ln new))) - - -- TODO: check inside the ns here too - renameLIE useQual' (GHC.L l (GHC.IEThingWith old@(GHC.L ln n) ns)) - = do - - old' <- if (cond (GHC.L ln n)) - then do - logTr $ "renamePN:renameLIE.IEThingWith at :" ++ (showGhc l) - let new = newNameCalcBool useQual' n - - let newn = (GHC.L ln new) - modifyAnnsT (replaceAnnKey old newn) - - return (GHC.L ln new) - else return old - - - ns' <- if (any (\(GHC.L lnn nn) -> cond (GHC.L lnn nn)) ns) - then renameTransform useQual' ns - else return ns - return (GHC.L l (GHC.IEThingWith old' ns')) - - renameLIE _ x = do - -- logTr $ "renamePN:renameLIE miss for :" ++ (showGhc x) - return x - - -- --------------------------------- - - renameLPat :: Bool -> (GHC.LPat GHC.RdrName) -> Transform (GHC.LPat GHC.RdrName) - renameLPat useQual' (GHC.L l (GHC.VarPat n)) - | cond (GHC.L l n) - = do - logTr $ "renamePNworker:renameLPat at :" ++ (showGhc l) - let nn = newNameCalcBool useQual' n - return (GHC.L l (GHC.VarPat nn)) - renameLPat _ x = return x - - renameFunBind :: Bool -> GHC.HsBindLR GHC.RdrName GHC.RdrName -> Transform (GHC.HsBindLR GHC.RdrName GHC.RdrName) - renameFunBind _useQual (GHC.FunBind (GHC.L ln n) fi (GHC.MG matches a typ o) co fvs tick) - | cond (GHC.L ln n) - = do -- Need to (a) rename the actual funbind name - -- NOTE: due to bottom-up traversal, (a) should - -- already have been done. - -- (b) rename each of 'tail matches' - -- (head is renamed in (a) ) - -- logTr $ "renamePN.renameFunBind" - -- Now do (b) - logTr $ "renamePN.renameFunBind.renameFunBind:starting matches" - let w lmatch@(GHC.L lm (GHC.Match mln pats typ' grhss)) = do - case mln of - Just (old@(GHC.L lmn _),f) -> do - -- A RdrName Can have a number of constructors, which are used to - -- index the annotations associated with it. Make sure the annotation - -- lines up. - let new = (GHC.L lmn newNameUnqual) - modifyAnnsT (replaceAnnKey old new) - - return (GHC.L lm (GHC.Match (Just (new,f)) pats typ' grhss)) - Nothing -> return lmatch - matches' <- mapM w matches - logTr $ "renamePN.renameFunBind.renameFunBind.renameFunBind:matches done" - return (GHC.FunBind (GHC.L ln newNameRdr) fi (GHC.MG matches' a typ o) co fvs tick) - renameFunBind _ x = return x - - renameImportDecl :: Bool -> (GHC.ImportDecl GHC.RdrName) -> Transform (GHC.ImportDecl GHC.RdrName) - renameImportDecl _useQual (GHC.ImportDecl src mn mq isrc isafe iq ii ma (Just (ij,GHC.L ll ies))) = do - ies' <- mapM (renameLIE False) ies - logTr $ "renamePN'.renameImportDecl:(ies,ies')=" ++ showGhc (ies,ies') - return (GHC.ImportDecl src mn mq isrc isafe iq ii ma (Just (ij,GHC.L ll ies'))) - renameImportDecl _ x = return x - - renameTypeSig :: Bool -> (GHC.Sig GHC.RdrName) -> Transform (GHC.Sig GHC.RdrName) - renameTypeSig _useQual (GHC.TypeSig ns typ p) - = do - logTr $ "renamePN:renameTypeSig" - -- Has already been renamed, make sure qualifier is removed - ns' <- renameTransform False ns - typ' <- renameTransform False typ - logTr $ "renamePN:renameTypeSig done" - return (GHC.TypeSig ns' typ' p) - renameTypeSig _ x = return x - - renameTransform useQual' t' = - -- Note: bottom-up traversal (no ' at end) - (SYB.everywhereM ( - -- (everywhereM' ( - SYB.mkM (rename useQual') - `SYB.extM` (renameVar useQual') - `SYB.extM` (renameTyVar useQual') - `SYB.extM` (renameHsTyVarBndr useQual') - `SYB.extM` (renameLIE useQual') - `SYB.extM` (renameLPat useQual') - `SYB.extM` (renameTypeSig useQual') - `SYB.extM` (renameImportDecl useQual') - `SYB.extM` (renameFunBind useQual') - ) t') - t' <- liftT (renameTransform useQual t) - return t' - --- --------------------------------------------------------------------- - --- | Check whether the specified identifier is declared in the given syntax phrase t, --- if so, rename the identifier by creating a new name automatically. -autoRenameLocalVar:: (SYB.Data t) - => GHC.Name -- ^ The identifier. - -> t -- ^ The syntax phrase. - -> RefactGhc t -- ^ The result. -autoRenameLocalVar pn t = do - logm $ "autoRenameLocalVar: (pn)=" ++ (showGhc (pn)) - -- = everywhereMStaged SYB.Renamer (SYB.mkM renameInMatch) - nm <- getRefactNameMap - decls <- liftT $ hsDeclsGeneric t - if isDeclaredInRdr nm pn decls - then do t' <- worker t - return t' - else do return t - - where - worker :: (SYB.Data t) => t -> RefactGhc t - worker tt - =do (f,d) <- hsFDNamesFromInsideRdr tt - ds <- hsVisibleNamesRdr pn tt - let newNameStr = mkNewName (nameToString pn) (nub (f `union` d `union` ds)) 1 - newName <- mkNewGhcName Nothing newNameStr - renamePN pn newName False tt - --- --------------------------------------------------------------------- - -isMainModule :: GHC.Module -> Bool -isMainModule modu = GHC.modulePackageKey modu == GHC.mainPackageKey - --- --------------------------------------------------------------------- - --- | Return the identifier's defining location. --- defineLoc::PNT->SrcLoc -defineLoc :: GHC.Located GHC.Name -> GHC.SrcLoc -defineLoc (GHC.L _ name) = GHC.nameSrcLoc name - --- | Return the identifier's source location. --- useLoc::PNT->SrcLoc -useLoc:: (GHC.Located GHC.Name) -> GHC.SrcLoc --- useLoc (GHC.L l _) = getGhcLoc l -useLoc (GHC.L l _) = GHC.srcSpanStart l - --- --------------------------------------------------------------------- - --- | Return True if the identifier is used in the RHS if a --- function\/pattern binding. -isUsedInRhs::(SYB.Data t) => (GHC.Located GHC.Name) -> t -> Bool -isUsedInRhs pnt t = useLoc pnt /= defineLoc pnt && not (notInLhs) - where - notInLhs = fromMaybe False $ SYB.somethingStaged SYB.Parser Nothing - (Nothing `SYB.mkQ` inMatch `SYB.extQ` inDecl) t - where - inMatch ((GHC.FunBind name _ (GHC.MG _matches _ _ _) _ _ _) :: GHC.HsBind GHC.Name) - | isJust (find (sameOccurrence pnt) [name]) = Just True - inMatch _ = Nothing - - inDecl ((GHC.TypeSig is _ _) :: GHC.Sig GHC.Name) - |isJust (find (sameOccurrence pnt) is) = Just True - inDecl _ = Nothing - --- --------------------------------------------------------------------- --- | Find all occurrences with location of the given name -findAllNameOccurences :: (SYB.Data t) => GHC.Name -> t -> [(GHC.Located GHC.Name)] -findAllNameOccurences name t - = res - where - res = SYB.everythingStaged SYB.Renamer (++) [] - ([] `SYB.mkQ` worker `SYB.extQ` workerBind `SYB.extQ` workerExpr) t - - worker (ln@(GHC.L _l n) :: (GHC.Located GHC.Name)) - | GHC.nameUnique n == GHC.nameUnique name = [ln] - worker _ = [] - - workerBind (GHC.L l (GHC.VarPat n) :: (GHC.Located (GHC.Pat GHC.Name))) - | GHC.nameUnique n == GHC.nameUnique name = [(GHC.L l n)] - workerBind _ = [] - - workerExpr (GHC.L l (GHC.HsVar n) :: (GHC.Located (GHC.HsExpr GHC.Name))) - | GHC.nameUnique n == GHC.nameUnique name = [(GHC.L l n)] - workerExpr _ = [] - --- --------------------------------------------------------------------- - -findNameInRdr :: (SYB.Data t) => NameMap -> GHC.Name -> t -> Bool -findNameInRdr nm pn t = - isJust $ SYB.something (Nothing `SYB.mkQ` worker) t - where - worker (ln :: GHC.Located GHC.RdrName) - | GHC.nameUnique pn == GHC.nameUnique (rdrName2NamePure nm ln) = Just True - worker _ = Nothing - --- --------------------------------------------------------------------- - --- | Return True if the identifier occurs in the given syntax phrase. -findPNT::(SYB.Data t) => GHC.Located GHC.Name -> t -> Bool -findPNT (GHC.L _ pn) = findPN pn - --- | Return True if the identifier occurs in the given syntax phrase. -findPN::(SYB.Data t)=> GHC.Name -> t -> Bool -findPN pn - = isJust . SYB.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` worker) - where - worker (n::GHC.Name) - | GHC.nameUnique pn == GHC.nameUnique n = Just True - worker _ = Nothing - --- | Return True if any of the specified PNames ocuur in the given syntax phrase. -findPNs::(SYB.Data t)=> [GHC.Name] -> t -> Bool -findPNs pns - = isJust . SYB.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` worker) - where - uns = map GHC.nameUnique pns - - worker (n::GHC.Name) - | elem (GHC.nameUnique n) uns = Just True - worker _ = Nothing - --- --------------------------------------------------------------------- - --- | Return True if any of the specified PNames ocuur in the given syntax phrase. -findNamesRdr :: (SYB.Data t) => NameMap -> [GHC.Name] -> t -> Bool -findNamesRdr nm pns t = - isJust $ SYB.something (inName) t - where - -- r = (SYB.everythingStaged SYB.Parser mappend mempty (inName) t) - - checker :: GHC.Located GHC.RdrName -> Maybe Bool - checker ln - | elem (GHC.nameUnique (rdrName2NamePure nm ln)) uns = Just True - checker _ = Nothing - - inName :: (SYB.Typeable a) => a -> Maybe Bool - inName = nameSybQuery checker - - uns = map GHC.nameUnique pns - --- --------------------------------------------------------------------- - --- | Return the type checked `GHC.Id` corresponding to the given --- `GHC.Name` - --- TODO: there has to be a simpler way, using the appropriate GHC internals -findIdForName :: GHC.Name -> RefactGhc (Maybe GHC.Id) -findIdForName n = do - tm <- getTypecheckedModule - let t = GHC.tm_typechecked_source tm - let r = SYB.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` worker) t - worker (i::GHC.Id) - | (GHC.nameUnique n) == (GHC.varUnique i) = Just i - worker _ = Nothing - return r - --- --------------------------------------------------------------------- - -getTypeForName :: GHC.Name -> RefactGhc (Maybe GHC.Type) -getTypeForName n = do - mId <- findIdForName n - case mId of - Nothing -> return Nothing - Just i -> return $ Just (GHC.varType i) - --- --------------------------------------------------------------------- - --- | Given the syntax phrase, find the largest-leftmost expression --- contained in the region specified by the start and end position, if --- found. -locToExp:: (SYB.Data t,SYB.Typeable n) => - SimpPos -- ^ The start position. - -> SimpPos -- ^ The end position. - -> t -- ^ The syntax phrase. - -> Maybe (GHC.Located (GHC.HsExpr n)) -- ^ The result. -locToExp beginPos endPos t = res - where - res = SYB.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` expr) t - - expr :: GHC.Located (GHC.HsExpr n) -> (Maybe (GHC.Located (GHC.HsExpr n))) - expr e - |inScope e = Just e - expr _ = Nothing - - inScope :: GHC.Located e -> Bool - inScope (GHC.L l _) = - let - (startLoc,endLoc) = case l of - (GHC.RealSrcSpan ss) -> - ((GHC.srcSpanStartLine ss,GHC.srcSpanStartCol ss), - (GHC.srcSpanEndLine ss,GHC.srcSpanEndCol ss)) - (GHC.UnhelpfulSpan _) -> ((0,0),(0,0)) - in - (startLoc>=beginPos) && (startLoc<= endPos) && (endLoc>= beginPos) && (endLoc<=endPos) - --------------------------------------------------------------------------------- - - -ghcToPN :: GHC.RdrName -> PName -ghcToPN rdr = PN rdr - -lghcToPN :: GHC.Located GHC.RdrName -> PName -lghcToPN (GHC.L _ rdr) = PN rdr - - --- | If an expression consists of only one identifier then return this --- identifier in the GHC.Name format, otherwise return the default Name -expToName:: GHC.LHsExpr GHC.Name -> GHC.Name -- TODO: Use a Maybe, rather than defaultName -expToName (GHC.L _ (GHC.HsVar pnt)) = pnt -expToName (GHC.L _ (GHC.HsPar e)) = expToName e -expToName _ = defaultName - --- | If an expression consists of only one identifier then return this --- identifier in the GHC.Name format, otherwise return the default Name -expToNameRdr :: NameMap -> GHC.LHsExpr GHC.RdrName -> Maybe GHC.Name -expToNameRdr nm (GHC.L l (GHC.HsVar pnt)) = Just (rdrName2NamePure nm (GHC.L l pnt)) -expToNameRdr nm (GHC.L _ (GHC.HsPar e)) = expToNameRdr nm e -expToNameRdr _ _ = Nothing - -nameToString :: GHC.Name -> String --- nameToString name = showGhc name -nameToString name = showGhcQual name - --- | If a pattern consists of only one identifier then return this --- identifier, otherwise return Nothing -patToNameRdr :: NameMap -> GHC.LPat GHC.RdrName -> Maybe GHC.Name -patToNameRdr nm (GHC.L l (GHC.VarPat n)) = Just (rdrName2NamePure nm (GHC.L l n)) -patToNameRdr _ _ = Nothing - --- | If a pattern consists of only one identifier then return this --- identifier, otherwise return Nothing -patToPNT :: GHC.LPat GHC.Name -> Maybe GHC.Name -patToPNT (GHC.L _ (GHC.VarPat n)) = Just n -patToPNT _ = Nothing - --- | Compose a pattern from a pName. -pNtoPat :: name -> GHC.Pat name -pNtoPat pname = GHC.VarPat pname + , hsQualifier + + -- ** Property checking + ,isVarId,isConId,isOperator,isTopLevelPN,isLocalPN,isNonLibraryName + ,isQualifiedPN, isFunOrPatName, isTypeSig, isTypeSigDecl + ,isFunBindP,isFunBindR,isPatBindP,isPatBindR,isSimplePatBind,isSimplePatDecl + ,isComplexPatBind,isComplexPatDecl,isFunOrPatBindP,isFunOrPatBindR + + -- ** Getting + , findEntity' + , findIdForName + , getTypeForName + + ,definesTypeSigRdr + ,sameBindRdr + ,UsedByRhs(..) + + -- ** Modules and files + -- ,clientModsAndFiles,serverModsAndFiles,isAnExistingMod + -- ,fileNameToModName, strToModName, modNameToStr + , isMainModule + , getModule + + -- ** Locations + ,defineLoc, useLoc, locToExp + -- ,locToName + , locToRdrName + ,getName + + -- * Program transformation + -- ** Adding + ,addDecl, addItemsToImport, addItemsToExport, addHiding + ,addParamsToDecls, addParamsToSigs, addActualParamsToRhs, addImportDecl, duplicateDecl + + -- ** Removing + ,rmDecl, rmTypeSig, rmTypeSigs -- , commentOutTypeSig, rmParams + -- ,rmItemsFromExport, rmSubEntsFromExport, Delete(delete) + + -- ** Updating + , rmQualifier, qualifyToplevelName, renamePN, HowToQual(..), autoRenameLocalVar + + -- ** Identifiers, expressions, patterns and declarations + , expToNameRdr + ,nameToString + ,patToNameRdr + , pNtoPat + , usedWithoutQualR + + -- ** Others + , divideDecls + , mkRdrName,mkQualifiedRdrName,mkNewGhcName,mkNewName,mkNewToplevelName + , registerRdrName + + -- The following functions are not in the the API yet. + , causeNameClashInExports {- , inRegion , unmodified -} + + , declsSybTransform + + -- * Typed AST traversals (added by CMB) + -- * Miscellous + -- ,removeFromInts, getDataName, checkTypes, getPNs, getPN, getPNPats, mapASTOverTAST + + -- * Debug stuff + , rdrNameFromName + ) where + +import Control.Monad.State +import Data.Char +import Data.Foldable +import Data.List +import Data.Maybe +import Exception + +import Language.Haskell.Refact.Utils.ExactPrint +import Language.Haskell.Refact.Utils.GhcUtils +import Language.Haskell.Refact.Utils.GhcVersionSpecific +import Language.Haskell.Refact.Utils.LocUtils +import Language.Haskell.Refact.Utils.Monad +import Language.Haskell.Refact.Utils.MonadFunctions +import Language.Haskell.Refact.Utils.TypeSyn +import Language.Haskell.Refact.Utils.Types +import Language.Haskell.Refact.Utils.Variables + +import Language.Haskell.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint.Types +import Language.Haskell.GHC.ExactPrint.Utils + + +-- Modules from GHC +import qualified FastString as GHC +import qualified GHC as GHC +import qualified Module as GHC +import qualified Name as GHC +import qualified Outputable as GHC +import qualified RdrName as GHC +import qualified TyCon as GHC +#if __GLASGOW_HASKELL__ <= 710 +import qualified TypeRep as GHC +#else +import qualified TyCoRep as GHC +import qualified BasicTypes as GHC +#endif +import qualified Unique as GHC +import qualified Var as GHC + +import qualified Var as Var + +import qualified Data.Generics as SYB +import qualified GHC.SYB.Utils as SYB + +import qualified Data.Map as Map + +import Data.Generics.Strafunski.StrategyLib.StrategyLib hiding (liftIO,MonadPlus,mzero) + +-- --------------------------------------------------------------------- +-- |Process the inscope relation returned from the parsing and module +-- analysis pass, and return a list of four-element tuples. Each tuple +-- contains an identifier name, the identifier's namespace info, the +-- identifier's defining module name and its qualifier name. +-- +-- The same identifier may have multiple entries in the result because +-- it may have different qualifiers. This makes it easier to decide +-- whether the identifier can be used unqualifiedly by just checking +-- whether there is an entry for it with the qualifier field being +-- Nothing. +-- +inScopeInfo :: InScopes -- ^ The inscope relation . + ->[(String, GHC.NameSpace, GHC.ModuleName, Maybe GHC.ModuleName)] -- ^ The result +inScopeInfo names = nub $ map getEntInfo $ names + where + getEntInfo name + =(showGhc name, + GHC.occNameSpace $ GHC.nameOccName name, + GHC.moduleName $ GHC.nameModule name, + getQualMaybe $ GHC.nameRdrName name) + + getQualMaybe rdrName = case rdrName of + GHC.Qual modName _occName -> Just modName + _ -> Nothing + + +-- --------------------------------------------------------------------- + +-- | Return True if the identifier is inscope and can be used without +-- a qualifier. +isInScopeAndUnqualified::String -- ^ The identifier name. + ->InScopes -- ^ The inscope relation + ->Bool -- ^ The result. +isInScopeAndUnqualified n names + = isJust $ find (\ (x, _,_, qual) -> x == n && isNothing qual ) $ inScopeInfo names + +-- | Return True if the identifier is inscope and can be used without +-- a qualifier. The identifier name string may have a qualifier +-- already +-- NOTE: may require qualification based on name clash with an +-- existing identifier. +isInScopeAndUnqualifiedGhc :: + String -- ^ The identifier name. + -> (Maybe GHC.Name) -- ^ Existing name, to be excluded from test, if + -- known + -> RefactGhc Bool -- ^ The result. +isInScopeAndUnqualifiedGhc n maybeExising = do + names <- ghandle handler (GHC.parseName n) + logm $ "isInScopeAndUnqualifiedGhc:(n,(maybeExising,names))=" ++ (show n) ++ ":" ++ (showGhc (maybeExising,names)) + ctx <- GHC.getContext + logm $ "isInScopeAndUnqualifiedGhc:ctx=" ++ (showGhc ctx) + let nameList = case maybeExising of + Nothing -> names + Just n' -> filter (\x -> (showGhcQual x) /= (showGhcQual n')) names + logm $ "isInScopeAndUnqualifiedGhc:(n,nameList)=" ++ (show n) ++ ":" ++ (showGhc nameList) + return $ nameList /= [] + + where + handler:: SomeException -> RefactGhc [GHC.Name] + handler e = do + logm $ "isInScopeAndUnqualifiedGhc.handler e=" ++ (show e) + return [] + +-- --------------------------------------------------------------------- + +-- |Return all 'GHC.Name's that correspond to the given string, in the current +-- module. + +-- Note: this returns a list because TH constructor names do not have the +-- correct namespace so the two variants are returned, constructor and +-- non-constructor. I suspect that when this is looked up only one will ever +-- come through. Hence we should only ever see 0 or 1 names here. +inScopeNames :: String -- ^ The identifier name. + -> RefactGhc [GHC.Name] -- ^ The result. +inScopeNames n = do + names <- ghandle handler (GHC.parseName n) + logm $ "inScopeNames:(n,names)=" ++ (show n) ++ ":" ++ (showGhc names) + return $ names + + where + handler:: SomeException -> RefactGhc [GHC.Name] + handler e = do + logm $ "inScopeNames.handler e=" ++ (show e) + return [] + +-- --------------------------------------------------------------------- + +-- |Given a 'GHC.Name' defined in one module, find the equivalent one in the +-- currently loaded module. This is required otherwise name equality checking +-- based on 'GHC.nameUnique' will fail. +equivalentNameInNewMod :: GHC.Name -> RefactGhc [GHC.Name] +equivalentNameInNewMod old = do + -- we have to do it this way otherwise names imported qualified will not be + -- detected + + -- ghc-mod 5.6 introduced a funny whereby the packagekey for the inscopes is + -- "main@main" but for the current file is "main@main" + -- So ignore the packagekey for now + -- See https://github.com/DanielG/ghc-mod/issues/811 + -- TODO: revisit this + -- let eqModules (GHC.Module pk1 mn1) (GHC.Module pk2 mn2) = mn1 == mn2 + let eqModules (GHC.Module pk1 mn1) (GHC.Module pk2 mn2) = mn1 == mn2 && pk1 == pk2 + + gnames <- GHC.getNamesInScope + logm $ "equivalentNameInNewMod:gnames=" ++ showGhcQual (map (\n -> (GHC.nameModule n,n)) gnames) + let clientModule = GHC.nameModule old + logm $ "equivalentNameInNewMod:(old,clientModule)=" ++ showGhcQual (old,clientModule) + let clientInscopes = filter (\n -> clientModule == GHC.nameModule n) gnames + let clientInscopes = filter (\n -> eqModules clientModule (GHC.nameModule n)) gnames + logm $ "equivalentNameInNewMod:clientInscopes=" ++ showGhcQual clientInscopes + let newNames = filter (\n -> showGhcQual n == showGhcQual old) clientInscopes + return newNames + +-- --------------------------------------------------------------------- + +-- | Return all the possible qualifiers for the identifier. The identifier +-- is not inscope if the result is an empty list. NOTE: This is intended to be +-- used when processing a client module, so the 'GHC.Name' parameter is actually +-- from a different module. +hsQualifier :: GHC.Name -- ^ The identifier. + -> RefactGhc [GHC.ModuleName] -- ^ The result. +hsQualifier pname = do + names <- inScopeNames (showGhc pname) + let mods = map (GHC.moduleName . GHC.nameModule) names + return mods + +-- --------------------------------------------------------------------- + +-- |Make a qualified 'GHC.RdrName' +mkQualifiedRdrName :: GHC.ModuleName -> String -> GHC.RdrName +mkQualifiedRdrName mn s = GHC.mkRdrQual mn (GHC.mkVarOcc s) + +-- |Make a simple unqualified 'GHC.RdrName' +mkRdrName :: String -> GHC.RdrName +mkRdrName s = GHC.mkVarUnqual (GHC.mkFastString s) + +-- --------------------------------------------------------------------- + +-- |Register a 'GHC.Located' 'GHC.RdrName' in the 'NameMap' so it can be looked +-- up if needed. This will create a brand new 'GHC.Name', so no guarantees are +-- given as to matches later. Perhaps this is a bad idea. +registerRdrName :: GHC.Located GHC.RdrName -> RefactGhc () +registerRdrName (GHC.L l rn) = do + case GHC.isQual_maybe rn of + Nothing -> do + n <- mkNewGhcName Nothing (showGhc rn) + addToNameMap l n + Just (mn,oc) -> do +#if __GLASGOW_HASKELL__ <= 710 + n <- mkNewGhcName (Just (GHC.Module (GHC.stringToPackageKey "HaRe") mn)) (showGhc oc) +#else + n <- mkNewGhcName (Just (GHC.Module (GHC.stringToUnitId "HaRe") mn)) (showGhc oc) +#endif + addToNameMap l n + +-- --------------------------------------------------------------------- + +-- | Make a new GHC.Name, using the Unique Int sequence stored in the +-- RefactState. +mkNewGhcName :: Maybe GHC.Module -> String -> RefactGhc GHC.Name +mkNewGhcName maybeMod name = do + s <- get + u <- gets rsUniqState + put s { rsUniqState = (u+1) } + return (mkNewGhcNamePure 'H' (u + 1) maybeMod name) + + +-- --------------------------------------------------------------------- + +mkNewToplevelName :: GHC.Module -> String -> GHC.SrcSpan -> RefactGhc GHC.Name +mkNewToplevelName modid name defLoc = do + s <- get + u <- gets rsUniqState + put s { rsUniqState = (u+1) } + + let un = GHC.mkUnique 'H' (u+1) -- H for HaRe :) + n = GHC.mkExternalName un modid (GHC.mkVarOcc name) defLoc + return n + +--------------------------------------------------------------------------- + + +-- |Create a new name base on the old name. Suppose the old name is 'f', then +-- the new name would be like 'f_i' where 'i' is an integer. +mkNewName::String -- ^ The old name + ->[String] -- ^ The set of names which the new name cannot take + ->Int -- ^ The posfix value + ->String -- ^ The result +mkNewName oldName fds suffix + =let newName=if suffix==0 then oldName + else oldName++"_"++ show suffix + in if elem newName fds + then mkNewName oldName fds (suffix+1) + else newName + +-- --------------------------------------------------------------------- + +-- | Return True if the current module is exported either by default +-- or by specifying the module name in the export. +modIsExported:: GHC.ModuleName -- ^ The module name + -> GHC.RenamedSource -- ^ The AST of the module + -> Bool -- ^ The result +modIsExported modName (_g,_emps,mexps,_mdocs) + = let + modExported (GHC.L _ (GHC.IEModuleContents (GHC.L _ name))) = name == modName + modExported _ = False + + moduleExports = filter modExported $ fromMaybe [] mexps + + in if isNothing mexps + then True + else (nonEmptyList moduleExports) + +-- --------------------------------------------------------------------- + +-- | Return True if an identifier is exported by the module currently +-- being refactored. +isExported :: GHC.Name -> RefactGhc Bool +isExported n = do + typechecked <- getTypecheckedModule + let modInfo = GHC.tm_checked_module_info typechecked + return $ GHC.modInfoIsExportedName modInfo n + +-- --------------------------------------------------------------------- + +-- | Return True if an identifier is explicitly exported by the module. +isExplicitlyExported:: NameMap + -> GHC.Name -- ^ The identifier + -> GHC.ParsedSource -- ^ The AST of the module + -> Bool -- ^ The result +isExplicitlyExported nm pn (GHC.L _ p) + = findNameInRdr nm pn (GHC.hsmodExports p) + +-- --------------------------------------------------------------------- + +-- | Check if the proposed new name will conflict with an existing export +causeNameClashInExports:: NameMap + -> GHC.Name -- ^ The original name + -> GHC.Name -- ^ The new name + -> GHC.ModuleName -- ^ The identity of the module + -> GHC.ParsedSource -- ^ The AST of the module + -> Bool -- ^ The result + +-- Note that in the abstract representation of exps, there is no qualified entities. +causeNameClashInExports nm pn newName modName parsed@(GHC.L _ p) + = let exps = GHC.unLoc $ fromMaybe (GHC.noLoc []) (GHC.hsmodExports p) + varExps = concatMap nameFromExport $ filter isImpVar exps + nameFromExport (GHC.L _ (GHC.IEVar x)) = [rdrName2NamePure nm x] + nameFromExport _ = [] + -- TODO: make withoutQual part of the API + withoutQual n = showGhc $ GHC.localiseName n + modNames=nub (concatMap (\x -> if withoutQual x== withoutQual newName + then [GHC.moduleName $ GHC.nameModule x] + else []) varExps) + res = (isExplicitlyExported nm pn parsed) && + ( any modIsUnQualifedImported modNames + || elem modName modNames) + in res + where + isImpVar (GHC.L _ x) = case x of + GHC.IEVar _ -> True + _ -> False + + modIsUnQualifedImported modName' + =let + in isJust $ find (\(GHC.L _ (GHC.ImportDecl _ (GHC.L _ modName1) _qualify _source _safe isQualified _isImplicit _as _h)) + -> modName1 == modName' && (not isQualified)) (GHC.hsmodImports p) + +-- Original seems to be +-- 1. pick up any module names in the export list with same unQual + -- part as the new name +-- 2. Check if the old is exported explicitly +-- 3. if so, if the new module is exported unqualified +-- or belongs to the current module +-- then it will cause a clash + +------------------------------------------------------------------------ + +-- | Return True if the identifier is unqualifiedly used in the given syntax +-- phrase. Check in a way that the test can be done in a client module, i.e. not +-- using the nameUnique +-- usedWithoutQualR :: GHC.Name -> GHC.ParsedSource -> Bool +usedWithoutQualR :: (SYB.Data t) => GHC.Name -> t -> Bool +usedWithoutQualR name t = isJust $ SYB.something (inName) t + where + inName :: (SYB.Typeable a) => a -> Maybe Bool + inName = nameSybQuery checkName + + -- ---------------- + + checkName ((GHC.L _ pn)::GHC.Located GHC.RdrName) + -- Check the OccName match, for use in a client module refactoring + | ((GHC.rdrNameOcc pn) == (GHC.nameOccName name)) && + GHC.isUnqual pn = Just True + checkName _ = Nothing + +----------------------------------------------------------------------------- + +getModule :: RefactGhc GHC.Module +getModule = do + typechecked <- getTypecheckedModule + return $ GHC.ms_mod $ GHC.pm_mod_summary $ GHC.tm_parsed_module typechecked + +-- --------------------------------------------------------------------- + +-- | Return True if a string is a lexically valid variable name. +isVarId :: String -> Bool +isVarId mid = isId mid && isSmall (ghead "isVarId" mid) + where isSmall c=isLower c || c=='_' + +-- | Return True if a string is a lexically valid constructor name. +isConId :: String -> Bool +isConId mid = isId mid && isUpper (ghead "isConId" mid) + +-- | Return True if a string is a lexically valid operator name. +isOperator :: String -> Bool +isOperator mid = mid /= [] && isOpSym (ghead "isOperator" mid) && + isLegalOpTail (tail mid) && not (isReservedOp mid) + where + isOpSym mid' = elem mid' opSymbols + where opSymbols = ['!', '#', '$', '%', '&', '*', '+','.','/','<','=','>','?','@','\'','^','|','-','~'] + + isLegalOpTail tail' = all isLegal tail' + where isLegal c = isOpSym c || c==':' + + isReservedOp mid' = elem mid' reservedOps + where reservedOps = ["..", ":","::","=","\"", "|","<-","@","~","=>"] + +-- | Returns True if a string lexically is an identifier. +-- *This function should not be exported.* +isId::String->Bool +isId mid = mid/=[] && isLegalIdTail (tail mid) && not (isReservedId mid) + where + isLegalIdTail tail' = all isLegal tail' + where isLegal c=isSmall c|| isUpper c || isDigit c || c=='\'' + + isReservedId mid' = elem mid' reservedIds + where reservedIds=["case", "class", "data", "default", "deriving","do","else" ,"if", + "import", "in", "infix","infixl","infixr","instance","let","module", + "newtype", "of","then","type","where","_"] + + isSmall c=isLower c || c=='_' + +----------------------------------------------------------------------------- + +-- |Return True if a PName is a toplevel PName. +isTopLevelPN::GHC.Name -> RefactGhc Bool +isTopLevelPN n = do + typechecked <- getTypecheckedModule + let maybeNames = GHC.modInfoTopLevelScope $ GHC.tm_checked_module_info typechecked + let names = fromMaybe [] maybeNames + return $ n `elem` names + + +-- |Return True if a PName is a local PName. +isLocalPN::GHC.Name -> Bool +isLocalPN = GHC.isInternalName + +-- |Return True if the name has a @GHC.SrcSpan@, i.e. is declared in +-- source we care about +isNonLibraryName :: GHC.Name -> Bool +isNonLibraryName n = case (GHC.nameSrcSpan n) of + GHC.UnhelpfulSpan _ -> False + _ -> True + +-- |Return True if a PName is a function\/pattern name defined in t. +isFunOrPatName :: (SYB.Data t) => NameMap -> GHC.Name -> t -> Bool +isFunOrPatName nm pn + = isJust . SYB.something (Nothing `SYB.mkQ` worker `SYB.extQ` workerDecl) + where + worker (decl::GHC.LHsBind GHC.RdrName) + | definesRdr nm pn decl = Just True + worker _ = Nothing + + workerDecl (GHC.L l (GHC.ValD decl)::GHC.LHsDecl GHC.RdrName) + | definesRdr nm pn (GHC.L l decl) = Just True + workerDecl _ = Nothing + +------------------------------------------------------------------------------- +-- |Return True if a PName is a qualified PName. +-- AZ:NOTE: this tests the use instance, the underlying name may be qualified. +-- e.g. used name is zip, GHC.List.zip +-- NOTE2: not sure if this gives a meaningful result for a GHC.Name +isQualifiedPN :: GHC.Name -> RefactGhc Bool +isQualifiedPN name = return $ GHC.isQual $ GHC.nameRdrName name + + +-- | Return True if a declaration is a type signature declaration. +isTypeSig :: GHC.LSig a -> Bool +isTypeSig (GHC.L _ (GHC.TypeSig{})) = True +isTypeSig _ = False + +-- | Return True if a declaration is a type signature declaration. +isTypeSigDecl :: GHC.LHsDecl a -> Bool +isTypeSigDecl (GHC.L _ (GHC.SigD (GHC.TypeSig{}))) = True +isTypeSigDecl _ = False + +-- | Return True if a declaration is a function definition. +isFunBindP :: GHC.LHsDecl GHC.RdrName -> Bool +isFunBindP (GHC.L _ (GHC.ValD (GHC.FunBind{}))) = True +isFunBindP _ =False + +isFunBindR::GHC.LHsBind t -> Bool +isFunBindR (GHC.L _l (GHC.FunBind{})) = True +isFunBindR _ =False + +-- | Returns True if a declaration is a pattern binding. +isPatBindP :: GHC.LHsDecl GHC.RdrName -> Bool +isPatBindP (GHC.L _ (GHC.ValD (GHC.PatBind _ _ _ _ _))) = True +isPatBindP _=False + +isPatBindR :: GHC.LHsBind t -> Bool +isPatBindR (GHC.L _ (GHC.PatBind _ _ _ _ _)) = True +isPatBindR _=False + + +-- | Return True if a declaration is a pattern binding which only +-- defines a variable value. +isSimplePatDecl :: GHC.LHsDecl GHC.RdrName -> Bool +isSimplePatDecl decl = case decl of + (GHC.L _l (GHC.ValD (GHC.PatBind p _rhs _ty _fvs _))) -> hsNamessRdr p /= [] + _ -> False + +-- | Return True if a declaration is a pattern binding which only +-- defines a variable value. +isSimplePatBind :: (GHC.DataId t) => GHC.LHsBind t-> Bool +isSimplePatBind decl = case decl of + (GHC.L _l (GHC.PatBind p _rhs _ty _fvs _)) -> hsNamessRdr p /= [] + _ -> False + +-- | Return True if a declaration is a pattern binding but not a simple one. +isComplexPatDecl::GHC.LHsDecl name -> Bool +isComplexPatDecl (GHC.L l (GHC.ValD decl)) = isComplexPatBind (GHC.L l decl) +isComplexPatDecl _ = False + +-- | Return True if a LHsBin is a pattern binding but not a simple one. +isComplexPatBind::GHC.LHsBind name -> Bool +isComplexPatBind decl + = case decl of + (GHC.L _l (GHC.PatBind (GHC.L _ (GHC.VarPat _)) _rhs _ty _fvs _)) -> True + _ -> False + +-- | Return True if a declaration is a function\/pattern definition. +isFunOrPatBindP :: HsDeclP -> Bool +isFunOrPatBindP decl = isFunBindP decl || isPatBindP decl + +-- | Return True if a declaration is a function\/pattern definition. +isFunOrPatBindR :: GHC.LHsBind t -> Bool +isFunOrPatBindR decl = isFunBindR decl || isPatBindR decl + +-- --------------------------------------------------------------------- + + +-- | Returns True is a syntax phrase, say a, is part of another syntax +-- phrase, say b. +-- Expects to be at least Parser output +findEntity':: (SYB.Data a, SYB.Data b) + => a -> b -> Maybe (SimpPos,SimpPos) +findEntity' a b = res + where + -- ++AZ++ do a generic traversal, and see if it matches. + res = SYB.somethingStaged SYB.Parser Nothing worker b + + worker :: (SYB.Data c) + => c -> Maybe (SimpPos,SimpPos) + worker x = if SYB.typeOf a == SYB.typeOf x + -- then Just (getStartEndLoc b == getStartEndLoc a) + then Just (getStartEndLoc x) + else Nothing + +-------------------------------------------------------------------------------- + +sameBindRdr :: NameMap -> GHC.LHsDecl GHC.RdrName -> GHC.LHsDecl GHC.RdrName -> Bool +sameBindRdr nm b1 b2 = (definedNamesRdr nm b1) == (definedNamesRdr nm b2) + +-- --------------------------------------------------------------------- + +-- TODO: is this the same is isUsedInRhs? +class (SYB.Data t) => UsedByRhs t where + + -- | Return True if any of the GHC.Name's appear in the given + -- syntax element + usedByRhsRdr :: NameMap -> t -> [GHC.Name] -> Bool + +instance UsedByRhs (GHC.HsModule GHC.RdrName) where + + -- Not a meaningful question at this level + usedByRhsRdr _ _parsed _pns = False + +-- ------------------------------------- + +instance (UsedByRhs a) => UsedByRhs (GHC.Located a) where + usedByRhsRdr nm (GHC.L _ d) pns = usedByRhsRdr nm d pns + +-- ------------------------------------- + +instance (UsedByRhs a) => UsedByRhs (Maybe a) where + usedByRhsRdr _ Nothing _ = False + usedByRhsRdr nm (Just a) pns = usedByRhsRdr nm a pns + +-- ------------------------------------- + +instance UsedByRhs [GHC.LIE GHC.RdrName] where + usedByRhsRdr nm ds pns = or $ map (\d -> usedByRhsRdr nm d pns) ds + +-- ------------------------------------- + +instance UsedByRhs (GHC.IE GHC.RdrName) where + usedByRhsRdr _ _ _ = False + +-- ------------------------------------- + +instance UsedByRhs [GHC.LHsDecl GHC.RdrName] where + usedByRhsRdr nm ds pns = or $ map (\d -> usedByRhsRdr nm d pns) ds + +-- ------------------------------------- + +instance UsedByRhs (GHC.HsDecl GHC.RdrName) where + usedByRhsRdr nm de pns = + case de of + GHC.TyClD d -> f d + GHC.InstD d -> f d + GHC.DerivD d -> f d + GHC.ValD d -> f d + GHC.SigD d -> f d + GHC.DefD d -> f d + GHC.ForD d -> f d + GHC.WarningD d -> f d + GHC.AnnD d -> f d + GHC.RuleD d -> f d + GHC.VectD d -> f d + GHC.SpliceD d -> f d + GHC.DocD d -> f d + GHC.RoleAnnotD d -> f d +#if __GLASGOW_HASKELL__ < 711 + GHC.QuasiQuoteD d -> f d +#endif + where + f d' = usedByRhsRdr nm d' pns + +-- ------------------------------------- + +instance UsedByRhs (GHC.TyClDecl GHC.RdrName) where + usedByRhsRdr = assert False undefined + +instance UsedByRhs (GHC.InstDecl GHC.RdrName) where + usedByRhsRdr = assert False undefined + +instance UsedByRhs (GHC.DerivDecl GHC.RdrName) where + usedByRhsRdr = assert False undefined + +instance UsedByRhs (GHC.ForeignDecl GHC.RdrName) where + usedByRhsRdr = assert False undefined + +instance UsedByRhs (GHC.WarnDecls GHC.RdrName) where + usedByRhsRdr = assert False undefined + +instance UsedByRhs (GHC.AnnDecl GHC.RdrName) where + usedByRhsRdr = assert False undefined + +instance UsedByRhs (GHC.RoleAnnotDecl GHC.RdrName) where + usedByRhsRdr = assert False undefined + +#if __GLASGOW_HASKELL__ <= 710 +instance UsedByRhs (GHC.HsQuasiQuote GHC.RdrName) where + usedByRhsRdr = assert False undefined +#endif + +instance UsedByRhs (GHC.DefaultDecl GHC.RdrName) where + usedByRhsRdr = assert False undefined + +instance UsedByRhs (GHC.SpliceDecl GHC.RdrName) where + usedByRhsRdr = assert False undefined + +instance UsedByRhs (GHC.VectDecl GHC.RdrName) where + usedByRhsRdr = assert False undefined + +instance UsedByRhs (GHC.RuleDecls GHC.RdrName) where + usedByRhsRdr = assert False undefined + +instance UsedByRhs GHC.DocDecl where + usedByRhsRdr = assert False undefined + +instance UsedByRhs (GHC.Sig GHC.RdrName) where + usedByRhsRdr _ _ _ = False + +-- ------------------------------------- + +instance UsedByRhs (GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where + usedByRhsRdr nm (GHC.Match _ _ _ (GHC.GRHSs rhs _)) pns + = findNamesRdr nm pns rhs + +-- ------------------------------------- + +instance UsedByRhs (GHC.HsBind GHC.RdrName) where +#if __GLASGOW_HASKELL__ <= 710 + usedByRhsRdr nm (GHC.FunBind _ _ matches _ _ _) pns = findNamesRdr nm pns matches +#else + usedByRhsRdr nm (GHC.FunBind _ matches _ _ _) pns = findNamesRdr nm pns matches +#endif + usedByRhsRdr nm (GHC.PatBind _ rhs _ _ _) pns = findNamesRdr nm pns rhs + usedByRhsRdr nm (GHC.PatSynBind (GHC.PSB _ _ _ rhs _)) pns = findNamesRdr nm pns rhs + usedByRhsRdr nm (GHC.VarBind _ rhs _) pns = findNamesRdr nm pns rhs + usedByRhsRdr _nm (GHC.AbsBinds _ _ _ _ _) _pns = False +#if __GLASGOW_HASKELL__ > 710 + usedByRhsRdr _nm (GHC.AbsBindsSig _ _ _ _ _ _) _pns = False +#endif + +-- ------------------------------------- + +instance UsedByRhs (GHC.HsExpr GHC.RdrName) where + usedByRhsRdr nm (GHC.HsLet _lb e) pns = findNamesRdr nm pns e + usedByRhsRdr _ e _pns = error $ "undefined usedByRhsRdr:" ++ (showGhc e) + +-- ------------------------------------- + +instance UsedByRhs (GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where + usedByRhsRdr nm (GHC.LetStmt lb) pns = findNamesRdr nm pns lb + usedByRhsRdr _ s _pns = error $ "undefined usedByRhsRdr:" ++ (showGhc s) + +-------------------------------------------------------------------------------- + +-- |Find the identifier with the given name. This looks through the +-- given syntax phrase for the first GHC.Name which matches. Because +-- it is Renamed source, the GHC.Name will include its defining +-- location. Returns Nothing if the name is not found. + +getName::(SYB.Data t)=> String -- ^ The name to find + -> t -- ^ The syntax phrase + -> Maybe GHC.Name -- ^ The result +getName str t + = res + -- ++AZ++:TODO use nameSybQuery? + where + res = SYB.somethingStaged SYB.Renamer Nothing + (Nothing `SYB.mkQ` worker +#if __GLASGOW_HASKELL__ <= 710 + `SYB.extQ` workerBind + `SYB.extQ` workerExpr +#endif + ) t + + worker ((GHC.L _ n) :: (GHC.Located GHC.Name)) + | showGhcQual n == str = Just n + worker _ = Nothing + +#if __GLASGOW_HASKELL__ <= 710 + workerBind (GHC.L _ (GHC.VarPat name) :: (GHC.Located (GHC.Pat GHC.Name))) + | showGhcQual name == str = Just name + workerBind _ = Nothing + + + workerExpr ((GHC.L _ (GHC.HsVar name)) :: (GHC.Located (GHC.HsExpr GHC.Name))) + | showGhcQual name == str = Just name + workerExpr _ = Nothing +#endif + +-- --------------------------------------------------------------------- + +-- | Add identifiers to the export list of a module. If the second argument is +-- like: Just p, then do the adding only if p occurs in the export list, and the +-- new identifiers are added right after p in the export list. Otherwise the new +-- identifiers are add to the beginning of the export list. In the case that the +-- export list is emport, then if the third argument is True, then create an +-- explict export list to contain only the new identifiers, otherwise do +-- nothing. + +addImportDecl :: + GHC.ParsedSource + -> GHC.ModuleName +#if __GLASGOW_HASKELL__ <= 710 + -> Maybe GHC.FastString -- ^qualifier +#else + -> Maybe GHC.StringLiteral -- ^qualifier +#endif + -> Bool -> Bool -> Bool + -> Maybe String -- ^alias + -> Bool + -> [GHC.RdrName] + -> RefactGhc GHC.ParsedSource +-- addImportDecl (groupedDecls,imp, b, c) modName pkgQual source safe qualify alias hide idNames +addImportDecl (GHC.L l p) modName pkgQual source safe qualify alias hide idNames + = do + let imp = GHC.hsmodImports p + impDecl <- mkImpDecl + newSpan <- liftT uniqueSrcSpanT + let newImp = GHC.L newSpan impDecl + liftT $ addSimpleAnnT newImp (DP (1,0)) [((G GHC.AnnImport),DP (0,0))] + return (GHC.L l p { GHC.hsmodImports = (imp++[newImp])}) + where + + alias' = case alias of + Just stringName -> Just $ GHC.mkModuleName stringName + _ -> Nothing + + mkImpDecl = do + newSpan1 <- liftT uniqueSrcSpanT + newSpan2 <- liftT uniqueSrcSpanT + newEnts <- mkNewEntList idNames + let lNewEnts = GHC.L newSpan2 newEnts + -- logm $ "addImportDecl.mkImpDecl:adding anns for:" ++ showGhc lNewEnts + liftT $ addSimpleAnnT lNewEnts (DP (0,1)) [((G GHC.AnnHiding),DP (0,0)),((G GHC.AnnOpenP),DP (0,1)),((G GHC.AnnCloseP),DP (0,0))] + let lmodname = GHC.L newSpan1 modName + liftT $ addSimpleAnnT lmodname (DP (0,1)) [((G GHC.AnnVal),DP (0,0))] + return $ GHC.ImportDecl + { GHC.ideclSourceSrc = Nothing + , GHC.ideclName = lmodname + , GHC.ideclPkgQual = pkgQual + , GHC.ideclSource = source + , GHC.ideclSafe = safe + , GHC.ideclQualified = qualify + , GHC.ideclImplicit = False + , GHC.ideclAs = alias' + , GHC.ideclHiding = + (if idNames == [] && hide == False then + Nothing + else + (Just (hide, lNewEnts))) + } + +-- --------------------------------------------------------------------- + +-- | Adding a declaration to the declaration list of the given syntax +-- phrase. If the second argument is Nothing, then the declaration +-- will be added to the beginning of the declaration list, but after +-- the data type declarations is there is any. +addDecl:: (SYB.Data t,SYB.Typeable t) + => t -- ^The AST to be updated + -> Maybe GHC.Name -- ^If this is Just, then the declaration + -- will be added right after this + -- identifier's definition. + -> ([GHC.LHsDecl GHC.RdrName], Maybe Anns) + -- ^ The declaration with optional signatures to be added, together + -- with optional Annotations. + -> RefactGhc t + +addDecl parent pn (declSig, mDeclAnns) = do + logm $ "addDecl:declSig=" ++ showGhc declSig + case mDeclAnns of + Nothing -> return () + Just declAnns -> -- addRefactAnns declAnns + liftT $ modifyAnnsT (mergeAnns declAnns) + case pn of + Just pn' -> appendDecl parent pn' declSig + Nothing -> addLocalDecl parent declSig + where + setDeclSpacing newDeclSig n c = do + -- First clear any previous indentation + mapM_ (\d -> setPrecedingLinesDeclT d 1 0) newDeclSig + setPrecedingLinesT (ghead "addDecl" newDeclSig) n c + -- mapM_ (\d -> setPrecedingLinesT d 1 0) (gtail "addDecl" newDeclSig) + + appendDecl :: (SYB.Data t) + => t -- ^Original AST + -> GHC.Name -- ^Name to add the declaration after + -> [GHC.LHsDecl GHC.RdrName] -- ^declaration and maybe sig + -> RefactGhc t -- ^updated AST + appendDecl parent1 pn' newDeclSig = do + hasDeclsSybTransform workerHsDecls workerBind parent1 + where + workerHsDecls :: forall t. HasDecls t => t -> RefactGhc t + workerHsDecls parent' = do + -- logm $ "addDecl.appendDecl:(pn')=" ++ showGhc pn' + liftT $ setDeclSpacing newDeclSig 2 0 + nameMap <- getRefactNameMap + decls <- liftT $ hsDecls parent' + let + (before,after) = break (definesDeclRdr nameMap pn') decls + + -- logm $ "addDecl.appendDecl:(before,after)=" ++ showGhc (before,after) + let (decls1,decls2) = case after of + [] -> (before,[]) + _ -> (before ++ [ghead "appendDecl14" after], + gtail "appendDecl15" after) + unless (null decls1 || null decls2) $ do liftT $ balanceComments (last decls1) (head decls2) + liftT $ replaceDecls parent' (decls1++newDeclSig++decls2) + + workerBind :: (GHC.LHsBind GHC.RdrName -> RefactGhc (GHC.LHsBind GHC.RdrName)) + workerBind = assert False undefined + + addLocalDecl :: (SYB.Typeable t,SYB.Data t) + => t -> [GHC.LHsDecl GHC.RdrName] + -> RefactGhc t + addLocalDecl parent' newDeclSig = do + logm $ "addLocalDecl entered" + -- logDataWithAnns "addLocalDecl.parent'" parent' + hasDeclsSybTransform workerHasDecls workerBind parent' + where + workerDecls :: [GHC.LHsDecl GHC.RdrName] -> RefactGhc [GHC.LHsDecl GHC.RdrName] + workerDecls decls = do + logm $ "workerDecls entered" + case decls of + [] -> liftT $ setDeclSpacing newDeclSig 2 0 + ds -> do + DP (r,c) <- liftT (getEntryDPT (head ds)) + liftT $ setDeclSpacing newDeclSig r c + liftT $ setPrecedingLinesT (head ds) 2 0 + return (newDeclSig++decls) + + workerHasDecls :: (HasDecls t) => t -> RefactGhc t + workerHasDecls p = do + logm $ "workerHasDecls entered" + decls <- liftT (hsDecls p) + decls' <- workerDecls decls + r <- liftT $ replaceDecls p decls' + return r + + workerBind :: GHC.LHsBind GHC.RdrName -> RefactGhc (GHC.LHsBind GHC.RdrName) + workerBind b = do + logm $ "workerBind entered" + case b of +#if __GLASGOW_HASKELL__ <= 710 + GHC.L l (GHC.FunBind n i (GHC.MG [match] a ptt o) co fvs t) -> do +#else + GHC.L l (GHC.FunBind n (GHC.MG (GHC.L lm [match]) a ptt o) co fvs t) -> do +#endif + match' <- workerHasDecls match +#if __GLASGOW_HASKELL__ <= 710 + return (GHC.L l (GHC.FunBind n i (GHC.MG [match'] a ptt o) co fvs t)) +#else + return (GHC.L l (GHC.FunBind n (GHC.MG (GHC.L lm [match']) a ptt o) co fvs t)) +#endif +#if __GLASGOW_HASKELL__ <= 710 + GHC.L _ (GHC.FunBind _ _ (GHC.MG _matches _ _ _) _ _ _) -> do +#else + GHC.L _ (GHC.FunBind _ (GHC.MG _matches _ _ _) _ _ _) -> do +#endif + error "addDecl:Cannot add a local decl to a FunBind with multiple matches" + p@(GHC.L _ (GHC.PatBind _pat _rhs _ty _fvs _t)) -> do + logm $ "workerBind.PatBind entered" + decls <- liftT (hsDeclsPatBind p) + decls' <- workerDecls decls + r <- liftT $ replaceDeclsPatBind p decls' + return r + + x -> error $ "addLocalDecl.workerBind:not processing:" ++ SYB.showData SYB.Parser 0 x + +-- --------------------------------------------------------------------- +-- +-- --------------------------------------------------------------------- + +rdrNameFromName :: Bool -> GHC.Name -> RefactGhc GHC.RdrName +rdrNameFromName useQual newName = do + mname <- case (GHC.nameModule_maybe newName) of + Just (GHC.Module _ mn) -> return mn + Nothing -> do + GHC.Module _ mn <- getRefactModule + return mn + + if useQual + then return $ GHC.mkRdrQual mname (GHC.nameOccName newName) + else return $ GHC.mkRdrUnqual (GHC.nameOccName newName) + +-- --------------------------------------------------------------------- + +-- | add items to the hiding list of an import declaration which +-- imports the specified module. +addHiding:: + GHC.ModuleName -- ^ The imported module name + -> GHC.ParsedSource -- ^ The current module + -> [GHC.RdrName] -- ^ The items to be added + -> RefactGhc GHC.ParsedSource -- ^ The result +addHiding mn p ns = do + logm $ "addHiding called for (module,names):" ++ showGhc (mn,ns) + p' <- addItemsToImport' mn p (Left ns) Hide + putRefactParsed p' emptyAnns + return p' + +-- -------------------------------------------------------------------- + +-- | Creates a new entity list for hiding a name in an ImportDecl. +mkNewEntList :: [GHC.RdrName] -> RefactGhc [GHC.LIE GHC.RdrName] +mkNewEntList idNames = do + case idNames of + [] -> return [] + _ -> do + newEntsInit <- mapM (mkNewEnt True) (init idNames) + newEntsLast <- mkNewEnt False (last idNames) + return (newEntsInit ++ [newEntsLast]) + +-- | Creates a new entity for hiding a name in an ImportDecl. +mkNewEnt :: Bool -> GHC.RdrName -> RefactGhc (GHC.LIE GHC.RdrName) +mkNewEnt addCommaAnn pn = do + newSpan <- liftT uniqueSrcSpanT + let lpn = GHC.L newSpan pn + if addCommaAnn + then liftT $ addSimpleAnnT lpn (DP (0,0)) [((G GHC.AnnVal),DP (0,0)),((G GHC.AnnComma),DP (0,0))] + else liftT $ addSimpleAnnT lpn (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] + return (GHC.L newSpan (GHC.IEVar lpn)) + +-- | Represents the operation type we want to select on addItemsToImport' +data ImportType = Hide -- ^ Used for addHiding + | Import -- ^ Used for addItemsToImport + +-- | Add identifiers (given by the third argument) to the explicit entity list +-- in the declaration importing the specified module name. This function does +-- nothing if the import declaration does not have an explicit entity list. +addItemsToImport :: + GHC.ModuleName -- ^ The imported module name + -> Maybe GHC.Name -- ^ The condition identifier. + -> Either [GHC.RdrName] [GHC.LIE GHC.RdrName] -- ^ The items to be added + -> GHC.ParsedSource -- ^ The current module + -> RefactGhc GHC.ParsedSource -- ^ The result +addItemsToImport mn mc ns r = addItemsToImport' mn r ns Import + +-- | Add identifiers (given by the third argument) to the explicit entity list +-- in the declaration importing the specified module name. If the ImportType +-- argument is Hide, then the items will be added to the "hiding" list. If it +-- is Import, they will be added to the explicit import entries. This function +-- does nothing if the import declaration does not have an explicit entity +-- list and ImportType is Import. +addItemsToImport':: + GHC.ModuleName -- ^ The imported module name + -> GHC.ParsedSource -- ^ The current module + -- -> [GHC.RdrName] -- ^ The items to be added + -> Either [GHC.RdrName] [GHC.LIE GHC.RdrName] -- ^ The items to be added +-- ->Maybe GHC.Name -- ^ The condition identifier. + -> ImportType -- ^ Whether to hide the names or import them. Uses special data for clarity. + -> RefactGhc GHC.ParsedSource -- ^ The result +addItemsToImport' serverModName (GHC.L l p) pns impType = do + let imps = GHC.hsmodImports p + imps' <- mapM inImport imps + return $ GHC.L l p {GHC.hsmodImports = imps'} + where + isHide = case impType of + Hide -> True + Import -> False + + inImport :: GHC.LImportDecl GHC.RdrName -> RefactGhc (GHC.LImportDecl GHC.RdrName) + inImport imp@(GHC.L _ (GHC.ImportDecl _st (GHC.L _ modName) _qualify _source _safe isQualified _isImplicit _as h)) + | serverModName == modName && not isQualified -- && (if isJust pn then findPN (gfromJust "addItemsToImport" pn) h else True) + = case h of + Nothing -> insertEnts imp [] True + Just (_isHide, (GHC.L _le ents)) -> insertEnts imp ents False + inImport x = return x + + insertEnts :: + GHC.LImportDecl GHC.RdrName + -> [GHC.LIE GHC.RdrName] + -> Bool -- True means there are already existing entities + -> RefactGhc ( GHC.LImportDecl GHC.RdrName ) + insertEnts imp ents isNew = do + logm $ "addItemsToImport':insertEnts:(imp,ents,isNew):" ++ showGhc (imp,ents,isNew) + if isNew && not isHide then return imp + else do + logm $ "addItemsToImport':insertEnts:doing stuff" + newSpan <- liftT uniqueSrcSpanT + -- newEnts <- mkNewEntList pns + newEnts <- case pns of + Left pns' -> mkNewEntList pns' + Right pns' -> return pns' + let lNewEnts = GHC.L newSpan (ents++newEnts) + logm $ "addImportDecl.mkImpDecl:adding anns for:" ++ showGhc lNewEnts + if isHide + then + liftT $ addSimpleAnnT lNewEnts (DP (0,1)) [((G GHC.AnnHiding),DP (0,0)),((G GHC.AnnOpenP),DP (0,1)),((G GHC.AnnCloseP),DP (0,0))] + else + liftT $ addSimpleAnnT lNewEnts (DP (0,1)) [((G GHC.AnnOpenP),DP (0,0)),((G GHC.AnnCloseP),DP (0,0))] + when (not (null ents)) $ do liftT (addTrailingCommaT (last ents)) + return (replaceHiding imp (Just (isHide, lNewEnts))) + + + replaceHiding (GHC.L l1 (GHC.ImportDecl st mn q src safe isQ isImp as _h)) h1 = + (GHC.L l1 (GHC.ImportDecl st mn q src safe isQ isImp as h1)) + +-- --------------------------------------------------------------------- + +addParamsToSigs :: [GHC.Name] -> GHC.LSig GHC.RdrName -> RefactGhc (GHC.LSig GHC.RdrName) +addParamsToSigs [] ms = return ms +#if __GLASGOW_HASKELL__ <= 710 +addParamsToSigs newParams (GHC.L l (GHC.TypeSig lns ltyp pns)) = do +#else +addParamsToSigs newParams (GHC.L l (GHC.TypeSig lns (GHC.HsIB ivs (GHC.HsWC wcs mwc ltyp)))) = do +#endif + logm $ "addParamsToSigs:newParams=" ++ showGhc newParams + mts <- mapM getTypeForName newParams + let ts = catMaybes mts + logm $ "addParamsToSigs:ts=" ++ showGhc ts + logDataWithAnns "addParamsToSigs:ts=" ts + let newStr = ":: " ++ (intercalate " -> " $ map printSigComponent ts) ++ " -> " + logm $ "addParamsToSigs:newStr=[" ++ newStr ++ "]" + typ' <- liftT $ foldlM addOneType ltyp (reverse ts) + sigOk <- isNewSignatureOk ts + logm $ "addParamsToSigs:(sigOk,newStr)=" ++ show (sigOk,newStr) + if sigOk +#if __GLASGOW_HASKELL__ <= 710 + then return (GHC.L l (GHC.TypeSig lns typ' pns)) +#else + then return (GHC.L l (GHC.TypeSig lns (GHC.HsIB ivs (GHC.HsWC wcs mwc typ')))) +#endif + else error $ "\nNew type signature may fail type checking: " ++ newStr ++ "\n" + where + addOneType :: GHC.LHsType GHC.RdrName -> GHC.Type -> Transform (GHC.LHsType GHC.RdrName) + addOneType et t = do + hst <- typeToLHsType t + ss1 <- uniqueSrcSpanT +#if __GLASGOW_HASKELL__ <= 710 + hst1 <- case t of + (GHC.FunTy _ _) -> do + ss <- uniqueSrcSpanT + let t1 = GHC.L ss (GHC.HsParTy hst) + setEntryDPT hst (DP (0,0)) + addSimpleAnnT t1 (DP (0,0)) [((G GHC.AnnOpenP),DP (0,1)),((G GHC.AnnCloseP),DP (0,0))] + return t1 + _ -> return hst + let typ = GHC.L ss1 (GHC.HsFunTy hst1 et) + + addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnRarrow),DP (0,1))] +#else + hst1 <- case t of + -- GHC 8: (ForAllTy (Anon arg) res used to be called FunTy arg res.) + (GHC.ForAllTy (GHC.Anon _) _) -> do + ss <- uniqueSrcSpanT + let t1 = GHC.L ss (GHC.HsParTy hst) + setEntryDPT hst (DP (0,0)) + addSimpleAnnT t1 (DP (0,0)) [((G GHC.AnnOpenP),DP (0,1)),((G GHC.AnnCloseP),DP (0,0))] + return t1 + _ -> return hst + let typ = GHC.L ss1 (GHC.HsFunTy hst1 et) + + -- let typ = error $ "addParamsToSigs:need to update for GHC 8:hst=" ++ SYB.showData SYB.Parser 0 hst + -- let typ = GHC.L ss1 (GHC.HsFunTy hst et) + + addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnRarrow),DP (0,1))] +#endif + return typ + + printSigComponent :: GHC.Type -> String + printSigComponent x = ppType x + +addParamsToSigs np ls = error $ "addParamsToSigs: no match for:" ++ showGhc (np,ls) + +-- --------------------------------------------------------------------- + +-- |Fail any signature having a forall in it. +-- TODO: this is unnecesarily restrictive, but needs +-- a) proper reversing of GHC.Type to GHC.LhsType +-- b) some serious reverse type inference to ensure that the +-- constraints are modified properly to merge the old signature +-- part and the new. +isNewSignatureOk :: [GHC.Type] -> RefactGhc Bool +isNewSignatureOk types = do + logm $ "isNewSignatureOk:types=" ++ SYB.showData SYB.Parser 0 types + -- NOTE: under some circumstances enabling Rank2Types or RankNTypes + -- can resolve the type conflict, this can potentially be checked + -- for. + -- NOTE2: perhaps proceed and reload the tentative refactoring into + -- the GHC session and accept it only if it type checks + + -- GHC 8: (ForAllTy (Anon arg) res used to be called FunTy arg res.) + + let + r = SYB.everythingStaged SYB.TypeChecker (++) [] + ([] `SYB.mkQ` usesForAll) types +#if __GLASGOW_HASKELL__ <= 710 + usesForAll (GHC.ForAllTy _ _) = [1::Int] +#else + usesForAll (GHC.ForAllTy (GHC.Named _ _) _) = [1::Int] +#endif + usesForAll _ = [] + + return $ emptyList r + +-- --------------------------------------------------------------------- + +-- TODO: complete this +typeToLHsType :: GHC.Type -> Transform (GHC.LHsType GHC.RdrName) +typeToLHsType (GHC.TyVarTy v) = do + ss <- uniqueSrcSpanT +#if __GLASGOW_HASKELL__ <= 710 + let typ = GHC.L ss (GHC.HsTyVar (GHC.nameRdrName $ Var.varName v)) +#else + let typ = GHC.L ss (GHC.HsTyVar (GHC.L ss (GHC.nameRdrName $ Var.varName v))) +#endif + addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] + return typ + +typeToLHsType (GHC.AppTy t1 t2) = do + t1' <- typeToLHsType t1 + t2' <- typeToLHsType t2 + ss <- uniqueSrcSpanT + return $ GHC.L ss (GHC.HsAppTy t1' t2') + +typeToLHsType t@(GHC.TyConApp _tc _ts) = tyConAppToHsType t + +#if __GLASGOW_HASKELL__ <= 710 +typeToLHsType (GHC.FunTy t1 t2) = do + t1' <- typeToLHsType t1 + t2' <- typeToLHsType t2 + ss <- uniqueSrcSpanT + let typ = GHC.L ss (GHC.HsFunTy t1' t2') + addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnRarrow),DP (0,1))] + return typ +#else +-- GHC 8: (ForAllTy (Anon arg) res used to be called FunTy arg res.) +typeToLHsType (GHC.ForAllTy (GHC.Anon t1) t2) = do + t1' <- typeToLHsType t1 + t2' <- typeToLHsType t2 + ss <- uniqueSrcSpanT + let typ = GHC.L ss (GHC.HsFunTy t1' t2') + addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnRarrow),DP (0,1))] + return typ +#endif + +typeToLHsType (GHC.ForAllTy _v t) = do + t' <- typeToLHsType t + ss1 <- uniqueSrcSpanT +#if __GLASGOW_HASKELL__ <= 710 + ss2 <- uniqueSrcSpanT + return $ GHC.L ss1 (GHC.HsForAllTy GHC.Explicit Nothing (GHC.HsQTvs [] []) (GHC.L ss2 []) t') +#else + return $ GHC.L ss1 (GHC.HsForAllTy [] t') +#endif + +typeToLHsType (GHC.LitTy (GHC.NumTyLit i)) = do + ss <- uniqueSrcSpanT + let typ = GHC.L ss (GHC.HsTyLit (GHC.HsNumTy (show i) i)) :: GHC.LHsType GHC.RdrName + addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] + return typ + +typeToLHsType (GHC.LitTy (GHC.StrTyLit s)) = do + ss <- uniqueSrcSpanT + let typ = GHC.L ss (GHC.HsTyLit (GHC.HsStrTy "" s)) :: GHC.LHsType GHC.RdrName + addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] + return typ + + +{- +data Type + = TyVarTy Var -- ^ Vanilla type or kind variable (*never* a coercion variable) + + | AppTy -- See Note [AppTy invariant] + Type + Type -- ^ Type application to something other than a 'TyCon'. Parameters: + -- + -- 1) Function: must /not/ be a 'TyConApp', + -- must be another 'AppTy', or 'TyVarTy' + -- + -- 2) Argument type + + | TyConApp -- See Note [AppTy invariant] + TyCon + [KindOrType] -- ^ Application of a 'TyCon', including newtypes /and/ synonyms. + -- Invariant: saturated appliations of 'FunTyCon' must + -- use 'FunTy' and saturated synonyms must use their own + -- constructors. However, /unsaturated/ 'FunTyCon's + -- do appear as 'TyConApp's. + -- Parameters: + -- + -- 1) Type constructor being applied to. + -- + -- 2) Type arguments. Might not have enough type arguments + -- here to saturate the constructor. + -- Even type synonyms are not necessarily saturated; + -- for example unsaturated type synonyms + -- can appear as the right hand side of a type synonym. + + | FunTy + Type + Type -- ^ Special case of 'TyConApp': @TyConApp FunTyCon [t1, t2]@ + -- See Note [Equality-constrained types] + + | ForAllTy + Var -- Type or kind variable + Type -- ^ A polymorphic type + + | LitTy TyLit -- ^ Type literals are simillar to type constructors. + +-} + +tyConAppToHsType :: GHC.Type -> Transform (GHC.LHsType GHC.RdrName) +tyConAppToHsType (GHC.TyConApp tc _ts) = r (show $ GHC.tyConName tc) + where + r str = do + ss <- uniqueSrcSpanT + let typ = GHC.L ss (GHC.HsTyLit (GHC.HsStrTy str $ GHC.mkFastString str)) :: GHC.LHsType GHC.RdrName + addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnVal),DP (0,1))] + return typ + +-- tyConAppToHsType t@(GHC.TyConApp _tc _ts) +-- = error $ "tyConAppToHsType: unexpected:" ++ (SYB.showData SYB.TypeChecker 0 t) + +{- +HsType +HsForAllTy HsExplicitFlag (LHsTyVarBndrs name) (LHsContext name) (LHsType name) +HsTyVar name +HsAppTy (LHsType name) (LHsType name) +HsFunTy (LHsType name) (LHsType name) +HsListTy (LHsType name) +HsPArrTy (LHsType name) +HsTupleTy HsTupleSort [LHsType name] +HsOpTy (LHsType name) (LHsTyOp name) (LHsType name) +HsParTy (LHsType name) +HsIParamTy HsIPName (LHsType name) +HsEqTy (LHsType name) (LHsType name) +HsKindSig (LHsType name) (LHsKind name) +HsQuasiQuoteTy (HsQuasiQuote name) +HsSpliceTy (HsSplice name) FreeVars PostTcKind +HsDocTy (LHsType name) LHsDocString +HsBangTy HsBang (LHsType name) +HsRecTy [ConDeclField name] +HsCoreTy Type +HsExplicitListTy PostTcKind [LHsType name] +HsExplicitTupleTy [PostTcKind] [LHsType name] +HsTyLit HsTyLit +HsWrapTy HsTyWrapper (HsType name) +-} + +-- --------------------------------------------------------------------- + +addParamsToDecls:: + [GHC.LHsDecl GHC.RdrName] -- ^ A declaration list where the function is defined and\/or used. + -> GHC.Name -- ^ The function name. + -> [GHC.RdrName] -- ^ The parameters to be added. + -> RefactGhc [GHC.LHsDecl GHC.RdrName] -- ^ The result. + +addParamsToDecls decls pn paramPNames = do + logm $ "addParamsToDecls (pn,paramPNames)=" ++ (showGhc (pn,paramPNames)) + nameMap <- getRefactNameMap + if (paramPNames /= []) + then mapM (addParamToDecl nameMap) decls + else return decls + where + addParamToDecl :: NameMap -> GHC.LHsDecl GHC.RdrName -> RefactGhc (GHC.LHsDecl GHC.RdrName) +#if __GLASGOW_HASKELL__ <= 710 + addParamToDecl nameMap (GHC.L l1 (GHC.ValD (GHC.FunBind lp@(GHC.L l2 pname) i (GHC.MG matches a ptt o) co fvs t))) +#else + addParamToDecl nameMap (GHC.L l1 (GHC.ValD (GHC.FunBind lp@(GHC.L l2 pname) (GHC.MG (GHC.L lm matches) a ptt o) co fvs t))) +#endif + | eqRdrNamePure nameMap lp pn + = do + matches' <- mapM addParamtoMatch matches +#if __GLASGOW_HASKELL__ <= 710 + return (GHC.L l1 (GHC.ValD (GHC.FunBind (GHC.L l2 pname) i (GHC.MG matches' a ptt o) co fvs t))) +#else + return (GHC.L l1 (GHC.ValD (GHC.FunBind (GHC.L l2 pname) (GHC.MG (GHC.L lm matches') a ptt o) co fvs t))) +#endif + where + addParamtoMatch (GHC.L l (GHC.Match fn1 pats mtyp rhs)) + = do + rhs' <- addActualParamsToRhs pn paramPNames rhs + pats' <- liftT $ mapM addParam paramPNames + -- logDataWithAnns "addParamToDecl.addParam:pats'" pats' + return (GHC.L l (GHC.Match fn1 (pats'++pats) mtyp rhs')) + + -- TODO: The following will never match, as a PatBind only deals with complex patterns. + addParamToDecl _nameMap x@(GHC.L _l1 (GHC.ValD (GHC.PatBind _pat@(GHC.L _l2 (GHC.VarPat _p)) _rhs _ty _fvs _t))) + = return x + addParamToDecl _ x = return x + + addParam n = do + newSpan <- uniqueSrcSpanT +#if __GLASGOW_HASKELL__ <= 710 + let vn = (GHC.L newSpan (GHC.VarPat n)) +#else + let vn = (GHC.L newSpan (GHC.VarPat (GHC.L newSpan n))) +#endif + addSimpleAnnT vn (DP (0,1)) [((G GHC.AnnVal),DP (0,0))] + return vn + +-- --------------------------------------------------------------------- + +-- ++AZ++: This looks like it is trying to do too many things +-- | Add identifiers to the export list of a module. If the second argument +-- is like: Just p, then do the adding only if p occurs in the export list, and +-- the new identifiers are added right after p in the export list. Otherwise the +-- new identifiers are add to the beginning of the export list. In the case that +-- the export list is empty, then if the third argument is True, then create an +-- explict export list to contain only the new identifiers, otherwise do +-- nothing. +-- TODO:AZ: re-arrange params to line up with addItemsToExport +addItemsToExport :: + GHC.ParsedSource -- ^The module AST. + -> Maybe GHC.Name -- ^The condtion identifier. + -> Bool -- ^Create an explicit list or not + -> Either [GHC.RdrName] [GHC.LIE GHC.RdrName] + -- ^The identifiers to add in either String or HsExportEntP format. + -> RefactGhc GHC.ParsedSource -- ^The result. +addItemsToExport modu _ _ (Left []) = return modu +addItemsToExport modu _ _ (Right []) = return modu +-- addItemsToExport modu@(HsModule loc modName exps imps ds) (Just pn) _ ids +addItemsToExport modu@(GHC.L l (GHC.HsModule modName exps imps ds deps hs)) (Just pn) _ ids + = case exps of + Just (GHC.L le ents) -> do + logm $ "addItemsToExport:pn=" ++ showGhc pn + nm <- getRefactNameMap + let (e1,e2) = break (findLRdrName nm pn) ents + if e2 /= [] + then do + es <- case ids of + Left is' -> mkNewEntList is' + Right es' -> return es' + let e = (ghead "addVarItemInExport" e2) + lNewEnts = GHC.L le (e1++(e:es)++tail e2) + liftT (addTrailingCommaT e) + return (GHC.L l (GHC.HsModule modName (Just lNewEnts) imps ds deps hs)) + -- then do ((toks,_),others)<-get + -- let e = (ghead "addVarItemInExport" e2) + -- es = case ids of + -- (Left is' ) ->map (\x-> (EntE (Var (nameToPNT x)))) is' + -- (Right es') -> es' + -- let (_,endPos) = getStartEndLoc toks e + -- (t, (_,s)) = ghead "addVarItemInExport" $ getToks (endPos,endPos) toks + -- newToken = mkToken t endPos (s++","++ showEntities (render.ppi) es) + -- toks' = replaceToks toks endPos endPos [newToken] + -- put ((toks',modified),others) + -- return (HsModule loc modName (Just (e1++(e:es)++tail e2)) imps ds) + else return modu + Nothing -> return modu + +addItemsToExport (GHC.L l (GHC.HsModule _ (Just ents) _ _ _ _)) Nothing createExp ids + = assert False undefined + -- = do ((toks,_),others)<-get + -- let es = case ids of + -- (Left is' ) ->map (\x-> (EntE (Var (nameToPNT x)))) is' + -- (Right es') -> es' + -- (t, (pos,s))=fromJust $ find isOpenBracket toks -- s is the '(' + -- newToken = if ents /=[] then (t, (pos,(s++showEntities (render.ppi) es++","))) + -- else (t, (pos,(s++showEntities (render.ppi) es))) + -- pos'= simpPos pos + -- toks' = replaceToks toks pos' pos' [newToken] + -- put ((toks',modified),others) + -- return modu {hsModExports=Just (es++ ents)} + +-- addItemsToExport mod@(HsModule _ (SN modName (SrcLoc _ c row col)) Nothing _ _) Nothing createExp ids +addItemsToExport modu@(GHC.L l (GHC.HsModule modName Nothing _ _ _ _)) Nothing createExp ids + = assert False undefined + -- =case createExp of + -- True ->do ((toks,_),others)<-get + -- let es = case ids of + -- (Left is' ) ->map (\x-> (EntE (Var (nameToPNT x)))) is' + -- (Right es') -> es' + -- pos = (row,col) + -- newToken = mkToken Varid pos (modNameToStr modName++ "(" + -- ++ showEntities (render.ppi) es++")") + -- toks' = replaceToks toks pos pos [newToken] + -- put ((toks', modified), others) + -- return modu {hsModExports=Just es} + -- False ->return modu + + +{- +-- | Add identifiers to the export list of a module. If the second argument is like: Just p, then do the adding only if p occurs +-- in the export list, and the new identifiers are added right after p in the export list. Otherwise the new identifiers are add +-- to the beginning of the export list. In the case that the export list is emport, then if the third argument is True, then create +-- an explict export list to contain only the new identifiers, otherwise do nothing. +{- +addItemsToExport::( ) + => HsModuleP -- The module AST. + -> Maybe PName -- The condtion identifier. + -> Bool -- Create an explicit list or not + -> Either [String] [HsExportEntP] -- The identifiers to add in either String or HsExportEntP format. + -> m HsModuleP -- The result. +-} + +addItemsToExport::(MonadState (([PosToken],Bool), t1) m) + => HsModuleP -- The module AST. + -> Maybe PName -- The condtion identifier. + -> Bool -- Create an explicit list or not + -> Either [String] [HsExportEntP] -- The identifiers to add in either String or HsExportEntP format. + -> m HsModuleP -- The result. + + +addItemsToExport mod _ _ (Left []) = return mod +addItemsToExport mod _ _ (Right []) = return mod +addItemsToExport mod@(HsModule loc modName exps imps ds) (Just pn) _ ids + = case exps of + Just ents ->let (e1,e2) = break (findEntity pn) ents + in if e2 /=[] + then do ((toks,_),others)<-get + let e = (ghead "addVarItemInExport" e2) + es = case ids of + (Left is' ) ->map (\x-> (EntE (Var (nameToPNT x)))) is' + (Right es') -> es' + let (_,endPos) = getStartEndLoc toks e + (t, (_,s)) = ghead "addVarItemInExport" $ getToks (endPos,endPos) toks + newToken = mkToken t endPos (s++","++ showEntities (render.ppi) es) + toks' = replaceToks toks endPos endPos [newToken] + put ((toks',modified),others) + return (HsModule loc modName (Just (e1++(e:es)++tail e2)) imps ds) + else return mod + Nothing -> return mod + +addItemsToExport mod@(HsModule _ _ (Just ents) _ _) Nothing createExp ids + = do ((toks,_),others)<-get + let es = case ids of + (Left is' ) ->map (\x-> (EntE (Var (nameToPNT x)))) is' + (Right es') -> es' + (t, (pos,s))=fromJust $ find isOpenBracket toks -- s is the '(' + newToken = if ents /=[] then (t, (pos,(s++showEntities (render.ppi) es++","))) + else (t, (pos,(s++showEntities (render.ppi) es))) + pos'= simpPos pos + toks' = replaceToks toks pos' pos' [newToken] + put ((toks',modified),others) + return mod {hsModExports=Just (es++ ents)} + +addItemsToExport mod@(HsModule _ (SN modName (SrcLoc _ c row col)) Nothing _ _) Nothing createExp ids + =case createExp of + True ->do ((toks,_),others)<-get + let es = case ids of + (Left is' ) ->map (\x-> (EntE (Var (nameToPNT x)))) is' + (Right es') -> es' + pos = (row,col) + newToken = mkToken Varid pos (modNameToStr modName++ "(" + ++ showEntities (render.ppi) es++")") + toks' = replaceToks toks pos pos [newToken] + put ((toks', modified), others) + return mod {hsModExports=Just es} + False ->return mod +-} +-- --------------------------------------------------------------------- + +addActualParamsToRhs :: (SYB.Data t) => + GHC.Name -> [GHC.RdrName] -> t -> RefactGhc t +addActualParamsToRhs pn paramPNames rhs = do + logm $ "addActualParamsToRhs:entered:(pn,paramPNames)=" ++ showGhc (pn,paramPNames) + nameMap <- getRefactNameMap + let + worker :: (GHC.LHsExpr GHC.RdrName) -> RefactGhc (GHC.LHsExpr GHC.RdrName) +#if __GLASGOW_HASKELL__ <= 710 + worker oldExp@(GHC.L l2 (GHC.HsVar pname)) +#else + worker oldExp@(GHC.L l2 (GHC.HsVar (GHC.L _ pname))) +#endif + | eqRdrNamePure nameMap (GHC.L l2 pname) pn + = do + logDataWithAnns "addActualParamsToRhs:oldExp=" oldExp + newExp' <- foldlM addParamToExp oldExp paramPNames + + edp <- liftT $ getEntryDPT oldExp + liftT $ setEntryDPT oldExp (DP (0,0)) + l2' <- liftT $ uniqueSrcSpanT + let newExp = (GHC.L l2' (GHC.HsPar newExp')) + liftT $ addSimpleAnnT newExp (DP (0,0)) [(G GHC.AnnOpenP,DP (0,0)),(G GHC.AnnCloseP,DP (0,0))] + liftT $ setEntryDPT newExp edp + return newExp + worker x = return x + + addParamToExp :: (GHC.LHsExpr GHC.RdrName) -> GHC.RdrName -> RefactGhc (GHC.LHsExpr GHC.RdrName) + addParamToExp expr param = do + ss1 <- liftT $ uniqueSrcSpanT + ss2 <- liftT $ uniqueSrcSpanT + logm $ "addActualParamsToRhs.addParamsToExp:(ss1,ss2):" ++ showGhc (ss1,ss2) + registerRdrName (GHC.L ss2 param) +#if __GLASGOW_HASKELL__ <= 710 + let var = GHC.L ss2 (GHC.HsVar param) +#else + let var = GHC.L ss2 (GHC.HsVar (GHC.L ss2 param)) +#endif + liftT $ addSimpleAnnT var (DP (0,0)) [(G GHC.AnnVal,DP (0,1))] + let expr' = GHC.L ss1 (GHC.HsApp expr var) + liftT $ addSimpleAnnT expr' (DP (0,0)) [] + return expr' + + r <- applyTP (full_buTP (idTP `adhocTP` worker)) rhs + return r + +{- + +The code + + sumSqu (x:xs) = (sq bar2) x + sumSquares xs + +results in + + (GRHSs + [ + ({ LiftToToplevel/D1.hs:(13,15)-(15,16) } + Just (Ann (DP (0,-1)) [] [] [] Nothing Nothing) + (GRHS + [] + ({ LiftToToplevel/D1.hs:13:17-43 } + Just (Ann (DP (0,1)) [] [] [] Nothing Nothing) + (OpApp + ({ LiftToToplevel/D1.hs:13:17-27 } + Just (Ann (DP (0,0)) [] [] [] Nothing Nothing) + (HsApp + ({ LiftToToplevel/D1.hs:13:17-25 } + Just (Ann (DP (0,0)) [] [] [((G AnnOpenP),DP (0,0)),((G AnnCloseP),DP (0,0))] Nothing Nothing) + (HsPar + ({ LiftToToplevel/D1.hs:13:18-24 } + Just (Ann (DP (0,0)) [] [] [] Nothing Nothing) + (HsApp + ({ LiftToToplevel/D1.hs:13:18-19 } + Just (Ann (DP (0,0)) [] [] [((G AnnVal),DP (0,0))] Nothing Nothing) + (HsVar + (Unqual {OccName: sq}))) + ({ LiftToToplevel/D1.hs:13:21-24 } + Just (Ann (DP (0,1)) [] [] [((G AnnVal),DP (0,0))] Nothing Nothing) + (HsVar + (Unqual {OccName: bar2}))))))) + ({ LiftToToplevel/D1.hs:13:27 } + Just (Ann (DP (0,1)) [] [] [((G AnnVal),DP (0,0))] Nothing Nothing) + (HsVar + (Unqual {OccName: x}))))) + ({ LiftToToplevel/D1.hs:13:29 } + Just (Ann (DP (0,1)) [] [] [((G AnnVal),DP (0,0))] Nothing Nothing) + (HsVar + (Unqual {OccName: +}))) + (PlaceHolder) + ({ LiftToToplevel/D1.hs:13:31-43 } + Just (Ann (DP (0,1)) [] [] [] Nothing Nothing) + (HsApp + ({ LiftToToplevel/D1.hs:13:31-40 } + Just (Ann (DP (0,0)) [] [] [((G AnnVal),DP (0,0))] Nothing Nothing) + (HsVar + (Unqual {OccName: sumSquares}))) + ({ LiftToToplevel/D1.hs:13:42-43 } + Just (Ann (DP (0,1)) [] [] [((G AnnVal),DP (0,0))] Nothing Nothing) + (HsVar + (Unqual {OccName: xs})))))))))] + +-} +{- +Required end result : (sq pow) x + sumSquares xs + + (L {test/testdata/LiftToToplevel/D2.hs:6:21-46} + (OpApp + + (L {test/testdata/LiftToToplevel/D2.hs:6:21-30} + (HsApp + (L {test/testdata/LiftToToplevel/D2.hs:6:21-28} + (HsPar + (L {test/testdata/LiftToToplevel/D2.hs:6:22-27} + (HsApp + (L {test/testdata/LiftToToplevel/D2.hs:6:22-23} + (HsVar {Name: LiftToToplevel.D2.sq})) + (L {test/testdata/LiftToToplevel/D2.hs:6:25-27} + (HsVar {Name: pow})))))) + (L {test/testdata/LiftToToplevel/D2.hs:6:30} + (HsVar {Name: x})))) + + (L {test/testdata/LiftToToplevel/D2.hs:6:32} + (HsVar {Name: GHC.Num.+})) {Fixity: infixl 6} + (L {test/testdata/LiftToToplevel/D2.hs:6:34-46} + (HsApp + (L {test/testdata/LiftToToplevel/D2.hs:6:34-43} + (HsVar {Name: LiftToToplevel.D2.sumSquares})) + (L {test/testdata/LiftToToplevel/D2.hs:6:45-46} + (HsVar {Name: xs}))))))))] + +Alternate, no parens : sq pow x + sumSquares xs + + (L {test/testdata/LiftToToplevel/D2.hs:6:21-44} + (OpApp + + (L {test/testdata/LiftToToplevel/D2.hs:6:21-28} + (HsApp + (L {test/testdata/LiftToToplevel/D2.hs:6:21-26} + (HsApp + (L {test/testdata/LiftToToplevel/D2.hs:6:21-22} + (HsVar {Name: LiftToToplevel.D2.sq})) + (L {test/testdata/LiftToToplevel/D2.hs:6:24-26} + (HsVar {Name: pow})))) + (L {test/testdata/LiftToToplevel/D2.hs:6:28} + (HsVar {Name: x})))) + + + (L {test/testdata/LiftToToplevel/D2.hs:6:30} + (HsVar {Name: GHC.Num.+})) {Fixity: infixl 6} + (L {test/testdata/LiftToToplevel/D2.hs:6:32-44} + (HsApp + (L {test/testdata/LiftToToplevel/D2.hs:6:32-41} + (HsVar {Name: LiftToToplevel.D2.sumSquares})) + (L {test/testdata/LiftToToplevel/D2.hs:6:43-44} + (HsVar {Name: xs}))))))))] + + +Original : sq x + sumSquares xs + + (L {test/testdata/LiftToToplevel/D2.hs:6:21-40} + (OpApp + + (L {test/testdata/LiftToToplevel/D2.hs:6:21-24} + (HsApp + (L {test/testdata/LiftToToplevel/D2.hs:6:21-22} + (HsVar {Name: sq})) + (L {test/testdata/LiftToToplevel/D2.hs:6:24} + (HsVar {Name: x})))) + + + (L {test/testdata/LiftToToplevel/D2.hs:6:26} + (HsVar {Name: GHC.Num.+})) {Fixity: infixl 6} + (L {test/testdata/LiftToToplevel/D2.hs:6:28-40} + (HsApp + (L {test/testdata/LiftToToplevel/D2.hs:6:28-37} + (HsVar {Name: LiftToToplevel.D2.sumSquares})) + (L {test/testdata/LiftToToplevel/D2.hs:6:39-40} + (HsVar {Name: xs}))))))))] + +-} + +-- --------------------------------------------------------------------- + +-- | Duplicate a function\/pattern binding declaration under a new name +-- right after the original one. +duplicateDecl :: + [GHC.LHsDecl GHC.RdrName] -- ^ decls to be updated, containing the original decl (and sig) + ->GHC.Name -- ^ The identifier whose definition is to be duplicated + ->GHC.Name -- ^ The new name (possibly qualified) + ->RefactGhc [GHC.LHsDecl GHC.RdrName] -- ^ The result +duplicateDecl decls n newFunName + = do + logm $ "duplicateDecl entered:(decls,n,newFunName)=" ++ showGhc (decls,n,newFunName) + nm <- getRefactNameMap + let + declsToDup = definingDeclsRdrNames nm [n] decls True False + funBinding = filter isFunOrPatBindP declsToDup --get the fun binding. + typeSig = map wrapSig $ definingSigsRdrNames nm [n] decls + funBinding'' <- renamePN n newFunName PreserveQualify funBinding + typeSig'' <- renamePN n newFunName PreserveQualify typeSig + logm $ "duplicateDecl:funBinding''=" ++ showGhc funBinding'' + + funBinding3 <- mapM (\f@(GHC.L _ fb) -> do + newSpan <- liftT uniqueSrcSpanT + let fb' = GHC.L newSpan fb + liftT $ modifyAnnsT (copyAnn f fb') + return fb' + ) (typeSig'' ++ funBinding'') + when (not $ null funBinding3) $ do + liftT $ setEntryDPT (head funBinding3) (DP (2,0)) + liftT $ mapM_ (\d -> setEntryDPT d (DP (1,0))) (tail funBinding3) + let (decls1,decls2) = break (definesDeclRdr nm n) decls + (declsToDup',declsRest) = break (not . definesDeclRdr nm n) decls2 + -- logDataWithAnns "duplicateDecl:funBinding3" funBinding3 + return $ decls1 ++ declsToDup' ++ funBinding3 ++ declsRest + +-- --------------------------------------------------------------------- +-- |Divide a declaration list into three parts (before, parent, after) +-- according to the PNT, where 'parent' is the first decl containing +-- the PNT, 'before' are those decls before 'parent' and 'after' are +-- those decls after 'parent'. +divideDecls :: SYB.Data t => + [t] -> GHC.Located GHC.Name -> RefactGhc ([t], [t], [t]) +divideDecls ds (GHC.L _ pnt) = do + nm <- getRefactNameMap + let (before,after) = break (\x -> findNameInRdr nm pnt x) ds + return $ if (not $ emptyList after) + then (before, [ghead "divideDecls" after], gtail "divideDecls" after) + else (ds,[],[]) + +-- --------------------------------------------------------------------- + +-- | Remove the declaration (and the type signature is the second +-- parameter is True) that defines the given identifier from the +-- declaration list. +rmDecl:: (SYB.Data t) + => GHC.Name -- ^ The identifier whose definition is to be removed. + -> Bool -- ^ True means including the type signature. + -> t -- ^ The AST fragment containting the declarations, + -- originating from the ParsedSource + -> RefactGhc + (t, + GHC.LHsDecl GHC.RdrName, + Maybe (GHC.LSig GHC.RdrName)) -- ^ The result and the removed declaration + -- and the possibly removed siganture + +rmDecl pn incSig t = do + setStateStorage StorageNone + t' <- everywhereMStaged' SYB.Parser (SYB.mkM inModule + `SYB.extM` inLet + `SYB.extM` inMatch + ) t -- top down + -- applyTP (once_tdTP (failTP `adhocTP` inBinds)) t + storage <- getStateStorage + let decl' = case storage of + StorageDeclRdr decl -> decl + x -> error $ "rmDecl: unexpected value in StateStorage:" ++ (show x) + setStateStorage StorageNone + (t'',sig') <- if incSig + then rmTypeSig pn t' + else return (t', Nothing) + return (t'',decl',sig') + where + inModule (p :: GHC.ParsedSource) + = doRmDeclList p + + inMatch x@(((GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ _localDecls)))):: (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))) + = doRmDeclList x + + inLet :: GHC.LHsExpr GHC.RdrName -> RefactGhc (GHC.LHsExpr GHC.RdrName) + inLet letExpr@(GHC.L _ (GHC.HsLet _localDecls expr)) + = do + isDone <- getDone + if isDone + then return letExpr + else do + nameMap <- getRefactNameMap + -- decls <- liftT $ hsDecls localDecls + decls <- liftT $ hsDecls letExpr + let (decls1,decls2) = break (definesDeclRdr nameMap pn) decls + if not $ emptyList decls2 + then do + let decl = ghead "rmDecl" decls2 + setStateStorage (StorageDeclRdr decl) + case length decls of + 1 -> do -- Removing the last declaration + return expr + _ -> do + -- logm $ "rmDecl.inLet:length decls /= 1" + decls' <- doRmDecl decls1 decls2 + letExpr' <- liftT $ replaceDecls letExpr decls' + return letExpr' + else do + -- liftT $ replaceDecls localDecls decls + return letExpr + inLet x = return x + + -- --------------------------------- + + doRmDeclList parent + = do + isDone <- getDone + -- logm $ "doRmDeclList:isDone=" ++ show isDone + -- logm $ "doRmDeclList:parent=" ++ SYB.showData SYB.Parser 0 parent + if isDone + then return parent + else do + nameMap <- getRefactNameMap + decls <- liftT $ hsDecls parent + let (decls1,decls2) = break (definesDeclRdr nameMap pn) decls + if not (null decls2) + then do + -- logDataWithAnns "doRmDeclList:(parent)" (parent) + let decl = ghead "doRmDeclList" decls2 + setStateStorage (StorageDeclRdr decl) + decls' <- doRmDecl decls1 decls2 + parent' <- liftT $ replaceDecls parent decls' + -- logDataWithAnns "doRmDeclList:(parent')" (parent') + return parent' + else do + return parent + + -- --------------------------------- + + getDone = do + s <- getStateStorage + case s of + StorageNone -> return False + _ -> return True + +-- --------------------------------------------------------------------- + +-- ++AZ++ TODO: I think this has been superseded by hasDeclsSybTransform +declsSybTransform :: (SYB.Typeable a) + => (forall b. HasDecls b => b -> RefactGhc b) + -> a -> RefactGhc a +declsSybTransform transform = mt + where + mt = SYB.mkM inMatch + `SYB.extM` inPatDecl + `SYB.extM` inModule + `SYB.extM` inHsLet + + inModule :: GHC.ParsedSource -> RefactGhc GHC.ParsedSource + inModule (modu :: GHC.ParsedSource) + = transform modu + + inMatch :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> RefactGhc (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) + inMatch x@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ _localDecls))) + = transform x + + inPatDecl ::GHC.LHsDecl GHC.RdrName -> RefactGhc (GHC.LHsDecl GHC.RdrName) + inPatDecl (GHC.L _ (GHC.ValD (GHC.PatBind _ _ _ _ _))) + -- = transform x + = error $ "declsSybTransform:need to reimplement PatBind case" + inPatDecl x = return x + + inHsLet :: GHC.LHsExpr GHC.RdrName -> RefactGhc (GHC.LHsExpr GHC.RdrName) + inHsLet x@(GHC.L _ (GHC.HsLet{})) + = transform x + inHsLet x = return x + + --------------------------------------------------------------------- + +-- |Utility function to remove a decl from the middle of a list, assuming the +-- list has already been split into a (possibly empty) front before the decl, +-- and a back where the head is the decl to be removed. +doRmDecl :: [GHC.LHsDecl GHC.RdrName] -> [GHC.LHsDecl GHC.RdrName] -> RefactGhc [GHC.LHsDecl GHC.RdrName] +doRmDecl decls1 decls2 + = do + let decls2' = gtail "doRmDecl 1" decls2 + declToRemove = head decls2 + + -- logDataWithAnns "doRmDecl:(decls1,decls2)" (decls1,decls2) + unless (null decls1) $ do liftT $ balanceComments (last decls1) declToRemove + unless (null decls2') $ do liftT $ balanceComments declToRemove (head decls2') + + when (not (null decls2') && null decls1) $ do liftT $ transferEntryDPT declToRemove (head decls2') + when (not (null decls2') && not (null decls1) && not (isTypeSigDecl (last decls1))) + $ do liftT $ transferEntryDPT declToRemove (head decls2') + + -- logDataWithAnns "doRmDecl:(decls2')" (decls2') + return $ (decls1 ++ decls2') + +-- --------------------------------------------------------------------- + +-- | Remove multiple type signatures +rmTypeSigs :: (SYB.Data t) => + [GHC.Name] -- ^ The identifiers whose type signatures are to be removed. + -> t -- ^ The declarations + -> RefactGhc (t,[GHC.LSig GHC.RdrName]) + -- ^ The result and removed signatures, if there + -- were any +rmTypeSigs pns t = do + (t',demotedSigsMaybe) <- foldM (\(tee,ds) n -> do { (tee',d) <- rmTypeSig n tee; return (tee', ds++[d])}) (t,[]) pns + return (t',catMaybes demotedSigsMaybe) + +-- --------------------------------------------------------------------- + +-- | Remove the type signature that defines the given identifier's +-- type from the declaration list. +rmTypeSig :: (SYB.Data t) => + GHC.Name -- ^ The identifier whose type signature is to be removed. + -> t -- ^ The declarations + -> RefactGhc (t,Maybe (GHC.LSig GHC.RdrName)) + -- ^ The result and removed signature, if there + -- was one + + -- NOTE: It may have originated from a SigD, it is up + -- to the calling function to insert this if required +rmTypeSig pn t + = do + setStateStorage StorageNone + t' <- SYB.everywhereMStaged SYB.Renamer (SYB.mkM inMatch `SYB.extM` inPatDecl `SYB.extM` inModule) t + storage <- getStateStorage + let sig' = case storage of + StorageSigRdr sig -> Just sig + StorageNone -> Nothing + x -> error $ "rmTypeSig: unexpected value in StateStorage:" ++ (show x) + return (t',sig') + where + inModule :: GHC.ParsedSource -> RefactGhc GHC.ParsedSource + inModule (modu :: GHC.ParsedSource) + = doRmTypeSig modu + + -- Deals with the distrinct parts of a FunBind + inMatch :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName) + -> RefactGhc (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) + inMatch x@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ _localDecls))) + = doRmTypeSig x + + inPatDecl ::GHC.LHsDecl GHC.RdrName -> RefactGhc (GHC.LHsDecl GHC.RdrName) + inPatDecl x@(GHC.L _ (GHC.ValD (GHC.PatBind _ _ _ _ _))) = do + decls <- liftT $ hsDeclsPatBindD x + decls' <- doRmTypeSigDecls decls + liftT $ replaceDeclsPatBindD x decls' + + inPatDecl x = return x + + -- ---------------------------------- + + doRmTypeSig :: (HasDecls t) => t -> RefactGhc t + doRmTypeSig parent = do + decls <- liftT $ hsDecls parent + decls' <- doRmTypeSigDecls decls + liftT $ replaceDecls parent decls' + + + doRmTypeSigDecls :: [GHC.LHsDecl GHC.RdrName] -> RefactGhc [GHC.LHsDecl GHC.RdrName] + doRmTypeSigDecls decls = do + isDone <- getDone + if isDone + then return decls + else do + -- logDataWithAnns "doRmTypeSig:decls" decls + nameMap <- getRefactNameMap + let (decls1,decls2)= break (definesSigDRdr nameMap pn) decls + if not $ null decls2 + then do + -- logDataWithAnns "doRmTypeSig:parent" parent +#if __GLASGOW_HASKELL__ <= 710 + let sig@(GHC.L sspan (GHC.SigD (GHC.TypeSig names typ p))) = ghead "rmTypeSig" decls2 +#else + let sig@(GHC.L sspan (GHC.SigD (GHC.TypeSig names typ))) = ghead "rmTypeSig" decls2 +#endif + if length names > 1 + then do + let newNames = filter (\rn -> rdrName2NamePure nameMap rn /= pn) names +#if __GLASGOW_HASKELL__ <= 710 + newSig = GHC.L sspan (GHC.SigD (GHC.TypeSig newNames typ p)) +#else + newSig = GHC.L sspan (GHC.SigD (GHC.TypeSig newNames typ)) +#endif + + liftT $ removeTrailingCommaT (glast "doRmTypeSig" newNames) + + let pnt = ghead "rmTypeSig" (filter (\rn -> rdrName2NamePure nameMap rn == pn) names) + liftT $ removeTrailingCommaT pnt + + -- Construct the old signature, by keeping the + -- signature part but discarding the other names + newSpan <- liftT uniqueSrcSpanT +#if __GLASGOW_HASKELL__ <= 710 + let oldSig = (GHC.L newSpan (GHC.TypeSig [pnt] typ p)) +#else + let oldSig = (GHC.L newSpan (GHC.TypeSig [pnt] typ)) +#endif + liftT $ modifyAnnsT (copyAnn sig oldSig) + setStateStorage (StorageSigRdr oldSig) + + return (decls1++[newSig]++gtail "doRmTypeSig" decls2) + else do + let [oldSig] = decl2Sig sig + setStateStorage (StorageSigRdr oldSig) + decls' <- doRmDecl decls1 decls2 + return decls' + else do + return decls + + getDone = do + s <- getStateStorage + case s of + StorageNone -> return False + _ -> return True + +-- --------------------------------------------------------------------- + +-- TODO: Is this function needed with GHC? + +-- | Remove the qualifier from the given identifiers in the given syntax phrase. +rmQualifier:: (SYB.Data t) + =>[GHC.Name] -- ^ The identifiers. + ->t -- ^ The syntax phrase. + ->RefactGhc t -- ^ The result. +rmQualifier pns t = do + nm <- getRefactNameMap + SYB.everywhereM (nameSybTransform (rename nm)) t + where + rename nm (ln@(GHC.L l pn)::GHC.Located GHC.RdrName) + | elem (rdrName2NamePure nm ln) pns + = do + case pn of + GHC.Qual _ n -> return (GHC.L l (GHC.Unqual n)) + _ -> return ln + rename _ x = return x + +-- --------------------------------------------------------------------- + +-- | Replace all occurences of a top level GHC.Name with a qualified version. +qualifyToplevelName :: GHC.Name -> RefactGhc () +qualifyToplevelName n = do + parsed <- getRefactParsed + parsed' <- renamePN n n Qualify parsed + putRefactParsed parsed' emptyAnns + return () + +-- --------------------------------------------------------------------- + +data HowToQual = Qualify | NoQualify | PreserveQualify + deriving (Show,Eq) + +instance GHC.Outputable HowToQual where + ppr x = GHC.text (show x) + +-- | Rename each occurrences of the identifier in the given syntax +-- phrase with the new name. + +-- TODO: the syntax phrase is required to be GHC.Located, not sure how +-- to specify this without breaking the everywhereMStaged call + +renamePN::(SYB.Data t) + => GHC.Name -- ^ The identifier to be renamed. + -> GHC.Name -- ^ The new name, including possible qualifier + -> HowToQual + -- the new name. + -> t -- ^ The syntax phrase + -> RefactGhc t +renamePN oldPN newName useQual t = do + -- logm $ "renamePN: (oldPN,newName)=" ++ (showGhc (oldPN,newName)) + -- logm $ "renamePN: t=" ++ (SYB.showData SYB.Parser 0 t) + -- nm <- getRefactNameMap + newNameQual <- rdrNameFromName True newName + newNameUnqual <- rdrNameFromName False newName + -- newNameRdr <- rdrNameFromName useQual newName + -- logm $ "renamePN: (newNameQual,newNameUnqual,newNameRdr)=" ++ showGhc (newNameQual,newNameUnqual,newNameRdr) + + let + cond :: NameMap -> GHC.Located GHC.RdrName -> Bool + cond nm (GHC.L ln _) = + case Map.lookup ln nm of + Nothing -> False + Just n -> GHC.nameUnique n == GHC.nameUnique oldPN || GHC.nameUnique n == GHC.nameUnique newName + + -- Decision process for new names + newNameCalc :: HowToQual -> GHC.RdrName -> GHC.RdrName + newNameCalc uq old = newNameCalc' uq (GHC.isQual_maybe old) + where + newNameCalc' :: HowToQual -> (Maybe (GHC.ModuleName,GHC.OccName)) -> GHC.RdrName + newNameCalc' Qualify (Just (mn,_)) = GHC.Qual mn (GHC.occName newName) + newNameCalc' PreserveQualify (Just (mn,_)) = GHC.Qual mn (GHC.occName newName) + newNameCalc' NoQualify (Just (_n,_)) = GHC.Unqual (GHC.occName newName) + newNameCalc' uq' _ = if uq' == Qualify then newNameQual else newNameUnqual + + -- --------------------------------- + + makeNewName :: GHC.Located GHC.RdrName -> GHC.RdrName -> RefactGhc (GHC.Located GHC.RdrName) + makeNewName old newRdr = do + ss' <- liftT $ uniqueSrcSpanT + let new = (GHC.L ss' newRdr) + liftT $ modifyAnnsT (copyAnn old new) + addToNameMap ss' newName + return new + + -- --------------------------------- + + renameLRdr :: HowToQual -> GHC.Located GHC.RdrName -> RefactGhc (GHC.Located GHC.RdrName) + renameLRdr useQual' old@(GHC.L _ n) = do + nm <- getRefactNameMap + if cond nm old + then do + logDataWithAnns "renamePN:rename old :" old + -- let nn = newNameCalcBool useQual' n + let nn = newNameCalc useQual' n + new <- makeNewName old nn + logDataWithAnns "renamePN:rename new :" new + logDataWithAnns "renamePN:rename old2 :" old + return new + else return old + + -- --------------------------------- + + renameVar :: HowToQual -> GHC.LHsExpr GHC.RdrName -> RefactGhc (GHC.LHsExpr GHC.RdrName) +#if __GLASGOW_HASKELL__ <= 710 + renameVar useQual' x@(GHC.L l (GHC.HsVar n)) = do +#else + renameVar useQual' x@(GHC.L l (GHC.HsVar (GHC.L _ n))) = do +#endif + nm <- getRefactNameMap + if cond nm (GHC.L l n) + then do + let nn = newNameCalc useQual' n +#if __GLASGOW_HASKELL__ <= 710 + ss' <- liftT $ uniqueSrcSpanT + let (GHC.L l' _) = (GHC.L ss' nn) + liftT $ modifyAnnsT (copyAnn x (GHC.L ss' (GHC.HsVar nn))) + addToNameMap ss' newName + return (GHC.L l' (GHC.HsVar nn)) +#else + new <- makeNewName (GHC.L l n) nn + return (GHC.L l (GHC.HsVar new)) +#endif + else return x + renameVar _ x = return x + + -- --------------------------------- + + renameTyVar :: HowToQual -> (GHC.Located (GHC.HsType GHC.RdrName)) -> RefactGhc (GHC.Located (GHC.HsType GHC.RdrName)) +#if __GLASGOW_HASKELL__ <= 710 + renameTyVar useQual' x@(GHC.L l (GHC.HsTyVar n)) = do +#else + renameTyVar useQual' x@(GHC.L l (GHC.HsTyVar (GHC.L _ n))) = do +#endif + nm <- getRefactNameMap + if cond nm (GHC.L l n) + then do + logm $ "renamePN:renameTyVar at :" ++ (showGhc l) + let nn = newNameCalc useQual' n +#if __GLASGOW_HASKELL__ <= 710 + ss' <- liftT $ uniqueSrcSpanT + let (GHC.L l' _) = (GHC.L ss' nn) + liftT $ modifyAnnsT (copyAnn x (GHC.L ss' (GHC.HsTyVar nn))) + addToNameMap ss' newName + return (GHC.L l' (GHC.HsTyVar nn)) +#else + new <- makeNewName (GHC.L l n) nn + return (GHC.L l (GHC.HsTyVar new)) +#endif + else return x + renameTyVar _ x = return x + + -- --------------------------------- + + renameHsTyVarBndr :: HowToQual -> GHC.LHsTyVarBndr GHC.RdrName -> RefactGhc (GHC.LHsTyVarBndr GHC.RdrName) +#if __GLASGOW_HASKELL__ <= 710 + renameHsTyVarBndr useQual' x@(GHC.L l (GHC.UserTyVar n)) = do +#else + renameHsTyVarBndr useQual' x@(GHC.L l (GHC.UserTyVar (GHC.L _ n))) = do +#endif + nm <- getRefactNameMap + if cond nm (GHC.L l n) + then do + logm $ "renamePN:renameHsTyVarBndr at :" ++ (showGhc l) + -- let nn = newNameCalcBool useQual' n + let nn = newNameCalc useQual' n +#if __GLASGOW_HASKELL__ <= 710 + addToNameMap l newName + return (GHC.L l (GHC.UserTyVar nn)) +#else + new <- makeNewName (GHC.L l n) nn + return (GHC.L l (GHC.UserTyVar new)) +#endif + else return x + renameHsTyVarBndr _ x = return x + + -- --------------------------------- + + renameLIE :: HowToQual -> (GHC.LIE GHC.RdrName) -> RefactGhc (GHC.LIE GHC.RdrName) + renameLIE useQual' x@(GHC.L l (GHC.IEVar old@(GHC.L ln n))) = do + nm <- getRefactNameMap + if cond nm (GHC.L ln n) + then do + -- logm $ "renamePN:renameLIE.IEVar at :" ++ (showGhc l) + let nn = newNameCalc useQual' n + + new <- makeNewName old nn + + return (GHC.L l (GHC.IEVar new)) + else return x + + renameLIE useQual' x@(GHC.L l (GHC.IEThingAbs old@(GHC.L _ln n))) = do + nm <- getRefactNameMap + if cond nm (GHC.L l n) + then do + -- logm $ "renamePN:renameLIE.IEThingAbs at :" ++ (showGhc l) + let nn = newNameCalc useQual' n + + new <- makeNewName old nn + + return (GHC.L l (GHC.IEThingAbs new)) + else return x + + renameLIE useQual' x@(GHC.L l (GHC.IEThingAll old@(GHC.L ln n))) = do + nm <- getRefactNameMap + if cond nm (GHC.L ln n) + then do + -- logm $ "renamePN:renameLIE.IEThingAll at :" ++ (showGhc l) + let nn = newNameCalc useQual' n + + new <- makeNewName old nn + + return (GHC.L l (GHC.IEThingAll new)) + else return x + + -- TODO: check inside the ns here too +#if __GLASGOW_HASKELL__ <= 710 + renameLIE useQual' (GHC.L l (GHC.IEThingWith old@(GHC.L ln n) ns)) +#else + renameLIE useQual' (GHC.L l (GHC.IEThingWith old@(GHC.L ln n) wc ns fls)) +#endif + = do + nm <- getRefactNameMap + old' <- if (cond nm (GHC.L ln n)) + then do + logm $ "renamePN:renameLIE.IEThingWith at :" ++ (showGhc l) + -- let nn = newNameCalcBool useQual' n + let nn = newNameCalc useQual' n + new <- makeNewName old nn + return new + else return old + + + ns' <- if (any (\(GHC.L lnn nn) -> cond nm (GHC.L lnn nn)) ns) + then renameTransform useQual' ns + else return ns +#if __GLASGOW_HASKELL__ <= 710 + return (GHC.L l (GHC.IEThingWith old' ns')) +#else + return (GHC.L l (GHC.IEThingWith old' wc ns' fls)) +#endif + + renameLIE _ x = do + -- logm $ "renamePN:renameLIE miss for :" ++ (showGhc x) + return x + + -- --------------------------------- + + renameLPat :: HowToQual -> (GHC.LPat GHC.RdrName) -> RefactGhc (GHC.LPat GHC.RdrName) +#if __GLASGOW_HASKELL__ <= 710 + renameLPat useQual' x@(GHC.L l (GHC.VarPat n)) = do +#else + renameLPat useQual' x@(GHC.L l (GHC.VarPat (GHC.L _ n))) = do +#endif + nm <- getRefactNameMap + if cond nm (GHC.L l n) + then do + logm $ "renamePNworker:renameLPat at :" ++ (showGhc l) + let nn = newNameCalc useQual' n +#if __GLASGOW_HASKELL__ <= 710 + ss' <- liftT $ uniqueSrcSpanT + let (GHC.L l' _) = (GHC.L ss' nn) + liftT $ modifyAnnsT (copyAnn x (GHC.L ss' (GHC.VarPat nn))) + addToNameMap ss' newName + return (GHC.L l' (GHC.VarPat nn)) +#else + new <- makeNewName (GHC.L l n) nn + return (GHC.L l (GHC.VarPat new)) +#endif + else return x + renameLPat _ x = return x + + -- --------------------------------- + + renameMatch :: HowToQual -> GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName) + -> RefactGhc (GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName)) + renameMatch _useQual (GHC.Match mln pats ty grhss) = do + logm $ "renamePN.renameMatch entered:" + pats' <- renameTransform _useQual pats + ty' <- renameTransform _useQual ty + grhss' <- renameTransform _useQual grhss + mln' <- case mln of +#if __GLASGOW_HASKELL__ <= 710 + Just (old@(GHC.L lmn mn),f) -> do + nm <- getRefactNameMap + if cond nm (GHC.L lmn mn) + then do + new <- makeNewName old newNameUnqual + return (Just (new,f)) + else return mln + Nothing -> return mln +#else + GHC.FunBindMatch old f -> do + nm <- getRefactNameMap + if cond nm old + then do + new <- makeNewName old newNameUnqual + return (GHC.FunBindMatch new f) + else return mln + GHC.NonFunBindMatch -> return mln +#endif + return (GHC.Match mln' pats' ty' grhss') + + -- --------------------------------- + + renameImportDecl :: HowToQual -> GHC.ImportDecl GHC.RdrName -> RefactGhc (GHC.ImportDecl GHC.RdrName) + renameImportDecl _useQual (GHC.ImportDecl src mn mq isrc isafe iq ii ma (Just (ij,GHC.L ll ies))) = do + ies' <- mapM (renameLIE PreserveQualify) ies + logm $ "renamePN'.renameImportDecl:(ies,ies')=" ++ showGhc (ies,ies') + return (GHC.ImportDecl src mn mq isrc isafe iq ii ma (Just (ij,GHC.L ll ies'))) + renameImportDecl _ x = return x + + -- --------------------------------- + + renameTypeSig :: HowToQual -> (GHC.Sig GHC.RdrName) -> RefactGhc (GHC.Sig GHC.RdrName) +#if __GLASGOW_HASKELL__ <= 710 + renameTypeSig _useQual (GHC.TypeSig ns typ p) +#else + renameTypeSig _useQual (GHC.TypeSig ns typ) +#endif + = do + logm $ "renamePN:renameTypeSig" + ns' <- mapM (renameLRdr NoQualify) ns + typ' <- renameTransform _useQual typ + logm $ "renamePN:renameTypeSig done" +#if __GLASGOW_HASKELL__ <= 710 + return (GHC.TypeSig ns' typ' p) +#else + return (GHC.TypeSig ns' typ') +#endif +#if __GLASGOW_HASKELL__ > 710 + renameTypeSig _useQual (GHC.ClassOpSig f ns typ) + = do + ns' <- mapM (renameLRdr NoQualify) ns + typ' <- renameTransform _useQual typ + return (GHC.ClassOpSig f ns' typ') +#endif + renameTypeSig _ x = return x + + -- --------------------------------- + + everywhereMSkip :: Monad m => SYB.GenericM m -> SYB.GenericM m + everywhereMSkip f x + | (const False `SYB.extQ` typeSig) x = f x -- no recursion for typeSig + | (const False `SYB.extQ` match) x = f x -- no recursion for FunBind + | (const False `SYB.extQ` importDecl) x = f x -- no recursion for ImportDecl + | otherwise = do x' <- f x + SYB.gmapM (everywhereMSkip f) x' + where + typeSig = const True :: GHC.Sig GHC.RdrName -> Bool + match = const True :: GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> Bool + importDecl = const True :: GHC.ImportDecl GHC.RdrName -> Bool + + renameTransform useQual' t' = + (everywhereMSkip ( -- top-down, skipping Located Names for Sig/Match + SYB.mkM (renameVar useQual') + `SYB.extM` (renameLRdr useQual') + `SYB.extM` (renameTyVar useQual') + `SYB.extM` (renameHsTyVarBndr useQual') + `SYB.extM` (renameLIE useQual') + `SYB.extM` (renameLPat useQual') + `SYB.extM` (renameTypeSig useQual') + `SYB.extM` (renameImportDecl useQual') + `SYB.extM` (renameMatch useQual') + ) t') + t' <- renameTransform useQual t + return t' + +-- --------------------------------------------------------------------- + +-- | Check whether the specified identifier is declared in the given syntax phrase t, +-- if so, rename the identifier by creating a new name automatically. +autoRenameLocalVar:: (SYB.Data t) + => GHC.Name -- ^ The identifier. + -> t -- ^ The syntax phrase. + -> RefactGhc t -- ^ The result. +autoRenameLocalVar pn t = do + logm $ "autoRenameLocalVar: (pn)=" ++ (showGhc (pn)) + -- = everywhereMStaged SYB.Renamer (SYB.mkM renameInMatch) + nm <- getRefactNameMap + decls <- liftT $ hsDeclsGeneric t + if isDeclaredInRdr nm pn decls + then do t' <- worker t + return t' + else do return t + + where + worker :: (SYB.Data t) => t -> RefactGhc t + worker tt + =do (f,d) <- hsFDNamesFromInsideRdr tt + ds <- hsVisibleNamesRdr pn tt + let newNameStr = mkNewName (nameToString pn) (nub (f `union` d `union` ds)) 1 + newName <- mkNewGhcName Nothing newNameStr + renamePN pn newName PreserveQualify tt + +-- --------------------------------------------------------------------- + +isMainModule :: GHC.Module -> Bool +#if __GLASGOW_HASKELL__ <= 710 +isMainModule modu = GHC.modulePackageKey modu == GHC.mainPackageKey +#else +isMainModule modu = GHC.moduleUnitId modu == GHC.mainUnitId +#endif + +-- --------------------------------------------------------------------- + +-- | Return the identifier's defining location. +-- defineLoc::PNT->SrcLoc +defineLoc :: GHC.Located GHC.Name -> GHC.SrcLoc +defineLoc (GHC.L _ name) = GHC.nameSrcLoc name + +-- | Return the identifier's source location. +-- useLoc::PNT->SrcLoc +useLoc:: (GHC.Located GHC.Name) -> GHC.SrcLoc +-- useLoc (GHC.L l _) = getGhcLoc l +useLoc (GHC.L l _) = GHC.srcSpanStart l + +-- --------------------------------------------------------------------- + +-- | Return the type checked `GHC.Id` corresponding to the given +-- `GHC.Name` + +-- TODO: there has to be a simpler way, using the appropriate GHC internals +findIdForName :: GHC.Name -> RefactGhc (Maybe GHC.Id) +findIdForName n = do + tm <- getTypecheckedModule + let t = GHC.tm_typechecked_source tm + let r = SYB.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` worker) t + worker (i::GHC.Id) + | (GHC.nameUnique n) == (GHC.varUnique i) = Just i + worker _ = Nothing + return r + +-- --------------------------------------------------------------------- + +getTypeForName :: GHC.Name -> RefactGhc (Maybe GHC.Type) +getTypeForName n = do + mId <- findIdForName n + case mId of + Nothing -> return Nothing + Just i -> return $ Just (GHC.varType i) + +-- --------------------------------------------------------------------- + +-- | Given the syntax phrase, find the largest-leftmost expression +-- contained in the region specified by the start and end position, if +-- found. +locToExp:: (SYB.Data t,SYB.Typeable n) => + SimpPos -- ^ The start position. + -> SimpPos -- ^ The end position. + -> t -- ^ The syntax phrase. + -> Maybe (GHC.LHsExpr n) -- ^ The result. +locToExp beginPos endPos t = res + where + res = SYB.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` expr) t + + expr :: GHC.LHsExpr n -> Maybe (GHC.LHsExpr n) + expr e + |inScope e = Just e + expr _ = Nothing + + inScope :: GHC.Located e -> Bool + inScope (GHC.L l _) = + let + (startLoc,endLoc) = case l of + (GHC.RealSrcSpan ss) -> + ((GHC.srcSpanStartLine ss,GHC.srcSpanStartCol ss), + (GHC.srcSpanEndLine ss,GHC.srcSpanEndCol ss)) + (GHC.UnhelpfulSpan _) -> ((0,0),(0,0)) + in + (startLoc>=beginPos) && (startLoc<= endPos) && (endLoc>= beginPos) && (endLoc<=endPos) + +-------------------------------------------------------------------------------- + +-- | If an expression consists of only one identifier then return this +-- identifier in the GHC.Name format, otherwise return the default Name +expToNameRdr :: NameMap -> GHC.LHsExpr GHC.RdrName -> Maybe GHC.Name +#if __GLASGOW_HASKELL__ <= 710 +expToNameRdr nm (GHC.L l (GHC.HsVar pnt)) = Just (rdrName2NamePure nm (GHC.L l pnt)) +#else +expToNameRdr nm (GHC.L _ (GHC.HsVar pnt)) = Just (rdrName2NamePure nm pnt) +#endif +expToNameRdr nm (GHC.L _ (GHC.HsPar e)) = expToNameRdr nm e +expToNameRdr _ _ = Nothing + +nameToString :: GHC.Name -> String +-- nameToString name = showGhc name +nameToString name = showGhcQual name + +-- | If a pattern consists of only one identifier then return this +-- identifier, otherwise return Nothing +patToNameRdr :: NameMap -> GHC.LPat GHC.RdrName -> Maybe GHC.Name +#if __GLASGOW_HASKELL__ <= 710 +patToNameRdr nm (GHC.L l (GHC.VarPat n)) = Just (rdrName2NamePure nm (GHC.L l n)) +#else +patToNameRdr nm (GHC.L _ (GHC.VarPat n)) = Just (rdrName2NamePure nm n) +#endif +patToNameRdr _ _ = Nothing + +-- | Compose a pattern from a pName. +{-# DEPRECATED pNtoPat "Can't use Renamed in GHC 8" #-} +pNtoPat :: name -> GHC.Pat name +#if __GLASGOW_HASKELL__ <= 710 +pNtoPat pname = GHC.VarPat pname +#else +pNtoPat pname = GHC.VarPat (GHC.noLoc pname) +#endif -- EOF diff --git a/src/Language/Haskell/Refact/Utils/Types.hs b/src/Language/Haskell/Refact/Utils/Types.hs --- a/src/Language/Haskell/Refact/Utils/Types.hs +++ b/src/Language/Haskell/Refact/Utils/Types.hs @@ -1,8 +1,9 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} module Language.Haskell.Refact.Utils.Types ( ApplyRefacResult , RefacResult(..) - , RefacSource(..) -- * , TreeId(..) , mainTid @@ -13,9 +14,12 @@ ) where -import qualified GHC as GHC +import qualified GHC as GHC +-- import qualified Name as GHC +-- import qualified Outputable as GHC import Language.Haskell.GHC.ExactPrint +-- import Language.Haskell.GHC.ExactPrint.Utils import qualified Data.Map as Map @@ -28,11 +32,6 @@ data RefacResult = RefacModified | RefacUnmodifed deriving (Show,Ord,Eq) - -data RefacSource = RSFile FilePath - | RSMod GHC.ModSummary - | RSAlreadyLoaded - -- --------------------------------------------------------------------- data TreeId = TId !Int deriving (Eq,Ord,Show) @@ -54,3 +53,7 @@ type NameMap = Map.Map GHC.SrcSpan GHC.Name +-- instance GHC.Outputable NameMap where +-- ppr nm = GHC.text "NameMap" GHC.<+> GHC.hcat (map one $ Map.toList nm) +-- where +-- one (s,n) = GHC.text (showGhc (s,n,GHC.nameUnique n)) diff --git a/src/Language/Haskell/Refact/Utils/Utils.hs b/src/Language/Haskell/Refact/Utils/Utils.hs --- a/src/Language/Haskell/Refact/Utils/Utils.hs +++ b/src/Language/Haskell/Refact/Utils/Utils.hs @@ -28,14 +28,16 @@ , modifiedFiles , writeRefactoredFiles + , stripCallStack + ) where -import Control.Exception +-- import Control.Exception import Control.Monad.Identity import Control.Monad.State import Data.List -import Language.Haskell.GHC.ExactPrint +-- import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Preprocess import Language.Haskell.GHC.ExactPrint.Print import Language.Haskell.GHC.ExactPrint.Types @@ -103,7 +105,6 @@ setDynFlags :: GHC.DynFlags -> GHC.Ghc GHC.DynFlags setDynFlags df = return (GHC.gopt_set df GHC.Opt_KeepRawTokenStream) --- setDynFlags df = return df -- --------------------------------------------------------------------- @@ -208,15 +209,6 @@ -- --------------------------------------------------------------------- -cdAndDo :: FilePath -> IO a -> IO a -cdAndDo path fn = do - old <- getCurrentDirectory - r <- GHC.gbracket (setCurrentDirectory path) (\_ -> setCurrentDirectory old) - $ const fn - return r - --- --------------------------------------------------------------------- - canonicalizeTargets :: Targets-> IO Targets canonicalizeTargets tgts = do cur <- getCurrentDirectory @@ -245,6 +237,8 @@ fileName <- case source of RSFile fname -> do parseSourceFileGhc fname return fname + RSTarget tgt -> do getTargetGhc tgt + return (GM.mpPath tgt) RSMod ms -> do parseSourceFileGhc $ fileNameFromModSummary ms return $ fileNameFromModSummary ms RSAlreadyLoaded -> do mfn <- getRefactFileName @@ -451,3 +445,15 @@ $ map summaryNodeSummary $ GHC.reachableG mg modNode return serverMods + +-- --------------------------------------------------------------------- + +-- | In GHC 8 an error has an attached callstack. This is not always what we +-- want, so this function strips it +stripCallStack :: String -> String +stripCallStack str = str' + where + s1 = init $ unlines $ takeWhile (\s -> s /= "CallStack (from HasCallStack):") $ lines str + str' = if last str == '\n' + then s1 ++ "\n" + else s1 diff --git a/src/Language/Haskell/Refact/Utils/Variables.hs b/src/Language/Haskell/Refact/Utils/Variables.hs --- a/src/Language/Haskell/Refact/Utils/Variables.hs +++ b/src/Language/Haskell/Refact/Utils/Variables.hs @@ -17,2459 +17,1590 @@ isFieldName , isClassName , isInstanceName - , isDeclaredIn,isDeclaredInRdr - , FreeNames(..),DeclaredNames(..) - , hsFreeAndDeclaredPNsOld - , hsFreeAndDeclaredRdr - , hsFreeAndDeclaredNameStrings - , hsFreeAndDeclaredPNs - , hsFreeAndDeclaredGhc - , getDeclaredTypes - , getDeclaredTypesRdr - , getFvs, getFreeVars, getDeclaredVars - , hsVisiblePNs, hsVisiblePNsRdr, hsVisibleNames, hsVisibleNamesRdr - , hsFDsFromInsideRdr, hsFDNamesFromInsideRdr - , hsFDsFromInside, hsFDNamesFromInside - , hsVisibleDs, hsVisibleDsRdr - , rdrName2Name, rdrName2NamePure - , eqRdrNamePure - , rdrName2Name' - - -- ** Identifiers, expressions, patterns and declarations - , FindEntity(..) - , sameOccurrence - , definedPNs, definedPNsRdr,definedNamesRdr - , definingDeclsRdrNames,definingDeclsRdrNames',definingSigsRdrNames - , definingDeclsNames, definingDeclsNames', definingSigsNames - , definingTyClDeclsNames - , defines - , definesRdr,definesDeclRdr - , definesTypeSig,definesTypeSigRdr,definesSigDRdr - , definesP - , allNames - - , hsPNs, hsNamess, hsNamessRdr - , locToName, locToRdrName - ) where - -import Control.Monad.State -import Data.List -import Data.Maybe -import Data.Monoid - -import Language.Haskell.Refact.Utils.Binds -import Language.Haskell.Refact.Utils.GhcVersionSpecific -import Language.Haskell.Refact.Utils.LocUtils -import Language.Haskell.Refact.Utils.Monad -import Language.Haskell.Refact.Utils.MonadFunctions -import Language.Haskell.Refact.Utils.TypeSyn -import Language.Haskell.Refact.Utils.Types - -import Language.Haskell.GHC.ExactPrint.Types -import Language.Haskell.GHC.ExactPrint -import Language.Haskell.GHC.ExactPrint.Utils - - --- Modules from GHC -import qualified Bag as GHC -import qualified GHC as GHC -import qualified Name as GHC -import qualified NameSet as GHC -import qualified Outputable as GHC -import qualified RdrName as GHC -import qualified UniqSet as GHC - -import qualified Data.Generics as SYB -import qualified GHC.SYB.Utils as SYB - -import qualified Data.Map as Map - -import Data.Generics.Strafunski.StrategyLib.StrategyLib hiding (liftIO,MonadPlus,mzero) - --- --------------------------------------------------------------------- - -class (SYB.Data a, SYB.Typeable a) => FindEntity a where - - -- | Returns True is a syntax phrase, say a, is part of another - -- syntax phrase, say b. - -- NOTE: very important: only do a shallow check - findEntity:: (SYB.Data b) => a -> b -> Bool - --- --------------------------------------------------------------------- - -instance FindEntity GHC.Name where - - findEntity n t = fromMaybe False res - where - res = SYB.somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t - - worker (name::GHC.Name) - | n == name = Just True - worker _ = Nothing - - --- This instance does not make sense, it will only find the specific RdrName --- where it was found, not any other instances of it. -instance FindEntity (GHC.Located GHC.RdrName) where - - findEntity ln t = - case SYB.something (nameSybQuery checkRdr) t of - Nothing -> False - _ -> True - where - checkRdr :: GHC.Located GHC.RdrName -> Maybe Bool - checkRdr n - | sameOccurrence n ln = Just True - | otherwise = Nothing - --- --------------------------------------------------------------------- -{- --- This is not precise enough, RdrNames are ambiguous -instance FindEntity GHC.RdrName where - - findEntity n t = fromMaybe False res - where - res = SYB.something (Nothing `SYB.mkQ` worker) t - - worker (name::GHC.RdrName) - | n == name = Just True - worker _ = Nothing --} --- --------------------------------------------------------------------- - --- TODO: should the location be matched too in this case? -instance FindEntity (GHC.Located GHC.Name) where - - findEntity n t = fromMaybe False res - where - res = SYB.somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t - - worker (name::GHC.Located GHC.Name) - | n == name = Just True - worker _ = Nothing - - --- --------------------------------------------------------------------- - -instance FindEntity (GHC.LHsExpr GHC.RdrName) where - - findEntity e t = fromMaybe False res - where - res = SYB.something (Nothing `SYB.mkQ` worker) t - - worker (expr :: GHC.LHsExpr GHC.RdrName) - | sameOccurrence e expr = Just True - worker _ = Nothing - --- TODO: remove this instance -instance FindEntity (GHC.LHsExpr GHC.Name) where - - findEntity e t = fromMaybe False res - where - res = SYB.something (Nothing `SYB.mkQ` worker) t - - worker (expr :: GHC.LHsExpr GHC.Name) - | sameOccurrence e expr = Just True - worker _ = Nothing - --- --------------------------------------------------------------------- - -instance FindEntity (GHC.Located (GHC.HsBindLR GHC.Name GHC.Name)) where - findEntity e t = fromMaybe False res - where - res = SYB.somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t - - worker (expr::(GHC.Located (GHC.HsBindLR GHC.Name GHC.Name))) - | sameOccurrence e expr = Just True - worker _ = Nothing - -instance FindEntity (GHC.Located (GHC.HsDecl GHC.Name)) where - findEntity d t = fromMaybe False res - where - res = SYB.somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t - - worker (decl::(GHC.Located (GHC.HsDecl GHC.Name))) - | sameOccurrence d decl = Just True - worker _ = Nothing - --- --------------------------------------------------------------------- - --- TODO: AZ: pretty sure this can be simplified, depends if we need to --- manage transformed stuff too though. - --- | Return True if syntax phrases t1 and t2 refer to the same one. -sameOccurrence :: (GHC.Located t) -> (GHC.Located t) -> Bool -sameOccurrence (GHC.L l1 _) (GHC.L l2 _) - = l1 == l2 - - --- --------------------------------------------------------------------- - --- | For free variables -data FreeNames = FN { fn :: [GHC.Name] } - --- | For declared variables -data DeclaredNames = DN { dn :: [GHC.Name] } - -instance Show FreeNames where - show (FN ls) = "FN " ++ showGhcQual ls - -instance Show DeclaredNames where - show (DN ls) = "DN " ++ showGhcQual ls - -instance Monoid FreeNames where - mempty = FN [] - mappend (FN a) (FN b) = FN (a `mappend` b) - -instance Monoid DeclaredNames where - mempty = DN [] - mappend (DN a) (DN b) = DN (a `mappend` b) - - -emptyFD :: (FreeNames,DeclaredNames) -emptyFD = (FN [], DN []) - --- --------------------------------------------------------------------- --- | True if the name is a field name -isFieldName :: GHC.Name -> Bool -isFieldName _n = error "undefined isFieldName" - --- --------------------------------------------------------------------- --- | True if the name is a field name -isClassName :: GHC.Name -> Bool -isClassName _n = error "undefined isClassName" - --- --------------------------------------------------------------------- --- | True if the name is a class instance -isInstanceName :: GHC.Name -> Bool -isInstanceName _n = error "undefined isInstanceName" - - --- --------------------------------------------------------------------- --- | Collect the identifiers (in PName format) in a given syntax phrase. - -hsPNs::(SYB.Data t)=> t -> [PName] -hsPNs t = (nub.ghead "hsPNs") res - where - res = SYB.everythingStaged SYB.Parser (++) [] ([] `SYB.mkQ` inPnt) t - - inPnt (pname :: GHC.RdrName) = return [(PN pname)] - -------------------------------------------------------------------------------- --- ++AZ++ see if we can get away with one only.. -isDeclaredIn :: (HsValBinds t GHC.Name) => GHC.Name -> t -> Bool -isDeclaredIn name t = nonEmptyList $ definingDeclsNames [name] (hsBinds t) False True - -isDeclaredInRdr :: NameMap -> GHC.Name -> [GHC.LHsDecl GHC.RdrName] -> Bool -isDeclaredInRdr nm name decls = nonEmptyList $ definingDeclsRdrNames nm [name] decls False True - --- --------------------------------------------------------------------- --- | Collect the free and declared variables (in the GHC.Name format) --- in a given syntax phrase t. In the result, the first list contains --- the free variables, and the second list contains the declared --- variables. --- Expects RenamedSource -hsFreeAndDeclaredRdr :: (SYB.Data t) => NameMap -> t -> (FreeNames,DeclaredNames) -hsFreeAndDeclaredRdr nm t = res - where - fd = hsFreeAndDeclaredRdr' nm t - (FN f,DN d) = fromMaybe mempty fd - res = (FN (f \\ d),DN d) - -hsFreeAndDeclaredRdr':: (SYB.Data t) => NameMap -> t -> Maybe (FreeNames,DeclaredNames) -hsFreeAndDeclaredRdr' nm t = do - (FN f,DN d) <- hsFreeAndDeclared' - let (f',d') = (nub f, nub d) - return (FN f',DN d') - -- hsFreeAndDeclared'=applyTU (stop_tdTU (failTU `adhocTU` exp - - where - hsFreeAndDeclared' :: Maybe (FreeNames,DeclaredNames) - hsFreeAndDeclared' = applyTU (stop_tdTU (failTU - `adhocTU` expr - `adhocTU` pattern - `adhocTU` binds - `adhocTU` bindList - `adhocTU` match - `adhocTU` stmts - `adhocTU` rhs - `adhocTU` ltydecl - )) t - - -- expr -- - expr (GHC.L l (GHC.HsVar n)) - = return (FN [rdrName2NamePure nm (GHC.L l n)],DN []) - - expr (GHC.L _ (GHC.OpApp e1 (GHC.L l (GHC.HsVar n)) _ e2)) = do - efed <- hsFreeAndDeclaredRdr' nm [e1,e2] - fd <- addFree (rdrName2NamePure nm (GHC.L l n)) efed - return fd - - expr (GHC.L _ ((GHC.HsLam (GHC.MG matches _ _ _))) :: GHC.LHsExpr GHC.RdrName) = - hsFreeAndDeclaredRdr' nm matches - - expr (GHC.L _ ((GHC.HsLet decls e)) :: GHC.LHsExpr GHC.RdrName) = - do - (FN df,DN dd) <- hsFreeAndDeclaredRdr' nm decls - (FN ef,_) <- hsFreeAndDeclaredRdr' nm e - return (FN (df `union` (ef \\ dd)),DN []) - - expr (GHC.L _ (GHC.RecordCon ln _ e)) = do - fd <- (hsFreeAndDeclaredRdr' nm e) - addFree (rdrName2NamePure nm ln) fd --Need Testing - - expr (GHC.L _ (GHC.EAsPat ln e)) = do - fd <- (hsFreeAndDeclaredRdr' nm e) - addFree (rdrName2NamePure nm ln) fd - - expr _ = mzero - - - -- rhs -- - rhs ((GHC.GRHSs g ds) :: GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName)) - = do (FN df,DN dd) <- hsFreeAndDeclaredRdr' nm g - (FN ef,DN ed) <- hsFreeAndDeclaredRdr' nm ds - return (FN $ df ++ ef, DN $ dd ++ ed) - - - -- pat -- - pattern (GHC.L _ (GHC.AsPat ln pat)) = do - let (f,DN d) = fromMaybe mempty $ hsFreeAndDeclaredRdr' nm pat - return (f,DN (rdrName2NamePure nm ln:d)) - - pattern (GHC.L l (GHC.VarPat n)) - = return (FN [],DN [rdrName2NamePure nm (GHC.L l n)]) - -- It seems all the GHC pattern match syntax elements end up - -- with GHC.VarPat - - pattern _ = mzero - -- pattern _ = return ([],[]) - - bindList (ds :: [GHC.LHsBind GHC.RdrName]) - =do (FN f,DN d) <- hsFreeAndDeclaredList ds - return (FN (f\\d),DN d) - -- bindList _ = mzero - - -- match and patBind, same type-- - binds ((GHC.FunBind ln _ (GHC.MG matches _ _ _) _ _fvs _) :: GHC.HsBind GHC.RdrName) - = do - (FN pf,_pd) <- hsFreeAndDeclaredRdr' nm matches - let n = rdrName2NamePure nm ln - return (FN (pf \\ [n]) ,DN [n]) - - -- patBind -- - binds (GHC.PatBind pat prhs _ _ds _) = - do - (FN pf,DN pd) <- hsFreeAndDeclaredRdr' nm pat - (FN rf,DN rd) <- hsFreeAndDeclaredRdr' nm prhs - return (FN $ pf `union` (rf \\ pd),DN $ pd ++ rd) - - binds _ = mzero - - match ((GHC.Match _fn pats _mtype mrhs) :: GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName)) - = do - (FN pf,DN pd) <- hsFreeAndDeclaredRdr' nm pats - (FN rf,DN rd) <- hsFreeAndDeclaredRdr' nm mrhs - return (FN (pf `union` (rf \\ (pd `union` rd))),DN []) - - -- stmts -- - stmts ((GHC.BindStmt pat expre _bindOp _failOp) :: GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = do - -- TODO ++AZ++ : Not sure it is meaningful to pull - -- anything out of bindOp/failOp - (FN pf,DN pd) <- hsFreeAndDeclaredRdr' nm pat - (FN ef,_ed) <- hsFreeAndDeclaredRdr' nm expre - let sf1 = [] - return (FN $ pf `union` ef `union` (sf1\\pd),DN []) -- pd) -- Check this - - stmts ((GHC.LetStmt binds') :: GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = - hsFreeAndDeclaredRdr' nm binds' - - stmts _ = mzero - - -- tycldecls ----------------- - - ltydecl :: GHC.LTyClDecl GHC.RdrName -> Maybe (FreeNames,DeclaredNames) - - ltydecl (GHC.L _ (GHC.FamDecl fd)) = hsFreeAndDeclaredRdr' nm fd - ltydecl (GHC.L _ (GHC.SynDecl ln _bndrs _rhs _fvs)) - = return (FN [],DN [rdrName2NamePure nm ln]) - ltydecl (GHC.L _ (GHC.DataDecl ln _bndrs defn _fvs)) = do - let dds = map (rdrName2NamePure nm) $ concatMap (GHC.con_names . GHC.unLoc) $ GHC.dd_cons defn - return (FN [],DN (rdrName2NamePure nm ln:dds)) - ltydecl (GHC.L _ (GHC.ClassDecl _ctx ln _tyvars - _fds _sigs meths ats atds _docs _fvs)) = do - (_,md) <- hsFreeAndDeclaredRdr' nm meths - (_,ad) <- hsFreeAndDeclaredRdr' nm ats - (_,atd) <- hsFreeAndDeclaredRdr' nm atds - return (FN [],DN [rdrName2NamePure nm ln] <> md <> ad <> atd) - - ------------------------------ - - addFree :: GHC.Name -> (FreeNames,DeclaredNames) - -> Maybe (FreeNames,DeclaredNames) - addFree free (FN fr,de) = return (FN $ [free] `union` fr, de) - - hsFreeAndDeclaredList :: (SYB.Data t) => [t] -> Maybe (FreeNames,DeclaredNames) - hsFreeAndDeclaredList l = do - fds <- mapM (hsFreeAndDeclaredRdr' nm) l - let - unionF (FN a) (FN b) = FN (a `union` b) - unionD (DN a) (DN b) = DN (a `union` b) - return (foldr unionF mempty (map fst fds), - foldr unionD mempty (map snd fds)) - - --- --------------------------------------------------------------------- --- | Collect the free and declared variables (in the GHC.Name format) --- in a given syntax phrase t. In the result, the first list contains --- the free variables, and the second list contains the declared --- variables. --- Expects RenamedSource -hsFreeAndDeclaredPNsOld:: (SYB.Data t) => t -> ([GHC.Name],[GHC.Name]) -hsFreeAndDeclaredPNsOld t = res - where - fd = hsFreeAndDeclaredPNs' t - (f,d) = fromMaybe ([],[]) fd - res = (f \\ d, d) - -hsFreeAndDeclaredPNs':: (SYB.Data t) => t -> Maybe ([GHC.Name],[GHC.Name]) -hsFreeAndDeclaredPNs' t = do - (f,d) <- hsFreeAndDeclared' - let (f',d') = (nub f, nub d) - -- return (f' \\ d',d') - return (f',d') - -- hsFreeAndDeclared'=applyTU (stop_tdTU (failTU `adhocTU` exp - - where - - hsFreeAndDeclared' = applyTU (stop_tdTU (failTU - `adhocTU` expr - `adhocTU` pattern - `adhocTU` binds - `adhocTU` bindList - `adhocTU` match - `adhocTU` stmts - `adhocTU` rhs - )) t - - -- expr -- - expr (GHC.HsVar n) = return ([n],[]) - - expr (GHC.OpApp e1 (GHC.L _ (GHC.HsVar n)) _ e2) = do - efed <- hsFreeAndDeclaredPNs' [e1,e2] - fd <- addFree n efed - return fd - - expr ((GHC.HsLam (GHC.MG matches _ _ _)) :: GHC.HsExpr GHC.Name) = - hsFreeAndDeclaredPNs' matches - - expr ((GHC.HsLet decls e) :: GHC.HsExpr GHC.Name) = - do - (df,dd) <- hsFreeAndDeclaredPNs' decls - (ef,_) <- hsFreeAndDeclaredPNs' e - return ((df `union` (ef \\ dd)),[]) - - expr (GHC.RecordCon (GHC.L _ n) _ e) = do - fd <- (hsFreeAndDeclaredPNs' e) - addFree n fd --Need Testing - - expr (GHC.EAsPat (GHC.L _ n) e) = do - fd <- (hsFreeAndDeclaredPNs' e) - addFree n fd - - expr _ = mzero - - - -- rhs -- - rhs ((GHC.GRHSs g ds) :: GHC.GRHSs GHC.Name (GHC.LHsExpr GHC.Name)) - = do (df,dd) <- hsFreeAndDeclaredPNs' g - (ef,ed) <- hsFreeAndDeclaredPNs' ds - return (df ++ ef, dd ++ ed) - - - -- pat -- - pattern (GHC.AsPat (GHC.L _ n) pat) = do - (f,d) <- hsFreeAndDeclaredPNs' pat - return (f,n:d) - - pattern (GHC.VarPat n) = return ([],[n]) - -- It seems all the GHC pattern match syntax elements end up - -- with GHC.VarPat - - pattern _ = mzero - -- pattern _ = return ([],[]) - - bindList (ds :: [GHC.LHsBind GHC.Name]) - =do (f,d) <- hsFreeAndDeclaredList ds - return (f\\d,d) - -- bindList _ = mzero - - -- match and patBind, same type-- - binds ((GHC.FunBind (GHC.L _ n) _ (GHC.MG matches _ _ _) _ _fvs _) :: GHC.HsBind GHC.Name) - = do - (pf,_pd) <- hsFreeAndDeclaredPNs' matches - - return (pf \\ [n] ,[n]) - - -- patBind -- - binds (GHC.PatBind pat prhs _ ds _) = - do - (pf,pd) <- hsFreeAndDeclaredPNs' pat - (rf,rd) <- hsFreeAndDeclaredPNs' prhs - return (pf `union` (rf \\pd),pd ++ GHC.uniqSetToList ds ++ rd) - - binds _ = mzero - - match ((GHC.Match _fn pats _mtype mrhs) :: GHC.Match GHC.Name (GHC.LHsExpr GHC.Name)) - = do - (pf,pd) <- hsFreeAndDeclaredPNs' pats - (rf,rd) <- hsFreeAndDeclaredPNs' mrhs - return ((pf `union` (rf \\ (pd `union` rd))),[]) - - -- stmts -- - stmts ((GHC.BindStmt pat expre _bindOp _failOp) :: GHC.Stmt GHC.Name (GHC.LHsExpr GHC.Name)) = do - -- TODO ++AZ++ : Not sure it is meaningful to pull - -- anything out of bindOp/failOp - (pf,pd) <- hsFreeAndDeclaredPNs' pat - (ef,_ed) <- hsFreeAndDeclaredPNs' expre - let sf1 = [] - return (pf `union` ef `union` (sf1\\pd),[]) -- pd) -- Check this - - stmts ((GHC.LetStmt binds') :: GHC.Stmt GHC.Name (GHC.LHsExpr GHC.Name)) = - hsFreeAndDeclaredPNs' binds' - - stmts _ = mzero - - - addFree :: GHC.Name -> ([GHC.Name],[GHC.Name]) - -> Maybe ([GHC.Name],[GHC.Name]) - addFree free (fr,de) = return ([free] `union` fr, de) - - hsFreeAndDeclaredList l=do fds<-mapM hsFreeAndDeclaredPNs' l - return (foldr union [] (map fst fds), - foldr union [] (map snd fds)) - - - --- |The same as `hsFreeAndDeclaredPNs` except that the returned --- variables are in the String format. -hsFreeAndDeclaredNameStrings::(SYB.Data t,GHC.Outputable t) - => t -> RefactGhc ([String],[String]) -hsFreeAndDeclaredNameStrings t = do - (f1,d1) <- hsFreeAndDeclaredPNs t - return ((nub.map showGhc) f1, (nub.map showGhc) d1) - - -hsFreeAndDeclaredPNs :: (SYB.Data t) => t -> RefactGhc ([GHC.Name],[GHC.Name]) -hsFreeAndDeclaredPNs t = do - -- logm $ "hsFreeAndDeclaredPNs:t=" ++ (showGhc t) - (FN f,DN d) <- hsFreeAndDeclaredGhc t - return (f,d) - --- --------------------------------------------------------------------- - --- | Collect the free and declared variables (in the GHC.Name format) --- in a given syntax phrase t. In the result, the first list contains --- the free variables, and the second list contains the declared --- variables. --- TODO: use GHC.NameSet instead of lists for FreeNames/DeclaredNames --- NOTE: The GHC fvs fields only carry non-GHC values, as they are --- used in the renaming process --- hsFreeAndDeclaredGhc :: (SYB.Data t,GHC.Outputable t) -hsFreeAndDeclaredGhc :: (SYB.Data t) - => t -> RefactGhc (FreeNames,DeclaredNames) -hsFreeAndDeclaredGhc t = do - -- logm $ "hsFreeAndDeclaredGhc:t=" ++ showGhc t - -- logm $ "hsFreeAndDeclaredGhc:t=" ++ SYB.showData SYB.Renamer 0 t - (FN f,DN d) <- res - let f' = nub f - let d' = nub d - -- logm $ "hsFreeAndDeclaredGhc:res=" ++ showGhc (f',d') - return (FN (f' \\ d'), DN d') - - where - res = (const err - `SYB.extQ` renamed - `SYB.extQ` lhsbind - `SYB.extQ` hsbind - `SYB.extQ` lhsbinds - `SYB.extQ` lhsbindslrs - `SYB.extQ` lhsbindslr - `SYB.extQ` hslocalbinds - `SYB.extQ` hsvalbinds - `SYB.extQ` lpats - `SYB.extQ` lpat - `SYB.extQ` bndrs - `SYB.extQ` ltydecls - `SYB.extQ` ltydecl - -- `SYB.extQ` lfaminstdecls - -- `SYB.extQ` lfaminstdecl - `SYB.extQ` lsigs - `SYB.extQ` lsig - `SYB.extQ` lexprs - `SYB.extQ` lexpr - `SYB.extQ` expr - `SYB.extQ` name - `SYB.extQ` lstmts - `SYB.extQ` lstmt - `SYB.extQ` lhstype - `SYB.extQ` hstype - `SYB.extQ` grhs_s - `SYB.extQ` grhs - `SYB.extQ` grhsss - `SYB.extQ` grhss - `SYB.extQ` matchgroup - `SYB.extQ` lmatches - `SYB.extQ` lmatch - `SYB.extQ` hsrecordbinds - `SYB.extQ` hsrecordbind - ) t - - -- ----------------------- - - renamed :: GHC.RenamedSource -> RefactGhc (FreeNames,DeclaredNames) - renamed (g,_i,_e,_d) = do - (FN gf,DN gd) <- hsFreeAndDeclaredGhc $ GHC.hs_valds g - let tds = concatMap getDeclaredTypes $ concatMap GHC.group_tyclds (GHC.hs_tyclds g) - logm $ "hsFreeAndDeclaredGhc.renamed:(gf,gd,tds)=" ++ showGhc (gf,gd,tds) - -- return $ gfds <> (FN [],DN tds) - return $ (FN (gf \\ tds), DN (gd++tds)) - - -- ----------------------- - - lhsbinds :: [GHC.LHsBind GHC.Name] -> RefactGhc (FreeNames,DeclaredNames) - lhsbinds bs = do - (FN f,DN d) <- recurseList bs - let r = (FN (f \\ d),DN d) - -- logm $ "hsFreeAndDeclaredGhc.hsbinds:r=" ++ (show r) - return r - - lhsbind :: GHC.LHsBind GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - lhsbind (GHC.L _ b) = hsFreeAndDeclaredGhc b - - -- ----------------------- - - hsbind :: GHC.HsBind GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - hsbind b@(GHC.FunBind _n _ (GHC.MG matches _ _ _) _ _ _) = do - -- logm $ "hsFreeAndDeclaredGhc.hsbind:b=" ++ (showGhc b) - let d = GHC.collectHsBindBinders b - (fp,_dp) <- hsFreeAndDeclaredGhc matches - -- logm $ "hsFreeAndDeclaredGhc.hsbind:(fp,_dp)=" ++ (show (fp,_dp)) - -- logm $ "hsFreeAndDeclaredGhc.hsbind:(d)=" ++ (showGhc (d)) - let r = (fp,DN []) <> (FN [],DN d) - -- logm $ "hsFreeAndDeclaredGhc.hsbind:r=" ++ (show (r)) - return $ r - hsbind b@(GHC.PatBind pa rhs _ _ _) = do - -- logm $ "hsFreeAndDeclaredGhc.hsbind.PatBind:b=" ++ (showGhc b) - let d = GHC.collectHsBindBinders b - (FN fr,DN _dr) <- hsFreeAndDeclaredGhc rhs - (fp,_) <- lpat pa - -- logm $ "hsFreeAndDeclaredGhc.hsbind.PatBind:f=" ++ (showGhc fr) - return $ (fp,DN []) <> (FN fr,DN d) - hsbind b = do - -- logm $ "hsFreeAndDeclaredGhc.hsbind:b=" ++ (showGhc b) - let d = GHC.collectHsBindBinders b - return (FN [],DN d) - - -- ----------------------- - - lhsbindslrs :: [GHC.LHsBindsLR GHC.Name GHC.Name] -> RefactGhc (FreeNames,DeclaredNames) - lhsbindslrs bs = recurseList bs - - -- ----------------------- - - lhsbindslr :: GHC.LHsBindsLR GHC.Name GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - lhsbindslr bs = do - hsFreeAndDeclaredGhc $ GHC.bagToList bs - - hslocalbinds :: GHC.HsLocalBinds GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - hslocalbinds (GHC.HsValBinds binds) = hsFreeAndDeclaredGhc binds - hslocalbinds (GHC.HsIPBinds binds) = hsFreeAndDeclaredGhc binds - hslocalbinds GHC.EmptyLocalBinds = return emptyFD - - - hsvalbinds :: GHC.HsValBinds GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - hsvalbinds (GHC.ValBindsIn binds sigs) = do - bfds <- hsFreeAndDeclaredGhc binds - sfds <- hsFreeAndDeclaredGhc sigs - return $ bfds <> sfds - hsvalbinds (GHC.ValBindsOut binds sigs) = do - bfds <- hsFreeAndDeclaredGhc $ map snd binds - sfds <- hsFreeAndDeclaredGhc sigs - return $ bfds <> sfds - - -- ----------------------- - - lpats :: [GHC.LPat GHC.Name] -> RefactGhc (FreeNames,DeclaredNames) - lpats xs = recurseList xs - - -- ----------------------- - - lpat :: GHC.LPat GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - lpat lp@(GHC.L _ p) = do - -- logm $ "hsFreeAndDeclaredGhc.lpat:" ++ (showGhc lp) - let - d = GHC.collectPatBinders lp - - (FN f,DN _dn) <- pat p - -- logm $ "hsFreeAndDeclaredGhc.lpat:(fn,dn)=" ++ (showGhc (fn,dn)) - return (FN f,DN d) - - pat :: GHC.Pat GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - pat (GHC.WildPat _) = return emptyFD - pat (GHC.VarPat n) = return (FN [],DN [n]) - pat (GHC.LazyPat (GHC.L _ p)) = pat p - pat (GHC.AsPat (GHC.L _ n) (GHC.L _ p)) = do - fd <- pat p - return $ (FN [], DN [n]) <> fd - pat (GHC.ParPat (GHC.L _ p)) = pat p - pat (GHC.BangPat (GHC.L _ p)) = pat p - pat (GHC.ListPat ps _ _) = do - fds <- mapM pat $ map GHC.unLoc ps - return $ mconcat fds - pat (GHC.TuplePat ps _ _) = do - fds <- mapM pat $ map GHC.unLoc ps - return $ mconcat fds - pat (GHC.PArrPat ps _) = do - fds <- mapM pat $ map GHC.unLoc ps - return $ mconcat fds - pat (GHC.ConPatIn (GHC.L _ n) det) = do - -- logm $ "hsFreeAndDeclaredGhc.pat.ConPatIn:details=" ++ (SYB.showData SYB.Renamer 0 det) - (FN f,DN _d) <- details det - return $ (FN [n],DN []) <> (FN [],DN f) - -- pat (GHC.ConPatOut ) - pat (GHC.ViewPat e (GHC.L _ p) _) = do - fde <- hsFreeAndDeclaredGhc e - fdp <- pat p - return $ fde <> fdp - -- pat (GHC.QuasiQuotePat _) - pat (GHC.LitPat _) = return emptyFD - pat (GHC.NPat _ _ _) = return emptyFD - pat (GHC.NPlusKPat (GHC.L _ n) _ _ _) = return (FN [],DN [n]) - pat _p@(GHC.SigPatIn (GHC.L _ p) b) = do - fdp <- pat p - (FN fb,DN _db) <- hsFreeAndDeclaredGhc b - return $ fdp <> (FN fb,DN []) - pat (GHC.SigPatOut (GHC.L _ p) _) = pat p - pat (GHC.CoPat _ p _) = pat p - - pat p = error $ "hsFreeAndDeclaredGhc.pat:unimplemented:" ++ (showGhc p) - - details :: GHC.HsConPatDetails GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - details (GHC.PrefixCon args) = do - -- logm $ "hsFreeAndDeclaredGhc.details:args=" ++ (showGhc args) - fds <- mapM pat $ map GHC.unLoc args - return $ mconcat fds - details (GHC.RecCon recf) = - recfields recf - details (GHC.InfixCon arg1 arg2) = do - fds <- mapM pat $ map GHC.unLoc [arg1,arg2] - return $ mconcat fds - - -- Note: this one applies to HsRecFields in LPats - recfields :: (GHC.HsRecFields GHC.Name (GHC.LPat GHC.Name)) -> RefactGhc (FreeNames,DeclaredNames) - recfields (GHC.HsRecFields fields _) = do - let args = map (\(GHC.L _ (GHC.HsRecField _ (GHC.L _ arg) _)) -> arg) fields - fds <- mapM pat args - return $ mconcat fds - - -- ----------------------- - - bndrs :: GHC.HsWithBndrs GHC.Name (GHC.LHsType GHC.Name) -> RefactGhc (FreeNames,DeclaredNames) - bndrs (GHC.HsWB (GHC.L _ thing) _ _ _) = do - (_ft,DN dt) <- hsFreeAndDeclaredGhc thing - -- logm $ "hsFreeAndDeclaredGhc.bndrs (_ft,dt)=" ++ show (_ft,DN dt) - return (FN dt,DN []) - -- ----------------------- - - ltydecls :: [GHC.LTyClDecl GHC.Name] -> RefactGhc (FreeNames,DeclaredNames) - ltydecls ds = do - fds <- mapM hsFreeAndDeclaredGhc ds - return $ mconcat fds - - ltydecl :: GHC.LTyClDecl GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - -- ltydecl (GHC.L _ (GHC.ForeignType (GHC.L _ n) _)) = return (FN [],DN [n]) - - -- ltydecl (GHC.L _ (GHC.TyFamily _ (GHC.L _ n) _bndrs _)) = return (FN [],DN [n]) - ltydecl (GHC.L _ (GHC.FamDecl fd)) = hsFreeAndDeclaredGhc fd - ltydecl (GHC.L _ (GHC.SynDecl (GHC.L _ n) _bndrs _rhs fvs)) - = return (FN (GHC.nameSetElems fvs),DN [n]) - ltydecl (GHC.L _ (GHC.DataDecl (GHC.L _ n) _bndrs defn fvs)) = do - let dds = map GHC.unLoc $ concatMap (GHC.con_names . GHC.unLoc) $ GHC.dd_cons defn - logm $ "hsFreeAndDeclaredGhc.ltydecl:(n,dds)" ++ showGhc (n,dds) - return (FN (GHC.nameSetElems fvs),DN (n:dds)) - ltydecl (GHC.L _ (GHC.ClassDecl _ctx (GHC.L _ n) _tyvars - _fds _sigs meths ats atds _docs fvs)) = do - -- logm $ "hsFreeAndDeclaredGhc.ltydecl.ClassDecl.meths" - (_,md) <- hsFreeAndDeclaredGhc meths - -- logm $ "hsFreeAndDeclaredGhc.ltydecl.ClassDecl.ats" - (_,ad) <- hsFreeAndDeclaredGhc ats - -- logm $ "hsFreeAndDeclaredGhc.ltydecl.ClassDecl.atds" - (_,atd) <- hsFreeAndDeclaredGhc atds - -- logm $ "hsFreeAndDeclaredGhc.ltydecl.ClassDecl.done" - return (FN (GHC.nameSetElems fvs),DN [n] <> md <> ad <> atd) -{- -FamDecl -- type/data family T :: *->* - tcdFam :: FamilyDecl name - -SynDecl -- type declaration - tcdLName :: Located name - tcdTyVars :: LHsTyVarBndrs name - tcdRhs :: LHsType name - tcdFVs :: PostRn name NameSet - -DataDecl - tcdLName :: Located name - tcdTyVars :: LHsTyVarBndrs name - tcdDataDefn :: HsDataDefn name - tcdFVs :: PostRn name NameSet - -ClassDecl - tcdCtxt :: LHsContext name - tcdLName :: Located name - tcdTyVars :: LHsTyVarBndrs name - tcdFDs :: [Located (FunDep (Located name))] - tcdSigs :: [LSig name] - tcdMeths :: LHsBinds name - tcdATs :: [LFamilyDecl name] - tcdATDefs :: [LTyFamDefltEqn name] - tcdDocs :: [LDocDecl] - tcdFVs :: PostRn name NameSet - - --} - - -- --------------------------------- -{- - lfaminstdecls :: [GHC.LFamInstDecl GHC.Name] -> RefactGhc (FreeNames,DeclaredNames) - lfaminstdecls ds = do - fds <- mapM hsFreeAndDeclaredGhc ds - return $ mconcat fds - - lfaminstdecl :: GHC.LFamInstDecl GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - lfaminstdecl _f@(GHC.L _ (GHC.FamInstDecl (GHC.L _ n) _pats _defn fvs)) = do - -- logm $ "hsFreeAndDeclaredGhc.lfaminstdecl:" ++ showGhc _f - return (FN (GHC.nameSetElems fvs), DN [n]) --} - -- ----------------------- - - lsigs :: [GHC.LSig GHC.Name] -> RefactGhc (FreeNames,DeclaredNames) - lsigs ss = do - fds <- mapM hsFreeAndDeclaredGhc ss - return $ mconcat fds - - -- ----------------------- - - lsig :: GHC.LSig GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - lsig (GHC.L _ (GHC.TypeSig ns typ _)) = do - tfds <- hsFreeAndDeclaredGhc typ - return $ (FN [],DN (map GHC.unLoc ns)) <> tfds - lsig (GHC.L _ (GHC.GenericSig n typ)) = do - tfds <- hsFreeAndDeclaredGhc typ - return $ (FN [],DN (map GHC.unLoc n)) <> tfds - lsig (GHC.L _ (GHC.IdSig _)) = return emptyFD - lsig (GHC.L _ (GHC.InlineSig _ _)) = return emptyFD - lsig (GHC.L _ (GHC.SpecSig n typ _)) = do - tfds <- hsFreeAndDeclaredGhc typ - return $ (FN [],DN [GHC.unLoc n]) <> tfds - lsig (GHC.L _ (GHC.SpecInstSig _ _)) = return emptyFD - lsig (GHC.L _ (GHC.FixSig _)) = return emptyFD - lsig (GHC.L _ (GHC.PatSynSig _ _ _ _ _)) = error "lsig: PatSynSig: toImplement" - lsig (GHC.L _ (GHC.MinimalSig _ _)) = error "lsig FixSig: toImplement" - - -- ----------------------- - - lexprs :: [GHC.LHsExpr GHC.Name] -> RefactGhc (FreeNames,DeclaredNames) - lexprs es = recurseList es - - -- ----------------------- - - lexpr :: GHC.LHsExpr GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - lexpr (GHC.L _ e) = hsFreeAndDeclaredGhc e - - -- ----------------------- - - expr :: GHC.HsExpr GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - expr ((GHC.HsVar n)) = return (FN [n],DN []) - - expr ((GHC.HsIPVar _)) = return emptyFD - - expr ((GHC.HsOverLit _)) = return emptyFD - - expr ((GHC.HsLit _)) = return emptyFD - - expr ((GHC.HsLam mg)) = hsFreeAndDeclaredGhc mg - - expr ((GHC.HsLamCase _ mg)) = hsFreeAndDeclaredGhc mg - - expr ((GHC.HsApp e1 e2)) = do - fde1 <- hsFreeAndDeclaredGhc e1 - fde2 <- hsFreeAndDeclaredGhc e2 - return $ fde1 <> fde2 - - expr ((GHC.OpApp e1 eop _fix e2)) = do - fde1 <- hsFreeAndDeclaredGhc e1 - fdeop <- hsFreeAndDeclaredGhc eop - fde2 <- hsFreeAndDeclaredGhc e2 - return $ fde1 <> fdeop <> fde2 - - expr ((GHC.NegApp e _)) = hsFreeAndDeclaredGhc e - - expr ((GHC.HsPar e)) = hsFreeAndDeclaredGhc e - - expr ((GHC.SectionL e1 e2)) = do - fde1 <- hsFreeAndDeclaredGhc e1 - fde2 <- hsFreeAndDeclaredGhc e2 - return $ fde1 <> fde2 - - expr ((GHC.SectionR e1 e2)) = do - fde1 <- hsFreeAndDeclaredGhc e1 - fde2 <- hsFreeAndDeclaredGhc e2 - return $ fde1 <> fde2 - - expr ((GHC.ExplicitTuple args _boxity)) = do - let argse = concatMap bb args - bb (GHC.L _ (GHC.Missing _)) = [] - bb (GHC.L _ (GHC.Present a)) = [a] - - fds <- mapM hsFreeAndDeclaredGhc argse - return $ mconcat fds - - expr ((GHC.HsCase e body)) = do - fdes <- hsFreeAndDeclaredGhc e - fdbs <- hsFreeAndDeclaredGhc body - return $ fdes <> fdbs - - expr ((GHC.HsIf _ms e1 e2 e3)) = do - fde1 <- hsFreeAndDeclaredGhc e1 - fde2 <- hsFreeAndDeclaredGhc e2 - fde3 <- hsFreeAndDeclaredGhc e3 - return $ fde1 <> fde2 <> fde3 - - expr ((GHC.HsMultiIf _typ rhs)) - = hsFreeAndDeclaredGhc rhs - - expr ((GHC.HsLet binds e)) = do - fdb <- hsFreeAndDeclaredGhc binds - fde <- hsFreeAndDeclaredGhc e - return $ fdb <> fde - - expr ((GHC.HsDo _ctx stmts _typ)) - = hsFreeAndDeclaredGhc stmts - - expr ((GHC.ExplicitList _ _ es)) - = hsFreeAndDeclaredGhc es - - expr ((GHC.ExplicitPArr _typ es)) - = hsFreeAndDeclaredGhc es - - expr ((GHC.RecordCon (GHC.L _ n) _typ binds)) = do - fdb <- hsFreeAndDeclaredGhc binds - return $ (FN [],DN [n]) <> fdb - - expr ((GHC.RecordUpd e1 binds _cons _typ1 _typ2)) = do - fde <- hsFreeAndDeclaredGhc e1 - fdb <- hsFreeAndDeclaredGhc binds - return $ fde <> fdb - - expr ((GHC.ExprWithTySig e _typ _)) - = hsFreeAndDeclaredGhc e - - expr ((GHC.ExprWithTySigOut e _typ)) - = hsFreeAndDeclaredGhc e - - expr ((GHC.ArithSeq _ _typ as)) = do - fds <- case as of - GHC.From e -> hsFreeAndDeclaredGhc e - GHC.FromThen e1 e2 -> recurseList [e1,e2] - GHC.FromTo e1 e2 -> recurseList [e1,e2] - GHC.FromThenTo e1 e2 e3 -> recurseList [e1,e2,e3] - return fds - - expr ((GHC.PArrSeq _typ as)) - = hsFreeAndDeclaredGhc as - - expr ((GHC.HsSCC _ _ e)) - = hsFreeAndDeclaredGhc e - - expr ((GHC.HsCoreAnn _ _ e)) - = hsFreeAndDeclaredGhc e - - expr ((GHC.HsBracket (GHC.ExpBr b))) - = hsFreeAndDeclaredGhc b - expr ((GHC.HsBracket (GHC.PatBr b))) - = hsFreeAndDeclaredGhc b - expr ((GHC.HsBracket (GHC.DecBrL b))) - = hsFreeAndDeclaredGhc b - expr ((GHC.HsBracket (GHC.DecBrG b))) - = hsFreeAndDeclaredGhc b - expr ((GHC.HsBracket (GHC.TypBr b))) - = hsFreeAndDeclaredGhc b - expr ((GHC.HsBracket (GHC.VarBr _ n))) - = return (FN [],DN [n]) - expr ((GHC.HsBracket (GHC.TExpBr _))) - = error "expr: GHC.HsBracket (GHC.TExpBr), to implement" - - expr ((GHC.HsRnBracketOut b _ps)) - = hsFreeAndDeclaredGhc b - - expr ((GHC.HsTcBracketOut b _ps)) - = hsFreeAndDeclaredGhc b - - expr ((GHC.HsSpliceE _ (GHC.HsSplice _ e))) - = hsFreeAndDeclaredGhc e - - expr ((GHC.HsQuasiQuoteE _q)) - = return emptyFD - - expr ((GHC.HsProc pa cmd)) = do - fdp <- hsFreeAndDeclaredGhc pa - fdc <- hsFreeAndDeclaredGhc cmd - return $ fdp <> fdc - - expr ((GHC.HsStatic e)) = hsFreeAndDeclaredGhc e - - expr ((GHC.HsArrApp e1 e2 _typ _atyp _)) = do - fd1 <- hsFreeAndDeclaredGhc e1 - fd2 <- hsFreeAndDeclaredGhc e2 - return $ fd1 <> fd2 - - expr ((GHC.HsArrForm e1 _fix cmds)) = do - fd1 <- hsFreeAndDeclaredGhc e1 - fdc <- hsFreeAndDeclaredGhc cmds - return $ fd1 <> fdc - - expr ((GHC.HsTick _ e)) - = hsFreeAndDeclaredGhc e - - expr ((GHC.HsBinTick _ _ e)) - = hsFreeAndDeclaredGhc e - - expr ((GHC.HsTickPragma _ _ e)) - = hsFreeAndDeclaredGhc e - - expr ((GHC.EWildPat)) = return emptyFD - - expr ((GHC.EAsPat (GHC.L _ n) e)) = do - fde <- hsFreeAndDeclaredGhc e - return $ (FN [],DN [n]) <> fde - - expr ((GHC.EViewPat e1 e2)) = do - fd1 <- hsFreeAndDeclaredGhc e1 - fd2 <- hsFreeAndDeclaredGhc e2 - return $ fd1 <> fd2 - - expr ((GHC.ELazyPat e)) - = hsFreeAndDeclaredGhc e - - expr ((GHC.HsType typ)) - = hsFreeAndDeclaredGhc typ - - expr ((GHC.HsWrap _wrap e)) - = hsFreeAndDeclaredGhc e - - expr ((GHC.HsUnboundVar _)) = return emptyFD - - -- ----------------------- - - name :: GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - name n = return (FN [],DN [n]) - - -- ----------------------- - lstmts :: [GHC.LStmt GHC.Name (GHC.LHsExpr GHC.Name)] -> RefactGhc (FreeNames,DeclaredNames) - lstmts ss = recurseList ss - - - lstmt :: GHC.LStmt GHC.Name (GHC.LHsExpr GHC.Name) -> RefactGhc (FreeNames,DeclaredNames) - lstmt (GHC.L _ (GHC.LastStmt e _)) = hsFreeAndDeclaredGhc e - lstmt (GHC.L _ (GHC.BindStmt pa e _ _)) = do - fdp <- hsFreeAndDeclaredGhc pa - fde <- hsFreeAndDeclaredGhc e - return (fdp <> fde) - lstmt (GHC.L _ (GHC.BodyStmt e _ _ _)) = hsFreeAndDeclaredGhc e - -- lstmt (GHC.L _ (GHC.ExprStmt e _ _ _)) = hsFreeAndDeclaredGhc e - - lstmt (GHC.L _ (GHC.LetStmt bs)) = hsFreeAndDeclaredGhc bs - lstmt (GHC.L _ (GHC.ParStmt ps _ _)) = hsFreeAndDeclaredGhc ps - lstmt (GHC.L _ (GHC.TransStmt _ stmts _ using mby _ _ _)) = do - fds <- hsFreeAndDeclaredGhc stmts - fdu <- hsFreeAndDeclaredGhc using - fdb <- case mby of - Nothing -> return emptyFD - Just e -> hsFreeAndDeclaredGhc e - return $ fds <> fdu <> fdb - lstmt (GHC.L _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _)) = hsFreeAndDeclaredGhc stmts - - -- ----------------------- - - lhstype :: GHC.LHsType GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - lhstype (GHC.L _ typ) = hstype typ - - -- ----------------------- - - hstype :: GHC.HsType GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - hstype (GHC.HsForAllTy _ _ _ _ typ) = hsFreeAndDeclaredGhc typ - hstype (GHC.HsTyVar n) = return (FN [],DN [n]) - hstype (GHC.HsAppTy t1 t2) = recurseList [t1,t2] - hstype (GHC.HsFunTy t1 t2) = recurseList [t1,t2] - hstype (GHC.HsListTy typ) = hsFreeAndDeclaredGhc typ - hstype (GHC.HsPArrTy typ) = hsFreeAndDeclaredGhc typ - hstype (GHC.HsTupleTy _ typs) = recurseList typs - hstype (GHC.HsOpTy t1 _ t2) = recurseList [t1,t2] - hstype (GHC.HsParTy typ) = hsFreeAndDeclaredGhc typ - hstype (GHC.HsIParamTy _ typ) = hsFreeAndDeclaredGhc typ - hstype (GHC.HsEqTy t1 t2) = recurseList [t1,t2] - hstype (GHC.HsKindSig t1 t2) = recurseList [t1,t2] - hstype (GHC.HsQuasiQuoteTy _) = return emptyFD - hstype (GHC.HsSpliceTy _ _) = return (FN [],DN []) - hstype (GHC.HsDocTy _ typ) = hsFreeAndDeclaredGhc typ - hstype (GHC.HsBangTy _ typ) = hsFreeAndDeclaredGhc typ - hstype (GHC.HsRecTy cons) = recurseList cons - hstype (GHC.HsCoreTy _) = return emptyFD - hstype (GHC.HsExplicitListTy _ typs) = recurseList typs - hstype (GHC.HsExplicitTupleTy _ typs) = recurseList typs - hstype (GHC.HsTyLit _) = return emptyFD - hstype (GHC.HsWrapTy _ typ) = hsFreeAndDeclaredGhc typ - hstype (GHC.HsWildcardTy) = error "To implement: hstype, HsWildcardTy" - hstype (GHC.HsNamedWildcardTy _) = error "To implement: HsNamedWildcardTy" - - - - -- ----------------------- - - grhs_s :: [GHC.LGRHS GHC.Name (GHC.LHsExpr GHC.Name)] -> RefactGhc (FreeNames,DeclaredNames) - grhs_s gs = recurseList gs - - -- ----------------------- - - grhs :: GHC.LGRHS GHC.Name (GHC.LHsExpr GHC.Name) -> RefactGhc (FreeNames,DeclaredNames) - grhs (GHC.L _ (GHC.GRHS stmts e)) = do - fds <- hsFreeAndDeclaredGhc stmts - fde <- hsFreeAndDeclaredGhc e - return $ fds <> fde - - -- ----------------------- - - grhsss :: [GHC.GRHSs GHC.Name (GHC.LHsExpr GHC.Name)] -> RefactGhc (FreeNames,DeclaredNames) - grhsss gs = recurseList gs - - -- ----------------------- - - grhss :: GHC.GRHSs GHC.Name (GHC.LHsExpr GHC.Name) -> RefactGhc (FreeNames,DeclaredNames) - grhss (GHC.GRHSs g binds) = do - (fg,_dg) <- hsFreeAndDeclaredGhc g - fdb <- hsFreeAndDeclaredGhc binds - return $ (fg,DN[]) <> fdb - - -- ----------------------- - - matchgroup :: GHC.MatchGroup GHC.Name (GHC.LHsExpr GHC.Name) -> RefactGhc (FreeNames,DeclaredNames) - matchgroup (GHC.MG matches _ _ _) = recurseList matches - - -- ----------------------- - - lmatches :: [GHC.LMatch GHC.Name (GHC.LHsExpr GHC.Name)] -> RefactGhc (FreeNames,DeclaredNames) - lmatches ms = recurseList ms - - -- ----------------------- - - lmatch :: GHC.LMatch GHC.Name (GHC.LHsExpr GHC.Name) -> RefactGhc (FreeNames,DeclaredNames) - lmatch (GHC.L _ _m@(GHC.Match _fn pats _ rhs)) = do - (fp,DN dp) <- recurseList pats - (FN fr,DN dr) <- hsFreeAndDeclaredGhc rhs - let r = (fp,DN []) <> (FN (fr \\ (dr ++ dp)), DN []) - return $ r - - -- ----------------------- - - hsrecordbinds :: (GHC.HsRecordBinds GHC.Name) -> RefactGhc (FreeNames,DeclaredNames) - hsrecordbinds (GHC.HsRecFields fields _) = recurseList fields - - hsrecordbind :: (GHC.HsRecField GHC.Name (GHC.LHsExpr GHC.Name)) -> RefactGhc (FreeNames,DeclaredNames) - hsrecordbind (GHC.HsRecField (GHC.L _ n) arg _) = do - fda <- hsFreeAndDeclaredGhc arg - return $ (FN [n],DN []) <> fda - - -- ----------------------- - - err = do - logm $ "hsFreeAndDeclaredGhc:not matched:" - ++ show (annGetConstr t) ++ ":" - ++ (SYB.showData SYB.Renamer 0 t) - return emptyFD - - -- --------------------------------- - - recurseList xs = do - fds <- mapM hsFreeAndDeclaredGhc xs - return $ mconcat fds - - --- --------------------------------------------------------------------- - --- |Get the names of all types declared in the given declaration --- getDeclaredTypesRdr :: GHC.LTyClDecl GHC.RdrName -> RefactGhc [GHC.Name] -getDeclaredTypesRdr :: GHC.LHsDecl GHC.RdrName -> RefactGhc [GHC.Name] -getDeclaredTypesRdr (GHC.L _ (GHC.TyClD decl)) = do - nm <- getRefactNameMap - case decl of - (GHC.FamDecl (GHC.FamilyDecl _ ln _ _)) -> return [rdrName2NamePure nm ln] - (GHC.SynDecl ln _ _ _) -> return [rdrName2NamePure nm ln] - (GHC.DataDecl ln _ defn _) -> do - let dds = concatMap (GHC.con_names . GHC.unLoc) $ GHC.dd_cons defn - let ddns = map (rdrName2NamePure nm) dds - return $ [rdrName2NamePure nm ln] ++ ddns - - (GHC.ClassDecl _ ln _vars _fds sigs meths ats _atdefs _ _fvs) -> do - -- msn <- getMsn meths - let msn = getDeclaredVarsRdr nm (map wrapDecl $ GHC.bagToList meths) - let fds = map (GHC.fdLName . GHC.unLoc) ats - fds' = map (rdrName2NamePure nm) fds - return $ nub $ [rdrName2NamePure nm ln] ++ ssn ++ msn ++ fds' -- ++ asn - where - getLSig :: GHC.LSig GHC.RdrName -> [GHC.Name] - getLSig (GHC.L _ (GHC.TypeSig ns _ _)) = map (rdrName2NamePure nm) ns - getLSig (GHC.L _ (GHC.GenericSig ns _)) = map (rdrName2NamePure nm) ns - getLSig (GHC.L _ (GHC.IdSig _n)) = [] - getLSig (GHC.L _ (GHC.InlineSig ln2 _)) = [rdrName2NamePure nm ln2] - getLSig (GHC.L _ (GHC.SpecSig ln2 _ _)) = [rdrName2NamePure nm ln2] - getLSig (GHC.L _ (GHC.SpecInstSig _ _)) = [] - getLSig (GHC.L _ (GHC.FixSig _)) = [] - getLSig (GHC.L _ (GHC.PatSynSig _ _ _ _ _)) = error "To implement: getLSig PatSynSig" - getLSig (GHC.L _ (GHC.MinimalSig _ _)) = error "To implement: getLSig PatSynSig" - - ssn = concatMap getLSig sigs - -- msn = getDeclaredVars $ hsBinds meths -getDeclaredTypesRdr _ = return [] - --- |Get the names of all types declared in the given declaration -getDeclaredTypes :: GHC.LTyClDecl GHC.Name -> [GHC.Name] -getDeclaredTypes (GHC.L _ (GHC.FamDecl (GHC.FamilyDecl _ (GHC.L _ n) _ _))) = [n] -getDeclaredTypes (GHC.L _ (GHC.SynDecl (GHC.L _ n) _ _ _)) = [n] -getDeclaredTypes (GHC.L _ (GHC.DataDecl (GHC.L _ n) _ defn _)) = n:dds - where dds = map GHC.unLoc $ concatMap (GHC.con_names . GHC.unLoc) $ GHC.dd_cons defn -getDeclaredTypes (GHC.L _ (GHC.ClassDecl _ (GHC.L _ n) _vars _fds sigs meths _ats _atdefs _ _fvs)) - = nub $ [n] ++ ssn ++ msn -- ++ asn - where - getLSig :: GHC.LSig GHC.Name -> [GHC.Name] - getLSig (GHC.L _ (GHC.TypeSig ns _ _)) = map GHC.unLoc ns - getLSig (GHC.L _ (GHC.GenericSig ns _)) = map GHC.unLoc ns - getLSig (GHC.L _ (GHC.IdSig _n)) = [] - getLSig (GHC.L _ (GHC.InlineSig (GHC.L _ n2) _)) = [n2] - getLSig (GHC.L _ (GHC.SpecSig (GHC.L _ n2) _ _)) = [n2] - getLSig (GHC.L _ (GHC.SpecInstSig _ _)) = [] - getLSig (GHC.L _ (GHC.FixSig _)) = [] - getLSig (GHC.L _ (GHC.PatSynSig _ _ _ _ _)) = error "To implement: getLSig PatSynSig" - getLSig (GHC.L _ (GHC.MinimalSig _ _)) = error "To implement: getLSig PatSynSig" - - ssn = concatMap getLSig sigs - msn = getDeclaredVars $ hsBinds meths - --- --------------------------------------------------------------------- - --- | Return the list of identifiers (in PName format) defined by a --- function\/pattern binding. -definedPNs :: GHC.LHsBind GHC.Name -> [GHC.Name] -definedPNs (GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ _ _)) = [pname] -definedPNs (GHC.L _ (GHC.PatBind p _rhs _ty _fvs _)) = (hsNamess p) -definedPNs (GHC.L _ (GHC.VarBind pname _rhs _)) = [pname] - --- AbsBinds and ValBinds will never occur in ParsedSource -definedPNs _ = [] - -definedPNsRdr :: GHC.LHsDecl GHC.RdrName -> [GHC.Located GHC.RdrName] -definedPNsRdr (GHC.L _ (GHC.ValD (GHC.FunBind pname _ _ _ _ _))) = [pname] -definedPNsRdr (GHC.L _ (GHC.ValD (GHC.PatBind p _rhs _ty _fvs _))) = (hsNamessRdr p) --- VarBind will never occur in ParsedSource --- TODO: what about GHC.AbsBinds? -definedPNsRdr _ = [] - --- --------------------------------------------------------------------- - -definedNamesRdr :: NameMap -> GHC.LHsDecl GHC.RdrName -> [GHC.Name] -definedNamesRdr nameMap bind = map (rdrName2NamePure nameMap) (definedPNsRdr bind) - --- --------------------------------------------------------------------- - --- |Find those declarations(function\/pattern binding) which define --- the specified GHC.Names. incTypeSig indicates whether the --- corresponding type signature will be included. -definingDeclsRdrNames:: - NameMap - ->[GHC.Name] -- ^ The specified identifiers. - ->[GHC.LHsDecl GHC.RdrName] -- ^ A collection of declarations. - ->Bool -- ^ True means to include the type signature. - ->Bool -- ^ True means to look at the local declarations as well. - ->[GHC.LHsDecl GHC.RdrName] -- ^ The result. -definingDeclsRdrNames nameMap pns ds _incTypeSig recursive = concatMap defining ds --- ++AZ++:TODO: now we are processing decls again, reinstate incTypeSig function - where - defining decl - = if recursive - then SYB.everythingStaged SYB.Parser (++) [] ([] `SYB.mkQ` definesDecl `SYB.extQ` definesBind) decl - else definesDecl decl - where - definesDecl :: (GHC.LHsDecl GHC.RdrName) -> [GHC.LHsDecl GHC.RdrName] - definesDecl decl'@(GHC.L _ (GHC.ValD (GHC.FunBind _ _ _ _ _ _))) - | any (\n -> definesDeclRdr nameMap n decl') pns = [decl'] - - definesDecl decl'@(GHC.L _l (GHC.ValD (GHC.PatBind _p _rhs _ty _fvs _))) - | any (\n -> definesDeclRdr nameMap n decl') pns = [decl'] - - definesDecl _ = [] - - definesBind :: (GHC.LHsBind GHC.RdrName) -> [GHC.LHsDecl GHC.RdrName] - definesBind (GHC.L l b) = definesDecl (GHC.L l (GHC.ValD b)) - --- --------------------------------------------------------------------- - --- |Find those declarations(function\/pattern binding) which define --- the specified GHC.Names. incTypeSig indicates whether the corresponding type --- signature will be included. -definingDeclsRdrNames' :: (SYB.Data t) - => NameMap - -> [GHC.Name] -- ^ The specified identifiers. - -> t -- ^ A collection of declarations. - -> [GHC.LHsDecl GHC.RdrName] -- ^ The result. -definingDeclsRdrNames' nameMap pns ds = defining ds - where - defining decl - = SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` defines' `SYB.extQ` definesBind) decl - where - defines' :: (GHC.LHsDecl GHC.RdrName) -> [GHC.LHsDecl GHC.RdrName] - defines' decl'@(GHC.L _ (GHC.ValD (GHC.FunBind _ _ _ _ _ _))) - | any (\n -> definesDeclRdr nameMap n decl') pns = [decl'] - - defines' decl'@(GHC.L _l (GHC.ValD (GHC.PatBind _p _rhs _ty _fvs _))) - | any (\n -> definesDeclRdr nameMap n decl') pns = [decl'] - - defines' _ = [] - - definesBind :: (GHC.LHsBind GHC.RdrName) -> [GHC.LHsDecl GHC.RdrName] - definesBind (GHC.L l b) = defines' (GHC.L l (GHC.ValD b)) - --- --------------------------------------------------------------------- - --- |Find those declarations(function\/pattern binding) which define --- the specified GHC.Names. incTypeSig indicates whether the --- corresponding type signature will be included. -definingDeclsNames:: - [GHC.Name] -- ^ The specified identifiers. - ->[GHC.LHsBind GHC.Name] -- ^ A collection of declarations. - ->Bool -- ^ True means to include the type signature. - ->Bool -- ^ True means to look at the local declarations as well. - ->[GHC.LHsBind GHC.Name] -- ^ The result. -definingDeclsNames pns ds _incTypeSig recursive = concatMap defining ds - where - defining decl - = if recursive - then SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` defines') decl - else defines' decl - where - defines' :: (GHC.LHsBind GHC.Name) -> [GHC.LHsBind GHC.Name] - defines' decl'@(GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ _ _)) - |isJust (find (==(pname)) pns) = [decl'] - - defines' decl'@(GHC.L _l (GHC.PatBind p _rhs _ty _fvs _)) - |(hsNamess p) `intersect` pns /= [] = [decl'] - - defines' _ = [] - --- |Find those declarations(function\/pattern binding) which define --- the specified GHC.Names. incTypeSig indicates whether the --- corresponding type signature will be included. -definingDeclsNames':: (SYB.Data t) - => [GHC.Name] -- ^ The specified identifiers. - -> t -- ^ A collection of declarations. - ->[GHC.LHsBind GHC.Name] -- ^ The result. -definingDeclsNames' pns t = defining t - where - defining decl - = SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` defines') decl - where - defines' :: (GHC.LHsBind GHC.Name) -> [GHC.LHsBind GHC.Name] - defines' decl'@(GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ _ _)) - |isJust (find (==(pname)) pns) = [decl'] - - defines' decl'@(GHC.L _l (GHC.PatBind p _rhs _ty _fvs _)) - |(hsNamess p) `intersect` pns /= [] = [decl'] - - defines' _ = [] - --- --------------------------------------------------------------------- - --- |Find those type signatures for the specified GHC.Names. -definingSigsNames :: (SYB.Data t) => - [GHC.Name] -- ^ The specified identifiers. - ->t -- ^ A collection of declarations. - ->[GHC.LSig GHC.Name] -- ^ The result. -definingSigsNames pns ds = def ds - where - def decl - = SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` inSig) decl - where - inSig :: (GHC.LSig GHC.Name) -> [GHC.LSig GHC.Name] - inSig (GHC.L l (GHC.TypeSig ns t p)) - | defines' ns /= [] = [(GHC.L l (GHC.TypeSig (defines' ns) t p))] - inSig _ = [] - - defines' (p::[GHC.Located GHC.Name]) - = filter (\(GHC.L _ n) -> n `elem` pns) p - --- --------------------------------------------------------------------- - --- |Find those type signatures for the specified GHC.Names. -definingSigsRdrNames :: (SYB.Data t) => - NameMap - ->[GHC.Name] -- ^ The specified identifiers. - ->t -- ^ A collection of declarations. - ->[GHC.LSig GHC.RdrName] -- ^ The result. -definingSigsRdrNames nameMap pns ds = def ds - where - def decl - -- = SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` inSig) decl - = SYB.everything (++) ([] `SYB.mkQ` inSig `SYB.extQ` inSigDecl) decl - where - inSigDecl :: GHC.LHsDecl GHC.RdrName -> [GHC.LSig GHC.RdrName] - inSigDecl (GHC.L l (GHC.SigD s)) = inSig (GHC.L l s) - inSigDecl _ = [] - - inSig :: (GHC.LSig GHC.RdrName) -> [GHC.LSig GHC.RdrName] - inSig (GHC.L l (GHC.TypeSig ns t p)) - | defines' ns /= [] = [(GHC.L l (GHC.TypeSig (defines' ns) t p))] - inSig _ = [] - - defines' :: [GHC.Located GHC.RdrName] -> [GHC.Located GHC.RdrName] - defines' p - -- = filter (\(GHC.L _ n) -> n `elem` pns) p - = let - isDefined :: GHC.Located GHC.RdrName -> [GHC.Located GHC.RdrName] - isDefined ln = if (rdrName2NamePure nameMap ln) `elem` pns - then [ln] - else [] - in concatMap isDefined p - --- --------------------------------------------------------------------- - --- |Find those declarations which define the specified GHC.Names. -definingTyClDeclsNames:: (SYB.Data t) - => [GHC.Name] -- ^ The specified identifiers. - -> t -- ^ A collection of declarations. - ->[GHC.LTyClDecl GHC.Name] -- ^ The result. -definingTyClDeclsNames pns t = defining t - where - defining decl - = SYB.everythingStaged SYB.Renamer (++) [] - ([] `SYB.mkQ` defines') decl - where - defines' :: (GHC.LTyClDecl GHC.Name) -> [GHC.LTyClDecl GHC.Name] - defines' decl'@(GHC.L _ (GHC.FamDecl (GHC.FamilyDecl _ (GHC.L _ pname) _ _))) - |isJust (find (==(pname)) pns) = [decl'] - | otherwise = [] - - defines' decl'@(GHC.L _ (GHC.SynDecl (GHC.L _ pname) _ _ _)) - |isJust (find (==(pname)) pns) = [decl'] - | otherwise = [] - - defines' decl'@(GHC.L _ (GHC.DataDecl (GHC.L _ pname) _ _ _)) - |isJust (find (==(pname)) pns) = [decl'] - | otherwise = [] - - defines' decl'@(GHC.L _ (GHC.ClassDecl _ (GHC.L _ pname) _ _ _ _ _ _ _ _)) - |isJust (find (==(pname)) pns) = [decl'] - | otherwise = [] - --- --------------------------------------------------------------------- - --- | Return True if the function\/pattern binding defines the --- specified identifier. -defines:: GHC.Name -> GHC.LHsBind GHC.Name -> Bool -defines n (GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ _ _)) - = GHC.nameUnique pname == GHC.nameUnique n -defines n (GHC.L _ (GHC.PatBind p _rhs _ty _fvs _)) - = elem (GHC.nameUnique n) (map GHC.nameUnique $ hsNamess p) -defines _ _= False - --- | Return True if the function\/pattern binding defines the --- specified identifier. -definesRdr :: NameMap -> GHC.Name -> GHC.LHsBind GHC.RdrName -> Bool -definesRdr nameMap nin (GHC.L _ (GHC.FunBind (GHC.L ln _pname) _ _ _ _ _)) = - case Map.lookup ln nameMap of - Nothing -> False - Just n -> GHC.nameUnique n == GHC.nameUnique nin -definesRdr nameMap n (GHC.L _ (GHC.PatBind p _rhs _ty _fvs _)) = - elem n (map (rdrName2NamePure nameMap) (hsNamessRdr p)) -definesRdr _ _ _= False - --- |Unwraps a LHsDecl and calls definesRdr on the result if a HsBind -definesDeclRdr :: NameMap -> GHC.Name -> GHC.LHsDecl GHC.RdrName -> Bool -definesDeclRdr nameMap nin (GHC.L l (GHC.ValD d)) = definesRdr nameMap nin (GHC.L l d) -definesDeclRdr _ _ _ = False - - -definesP::PName -> HsDeclP ->Bool -definesP pn (GHC.L _ (GHC.ValD (GHC.FunBind (GHC.L _ pname) _ _ _ _ _))) - = PN pname == pn -definesP pn (GHC.L _ (GHC.ValD (GHC.PatBind p _rhs _ty _fvs _))) - = elem pn (hsPNs p) -definesP _ _= False - --- --------------------------------------------------------------------- - --- | Return True if the declaration defines the type signature of the --- specified identifier. -definesTypeSig :: GHC.Name -> GHC.LSig GHC.Name -> Bool -definesTypeSig pn (GHC.L _ (GHC.TypeSig names _typ _)) = elem (GHC.nameUnique pn) $ map (\(GHC.L _ n)->GHC.nameUnique n) names -definesTypeSig _ _ = False - --- | Return True if the declaration defines the type signature of the --- specified identifier. -definesTypeSigRdr :: NameMap -> GHC.Name -> GHC.Sig GHC.RdrName -> Bool -definesTypeSigRdr nameMap pn (GHC.TypeSig names _typ _) - = elem (GHC.nameUnique pn) (map (GHC.nameUnique . rdrName2NamePure nameMap) names) --- definesTypeSigRdr _ _ _ = False -definesTypeSigRdr _ _ x = error $ "definesTypeSigRdr : got " ++ SYB.showData SYB.Parser 0 x - --- |Unwraps a LHsDecl and calls definesRdr on the result if a Sig -definesSigDRdr :: NameMap -> GHC.Name -> GHC.LHsDecl GHC.RdrName -> Bool -definesSigDRdr nameMap nin (GHC.L _ (GHC.SigD d)) = definesTypeSigRdr nameMap nin d -definesSigDRdr _ _ _ = False - --- --------------------------------------------------------------------- - --- |Find all Located Names in the given Syntax phrase. -allNames::(SYB.Data t) - =>t -- ^ The syntax phrase - ->[GHC.Located GHC.Name] -- ^ The result -allNames t - = res - where - res = SYB.everythingStaged SYB.Parser (++) [] - ([] `SYB.mkQ` worker `SYB.extQ` workerBind `SYB.extQ` workerExpr) t - - worker (pnt :: (GHC.Located GHC.Name)) - = [pnt] - -- worker _ = [] - - workerBind (GHC.L l (GHC.VarPat name) :: (GHC.Located (GHC.Pat GHC.Name))) - = [(GHC.L l name)] - workerBind _ = [] - - workerExpr ((GHC.L l (GHC.HsVar name)) :: (GHC.Located (GHC.HsExpr GHC.Name))) - = [(GHC.L l name)] - workerExpr _ = [] - - - --- --------------------------------------------------------------------- - --- |Get all the names in the given syntax element -hsNamess :: (SYB.Data t) => t -> [GHC.Name] -hsNamess t = nub $ concat res - where - res = SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` inName) t - - inName (pname :: GHC.Name) = return [pname] - --- |Get all the names in the given syntax element -hsNamessRdr :: (SYB.Data t) => t -> [GHC.Located GHC.RdrName] -hsNamessRdr t = nub $ fromMaybe [] r - where - r = (SYB.everythingStaged SYB.Parser mappend mempty (inName) t) - - checker :: GHC.Located GHC.RdrName -> Maybe [GHC.Located GHC.RdrName] - checker x = Just [x] - - inName :: (SYB.Typeable a) => a -> Maybe [GHC.Located GHC.RdrName] - inName = nameSybQuery checker - --- --------------------------------------------------------------------- - - -getDeclaredVarsRdr :: NameMap -> [GHC.LHsDecl GHC.RdrName] -> [GHC.Name] -getDeclaredVarsRdr nm bs = concatMap vars bs - where - vars :: (GHC.LHsDecl GHC.RdrName) -> [GHC.Name] - vars (GHC.L _ (GHC.ValD (GHC.FunBind ln _ _ _ _fvs _))) = [rdrName2NamePure nm ln] - vars (GHC.L _ (GHC.ValD (GHC.PatBind p _rhs _ty _fvs _))) = (hsNamess p) - vars _ = [] - -getDeclaredVars :: [GHC.LHsBind GHC.Name] -> [GHC.Name] -getDeclaredVars bs = concatMap vars bs - where - vars :: (GHC.LHsBind GHC.Name) -> [GHC.Name] - vars (GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ _fvs _)) = [pname] - vars (GHC.L _ (GHC.PatBind p _rhs _ty _fvs _)) = (hsNamess p) - vars _ = [] - --- --------------------------------------------------------------------- --- |Experiment with GHC fvs stuff -getFvs :: [GHC.LHsBind GHC.Name] -> [([GHC.Name], GHC.NameSet)] -getFvs bs = concatMap binds bs - where - binds :: (GHC.LHsBind GHC.Name) -> [([GHC.Name],GHC.NameSet)] - binds (GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ fvs _)) = [([pname], fvs)] - binds (GHC.L _ (GHC.PatBind p _rhs _ty fvs _)) = [((hsNamess p),fvs)] - binds _ = [] - -getFreeVars :: [GHC.LHsBind GHC.Name] -> [GHC.Name] -getFreeVars bs = concatMap binds bs - where - binds :: (GHC.LHsBind GHC.Name) -> [GHC.Name] - binds (GHC.L _ (GHC.FunBind (GHC.L _ _pname) _ _ _ fvs _)) = (GHC.nameSetElems fvs) - binds (GHC.L _ (GHC.PatBind _p _rhs _ty fvs _)) = (GHC.nameSetElems fvs) - binds _ = [] - ------------------------------------------------------------------------- - --- | Given syntax phrases e and t, if e occurs in t, then return those --- variables which are declared in t and accessible to e, otherwise --- return []. -hsVisiblePNs :: (FindEntity e,HsValBinds t GHC.Name,GHC.Outputable e) - => e -> t -> RefactGhc [GHC.Name] -hsVisiblePNs e t = do - (DN d) <- hsVisibleDs e t - return d - --------------------------------------------------------------------------------- --- | Same as `hsVisiblePNs' except that the returned identifiers are --- in String format. -hsVisibleNames:: (FindEntity t1,HsValBinds t2 GHC.Name,GHC.Outputable t1) - => t1 -> t2 -> RefactGhc [String] -hsVisibleNames e t = do - d <- hsVisiblePNs e t - return ((nub . map showGhc) d) - --------------------------------------------------------------------------------- --- | Same as `hsVisiblePNs' except that the returned identifiers are --- in String format. -hsVisibleNamesRdr:: (FindEntity t1,SYB.Data t2,GHC.Outputable t1) - => t1 -> t2 -> RefactGhc [String] -hsVisibleNamesRdr e t = do - nm <- getRefactNameMap - d <- hsVisiblePNsRdr nm e t - return ((nub . map showGhc) d) - ------------------------------------------------------------------------- - --- | Given syntax phrases e and t, if e occurs in t, then return those --- variables which are declared in t and accessible to e, otherwise --- return []. -hsVisiblePNsRdr :: (FindEntity e,SYB.Data t,GHC.Outputable e) - => NameMap -> e -> t -> RefactGhc [GHC.Name] -hsVisiblePNsRdr nm e t = do - (DN d) <- hsVisibleDsRdr nm e t - return d - ------------------------------------------------------------------------- - --- | Given syntax phrases e and t, if e occurs in t, then return those --- variables which are declared in t and accessible to e, otherwise --- return []. -hsVisibleDsRdr :: (FindEntity e, GHC.Outputable e,SYB.Data t) - => NameMap -> e -> t -> RefactGhc DeclaredNames -hsVisibleDsRdr nm e t = do - -- logm $ "hsVisibleDsRdr:(e,t)=" ++ (SYB.showData SYB.Renamer 0 (e,t)) - (DN d) <- res - return (DN (nub d)) - where - -- TODO: this is effectively a recursive descent approach, where - -- each syntax element processor knows exactly what it needs - -- in terms of sub-elements. Hence as an optimisation, - -- consider calling the relevent element directly, instead - -- of looping back into the main function. - res = (const err -- (DN []) - `SYB.extQ` parsed - `SYB.extQ` valbinds - `SYB.extQ` lhsdecls - `SYB.extQ` lhsdecl - `SYB.extQ` lhsbindslr - `SYB.extQ` hsbinds - `SYB.extQ` hsbind - `SYB.extQ` hslocalbinds - `SYB.extQ` lmatch - `SYB.extQ` grhss - `SYB.extQ` lgrhs - `SYB.extQ` lexpr - `SYB.extQ` tyclgroups - `SYB.extQ` tyclgroup - `SYB.extQ` tycldeclss - `SYB.extQ` tycldecls - `SYB.extQ` tycldecl - `SYB.extQ` instdecls - `SYB.extQ` instdecl - `SYB.extQ` lhstype - `SYB.extQ` lsigs - `SYB.extQ` lsig - ) t - - -- err2 = error $ "hsVisibleDsRdr:err2:no match for:" ++ (SYB.showData SYB.Renamer 0 t) - - parsed :: GHC.ParsedSource -> RefactGhc DeclaredNames - parsed p - | findEntity e p = do - -- dfds <- mapM (hsVisibleDsRdr nm e) $ GHC.hsmodDecls $ GHC.unLoc p - logm $ "hsVisibleDsRdr parsedSource:decls starting" - dfds <- mapM (declFun ( hsVisibleDsRdr nm e) ) $ GHC.hsmodDecls $ GHC.unLoc p - logm $ "hsVisibleDsRdr parsedSource:decls done" - return $ mconcat dfds - parsed _ = return (DN []) - - valbinds :: (GHC.HsValBindsLR GHC.RdrName GHC.RdrName) -> RefactGhc DeclaredNames - valbinds vb@(GHC.ValBindsIn bindsBag sigs) - | findEntity e vb = do - fdsb <- mapM (hsVisibleDsRdr nm e) $ hsBinds bindsBag - fdss <- mapM (hsVisibleDsRdr nm e) sigs - return $ mconcat fdss <> mconcat fdsb - valbinds vb@(GHC.ValBindsOut _binds _sigs) - | findEntity e vb = do - logm $ "hsVisibleDsRdr valbinds:ValBindsOut:impossible for RdrName" - return (DN []) - - valbinds _ = do - logm $ "hsVisibleDsRdr nm.valbinds:not matched" - return (DN []) - - lhsdecls :: [GHC.LHsDecl GHC.RdrName] -> RefactGhc DeclaredNames - lhsdecls ds - | findEntity e ds = do - dfds <- mapM (declFun ( hsVisibleDsRdr nm e) ) ds - return $ mconcat dfds - lhsdecls _ = return (DN []) - - lhsdecl :: GHC.LHsDecl GHC.RdrName -> RefactGhc DeclaredNames - lhsdecl (GHC.L l dd) = do - logm $ "hsVisibleDsRdr.lhsdecl" - case dd of - GHC.TyClD d -> hsVisibleDsRdr nm e (GHC.L l d) - GHC.InstD d -> hsVisibleDsRdr nm e (GHC.L l d) - GHC.DerivD d -> hsVisibleDsRdr nm e (GHC.L l d) - GHC.ValD d -> hsVisibleDsRdr nm e (GHC.L l d) - GHC.SigD d -> hsVisibleDsRdr nm e (GHC.L l d) - GHC.DefD d -> hsVisibleDsRdr nm e (GHC.L l d) - GHC.ForD d -> hsVisibleDsRdr nm e (GHC.L l d) - GHC.WarningD d -> hsVisibleDsRdr nm e (GHC.L l d) - GHC.AnnD d -> hsVisibleDsRdr nm e (GHC.L l d) - GHC.RuleD d -> hsVisibleDsRdr nm e (GHC.L l d) - GHC.VectD d -> hsVisibleDsRdr nm e (GHC.L l d) - GHC.SpliceD d -> hsVisibleDsRdr nm e (GHC.L l d) - GHC.DocD d -> hsVisibleDsRdr nm e (GHC.L l d) - GHC.RoleAnnotD d -> hsVisibleDsRdr nm e (GHC.L l d) -#if __GLASGOW_HASKELL__ < 711 - GHC.QuasiQuoteD d -> hsVisibleDsRdr nm e (GHC.L l d) -#endif - - lhsbindslr :: GHC.LHsBindsLR GHC.RdrName GHC.RdrName -> RefactGhc DeclaredNames - lhsbindslr bs = do - fds <- mapM (hsVisibleDsRdr nm e) $ GHC.bagToList bs - return $ mconcat fds - - hsbinds :: [GHC.LHsBind GHC.RdrName] -> RefactGhc DeclaredNames - hsbinds ds - | findEntity e ds = do - fds <- mapM (hsVisibleDsRdr nm e) ds - return $ mconcat fds - hsbinds _ = return (DN []) - - hsbind :: (GHC.LHsBind GHC.RdrName) -> RefactGhc DeclaredNames - hsbind ((GHC.L _ (GHC.FunBind _n _ (GHC.MG matches _ _ _) _ _ _))) - | findEntity e matches = do - fds <- mapM (hsVisibleDsRdr nm e) matches - logm $ "hsVisibleDsRdr.hsbind:fds=" ++ show fds - return $ mconcat fds - hsbind _ = do - logm $ "hsVisibleDsRdr.hsbind:miss" - return (DN []) - - hslocalbinds :: (GHC.HsLocalBinds GHC.RdrName) -> RefactGhc DeclaredNames - hslocalbinds (GHC.HsValBinds binds) - | findEntity e binds = hsVisibleDsRdr nm e binds - hslocalbinds (GHC.HsIPBinds binds) - | findEntity e binds = hsVisibleDsRdr nm e binds - hslocalbinds (GHC.EmptyLocalBinds) = return (DN []) - hslocalbinds _ = return (DN []) - - lmatch :: (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) -> RefactGhc DeclaredNames - lmatch (GHC.L _ (GHC.Match _fn pats _mtyp rhs)) - | findEntity e pats = do - logm $ "hsVisibleDsRdr nm.lmatch:in pats=" - return (DN []) -- TODO: extend this - | findEntity e rhs = do - logm $ "hsVisibleDsRdr nm.lmatch:doing rhs" - let (pf,pd) = hsFreeAndDeclaredRdr nm pats - logm $ "hsVisibleDsRdr nm.lmatch:(pf,pd)=" ++ (show (pf,pd)) - ( rd) <- hsVisibleDsRdr nm e rhs - return (pd <> rd) - lmatch _ =return (DN []) - - grhss :: (GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName)) -> RefactGhc DeclaredNames - grhss (GHC.GRHSs guardedRhss lstmts) - | findEntity e guardedRhss = do - logm "hsVisibleDsRdr nm.grhss:about to do grhss" - fds <- mapM (hsVisibleDsRdr nm e) guardedRhss - logm "hsVisibleDsRdr nm.grhss:grhss done" - return $ mconcat fds - | findEntity e lstmts = do - logm "hsVisibleDsRdr nm.grhss:about to do lstmts" - hsVisibleDsRdr nm e lstmts - grhss _ = return (DN []) - - lgrhs :: GHC.LGRHS GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> RefactGhc DeclaredNames - lgrhs (GHC.L _ (GHC.GRHS guards ex)) - | findEntity e guards = logm "hsVisibleDsRdr nm.lgrhs.guards" >> hsVisibleDsRdr nm e guards - | findEntity e ex = logm "hsVisibleDsRdr nm.lgrhs.ex" >> hsVisibleDsRdr nm e ex - lgrhs _ = return (DN []) - - - lexpr :: GHC.LHsExpr GHC.RdrName -> RefactGhc DeclaredNames - lexpr (GHC.L l (GHC.HsVar n)) - | findEntity e n = do - logm $ "hsVisibleDsRdr.lexpr.HsVar entity found" - return (DN [rdrName2NamePure nm (GHC.L l n)]) - lexpr (GHC.L _ (GHC.HsLet lbinds expr)) - | findEntity e lbinds || findEntity e expr = do - logm $ "hsVisibleDsRdr.lexpr.HsLet entity found" - let (_,lds) = hsFreeAndDeclaredRdr nm lbinds - let (_,eds) = hsFreeAndDeclaredRdr nm expr - return $ lds <> eds - - lexpr expr - | findEntity e expr = do - logm $ "hsVisibleDsRdr nm.lexpr.(e,expr):" ++ (showGhc (e,expr)) - let (FN efs,_) = hsFreeAndDeclaredRdr nm expr - let (FN _eefs,DN eeds) = hsFreeAndDeclaredRdr nm e - logm $ "hsVisibleDsRdr nm.lexpr done" - -- return (DN e1fs <> DN eofs <> DN e2fs) - return (DN (efs \\ eeds)) - - lexpr x = do - logm $ "hsVisibleDsRdr.lexpr:miss for:" ++ SYB.showData SYB.Parser 0 x - return (DN []) - - -- --------------------------------- - - tyclgroups :: [GHC.TyClGroup GHC.RdrName] -> RefactGhc DeclaredNames - tyclgroups tgrps - | findEntity e tgrps = do - fds <- mapM (hsVisibleDsRdr nm e) tgrps - return $ mconcat fds - tyclgroups _ = return (DN []) - - tyclgroup :: GHC.TyClGroup GHC.RdrName -> RefactGhc DeclaredNames - tyclgroup (GHC.TyClGroup tyclds _roles) - | findEntity e tyclds = do - fds <- mapM (hsVisibleDsRdr nm e) tyclds - return $ mconcat fds - tyclgroup _ = return (DN []) - - tycldeclss :: [[GHC.LTyClDecl GHC.RdrName]] -> RefactGhc DeclaredNames - tycldeclss tcds - | findEntity e tcds = do - fds <- mapM (hsVisibleDsRdr nm e) tcds - return $ mconcat fds - tycldeclss _ = return (DN []) - - tycldecls :: [GHC.LTyClDecl GHC.RdrName] -> RefactGhc DeclaredNames - tycldecls tcds - | findEntity e tcds = do - logm $ "hsVisibleDsRdr.tycldecls" - fds <- mapM (hsVisibleDsRdr nm e) tcds - logm $ "hsVisibleDsRdr.tycldecls done" - return $ mconcat fds - tycldecls _ = return (DN []) - - tycldecl :: GHC.LTyClDecl GHC.RdrName -> RefactGhc DeclaredNames - tycldecl tcd - | findEntity e tcd = do - logm $ "hsVisibleDsRdr.tycldecl" - let (_,ds) = hsFreeAndDeclaredRdr nm tcd - logm $ "hsVisibleDsRdr.tycldecl done" - return ds - tycldecl _ = return (DN []) - - -- --------------------------------- - - instdecls :: [GHC.LInstDecl GHC.RdrName] -> RefactGhc DeclaredNames - instdecls ds - | findEntity e ds = do - fds <- mapM (hsVisibleDsRdr nm e) ds - return $ mconcat fds - instdecls _ = return (DN []) - - instdecl :: GHC.LInstDecl GHC.RdrName -> RefactGhc DeclaredNames - instdecl (GHC.L _ (GHC.ClsInstD (GHC.ClsInstDecl polytyp binds sigs tyfaminsts dfaminsts _))) - | findEntity e polytyp = hsVisibleDsRdr nm e polytyp - | findEntity e binds = hsVisibleDsRdr nm e binds - | findEntity e sigs = hsVisibleDsRdr nm e sigs - | findEntity e tyfaminsts = hsVisibleDsRdr nm e tyfaminsts - | findEntity e dfaminsts = hsVisibleDsRdr nm e dfaminsts - | otherwise = return (DN []) - instdecl (GHC.L _ (GHC.DataFamInstD (GHC.DataFamInstDecl _ln pats defn _))) - | findEntity e pats = hsVisibleDsRdr nm e pats - | findEntity e defn = hsVisibleDsRdr nm e defn - | otherwise = return (DN []) - instdecl (GHC.L _ (GHC.TyFamInstD (GHC.TyFamInstDecl eqn _))) - | findEntity e eqn = hsVisibleDsRdr nm e eqn - | otherwise = return (DN []) - - lhstype :: GHC.LHsType GHC.RdrName -> RefactGhc DeclaredNames - lhstype tv@(GHC.L l (GHC.HsTyVar n)) - | findEntity e tv = return (DN [rdrName2NamePure nm (GHC.L l n)]) - | otherwise = return (DN []) - lhstype (GHC.L _ (GHC.HsForAllTy _ _ _bndrs _ctxt _typ)) - = return (DN []) - lhstype (GHC.L _ (GHC.HsFunTy{})) = return (DN []) - lhstype ty = do - logm $ "lshtype: TypeUtils 1588" ++ SYB.showData SYB.Renamer 0 ty - return (DN []) - - -- ----------------------- - - lsigs :: [GHC.LSig GHC.RdrName] -> RefactGhc DeclaredNames - lsigs ss = do - fds <- mapM (hsVisibleDsRdr nm e) ss - return $ mconcat fds - - -- ----------------------- - - lsig :: GHC.LSig GHC.RdrName -> RefactGhc DeclaredNames - lsig (GHC.L _ (GHC.TypeSig _ns typ _)) - | findEntity e typ = hsVisibleDsRdr nm e typ - lsig (GHC.L _ (GHC.GenericSig _n typ)) - | findEntity e typ = hsVisibleDsRdr nm e typ - lsig (GHC.L _ (GHC.IdSig _)) = return (DN []) - lsig (GHC.L _ (GHC.InlineSig _ _)) = return (DN []) - lsig (GHC.L _ (GHC.SpecSig _n typ _)) - | findEntity e typ = hsVisibleDsRdr nm e typ - lsig (GHC.L _ (GHC.SpecInstSig _ _)) = return (DN []) - - lsig _ = return (DN []) - - -- ----------------------- - - err = error $ "hsVisibleDsRdr nm:no match for:" ++ (SYB.showData SYB.Renamer 0 t) - - ------------------------------------------------------------------------- - --- | Given syntax phrases e and t, if e occurs in t, then return those --- variables which are declared in t and accessible to e, otherwise --- return []. -hsVisibleDs :: (FindEntity e, GHC.Outputable e - ,SYB.Data t,HsValBinds t GHC.Name) - => e -> t -> RefactGhc DeclaredNames -hsVisibleDs e t = do - -- logm $ "hsVisibleDs:(e,t)=" ++ (SYB.showData SYB.Renamer 0 (e,t)) - (DN d) <- res - return (DN (nub d)) - where - -- TODO: this is effectively a recursive descent approach, where - -- each syntax element processor knows exactly what it needs - -- in terms of sub-elements. Hence as an optimisation, - -- consider calling the relevent element directly, instead - -- of looping back into the main function. - res = (const err -- (DN []) - `SYB.extQ` renamed - `SYB.extQ` valbinds - `SYB.extQ` lhsbindslr - `SYB.extQ` hsbinds - `SYB.extQ` hsbind - `SYB.extQ` hslocalbinds - `SYB.extQ` lmatch - `SYB.extQ` grhss - `SYB.extQ` lgrhs - `SYB.extQ` lexpr - `SYB.extQ` tyclgroups - `SYB.extQ` tyclgroup - `SYB.extQ` tycldeclss - `SYB.extQ` tycldecls - `SYB.extQ` tycldecl - `SYB.extQ` instdecls - `SYB.extQ` instdecl - `SYB.extQ` lhstype - `SYB.extQ` lsigs - `SYB.extQ` lsig - ) t - - renamed :: GHC.RenamedSource -> RefactGhc DeclaredNames - renamed (g,_i,_ex,_d) - | findEntity e g = do - dfds <- hsVisibleDs e $ GHC.hs_valds g - -- logm $ "hsVisibleDs.renamedSource:valds done" - tfds <- hsVisibleDs e $ GHC.hs_tyclds g - -- logm $ "hsVisibleDs.renamedSource:tyclds done" - ifds <- hsVisibleDs e $ GHC.hs_instds g - -- logm $ "hsVisibleDs.renamedSource:instds done" - return $ dfds <> tfds <> ifds - renamed _ = return (DN []) - - valbinds :: (GHC.HsValBindsLR GHC.Name GHC.Name) -> RefactGhc DeclaredNames - valbinds vb@(GHC.ValBindsIn bindsBag sigs) - | findEntity e vb = do - fdsb <- mapM (hsVisibleDs e) $ hsBinds bindsBag - fdss <- mapM (hsVisibleDs e) sigs - return $ mconcat fdss <> mconcat fdsb - valbinds vb@(GHC.ValBindsOut binds sigs) - | findEntity e vb = do - -- logm $ "hsVisibleDs.valbinds:ValBindsOut" - fdsb <- mapM (hsVisibleDs e) $ map snd binds - fdss <- mapM (hsVisibleDs e) sigs - return $ mconcat fdss <> mconcat fdsb - - valbinds _ = do - -- logm $ "hsVisibleDs.valbinds:not matched" - return (DN []) - - lhsbindslr :: GHC.LHsBindsLR GHC.Name GHC.Name -> RefactGhc DeclaredNames - lhsbindslr bs = do - fds <- mapM (hsVisibleDs e) $ GHC.bagToList bs - return $ mconcat fds - - hsbinds :: [GHC.LHsBind GHC.Name] -> RefactGhc DeclaredNames - hsbinds ds - | findEntity e ds = do - fds <- mapM (hsVisibleDs e) ds - return $ mconcat fds - hsbinds _ = return (DN []) - - hsbind :: (GHC.LHsBind GHC.Name) -> RefactGhc DeclaredNames - hsbind ((GHC.L _ (GHC.FunBind _n _ (GHC.MG matches _ _ _) _ _ _))) - | findEntity e matches = do - fds <- mapM (hsVisibleDs e) matches - -- logm $ "hsVisibleDs.hsbind:fds=" ++ show fds - return $ mconcat fds - hsbind _ = return (DN []) - - hslocalbinds :: (GHC.HsLocalBinds GHC.Name) -> RefactGhc DeclaredNames - hslocalbinds (GHC.HsValBinds binds) - | findEntity e binds = hsVisibleDs e binds - hslocalbinds (GHC.HsIPBinds binds) - | findEntity e binds = hsVisibleDs e binds - hslocalbinds (GHC.EmptyLocalBinds) = return (DN []) - hslocalbinds _ = return (DN []) - - lmatch :: (GHC.LMatch GHC.Name (GHC.LHsExpr GHC.Name)) -> RefactGhc DeclaredNames - lmatch (GHC.L _ (GHC.Match _fn pats _mtyp rhs)) - | findEntity e pats = do - -- logm $ "hsVisibleDs.lmatch:in pats=" - return (DN []) -- TODO: extend this - | findEntity e rhs = do - -- logm $ "hsVisibleDs.lmatch:doing rhs" - (_pf,pd) <- hsFreeAndDeclaredGhc pats - -- logm $ "hsVisibleDs.lmatch:(pf,pd)=" ++ (show (pf,pd)) - ( rd) <- hsVisibleDs e rhs - return (pd <> rd) - lmatch _ =return (DN []) - - grhss :: (GHC.GRHSs GHC.Name (GHC.LHsExpr GHC.Name)) -> RefactGhc DeclaredNames - grhss (GHC.GRHSs guardedRhss lstmts) - | findEntity e guardedRhss = do - -- logm "hsVisibleDs.grhss:about to do grhss" - fds <- mapM (hsVisibleDs e) guardedRhss - -- logm "hsVisibleDs.grhss:grhss done" - return $ mconcat fds - | findEntity e lstmts = do - -- logm "hsVisibleDs.grhss:about to do lstmts" - hsVisibleDs e lstmts - grhss _ = return (DN []) - - lgrhs :: GHC.LGRHS GHC.Name (GHC.LHsExpr GHC.Name) -> RefactGhc DeclaredNames - lgrhs (GHC.L _ (GHC.GRHS guards ex)) - | findEntity e guards = hsVisibleDs e guards - | findEntity e ex = hsVisibleDs e ex - lgrhs _ = return (DN []) - - - lexpr :: GHC.LHsExpr GHC.Name -> RefactGhc DeclaredNames - lexpr (GHC.L _ (GHC.HsVar n)) - | findEntity e n = return (DN [n]) - lexpr (GHC.L _ (GHC.HsLet lbinds expr)) - | findEntity e lbinds || findEntity e expr = do - (_,lds) <- hsFreeAndDeclaredGhc lbinds - (_,eds) <- hsFreeAndDeclaredGhc expr - return $ lds <> eds - - lexpr expr - | findEntity e expr = do - -- logm $ "hsVisibleDs.lexpr.(e,expr):" ++ (showGhc (e,expr)) - (FN efs,_) <- hsFreeAndDeclaredGhc expr - (FN _eefs,DN eeds) <- hsFreeAndDeclaredGhc e - -- logm $ "hsVisibleDs.lexpr done" - -- return (DN e1fs <> DN eofs <> DN e2fs) - return (DN (efs \\ eeds)) - - lexpr _ = return (DN []) - - -- --------------------------------- - - tyclgroups :: [GHC.TyClGroup GHC.Name] -> RefactGhc DeclaredNames - tyclgroups tgrps - | findEntity e tgrps = do - fds <- mapM (hsVisibleDs e) tgrps - return $ mconcat fds - tyclgroups _ = return (DN []) - - tyclgroup :: GHC.TyClGroup GHC.Name -> RefactGhc DeclaredNames - tyclgroup (GHC.TyClGroup tyclds _roles) - | findEntity e tyclds = do - fds <- mapM (hsVisibleDs e) tyclds - return $ mconcat fds - tyclgroup _ = return (DN []) - - tycldeclss :: [[GHC.LTyClDecl GHC.Name]] -> RefactGhc DeclaredNames - tycldeclss tcds - | findEntity e tcds = do - fds <- mapM (hsVisibleDs e) tcds - return $ mconcat fds - tycldeclss _ = return (DN []) - - tycldecls :: [GHC.LTyClDecl GHC.Name] -> RefactGhc DeclaredNames - tycldecls tcds - | findEntity e tcds = do - -- logm $ "hsVisibleDs.tycldecls" - fds <- mapM (hsVisibleDs e) tcds - return $ mconcat fds - tycldecls _ = return (DN []) - - tycldecl :: GHC.LTyClDecl GHC.Name -> RefactGhc DeclaredNames - tycldecl tcd - | findEntity e tcd = do - -- logm $ "hsVisibleDs.tycldecl" - (_,ds) <- hsFreeAndDeclaredGhc tcd - return ds - tycldecl _ = return (DN []) - - -- --------------------------------- - - instdecls :: [GHC.LInstDecl GHC.Name] -> RefactGhc DeclaredNames - instdecls ds - | findEntity e ds = do - fds <- mapM (hsVisibleDs e) ds - return $ mconcat fds - instdecls _ = return (DN []) - - instdecl :: GHC.LInstDecl GHC.Name -> RefactGhc DeclaredNames - instdecl (GHC.L _ (GHC.ClsInstD (GHC.ClsInstDecl polytyp binds sigs tyfaminsts dfaminsts _))) - | findEntity e polytyp = hsVisibleDs e polytyp - | findEntity e binds = hsVisibleDs e binds - | findEntity e sigs = hsVisibleDs e sigs - | findEntity e tyfaminsts = hsVisibleDs e tyfaminsts - | findEntity e dfaminsts = hsVisibleDs e dfaminsts - | otherwise = return (DN []) - instdecl (GHC.L _ (GHC.DataFamInstD (GHC.DataFamInstDecl _ln pats defn _))) - | findEntity e pats = hsVisibleDs e pats - | findEntity e defn = hsVisibleDs e defn - | otherwise = return (DN []) - instdecl (GHC.L _ (GHC.TyFamInstD (GHC.TyFamInstDecl eqn _))) - | findEntity e eqn = hsVisibleDs e eqn - | otherwise = return (DN []) - - lhstype :: GHC.LHsType GHC.Name -> RefactGhc DeclaredNames - lhstype tv@(GHC.L _ (GHC.HsTyVar n)) - | findEntity e tv = return (DN [n]) - | otherwise = return (DN []) - lhstype (GHC.L _ (GHC.HsForAllTy _ _ _bndrs _ctxt _typ)) - = return (DN []) - lhstype (GHC.L _ (GHC.HsFunTy{})) = return (DN []) - lhstype _ty = do - -- logm $ "lshtype: TypeUtils 1588" ++ SYB.showData SYB.Renamer 0 _ty - return (DN []) - - -- ----------------------- - - lsigs :: [GHC.LSig GHC.Name] -> RefactGhc DeclaredNames - lsigs ss = do - fds <- mapM (hsVisibleDs e) ss - return $ mconcat fds - - -- ----------------------- - - lsig :: GHC.LSig GHC.Name -> RefactGhc DeclaredNames - lsig (GHC.L _ (GHC.TypeSig _ns typ _)) - | findEntity e typ = hsVisibleDs e typ - lsig (GHC.L _ (GHC.GenericSig _n typ)) - | findEntity e typ = hsVisibleDs e typ - lsig (GHC.L _ (GHC.IdSig _)) = return (DN []) - lsig (GHC.L _ (GHC.InlineSig _ _)) = return (DN []) - lsig (GHC.L _ (GHC.SpecSig _n typ _)) - | findEntity e typ = hsVisibleDs e typ - lsig (GHC.L _ (GHC.SpecInstSig _ _)) = return (DN []) - - lsig _ = return (DN []) - - -- ----------------------- - - err = error $ "hsVisibleDs:no match for:" ++ (SYB.showData SYB.Renamer 0 t) - --- --------------------------------------------------------------------- - --- |`hsFDsFromInsideRdr` is different from `hsFreeAndDeclaredPNs` in --- that: given an syntax phrase t, `hsFDsFromInsideRdr` returns not only --- the declared variables that are visible from outside of t, but also --- those declared variables that are visible to the main expression --- inside t. --- NOTE: Expects to be given RenamedSource -hsFDsFromInsideRdr:: (SYB.Data t) - => NameMap -> t -> RefactGhc (FreeNames,DeclaredNames) -hsFDsFromInsideRdr nm t = do - r <- hsFDsFromInsideRdr' t - return r - where - hsFDsFromInsideRdr' :: (SYB.Data t) => t -> RefactGhc (FreeNames,DeclaredNames) - hsFDsFromInsideRdr' t1 = do - r1 <- applyTU (once_tdTU (failTU `adhocTU` parsed - `adhocTU` decl - `adhocTU` match - `adhocTU` expr - `adhocTU` stmts )) t1 - -- let (f',d') = fromMaybe ([],[]) r1 - let (FN f',DN d') = r1 - return (FN $ nub f', DN $ nub d') - - parsed :: GHC.ParsedSource -> RefactGhc (FreeNames,DeclaredNames) - parsed p - = return $ hsFreeAndDeclaredRdr nm p - - match :: GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> RefactGhc (FreeNames,DeclaredNames) - match (GHC.Match _fn pats _type rhs) = do - let (FN pf, DN pd) = hsFreeAndDeclaredRdr nm pats - let (FN rf, DN rd) = hsFreeAndDeclaredRdr nm rhs - return (FN $ nub (pf `union` (rf \\ pd)), - DN $ nub (pd `union` rd)) - - -- ---------------------- - - decl :: GHC.HsBind GHC.RdrName -> RefactGhc (FreeNames,DeclaredNames) - decl (GHC.FunBind (GHC.L _ _) _ (GHC.MG matches _ _ _) _ _ _) = - do - fds <- mapM hsFDsFromInsideRdr' matches - -- error (show $ nameToString n) - return (FN $ nub (concat $ map (fn . fst) fds), DN $ nub (concat $ map (dn . snd) fds)) - - decl ((GHC.PatBind p rhs _ _ _) :: GHC.HsBind GHC.RdrName) = - do - let (FN pf, DN pd) = hsFreeAndDeclaredRdr nm p - let (FN rf, DN rd) = hsFreeAndDeclaredRdr nm rhs - return - (FN $ nub (pf `union` (rf \\ pd)), - DN $ nub (pd `union` rd)) - - decl ((GHC.VarBind p rhs _) :: GHC.HsBind GHC.RdrName) = - do - let (FN pf, DN pd) = hsFreeAndDeclaredRdr nm p - let (FN rf, DN rd) = hsFreeAndDeclaredRdr nm rhs - return - (FN $ nub (pf `union` (rf \\ pd)), - DN $ nub (pd `union` rd)) - - decl _ = return (FN [],DN []) - - -- ---------------------- - - expr ((GHC.HsLet decls e) :: GHC.HsExpr GHC.RdrName) = - do - let (FN df,DN dd) = hsFreeAndDeclaredRdr nm decls - let (FN ef,_) = hsFreeAndDeclaredRdr nm e - return (FN $ nub (df `union` (ef \\ dd)), DN $ nub dd) - - expr ((GHC.HsLam (GHC.MG matches _ _ _)) :: GHC.HsExpr GHC.RdrName) = - return $ hsFreeAndDeclaredRdr nm matches - - expr ((GHC.HsCase e (GHC.MG matches _ _ _)) :: GHC.HsExpr GHC.RdrName) = - do - let (FN ef,_) = hsFreeAndDeclaredRdr nm e - let (FN df,DN dd) = hsFreeAndDeclaredRdr nm matches - return (FN $ nub (df `union` (ef \\ dd)), DN $ nub dd) - - expr _ = mzero - - stmts ((GHC.BindStmt pat e1 e2 e3) :: GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = - do - let (FN pf,DN pd) = hsFreeAndDeclaredRdr nm pat - let (FN ef,DN _ed) = hsFreeAndDeclaredRdr nm e1 - let (FN df,DN dd) = hsFreeAndDeclaredRdr nm [e2,e3] - return - (FN $ nub (pf `union` (((ef \\ dd) `union` df) \\ pd)), DN $ nub (pd `union` dd)) - - stmts ((GHC.LetStmt binds) :: GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = - return $ hsFreeAndDeclaredRdr nm binds - - stmts _ = mzero - - --- --------------------------------------------------------------------- - --- |`hsFDsFromInside` is different from `hsFreeAndDeclaredPNs` in --- that: given an syntax phrase t, `hsFDsFromInside` returns not only --- the declared variables that are visible from outside of t, but also --- those declared variables that are visible to the main expression --- inside t. --- NOTE: Expects to be given RenamedSource -hsFDsFromInside:: (SYB.Data t) => t-> RefactGhc ([GHC.Name],[GHC.Name]) -hsFDsFromInside t = do - r <- hsFDsFromInside' t - return r - where - hsFDsFromInside' :: (SYB.Data t) => t -> RefactGhc ([GHC.Name],[GHC.Name]) - hsFDsFromInside' t1 = do - r1 <- applyTU (once_tdTU (failTU `adhocTU` renamed - `adhocTU` decl - `adhocTU` match - `adhocTU` expr - `adhocTU` stmts )) t1 - let (f',d') = r1 - return (nub f', nub d') - - renamed :: GHC.RenamedSource -> RefactGhc ([GHC.Name],[GHC.Name]) - renamed ((grp,_,_,_)::GHC.RenamedSource) - = hsFreeAndDeclaredPNs $ GHC.hs_valds grp - - match :: GHC.Match GHC.Name (GHC.LHsExpr GHC.Name) -> RefactGhc ([GHC.Name],[GHC.Name]) - match ((GHC.Match _fn pats _type rhs):: GHC.Match GHC.Name (GHC.LHsExpr GHC.Name)) = do - (pf, pd) <- hsFreeAndDeclaredPNs pats - (rf, rd) <- hsFreeAndDeclaredPNs rhs - return (nub (pf `union` (rf \\ pd)), - nub (pd `union` rd)) - - -- ---------------------- - - decl :: GHC.HsBind GHC.Name -> RefactGhc ([GHC.Name],[GHC.Name]) - decl ((GHC.FunBind (GHC.L _ _) _ (GHC.MG matches _ _ _) _ _ _) :: GHC.HsBind GHC.Name) = - do - fds <- mapM hsFDsFromInside' matches - -- error (show $ nameToString n) - return (nub (concatMap fst fds), nub (concatMap snd fds)) - - decl ((GHC.PatBind p rhs _ _ _) :: GHC.HsBind GHC.Name) = - do - (pf, pd) <- hsFreeAndDeclaredPNs p - (rf, rd) <- hsFreeAndDeclaredPNs rhs - return - (nub (pf `union` (rf \\ pd)), - nub (pd `union` rd)) - - decl ((GHC.VarBind p rhs _) :: GHC.HsBind GHC.Name) = - do - (pf, pd) <- hsFreeAndDeclaredPNs p - (rf, rd) <- hsFreeAndDeclaredPNs rhs - return - (nub (pf `union` (rf \\ pd)), - nub (pd `union` rd)) - - decl _ = return ([],[]) - - -- ---------------------- - - expr ((GHC.HsLet decls e) :: GHC.HsExpr GHC.Name) = - do - (df,dd) <- hsFreeAndDeclaredPNs decls - (ef,_) <- hsFreeAndDeclaredPNs e - return (nub (df `union` (ef \\ dd)), nub dd) - - expr ((GHC.HsLam (GHC.MG matches _ _ _)) :: GHC.HsExpr GHC.Name) = - hsFreeAndDeclaredPNs matches - - expr ((GHC.HsCase e (GHC.MG matches _ _ _)) :: GHC.HsExpr GHC.Name) = - do - (ef,_) <- hsFreeAndDeclaredPNs e - (df,dd) <- hsFreeAndDeclaredPNs matches - return (nub (df `union` (ef \\ dd)), nub dd) - - expr _ = mzero - - stmts ((GHC.BindStmt pat e1 e2 e3) :: GHC.Stmt GHC.Name (GHC.LHsExpr GHC.Name)) = - do - (pf,pd) <- hsFreeAndDeclaredPNs pat - (ef,_ed) <- hsFreeAndDeclaredPNs e1 - (df,dd) <- hsFreeAndDeclaredPNs [e2,e3] - return - (nub (pf `union` (((ef \\ dd) `union` df) \\ pd)), nub (pd `union` dd)) - - stmts ((GHC.LetStmt binds) :: GHC.Stmt GHC.Name (GHC.LHsExpr GHC.Name)) = - hsFreeAndDeclaredPNs binds - - stmts _ = mzero - - - --- | The same as `hsFDsFromInside` except that the returned variables --- are in the String format -hsFDNamesFromInside::(SYB.Data t) => t -> RefactGhc ([String],[String]) -hsFDNamesFromInside t = do - (f,d) <- hsFDsFromInside t - return - ((nub.map showGhc) f, (nub.map showGhc) d) - --- | The same as `hsFDsFromInside` except that the returned variables --- are in the String format -hsFDNamesFromInsideRdr ::(SYB.Data t) => t -> RefactGhc ([String],[String]) -hsFDNamesFromInsideRdr t = do - nm <- getRefactNameMap - (FN f,DN d) <- hsFDsFromInsideRdr nm t - return - ((nub.map showGhc) f, (nub.map showGhc) d) - --- --------------------------------------------------------------------- - -rdrName2Name' :: GHC.Located GHC.RdrName -> RefactGhc GHC.Name -rdrName2Name' (GHC.L l rdr) = do - renamed <- getRefactRenamed - let mn = locToName (getGhcLoc l) renamed - return (GHC.unLoc $ gfromJust ("rdrName2Name':failed for:" ++ showGhc (GHC.L l rdr)) mn) - --- --------------------------------------------------------------------- - -rdrName2Name :: GHC.Located GHC.RdrName -> RefactGhc GHC.Name -rdrName2Name ln = do - nameMap <- getRefactNameMap - return (rdrName2NamePure nameMap ln) - -rdrName2NamePure :: NameMap -> GHC.Located GHC.RdrName -> GHC.Name -rdrName2NamePure _nameMap (GHC.L _ (GHC.Exact n)) = n -rdrName2NamePure nameMap (GHC.L lrn _) = - fromMaybe (error $ "rdrName2NamePure: no name found for" ++ showGhc lrn) - -- fromMaybe (error $ "rdrName2NamePure: no name found for (lrn,e,nameMap)=" ++ showGhc (lrn,e,nameMap)) - (Map.lookup lrn nameMap) - -eqRdrNamePure :: NameMap -> GHC.Located GHC.RdrName -> GHC.Name -> Bool -eqRdrNamePure nameMap rn n - = GHC.nameUnique (rdrName2NamePure nameMap rn) == GHC.nameUnique n - --- --------------------------------------------------------------------- - --- |Find the identifier(in GHC.Name format) whose start position is --- (row,col) in the file specified by the fileName, and returns --- `Nothing` if such an identifier does not exist. -locToName::(SYB.Data t) - =>SimpPos -- ^ The row and column number - ->t -- ^ The syntax phrase - -> Maybe (GHC.Located GHC.Name) -- ^ The result -locToName (row,col) t = locToName' (row,col) t - --- |Find the identifier(in GHC.RdrName format) whose start position is --- (row,col) in the file specified by the fileName, and returns --- `Nothing` if such an identifier does not exist. -locToRdrName::(SYB.Data t) - =>SimpPos -- ^ The row and column number - ->t -- ^ The syntax phrase - -> Maybe (GHC.Located GHC.RdrName) -- ^ The result -locToRdrName (row,col) t = locToName' (row,col) t - - --- |Worker for both locToName and locToRdrName. --- NOTE: provides for FunBind MatchGroups where only the first name is --- retained in the AST - -locToName':: forall a t.(SYB.Data t, SYB.Data a, Eq a) - =>SimpPos -- ^ The row and column number - ->t -- ^ The syntax phrase - -> Maybe (GHC.Located a) -- ^ The result -locToName' (row,col) t = res1 - where - res1 :: Maybe (GHC.Located a) - res1 = SYB.something (nameSybQuery checker) t - - checker pnt = + , isDeclaredInRdr + , FreeNames(..),DeclaredNames(..) + , hsFreeAndDeclaredRdr + , hsFreeAndDeclaredNameStrings + , hsFreeAndDeclaredPNs + -- , hsFreeAndDeclaredGhc + , getDeclaredTypesRdr + , getDeclaredVarsRdr + , hsVisibleNamesRdr + , hsFDsFromInsideRdr, hsFDNamesFromInsideRdr, hsFDNamesFromInsideRdrPure + , hsVisibleDsRdr + , rdrName2Name, rdrName2NamePure + , eqRdrNamePure + -- , rdrName2Name' + + -- ** Identifiers, expressions, patterns and declarations + , FindEntity(..) + , findNameInRdr + , findNamesRdr + , sameOccurrence + , definedPNsRdr,definedNamesRdr + , definingDeclsRdrNames,definingDeclsRdrNames',definingSigsRdrNames + , definingTyClDeclsNames + , definesRdr,definesDeclRdr + , definesTypeSigRdr,definesSigDRdr + + , hsTypeVbls + , hsNamessRdr + , findLRdrName + , locToNameRdr, locToNameRdrPure + , locToRdrName + ) where + +import Control.Monad.State +import Data.List +import Data.Maybe +import Data.Monoid +-- import Debug.Trace + +import Language.Haskell.Refact.Utils.GhcVersionSpecific +import Language.Haskell.Refact.Utils.LocUtils +import Language.Haskell.Refact.Utils.Monad +import Language.Haskell.Refact.Utils.MonadFunctions +import Language.Haskell.Refact.Utils.Types + +import Language.Haskell.GHC.ExactPrint.Types +import Language.Haskell.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint.Utils + + +-- Modules from GHC +import qualified Bag as GHC +import qualified GHC as GHC +import qualified Name as GHC +import qualified Outputable as GHC +import qualified RdrName as GHC + +import qualified Data.Generics as SYB +import qualified GHC.SYB.Utils as SYB + +import qualified Data.Map as Map + +import Data.Generics.Strafunski.StrategyLib.StrategyLib hiding (liftIO,MonadPlus,mzero) + +-- --------------------------------------------------------------------- + +class (SYB.Data a, SYB.Typeable a) => FindEntity a where + + -- | Returns True is a syntax phrase, say a, is part of another + -- syntax phrase, say b. + -- NOTE: very important: only do a shallow check + findEntity:: (SYB.Data b) => a -> b -> Bool + +-- --------------------------------------------------------------------- + +{-# DEPRECATED FindEntity "Can't use Renamed in GHC 8" #-} +instance FindEntity GHC.Name where + + findEntity n t = fromMaybe False res + where + res = SYB.somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t + + worker (name::GHC.Name) + | n == name = Just True + worker _ = Nothing + + +-- This instance does not make sense, it will only find the specific RdrName +-- where it was found, not any other instances of it. +instance FindEntity (GHC.Located GHC.RdrName) where + + findEntity ln t = + case SYB.something (nameSybQuery checkRdr) t of + Nothing -> False + _ -> True + where + checkRdr :: GHC.Located GHC.RdrName -> Maybe Bool + checkRdr n + | sameOccurrence n ln = Just True + | otherwise = Nothing + +-- --------------------------------------------------------------------- + +-- TODO: should the location be matched too in this case? +instance FindEntity (GHC.Located GHC.Name) where + + findEntity n t = fromMaybe False res + where + res = SYB.somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t + + worker (name::GHC.Located GHC.Name) + | n == name = Just True + worker _ = Nothing + + +-- --------------------------------------------------------------------- + +instance FindEntity (GHC.LHsExpr GHC.RdrName) where + + findEntity e t = fromMaybe False res + where + res = SYB.something (Nothing `SYB.mkQ` worker) t + + worker (expr :: GHC.LHsExpr GHC.RdrName) + | sameOccurrence e expr = Just True + worker _ = Nothing + +-- TODO: remove this instance +instance FindEntity (GHC.LHsExpr GHC.Name) where + + findEntity e t = fromMaybe False res + where + res = SYB.something (Nothing `SYB.mkQ` worker) t + + worker (expr :: GHC.LHsExpr GHC.Name) + | sameOccurrence e expr = Just True + worker _ = Nothing + +-- --------------------------------------------------------------------- + +instance FindEntity (GHC.Located (GHC.HsBindLR GHC.Name GHC.Name)) where + findEntity e t = fromMaybe False res + where + res = SYB.somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t + + worker (expr::(GHC.Located (GHC.HsBindLR GHC.Name GHC.Name))) + | sameOccurrence e expr = Just True + worker _ = Nothing + +instance FindEntity (GHC.Located (GHC.HsDecl GHC.Name)) where + findEntity d t = fromMaybe False res + where + res = SYB.somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t + + worker (decl::(GHC.Located (GHC.HsDecl GHC.Name))) + | sameOccurrence d decl = Just True + worker _ = Nothing + +-- --------------------------------------------------------------------- + +-- TODO: AZ: pretty sure this can be simplified, depends if we need to +-- manage transformed stuff too though. + +-- | Return True if syntax phrases t1 and t2 refer to the same one. +sameOccurrence :: (GHC.Located t) -> (GHC.Located t) -> Bool +sameOccurrence (GHC.L l1 _) (GHC.L l2 _) + = l1 == l2 + + +-- --------------------------------------------------------------------- + +-- | For free variables +data FreeNames = FN { fn :: [GHC.Name] } + +-- | For declared variables +data DeclaredNames = DN { dn :: [GHC.Name] } + +instance Show FreeNames where + show (FN ls) = "FN " ++ showGhcQual ls + +instance Show DeclaredNames where + show (DN ls) = "DN " ++ showGhcQual ls + +instance Monoid FreeNames where + mempty = FN [] + mappend (FN a) (FN b) = FN (a `mappend` b) + +instance Monoid DeclaredNames where + mempty = DN [] + mappend (DN a) (DN b) = DN (a `mappend` b) + + +emptyFD :: (FreeNames,DeclaredNames) +emptyFD = (FN [], DN []) + +-- --------------------------------------------------------------------- +-- | True if the name is a field name +isFieldName :: GHC.Name -> Bool +isFieldName _n = error "undefined isFieldName" + +-- --------------------------------------------------------------------- +-- | True if the name is a field name +isClassName :: GHC.Name -> Bool +isClassName _n = error "undefined isClassName" + +-- --------------------------------------------------------------------- +-- | True if the name is a class instance +isInstanceName :: GHC.Name -> Bool +isInstanceName _n = error "undefined isInstanceName" + + +-- --------------------------------------------------------------------- +-- | Collect those type variables that are declared in a given syntax phrase t. In +-- the returned result, the first list is always be empty. +hsTypeVbls::(SYB.Data t) => t -> ([GHC.RdrName],[GHC.RdrName]) +hsTypeVbls =ghead "hsTypeVbls".(applyTU (stop_tdTU (failTU `adhocTU` pnt))) + where + -- pnt (PNT (PN i (UniqueNames.S loc)) (Type _) _) = return ([], [(PN i (UniqueNames.S loc))]) + pnt n | GHC.rdrNameSpace n == GHC.tvName = return ([], [n]) + pnt _ = mzero + + +------------------------------------------------------------------------------- + +isDeclaredInRdr :: NameMap -> GHC.Name -> [GHC.LHsDecl GHC.RdrName] -> Bool +isDeclaredInRdr nm name decls = nonEmptyList $ definingDeclsRdrNames nm [name] decls False True + +-- --------------------------------------------------------------------- + +-- | Collect the free and declared variables (in the GHC.Name format) +-- in a given syntax phrase t. In the result, the first list contains +-- the free variables, and the second list contains the declared +-- variables. +-- Expects RenamedSource +hsFreeAndDeclaredRdr :: (SYB.Data t) => NameMap -> t -> (FreeNames,DeclaredNames) +hsFreeAndDeclaredRdr nm t = res + where + fd = hsFreeAndDeclaredRdr' nm t + (FN f,DN d) = fromMaybe mempty fd + res = (FN (f \\ d),DN d) + +hsFreeAndDeclaredRdr':: (SYB.Data t) => NameMap -> t -> Maybe (FreeNames,DeclaredNames) +hsFreeAndDeclaredRdr' nm t = do + (FN f,DN d) <- hsFreeAndDeclared' + let (f',d') = (nub f, nub d) + return (FN f',DN d') + -- hsFreeAndDeclared'=applyTU (stop_tdTU (failTU `adhocTU` exp + + where + hsFreeAndDeclared' :: Maybe (FreeNames,DeclaredNames) + hsFreeAndDeclared' = applyTU (stop_tdTU (failTU + `adhocTU` expr + `adhocTU` pat + `adhocTU` bndrs + `adhocTU` binds + `adhocTU` bindList + `adhocTU` match + `adhocTU` stmts + `adhocTU` rhs + `adhocTU` ltydecl + `adhocTU` hstype + )) t + + -- expr -- +#if __GLASGOW_HASKELL__ <= 710 + expr (GHC.L l (GHC.HsVar n)) +#else + expr (GHC.L l (GHC.HsVar (GHC.L _ n))) +#endif + = return (FN [rdrName2NamePure nm (GHC.L l n)],DN []) + +#if __GLASGOW_HASKELL__ <= 710 + expr (GHC.L _ (GHC.OpApp e1 (GHC.L l (GHC.HsVar n)) _ e2)) = do +#else + expr (GHC.L _ (GHC.OpApp e1 (GHC.L l (GHC.HsVar (GHC.L _ n))) _ e2)) = do +#endif + efed <- hsFreeAndDeclaredRdr' nm [e1,e2] + fd <- addFree (rdrName2NamePure nm (GHC.L l n)) efed + return fd + + expr (GHC.L _ ((GHC.HsLam (GHC.MG matches _ _ _))) :: GHC.LHsExpr GHC.RdrName) = + hsFreeAndDeclaredRdr' nm matches + + expr (GHC.L _ ((GHC.HsLet decls e)) :: GHC.LHsExpr GHC.RdrName) = + do + (FN df,DN dd) <- hsFreeAndDeclaredRdr' nm decls + (FN ef,_) <- hsFreeAndDeclaredRdr' nm e + return (FN (df `union` (ef \\ dd)),DN []) + +#if __GLASGOW_HASKELL__ <= 710 + expr (GHC.L _ (GHC.RecordCon ln _ e)) = do +#else + expr (GHC.L _ (GHC.RecordCon ln _ _ e)) = do +#endif + fd <- (hsFreeAndDeclaredRdr' nm e) + addFree (rdrName2NamePure nm ln) fd --Need Testing + + expr (GHC.L _ (GHC.EAsPat ln e)) = do + fd <- (hsFreeAndDeclaredRdr' nm e) + addFree (rdrName2NamePure nm ln) fd + + expr _ = mzero + + + -- rhs -- + rhs ((GHC.GRHSs g ds) :: GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName)) + = do (FN df,DN dd) <- hsFreeAndDeclaredRdr' nm g + (FN ef,DN ed) <- hsFreeAndDeclaredRdr' nm ds + return (FN $ df ++ ef, DN $ dd ++ ed) + + + -- pat -- + pat :: GHC.LPat GHC.RdrName -> Maybe (FreeNames,DeclaredNames) + pat (GHC.L _ (GHC.WildPat _)) = mzero +#if __GLASGOW_HASKELL__ <= 710 + pat (GHC.L l (GHC.VarPat n)) +#else + pat (GHC.L l (GHC.VarPat (GHC.L _ n))) +#endif + = return (FN [],DN [rdrName2NamePure nm (GHC.L l n)]) + pat (GHC.L _ (GHC.AsPat ln p)) = do + let (f,DN d) = fromMaybe mempty $ hsFreeAndDeclaredRdr' nm p + return (f,DN (rdrName2NamePure nm ln:d)) + + pat (GHC.L _ (GHC.ParPat p)) = pat p + pat (GHC.L _ (GHC.BangPat p)) = pat p + pat (GHC.L _ (GHC.ListPat ps _ _)) = do + fds <- mapM pat ps + return $ mconcat fds + pat (GHC.L _ (GHC.TuplePat ps _ _)) = do + fds <- mapM pat ps + return $ mconcat fds + pat (GHC.L _ (GHC.PArrPat ps _)) = do + fds <- mapM pat ps + return $ mconcat fds + pat (GHC.L _ (GHC.ConPatIn n det)) = do + (FN f,DN d) <- details det + return $ (FN [rdrName2NamePure nm n],DN d) <> (FN [],DN f) + pat (GHC.L _ (GHC.ViewPat e p _)) = do + fde <- hsFreeAndDeclaredRdr' nm e + fdp <- pat p + return $ fde <> fdp + -- pat (GHC.QuasiQuotePat _) + pat (GHC.L _ (GHC.LitPat _)) = return emptyFD +#if __GLASGOW_HASKELL__ <= 710 + pat (GHC.L _ (GHC.NPat _ _ _)) = return emptyFD + pat (GHC.L _ (GHC.NPlusKPat n _ _ _)) = return (FN [],DN [rdrName2NamePure nm n]) +#else + pat (GHC.L _ (GHC.NPat _ _ _ _)) = return emptyFD + pat (GHC.L _ (GHC.NPlusKPat n _ _ _ _ _)) = return (FN [],DN [rdrName2NamePure nm n]) +#endif + pat (GHC.L _ _p@(GHC.SigPatIn p b)) = do + fdp <- pat p + (FN fb,DN _db) <- hsFreeAndDeclaredRdr' nm b + -- error $ "pat.SigPatIn:(b,fb,db)" ++ showGhc (b,fb,db) + return $ fdp <> (FN fb,DN []) + pat (GHC.L _ (GHC.SigPatOut p _)) = pat p + pat (GHC.L l (GHC.CoPat _ p _)) = pat (GHC.L l p) + + pat (GHC.L _ (GHC.LazyPat p)) = pat p + + pat (GHC.L _ (GHC.ConPatOut {})) = error $ "hsFreeAndDeclaredRdr'.pat:impossible: ConPatOut" + +#if __GLASGOW_HASKELL__ <= 710 + pat (GHC.L _ (GHC.SplicePat (GHC.HsSplice _ e))) = hsFreeAndDeclaredRdr' nm e +#else + pat (GHC.L _ (GHC.SplicePat (GHC.HsQuasiQuote {}))) = return (FN [], DN []) + pat (GHC.L _ (GHC.SplicePat (GHC.HsTypedSplice _ e))) = hsFreeAndDeclaredRdr' nm e + pat (GHC.L _ (GHC.SplicePat (GHC.HsUntypedSplice _ e))) = hsFreeAndDeclaredRdr' nm e +#endif + +#if __GLASGOW_HASKELL__ <= 710 + pat (GHC.L _ (GHC.QuasiQuotePat _)) = return (FN [], DN []) +#endif + + -- pat p = error $ "hsFreeAndDeclaredRdr'.pat:unimplemented:" ++ (showGhc p) + + -- --------------------------- + + details :: GHC.HsConPatDetails GHC.RdrName -> Maybe (FreeNames,DeclaredNames) + details (GHC.PrefixCon args) = do + -- logm $ "hsFreeAndDeclaredGhc.details:args=" ++ (showGhc args) + fds <- mapM pat args + return $ mconcat fds + details (GHC.RecCon recf) = + recfields recf + details (GHC.InfixCon arg1 arg2) = do + fds <- mapM pat [arg1,arg2] + return $ mconcat fds + + -- Note: this one applies to HsRecFields in LPats + recfields :: (GHC.HsRecFields GHC.RdrName (GHC.LPat GHC.RdrName)) -> Maybe (FreeNames,DeclaredNames) + recfields (GHC.HsRecFields fields _) = do + let args = map (\(GHC.L _ (GHC.HsRecField _ arg _)) -> arg) fields + fds <- mapM pat args + return $ mconcat fds + + -- ----------------------- + +#if __GLASGOW_HASKELL__ <= 710 + bndrs :: GHC.HsWithBndrs GHC.RdrName (GHC.LHsType GHC.RdrName) -> Maybe (FreeNames,DeclaredNames) + bndrs (GHC.HsWB thing _ _ _) = do + (FN ft,DN _dt) <- hsFreeAndDeclaredRdr' nm thing + return (FN ft,DN []) +#else + bndrs :: GHC.LHsSigWcType GHC.RdrName -> Maybe (FreeNames,DeclaredNames) + bndrs (GHC.HsIB _ (GHC.HsWC _ _ ty)) = do + (FN ft,DN _dt) <- hsFreeAndDeclaredRdr' nm ty + -- return (FN dt,DN []) + return (FN ft,DN []) +#endif + + -- --------------------------- + + bindList (ds :: [GHC.LHsBind GHC.RdrName]) + =do (FN f,DN d) <- recurseList ds + return (FN (f\\d),DN d) + + -- match and patBind, same type-- +#if __GLASGOW_HASKELL__ <= 710 + binds ((GHC.FunBind ln _ (GHC.MG matches _ _ _) _ _fvs _) :: GHC.HsBind GHC.RdrName) +#else + binds ((GHC.FunBind ln (GHC.MG matches _ _ _) _ _fvs _) :: GHC.HsBind GHC.RdrName) +#endif + = do + (FN pf,_pd) <- hsFreeAndDeclaredRdr' nm matches + let n = rdrName2NamePure nm ln + return (FN (pf \\ [n]) ,DN [n]) + + -- patBind -- + binds (GHC.PatBind pat' prhs _ _ds _) = + do + (FN pf,DN pd) <- hsFreeAndDeclaredRdr' nm pat' + (FN rf,DN rd) <- hsFreeAndDeclaredRdr' nm prhs + return (FN $ pf `union` (rf \\ pd),DN $ pd ++ rd) + + binds _ = mzero + + match ((GHC.Match _fn pats _mtype mrhs) :: GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName)) + = do + (FN pf,DN pd) <- hsFreeAndDeclaredRdr' nm pats + (FN rf,DN rd) <- hsFreeAndDeclaredRdr' nm mrhs + return (FN (pf `union` (rf \\ (pd `union` rd))),DN []) + + -- stmts -- +#if __GLASGOW_HASKELL__ <= 710 + stmts ((GHC.BindStmt pat' expre _bindOp _failOp) :: GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = do +#else + stmts ((GHC.BindStmt pat' expre _bindOp _failOp _) :: GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = do +#endif + -- TODO ++AZ++ : Not sure it is meaningful to pull + -- anything out of bindOp/failOp + (FN pf,DN pd) <- hsFreeAndDeclaredRdr' nm pat' + (FN ef,_ed) <- hsFreeAndDeclaredRdr' nm expre + let sf1 = [] + return (FN $ pf `union` ef `union` (sf1\\pd),DN []) -- pd) -- Check this + + stmts ((GHC.LetStmt binds') :: GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = + hsFreeAndDeclaredRdr' nm binds' + + stmts _ = mzero + + -- tycldecls ----------------- + + ltydecl :: GHC.TyClDecl GHC.RdrName -> Maybe (FreeNames,DeclaredNames) + + ltydecl (GHC.FamDecl fd) = hsFreeAndDeclaredRdr' nm fd + ltydecl (GHC.SynDecl ln _bndrs _rhs _fvs) + = return (FN [],DN [rdrName2NamePure nm ln]) +#if __GLASGOW_HASKELL__ <= 710 + ltydecl (GHC.DataDecl ln _bndrs defn _fvs) = do + let dds = map (rdrName2NamePure nm) $ concatMap (GHC.con_names . GHC.unLoc) $ GHC.dd_cons defn +#else + ltydecl (GHC.DataDecl ln _bndrs defn _c _fvs) = do + let dds = map (rdrName2NamePure nm) $ concatMap (GHC.getConNames . GHC.unLoc) $ GHC.dd_cons defn +#endif + return (FN [],DN (rdrName2NamePure nm ln:dds)) + ltydecl (GHC.ClassDecl _ctx ln _tyvars + _fds _sigs meths ats atds _docs _fvs) = do + (_,md) <- hsFreeAndDeclaredRdr' nm meths + (_,ad) <- hsFreeAndDeclaredRdr' nm ats + (_,atd) <- hsFreeAndDeclaredRdr' nm atds + return (FN [],DN [rdrName2NamePure nm ln] <> md <> ad <> atd) + + ------------------------------ + + hstype :: GHC.LHsType GHC.RdrName -> Maybe (FreeNames,DeclaredNames) +#if __GLASGOW_HASKELL__ <= 710 + hstype (GHC.L _ (GHC.HsForAllTy _ _ _ _ typ)) = hsFreeAndDeclaredRdr' nm typ +#else + hstype (GHC.L _ (GHC.HsForAllTy _ typ)) = hsFreeAndDeclaredRdr' nm typ +#endif +#if __GLASGOW_HASKELL__ <= 710 + hstype (GHC.L l (GHC.HsTyVar n)) = return (FN [rdrName2NamePure nm (GHC.L l n)],DN []) +#else + hstype (GHC.L _ (GHC.HsTyVar n)) = return (FN [rdrName2NamePure nm n],DN []) +#endif + hstype (GHC.L _ (GHC.HsAppTy t1 t2)) = recurseList [t1,t2] + hstype (GHC.L _ (GHC.HsFunTy t1 t2)) = recurseList [t1,t2] + hstype (GHC.L _ (GHC.HsListTy typ)) = hsFreeAndDeclaredRdr' nm typ + hstype (GHC.L _ (GHC.HsPArrTy typ)) = hsFreeAndDeclaredRdr' nm typ + hstype (GHC.L _ (GHC.HsTupleTy _ typs)) = recurseList typs + hstype (GHC.L _ (GHC.HsOpTy t1 _ t2)) = recurseList [t1,t2] + hstype (GHC.L _ (GHC.HsParTy typ)) = hsFreeAndDeclaredRdr' nm typ + hstype (GHC.L _ (GHC.HsIParamTy _ typ)) = hsFreeAndDeclaredRdr' nm typ + hstype (GHC.L _ (GHC.HsEqTy t1 t2)) = recurseList [t1,t2] + hstype (GHC.L _ (GHC.HsKindSig t1 t2)) = recurseList [t1,t2] +#if __GLASGOW_HASKELL__ <= 710 + hstype (GHC.L _ (GHC.HsQuasiQuoteTy _)) = return emptyFD +#endif + hstype (GHC.L _ (GHC.HsSpliceTy _ _)) = return (FN [],DN []) + hstype (GHC.L _ (GHC.HsDocTy _ typ)) = hsFreeAndDeclaredRdr' nm typ + hstype (GHC.L _ (GHC.HsBangTy _ typ)) = hsFreeAndDeclaredRdr' nm typ + hstype (GHC.L _ (GHC.HsRecTy cons)) = recurseList cons + hstype (GHC.L _ (GHC.HsCoreTy _)) = return emptyFD + hstype (GHC.L _ (GHC.HsExplicitListTy _ typs)) = recurseList typs + hstype (GHC.L _ (GHC.HsExplicitTupleTy _ typs)) = recurseList typs + hstype (GHC.L _ (GHC.HsTyLit _)) = return emptyFD +#if __GLASGOW_HASKELL__ <= 710 + hstype (GHC.L _ (GHC.HsWrapTy _ typ)) = hsFreeAndDeclaredRdr' nm typ +#endif +#if __GLASGOW_HASKELL__ <= 710 + hstype (GHC.L _ (GHC.HsWildcardTy)) = error "To implement: hstype, HsWildcardTy" + hstype (GHC.L _ (GHC.HsNamedWildcardTy _)) = error "To implement: HsNamedWildcardTy" +#else + hstype (GHC.L _ (GHC.HsWildCardTy _)) = error "To implement: hstype, HsWildcardTy" +#endif +#if __GLASGOW_HASKELL__ > 710 + hstype (GHC.L _ (GHC.HsQualTy (GHC.L _ ctxt) ty)) = recurseList (ty:ctxt) + hstype (GHC.L _ (GHC.HsAppsTy as)) = do + fds <- mapM doApp as + return $ mconcat fds + where + doApp (GHC.L _ (GHC.HsAppInfix n)) = return (FN [rdrName2NamePure nm n],DN []) + doApp (GHC.L _ (GHC.HsAppPrefix ty)) = hstype ty +#endif + + -- --------------------------------- + + recurseList xs = do + fds <- mapM (hsFreeAndDeclaredRdr' nm) xs + return $ mconcat fds + + ------------------------------ + + addFree :: GHC.Name -> (FreeNames,DeclaredNames) + -> Maybe (FreeNames,DeclaredNames) + addFree free (FN fr,de) = return (FN $ [free] `union` fr, de) + + -- hsFreeAndDeclaredList :: (SYB.Data t) => [t] -> Maybe (FreeNames,DeclaredNames) + -- hsFreeAndDeclaredList l = do + -- fds <- mapM (hsFreeAndDeclaredRdr' nm) l + -- let + -- unionF (FN a) (FN b) = FN (a `union` b) + -- unionD (DN a) (DN b) = DN (a `union` b) + -- return (foldr unionF mempty (map fst fds), + -- foldr unionD mempty (map snd fds)) + + +-- |The same as `hsFreeAndDeclaredPNs` except that the returned +-- variables are in the String format. +hsFreeAndDeclaredNameStrings::(SYB.Data t) + => t -> RefactGhc ([String],[String]) +hsFreeAndDeclaredNameStrings t = do + (f1,d1) <- hsFreeAndDeclaredPNs t + return ((nub.map showGhc) f1, (nub.map showGhc) d1) + + +-- | Return the free and declared Names in the given syntax fragment. The syntax +-- fragment MUST be parameterised by RdrName, else the empty list will be +-- returned. +hsFreeAndDeclaredPNs :: (SYB.Data t) => t -> RefactGhc ([GHC.Name],[GHC.Name]) +hsFreeAndDeclaredPNs t = do + -- (FN f,DN d) <- hsFreeAndDeclaredGhc t + nm <- getRefactNameMap + let (FN f,DN d) = hsFreeAndDeclaredRdr nm t + return (f,d) + +-- --------------------------------------------------------------------- + +-- |Get the names of all types declared in the given declaration +-- getDeclaredTypesRdr :: GHC.LTyClDecl GHC.RdrName -> RefactGhc [GHC.Name] +getDeclaredTypesRdr :: GHC.LHsDecl GHC.RdrName -> RefactGhc [GHC.Name] +getDeclaredTypesRdr (GHC.L _ (GHC.TyClD decl)) = do + nm <- getRefactNameMap + case decl of +#if __GLASGOW_HASKELL__ <= 710 + (GHC.FamDecl (GHC.FamilyDecl _ ln _ _)) -> return [rdrName2NamePure nm ln] +#else + (GHC.FamDecl (GHC.FamilyDecl _ ln _ _ _)) -> return [rdrName2NamePure nm ln] +#endif + (GHC.SynDecl ln _ _ _) -> return [rdrName2NamePure nm ln] +#if __GLASGOW_HASKELL__ <= 710 + (GHC.DataDecl ln _ defn _) -> do + let dds = concatMap (GHC.con_names . GHC.unLoc) $ GHC.dd_cons defn +#else + (GHC.DataDecl ln _ defn _ _) -> do + let dds = concatMap (GHC.getConNames . GHC.unLoc) $ GHC.dd_cons defn +#endif + let ddns = map (rdrName2NamePure nm) dds + return $ [rdrName2NamePure nm ln] ++ ddns + + (GHC.ClassDecl _ ln _vars _fds sigs meths ats _atdefs _ _fvs) -> do + -- msn <- getMsn meths + let msn = getDeclaredVarsRdr nm (map wrapDecl $ GHC.bagToList meths) + let fds = map (GHC.fdLName . GHC.unLoc) ats + fds' = map (rdrName2NamePure nm) fds + return $ nub $ [rdrName2NamePure nm ln] ++ ssn ++ msn ++ fds' -- ++ asn + where + getLSig :: GHC.LSig GHC.RdrName -> [GHC.Name] +#if __GLASGOW_HASKELL__ <= 710 + getLSig (GHC.L _ (GHC.TypeSig ns _ _)) = map (rdrName2NamePure nm) ns +#else + getLSig (GHC.L _ (GHC.TypeSig ns _)) = map (rdrName2NamePure nm) ns +#endif +#if __GLASGOW_HASKELL__ <= 710 + getLSig (GHC.L _ (GHC.GenericSig ns _)) = map (rdrName2NamePure nm) ns +#else + getLSig (GHC.L _ (GHC.ClassOpSig _ ns _)) = map (rdrName2NamePure nm) ns +#endif + getLSig (GHC.L _ (GHC.IdSig _n)) = [] + getLSig (GHC.L _ (GHC.InlineSig ln2 _)) = [rdrName2NamePure nm ln2] + getLSig (GHC.L _ (GHC.SpecSig ln2 _ _)) = [rdrName2NamePure nm ln2] + getLSig (GHC.L _ (GHC.SpecInstSig _ _)) = [] + getLSig (GHC.L _ (GHC.FixSig _)) = [] +#if __GLASGOW_HASKELL__ <= 710 + getLSig (GHC.L _ (GHC.PatSynSig _ _ _ _ _)) = error "To implement: getLSig PatSynSig" +#else + getLSig (GHC.L _ (GHC.PatSynSig _ _)) = error "To implement: getLSig PatSynSig" +#endif + getLSig (GHC.L _ (GHC.MinimalSig _ _)) = error "To implement: getLSig PatSynSig" + + ssn = concatMap getLSig sigs +getDeclaredTypesRdr _ = return [] + +-- --------------------------------------------------------------------- + +-- | Return True if the specified Name ocuurs in the given syntax phrase. +findNameInRdr :: (SYB.Data t) => NameMap -> GHC.Name -> t -> Bool +findNameInRdr nm pn t = findNamesRdr nm [pn] t + +-- --------------------------------------------------------------------- + +-- | Return True if any of the specified PNames ocuur in the given syntax phrase. +findNamesRdr :: (SYB.Data t) => NameMap -> [GHC.Name] -> t -> Bool +findNamesRdr nm pns t = + isJust $ SYB.something (inName) t + where + -- r = (SYB.everythingStaged SYB.Parser mappend mempty (inName) t) + + checker :: GHC.Located GHC.RdrName -> Maybe Bool + checker ln + | elem (GHC.nameUnique (rdrName2NamePure nm ln)) uns = Just True + checker _ = Nothing + + inName :: (SYB.Typeable a) => a -> Maybe Bool + inName = nameSybQuery checker + + uns = map GHC.nameUnique pns + +-- --------------------------------------------------------------------- + +definedPNsRdr :: GHC.LHsDecl GHC.RdrName -> [GHC.Located GHC.RdrName] +#if __GLASGOW_HASKELL__ <= 710 +definedPNsRdr (GHC.L _ (GHC.ValD (GHC.FunBind pname _ _ _ _ _))) = [pname] +#else +definedPNsRdr (GHC.L _ (GHC.ValD (GHC.FunBind pname _ _ _ _))) = [pname] +#endif +definedPNsRdr (GHC.L _ (GHC.ValD (GHC.PatBind p _rhs _ty _fvs _))) = (hsNamessRdr p) +-- VarBind will never occur in ParsedSource +-- TODO: what about GHC.AbsBinds? +definedPNsRdr _ = [] + +-- --------------------------------------------------------------------- + +definedNamesRdr :: NameMap -> GHC.LHsDecl GHC.RdrName -> [GHC.Name] +definedNamesRdr nameMap bind = map (rdrName2NamePure nameMap) (definedPNsRdr bind) + +-- --------------------------------------------------------------------- + +-- |Find those declarations(function\/pattern binding) which define +-- the specified GHC.Names. incTypeSig indicates whether the +-- corresponding type signature will be included. +definingDeclsRdrNames:: + NameMap + ->[GHC.Name] -- ^ The specified identifiers. + ->[GHC.LHsDecl GHC.RdrName] -- ^ A collection of declarations. + ->Bool -- ^ True means to include the type signature. + ->Bool -- ^ True means to look at the local declarations as well. + ->[GHC.LHsDecl GHC.RdrName] -- ^ The result. +definingDeclsRdrNames nameMap pns ds _incTypeSig recursive = concatMap defining ds +-- ++AZ++:TODO: now we are processing decls again, reinstate incTypeSig function + where + defining decl + = if recursive + then SYB.everythingStaged SYB.Parser (++) [] ([] `SYB.mkQ` definesDecl `SYB.extQ` definesBind) decl + else definesDecl decl + where + definesDecl :: (GHC.LHsDecl GHC.RdrName) -> [GHC.LHsDecl GHC.RdrName] +#if __GLASGOW_HASKELL__ <= 710 + definesDecl decl'@(GHC.L _ (GHC.ValD (GHC.FunBind _ _ _ _ _ _))) +#else + definesDecl decl'@(GHC.L _ (GHC.ValD (GHC.FunBind _ _ _ _ _))) +#endif + | any (\n -> definesDeclRdr nameMap n decl') pns = [decl'] + + definesDecl decl'@(GHC.L _l (GHC.ValD (GHC.PatBind _p _rhs _ty _fvs _))) + | any (\n -> definesDeclRdr nameMap n decl') pns = [decl'] + + definesDecl _ = [] + + definesBind :: (GHC.LHsBind GHC.RdrName) -> [GHC.LHsDecl GHC.RdrName] + definesBind (GHC.L l b) = definesDecl (GHC.L l (GHC.ValD b)) + +-- --------------------------------------------------------------------- + +-- |Find those declarations(function\/pattern binding) which define +-- the specified GHC.Names. incTypeSig indicates whether the corresponding type +-- signature will be included. +definingDeclsRdrNames' :: (SYB.Data t) + => NameMap + -> [GHC.Name] -- ^ The specified identifiers. + -> t -- ^ A collection of declarations. + -> [GHC.LHsDecl GHC.RdrName] -- ^ The result. +definingDeclsRdrNames' nameMap pns ds = defining ds + where + defining decl + = SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` defines' `SYB.extQ` definesBind) decl + where + defines' :: (GHC.LHsDecl GHC.RdrName) -> [GHC.LHsDecl GHC.RdrName] + defines' decl'@(GHC.L _ (GHC.ValD (GHC.FunBind{}))) + | any (\n -> definesDeclRdr nameMap n decl') pns = [decl'] + + defines' decl'@(GHC.L _l (GHC.ValD (GHC.PatBind _p _rhs _ty _fvs _))) + | any (\n -> definesDeclRdr nameMap n decl') pns = [decl'] + + defines' _ = [] + + definesBind :: (GHC.LHsBind GHC.RdrName) -> [GHC.LHsDecl GHC.RdrName] + definesBind (GHC.L l b) = defines' (GHC.L l (GHC.ValD b)) + +-- --------------------------------------------------------------------- + +-- |Find those type signatures for the specified GHC.Names. +definingSigsRdrNames :: (SYB.Data t) => + NameMap + ->[GHC.Name] -- ^ The specified identifiers. + ->t -- ^ A collection of declarations. + ->[GHC.LSig GHC.RdrName] -- ^ The result. +definingSigsRdrNames nameMap pns ds = def ds + where + def decl + -- = SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` inSig) decl + = SYB.everything (++) ([] `SYB.mkQ` inSig `SYB.extQ` inSigDecl) decl + where + inSigDecl :: GHC.LHsDecl GHC.RdrName -> [GHC.LSig GHC.RdrName] + inSigDecl (GHC.L l (GHC.SigD s)) = inSig (GHC.L l s) + inSigDecl _ = [] + + inSig :: (GHC.LSig GHC.RdrName) -> [GHC.LSig GHC.RdrName] +#if __GLASGOW_HASKELL__ <= 710 + inSig (GHC.L l (GHC.TypeSig ns t p)) + | defines' ns /= [] = [(GHC.L l (GHC.TypeSig (defines' ns) t p))] +#else + inSig (GHC.L l (GHC.TypeSig ns t)) + | defines' ns /= [] = [(GHC.L l (GHC.TypeSig (defines' ns) t))] +#endif + inSig _ = [] + + defines' :: [GHC.Located GHC.RdrName] -> [GHC.Located GHC.RdrName] + defines' p + -- = filter (\(GHC.L _ n) -> n `elem` pns) p + = let + isDefined :: GHC.Located GHC.RdrName -> [GHC.Located GHC.RdrName] + isDefined ln = if (rdrName2NamePure nameMap ln) `elem` pns + then [ln] + else [] + in concatMap isDefined p + +-- --------------------------------------------------------------------- + +-- |Find those declarations which define the specified GHC.Names. +definingTyClDeclsNames:: (SYB.Data t) + => NameMap + -> [GHC.Name] -- ^ The specified identifiers. + -> t -- ^ A collection of declarations. + ->[GHC.LTyClDecl GHC.RdrName] -- ^ The result. +definingTyClDeclsNames nm pns t = defining t + where + defining decl + = SYB.everythingStaged SYB.Parser (++) [] + ([] `SYB.mkQ` defines' + `SYB.extQ` definesDecl) decl + where + defines' :: (GHC.LTyClDecl GHC.RdrName) -> [GHC.LTyClDecl GHC.RdrName] +#if __GLASGOW_HASKELL__ <= 710 + defines' decl'@(GHC.L _ (GHC.FamDecl (GHC.FamilyDecl _ pname _ _))) +#else + defines' decl'@(GHC.L _ (GHC.FamDecl (GHC.FamilyDecl _ pname _ _ _))) +#endif + | elem (GHC.nameUnique $ rdrName2NamePure nm pname) uns = [decl'] + | otherwise = [] + + defines' decl'@(GHC.L _ (GHC.SynDecl pname _ _ _)) + | elem (GHC.nameUnique $ rdrName2NamePure nm pname) uns = [decl'] + | otherwise = [] + +#if __GLASGOW_HASKELL__ <= 710 + defines' decl'@(GHC.L _ (GHC.DataDecl pname _ _ _)) +#else + defines' decl'@(GHC.L _ (GHC.DataDecl pname _ _ _ _)) +#endif + | elem (GHC.nameUnique $ rdrName2NamePure nm pname) uns = [decl'] + | otherwise = [] + + defines' decl'@(GHC.L _ (GHC.ClassDecl _ pname _ _ _ _ _ _ _ _)) + | elem (GHC.nameUnique $ rdrName2NamePure nm pname) uns = [decl'] + | otherwise = [] + + definesDecl (GHC.L l (GHC.TyClD d)) = defines' (GHC.L l d) + definesDecl _ = [] + + uns = map (\n -> GHC.nameUnique n) pns + +-- --------------------------------------------------------------------- + +-- | Return True if the function\/pattern binding defines the +-- specified identifier. +definesRdr :: NameMap -> GHC.Name -> GHC.LHsBind GHC.RdrName -> Bool +#if __GLASGOW_HASKELL__ <= 710 +definesRdr nm nin (GHC.L _ (GHC.FunBind ln _ _ _ _ _)) +#else +definesRdr nm nin (GHC.L _ (GHC.FunBind ln _ _ _ _)) +#endif + = GHC.nameUnique (rdrName2NamePure nm ln) == GHC.nameUnique nin +definesRdr nm n (GHC.L _ (GHC.PatBind p _rhs _ty _fvs _)) + = elem n (map (rdrName2NamePure nm) (hsNamessRdr p)) +definesRdr _ _ _= False + +-- |Unwraps a LHsDecl and calls definesRdr on the result if a HsBind +definesDeclRdr :: NameMap -> GHC.Name -> GHC.LHsDecl GHC.RdrName -> Bool +definesDeclRdr nameMap nin (GHC.L l (GHC.ValD d)) = definesRdr nameMap nin (GHC.L l d) +definesDeclRdr _ _ _ = False + +-- --------------------------------------------------------------------- + +-- | Return True if the declaration defines the type signature of the +-- specified identifier. +definesTypeSigRdr :: NameMap -> GHC.Name -> GHC.Sig GHC.RdrName -> Bool +#if __GLASGOW_HASKELL__ <= 710 +definesTypeSigRdr nameMap pn (GHC.TypeSig names _typ _) +#else +definesTypeSigRdr nameMap pn (GHC.TypeSig names _typ) +#endif + = elem (GHC.nameUnique pn) (map (GHC.nameUnique . rdrName2NamePure nameMap) names) +-- definesTypeSigRdr _ _ _ = False +definesTypeSigRdr _ _ x = error $ "definesTypeSigRdr : got " ++ SYB.showData SYB.Parser 0 x + +-- |Unwraps a LHsDecl and calls definesRdr on the result if a Sig +definesSigDRdr :: NameMap -> GHC.Name -> GHC.LHsDecl GHC.RdrName -> Bool +definesSigDRdr nameMap nin (GHC.L _ (GHC.SigD d)) = definesTypeSigRdr nameMap nin d +definesSigDRdr _ _ _ = False + +-- --------------------------------------------------------------------- + +-- |Get all the names in the given syntax element +hsNamessRdr :: (SYB.Data t) => t -> [GHC.Located GHC.RdrName] +hsNamessRdr t = nub $ fromMaybe [] r + where + r = (SYB.everythingStaged SYB.Parser mappend mempty (inName) t) + + checker :: GHC.Located GHC.RdrName -> Maybe [GHC.Located GHC.RdrName] + checker x = Just [x] + + inName :: (SYB.Typeable a) => a -> Maybe [GHC.Located GHC.RdrName] + inName = nameSybQuery checker + +-- --------------------------------------------------------------------- + +-- |Does the given 'GHC.Name' appear as a 'GHC.Located' 'GHC.RdrName' anywhere in 't'? +findLRdrName :: (SYB.Data t) => NameMap -> GHC.Name -> t -> Bool +findLRdrName nm n t = isJust $ SYB.something isMatch t + where + checker :: GHC.Located GHC.RdrName -> Maybe Bool + checker x + | GHC.nameUnique (rdrName2NamePure nm x) == GHC.nameUnique n = Just True + | otherwise = Nothing + + isMatch :: (SYB.Typeable a) => a -> Maybe Bool + isMatch = nameSybQuery checker + +-- --------------------------------------------------------------------- + + +getDeclaredVarsRdr :: NameMap -> [GHC.LHsDecl GHC.RdrName] -> [GHC.Name] +getDeclaredVarsRdr nm bs = concatMap vars bs + where + vars :: (GHC.LHsDecl GHC.RdrName) -> [GHC.Name] +#if __GLASGOW_HASKELL__ <= 710 + vars (GHC.L _ (GHC.ValD (GHC.FunBind ln _ _ _ _fvs _))) = [rdrName2NamePure nm ln] +#else + vars (GHC.L _ (GHC.ValD (GHC.FunBind ln _ _ _ _fvs))) = [rdrName2NamePure nm ln] +#endif + vars (GHC.L _ (GHC.ValD (GHC.PatBind p _rhs _ty _fvs _))) = (map (rdrName2NamePure nm) $ hsNamessRdr p) + vars _ = [] + +-------------------------------------------------------------------------------- +-- | Same as `hsVisiblePNsRdr' except that the returned identifiers are +-- in String format. +hsVisibleNamesRdr:: (SYB.Data t2) + => GHC.Name -> t2 -> RefactGhc [String] +hsVisibleNamesRdr e t = do + nm <- getRefactNameMap + (DN d) <- hsVisibleDsRdr nm e t + return ((nub . map showGhc) d) + +------------------------------------------------------------------------ + +-- | Given a 'Name' n and a syntax phrase t, if n occurs in t, then return those +-- variables which are declared in t and accessible to n, otherwise +-- return []. +hsVisibleDsRdr :: (SYB.Data t) + => NameMap -> GHC.Name -> t -> RefactGhc DeclaredNames +hsVisibleDsRdr nm e t = do + -- logm $ "hsVisibleDsRdr:(e,t)=" ++ (SYB.showData SYB.Renamer 0 (e,t)) + (DN d) <- res + return (DN (nub d)) + where + -- TODO: this is effectively a recursive descent approach, where + -- each syntax element processor knows exactly what it needs + -- in terms of sub-elements. Hence as an optimisation, + -- consider calling the relevent element directly, instead + -- of looping back into the main function. + res = (const err -- (DN []) + `SYB.extQ` parsed + `SYB.extQ` lvalbinds + `SYB.extQ` valbinds + `SYB.extQ` lhsdecls + `SYB.extQ` lhsdecl + `SYB.extQ` lhsbindslr + `SYB.extQ` hsbinds + `SYB.extQ` hsbind + `SYB.extQ` hslocalbinds + `SYB.extQ` lmatch + `SYB.extQ` grhss + `SYB.extQ` lgrhs + `SYB.extQ` lexpr + `SYB.extQ` tyclgroups + `SYB.extQ` tyclgroup + `SYB.extQ` tycldeclss + `SYB.extQ` tycldecls + `SYB.extQ` tycldecl + `SYB.extQ` instdecls + `SYB.extQ` instdecl + `SYB.extQ` lhstype + `SYB.extQ` lsigs + `SYB.extQ` lsig + `SYB.extQ` lstmts + `SYB.extQ` lstmt + `SYB.extQ` lpats + `SYB.extQ` lpat +#if __GLASGOW_HASKELL__ > 710 + `SYB.extQ` ibndrs + `SYB.extQ` lsigty +#endif + ) t + + -- err2 = error $ "hsVisibleDsRdr:err2:no match for:" ++ (SYB.showData SYB.Renamer 0 t) + + parsed :: GHC.ParsedSource -> RefactGhc DeclaredNames + parsed p + | findNameInRdr nm e p = do + -- dfds <- mapM (hsVisibleDsRdr nm e) $ GHC.hsmodDecls $ GHC.unLoc p + logm $ "hsVisibleDsRdr parsedSource:decls starting" + dfds <- mapM (declFun ( hsVisibleDsRdr nm e) ) $ GHC.hsmodDecls $ GHC.unLoc p + logm $ "hsVisibleDsRdr parsedSource:decls done" + return $ mconcat dfds + parsed _ = return (DN []) + + lvalbinds :: (GHC.Located (GHC.HsLocalBinds GHC.RdrName)) -> RefactGhc DeclaredNames + lvalbinds (GHC.L _ (GHC.HsValBinds vb)) = valbinds vb + lvalbinds (GHC.L _ (GHC.HsIPBinds _)) = return (DN []) + lvalbinds (GHC.L _ GHC.EmptyLocalBinds) = return (DN []) + + valbinds :: (GHC.HsValBinds GHC.RdrName) -> RefactGhc DeclaredNames + valbinds vb@(GHC.ValBindsIn bindsBag sigs) + | findNameInRdr nm e vb = do + fdsb <- mapM (hsVisibleDsRdr nm e) $ GHC.bagToList bindsBag + fdss <- mapM (hsVisibleDsRdr nm e) sigs + return $ mconcat fdss <> mconcat fdsb + valbinds vb@(GHC.ValBindsOut _binds _sigs) + | findNameInRdr nm e vb = do + logm $ "hsVisibleDsRdr valbinds:ValBindsOut:impossible for RdrName" + return (DN []) + + valbinds _ = do + logm $ "hsVisibleDsRdr nm.valbinds:not matched" + return (DN []) + + lhsdecls :: [GHC.LHsDecl GHC.RdrName] -> RefactGhc DeclaredNames + lhsdecls ds + | findNameInRdr nm e ds = do + dfds <- mapM (declFun ( hsVisibleDsRdr nm e) ) ds + return $ mconcat dfds + lhsdecls _ = return (DN []) + + lhsdecl :: GHC.LHsDecl GHC.RdrName -> RefactGhc DeclaredNames + lhsdecl (GHC.L l dd) = do + logm $ "hsVisibleDsRdr.lhsdecl" + case dd of + GHC.TyClD d -> hsVisibleDsRdr nm e (GHC.L l d) + GHC.InstD d -> hsVisibleDsRdr nm e (GHC.L l d) + GHC.DerivD d -> hsVisibleDsRdr nm e (GHC.L l d) + GHC.ValD d -> hsVisibleDsRdr nm e (GHC.L l d) + GHC.SigD d -> hsVisibleDsRdr nm e (GHC.L l d) + GHC.DefD d -> hsVisibleDsRdr nm e (GHC.L l d) + GHC.ForD d -> hsVisibleDsRdr nm e (GHC.L l d) + GHC.WarningD d -> hsVisibleDsRdr nm e (GHC.L l d) + GHC.AnnD d -> hsVisibleDsRdr nm e (GHC.L l d) + GHC.RuleD d -> hsVisibleDsRdr nm e (GHC.L l d) + GHC.VectD d -> hsVisibleDsRdr nm e (GHC.L l d) + GHC.SpliceD d -> hsVisibleDsRdr nm e (GHC.L l d) + GHC.DocD d -> hsVisibleDsRdr nm e (GHC.L l d) + GHC.RoleAnnotD d -> hsVisibleDsRdr nm e (GHC.L l d) +#if __GLASGOW_HASKELL__ < 711 + GHC.QuasiQuoteD d -> hsVisibleDsRdr nm e (GHC.L l d) +#endif + + lhsbindslr :: GHC.LHsBinds GHC.RdrName -> RefactGhc DeclaredNames + lhsbindslr bs = do + fds <- mapM (hsVisibleDsRdr nm e) $ GHC.bagToList bs + return $ mconcat fds + + hsbinds :: [GHC.LHsBind GHC.RdrName] -> RefactGhc DeclaredNames + hsbinds ds + | findNameInRdr nm e ds = do + fds <- mapM (hsVisibleDsRdr nm e) ds + return $ mconcat fds + hsbinds _ = return (DN []) + + hsbind :: (GHC.LHsBind GHC.RdrName) -> RefactGhc DeclaredNames +#if __GLASGOW_HASKELL__ <= 710 + hsbind ((GHC.L _ (GHC.FunBind _n _ (GHC.MG matches _ _ _) _ _ _))) +#else + hsbind ((GHC.L _ (GHC.FunBind _n (GHC.MG (GHC.L _ matches) _ _ _) _ _ _))) +#endif + | findNameInRdr nm e matches = do + fds <- mapM (hsVisibleDsRdr nm e) matches + logm $ "hsVisibleDsRdr.hsbind:fds=" ++ show fds + return $ mconcat fds + hsbind _ = do + -- logm $ "hsVisibleDsRdr.hsbind:miss" + return (DN []) + + + hslocalbinds :: (GHC.HsLocalBinds GHC.RdrName) -> RefactGhc DeclaredNames + hslocalbinds (GHC.HsValBinds binds) + | findNameInRdr nm e binds = hsVisibleDsRdr nm e binds + hslocalbinds (GHC.HsIPBinds binds) + | findNameInRdr nm e binds = hsVisibleDsRdr nm e binds + hslocalbinds (GHC.EmptyLocalBinds) = return (DN []) + hslocalbinds _ = return (DN []) + + lmatch :: (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) -> RefactGhc DeclaredNames + lmatch (GHC.L _ (GHC.Match _fn pats _mtyp rhs)) + | findNameInRdr nm e pats = do + logm $ "hsVisibleDsRdr nm.lmatch:in pats=" + return (DN []) -- TODO: extend this + | findNameInRdr nm e rhs = do + logm $ "hsVisibleDsRdr nm.lmatch:doing rhs" + let (pf,pd) = hsFreeAndDeclaredRdr nm pats + logm $ "hsVisibleDsRdr nm.lmatch:(pf,pd)=" ++ (show (pf,pd)) + ( rd) <- hsVisibleDsRdr nm e rhs + return (pd <> rd) + lmatch _ =return (DN []) + + grhss :: (GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName)) -> RefactGhc DeclaredNames + grhss (GHC.GRHSs guardedRhss lstmts') + | findNameInRdr nm e guardedRhss = do + logm "hsVisibleDsRdr nm.grhss:about to do grhss" + fds <- mapM (hsVisibleDsRdr nm e) guardedRhss + logm "hsVisibleDsRdr nm.grhss:grhss done" + return $ mconcat fds + | findNameInRdr nm e lstmts' = do + logm "hsVisibleDsRdr nm.grhss:about to do lstmts" + hsVisibleDsRdr nm e lstmts' + grhss _ = return (DN []) + + lgrhs :: GHC.LGRHS GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> RefactGhc DeclaredNames + lgrhs (GHC.L _ (GHC.GRHS guards ex)) + | findNameInRdr nm e guards = logm "hsVisibleDsRdr nm.lgrhs.guards" >> hsVisibleDsRdr nm e guards + | findNameInRdr nm e ex = logm "hsVisibleDsRdr nm.lgrhs.ex" >> hsVisibleDsRdr nm e ex + lgrhs _ = return (DN []) + + + lexpr :: GHC.LHsExpr GHC.RdrName -> RefactGhc DeclaredNames +#if __GLASGOW_HASKELL__ <= 710 + lexpr (GHC.L l (GHC.HsVar n)) +#else + lexpr (GHC.L l (GHC.HsVar (GHC.L _ n))) +#endif + | findNameInRdr nm e n = do + logm $ "hsVisibleDsRdr.lexpr.HsVar entity found" + return (DN [rdrName2NamePure nm (GHC.L l n)]) + lexpr (GHC.L _ (GHC.HsLet lbinds expr)) + | findNameInRdr nm e lbinds || findNameInRdr nm e expr = do + logm $ "hsVisibleDsRdr.lexpr.HsLet entity found" + let (_,lds) = hsFreeAndDeclaredRdr nm lbinds + let (_,eds) = hsFreeAndDeclaredRdr nm expr + return $ lds <> eds + + lexpr expr + | findNameInRdr nm e expr = do + logm $ "hsVisibleDsRdr nm.lexpr.(e,expr):" ++ (showGhc (e,expr)) + let (FN efs,_) = hsFreeAndDeclaredRdr nm expr + let (FN _eefs,DN eeds) = hsFreeAndDeclaredRdr nm e + logm $ "hsVisibleDsRdr nm.lexpr done" + -- return (DN e1fs <> DN eofs <> DN e2fs) + return (DN (efs \\ eeds)) + + lexpr x = do + logm $ "hsVisibleDsRdr.lexpr:miss for:" ++ SYB.showData SYB.Parser 0 x + return (DN []) + + -- --------------------------------- + + tyclgroups :: [GHC.TyClGroup GHC.RdrName] -> RefactGhc DeclaredNames + tyclgroups tgrps + | findNameInRdr nm e tgrps = do + fds <- mapM (hsVisibleDsRdr nm e) tgrps + return $ mconcat fds + tyclgroups _ = return (DN []) + + tyclgroup :: GHC.TyClGroup GHC.RdrName -> RefactGhc DeclaredNames + tyclgroup (GHC.TyClGroup tyclds _roles) + | findNameInRdr nm e tyclds = do + fds <- mapM (hsVisibleDsRdr nm e) tyclds + return $ mconcat fds + tyclgroup _ = return (DN []) + + tycldeclss :: [[GHC.LTyClDecl GHC.RdrName]] -> RefactGhc DeclaredNames + tycldeclss tcds + | findNameInRdr nm e tcds = do + fds <- mapM (hsVisibleDsRdr nm e) tcds + return $ mconcat fds + tycldeclss _ = return (DN []) + + tycldecls :: [GHC.LTyClDecl GHC.RdrName] -> RefactGhc DeclaredNames + tycldecls tcds + | findNameInRdr nm e tcds = do + logm $ "hsVisibleDsRdr.tycldecls" + fds <- mapM (hsVisibleDsRdr nm e) tcds + logm $ "hsVisibleDsRdr.tycldecls done" + return $ mconcat fds + tycldecls _ = return (DN []) + + tycldecl :: GHC.LTyClDecl GHC.RdrName -> RefactGhc DeclaredNames + tycldecl tcd + | findNameInRdr nm e tcd = do + logm $ "hsVisibleDsRdr.tycldecl" + let (_,ds) = hsFreeAndDeclaredRdr nm tcd + logm $ "hsVisibleDsRdr.tycldecl done" + return ds + tycldecl _ = return (DN []) + + -- --------------------------------- + + instdecls :: [GHC.LInstDecl GHC.RdrName] -> RefactGhc DeclaredNames + instdecls ds + | findNameInRdr nm e ds = do + fds <- mapM (hsVisibleDsRdr nm e) ds + return $ mconcat fds + instdecls _ = return (DN []) + + instdecl :: GHC.LInstDecl GHC.RdrName -> RefactGhc DeclaredNames + instdecl (GHC.L _ (GHC.ClsInstD (GHC.ClsInstDecl polytyp binds sigs tyfaminsts dfaminsts _))) + | findNameInRdr nm e polytyp = hsVisibleDsRdr nm e polytyp + | findNameInRdr nm e binds = hsVisibleDsRdr nm e binds + | findNameInRdr nm e sigs = hsVisibleDsRdr nm e sigs + | findNameInRdr nm e tyfaminsts = hsVisibleDsRdr nm e tyfaminsts + | findNameInRdr nm e dfaminsts = hsVisibleDsRdr nm e dfaminsts + | otherwise = return (DN []) + instdecl (GHC.L _ (GHC.DataFamInstD (GHC.DataFamInstDecl _ln pats defn _))) + | findNameInRdr nm e pats = hsVisibleDsRdr nm e pats + | findNameInRdr nm e defn = hsVisibleDsRdr nm e defn + | otherwise = return (DN []) + instdecl (GHC.L _ (GHC.TyFamInstD (GHC.TyFamInstDecl eqn _))) + | findNameInRdr nm e eqn = hsVisibleDsRdr nm e eqn + | otherwise = return (DN []) + + lhstype :: GHC.LHsType GHC.RdrName -> RefactGhc DeclaredNames +#if __GLASGOW_HASKELL__ <= 710 + lhstype tv@(GHC.L l (GHC.HsTyVar n)) +#else + lhstype tv@(GHC.L l (GHC.HsTyVar (GHC.L _ n))) +#endif + | findNameInRdr nm e tv = return (DN [rdrName2NamePure nm (GHC.L l n)]) + | otherwise = return (DN []) + lhstype (GHC.L _ (GHC.HsForAllTy {})) + = return (DN []) + lhstype (GHC.L _ (GHC.HsFunTy{})) = return (DN []) + lhstype ty = do + logm $ "lshtype: TypeUtils 1588" ++ SYB.showData SYB.Renamer 0 ty + return (DN []) + + -- ----------------------- + + lsigs :: [GHC.LSig GHC.RdrName] -> RefactGhc DeclaredNames + lsigs ss = do + fds <- mapM (hsVisibleDsRdr nm e) ss + return $ mconcat fds + + -- ----------------------- + + lsig :: GHC.LSig GHC.RdrName -> RefactGhc DeclaredNames +#if __GLASGOW_HASKELL__ <= 710 + lsig (GHC.L _ (GHC.TypeSig _ns typ _)) +#else + lsig (GHC.L _ (GHC.TypeSig _ns typ)) +#endif + | findNameInRdr nm e typ = hsVisibleDsRdr nm e typ +#if __GLASGOW_HASKELL__ <= 710 + lsig (GHC.L _ (GHC.GenericSig _n typ)) +#else + lsig (GHC.L _ (GHC.ClassOpSig _ _n (GHC.HsIB _ typ))) +#endif + | findNameInRdr nm e typ = hsVisibleDsRdr nm e typ + lsig (GHC.L _ (GHC.IdSig _)) = return (DN []) + lsig (GHC.L _ (GHC.InlineSig _ _)) = return (DN []) + lsig (GHC.L _ (GHC.SpecSig _n typ _)) + | findNameInRdr nm e typ = hsVisibleDsRdr nm e typ + lsig (GHC.L _ (GHC.SpecInstSig _ _)) = return (DN []) + + lsig _ = return (DN []) + + -- ----------------------- + + lstmts :: [GHC.LStmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)] -> RefactGhc DeclaredNames + lstmts ds + | findNameInRdr nm e ds = do + fds <- mapM (hsVisibleDsRdr nm e) ds + return $ mconcat fds + lstmts _ = return (DN []) + + -- ----------------------- + + lstmt :: GHC.LStmt GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> RefactGhc DeclaredNames +#if __GLASGOW_HASKELL__ <= 710 + lstmt (GHC.L _ (GHC.LastStmt ex _)) = hsVisibleDsRdr nm e ex +#else + lstmt (GHC.L _ (GHC.LastStmt ex _ _)) = hsVisibleDsRdr nm e ex +#endif +#if __GLASGOW_HASKELL__ <= 710 + lstmt (GHC.L _ (GHC.BindStmt pa ex _ _)) = do +#else + lstmt (GHC.L _ (GHC.BindStmt pa ex _ _ _)) = do +#endif + fdp <- hsVisibleDsRdr nm e pa + fde <- hsVisibleDsRdr nm e ex + return (fdp <> fde) + lstmt (GHC.L _ (GHC.BodyStmt ex _ _ _)) = hsVisibleDsRdr nm e ex + + lstmt (GHC.L _ (GHC.LetStmt bs)) = hsVisibleDsRdr nm e bs +#if __GLASGOW_HASKELL__ <= 710 + lstmt (GHC.L _ (GHC.ParStmt ps _ _)) = hsVisibleDsRdr nm e ps +#else + lstmt (GHC.L _ (GHC.ParStmt ps _ _ _)) = hsVisibleDsRdr nm e ps +#endif +#if __GLASGOW_HASKELL__ <= 710 + lstmt (GHC.L _ (GHC.TransStmt _ stmts _ using mby _ _ _)) = do +#else + lstmt (GHC.L _ (GHC.TransStmt _ stmts _ using mby _ _ _ _)) = do +#endif + fds <- hsVisibleDsRdr nm e stmts + fdu <- hsVisibleDsRdr nm e using + fdb <- case mby of + Nothing -> return (DN []) + Just ex -> hsVisibleDsRdr nm e ex + return $ fds <> fdu <> fdb +#if __GLASGOW_HASKELL__ <= 710 + lstmt (GHC.L _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _)) = hsVisibleDsRdr nm e stmts +#else + lstmt (GHC.L _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _ _)) = hsVisibleDsRdr nm e stmts +#endif + +#if __GLASGOW_HASKELL__ > 710 + lstmt (GHC.L _ (GHC.ApplicativeStmt {})) = return mempty +#endif + -- lstmt _ = return (DN []) + + -- ----------------------- + + lpats :: [GHC.LPat GHC.RdrName] -> RefactGhc DeclaredNames + lpats ps + | findNameInRdr nm e ps = do + fds <- mapM (hsVisibleDsRdr nm e) ps + return $ mconcat fds + lpats _ = return (DN []) + + -- ----------------------- + + lpat :: GHC.LPat GHC.RdrName -> RefactGhc DeclaredNames + lpat (GHC.L _ (GHC.WildPat _)) = return (DN []) +#if __GLASGOW_HASKELL__ <= 710 + lpat (GHC.L l (GHC.VarPat n)) +#else + lpat (GHC.L l (GHC.VarPat (GHC.L _ n))) +#endif + = return (DN [rdrName2NamePure nm (GHC.L l n)]) + lpat (GHC.L _ (GHC.AsPat ln p)) = do + (DN dp) <- lpat p + return (DN (rdrName2NamePure nm ln:dp)) + + lpat (GHC.L _ (GHC.ParPat p)) = lpat p + lpat (GHC.L _ (GHC.BangPat p)) = lpat p + lpat (GHC.L _ (GHC.ListPat ps _ _)) = do + fds <- mapM lpat ps + return $ mconcat fds + lpat (GHC.L _ (GHC.TuplePat ps _ _)) = do + fds <- mapM lpat ps + return $ mconcat fds + lpat (GHC.L _ (GHC.PArrPat ps _)) = do + fds <- mapM lpat ps + return $ mconcat fds + lpat (GHC.L _ (GHC.ConPatIn n det)) = do + -- logm $ "hsFreeAndDeclaredGhc.lpat.ConPatIn:details=" ++ (SYB.showData SYB.Renamer 0 det) + (DN d) <- details det + return $ (DN (rdrName2NamePure nm n:d)) + -- lpat (GHC.ConPatOut ) + lpat (GHC.L _ (GHC.ViewPat ex p _)) = do + fde <- hsVisibleDsRdr nm e ex + fdp <- lpat p + return $ fde <> fdp + -- lpat (GHC.QuasiQuotePat _) + lpat (GHC.L _ (GHC.LitPat _)) = return (DN []) +#if __GLASGOW_HASKELL__ <= 710 + lpat (GHC.L _ (GHC.NPat _ _ _)) = return (DN []) + lpat (GHC.L _ (GHC.NPlusKPat n _ _ _)) = return (DN [rdrName2NamePure nm n]) +#else + lpat (GHC.L _ (GHC.NPat _ _ _ _)) = return (DN []) + lpat (GHC.L _ (GHC.NPlusKPat n _ _ _ _ _)) = return (DN [rdrName2NamePure nm n]) +#endif + lpat (GHC.L _ _p@(GHC.SigPatIn p b)) = do + dp <- lpat p + db <- hsVisibleDsRdr nm e b + -- error $ "lpat.SigPatIn:(b,fb,db)" ++ showGhc (b,fb,db) + return $ dp <> db + lpat (GHC.L _ (GHC.SigPatOut p _)) = lpat p + lpat (GHC.L l (GHC.CoPat _ p _)) = lpat (GHC.L l p) + + lpat (GHC.L _ (GHC.LazyPat p)) = lpat p + lpat (GHC.L _ (GHC.ConPatOut {})) = error $ "hsFreeAndDeclared.lpat:impossible GHC.ConPatOut" +#if __GLASGOW_HASKELL__ <= 710 + lpat (GHC.L _ (GHC.QuasiQuotePat _)) = return mempty + lpat (GHC.L _ (GHC.SplicePat (GHC.HsSplice _ expr))) = hsVisibleDsRdr nm e expr +#else + lpat (GHC.L _ (GHC.SplicePat (GHC.HsTypedSplice _ expr))) = hsVisibleDsRdr nm e expr + lpat (GHC.L _ (GHC.SplicePat (GHC.HsUntypedSplice _ expr))) = hsVisibleDsRdr nm e expr + lpat (GHC.L _ (GHC.SplicePat (GHC.HsQuasiQuote {}))) = return mempty +#endif + + -- --------------------------- + + details :: GHC.HsConPatDetails GHC.RdrName -> RefactGhc DeclaredNames + details (GHC.PrefixCon args) = do + -- logm $ "hsFreeAndDeclaredGhc.details:args=" ++ (showGhc args) + fds <- mapM lpat args + return $ mconcat fds + details (GHC.RecCon recf) = + recfields recf + details (GHC.InfixCon arg1 arg2) = do + fds <- mapM lpat [arg1,arg2] + return $ mconcat fds + + -- Note: this one applies to HsRecFields in LPats + recfields :: (GHC.HsRecFields GHC.RdrName (GHC.LPat GHC.RdrName)) -> RefactGhc DeclaredNames + recfields (GHC.HsRecFields fields _) = do + let args = map (\(GHC.L _ (GHC.HsRecField _ arg _)) -> arg) fields + fds <- mapM lpat args + return $ mconcat fds + + -- ----------------------- +#if __GLASGOW_HASKELL__ > 710 + ibndrs :: GHC.LHsSigWcType GHC.RdrName -> RefactGhc DeclaredNames + ibndrs (GHC.HsIB _ (GHC.HsWC _ _ ty)) = hsVisibleDsRdr nm e ty + + lsigty :: GHC.LHsSigType GHC.RdrName -> RefactGhc DeclaredNames + lsigty (GHC.HsIB _ ty) = hsVisibleDsRdr nm e ty +#endif + -- ----------------------- + + err = error $ "hsVisibleDsRdr nm:no match for:" ++ (SYB.showData SYB.Parser 0 t) + +-- --------------------------------------------------------------------- + +-- |`hsFDsFromInsideRdr` is different from `hsFreeAndDeclaredPNs` in +-- that: given an syntax phrase t, `hsFDsFromInsideRdr` returns not only +-- the declared variables that are visible from outside of t, but also +-- those declared variables that are visible to the main expression +-- inside t. +-- NOTE: Expects to be given ParsedSource +hsFDsFromInsideRdr :: (SYB.Data t) + => NameMap -> t -> (FreeNames,DeclaredNames) +hsFDsFromInsideRdr nm t = hsFDsFromInsideRdr' t + where + hsFDsFromInsideRdr' :: (SYB.Data t) => t -> (FreeNames,DeclaredNames) + hsFDsFromInsideRdr' t1 = (FN $ nub f', DN $ nub d') + where + r1 = applyTU (once_tdTU (failTU `adhocTU` parsed + `adhocTU` decl + `adhocTU` match + `adhocTU` expr + `adhocTU` stmts )) t1 + -- let (f',d') = fromMaybe ([],[]) r1 + (FN f',DN d') = fromMaybe (FN [],DN []) r1 + -- (FN f',DN d') = r1 + + parsed :: GHC.ParsedSource -> Maybe (FreeNames,DeclaredNames) + parsed p = return $ hsFreeAndDeclaredRdr nm p + + -- ---------------------- + + match :: GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> Maybe (FreeNames,DeclaredNames) + match (GHC.Match _fn pats _type rhs) = do + let (FN pf, DN pd) = hsFreeAndDeclaredRdr nm pats + (FN rf, DN rd) = hsFreeAndDeclaredRdr nm rhs + return (FN $ nub (pf `union` (rf \\ pd)), + DN $ nub (pd `union` rd)) + + -- ---------------------- + + decl :: GHC.HsBind GHC.RdrName -> Maybe (FreeNames,DeclaredNames) +#if __GLASGOW_HASKELL__ <= 710 + decl (GHC.FunBind (GHC.L _ _) _ (GHC.MG matches _ _ _) _ _ _) = do +#else + decl (GHC.FunBind (GHC.L _ _) (GHC.MG (GHC.L _ matches) _ _ _) _ _ _) = do +#endif + let + fds = map hsFDsFromInsideRdr' matches + -- error (show $ nameToString n) + return (FN $ nub (concat $ map (fn . fst) fds), DN $ nub (concat $ map (dn . snd) fds)) + + decl ((GHC.PatBind p rhs _ _ _) :: GHC.HsBind GHC.RdrName) = do + let + (FN pf, DN pd) = hsFreeAndDeclaredRdr nm p + (FN rf, DN rd) = hsFreeAndDeclaredRdr nm rhs + return + (FN $ nub (pf `union` (rf \\ pd)), + DN $ nub (pd `union` rd)) + + decl ((GHC.VarBind p rhs _) :: GHC.HsBind GHC.RdrName) = do + let + (FN pf, DN pd) = hsFreeAndDeclaredRdr nm p + (FN rf, DN rd) = hsFreeAndDeclaredRdr nm rhs + return + (FN $ nub (pf `union` (rf \\ pd)), + DN $ nub (pd `union` rd)) + + decl _ = mzero + + -- ---------------------- + + expr ((GHC.HsLet decls e) :: GHC.HsExpr GHC.RdrName) = do + let + (FN df,DN dd) = hsFreeAndDeclaredRdr nm decls + (FN ef,_) = hsFreeAndDeclaredRdr nm e + return (FN $ nub (df `union` (ef \\ dd)), DN $ nub dd) + + expr ((GHC.HsLam (GHC.MG matches _ _ _)) :: GHC.HsExpr GHC.RdrName) = + return $ hsFreeAndDeclaredRdr nm matches + + expr ((GHC.HsCase e (GHC.MG matches _ _ _)) :: GHC.HsExpr GHC.RdrName) = do + let + (FN ef,_) = hsFreeAndDeclaredRdr nm e + (FN df,DN dd) = hsFreeAndDeclaredRdr nm matches + return (FN $ nub (df `union` (ef \\ dd)), DN $ nub dd) + + expr _ = return (FN [],DN []) + +#if __GLASGOW_HASKELL__ <= 710 + stmts ((GHC.BindStmt pat e1 e2 e3) :: GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = do +#else + stmts ((GHC.BindStmt pat e1 e2 e3 _) :: GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = do +#endif + let + (FN pf,DN pd) = hsFreeAndDeclaredRdr nm pat + (FN ef,DN _ed) = hsFreeAndDeclaredRdr nm e1 + (FN df,DN dd) = hsFreeAndDeclaredRdr nm [e2,e3] + return + (FN $ nub (pf `union` (((ef \\ dd) `union` df) \\ pd)), DN $ nub (pd `union` dd)) + + stmts ((GHC.LetStmt binds) :: GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = + return $ hsFreeAndDeclaredRdr nm binds + + stmts _ = return (FN [],DN []) + + +-- --------------------------------------------------------------------- + +-- | The same as `hsFDsFromInside` except that the returned variables +-- are in the String format +hsFDNamesFromInsideRdr ::(SYB.Data t) => t -> RefactGhc ([String],[String]) +hsFDNamesFromInsideRdr t = do + nm <- getRefactNameMap + return (hsFDNamesFromInsideRdrPure nm t) + -- (FN f,DN d) <- hsFDsFromInsideRdr nm t + -- return ((nub.map showGhc) f, (nub.map showGhc) d) + +-- | The same as `hsFDsFromInside` except that the returned variables +-- are in the String format +hsFDNamesFromInsideRdrPure :: (SYB.Data t) => NameMap -> t -> ([String],[String]) +hsFDNamesFromInsideRdrPure nm t = ((nub.map showGhc) f, (nub.map showGhc) d) + where + (FN f,DN d) = hsFDsFromInsideRdr nm t + +-- --------------------------------------------------------------------- + +rdrName2Name :: GHC.Located GHC.RdrName -> RefactGhc GHC.Name +rdrName2Name ln = do + nameMap <- getRefactNameMap + return (rdrName2NamePure nameMap ln) + +rdrName2NamePure :: NameMap -> GHC.Located GHC.RdrName -> GHC.Name +rdrName2NamePure _nameMap (GHC.L _ (GHC.Exact n)) = n +rdrName2NamePure nameMap (GHC.L lrn _) = + fromMaybe (error $ "rdrName2NamePure: no name found for" ++ showGhc lrn) + -- fromMaybe (error $ "rdrName2NamePure: no name found for (lrn,e,nameMap)=" ++ showGhc (lrn,e,nameMap)) + (Map.lookup lrn nameMap) + +eqRdrNamePure :: NameMap -> GHC.Located GHC.RdrName -> GHC.Name -> Bool +eqRdrNamePure nameMap rn n + = GHC.nameUnique (rdrName2NamePure nameMap rn) == GHC.nameUnique n + +-- --------------------------------------------------------------------- + +-- |Find the identifier(in GHC.Name format) whose start position is +-- (row,col) in the file specified by the fileName, and returns +-- `Nothing` if such an identifier does not exist. +locToNameRdr :: (SYB.Data t) + => SimpPos -- ^ The row and column number + -> t -- ^ The syntax phrase, parameterised by RdrName + -> RefactGhc (Maybe GHC.Name) -- ^ The result +locToNameRdr pos t = do + nm <- getRefactNameMap + let mn = locToRdrName pos t + return $ fmap (rdrName2NamePure nm) mn + +-- |Find the identifier(in GHC.Name format) whose start position is +-- (row,col) in the file specified by the fileName, and returns +-- `Nothing` if such an identifier does not exist. +locToNameRdrPure :: (SYB.Data t) + => NameMap + -> SimpPos -- ^ The row and column number + -> t -- ^ The syntax phrase, parameterised by RdrName + -> Maybe GHC.Name -- ^ The result +locToNameRdrPure nm pos t = + let mn = locToRdrName pos t + in fmap (rdrName2NamePure nm) mn + +-- |Find the identifier(in GHC.RdrName format) whose start position is +-- (row,col) in the file specified by the fileName, and returns +-- `Nothing` if such an identifier does not exist. +locToRdrName::(SYB.Data t) + =>SimpPos -- ^ The row and column number + ->t -- ^ The syntax phrase + -> Maybe (GHC.Located GHC.RdrName) -- ^ The result +locToRdrName (row,col) t = locToName' (row,col) t + + +-- |Worker for both locToName and locToRdrName. +-- NOTE: provides for FunBind MatchGroups where only the first name is +-- retained in the AST + +locToName':: forall a t.(SYB.Data t, SYB.Data a) + =>SimpPos -- ^ The row and column number + ->t -- ^ The syntax phrase + -> Maybe (GHC.Located a) -- ^ The result +locToName' (row,col) t = res1 + where + res1 :: Maybe (GHC.Located a) + res1 = SYB.something (nameSybQuery checker) t + + checker pnt = + -- trace ("locToName':pnt=" ++ show (GHC.getLoc pnt)) $ if inScope pnt then Just pnt else Nothing diff --git a/src/MainHaRe.hs b/src/MainHaRe.hs --- a/src/MainHaRe.hs +++ b/src/MainHaRe.hs @@ -1,156 +1,297 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +import Control.Exception +import Control.Monad.Writer.Lazy +import Data.List +import Data.Version +import Development.GitRev (gitCommitCount) +import Distribution.System (buildArch) +import Distribution.Text (display) +import Language.Haskell.Refact.API +import Language.Haskell.Refact.HaRe +import Options.Applicative.Simple +import qualified Language.Haskell.GhcMod as GM +import qualified Paths_HaRe as Meta --- Based on --- https://github.com/kazu-yamamoto/ghc-mod/blob/master/src/GHCMod.hs +-- temporary until exposed by ghc-mod +-- import Options +import Language.Haskell.GhcMod.Options.Options -import Control.Exception -import Data.List -import Data.Typeable -import Data.Version -import Language.Haskell.GhcMod -import Language.Haskell.Refact.HaRe -import Paths_HaRe -import Prelude -import System.Console.GetOpt -import System.Environment (getArgs) -import System.IO (hPutStr, hPutStrLn, stdout, stderr, hSetEncoding, utf8) +main :: IO () +main = do + -- Version code from stack. Maybe move this stuff into optparse-simple ? + let commitCount = $gitCommitCount + versionString' = concat $ concat + [ [$(simpleVersion Meta.version)] + -- Leave out number of commits for --depth=1 clone + -- See https://github.com/commercialhaskell/stack/issues/792 + , [" (" ++ commitCount ++ " commits)" | commitCount /= ("1"::String) && + commitCount /= ("UNKNOWN" :: String)] + , [" ", display buildArch] + ] + numericVersion :: Parser (a -> a) + numericVersion = + infoOption + (showVersion Meta.version) + (long "numeric-version" <> + help "Show only version number") + -- Parse the options and run the specified command. + (global, run) <- + simpleOptions + versionString' + "HaRe - the haskell refactorer" + "" + -- (numericVersion <*> globalOptsParser) $ + (numericVersion <*> allOptsParser) $ + do + addCommand "demote" + "Demote a declaration" + runCmd + demoteCmdOpts -import Text.Parsec.Combinator -import Text.Parsec.Prim -import Text.Parsec.Char + addCommand "dupdef" + "Duplicate a definition" + runCmd + dupDefCmdOpts ----------------------------------------------------------------- + addCommand "iftocase" + "Convert an if statement to a case statement" + runCmd + ifToCaseCmdOpts -ghcOptHelp :: String -ghcOptHelp = " [-g GHC_opt1 -g GHC_opt2 ...] " + addCommand "liftOneLevel" + "Lift a definition up one level" + runCmd + liftOneLevelCmdOpts -usage :: String -usage = "ghc-hare version " ++ showVersion version ++ "\n" - ++ "Usage:\n" - ++ "\t ghc-hare demote" ++ ghcOptHelp ++ "filename line col\n" - ++ "\t ghc-hare dupdef" ++ ghcOptHelp ++ "filename newname line col\n" - ++ "\t ghc-hare iftocase" ++ ghcOptHelp ++ "filename startline startcol endline endcol\n" - ++ "\t ghc-hare liftOneLevel" ++ ghcOptHelp ++ "filename line col\n" - ++ "\t ghc-hare liftToTopLevel" ++ ghcOptHelp ++ "filename line col\n" - ++ "\t ghc-hare rename" ++ ghcOptHelp ++ "filename newname line col\n" - ++ "\t ghc-hare help\n" + addCommand "liftToTopLevel" + "Lift a definition to the top level" + runCmd + liftToTopLevelCmdOpts ----------------------------------------------------------------- + addCommand "rename" + "Rename an identifier" + runCmd + renameCmdOpts -argspec :: [OptDescr (RefactSettings -> RefactSettings)] -argspec = [ - -- Option "m" ["mainfile"] - -- (ReqArg (\mf opts -> opts { rsetMainFile = Just [mf] }) "FILE") - -- "Main file name if not specified in cabal file" + addCommand "addOneParam" + "Add a new parameter to a function in first position" + runCmd + addOneParamCmdOpts - -- , Option "l" ["tolisp"] - -- (NoArg (\opts -> opts { outputStyle = LispStyle })) - -- "print as a list of Lisp" - -- , Option "h" ["hlintOpt"] - -- (ReqArg (\h opts -> opts { hlintOpts = h : hlintOpts opts }) "hlintOpt") - -- "hlint options" - -- , Option "g" ["ghcOpt"] - -- (ReqArg (\g opts -> opts { rsetGhcOpts = g : rsetGhcOpts opts }) "ghcOpt") - -- "GHC options" - -- , Option "o" ["operators"] - -- (NoArg (\opts -> opts { operators = True })) - -- "print operators, too" - -- , Option "d" ["detailed"] - -- (NoArg (\opts -> opts { detailed = True })) - -- "print detailed info" - Option "v" ["verbose"] - (NoArg (\opts -> opts { rsetVerboseLevel = Debug })) - "debug logging on" - -- , Option "b" ["boundary"] - -- (ReqArg (\s opts -> opts { rsetLineSeparator = LineSeparator s }) "sep") - -- "specify line separator (default is Nul string)" - ] + addCommand "rmOneParam" + "Remove a new parameter from a function" + runCmd + rmOneParamCmdOpts + run global -parseArgs :: [OptDescr (RefactSettings -> RefactSettings)] -> [String] -> (RefactSettings, [String]) -parseArgs spec argv - = case getOpt Permute spec argv of - (o,n,[] ) -> (foldr id defaultSettings o, n) - (_,_,errs) -> throw (CmdArg errs) +-- --------------------------------------------------------------------- ----------------------------------------------------------------- +type Row = Int +type Col = Int -data HareError = SafeList - | NoSuchCommand String - | CmdArg [String] - | FileNotExist String deriving (Show, Typeable) +data HareParams = DemoteCmd FilePath Row Col + | DupDefCmd FilePath String Row Col + | IfToCaseCmd FilePath Row Col Row Col + | LiftOneLevel FilePath Row Col + | LiftToTopLevel FilePath Row Col + | RenameCmd FilePath String Row Col + | AddOneParam FilePath String Row Col + | RmOneParam FilePath Row Col + deriving Show -instance Exception HareError +runCmd :: HareParams -> (RefactSettings,GM.Options) -> IO () +runCmd (DemoteCmd fileName r c) (opt, gOpt) + = runFunc $ demote opt gOpt fileName (r,c) ----------------------------------------------------------------- +runCmd (DupDefCmd fileName newname r c) (opt, gOpt) + = runFunc $ duplicateDef opt gOpt fileName newname (r,c) -main :: IO () -main = flip catches handlers $ do - hSetEncoding stdout utf8 - args <- getArgs - let (opt,cmdArg) = parseArgs argspec args - let cmdArg0 = cmdArg !. 0 - cmdArg1 = cmdArg !. 1 - cmdArg2 = cmdArg !. 2 - cmdArg3 = cmdArg !. 3 - cmdArg4 = cmdArg !. 4 - cmdArg5 = cmdArg !. 5 - -- putStrLn $ "cmdArg0=" ++ cmdArg0 - res <- case cmdArg0 of - -- demote wants FilePath -> SimpPos - "demote" -> runFunc $ demote opt defaultOptions cmdArg1 (parseSimpPos cmdArg2 cmdArg3) +runCmd (IfToCaseCmd fileName sr sc er ec) (opt, gOpt) + = runFunc $ ifToCase opt gOpt fileName (sr,sc) (er,ec) - -- dupdef wants FilePath -> String -> SimpPos - "dupdef" -> runFunc $ duplicateDef opt defaultOptions cmdArg1 cmdArg2 (parseSimpPos cmdArg3 cmdArg4) +runCmd (LiftOneLevel fileName r c) (opt, gOpt) + = runFunc $ liftOneLevel opt gOpt fileName (r,c) - -- iftocase wants FilePath -> SimpPos -> SimpPos - "iftocase" -> runFunc $ ifToCase opt defaultOptions cmdArg1 (parseSimpPos cmdArg2 cmdArg3) (parseSimpPos cmdArg4 cmdArg5) +runCmd (LiftToTopLevel fileName r c) (opt, gOpt) + = runFunc $ liftToTopLevel opt gOpt fileName (r,c) - -- liftOneLevel wants FilePath -> SimpPos - "liftOneLevel" -> runFunc $ liftOneLevel opt defaultOptions cmdArg1 (parseSimpPos cmdArg2 cmdArg3) +runCmd (RenameCmd fileName newname r c) (opt, gOpt) + = runFunc $ rename opt gOpt fileName newname (r,c) - -- liftToTopLevel wants FilePath -> SimpPos - "liftToTopLevel" -> runFunc $ liftToTopLevel opt defaultOptions cmdArg1 (parseSimpPos cmdArg2 cmdArg3) +runCmd (AddOneParam fileName newname r c) (opt, gOpt) + = runFunc $ addOneParameter opt gOpt fileName newname (r,c) - -- rename wants FilePath -> String -> SimpPos - "rename" -> runFunc $ rename opt defaultOptions cmdArg1 cmdArg2 (parseSimpPos cmdArg3 cmdArg4) +runCmd (RmOneParam fileName r c) (opt, gOpt) + = runFunc $ rmOneParameter opt gOpt fileName (r,c) - -- roundtrip wants FilePath - "roundtrip" -> runFunc $ roundTrip opt defaultOptions cmdArg1 +-- --------------------------------------------------------------------- - "show" -> putStrLn (show (opt)) +rmOneParamCmdOpts :: Parser HareParams +rmOneParamCmdOpts = + LiftOneLevel + <$> strArgument + ( metavar "FILE" + <> help "Specify Haskell file to process" + ) + <*> argument auto + ( metavar "line" + <> help "The line the function name is on") + <*> argument auto + ( metavar "col" + <> help "The col the function name starts at") - cmd -> throw (NoSuchCommand cmd) - -- putStr (show res) - -- putStr $ "(ok " ++ showLisp mfs ++ ")" - return () - where - handlers = [Handler handler1, Handler handler2] +-- --------------------------------------------------------------------- - handler1 :: ErrorCall -> IO () - handler1 = print -- for debug +addOneParamCmdOpts :: Parser HareParams +addOneParamCmdOpts = + AddOneParam + <$> strArgument + ( metavar "FILE" + <> help "Specify Haskell file to process" + ) + <*> strArgument + ( metavar "NAME" + <> help "The name for the parameter" + ) + <*> argument auto + ( metavar "line" + <> help "The line the function name is on") + <*> argument auto + ( metavar "col" + <> help "A col inside the function name name") - handler2 :: HareError -> IO () - handler2 SafeList = printUsage - handler2 (NoSuchCommand cmd) = do - hPutStrLn stderr $ "\"" ++ cmd ++ "\" not supported" - printUsage - handler2 (CmdArg errs) = do - mapM_ (hPutStr stderr) errs - printUsage - handler2 (FileNotExist file) = do - hPutStrLn stderr $ "\"" ++ file ++ "\" not found" - printUsage +-- --------------------------------------------------------------------- - printUsage = hPutStrLn stderr $ '\n' : usageInfo usage argspec - xs !. idx - | length xs <= idx = throw SafeList - | otherwise = xs !! idx +renameCmdOpts :: Parser HareParams +renameCmdOpts = + RenameCmd + <$> strArgument + ( metavar "FILE" + <> help "Specify Haskell file to process" + ) + <*> strArgument + ( metavar "NEWNAME" + <> help "The new name for the identifier" + ) + <*> argument auto + ( metavar "line" + <> help "The line the identifier is on") + <*> argument auto + ( metavar "col" + <> help "A col inside the identifier name") +-- --------------------------------------------------------------------- ----------------------------------------------------------------- +liftToTopLevelCmdOpts :: Parser HareParams +liftToTopLevelCmdOpts = + LiftOneLevel + <$> strArgument + ( metavar "FILE" + <> help "Specify Haskell file to process" + ) + <*> argument auto + ( metavar "line" + <> help "The line the declaration is on") + <*> argument auto + ( metavar "col" + <> help "The col the declaration starts at") +-- --------------------------------------------------------------------- + +liftOneLevelCmdOpts :: Parser HareParams +liftOneLevelCmdOpts = + LiftOneLevel + <$> strArgument + ( metavar "FILE" + <> help "Specify Haskell file to process" + ) + <*> argument auto + ( metavar "line" + <> help "The line the declaration is on") + <*> argument auto + ( metavar "col" + <> help "The col the declaration starts at") + +-- --------------------------------------------------------------------- + +ifToCaseCmdOpts :: Parser HareParams +ifToCaseCmdOpts = + IfToCaseCmd + <$> strArgument + ( metavar "FILE" + <> help "Specify Haskell file to process" + ) + <*> argument auto + ( metavar "startline" + <> help "The line the if statement starts on") + <*> argument auto + ( metavar "startcol" + <> help "The col the if statement starts at") + + <*> argument auto + ( metavar "endline" + <> help "The line the if statement ends on") + <*> argument auto + ( metavar "endcol" + <> help "The col the if statement ends at") + +-- --------------------------------------------------------------------- + +demoteCmdOpts :: Parser HareParams +demoteCmdOpts = + DemoteCmd + <$> strArgument + ( metavar "FILE" + <> help "Specify Haskell file to process" + ) + <*> argument auto + ( metavar "line" + <> help "The line the declaration is on") + <*> argument auto + ( metavar "col" + <> help "The col the declaration starts at") + +-- --------------------------------------------------------------------- + +dupDefCmdOpts :: Parser HareParams +dupDefCmdOpts = + DupDefCmd + <$> strArgument + ( metavar "FILE" + <> help "Specify Haskell file to process" + ) + <*> strArgument + ( metavar "NEWNAME" + <> help "The name for the new definition" + ) + <*> argument auto + ( metavar "line" + <> help "The line the definition is on") + <*> argument auto + ( metavar "col" + <> help "A col inside the definition name") + + +-- --------------------------------------------------------------------- + +allOptsParser :: Parser (RefactSettings,GM.Options) +allOptsParser = (,) <$> globalOptsParser <*> globalArgSpec + +globalOptsParser :: Parser RefactSettings +globalOptsParser = mkRefSet + <$> ((\b -> if b then Debug else Normal) <$> switch + ( long "debug" + <> short 'd' + <> help "Generate debug output" )) + where + mkRefSet v = RefSet v (True,True,True,True) + +-- --------------------------------------------------------------------- + +-- | Return the result of an Either as a sexp for emacs etc. runFunc :: IO [String] -> IO () runFunc f = do r <- catchException f @@ -168,27 +309,4 @@ return res where handler:: SomeException -> IO (Either String t) - handler e = return (Left (show e)) - ----------------------------------------------------------------- - -parseSimpPos :: String -> String -> SimpPos -parseSimpPos str1 str2 = case (parse rowCol "" ((str1 ++ " " ++ str2))) of - Left err -> throw (CmdArg [(show err)]) - Right val -> val - -rowCol :: P (Int,Int) -rowCol = do - row <- number "line number" - _ <- spaces - col <- number "column number" - return (fromIntegral row, fromIntegral col) - -type P = Parsec String () - - -number :: String -> P Integer -number expectedStr = do { ds <- many1 digit; return (read ds) } expectedStr - ----------------------------------------------------------------- - + handler e = return (Left (stripCallStack $ show e)) diff --git a/test/AddRmParamSpec.hs b/test/AddRmParamSpec.hs new file mode 100644 --- /dev/null +++ b/test/AddRmParamSpec.hs @@ -0,0 +1,495 @@ +module AddRmParamSpec (main, spec) where + +import Test.Hspec + +import Language.Haskell.Refact.Refactoring.AddRmParam + +import TestUtils + +import System.Directory + +-- --------------------------------------------------------------------- + +main :: IO () +main = do + hspec spec + +spec :: Spec +spec = do + + describe "Adding" $ do + it "addOneParameter in D3 A3" $ do + r <- ct $ addOneParameter defaultTestSettings testOptions "./AddOneParameter/D3.hs" "y" (7,1) + -- r <- ct $ addOneParameter logTestSettings testOptions "./AddOneParameter/D3.hs" "y" (7,1) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "AddOneParameter/D3.hs" + , "AddOneParameter/A3.hs" + ] + + diffD <- ct $ compareFiles "./AddOneParameter/D3.expected.hs" + "./AddOneParameter/D3.refactored.hs" + diffD `shouldBe` [] + + diffA <- ct $ compareFiles "./AddOneParameter/A3.expected.hs" + "./AddOneParameter/A3.refactored.hs" + diffA `shouldBe` [] + + -- ------------------- + + it "addOneParameter in D1 B1 C1 A1" $ do + r <- ct $ addOneParameter defaultTestSettings testOptions "./AddOneParameter/D1.hs" "f" (10,1) + -- r <- ct $ addOneParameter logTestSettings testOptions "./AddOneParameter/D1.hs" "f" (10,1) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "AddOneParameter/D1.hs" + , "AddOneParameter/A1.hs" + , "AddOneParameter/C1.hs" + ] + + diffD <- ct $ compareFiles "./AddOneParameter/D1.expected.hs" + "./AddOneParameter/D1.refactored.hs" + diffD `shouldBe` [] + + diffC <- ct $ compareFiles "./AddOneParameter/C1.expected.hs" + "./AddOneParameter/C1.refactored.hs" + diffC `shouldBe` [] + + diffA <- ct $ compareFiles "./AddOneParameter/A1.expected.hs" + "./AddOneParameter/A1.refactored.hs" + diffA `shouldBe` [] + + -- ------------------- + + it "addOneParameter in D2 B2 C2 A2" $ do + r <- ct $ addOneParameter defaultTestSettings testOptions "./AddOneParameter/D2.hs" "f" (11,1) + -- r <- ct $ addOneParameter logTestSettings testOptions "./AddOneParameter/D2.hs" "f" (11,1) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "AddOneParameter/D2.hs" + , "AddOneParameter/A2.hs" + , "AddOneParameter/C2.hs" + ] + + diffD <- ct $ compareFiles "./AddOneParameter/D2.expected.hs" + "./AddOneParameter/D2.refactored.hs" + diffD `shouldBe` [] + + diffC <- ct $ compareFiles "./AddOneParameter/C2.expected.hs" + "./AddOneParameter/C2.refactored.hs" + diffC `shouldBe` [] + + diffA <- ct $ compareFiles "./AddOneParameter/A2.expected.hs" + "./AddOneParameter/A2.refactored.hs" + diffA `shouldBe` [] + + -- ------------------- + + it "addOneParameter in PatIn1" $ do + r <- ct $ addOneParameter defaultTestSettings testOptions "./AddOneParameter/PatIn1.hs" "x" (7,1) + -- r <- ct $ addOneParameter logTestSettings testOptions "./AddOneParameter/PatIn1.hs" "x" (7,1) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "AddOneParameter/PatIn1.hs" + ] + + diffD <- ct $ compareFiles "./AddOneParameter/PatIn1.expected.hs" + "./AddOneParameter/PatIn1.refactored.hs" + diffD `shouldBe` [] + + -- ------------------- + + it "addOneParameter in FunIn1" $ do + -- (["FunIn1.hs"],["y","7","1"]), + r <- ct $ addOneParameter defaultTestSettings testOptions "./AddOneParameter/FunIn1.hs" "y" (7,1) + -- r <- ct $ addOneParameter logTestSettings testOptions "./AddOneParameter/FunIn1.hs" "y" (7,1) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "AddOneParameter/FunIn1.hs" + ] + + diffD <- ct $ compareFiles "./AddOneParameter/FunIn1.expected.hs" + "./AddOneParameter/FunIn1.refactored.hs" + diffD `shouldBe` [] + + -- ------------------- + + it "addOneParameter in FunIn2" $ do + -- (["FunIn2.hs"],["y","10","18"]), + r <- ct $ addOneParameter defaultTestSettings testOptions "./AddOneParameter/FunIn2.hs" "y" (10,18) + -- r <- ct $ addOneParameter logTestSettings testOptions "./AddOneParameter/FunIn2.hs" "y" (10,18) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "AddOneParameter/FunIn2.hs" + ] + + diffD <- ct $ compareFiles "./AddOneParameter/FunIn2.expected.hs" + "./AddOneParameter/FunIn2.refactored.hs" + diffD `shouldBe` [] + + -- ------------------- + + it "addOneParameter in FunIn3" $ do + -- (["FunIn3.hs"],["y","9","11"]), + r <- ct $ addOneParameter defaultTestSettings testOptions "./AddOneParameter/FunIn3.hs" "y" (9,11) + -- r <- ct $ addOneParameter logTestSettings testOptions "./AddOneParameter/FunIn3.hs" "y" (9,11) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "AddOneParameter/FunIn3.hs" + ] + + diffD <- ct $ compareFiles "./AddOneParameter/FunIn3.expected.hs" + "./AddOneParameter/FunIn3.refactored.hs" + diffD `shouldBe` [] + + -- ------------------- + + it "addOneParameter in FunIn4" $ do + -- (["FunIn4.hs"],["y","8","22"])], + r <- ct $ addOneParameter defaultTestSettings testOptions "./AddOneParameter/FunIn4.hs" "y" (8,22) + -- r <- ct $ addOneParameter logTestSettings testOptions "./AddOneParameter/FunIn4.hs" "y" (8,22) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "AddOneParameter/FunIn4.hs" + ] + + diffD <- ct $ compareFiles "./AddOneParameter/FunIn4.expected.hs" + "./AddOneParameter/FunIn4.refactored.hs" + diffD `shouldBe` [] + + -- ------------------- + + it "addOneParameter in FunIn6" $ do + -- (["FunIn6.hs"],["y","8","22"])], + r <- ct $ addOneParameter defaultTestSettings testOptions "./AddOneParameter/FunIn6.hs" "y" (9,7) + -- r <- ct $ addOneParameter logTestSettings testOptions "./AddOneParameter/FunIn6.hs" "y" (9,7) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "AddOneParameter/FunIn6.hs" + ] + + diffD <- ct $ compareFiles "./AddOneParameter/FunIn6.expected.hs" + "./AddOneParameter/FunIn6.refactored.hs" + diffD `shouldBe` [] + + -- ------------------- + + it "addOneParameter in Nested" $ do + r <- ct $ addOneParameter defaultTestSettings testOptions "./AddOneParameter/Nested.hs" "y" (8,1) + -- r <- ct $ addOneParameter logTestSettings testOptions "./AddOneParameter/Nested.hs" "y" (8,1) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "AddOneParameter/Nested.hs" + ] + + diffD <- ct $ compareFiles "./AddOneParameter/Nested.expected.hs" + "./AddOneParameter/Nested.refactored.hs" + diffD `shouldBe` [] + + -- ------------------- + + it "addOneParameter in MultiFun1" $ do + r <- ct $ addOneParameter defaultTestSettings testOptions "./AddOneParameter/MultiFun1.hs" "x" (9,1) + -- r <- ct $ addOneParameter logTestSettings testOptions "./AddOneParameter/MultiFun1.hs" "x" (9,1) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "AddOneParameter/MultiFun1.hs" + ] + + diffD <- ct $ compareFiles "./AddOneParameter/MultiFun1.expected.hs" + "./AddOneParameter/MultiFun1.refactored.hs" + diffD `shouldBe` [] + + -- --------------------------------- + -- Negative tests + -- --------------------------------- + + it "fails complex pat binding PatIn2" $ do + -- [(["PatIn2.hs"],["x","7","20"]), + res <- catchException (ct $ addOneParameter defaultTestSettings testOptions "./AddOneParameter/PatIn2.hs" "x" (7,20)) + (show res) `shouldBe` "Just \"Parameter can not be added to complex pattern binding\"" + + -- ------------------- + + it "fails name clash FunIn5" $ do + -- (["FunIn5.hs"],["h","8","1"])] + res <- catchException (ct $ addOneParameter defaultTestSettings testOptions "./AddOneParameter/FunIn5.hs" "h" (8,1)) + (show res) `shouldBe` "Just \"The new parameter name will cause name clash or semantics change, please choose another name!\"" + + -- ------------------- +{- +TestCases{refactorCmd="addOneParameter", +positive=[(["D3.hs","A3.hs"],["y","7","1"]), + (["D1.hs","C1.hs","A1.hs"],["f","10","1"]), + (["D2.hs","C2.hs","A2.hs"],["f","11","1"]), + (["PatIn1.hs"],["x","7","1"]), + (["FunIn1.hs"],["y","7","1"]), + (["FunIn2.hs"],["y","10","18"]), + (["FunIn3.hs"],["y","9","11"]), + (["FunIn4.hs"],["y","8","22"])], +negative=[(["PatIn2.hs"],["x","7","20"]), + (["FunIn5.hs"],["h","8","1"])] + +-} + + -- --------------------------------- + + describe "Removing" $ do + it "rmOneParameter in D1 A1" $ do + -- (["D1.hs","A1.hs"],["6","19"]), + r <- ct $ rmOneParameter defaultTestSettings testOptions "./RmOneParameter/D1.hs" (6,19) + -- r <- ct $ rmOneParameter logTestSettings testOptions "./RmOneParameter/D1.hs" (6,19) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "RmOneParameter/D1.hs" + , "RmOneParameter/A1.hs" + ] + + diffD <- ct $ compareFiles "./RmOneParameter/D1.expected.hs" + "./RmOneParameter/D1.refactored.hs" + diffD `shouldBe` [] + + diffA <- ct $ compareFiles "./RmOneParameter/A1.expected.hs" + "./RmOneParameter/A1.refactored.hs" + diffA `shouldBe` [] + + -- ------------------- + + it "rmOneParameter in D2 A2" $ do + -- (["D2.hs","A2.hs"],["7","19"]), + r <- ct $ rmOneParameter defaultTestSettings testOptions "./RmOneParameter/D2.hs" (7,19) + -- r <- ct $ rmOneParameter logTestSettings testOptions "./RmOneParameter/D2.hs" (7,19) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "RmOneParameter/D2.hs" + , "RmOneParameter/A2.hs" + ] + + diffD <- ct $ compareFiles "./RmOneParameter/D2.expected.hs" + "./RmOneParameter/D2.refactored.hs" + diffD `shouldBe` [] + + diffA <- ct $ compareFiles "./RmOneParameter/A2.expected.hs" + "./RmOneParameter/A2.refactored.hs" + diffA `shouldBe` [] + + -- ------------------- + + it "rmOneParameter in FunIn1" $ do + -- (["FunIn1.hs"],["8","5"]), + r <- ct $ rmOneParameter defaultTestSettings testOptions "./RmOneParameter/FunIn1.hs" (8,5) + -- r <- ct $ rmOneParameter logTestSettings testOptions "./RmOneParameter/FunIn1.hs" (8,5) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "RmOneParameter/FunIn1.hs" + ] + + diffD <- ct $ compareFiles "./RmOneParameter/FunIn1.expected.hs" + "./RmOneParameter/FunIn1.refactored.hs" + diffD `shouldBe` [] + + -- ------------------- + + it "rmOneParameter in FunIn2" $ do + -- (["FunIn2.hs"],["8","5"]), + r <- ct $ rmOneParameter defaultTestSettings testOptions "./RmOneParameter/FunIn2.hs" (8,5) + -- r <- ct $ rmOneParameter logTestSettings testOptions "./RmOneParameter/FunIn2.hs" (8,5) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "RmOneParameter/FunIn2.hs" + ] + + diffD <- ct $ compareFiles "./RmOneParameter/FunIn2.expected.hs" + "./RmOneParameter/FunIn2.refactored.hs" + diffD `shouldBe` [] + + -- ------------------- + + it "rmOneParameter in FunIn2a" $ do + -- (["FunIn2.hs"],["8","5"]), + r <- ct $ rmOneParameter defaultTestSettings testOptions "./RmOneParameter/FunIn2a.hs" (8,5) + -- r <- ct $ rmOneParameter logTestSettings testOptions "./RmOneParameter/FunIn2a.hs" (8,5) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "RmOneParameter/FunIn2a.hs" + ] + + diffD <- ct $ compareFiles "./RmOneParameter/FunIn2a.expected.hs" + "./RmOneParameter/FunIn2a.refactored.hs" + diffD `shouldBe` [] + + -- ------------------- + + it "rmOneParameter in FunIn3" $ do + -- (["FunIn3.hs"],["7","5"]), + r <- ct $ rmOneParameter defaultTestSettings testOptions "./RmOneParameter/FunIn3.hs" (7,5) + -- r <- ct $ rmOneParameter logTestSettings testOptions "./RmOneParameter/FunIn3.hs" (7,5) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "RmOneParameter/FunIn3.hs" + ] + + diffD <- ct $ compareFiles "./RmOneParameter/FunIn3.expected.hs" + "./RmOneParameter/FunIn3.refactored.hs" + diffD `shouldBe` [] + + -- ------------------- + + it "rmOneParameter in FunIn5" $ do + -- (["FunIn5.hs"],["7","6"]), + r <- ct $ rmOneParameter defaultTestSettings testOptions "./RmOneParameter/FunIn5.hs" (7,6) + -- r <- ct $ rmOneParameter logTestSettings testOptions "./RmOneParameter/FunIn5.hs" (7,6) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "RmOneParameter/FunIn5.hs" + ] + + diffD <- ct $ compareFiles "./RmOneParameter/FunIn5.expected.hs" + "./RmOneParameter/FunIn5.refactored.hs" + diffD `shouldBe` [] + + -- ------------------- + + it "rmOneParameter in FunIn6" $ do + -- (["FunIn6.hs"],["7","5"]), + r <- ct $ rmOneParameter defaultTestSettings testOptions "./RmOneParameter/FunIn6.hs" (7,5) + -- r <- ct $ rmOneParameter logTestSettings testOptions "./RmOneParameter/FunIn6.hs" (7,5) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "RmOneParameter/FunIn6.hs" + ] + + diffD <- ct $ compareFiles "./RmOneParameter/FunIn6.expected.hs" + "./RmOneParameter/FunIn6.refactored.hs" + diffD `shouldBe` [] + + -- ------------------- + + it "rmOneParameter in FunIn0" $ do + -- (["FunIn0.hs"],["10","7"])], + r <- ct $ rmOneParameter defaultTestSettings testOptions "./RmOneParameter/FunIn0.hs" (10,7) + -- r <- ct $ rmOneParameter logTestSettings testOptions "./RmOneParameter/FunIn0.hs" (10,7) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "RmOneParameter/FunIn0.hs" + ] + + diffD <- ct $ compareFiles "./RmOneParameter/FunIn0.expected.hs" + "./RmOneParameter/FunIn0.refactored.hs" + diffD `shouldBe` [] + + -- ------------------- + + it "rmOneParameter in SubFun1" $ do + r <- ct $ rmOneParameter defaultTestSettings testOptions "./RmOneParameter/SubFun1.hs" (10,9) + -- r <- ct $ rmOneParameter logTestSettings testOptions "./RmOneParameter/SubFun1.hs" (10,9) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "RmOneParameter/SubFun1.hs" + ] + + diffD <- ct $ compareFiles "./RmOneParameter/SubFun1.expected.hs" + "./RmOneParameter/SubFun1.refactored.hs" + diffD `shouldBe` [] + + -- ------------------- + + it "rmOneParameter in SubFun2" $ do + r <- ct $ rmOneParameter defaultTestSettings testOptions "./RmOneParameter/SubFun2.hs" (10,9) + -- r <- ct $ rmOneParameter logTestSettings testOptions "./RmOneParameter/SubFun2.hs" (10,9) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "RmOneParameter/SubFun2.hs" + ] + + diffD <- ct $ compareFiles "./RmOneParameter/SubFun2.expected.hs" + "./RmOneParameter/SubFun2.refactored.hs" + diffD `shouldBe` [] + + -- ------------------- + + it "rmOneParameter in SubFun3" $ do + r <- ct $ rmOneParameter defaultTestSettings testOptions "./RmOneParameter/SubFun3.hs" (10,9) + -- r <- ct $ rmOneParameter logTestSettings testOptions "./RmOneParameter/SubFun3.hs" (10,9) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "RmOneParameter/SubFun3.hs" + ] + + diffD <- ct $ compareFiles "./RmOneParameter/SubFun3.expected.hs" + "./RmOneParameter/SubFun3.refactored.hs" + diffD `shouldBe` [] + + -- ------------------- + + it "rmOneParameter in MultiFun1" $ do + r <- ct $ rmOneParameter defaultTestSettings testOptions "./RmOneParameter/MultiFun1.hs" (10,8) + -- r <- ct $ rmOneParameter logTestSettings testOptions "./RmOneParameter/MultiFun1.hs" (10,8) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "RmOneParameter/MultiFun1.hs" + ] + + diffD <- ct $ compareFiles "./RmOneParameter/MultiFun1.expected.hs" + "./RmOneParameter/MultiFun1.refactored.hs" + diffD `shouldBe` [] + + -- --------------------------------- + -- Negative tests + -- --------------------------------- + + it "fails FunIn4" $ do + -- (["FunIn4.hs"],["7","6"]), + res <- catchException (ct $ rmOneParameter defaultTestSettings testOptions "./RmOneParameter/FunIn4.hs" (7,6)) + -- ct $ rmOneParameter logTestSettings testOptions "./RmOneParameter/FunIn4.hs" (7,6) + (show res) `shouldBe` "Just \"This parameter can not be removed, as it is used!\"" + + -- ------------------- + + it "fails FunIn7" $ do + -- (["FunIn7.hs"],["10","4"])] + res <- catchException (ct $ rmOneParameter defaultTestSettings testOptions "./RmOneParameter/FunIn7.hs" (10,4)) + (show res) `shouldBe` "Just \"Invalid cursor position!\"" + + -- ------------------- +{- +TestCases{refactorCmd="rmOneParameter", +positive=[ + (["D1.hs","A1.hs"],["6","19"]), + (["D2.hs","A2.hs"],["7","19"]), + (["FunIn1.hs"],["8","5"]), + (["FunIn2.hs"],["8","5"]), + (["FunIn3.hs"],["7","5"]), + (["FunIn5.hs"],["7","6"]), + (["FunIn6.hs"],["7","5"]), + (["FunIn0.hs"],["10","7"])], +negative=[(["FunIn4.hs"],["7","6"]), + (["FunIn7.hs"],["10","4"])] +} + +TODO: Add a test for a PatBind too +-} diff --git a/test/GhcUtilsSpec.hs b/test/GhcUtilsSpec.hs --- a/test/GhcUtilsSpec.hs +++ b/test/GhcUtilsSpec.hs @@ -1,25 +1,26 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} module GhcUtilsSpec (main, spec) where import Test.Hspec -import TestUtils +-- import TestUtils -import qualified GHC as GHC +-- import qualified GHC as GHC -import qualified Data.Generics as SYB -import qualified GHC.SYB.Utils as SYB +-- import qualified Data.Generics as SYB +-- import qualified GHC.SYB.Utils as SYB -import Language.Haskell.GHC.ExactPrint.Utils +-- import Language.Haskell.GHC.ExactPrint.Utils -import Language.Haskell.Refact.Utils.Binds -import Language.Haskell.Refact.Utils.GhcUtils -import Language.Haskell.Refact.Utils.GhcVersionSpecific -import Language.Haskell.Refact.Utils.Monad -import Language.Haskell.Refact.Utils.MonadFunctions -import Language.Haskell.Refact.Utils.TypeUtils -import Language.Haskell.Refact.Utils.Utils -import Language.Haskell.Refact.Utils.Variables +-- import Language.Haskell.Refact.Utils.Binds +-- import Language.Haskell.Refact.Utils.GhcUtils +-- import Language.Haskell.Refact.Utils.GhcVersionSpecific +-- import Language.Haskell.Refact.Utils.Monad +-- import Language.Haskell.Refact.Utils.MonadFunctions +-- import Language.Haskell.Refact.Utils.TypeUtils +-- import Language.Haskell.Refact.Utils.Utils +-- import Language.Haskell.Refact.Utils.Variables -- import TestUtils @@ -31,7 +32,10 @@ spec :: Spec spec = do - + describe "nothing happening here" $ do + it "need to delete this" $ do + "a" `shouldBe` "a" + {- describe "onelayerStaged" $ do it "only descends one layer into a structure" $ do let s' = (2,[3,4],5) :: (Int,[Int],Int) @@ -53,12 +57,18 @@ comp = do parseSourceFileGhc "./DupDef/Dd1.hs" renamed <- getRefactRenamed + parsed <- getRefactParsed + nm <- getRefactNameMap - let mn = locToName (4,1) renamed - let (Just (ln@(GHC.L _ n))) = mn + let mn = locToRdrName (4,1) parsed + let Just (ln'@(GHC.L l _)) = mn + n = rdrName2NamePure nm ln' + ln = GHC.L l n - let mx = locToName (4,10) renamed - let (Just (lx@(GHC.L _ x))) = mx + let mx = locToRdrName (4,10) parsed + let (Just (lx'@(GHC.L l2 _))) = mx + x = rdrName2NamePure nm lx' + lx = GHC.L l2 x let declsr = hsBinds renamed duplicatedDecls = definingDeclsNames [n] declsr True False @@ -73,7 +83,11 @@ worker (nn::GHC.Name) = [showGhc nn] g = onelayerStaged SYB.Renamer ["-1"] (["-10"] `SYB.mkQ` worker) duplicatedDecls +#if __GLASGOW_HASKELL__ <= 710 worker2 ((GHC.L _ (GHC.FunBind (GHC.L _ n') _ _ _ _ _))::GHC.Located (GHC.HsBind GHC.Name)) +#else + worker2 ((GHC.L _ (GHC.FunBind (GHC.L _ n') _ _ _ _))::GHC.Located (GHC.HsBind GHC.Name)) +#endif | n == n' = ["found"] worker2 _ = [] g2 = onelayerStaged SYB.Renamer ["-1"] (["-10"] `SYB.mkQ` worker2) duplicatedDecls @@ -91,5 +105,6 @@ r2 `shouldBe` True rx `shouldBe` False rx2 `shouldBe` True +-} -- --------------------------------------------------------------------- diff --git a/test/RenamingSpec.hs b/test/RenamingSpec.hs --- a/test/RenamingSpec.hs +++ b/test/RenamingSpec.hs @@ -291,7 +291,7 @@ it "renames in ConstructorIn3 9 12" $ do r <- ct $ rename defaultTestSettings testOptions "./Renaming/ConstructorIn3.hs" "b" (9,13) - -- ct $ rename logTestSettings testOptions Nothing "./Renaming/ConstructorIn3.hs" "b" (9,13) + -- ct $ rename logTestSettings testOptions "./Renaming/ConstructorIn3.hs" "b" (9,13) r' <- ct $ mapM makeRelativeToCurrentDirectory r r' `shouldBe` [ "Renaming/ConstructorIn3.hs" ] @@ -366,7 +366,7 @@ -- --------------------------------- it "naming clash IdIn5" $ do - -- rename logTestSettings testOptions "./Renaming/IdIn5.hs" "y" (10,1) + -- ct $ rename logTestSettings testOptions "./Renaming/IdIn5.hs" "y" (10,1) res <- catchException (ct $ rename defaultTestSettings testOptions "./Renaming/IdIn5.hs" "y" (10,1)) (show res) `shouldBe` "Just \"Name 'y' already exists, or renaming 'IdIn5.x' to 'y' will change the program's semantics!\\n\"" diff --git a/test/TestUtils.hs b/test/TestUtils.hs --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -1,6 +1,5 @@ module TestUtils ( compareFiles - , compareStrings , parsedFileGhc , parsedFileGhcCd , parseSourceFileTest @@ -33,16 +32,20 @@ , parseDeclToAnnotated , ss2span , PosToken + , getHsDecls + , showNameMap ) where +import qualified DynFlags as GHC import qualified FastString as GHC import qualified GHC as GHC import qualified Name as GHC --- import qualified Outputable as GHC +import qualified Outputable as GHC import qualified Unique as GHC import Data.Algorithm.Diff +import Data.Algorithm.DiffOutput import Data.Data import Exception import Language.Haskell.GHC.ExactPrint @@ -81,18 +84,15 @@ -- --------------------------------------------------------------------- -compareFiles :: FilePath -> FilePath -> IO [Diff [String]] +compareFiles :: FilePath -> FilePath -> IO String compareFiles fileA fileB = do astr <- readFile fileA bstr <- readFile fileB - -- return $ filter (\c -> not( isBoth c)) $ getGroupedDiff (lines astr) (lines bstr) - return $ compareStrings astr bstr - -compareStrings :: String -> String -> [Diff [String]] -compareStrings astr bstr = filter (\c -> not( isBoth c)) $ getGroupedDiff (lines astr) (lines bstr) - where - isBoth (Both _ _) = True - isBoth _ = False + let + diffToString ds = case ppDiff ds of + "\n" -> "" + s -> s + return $ diffToString $ getGroupedDiff (lines astr) (lines bstr) -- --------------------------------------------------------------------- @@ -245,7 +245,7 @@ return res where handler:: SomeException -> IO (Maybe String) - handler e = return (Just (show e)) + handler e = return (Just (stripCallStack $ show e)) -- --------------------------------------------------------------------- @@ -387,6 +387,23 @@ ss2span :: GHC.SrcSpan -> (Pos,Pos) ss2span ss = (ss2pos ss,ss2posEnd ss) + +-- --------------------------------------------------------------------- + +-- | call ghc-excactprint hsDecls in a Transform context +getHsDecls :: (HasDecls t) => t -> [GHC.LHsDecl GHC.RdrName] +getHsDecls t = decls + where + -- runTransform :: Anns -> Transform a -> (a, (Anns, Int), [String]) + (decls,_,_) = runTransform mempty (hsDecls t) +-- --------------------------------------------------------------------- + +showNameMap :: NameMap -> String +showNameMap nm = GHC.showSDocDebug GHC.unsafeGlobalDynFlags doc + where + doc = GHC.text "NameMap" GHC.<+> GHC.vcat (map one $ Map.toList nm) + -- one (s,n) = GHC.parens $ GHC.text (showGhc (s,n,GHC.nameUnique n)) GHC.<+> GHC.ppr n + one (s,n) = GHC.parens $ GHC.hsep [GHC.ppr s, GHC.comma, GHC.ppr n] -- --------------------------------------------------------------------- -- EOF diff --git a/test/TypeUtilsSpec.hs b/test/TypeUtilsSpec.hs --- a/test/TypeUtilsSpec.hs +++ b/test/TypeUtilsSpec.hs @@ -1,3798 +1,3777 @@ -module TypeUtilsSpec (main, spec) where - -import Test.Hspec - -import TestUtils - -import qualified GHC.SYB.Utils as SYB - -import qualified GHC as GHC -import qualified GhcMonad as GHC -import qualified Name as GHC -import qualified RdrName as GHC -import qualified Module as GHC - -import Data.Maybe - -import Language.Haskell.GHC.ExactPrint.Types -import Language.Haskell.GHC.ExactPrint.Parsers -import Language.Haskell.GHC.ExactPrint - -import Language.Haskell.Refact.Utils.Binds -import Language.Haskell.Refact.Utils.GhcVersionSpecific -import Language.Haskell.Refact.Utils.LocUtils -import Language.Haskell.Refact.Utils.Monad -import Language.Haskell.Refact.Utils.MonadFunctions -import Language.Haskell.Refact.Utils.TypeUtils -import Language.Haskell.Refact.Utils.Utils -import Language.Haskell.Refact.Utils.Variables - -import qualified Data.Map as Map -import Data.List - -main :: IO () -main = do - hspec spec - -spec :: Spec -spec = do - - -- ------------------------------------------------------------------- - - describe "findAllNameOccurences" $ do - it "finds all occurrences of the given name in a syntax phrase" $ do - t <- ct $ parsedFileGhc "./TypeUtils/S.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just ((GHC.L _l n)) = locToName (4,5) renamed - (showGhcQual n) `shouldBe` "x" - - let res = findAllNameOccurences n renamed - (showGhcQual res) `shouldBe` "[x, x]" - -- NOTE: does not get the x's in line 8 - (showGhcQual $ map startEndLocGhc res) `shouldBe` "[((4, 5), (4, 6)), ((4, 17), (4, 18))]" - - -- ------------------------------------------------------------------- - - describe "locToName" $ do - it "returns a GHC.Name for a given source location, if it falls anywhere in an identifier #1" $ do - t <- ct $ parsedFileGhc "./TypeUtils/B.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just (res@(GHC.L l n)) = locToName (7,3) renamed - showGhcQual l `shouldBe` "TypeUtils/B.hs:7:1-3" - getLocatedStart res `shouldBe` (7,1) - showGhcQual n `shouldBe` "TypeUtils.B.foo" - - -- --------------------------------- - - it "returns a GHC.Name for a given source location, if it falls anywhere in an identifier #2" $ do - t <- ct $ parsedFileGhc "./TypeUtils/B.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just (res@(GHC.L l n)) = locToName (25,8) renamed - showGhcQual n `shouldBe` "TypeUtils.B.bob" - showGhcQual l `shouldBe` "TypeUtils/B.hs:25:7-9" - getLocatedStart res `shouldBe` (25,7) - - -- --------------------------------- - - it "returns Nothing for a given source location, if it does not fall in an identifier" $ do - t <- ct $ parsedFileGhc "TypeUtils/B.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let res = locToName (7,7) renamed - (showGhcQual res) `shouldBe` "Nothing" - - -- --------------------------------- - - it "gets a short name too" $ do - t <- ct $ parsedFileGhc "./Demote/WhereIn2.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just (res@(GHC.L l n)) = locToName (14,1) renamed - showGhcQual n `shouldBe` "Demote.WhereIn2.sq" - showGhcQual l `shouldBe` "Demote/WhereIn2.hs:14:1-2" - getLocatedStart res `shouldBe` (14,1) - - -- --------------------------------- - - it "gets a type variable name" $ do - t <- ct $ parsedFileGhc "./Renaming/ConstructorIn3.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just (res@(GHC.L l n)) = locToName (9,12) renamed - showGhcQual n `shouldBe` "a" - -- Note: loc does not line up due to multiple matches in FunBind - showGhcQual l `shouldBe` "Renaming/ConstructorIn3.hs:9:12" - getLocatedStart res `shouldBe` (9,12) - - -- --------------------------------- - - it "gets an instance class name" $ do - t <- ct $ parsedFileGhc "./Renaming/ClassIn3.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let Just (res@(GHC.L l n)) = locToName (16,10) renamed - showGhcQual n `shouldBe` "GHC.Classes.Eq" - showGhcQual l `shouldBe` "Renaming/ClassIn3.hs:16:10-11" - getLocatedStart res `shouldBe` (16,10) - - -- ------------------------------------------------------------------- - - describe "locToRdrName" $ do - it "returns a GHC.RdrName for a given source location, if it falls anywhere in an identifier" $ do - t <- ct $ parsedFileGhc "./Renaming/D5.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let Just (res@(GHC.L l n)) = locToRdrName (20,1) parsed - (show $ ss2span l) `shouldBe` "((20,1),(20,11))" - getLocatedStart res `shouldBe` (20,1) - showGhcQual n `shouldBe` "sumSquares" - - it "returns a GHC.RdrName for a source location, in a MatchGroup" $ do - t <- ct $ parsedFileGhc "./LocToName.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let Just (res@(GHC.L l n)) = locToRdrName (24,2) parsed - showGhcQual n `shouldBe` "sumSquares" - getLocatedStart res `shouldBe` (24,1) - showGhcQual l `shouldBe` "LocToName.hs:24:1-10" - - -- ------------------------------------------------------------------- - - describe "allNames" $ do - it "lists all Names" $ do - t <- ct $ parsedFileGhc "./TypeUtils/S.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let res = allNames renamed - let res' = map (\(GHC.L l n) -> (showGhcQual $ GHC.nameUnique n,showGhcQual (l, GHC.getSrcSpan n, n))) res - - let res'' = foldl' (\m (k,a) -> Map.insertWith (++) k a m) Map.empty res' - - (sort $ Map.elems res'') `shouldBe` - ["(TypeUtils/S.hs:10:12, TypeUtils/S.hs:10:8, n)(TypeUtils/S.hs:10:8, TypeUtils/S.hs:10:8, n)" - ,"(TypeUtils/S.hs:10:14, , GHC.Num.+)" - ,"(TypeUtils/S.hs:10:5-6, TypeUtils/S.hs:10:5-6, zz)(TypeUtils/S.hs:10:5-6, TypeUtils/S.hs:10:5-6, zz)(TypeUtils/S.hs:8:13-14, TypeUtils/S.hs:10:5-6, zz)" - ,"(TypeUtils/S.hs:4:1-3, TypeUtils/S.hs:4:1-3, TypeUtils.S.foo)(TypeUtils/S.hs:4:1-3, TypeUtils/S.hs:4:1-3, TypeUtils.S.foo)" - ,"(TypeUtils/S.hs:4:13-15, , GHC.Real.odd)" - ,"(TypeUtils/S.hs:4:17, TypeUtils/S.hs:4:5, x)(TypeUtils/S.hs:4:5, TypeUtils/S.hs:4:5, x)" - ,"(TypeUtils/S.hs:6:10, TypeUtils/S.hs:6:10, TypeUtils.S.A)" - ,"(TypeUtils/S.hs:6:14, TypeUtils/S.hs:6:14-21, TypeUtils.S.B)" - ,"(TypeUtils/S.hs:6:25, TypeUtils/S.hs:6:25, TypeUtils.S.C)" - ,"(TypeUtils/S.hs:6:6, TypeUtils/S.hs:6:1-25, TypeUtils.S.D)" - ,"(TypeUtils/S.hs:8:1-7, TypeUtils/S.hs:8:1-7, TypeUtils.S.subdecl)(TypeUtils/S.hs:8:1-7, TypeUtils/S.hs:8:1-7, TypeUtils.S.subdecl)" - ,"(TypeUtils/S.hs:8:16, TypeUtils/S.hs:8:9, x)(TypeUtils/S.hs:8:9, TypeUtils/S.hs:8:9, x)" - ] - - -- ------------------------------------------------------------------- - - describe "getName" $ do - it "gets a qualified Name at the top level" $ do - t <- ct $ parsedFileGhc "./TypeUtils/B.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let Just n = getName "TypeUtils.B.foo'" renamed - (showGhcQual n) `shouldBe` "TypeUtils.B.foo'" - (showGhcQual $ GHC.getSrcSpan n) `shouldBe` "TypeUtils/B.hs:14:1-4" - - it "gets any instance of an unqualified Name" $ do - t <- ct $ parsedFileGhc "./TypeUtils/B.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let Just n = getName "foo" renamed - (showGhcQual n) `shouldBe` "foo" - (showGhcQual $ GHC.getSrcSpan n) `shouldBe` "TypeUtils/B.hs:9:15-17" - - it "returns Nothing if the Name is not found" $ do - t <- ct $ parsedFileGhc "./TypeUtils/B.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let res = getName "baz" renamed - (showGhcQual res) `shouldBe` "Nothing" - - -- ------------------------------------------------------------------- - - describe "definingDeclsRdrNames" $ do - it "returns [] if not found" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let renamed = fromJust $ GHC.tm_renamed_source t - let nameMap = initRdrNameMap t - let Just ((GHC.L _ n)) = locToName (16,6) renamed - let decls = GHC.hsmodDecls $ GHC.unLoc parsed - let res = definingDeclsRdrNames nameMap [n] decls False False - showGhcQual res `shouldBe` "[]" - - -- --------------------------------- - - it "finds declarations at the top level" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let nameMap = initRdrNameMap t - - let Just (GHC.L _ n) = locToName (3,3) renamed - let decls = GHC.hsmodDecls $ GHC.unLoc parsed - let res = definingDeclsRdrNames nameMap [n] decls False False - showGhcQual res `shouldBe` "[toplevel x = c * x]" - - -- --------------------------------- - - it "finds declarations not at the top level 1" $ do - t <- ct $ parsedFileGhc "./LiftToToplevel/WhereIn6.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let nameMap = initRdrNameMap t - - let Just (GHC.L _ n) = locToName (13,29) renamed - let decls = GHC.hsmodDecls $ GHC.unLoc parsed - let res = definingDeclsRdrNames nameMap [n] decls False True - showGhcQual n `shouldBe` "pow" - showGhcQual res `shouldBe` "[pow = 2]" - - -- --------------------------------- - - it "finds declarations not at the top level 2" $ do - t <- ct $ parsedFileGhc "./LiftToToplevel/LetIn1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let nameMap = initRdrNameMap t - - let Just (GHC.L _ n) = locToName (11,22) renamed - let decls = GHC.hsmodDecls $ GHC.unLoc parsed - let res = definingDeclsRdrNames nameMap [n] decls False True - showGhcQual n `shouldBe` "sq" - showGhcQual res `shouldBe` "[sq 0 = 0\n sq z = z ^ pow]" - - -- --------------------------------- - - it "finds in a patbind" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let nameMap = initRdrNameMap t - - let Just (GHC.L _ n) = locToName (14,1) renamed - let decls = GHC.hsmodDecls $ GHC.unLoc parsed - let res = definingDeclsRdrNames nameMap [n] decls False False - showGhcQual res `shouldBe` "[tup@(h, t)\n = head $ zip [1 .. 10] [3 .. ff]\n where\n ff :: Int\n ff = 15]" - - -- --------------------------------- - - it "finds recursively in sub-binds" $ do - {- - modInfo@((_, _, mod@(GHC.L l (GHC.HsModule name exps imps ds _ _))), toks) <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let res = definingDecls [(PN (mkRdrName "zz"))] ds False True - showGhcQual res `shouldBe` "[zz n = n + 1]" -- TODO: Currently fails, will come back to it - -} - pending -- "Currently fails, will come back to it" - - -- --------------------------------- - - it "only finds recursively in sub-binds if asked" $ do - {- - modInfo@((_, _, mod@(GHC.L l (GHC.HsModule name exps imps ds _ _))), toks) <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let res = definingDecls [(PN (mkRdrName "zz"))] ds False False - showGhcQual res `shouldBe` "[]" - -} - pending -- "Convert to definingDeclsNames" - - -- ------------------------------------------------------------------- - - describe "definingDeclsNames" $ do - it "returns [] if not found" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just ((GHC.L _ n)) = locToName (16,6) renamed - let res = definingDeclsNames [n] (hsBinds renamed) False False - showGhcQual res `shouldBe` "[]" - - it "finds declarations at the top level" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just (GHC.L _ n) = locToName (3,3) renamed - let res = definingDeclsNames [n] (hsBinds renamed) False False - showGhcQual res `shouldBe` "[DupDef.Dd1.toplevel x = DupDef.Dd1.c GHC.Num.* x]" - - - it "finds in a patbind" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just (GHC.L _ n) = locToName (14,1) renamed - let res = definingDeclsNames [n] (hsBinds renamed) False False - showGhcQual res `shouldBe` "[DupDef.Dd1.tup@(DupDef.Dd1.h, DupDef.Dd1.t)\n = GHC.List.head GHC.Base.$ GHC.List.zip [1 .. 10] [3 .. ff]\n where\n ff :: GHC.Types.Int\n ff = 15]" - - - it "finds recursively in sub-binds" $ do - {- - modInfo@((_, _, mod@(GHC.L l (GHC.HsModule name exps imps ds _ _))), toks) <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let res = definingDecls [(PN (mkRdrName "zz"))] ds False True - showGhcQual res `shouldBe` "[zz n = n + 1]" -- TODO: Currently fails, will come back to it - -} - pending -- "Currently fails, will come back to it" - - it "only finds recursively in sub-binds if asked" $ do - {- - modInfo@((_, _, mod@(GHC.L l (GHC.HsModule name exps imps ds _ _))), toks) <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let res = definingDecls [(PN (mkRdrName "zz"))] ds False False - showGhcQual res `shouldBe` "[]" - -} - pending -- "Convert to definingDeclsNames" - - -- ------------------------------------------------------------------- - - describe "definingSigsRdrNames" $ do - it "returns [] if not found" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let nameMap = initRdrNameMap t - - let Just ((GHC.L _ n)) = locToName (21,1) renamed - showGhcQual n `shouldBe` "DupDef.Dd1.ff" - let res = definingSigsRdrNames nameMap [n] parsed - showGhcQual res `shouldBe` "[]" - - -- --------------------------------- - - it "finds signatures at the top level" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let nameMap = initRdrNameMap t - - let Just ((GHC.L _ n)) = locToName (4,1) renamed - showGhcQual n `shouldBe` "DupDef.Dd1.toplevel" - let res = definingSigsRdrNames nameMap [n] parsed - showGhcQual res `shouldBe` "[toplevel :: Integer -> Integer]" - - -- --------------------------------- - - it "returns only the single signature where there are others too" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let nameMap = initRdrNameMap t - - let Just ((GHC.L _ n)) = locToName (7,1) renamed - showGhcQual n `shouldBe` "DupDef.Dd1.c" - let res = definingSigsRdrNames nameMap [n] parsed - showGhcQual res `shouldBe` "[c :: Integer]" - - -- --------------------------------- - - it "finds signatures at lower levels" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let nameMap = initRdrNameMap t - - let Just ((GHC.L _ n)) = locToName (16,5) renamed - showGhcQual n `shouldBe` "ff" - let res = definingSigsRdrNames nameMap [n] parsed - showGhcQual res `shouldBe` "[ff :: Int]" - - -- --------------------------------- - - it "finds multiple signatures 1" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let nameMap = initRdrNameMap t - - let Just ((GHC.L _ n1)) = locToName (21,1) renamed - showGhcQual n1 `shouldBe` "DupDef.Dd1.ff" - - let Just ((GHC.L _ n2)) = locToName (16,5) renamed - showGhcQual n2 `shouldBe` "ff" - - let Just ((GHC.L _ n3)) = locToName (4,1) renamed - showGhcQual n3 `shouldBe` "DupDef.Dd1.toplevel" - - let res = definingSigsRdrNames nameMap [n1,n2,n3] parsed - showGhcQual res `shouldBe` "[toplevel :: Integer -> Integer, ff :: Int]" - - -- --------------------------------- - - it "finds multiple signatures 2" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let nameMap = initRdrNameMap t - - let Just ((GHC.L _ n1)) = locToName (14,1) renamed - showGhcQual n1 `shouldBe` "DupDef.Dd1.tup" - - let Just ((GHC.L _ n2)) = locToName (14,6) renamed - showGhcQual n2 `shouldBe` "DupDef.Dd1.h" - - let Just ((GHC.L _ n3)) = locToName (14,8) renamed - showGhcQual n3 `shouldBe` "DupDef.Dd1.t" - - let res = definingSigsRdrNames nameMap [n1,n2,n3] parsed - showGhcQual res `shouldBe` "[tup :: (Int, Int), h :: Int, t :: Int]" - - -- ------------------------------------------------------------------- - - describe "definingSigsNames" $ do - it "returns [] if not found" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just ((GHC.L _ n)) = locToName (21,1) renamed - showGhcQual n `shouldBe` "DupDef.Dd1.ff" - let res = definingSigsNames [n] renamed - showGhcQual res `shouldBe` "[]" - - it "finds signatures at the top level" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just ((GHC.L _ n)) = locToName (4,1) renamed - showGhcQual n `shouldBe` "DupDef.Dd1.toplevel" - let res = definingSigsNames [n] renamed - showGhcQual res `shouldBe` "[DupDef.Dd1.toplevel ::\n GHC.Integer.Type.Integer -> GHC.Integer.Type.Integer]" - - it "returns only the single signature where there are others too" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just ((GHC.L _ n)) = locToName (7,1) renamed - showGhcQual n `shouldBe` "DupDef.Dd1.c" - let res = definingSigsNames [n] renamed - showGhcQual res `shouldBe` "[DupDef.Dd1.c :: GHC.Integer.Type.Integer]" - - it "finds signatures at lower levels" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just ((GHC.L _ n)) = locToName (16,5) renamed - showGhcQual n `shouldBe` "ff" - let res = definingSigsNames [n] renamed - showGhcQual res `shouldBe` "[ff :: GHC.Types.Int]" - - it "finds multiple signatures" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just ((GHC.L _ n1)) = locToName (21,1) renamed - showGhcQual n1 `shouldBe` "DupDef.Dd1.ff" - - let Just ((GHC.L _ n2)) = locToName (16,5) renamed - showGhcQual n2 `shouldBe` "ff" - - let Just ((GHC.L _ n3)) = locToName (4,1) renamed - showGhcQual n3 `shouldBe` "DupDef.Dd1.toplevel" - - let res = definingSigsNames [n1,n2,n3] renamed - showGhcQual res `shouldBe` "[ff :: GHC.Types.Int,\n DupDef.Dd1.toplevel ::\n GHC.Integer.Type.Integer -> GHC.Integer.Type.Integer]" - - - -- ------------------------------------------------------------------- - - describe "definingTyClDeclsNames" $ do - it "returns [] if not found" $ do - t <- ct $ parsedFileGhc "./TypeUtils/TyClDecls.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just ((GHC.L _ n)) = locToName (10,29) renamed - let res = definingTyClDeclsNames [n] renamed - showGhcQual res `shouldBe` "[]" - - -- --------------------------------- - - it "finds foreign type declarations" $ do - pending - - -- --------------------------------- - - it "finds family declarations" $ do - t <- ct $ parsedFileGhc "./TypeUtils/TyClDecls.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just (GHC.L _ n) = locToName (7,14) renamed - let res = definingTyClDeclsNames [n] renamed - showGhcQual res `shouldBe` "[data family TypeUtils.TyClDEcls.XList a]" - - -- --------------------------------- - - it "finds data declarations" $ do - t <- ct $ parsedFileGhc "./TypeUtils/TyClDecls.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just (GHC.L _ n) = locToName (12,6) renamed - let res = definingTyClDeclsNames [n] renamed - (unspace $ showGhcQual res) `shouldBe` "[data TypeUtils.TyClDEcls.Foo\n = TypeUtils.TyClDEcls.Foo GHC.Types.Int]" - - -- --------------------------------- - - it "finds type declarations" $ do - t <- ct $ parsedFileGhc "./TypeUtils/TyClDecls.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just (GHC.L _ n) = locToName (14,6) renamed - let res = definingTyClDeclsNames [n] renamed - showGhcQual res `shouldBe` "[type TypeUtils.TyClDEcls.Foo2 = GHC.Base.String]" - - -- --------------------------------- - - it "finds class declarations" $ do - t <- ct $ parsedFileGhc "./TypeUtils/TyClDecls.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just (GHC.L _ n) = locToName (16,7) renamed - let res = definingTyClDeclsNames [n] renamed - showGhcQual res `shouldBe` "[class TypeUtils.TyClDEcls.Bar a where\n TypeUtils.TyClDEcls.bar :: a -> GHC.Types.Bool]" - - -- --------------------------------- - - it "finds multiple declarations" $ do - t <- ct $ parsedFileGhc "./TypeUtils/TyClDecls.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just (GHC.L _ n1) = locToName (14,6) renamed - let Just (GHC.L _ n2) = locToName (16,7) renamed - let res = definingTyClDeclsNames [n1,n2] renamed - showGhcQual res `shouldBe` - "[type TypeUtils.TyClDEcls.Foo2 = GHC.Base.String,\n"++ - " class TypeUtils.TyClDEcls.Bar a where\n"++ - " TypeUtils.TyClDEcls.bar :: a -> GHC.Types.Bool]" - - - -- ------------------------------------------------------------------- - - describe "isFunBindR" $ do - it "Returns False if not a function definition" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just tup = getName "DupDef.Dd1.tup" renamed - let [decl] = definingDeclsNames [tup] (hsBinds renamed) False False - isFunBindR decl `shouldBe` False - - it "Returns True if a function definition" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let (GHC.L _l (GHC.HsModule _name _exps _imps _ds _ _)) = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just toplevel = getName "DupDef.Dd1.toplevel" renamed - let [decl] = definingDeclsNames [toplevel] (hsBinds renamed) False False - isFunBindR decl `shouldBe` True - - -- ------------------------------------------------------------------- - - describe "isFunOrPatName" $ do - it "Return True if a PName is a function/pattern name defined in t" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just tup = getName "DupDef.Dd1.tup" renamed - isFunOrPatName tup renamed `shouldBe` True - - it "Return False if a PName is a function/pattern name defined in t" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - t2 <- ct $ parsedFileGhc "./DupDef/Dd2.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let renamed2 = fromJust $ GHC.tm_renamed_source t2 - - let Just tup = getName "DupDef.Dd1.tup" renamed - isFunOrPatName tup renamed2 `shouldBe` False - - - -- ------------------------------------------------------------------- - - describe "hsFreeAndDeclaredXXXX" $ do - - it "finds declared in type class definitions" $ do - t <- ct $ parsedFileGhc "./FreeAndDeclared/DeclareTypes.hs" - - let - comp = do - parsed <- getRefactParsed - decls <- liftT $ hsDecls parsed - tdss <- mapM getDeclaredTypesRdr decls - let tds = nub $ concat tdss - return (tds) - ((res),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (res)) `shouldBe` - "[(FreeAndDeclared.DeclareTypes.XList, (8, 1)),\n"++ - " (FreeAndDeclared.DeclareTypes.X, (19, 1)),\n"++ - " (FreeAndDeclared.DeclareTypes.Y, (19, 10)),\n"++ - " (FreeAndDeclared.DeclareTypes.Z, (19, 22)),\n"++ - " (FreeAndDeclared.DeclareTypes.W, (19, 26)),\n"++ - " (FreeAndDeclared.DeclareTypes.Foo, (21, 1)),\n"++ - " (FreeAndDeclared.DeclareTypes.Bar, (23, 1)),\n"++ - " (FreeAndDeclared.DeclareTypes.doBar, (27, 3)),\n"++ - " (FreeAndDeclared.DeclareTypes.BarVar, (24, 3)),\n"++ - " (FreeAndDeclared.DeclareTypes.BarData, (25, 3))]" - - -- --------------------------------- - - it "finds declared HsVar" $ do - t <- ct $ parsedFileGhc "./FreeAndDeclared/Declare.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let - comp = do - parsed <- getRefactParsed - nm <- getRefactNameMap - let rr = hsFreeAndDeclaredRdr nm parsed - let r = hsFreeAndDeclaredPNsOld renamed - rg <- hsFreeAndDeclaredPNs renamed - return (r,rg,rr) - -- ((res,resg,rrr),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - ((res,resg,(FN fr,DN dr)),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - -- (showGhcQual _fff) `shouldBe` "" - - -- --------------------- - -- Free Vars - renamed - (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst res)) `shouldBe` - "[(Data.Generics.Text.gshow, (-1, -1)),\n "++ - "(System.IO.getChar, (-1, -1)), "++ - "(System.IO.putStrLn, (-1, -1)),\n "++ - "(GHC.Base.return, (-1, -1)), "++ - "(GHC.Base.$, (-1, -1)),\n "++ - "(GHC.List.head, (-1, -1)), "++ - "(GHC.List.zip, (-1, -1)),\n "++ - "(GHC.Num.fromInteger, (-1, -1)), "++ - "(GHC.Num.*, (-1, -1))]" - - -- Declared Vars - renamed - (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd res)) `shouldBe` - "[(FreeAndDeclared.Declare.ff, (36, 1)),\n "++ - "(FreeAndDeclared.Declare.mkT, (34, 1)),\n "++ - "(FreeAndDeclared.Declare.main, (30, 1)),\n "++ - "(FreeAndDeclared.Declare.unF, (27, 1)),\n "++ - "(FreeAndDeclared.Declare.unD, (21, 1)),\n "++ - "(FreeAndDeclared.Declare.tup, (16, 1)),\n "++ -- ++AZ++ addition - "(FreeAndDeclared.Declare.h, (16, 6)),\n "++ - "(FreeAndDeclared.Declare.t, (16, 8)),\n "++ - "(FreeAndDeclared.Declare.d, (10, 1)),\n "++ - "(FreeAndDeclared.Declare.c, (9, 1)),\n "++ - "(FreeAndDeclared.Declare.toplevel, (6, 1))]" - - -- --------------------- - -- Free Vars - parsed - (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) fr) `shouldBe` - "[(GHC.Num.*, (-1, -1)), "++ - "(GHC.Base.$, (-1, -1)),\n "++ - "(GHC.List.head, (-1, -1)), "++ - "(GHC.List.zip, (-1, -1)),\n "++ - "(System.IO.getChar, (-1, -1)), "++ - "(System.IO.putStrLn, (-1, -1)),\n "++ - "(Data.Generics.Text.gshow, (-1, -1))]" - - -- Declared Vars - parsed - (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) dr) `shouldBe` - "[(FreeAndDeclared.Declare.toplevel, (6, 1)),\n "++ - "(FreeAndDeclared.Declare.c, (9, 1)),\n "++ - "(FreeAndDeclared.Declare.d, (10, 1)),\n "++ - "(FreeAndDeclared.Declare.tup, (16, 1)),\n "++ - "(FreeAndDeclared.Declare.h, (16, 6)),\n "++ - "(FreeAndDeclared.Declare.t, (16, 8)),\n "++ - "(FreeAndDeclared.Declare.unD, (21, 1)),\n "++ - "(FreeAndDeclared.Declare.unF, (27, 1)),\n "++ - "(FreeAndDeclared.Declare.main, (30, 1)),\n "++ - "(FreeAndDeclared.Declare.mkT, (34, 1)),\n "++ - "(FreeAndDeclared.Declare.ff, (36, 1))]" - - -- --------------------- - -- GHC version - -- Free Vars - (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst resg)) `shouldBe` - "[(Data.Generics.Text.gshow, (-1, -1)),\n "++ - "(System.IO.getChar, (-1, -1)), "++ - "(System.IO.putStrLn, (-1, -1)),\n "++ - "(GHC.List.head, (-1, -1)), "++ - "(GHC.Base.$, (-1, -1)),\n "++ - "(GHC.List.zip, (-1, -1)), "++ - "(GHC.Num.*, (-1, -1))]" - - -- Declared Vars - (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd resg)) `shouldBe` - "[(FreeAndDeclared.Declare.ff, (36, 1)),\n "++ - "(FreeAndDeclared.Declare.mkT, (34, 1)),\n "++ - "(FreeAndDeclared.Declare.main, (30, 1)),\n "++ - "(FreeAndDeclared.Declare.unF, (27, 1)),\n "++ - "(FreeAndDeclared.Declare.unD, (21, 1)),\n "++ - "(FreeAndDeclared.Declare.tup, (16, 1)),\n "++ -- ++AZ++ not found by old - "(FreeAndDeclared.Declare.h, (16, 6)),\n "++ - "(FreeAndDeclared.Declare.t, (16, 8)),\n "++ - "(FreeAndDeclared.Declare.d, (10, 1)),\n "++ - "(FreeAndDeclared.Declare.c, (9, 1)),\n "++ - "(FreeAndDeclared.Declare.toplevel, (6, 1)),\n "++ - "(GHC.Types.Int, (-1, -1)), (GHC.Integer.Type.Integer, (-1, -1)),\n "++ - "(FreeAndDeclared.Declare.D, (18, 1)),\n "++ - "(FreeAndDeclared.Declare.A, (18, 10)),\n "++ - "(FreeAndDeclared.Declare.B, (18, 14)),\n "++ - "(FreeAndDeclared.Declare.C, (18, 25)),\n "++ - "(FreeAndDeclared.Declare.F, (25, 1)),\n "++ - "(FreeAndDeclared.Declare.G, (25, 10)),\n "++ - "(FreeAndDeclared.Declare.:|, (25, 14))]" - - -- --------------------------------- - - it "finds free and declared in a single bind PrefixCon" $ do - t <- ct $ parsedFileGhc "./FreeAndDeclared/Declare.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - -- (SYB.showData SYB.Renamer 0 renamed) `shouldBe` "" - - let - comp = do - let b = head $ drop 4 $ hsBinds renamed - rg <- hsFreeAndDeclaredPNs [b] - return (b,rg) - ((bb,resg),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - - (showGhcQual bb) `shouldBe` "FreeAndDeclared.Declare.unD (FreeAndDeclared.Declare.B y) = y" - -- (SYB.showData SYB.Renamer 0 bb) `shouldBe` "" - - -- GHC version - -- Free Vars - (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst resg)) `shouldBe` - "[(FreeAndDeclared.Declare.B, (18, 14))]" - - -- Declared Vars - (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd resg)) `shouldBe` - "[(FreeAndDeclared.Declare.unD, (21, 1))]" - - -- --------------------------------- - - it "finds free and declared in a single bind InfixCon" $ do - t <- ct $ parsedFileGhc "./FreeAndDeclared/Declare.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - -- (SYB.showData SYB.Renamer 0 renamed) `shouldBe` "" - - let - comp = do - let b = head $ drop 3 $ hsBinds renamed - rg <- hsFreeAndDeclaredPNs [b] - return (b,rg) - ((bb,resg),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual bb) `shouldBe` "FreeAndDeclared.Declare.unF (a FreeAndDeclared.Declare.:| b)\n = (a, b)" - -- (SYB.showData SYB.Renamer 0 bb) `shouldBe` "" - - -- GHC version - -- Free Vars - (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst resg)) `shouldBe` - "[(FreeAndDeclared.Declare.:|, (25, 14))]" - - -- Declared Vars - (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd resg)) `shouldBe` - "[(FreeAndDeclared.Declare.unF, (27, 1))]" - - -- --------------------------------- - - it "finds free and declared in a single bind RecCon" $ do - t <- ct $ parsedFileGhc "./FreeAndDeclared/DeclareRec.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - -- (SYB.showData SYB.Renamer 0 renamed) `shouldBe` "" - - let - comp = do - let b = head $ drop 0 $ hsBinds renamed - rg <- hsFreeAndDeclaredPNs [b] - return (b,rg) - ((bb,resg),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - - (showGhcQual bb) `shouldBe` "FreeAndDeclared.DeclareRec.unR2\n (FreeAndDeclared.DeclareRec.RCon {FreeAndDeclared.DeclareRec.r1 = a})\n = a" - -- (SYB.showData SYB.Renamer 0 bb) `shouldBe` "" - - -- GHC version - -- Free Vars - (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst resg)) `shouldBe` - "[(FreeAndDeclared.DeclareRec.RCon, (3, 10))]" - - -- Declared Vars - (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd resg)) `shouldBe` - "[(FreeAndDeclared.DeclareRec.unR2, (7, 1))]" - - -- ----------------------------------------------------------------- - - it "hsFreeAndDeclaredPNs simplest" $ do - t <- ct $ parsedFileGhc "./FreeAndDeclared/DeclareS.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let - comp = do - r <- hsFreeAndDeclaredPNs renamed - return r - ((res),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - -- Free Vars - (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst res)) `shouldBe` "[]" - - -- Declared Vars - (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd res)) `shouldBe` "[(FreeAndDeclared.DeclareS.c, (6, 1))]" - - -- ----------------------------------------------------------------- - - it "finds free and declared in a single bind #2" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just tup = getName "DupDef.Dd1.ff" renamed - let [decl] = definingDeclsNames [tup] (hsBinds renamed) False False - - let - comp = do - r <- hsFreeAndDeclaredPNs [decl] - return (r,decl) - ((res,d),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual d) `shouldBe` "DupDef.Dd1.ff y\n = y GHC.Num.+ zz\n where\n zz = 1" - -- (SYB.showData SYB.Renamer 0 d) `shouldBe` "" - - -- Free Vars - (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst res)) `shouldBe` - "[(GHC.Num.+, (-1, -1))]" - - -- Declared Vars - (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd res)) `shouldBe` - "[(DupDef.Dd1.ff, (21, 1))]" - - -- ----------------------------------------------------------------- - - it "finds free and declared at the top level 1" $ do - t <- ct $ parsedFileGhc "./LiftToToplevel/WhereIn1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let - comp = do - r <- hsFreeAndDeclaredPNs $ hsBinds renamed - return r - ((res),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - -- Declared Vars - (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd res)) `shouldBe` - "[(LiftToToplevel.WhereIn1.anotherFun, (15, 1)),\n "++ - "(LiftToToplevel.WhereIn1.sumSquares, (9, 1))]" - - -- Free Vars - (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst res)) `shouldBe` - "[(GHC.Real.^, (-1, -1)), (GHC.Num.+, (-1, -1))]" - - -- ----------------------------------------------------------------- - - it "finds free and declared at the top level 2" $ do - t <- ct $ parsedFileGhc "./Renaming/IdIn3.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let - comp = do - r <- hsFreeAndDeclaredPNs renamed - return r - ((res),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - -- Declared Vars - (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd res)) `shouldBe` - "[(IdIn3.bar, (14, 1))"++ - ", (IdIn3.x, (10, 1))"++ - ", (IdIn3.foo, (12, 1)),\n "++ - "(IdIn3.main, (18, 1))]" - - - -- Free Vars - (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst res)) `shouldBe` - "[(GHC.Num.+, (-1, -1))]" - - -- ----------------------------------------------------------------- - - it "finds free and declared in a GRHSs" $ do - t <- ct $ parsedFileGhc "./LiftOneLevel/LetIn2.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just tup = getName "LiftOneLevel.LetIn2.sumSquares" renamed - let [decl] = definingDeclsNames [tup] (hsBinds renamed) False False - - let (GHC.L _ (GHC.FunBind _ _ (GHC.MG [match] _ _ _) _ _ _)) = decl - let (GHC.L _ (GHC.Match _ _pat _ grhss)) = match - - let - comp = do - r <- hsFreeAndDeclaredPNs grhss - return r - ((res),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - - -- Declared Vars - (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd res)) `shouldBe` - "[]" - - -- Free Vars - (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst res)) `shouldBe` - "[(GHC.Real.^, (-1, -1)), (x, (10, 12)), (GHC.Num.+, (-1, -1)),\n (y, (10, 14))]" - - -- ----------------------------------------------------------------- - - it "finds free and declared in a single bind" $ do - pending -- "fix the prior test" - - -- --------------------------------------------------------------------- - - - describe "hsFDsFromInsideRdr" $ do - it "does something useful" $ do - pending -- "Complete this" - - describe "hsFDsFromInside" $ do - it "does something useful" $ do - pending -- "Complete this" - - describe "hsFDNamesFromInside" $ do - it "does something useful" $ do - pending -- "Complete this" - - -- --------------------------------------------------------------------- - - describe "hsVisibleNames" $ do - it "does something useful" $ do - pending -- "Complete this" - - -- --------------------------------------------------------------------- - - describe "hsVisiblePNs" $ do - - -- --------------------------------- - - it "returns [] if e does not occur in t" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just tl1 = locToExp (4,13) (4,40) renamed :: (Maybe (GHC.Located (GHC.HsExpr GHC.Name))) - let Just tup = getName "DupDef.Dd1.tup" renamed - let - comp = do - r <- hsVisiblePNs tup tl1 - return r - ((res),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual $ res) `shouldBe` "[]" - - -- ----------------------------------------------------------------- - - it "returns visible vars if e does occur in t #1" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just tl1 = locToExp (28,4) (28,12) renamed :: (Maybe (GHC.Located (GHC.HsExpr GHC.Name))) - (showGhcQual tl1) `shouldBe` "ll GHC.Num.+ z" - - let Just tup = getName "DupDef.Dd1.l" renamed - let [decl] = definingDeclsNames [tup] (hsBinds renamed) False False - (showGhcQual decl) `shouldBe` "DupDef.Dd1.l z = let ll = 34 in ll GHC.Num.+ z" - - let - comp = do - r <- hsVisiblePNs tl1 decl - return (r) - ((res),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual res ) `shouldBe` "[z, ll]" - -- (showGhcQual res2 ) `shouldBe` "[z, ll]" - - -- ----------------------------------------------------------------- - - it "returns visible vars if e does occur in t #2" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just tl1 = locToExp (28,4) (28,12) renamed :: (Maybe (GHC.Located (GHC.HsExpr GHC.Name))) - (showGhcQual tl1) `shouldBe` "ll GHC.Num.+ z" - - let Just rhs = locToExp (26,1) (28,12) renamed :: (Maybe (GHC.Located (GHC.HsExpr GHC.Name))) - (showGhcQual rhs) `shouldBe` "let ll = 34 in ll GHC.Num.+ z" - - let - comp = do - r <- hsVisiblePNs tl1 rhs - return r - ((res),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual res) `shouldBe` "[ll]" - - -- ----------------------------------------------------------------- - -{- - it "returns visible vars if e does occur in t #3" $ do - (t,toks) <- ct $ parsedFileGhc "./TypeUtils/VisiblePNs.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - (SYB.showData SYB.Renamer 0 renamed) `shouldBe` "" - - let - comp = do - renamed <- getRefactRenamed - let Just tl1 = locToName (41,11) renamed -- :: (Maybe (GHC.Located (GHC.HsExpr GHC.Name))) - r <- hsVisiblePNs tl1 renamed - -- let r = hsVisiblePNsGhc tl1 renamed - let fvs = map (\b -> (showGhcQual b,getFreeVars [b])) (hsBinds renamed) - let dvs = getDeclaredVars $ hsBinds renamed - return (tl1,r,fvs,dvs) - -- ((tl,res,_f,d),_s) <- runRefactGhc comp $ initialState { rsModule = initRefactModule [] t } - ((tl,res,_f,d),_s) <- runRefactGhc comp $ initialLogOnState { rsModule = initRefactModule [] t } - - (showGhcQual tl) `shouldBe` "modu" - -- (showGhcQual f) `shouldBe` "" - (showGhcQual d) `shouldBe` - "[TypeUtils.VisiblePNs.parsedFileGhc,\n"++ - " TypeUtils.VisiblePNs.parsedFileBGhc,\n"++ - " TypeUtils.VisiblePNs.runRefactGhcState,"++ - " TypeUtils.VisiblePNs.zz,\n"++ - " TypeUtils.VisiblePNs.yy,"++ - " TypeUtils.VisiblePNs.xx,\n"++ - " TypeUtils.VisiblePNs.ww,"++ - " TypeUtils.VisiblePNs.spec,\n"++ - " TypeUtils.VisiblePNs.main]" - (showGhcQual res) `shouldBe` - "[TypeUtils.VisiblePNs.parsedFileGhc,\n"++ - " TypeUtils.VisiblePNs.parsedFileBGhc,\n"++ - " TypeUtils.VisiblePNs.runRefactGhcState,"++ - " TypeUtils.VisiblePNs.zz,\n"++ - " TypeUtils.VisiblePNs.yy,"++ - " TypeUtils.VisiblePNs.xx,\n"++ - " TypeUtils.VisiblePNs.ww,"++ - " TypeUtils.VisiblePNs.spec,\n"++ - " TypeUtils.VisiblePNs.main,"++ - " modu,"++ - " t,"++ - " _toks,"++ - " expr]" --} - - -- --------------------------------------------------------------------- - - describe "hsVisibleDsRdr" $ do - it "Rdr:finds function arguments visible in RHS 1" $ do - t <- ct $ parsedFileGhc "./Visible/Simple.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let Just e = locToExp (5,11) (5,19) parsed :: (Maybe (GHC.LHsExpr GHC.RdrName)) - (showGhcQual e) `shouldBe` "a + b" - - let Just n = getName "Visible.Simple.params" renamed - - let - comp = do - nameMap <- getRefactNameMap - declsp <- liftT $ hsDecls parsed - let [decl] = definingDeclsRdrNames nameMap [n] declsp False False - fds' <- hsVisibleDsRdr nameMap e decl - return (fds') - -- ((fds),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - ((fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (show fds) `shouldBe` "DN [a, b, GHC.Num.+]" - - -- ----------------------------------- - - it "Rdr:finds function arguments visible in RHS 2" $ do - t <- ct $ parsedFileGhc "./Visible/Simple.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - -- (SYB.showData SYB.Renamer 0 renamed) `shouldBe` "" - - let Just e = locToExp (9,15) (9,17) parsed :: (Maybe (GHC.LHsExpr GHC.RdrName)) - (showGhcQual e) `shouldBe` "x" - - let Just n = getName "Visible.Simple.param2" renamed - - let - comp = do - nameMap <- getRefactNameMap - declsp <- liftT $ hsDecls parsed - let [decl] = definingDeclsRdrNames nameMap [n] declsp False False - fds' <- hsVisibleDsRdr nameMap e decl - return (fds') - -- ((fds),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - ((fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (show fds) `shouldBe` "DN [x]" - - - -- ----------------------------------- - - it "Rdr:finds visible vars inside a function" $ do - t <- ct $ parsedFileGhc "./Renaming/IdIn5.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let Just rhsr = locToExp (14,6) (15,14) renamed :: (Maybe (GHC.LHsExpr GHC.Name)) - let Just rhs = locToExp (14,6) (15,14) parsed :: (Maybe (GHC.LHsExpr GHC.RdrName)) - (showGhcQual rhs) `shouldBe` "x + y + z" - - -- let Just er = getName "IdIn5.x" renamed - let Just e = locToRdrName (14,7) parsed - (showGhcQual e) `shouldBe` "x" - (SYB.showData SYB.Parser 0 e) `shouldBe` "\n(L {Renaming/IdIn5.hs:14:7} \n (Unqual {OccName: x}))" - - let - comp = do - nameMap <- getRefactNameMap - fds' <- hsVisibleDsRdr nameMap e rhs - ffds <- hsFreeAndDeclaredGhc rhsr - return (fds',ffds) - -- ((fds,_fds),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - ((fds,_fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (show _fds) `shouldBe` "(FN [IdIn5.x, GHC.Num.+, y, z],DN [])" - (show fds) `shouldBe` "DN [GHC.Num.+, IdIn5.x, y, z]" - - -- ----------------------------------- - - it "Rdr:finds visible vars inside a data declaration" $ do - t <- ct $ parsedFileGhc "./Renaming/D1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let Just ln = locToRdrName (6, 6) parsed - (showGhcQual ln) `shouldBe` "Tree" - (SYB.showData SYB.Parser 0 ln) `shouldBe` "\n(L {Renaming/D1.hs:6:6-9} \n (Unqual {OccName: Tree}))" - - let - comp = do - nameMap <- getRefactNameMap - fds' <- hsVisibleDsRdr nameMap ln parsed - ffds <- hsFreeAndDeclaredGhc renamed - return (fds',ffds) - ((fds,_fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- ((fds,_fds),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - - (show _fds) `shouldBe` "(FN [:, GHC.Num.+, GHC.Real.^, [], GHC.Base.++],"++ - "DN [Renaming.D1.sumSquares, Renaming.D1.fringe, Renaming.D1.Tree, a,\n"++ - " Renaming.D1.Leaf, Renaming.D1.Branch, Renaming.D1.SameOrNot,\n"++ - " Renaming.D1.isSame, Renaming.D1.isNotSame])" - (show fds) `shouldBe` "DN [Renaming.D1.Tree, Renaming.D1.Leaf, Renaming.D1.Branch]" - - - -- --------------------------------------------------------------------- - - describe "hsVisibleDs" $ do - it "finds function arguments visible in RHS 1" $ do - t <- ct $ parsedFileGhc "./Visible/Simple.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - -- (SYB.showData SYB.Renamer 0 renamed) `shouldBe` "" - - let Just e = locToExp (5,11) (5,19) renamed :: (Maybe (GHC.LHsExpr GHC.Name)) - (showGhcQual e) `shouldBe` "a GHC.Num.+ b" - - let Just n = getName "Visible.Simple.params" renamed - let [decl] = definingDeclsNames [n] (hsBinds renamed) False False - - let binds = hsValBinds [decl] - - let - comp = do - fds' <- hsVisibleDs e $ head $ hsBinds binds - return (fds') - -- ((fds),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - ((fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (show fds) `shouldBe` "DN [a, b, GHC.Num.+]" - - -- ----------------------------------- - - it "finds function arguments visible in RHS 2" $ do - t <- ct $ parsedFileGhc "./Visible/Simple.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just e = locToExp (9,15) (9,17) renamed :: (Maybe (GHC.LHsExpr GHC.Name)) - (showGhcQual e) `shouldBe` "x" - - let Just n = getName "Visible.Simple.param2" renamed - let [decl] = definingDeclsNames [n] (hsBinds renamed) False False - - let binds = hsValBinds [decl] - - let - comp = do - fds' <- hsVisibleDs e $ head $ hsBinds binds - return (fds') - ((fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (show fds) `shouldBe` "DN [x]" - - - -- ----------------------------------- - - it "finds visible vars inside a function" $ do - t <- ct $ parsedFileGhc "./Renaming/IdIn5.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just rhs = locToExp (14,6) (15,14) renamed :: (Maybe (GHC.LHsExpr GHC.Name)) - (showGhcQual rhs) `shouldBe` "IdIn5.x GHC.Num.+ y GHC.Num.+ z" - - let Just e = getName "IdIn5.x" renamed - - let - comp = do - fds' <- hsVisibleDs e rhs - ffds <- hsFreeAndDeclaredGhc rhs - return (fds',ffds) - ((fds,_fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (show _fds) `shouldBe` "(FN [IdIn5.x, GHC.Num.+, y, z],DN [])" - (show fds) `shouldBe` "DN [GHC.Num.+, y, z]" - - -- ----------------------------------- - - it "finds visible vars inside a data declaration" $ do - t <- ct $ parsedFileGhc "./Renaming/D1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just (GHC.L _ n) = locToName (6, 6) renamed - (showGhcQual n) `shouldBe` "Renaming.D1.Tree" - - let - comp = do - fds' <- hsVisibleDs n renamed - ffds <- hsFreeAndDeclaredGhc renamed - return (fds',ffds) - ((fds,_fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (show _fds) `shouldBe` "(FN [:, GHC.Num.+, GHC.Real.^, [], GHC.Base.++],"++ - "DN [Renaming.D1.sumSquares, Renaming.D1.fringe, Renaming.D1.Tree, a,\n "++ - "Renaming.D1.Leaf, Renaming.D1.Branch, Renaming.D1.SameOrNot,\n "++ - "Renaming.D1.isSame, Renaming.D1.isNotSame])" - (show fds) `shouldBe` "DN [Renaming.D1.Tree, Renaming.D1.Leaf, Renaming.D1.Branch]" - - - -- --------------------------------------------------------------------- - - describe "hsFreeAndDeclaredGhc" $ do - it "finds function arguments visible in RHS fd" $ do - t <- ct $ parsedFileGhc "./Visible/Simple.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - -- (SYB.showData SYB.Renamer 0 renamed) `shouldBe` "" - - let Just e = locToExp (5,11) (5,19) renamed :: (Maybe (GHC.Located (GHC.HsExpr GHC.Name))) - (showGhcQual e) `shouldBe` "a GHC.Num.+ b" - - let Just n = getName "Visible.Simple.params" renamed - let [decl] = definingDeclsNames [n] (hsBinds renamed) False False - - let binds = hsValBinds [decl] - - let - comp = do - fds' <- hsFreeAndDeclaredGhc $ head $ hsBinds binds - return (fds') - ((fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (show fds) `shouldBe` "(FN [GHC.Num.+],DN [Visible.Simple.params])" - - -- ----------------------------------- - - it "finds function arguments and free vars visible in RHS" $ do - t <- ct $ parsedFileGhc "./Visible/Simple.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just e = locToExp (9,15) (9,17) renamed :: (Maybe (GHC.LHsExpr GHC.Name)) - (showGhcQual e) `shouldBe` "x" - - let Just n = getName "Visible.Simple.param2" renamed - let [decl] = definingDeclsNames [n] (hsBinds renamed) False False - - let binds = hsValBinds [decl] - let (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) = head $ hsBinds binds - let [(GHC.L _ (GHC.Match _ pats _ _))] = matches - let lpat = head pats - - let - comp = do - fds' <- hsFreeAndDeclaredGhc $ lpat - return (fds') - ((fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (show fds) `shouldBe` "(FN [Visible.Simple.B],DN [x])" - - -- ----------------------------------- - - it "finds imported functions used in the rhs" $ do - t <- ct $ parsedFileGhc "./FreeAndDeclared/Declare.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just n = getName "FreeAndDeclared.Declare.tup" renamed - let decls = definingDeclsNames [n] (hsBinds renamed) False False - - let - comp = do - fds' <- hsFreeAndDeclaredGhc $ decls - return (fds') - ((fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (show fds) `shouldBe` - "(FN [GHC.List.head, GHC.Base.$, GHC.List.zip],"++ - "DN [FreeAndDeclared.Declare.tup, FreeAndDeclared.Declare.h,\n "++ - "FreeAndDeclared.Declare.t])" - - -- ----------------------------------- - - it "finds free vars in HsWithBndrs" $ do - t <- ct $ parsedFileGhc "./FreeAndDeclared/Binders.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just n = getName "FreeAndDeclared.Binders.findNewPName" renamed - let [decl] = definingDeclsNames [n] (hsBinds renamed) False False - let (GHC.L _ (GHC.FunBind _ _ (GHC.MG [match] _ _ _) _ _ _)) = decl - let (GHC.L _ (GHC.Match _ _pats _rhs binds)) = match - - let - comp = do - fds' <- hsFreeAndDeclaredGhc $ binds - return (fds') - ((fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (show fds) `shouldBe` - "(FN [FreeAndDeclared.Binders.gfromJust,"++ - " FreeAndDeclared.Binders.Name,\n"++ - " FreeAndDeclared.Binders.occNameString,"++ - " GHC.Base.$,\n"++ - " FreeAndDeclared.Binders.getOccName,"++ - " GHC.Classes.==,"++ - " name,\n"++ - " GHC.Base.Just,"++ - " GHC.Base.Nothing,\n"++ - " FreeAndDeclared.Binders.somethingStaged,\n"++ - " FreeAndDeclared.Binders.Renamer,"++ - " renamed],"++ - "DN [worker, res])" - - -- ----------------------------------- - - it "finds free vars in TH files" $ do - t <- ct $ parsedFileGhc "./TH/Main.hs" - let - comp = do - parseSourceFileGhc "./TH/Main.hs" - parsed <- getRefactParsed - nm <- getRefactNameMap - let fds' = hsFreeAndDeclaredRdr nm parsed - return (fds') - ((fds),_s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (show fds) `shouldBe` - "(FN [System.IO.putStrLn, pr],"++ - "DN [TH.Main.main, TH.Main.baz, TH.Main.sillyString])" - - -- --------------------------------------------- - - describe "getParsedForRenamedLPat" $ do - it "gets the ParsedSource version of a RenamedSource LPat" $ do - t <- ct $ parsedFileGhc "./Visible/Simple.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let Just e = locToExp (9,15) (9,17) renamed :: (Maybe (GHC.LHsExpr GHC.Name)) - (showGhcQual e) `shouldBe` "x" - - let Just n = getName "Visible.Simple.param2" renamed - let [decl] = definingDeclsNames [n] (hsBinds renamed) False False - - let binds = hsValBinds [decl] - let (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) = head $ hsBinds binds - let [(GHC.L _ (GHC.Match _ pats _ _))] = matches - let pat@(GHC.L lp _) = head pats - - let pat' = getParsedForRenamedLPat parsed pat - - let (GHC.L lp' _) = pat' - lp `shouldBe` lp' - - (SYB.showData SYB.Renamer 0 pat') `shouldBe` - "\n"++ - "(L {Visible/Simple.hs:9:8-12} \n"++ - " (ParPat \n"++ - " (L {Visible/Simple.hs:9:9-11} \n"++ - " (ConPatIn \n"++ - " (L {Visible/Simple.hs:9:9} \n"++ - " (Unqual {OccName: B})) \n"++ - " (PrefixCon \n"++ - " [\n"++ - " (L {Visible/Simple.hs:9:11} \n"++ - " (VarPat \n"++ - " (Unqual {OccName: x})))])))))" - - (SYB.showData SYB.Renamer 0 pat) `shouldBe` - "\n"++ - "(L {Visible/Simple.hs:9:8-12} \n"++ - " (ParPat \n"++ - " (L {Visible/Simple.hs:9:9-11} \n"++ - " (ConPatIn \n"++ - " (L {Visible/Simple.hs:9:9} {Name: B}) \n"++ - " (PrefixCon \n"++ - " [\n"++ - " (L {Visible/Simple.hs:9:11} \n"++ - " (VarPat {Name: x}))])))))" - - - -- --------------------------------------------- - - describe "isLocalPN" $ do - it "returns True if the name is local to the module" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let Just (GHC.L _ n) = locToName (17, 5) renamed - (showGhcQual n) `shouldBe` "ff" - isLocalPN n `shouldBe` True - - it "returns False if the name is not local to the module" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let Just (GHC.L _ n) = locToName (21, 1) renamed - (showGhcQual n) `shouldBe` "DupDef.Dd1.ff" - isLocalPN n `shouldBe` False - - -- --------------------------------------------- - - describe "isTopLevelPN" $ do - it "returns False if the name is not defined at the top level of the module" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let - comp = do - renamed <- getRefactRenamed - let Just (GHC.L _ n) = locToName (17, 5) renamed - topLevel <- isTopLevelPN n - return (n,topLevel) - ((nf,tl),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - (showGhcQual nf) `shouldBe` "ff" - tl `shouldBe` False - - it "returns True if the name is defined at the top level of the module" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let - comp = do - renamed <- getRefactRenamed - let Just (GHC.L _ n) = locToName (21, 1) renamed - topLevel <- isTopLevelPN n - return (n,topLevel) - - ((nf,tl),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - (showGhcQual nf) `shouldBe` "DupDef.Dd1.ff" - tl `shouldBe` True - - -- --------------------------------------------- - - describe "definedPNs" $ do - it "gets the PNs defined in a declaration" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just (GHC.L _ pn) = locToName (3, 1) renamed - (showGhcQual pn) `shouldBe` "DupDef.Dd1.toplevel" - - let origDecls = hsBinds renamed - let demotedDecls'= definingDeclsNames [pn] origDecls True False - let declaredPns = nub $ concatMap definedPNs demotedDecls' - - (showGhcQual declaredPns) `shouldBe` "[DupDef.Dd1.toplevel]" - - -- --------------------------------- - - it "gets the PNs defined in an as-match" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just (GHC.L _ pn) = locToName (14, 1) renamed - (showGhcQual pn) `shouldBe` "DupDef.Dd1.tup" - - let origDecls = hsBinds renamed - let demotedDecls'= definingDeclsNames [pn] origDecls True False - let declaredPns = nub $ concatMap definedPNs demotedDecls' - - (showGhcQual declaredPns) `shouldBe` "[DupDef.Dd1.tup, DupDef.Dd1.h, DupDef.Dd1.t]" - - - -- --------------------------------------------- - - describe "inScopeInfo" $ do - it "returns 4 element tuples for in scope names" $ do - pending -- "is this still needed?" - {- - ((inscopes, _renamed, _parsed), _toks) <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let info = inScopeInfo inscopes - (show $ head info) `shouldBe` "foo" - -- (show $ info) `shouldBe` "foo" - -} - - -- --------------------------------------------- - - describe "isInScopeAndUnqualified" $ do - it "True if the identifier is in scope and unqualified" $ do - pending -- "needed?" - {- - ((inscopes, _renamed, _parsed), _toks) <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let info = inScopeInfo inscopes - (show $ head info) `shouldBe` "foo" - -} --- inScopeInfo for c is --- (\"DupDef.Dd1.c\",VarName,DupDef.Dd1,Nothing) - - -- --------------------------------------------- - - describe "isInScopeAndUnqualifiedGhc" $ do - it "True if the identifier is in scope and unqualified" $ do - let - comp = do - parseSourceFileGhc "./DupDef/Dd1.hs" - ctx <- GHC.getContext - res1 <- isInScopeAndUnqualifiedGhc "c" Nothing - res2 <- isInScopeAndUnqualifiedGhc "DupDef.Dd1.c" Nothing - res3 <- isInScopeAndUnqualifiedGhc "nonexistent" Nothing - return (res1,res2,res3,ctx) - ((r1,r2,r3,_c),_s) <- ct $ runRefactGhc comp (initialState { rsModule = Nothing }) testOptions - r1 `shouldBe` True - r2 `shouldBe` True - r3 `shouldBe` False - - -- --------------------------------- - - it "requires qualification on name clash with an import" $ do - t <- ct $ parsedFileGhc "./ScopeAndQual.hs" - let - comp = do - parseSourceFileGhc "./ScopeAndQual.hs" - -- putParsedModule t - renamed <- getRefactRenamed - - logm $ "renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++ - - ctx <- GHC.getContext - - let Just sumSquares = locToName (13,15) renamed - ssUnqual <- isQualifiedPN $ GHC.unLoc sumSquares - names <- GHC.parseName "sum" - names2 <- GHC.parseName "mySumSq" - res1 <- isInScopeAndUnqualifiedGhc "sum" Nothing - res2 <- isInScopeAndUnqualifiedGhc "L.sum" Nothing - return (res1,res2,names,names2,sumSquares,ssUnqual,ctx) - ((r1,r2,ns,ns2,ss,ssu,_c),_s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (prettyprint ss) `shouldBe` "sumSquares" - (showGhcQual ss) `shouldBe` "ScopeAndQual.sumSquares" - (show $ ssu) `shouldBe` "False" - (showGhcQual ns) `shouldBe` "[ScopeAndQual.sum]" - (showGhcQual ns2) `shouldBe` "[ScopeAndQual.mySumSq]" - "1" ++ (show r1) `shouldBe` "1True" - "2" ++ (show r2) `shouldBe` "2True" - - -- --------------------------------------------- - - describe "mkNewGhcName" $ do - it "Creates a new GHC.Name" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let - comp = do - renamed <- getRefactRenamed - let Just (GHC.L _ topLevel) = locToName (3,1) renamed - - name1 <- mkNewGhcName Nothing "foo" - name2 <- mkNewGhcName Nothing "bar" - name3 <- mkNewGhcName (Just (GHC.nameModule topLevel)) "baz" - - return (name1,name2,name3) - ((n1,n2,n3),_s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - GHC.getOccString n1 `shouldBe` "foo" - showGhcQual n1 `shouldBe` "foo" - GHC.getOccString n2 `shouldBe` "bar" - showGhcQual n2 `shouldBe` "bar" - (showGhcQual $ GHC.nameModule n3) `shouldBe` "main@main:DupDef.Dd1" - (SYB.showData SYB.Renamer 0 n3) `shouldBe` "{Name: baz}" - GHC.getOccString n3 `shouldBe` "baz" - showGhcQual n3 `shouldBe` "DupDef.Dd1.baz" - (showGhcQual $ GHC.nameUnique n1) `shouldBe` "H2" - (showGhcQual $ GHC.nameUnique n2) `shouldBe` "H3" - (showGhcQual $ GHC.nameUnique n3) `shouldBe` "H4" - - -- --------------------------------------------- - - describe "prettyprint" $ do - it "Prints a GHC.Name ready for parsing into tokens" $ do - -- (_t, _toks, _tgt) <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let - comp = do - name1 <- mkNewGhcName Nothing "foo" - name2 <- mkNewGhcName Nothing "bar" - return (name1,name2) - ((n1,n2),_s) <- ct $ runRefactGhcState comp - GHC.getOccString n1 `shouldBe` "foo" - showGhcQual n1 `shouldBe` "foo" - GHC.getOccString n2 `shouldBe` "bar" - showGhcQual n2 `shouldBe` "bar" - showGhcQual n1 `shouldBe` "foo" - - -- --------------------------------------------- - - describe "duplicateDecl" $ do - it "duplicates a bind only" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just (GHC.L _ n) = locToName (3, 1) renamed - let - comp = do - parsed <- getRefactParsed - declsp <- liftT $ hsDecls parsed - newName2 <- mkNewGhcName Nothing "bar2" - newBindings <- duplicateDecl declsp n newName2 - parsed' <- liftT $ replaceDecls parsed newBindings - putRefactParsed parsed' emptyAnns - - return newBindings - (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - (showGhcQual n) `shouldBe` "DupDef.Dd1.toplevel" - (sourceFromState s) `shouldBe` "module DupDef.Dd1 where\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nbar2 :: Integer -> Integer\nbar2 x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nff y = y + zz\n where\n zz = 1\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\n" - - -- --------------------------------------------- - - it "duplicates a bind with a signature, and an offset" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just np = locToName (14, 1) renamed - (showGhcQual np) `shouldBe` "DupDef.Dd1.tup" - - let Just ln@(GHC.L _l n) = locToName (17, 6) renamed - (showGhcQual n) `shouldBe` "ff" - let - comp = do - newName2 <- mkNewGhcName Nothing "gg" - nm <- getRefactNameMap - - parsed <- getRefactParsed - decls <- liftT $ hsDecls parsed - - (front,[parent],back) <- divideDecls decls ln - - (parent',Just (funBinding,declsToDup,declsp')) <- modifyValD (GHC.getLoc parent) parent $ \_m declsp -> do - let - declsToDup = definingDeclsRdrNames nm [n] declsp True True - funBinding = filter isFunOrPatBindP declsToDup --get the fun binding. - - declsp' <- duplicateDecl declsp n newName2 - - return (declsp',Just (funBinding,declsToDup,declsp')) - - parsed' <- liftT $ replaceDecls parsed (front ++ [parent'] ++ back) - putRefactParsed parsed' emptyAnns - - return (funBinding,declsToDup,declsp') - - ((fb,dd,newb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- ((fb,dd,newb),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual n) `shouldBe` "ff" - (showGhcQual dd) `shouldBe` "[ff = 15]" - (showGhcQual fb) `shouldBe` "[ff = 15]" - (show $ getStartEndLoc fb) `shouldBe` "((17,5),(17,12))" - (sourceFromState s) `shouldBe` "module DupDef.Dd1 where\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\n gg :: Int\n gg = 15\n\ndata D = A | B String | C\n\nff y = y + zz\n where\n zz = 1\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\n" - (showGhcQual newb) `shouldBe` "[ff :: Int, ff = 15, gg :: Int, gg = 15]" - (showGhcQual fb) `shouldBe` "[ff = 15]" - - - -- --------------------------------------------- - - describe "addParamsToDecl" $ do - it "adds parameters to a declaration" $ do - t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let Just (GHC.L _ n) = locToName (3, 1) renamed - let - comp = do - declsp <- liftT $ hsDecls parsed - let newName2 = mkRdrName "bar2" - declsp' <- addParamsToDecls declsp n [newName2] - parsed' <- liftT $ replaceDecls parsed declsp' - putRefactParsed parsed' emptyAnns - - return declsp' - (nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual n) `shouldBe` "MoveDef.Md1.toplevel" - (sourceFromState s) `shouldBe` "module MoveDef.Md1 where\n\ntoplevel :: Integer -> Integer\ntoplevel bar2 x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nff :: Int -> Int\nff y = y + zz\n where\n zz = 1\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\nzz1 a = 1 + toplevel a\n\n-- General Comment\n-- |haddock comment\ntlFunc :: Integer -> Integer\ntlFunc x = c * x\n-- Comment at end\n\n\n" - (showGhcQual $ head $ tail nb) `shouldBe` "toplevel bar2 x = c * x" - - -- --------------------------------- - - it "adds parameters to a declaration with multiple matches" $ do - t <- ct $ parsedFileGhc "./AddParams1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let Just (GHC.L _ n) = locToName (3, 1) renamed - let - comp = do - declsp <- liftT $ hsDecls parsed - let newName = mkRdrName "pow" - declsp' <- addParamsToDecls declsp n [newName] - parsed' <- liftT $ replaceDecls parsed declsp' - putRefactParsed parsed' emptyAnns - return declsp' - (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual n) `shouldBe` "AddParams1.sq" - (sourceFromState s) `shouldBe` "module AddParams1 where\n\nsq pow 0 = 0\nsq pow z = z^2\n\nfoo = 3\n\n" - - -- --------------------------------- - - it "adds parameters to a declaration with no existing ones" $ do - t <- ct $ parsedFileGhc "./AddParams1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let Just (GHC.L _ n) = locToName (6, 1) renamed - let - comp = do - declsp <- liftT $ hsDecls parsed - let newName1 = mkRdrName "baz" - let newName2 = mkRdrName "bar" - declsp' <- addParamsToDecls declsp n [newName1,newName2] - parsed' <- liftT $ replaceDecls parsed declsp' - putRefactParsed parsed' emptyAnns - - return declsp' - (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual n) `shouldBe` "AddParams1.foo" - (sourceFromState s) `shouldBe` "module AddParams1 where\n\nsq 0 = 0\nsq z = z^2\n\nfoo baz bar = 3\n\n" - - -- --------------------------------------------- - - describe "addActualParamsToRhs" $ do - it "adds a parameter to the rhs of a declaration" $ do - t <- ct $ parsedFileGhc "./LiftToToplevel/D1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just (GHC.L _ n) = locToName (6, 21) renamed - let - comp = do - parsed <- getRefactParsed - declsp <- liftT $ hsDecls parsed - let decl = head declsp - let newName2 = mkRdrName "bar2" - newBinding <- addActualParamsToRhs n [newName2] decl - - return (newBinding,decl) - ((nb,decl'),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- ((nb,decl'),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - (showGhcQual decl') `shouldBe` "sumSquares (x : xs)\n = sq x + sumSquares xs\n where\n sq x = x ^ pow\n pow = 2\nsumSquares [] = 0" - (showGhcQual n) `shouldBe` "sq" - (showGhcQual nb) `shouldBe` "sumSquares (x : xs)\n = (sq bar2) x + sumSquares xs\n where\n sq x = x ^ pow\n pow = 2\nsumSquares [] = 0" - (exactPrintFromState s nb) `shouldBe` "\n\n{-lift 'sq' to top level. This refactoring\n affects module 'D1' and 'C1' -}\n\nsumSquares (x:xs) = (sq bar2) x + sumSquares xs\n where\n sq x = x ^ pow\n pow =2\n\nsumSquares [] = 0" - - -- -------------------- - - it "adds parameters to a complex rhs of a declaration" $ do - t <- ct $ parsedFileGhc "./LiftToToplevel/WhereIn7.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just (GHC.L _ n) = locToName (10, 17) renamed - let - comp = do - parsed <- getRefactParsed - declsp <- liftT $ hsDecls parsed - let decl = head declsp - - let newName1 = mkRdrName "x1" - let newName2 = mkRdrName "y1" - let newName3 = mkRdrName "z1" - newBinding <- addActualParamsToRhs n [newName1,newName2,newName3] decl - - return (newBinding,decl) - ((nb,decl'),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - (showGhcQual decl') `shouldBe` "fun x y z\n = inc addthree\n where\n inc a = a + 1\n addthree = x + y + z" - (showGhcQual n) `shouldBe` "addthree" - (showGhcQual nb) `shouldBe` "fun x y z\n = inc (addthree x1 y1 z1)\n where\n inc a = a + 1\n addthree = x + y + z" - (exactPrintFromState s nb) `shouldBe` "\n\n--A definition can be lifted from a where or let to the top level binding group.\n--Lifting a definition widens the scope of the definition.\n\n--In this example, lift 'addthree' defined in 'fun'.\n--This example aims to test adding parenthese.\n\n\nfun x y z =inc (addthree x1 y1 z1)\n where inc a =a +1\n addthree=x+y+z" - - - -- --------------------------------------------- - - describe "rmDecl" $ do - it "removes a top level declaration, leaving type signature 1" $ do - t <- ct $ parsedFileGhc "./MoveDef/Md1a.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let Just (GHC.L _ n) = locToName (6, 1) renamed - let - comp = do - (parsed',_removedDecl,_removedSig) <- rmDecl n False parsed - putRefactParsed parsed' emptyAnns - - return parsed' - -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual n) `shouldBe` "MoveDef.Md1a.ff" - (sourceFromState s) `shouldBe` "module MoveDef.Md1a where\n\ndata D = A | B String | C\n\nff :: Int -> Int\n\nl = 1\n\n" - - -- --------------------------------- - - it "removes a top level declaration, leaving type signature 2b" $ do - t <- ct $ parsedFileGhc "./MoveDef/Md1b.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let Just (GHC.L _ n) = locToName (6, 1) renamed - let - comp = do - (parsed',_removedDecl,_removedSig) <- rmDecl n False parsed - putRefactParsed parsed' emptyAnns - return parsed' - -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual n) `shouldBe` "MoveDef.Md1b.ff" - (sourceFromState s) `shouldBe` "module MoveDef.Md1b where\n\ndata D = A | C\n\nff :: Int -> Int\n\nl z =\n let\n ll = 34\n in ll + z\n\n" - - -- --------------------------------- - - it "removes a top level declaration, leaving type signature 2" $ do - t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let Just (GHC.L _ n) = locToName (22, 1) renamed - let - comp = do - (parsed',_removedDecl,_removedSig) <- rmDecl n False parsed - putRefactParsed parsed' emptyAnns - logDataWithAnns "parsed'" parsed' - return parsed' - -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual n) `shouldBe` "MoveDef.Md1.ff" - (sourceFromState s) `shouldBe` "module MoveDef.Md1 where\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nff :: Int -> Int\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\nzz1 a = 1 + toplevel a\n\n-- General Comment\n-- |haddock comment\ntlFunc :: Integer -> Integer\ntlFunc x = c * x\n-- Comment at end\n\n\n" - - -- --------------------------------- - - it "removes a top level declaration, and type signature" $ do - t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let Just (GHC.L _ n) = locToName (22, 1) renamed - let - comp = do - (newDecls,_removedDecl,_removedSig) <- rmDecl n True parsed - putRefactParsed newDecls emptyAnns - return newDecls - -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual n) `shouldBe` "MoveDef.Md1.ff" - (sourceFromState s) `shouldBe` "module MoveDef.Md1 where\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\nzz1 a = 1 + toplevel a\n\n-- General Comment\n-- |haddock comment\ntlFunc :: Integer -> Integer\ntlFunc x = c * x\n-- Comment at end\n\n\n" - - -- ----------------------------------- - - it "removes the last local decl in a let/in clause" $ do - t <- ct $ parsedFileGhc "./LiftToToplevel/LetIn1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just (GHC.L _ n) = locToName (11, 22) renamed - let - comp = do - parsed <- getRefactParsed - (parsed',_removedDecl,_removedSig) <- rmDecl n True parsed - - putRefactParsed parsed' emptyAnns - - return parsed' - (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual n) `shouldBe` "sq" - -- (showToks $ take 20 $ toksFromState s) `shouldBe` "" - (sourceFromState s) `shouldBe` "module LiftToToplevel.LetIn1 where\n\n--A definition can be lifted from a where or let to the top level binding group.\n--Lifting a definition widens the scope of the definition.\n\n--In this example, lift 'sq' in 'sumSquares'\n--This example aims to test lifting a definition from a let clause to top level,\n--and the elimination of the keywords 'let' and 'in'\n\nsumSquares x y = sq x + sq y\n where pow=2\n\nanotherFun 0 y = sq y\n where sq x = x^2\n" - - -- ----------------------------------- - - it "removes the last local decl in a where clause" $ do - t <- ct $ parsedFileGhc "./RmDecl3.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let Just (GHC.L _ n) = locToName (6, 5) renamed - let - comp = do - (parsed',_removedDecl,_removedSig) <- rmDecl n True parsed - - putRefactParsed parsed' emptyAnns - - return parsed' - (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual n) `shouldBe` "zz" - (sourceFromState s) `shouldBe` "module RmDecl3 where\n\n-- Remove last declaration from a where clause, where should disappear too\nff y = y + zz\n\n-- EOF\n" - - -- ----------------------------------- - - it "removes the first local decl in a where clause" $ do - t <- ct $ parsedFileGhc "./RmDecl4.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - -- (SYB.showData SYB.Renamer 0 renamed) `shouldBe` "" - - let Just (GHC.L _ n) = locToName (7, 5) renamed - let - comp = do - (parsed',_removedDecl,_removedSig) <- rmDecl n True parsed - - putRefactParsed parsed' emptyAnns - - return parsed' - (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual n) `shouldBe` "zz" - (sourceFromState s) `shouldBe` "{-# LANGUAGE FlexibleContexts #-}\nmodule RmDecl4 where\n\n-- Remove first declaration from a where clause, rest should still be indented\nff y = y + zz ++ xx\n where\n xx = 2\n\n-- EOF\n" - - -- ----------------------------------- - - it "removes the non last local decl in a let/in clause 1" $ do - t <- ct $ parsedFileGhc "./Demote/LetIn1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - -- (SYB.showData SYB.Renamer 0 renamed) `shouldBe` "" - - let Just (GHC.L _ n) = locToName (12, 22) renamed - let - comp = do - (parsed',_removedDecl,_removedSig) <- rmDecl n False parsed - putRefactParsed parsed' emptyAnns - - return parsed' - (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual n) `shouldBe` "pow" - (sourceFromState s) `shouldBe` "module Demote.LetIn1 where\n\n--A definition can be demoted to the local 'where' binding of a friend declaration,\n--if it is only used by this friend declaration.\n\n--Demoting a definition narrows down the scope of the definition.\n--In this example, demote the local 'pow' to 'sq'\n--This example also aims to test the demoting a local declaration in 'let'.\n\nsumSquares x y = let sq 0=0\n sq z=z^pow\n in sq x + sq y\n\n\nanotherFun 0 y = sq y\n where sq x = x^2\n\n " - - -- ----------------------------------- - - it "removes the non last local decl in a let/in clause 2" $ do - t <- ct $ parsedFileGhc "./Demote/LetIn2.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let Just (GHC.L _ n) = locToName (10, 22) renamed - let - comp = do - (parsed',_removedDecl,_removedSig) <- rmDecl n False parsed - putRefactParsed parsed' emptyAnns - - return parsed' - (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual n) `shouldBe` "sq" - (sourceFromState s) `shouldBe` "module Demote.LetIn2 where\n\n--A definition can be demoted to the local 'where' binding of a friend declaration,\n--if it is only used by this friend declaration.\n\n--Demoting a definition narrows down the scope of the definition.\n--In this example, demote the local 'pow' will fail.\n\nsumSquares x y = let pow=2\n in sq x + sq y +pow\n\n\nanotherFun 0 y = sq y\n where sq x = x^2\n\n " - - -- ----------------------------------------------------------------- - - it "removes a decl with a trailing comment" $ do - t <- ct $ parsedFileGhc "./Demote/WhereIn3.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let Just (GHC.L _ n) = locToName (14, 1) renamed - let - comp = do - (parsed',_removedDecl,_removedSig1) <- rmDecl n False parsed - putRefactParsed parsed' emptyAnns - - return parsed' - (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - (showGhcQual n) `shouldBe` "Demote.WhereIn3.sq" - (sourceFromState s) `shouldBe` "module Demote.WhereIn3 where\n\n--A definition can be demoted to the local 'where' binding of a friend declaration,\n--if it is only used by this friend declaration.\n\n--Demoting a definition narrows down the scope of the definition.\n--In this example, demote the top level 'sq' to 'sumSquares'\n--In this case (there are multi matches), the parameters are not folded after demoting.\n\nsumSquares x y = sq p x + sq p y\n where p=2 {-There is a comment-}\n\nsq :: Int -> Int -> Int\n\n{- foo bar -}\nanotherFun 0 y = sq y\n where sq x = x^2\n" - - - -- ----------------------------------------------------------------- - - it "removes a sub decl liftOneLevel D1" $ do - t <- ct $ parsedFileGhc "./LiftOneLevel/D1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let Just (GHC.L _ n) = locToName (8, 6) renamed - let - comp = do - (parsed',_removedDecl,_removedSig1) <- rmDecl n False parsed - putRefactParsed parsed' emptyAnns - - return parsed' - (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - (showGhcQual n) `shouldBe` "sq" - (sourceFromState s) `shouldBe` "module LiftOneLevel.D1 where\n\n{-lift 'sq' to top level. This refactoring\naffects module 'D1' and 'C1' -}\n\nsumSquares (x:xs) = sq x + sumSquares xs\n where\n pow =2\n\nsumSquares [] = 0\n\nmain = sumSquares [1..4]\n" - - - -- --------------------------------------------- - - describe "rmTypeSig" $ do - it "removes a type signature from the top level 1" $ do - t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let Just (GHC.L _ n) = locToName (22, 1) renamed - let - comp = do - (renamed',sigRemoved) <- rmTypeSig n parsed - putRefactParsed renamed' emptyAnns - return (renamed',sigRemoved) - ((_nb,os),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- ((_nb,os),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual n) `shouldBe` "MoveDef.Md1.ff" - (sourceFromState s) `shouldBe` "module MoveDef.Md1 where\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nff y = y + zz\n where\n zz = 1\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\nzz1 a = 1 + toplevel a\n\n-- General Comment\n-- |haddock comment\ntlFunc :: Integer -> Integer\ntlFunc x = c * x\n-- Comment at end\n\n\n" - (showGhcQual os) `shouldBe` "Just ff :: Int -> Int" - - -- ----------------------------------------------------------------- - - it "removes a type signature from the top level, after decl removed" $ do - t <- ct $ parsedFileGhc "./Demote/WhereIn3.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let Just (GHC.L _ n) = locToName (14, 1) renamed - let - comp = do - (parsed',_removedDecl,_removedSig1) <- rmDecl n False parsed - (parsed2,_removedSig2) <- rmTypeSig n parsed' - putRefactParsed parsed2 emptyAnns - - return parsed2 - (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - (showGhcQual n) `shouldBe` "Demote.WhereIn3.sq" - (sourceFromState s) `shouldBe` "module Demote.WhereIn3 where\n\n--A definition can be demoted to the local 'where' binding of a friend declaration,\n--if it is only used by this friend declaration.\n\n--Demoting a definition narrows down the scope of the definition.\n--In this example, demote the top level 'sq' to 'sumSquares'\n--In this case (there are multi matches), the parameters are not folded after demoting.\n\nsumSquares x y = sq p x + sq p y\n where p=2 {-There is a comment-}\n\n{- foo bar -}\nanotherFun 0 y = sq y\n where sq x = x^2\n" - - - -- ----------------------------------------------------------------- - - it "removes a type signature from non-top level" $ do - t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let Just (GHC.L _ n) = locToName (16, 5) renamed - let - comp = do - (renamed',_removedSig) <- rmTypeSig n parsed - putRefactParsed renamed' emptyAnns - return renamed' - -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual n) `shouldBe` "ff" - -- (showToks $ take 20 $ toksFromState s) `shouldBe` "" - (sourceFromState s) `shouldBe` "module MoveDef.Md1 where\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff = 15\n\ndata D = A | B String | C\n\nff :: Int -> Int\nff y = y + zz\n where\n zz = 1\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\nzz1 a = 1 + toplevel a\n\n-- General Comment\n-- |haddock comment\ntlFunc :: Integer -> Integer\ntlFunc x = c * x\n-- Comment at end\n\n\n" - - -- ----------------------------------------------------------------- - - it "removes a type signature within multi signatures 1" $ do - t <- ct $ parsedFileGhc "./TypeUtils/TypeSigs.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let Just (GHC.L _ b) = locToName (12, 1) renamed - let - comp = do - (renamed',removedSig) <- rmTypeSig b parsed - putRefactParsed renamed' emptyAnns - return (renamed',removedSig) - ((_nb,os),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - (exactPrintFromState s (fromJust os)) `shouldBe` "\n\nb::Int->Integer->Char" - (showGhcQual b) `shouldBe` "TypeSigs.b" - (sourceFromState s) `shouldBe` "module TypeSigs where\n\nsq,anotherFun :: Int -> Int\nsq 0 = 0\nsq z = z^2\n\nanotherFun x = x^2\n\na,c::Int->Integer->Char\n\na x y = undefined\nb x y = undefined\nc x y = undefined\n\n" - - -- ----------------------------------------------------------------- - - it "removes a type signature within multi signatures 2" $ do - t <- ct $ parsedFileGhc "./TypeUtils/TypeSigs.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let Just (GHC.L _ n) = locToName (4, 1) renamed - let - comp = do - (renamed',removedSig) <- rmTypeSig n parsed - putRefactParsed renamed' emptyAnns - return (renamed',removedSig) - -- ((_nb,os),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - ((_nb,os),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- putStrLn $ "anntree\n" ++ showAnnDataFromState s - (exactPrintFromState s (fromJust os)) `shouldBe` "\n\nsq :: Int -> Int" - (showGhcQual n) `shouldBe` "TypeSigs.sq" - (sourceFromState s) `shouldBe` "module TypeSigs where\n\nanotherFun :: Int -> Int\nsq 0 = 0\nsq z = z^2\n\nanotherFun x = x^2\n\na,b,c::Int->Integer->Char\n\na x y = undefined\nb x y = undefined\nc x y = undefined\n\n" - (showGhcQual os) `shouldBe` "Just sq :: Int -> Int" - - -- ----------------------------------------------------------------- - - it "removes a type signature within multi signatures 3" $ do - t <- ct $ parsedFileGhc "./Demote/WhereIn7.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let Just (GHC.L _ n) = locToName (12, 1) renamed - let - comp = do - (parsed',removedSig) <- rmTypeSig n parsed - putRefactParsed parsed' emptyAnns - return (parsed',removedSig) - -- ((_nb,os),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - ((_nb,os),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - (showGhcQual n) `shouldBe` "WhereIn7.sq" - (exactPrintFromState s (fromJust os)) `shouldBe` "\n\nsq :: Int -> Int" - (sourceFromState s) `shouldBe` "module WhereIn7 where\n\n--A definition can be demoted to the local 'where' binding of a friend declaration,\n--if it is only used by this friend declaration.\n\n--Demoting a definition narrows down the scope of the definition.\n--In this example, demote the top level 'sq' to 'sumSquares'\n--This example also aims to test the split of type signature.\n\nsumSquares x y = sq x + sq y\n\nanotherFun :: Int -> Int\nsq 0 = 0\nsq z = z^pow\n where pow=2\n\nanotherFun x = x^2\n " - (showGhcQual os) `shouldBe` "Just sq :: Int -> Int" - - -- ----------------------------------------------------------------- -{- - it "removes a type signature for a pattern in a bind" $ do - t <- ct $ parsedFileGhc "./LiftToToplevel/PatBindIn1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let Just (GHC.L _ n) = locToName (GHC.mkFastString "./test/testdata/LiftToToplevel/PatBindIn1.hs") (18, 7) renamed - let - comp = do - (renamed',removedSig) <- rmTypeSig n renamed - let (Just (GHC.L ss _)) = removedSig - oldSigToks <- getToksForSpan ss - return (renamed',removedSig,oldSigToks) - -- ((nb,os,ot),s) <- runRefactGhc comp $ initialState { rsModule = initRefactModule [] t } - ((nb,os,ot),s) <- runRefactGhc comp $ initialLogOnState { rsModule = initRefactModule [] t } - (showGhcQual n) `shouldBe` "tup" - -- (showToks $ take 20 $ toksFromState s) `shouldBe` "" - (sourceFromState s) `shouldBe` "module LiftToToplevel.PatBindIn1 where\n\n --A definition can be lifted from a where or let into the surrounding binding group.\n --Lifting a definition widens the scope of the definition.\n\n --In this example, lift 'tup' defined in 'foo'\n --This example aims to test renaming and the lifting of type signatures.\n\n main :: Int\n main = foo 3\n\n foo :: Int -> Int\n foo x = h + t + (snd tup)\n where\n \n \n\n tup@(h,t) = head $ zip [1..10] [3..15]\n " - (showGhcQual nb) `shouldBe` "" - (showGhcQual os) `shouldBe` "" - (GHC.showRichTokenStream ot) `shouldBe` "" --} - -- --------------------------------------------- - - describe "addDecl" $ do - it "adds a top level declaration without a type signature, in default pos" $ do - t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" - let - comp = do - parsed <- getRefactParsed - (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "a" "nn = n2") - -- let declAnns' = setPrecedingLines declAnns newDecl 2 - parsed' <- addDecl parsed Nothing ([decl],Just declAnns) - putRefactParsed parsed' emptyAnns - return parsed' - (nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- (nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - - (sourceFromState s) `shouldBe` "module MoveDef.Md1 where\n\nnn = n2\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nff :: Int -> Int\nff y = y + zz\n where\n zz = 1\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\nzz1 a = 1 + toplevel a\n\n-- General Comment\n-- |haddock comment\ntlFunc :: Integer -> Integer\ntlFunc x = c * x\n-- Comment at end\n\n\n" - (unspace $ showGhcQual nb) `shouldBe` unspace "module MoveDef.Md1 where\nnn = n2\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\nc, d :: Integer\nc = 7\nd = 9\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h, t)\n = head $ zip [1 .. 10] [3 .. ff]\n where\n ff :: Int\n ff = 15\ndata D = A | B String | C\nff :: Int -> Int\nff y\n = y + zz\n where\n zz = 1\nl z = let ll = 34 in ll + z\ndd q\n = do { let ss = 5;\n return (ss + q) }\nzz1 a = 1 + toplevel a\ntlFunc :: Integer -> Integer\ntlFunc x = c * x" - - -- ------------------------------------------- - - it "adds a top level declaration with a type signature 1" $ do - t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" - let - comp = do - parsed <- getRefactParsed - (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "decl" "nn = 2") - (sig, sigAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "sig" "nn :: Int") - parsed' <- addDecl parsed Nothing ([sig,decl],Just $ mergeAnns sigAnns declAnns) - putRefactParsed parsed' emptyAnns - return (sig,parsed') - ((_hs,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - (sourceFromState s) `shouldBe` "module MoveDef.Md1 where\n\nnn :: Int\nnn = 2\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nff :: Int -> Int\nff y = y + zz\n where\n zz = 1\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\nzz1 a = 1 + toplevel a\n\n-- General Comment\n-- |haddock comment\ntlFunc :: Integer -> Integer\ntlFunc x = c * x\n-- Comment at end\n\n\n" - (unspace $ showGhcQual nb) `shouldBe` unspace "module MoveDef.Md1 where\nnn :: Int\nnn = 2\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\nc, d :: Integer\nc = 7\nd = 9\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h, t)\n = head $ zip [1 .. 10] [3 .. ff]\n where\n ff :: Int\n ff = 15\ndata D = A | B String | C\nff :: Int -> Int\nff y\n = y + zz\n where\n zz = 1\nl z = let ll = 34 in ll + z\ndd q\n = do { let ss = 5;\n return (ss + q) }\nzz1 a = 1 + toplevel a\ntlFunc :: Integer -> Integer\ntlFunc x = c * x" - - -- ------------------------------------------- - - it "adds a top level declaration after a specified one" $ do - t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" - let - comp = do - parsed <- getRefactParsed - (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "a" "nn = nn2") - renamed <- getRefactRenamed - let Just (GHC.L _l n) = locToName (21, 1) renamed - parsed' <- addDecl parsed (Just n) ([decl],Just declAnns) - putRefactParsed parsed' emptyAnns - return (n,parsed') - ((n,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- ((n,nb),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - (showGhcQual n) `shouldBe` "MoveDef.Md1.ff" - (sourceFromState s) `shouldBe` "module MoveDef.Md1 where\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nff :: Int -> Int\nff y = y + zz\n where\n zz = 1\n\nnn = nn2\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\nzz1 a = 1 + toplevel a\n\n-- General Comment\n-- |haddock comment\ntlFunc :: Integer -> Integer\ntlFunc x = c * x\n-- Comment at end\n\n\n" - (unspace $ showGhcQual nb) `shouldBe` unspace "module MoveDef.Md1 where\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\nc, d :: Integer\nc = 7\nd = 9\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h, t)\n = head $ zip [1 .. 10] [3 .. ff]\n where\n ff :: Int\n ff = 15\ndata D = A | B String | C\nff :: Int -> Int\nff y\n = y + zz\n where\n zz = 1\nnn = nn2\nl z = let ll = 34 in ll + z\ndd q\n = do { let ss = 5;\n return (ss + q) }\nzz1 a = 1 + toplevel a\ntlFunc :: Integer -> Integer\ntlFunc x = c * x" - - - -- ------------------------------------------- - - it "adds a top level declaration with a type signature after a specified one" $ do - t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" - let - comp = do - renamed <- getRefactRenamed - let Just (GHC.L _l n) = locToName (21, 1) renamed - parsed <- getRefactParsed - (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "decl" "nn = nn2") - (sig, sigAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "sig" "nn :: Int") - parsed' <- addDecl parsed (Just n) ([sig,decl],Just $ mergeAnns sigAnns declAnns) - putRefactParsed parsed' emptyAnns - return (n,parsed') - ((nn,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - (showGhcQual nn) `shouldBe` "MoveDef.Md1.ff" - (sourceFromState s) `shouldBe`"module MoveDef.Md1 where\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nff :: Int -> Int\nff y = y + zz\n where\n zz = 1\n\nnn :: Int\nnn = nn2\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\nzz1 a = 1 + toplevel a\n\n-- General Comment\n-- |haddock comment\ntlFunc :: Integer -> Integer\ntlFunc x = c * x\n-- Comment at end\n\n\n" - (unspace $ showGhcQual nb) `shouldBe` unspace "module MoveDef.Md1 where\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\nc, d :: Integer\nc = 7\nd = 9\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h, t)\n = head $ zip [1 .. 10] [3 .. ff]\n where\n ff :: Int\n ff = 15\ndata D = A | B String | C\nff :: Int -> Int\nff y\n = y + zz\n where\n zz = 1\nnn :: Int\nnn = nn2\nl z = let ll = 34 in ll + z\ndd q\n = do { let ss = 5;\n return (ss + q) }\nzz1 a = 1 + toplevel a\ntlFunc :: Integer -> Integer\ntlFunc x = c * x" - - - -- ------------------------------------------- - - it "adds a local declaration without a type signature 1" $ do - t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" - - let - comp = do - parsed <- getRefactParsed - renamed <- getRefactRenamed - nameMap <- getRefactNameMap - - let Just (GHC.L _ tl) = locToName (4, 1) renamed - decls <- liftT (hsDecls parsed) - let - [tlDecl] = definingDeclsRdrNames nameMap [tl] decls True False - - (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "decl" "nn = nn2") - - newDecl <- addDecl tlDecl Nothing ([decl],Just declAnns) - - logm $ "test:addDecl done" - - return (tlDecl,newDecl) - -- ((tl,nb),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - ((tl,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - (showGhcQual tl) `shouldBe` "toplevel x = c * x" - (exactPrintFromState s nb) `shouldBe` "\ntoplevel x = c * x\n where\n nn = nn2" - (showGhcQual nb) `shouldBe` "toplevel x\n = c * x\n where\n nn = nn2" - - -- ------------------------------------------- - - it "adds a local declaration with a type signature 1" $ do - t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" - let - comp = do - parsed <- getRefactParsed - renamed <- getRefactRenamed - nameMap <- getRefactNameMap - - let Just (GHC.L _ tl) = locToName (4, 1) renamed - decls <- liftT (hsDecls parsed) - let - [tlDecl] = definingDeclsRdrNames nameMap [tl] decls True False - - (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "decl" "nn = nn2") - (sig, sigAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "sig" "nn :: Int") - - newDecl <- addDecl tlDecl Nothing ([sig,decl],Just $ mergeAnns sigAnns declAnns) - - return (tlDecl,newDecl) - ((tl,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- ((tl,nb),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - (showGhcQual tl) `shouldBe` "toplevel x = c * x" - -- putStrLn (showAnnDataItemFromState s nb) - (exactPrintFromState s nb) `shouldBe` "\ntoplevel x = c * x\n where\n nn :: Int\n nn = nn2" - (showGhcQual nb) `shouldBe` "toplevel x\n = c * x\n where\n nn = nn2\n nn :: Int" - -- ------------------------------------------- - - it "adds a local declaration with a where clause" $ do - t <- ct $ parsedFileGhc "./MoveDef/Demote.hs" - let - comp = do - - parsed <- getRefactParsed - renamed <- getRefactRenamed - nameMap <- getRefactNameMap - - let Just (GHC.L _ tl) = locToName (4, 1) renamed - decls <- liftT (hsDecls parsed) - let - [tlDecl] = definingDeclsRdrNames nameMap [tl] decls True False - - (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "decl" "nn = nn2") - - newDecl <- addDecl tlDecl Nothing ([decl],Just declAnns) - - return (tlDecl,newDecl) - ((tl,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - (showGhcQual tl) `shouldBe` "toplevel x = c * x" - (exactPrintFromState s nb) `shouldBe` "\ntoplevel x = c * x\n where\n nn = nn2" - (showGhcQual nb) `shouldBe` "toplevel x\n = c * x\n where\n nn = nn2" - - -- ------------------------------------------- - - it "adds a local declaration to an existing one" $ do - t <- ct $ parsedFileGhc "./MoveDef/Md2.hs" - let - comp = do - - parsed <- getRefactParsed - renamed <- getRefactRenamed - nameMap <- getRefactNameMap - - let Just (GHC.L _ tl) = locToName (4, 1) renamed - decls <- liftT (hsDecls parsed) - let - [tlDecl] = definingDeclsRdrNames nameMap [tl] decls True False - - (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "decl" "nn = nn2") - - newDecl <- addDecl tlDecl Nothing ([decl],Just declAnns) - - return (tlDecl,newDecl) - ((tl,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- ((tl,nb),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - (showGhcQual tl) `shouldBe` "toplevel x\n = c * x * b\n where\n b = 3" - (exactPrintFromState s nb) `shouldBe` "\ntoplevel x = c * x * b\n where\n nn = nn2\n\n b = 3" - (showGhcQual nb) `shouldBe` "toplevel x\n = c * x * b\n where\n b = 3\n nn = nn2" - - -- ------------------------------------------- - - it "adds a local declaration with a type signature to an existing one" $ do - t <- ct $ parsedFileGhc "./MoveDef/Md2.hs" - let - comp = do - - parsed <- getRefactParsed - renamed <- getRefactRenamed - nameMap <- getRefactNameMap - - let Just (GHC.L _ tl) = locToName (4, 1) renamed - decls <- liftT (hsDecls parsed) - let - [tlDecl] = definingDeclsRdrNames nameMap [tl] decls True False - - (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "decl" "nn = nn2") - (sig, sigAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "sig" "nn :: Int") - - newDecl <- addDecl tlDecl Nothing ([sig,decl],Just $ mergeAnns sigAnns declAnns) - - return (tlDecl,newDecl) - ((tl,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - (showGhcQual tl) `shouldBe` "toplevel x\n = c * x * b\n where\n b = 3" - (exactPrintFromState s nb) `shouldBe` "\ntoplevel x = c * x * b\n where\n nn :: Int\n nn = nn2\n\n b = 3" - (showGhcQual nb) `shouldBe` "toplevel x\n = c * x * b\n where\n b = 3\n nn = nn2\n nn :: Int" - - -- ------------------------------------------- - - it "adds a local decl with type signature to an existing one, with a comment" $ do - t <- ct $ parsedFileGhc "./Demote/WhereIn3.hs" - let - comp = do - parsed <- getRefactParsed - renamed <- getRefactRenamed - nameMap <- getRefactNameMap - - let Just (GHC.L _ tl) = locToName (10, 1) renamed - decls <- liftT (hsDecls parsed) - let [tlDecl] = definingDeclsRdrNames nameMap [tl] decls True False - - let Just (GHC.L _ sq) = locToName (14, 1) renamed - let Just (GHC.L _ af) = locToName (18, 1) renamed - - let [sqSig] = definingSigsRdrNames nameMap [sq] parsed - [sqDecl] = definingDeclsRdrNames nameMap [sq] decls False False - [afDecl] = definingDeclsRdrNames nameMap [af] decls False False - - let sqSigDecl = wrapSig sqSig - liftT (balanceComments tlDecl sqSigDecl) - liftT (balanceComments sqDecl afDecl) - - newDecl <- addDecl tlDecl Nothing ([sqSigDecl,sqDecl],Nothing) - - return (sqSig,sqDecl,tlDecl,afDecl,newDecl) - -- ((sigs,_sd,tl,aa,nb),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - ((sigs,_sd,tl,aa,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - (showGhcQual sigs) `shouldBe` "sq :: Int -> Int -> Int" - (showGhcQual tl) `shouldBe` "sumSquares x y\n = sq p x + sq p y\n where\n p = 2" - (showGhcQual aa) `shouldBe` "anotherFun 0 y\n = sq y\n where\n sq x = x ^ 2" - (exactPrintFromState s nb) `shouldBe` "\n\n--A definition can be demoted to the local 'where' binding of a friend declaration,\n--if it is only used by this friend declaration.\n\n--Demoting a definition narrows down the scope of the definition.\n--In this example, demote the top level 'sq' to 'sumSquares'\n--In this case (there are multi matches), the parameters are not folded after demoting.\n\nsumSquares x y = sq p x + sq p y\n where sq :: Int -> Int -> Int\n sq pow 0 = 0\n sq pow z = z^pow --there is a comment\n\n p=2 {-There is a comment-}" - (showGhcQual nb) `shouldBe` "sumSquares x y\n = sq p x + sq p y\n where\n p = 2\n sq :: Int -> Int -> Int\n sq pow 0 = 0\n sq pow z = z ^ pow" - - -- ------------------------------------------- - - it "does not add a local decl to a FunBind with multiple matches" $ do - t <- ct $ parsedFileGhc "./MoveDef/MultiFunBind1.hs" - let - comp = do - parsed <- getRefactParsed - renamed <- getRefactRenamed - nameMap <- getRefactNameMap - - let Just (GHC.L _ tl) = locToName (3, 1) renamed - decls <- liftT (hsDecls parsed) - let -- decls = hsBinds parsed - [tlDecl] = definingDeclsRdrNames nameMap [tl] decls True False - - let Just (GHC.L _ y) = locToName (6, 1) renamed - - let [yDecl] = definingDeclsRdrNames nameMap [y] decls False False - - newDecl <- addDecl tlDecl Nothing ([yDecl],Nothing) - - return (yDecl,tlDecl,newDecl) - r <- catchException $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - r `shouldBe` Just "addDecl:Cannot add a local decl to a FunBind with multiple matches" - - -- ------------------------------------------- - - it "adds a local declaration to a PatBind" $ do - t <- ct $ parsedFileGhc "./MoveDef/PatBind1.hs" - let - comp = do - - parsed <- getRefactParsed - renamed <- getRefactRenamed - nameMap <- getRefactNameMap - - let Just (GHC.L _ tl) = locToName (3, 1) renamed - decls <- liftT (hsDecls parsed) - let - [tlDecl] = definingDeclsRdrNames nameMap [tl] decls True False - - (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "decl" "nn = nn2") - - newDecl <- addDecl tlDecl Nothing ([decl],Just declAnns) - - return (tlDecl,newDecl) - ((tl,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- ((tl,nb),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - (showGhcQual tl) `shouldBe` "tup@(h, t) = (x, 1)" - (exactPrintFromState s nb) `shouldBe` "\n\ntup@(h,t) = (x,1)\n where\n nn = nn2" - (showGhcQual nb) `shouldBe` "tup@(h, t)\n = (x, 1)\n where\n nn = nn2" - - -- --------------------------------------------- - - describe "renamePN" $ do - it "replaces a Name with another, updating tokens 1" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let - comp = do - parsed <- getRefactParsed - renamed <- getRefactRenamed - let Just (GHC.L _l n') = locToName (3, 1) renamed - newName <- mkNewGhcName Nothing "bar2" - new <- renamePN n' newName False parsed - putRefactParsed new emptyAnns - return (new,newName,n') - let - - ((nb,nn,n),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - (showGhcQual (n,nn)) `shouldBe` "(DupDef.Dd1.toplevel, bar2)" - (sourceFromState s) `shouldBe` "module DupDef.Dd1 where\n\nbar2 :: Integer -> Integer\nbar2 x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nff y = y + zz\n where\n zz = 1\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\n" - (showGhcQual nb) `shouldBe` "module DupDef.Dd1 where\nbar2 :: Integer -> Integer\nbar2 x = c * x\nc, d :: Integer\nc = 7\nd = 9\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h, t)\n = head $ zip [1 .. 10] [3 .. ff]\n where\n ff :: Int\n ff = 15\ndata D = A | B String | C\nff y\n = y + zz\n where\n zz = 1\nl z = let ll = 34 in ll + z\ndd q\n = do { let ss = 5;\n return (ss + q) }" - - -- ----------------------------------------------------------------- - - it "replaces a Name with another, updating tokens 2" $ do - t <- ct $ parsedFileGhc "./Demote/WhereIn4.hs" - - let - comp = do - renamed <- getRefactRenamed - parsed <- getRefactParsed - declsr <- liftT $ hsDecls parsed - let decl = head $ drop 0 declsr - let Just (GHC.L _l n') = locToName (11, 21) renamed - newName <- mkNewGhcName Nothing "p_1" - new <- renamePN n' newName False decl - parsed' <- liftT $ replaceDecls parsed (new:tail declsr) - putRefactParsed parsed' emptyAnns - return (new,newName,decl,n') - let - ((nb,nn,d,n),s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - (showGhcQual d) `shouldBe` "sumSquares x y\n = sq p x + sq p y\n where\n p = 2" - (showGhcQual (n,nn)) `shouldBe` "(p, p_1)" - (sourceFromState s) `shouldBe` "module Demote.WhereIn4 where\n\n--A definition can be demoted to the local 'where' binding of a friend declaration,\n--if it is only used by this friend declaration.\n\n--Demoting a definition narrows down the scope of the definition.\n--In this example, demote the top level 'sq' to 'sumSquares'\n--In this case (there is single matches), if possible,\n--the parameters will be folded after demoting and type sigature will be removed.\n\nsumSquares x y = sq p_1 x + sq p_1 y\n where p_1=2 {-There is a comment-}\n\nsq::Int->Int->Int\nsq pow z = z^pow --there is a comment\n\nanotherFun 0 y = sq y\n where sq x = x^2\n\n" - (showGhcQual nb) `shouldBe` "sumSquares x y\n = sq p_1 x + sq p_1 y\n where\n p_1 = 2" - - - -- --------------------------------- - - it "replaces a Name with another in limited scope, updating tokens 1" $ do - t <- ct $ parsedFileGhc "./TokenTest.hs" - - let renamed = fromJust $ GHC.tm_renamed_source t - let Just (GHC.L _ n) = locToName (19, 1) renamed - (showGhcQual n) `shouldBe` "TokenTest.foo" - - let - comp = do - parsed <- getRefactParsed - decls <- liftT $ hsDecls parsed - newName <- mkNewGhcName Nothing "bar2" - new <- renamePN n newName False (head $ drop 3 decls) - parsed' <- liftT $ replaceDecls parsed (take 3 decls ++ [new] ++ drop 4 decls) - putRefactParsed parsed' emptyAnns - return (new,newName) - let - - ((nb,nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- ((nb,nn),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - (showGhcQual (n,nn)) `shouldBe` "(TokenTest.foo, bar2)" - (sourceFromState s) `shouldBe` "module TokenTest where\n\n-- Test new style token manager\n\nbob a b = x\n where x = 3\n\nbib a b = x\n where\n x = 3\n\n\nbab a b =\n let bar = 3\n in b + bar -- ^trailing comment\n\n\n-- leading comment\nbar2 x y =\n do c <- getChar\n return c\n\n\n\n\n" - (showGhcQual nb) `shouldBe` "bar2 x y\n = do { c <- getChar;\n return c }" - -- (showToks $ take 20 $ toksFromState s) `shouldBe` "" - - -- --------------------------------- - - it "replace a Name with another in limited scope, updating tokens 2" $ do - t <- ct $ parsedFileGhc "./TokenTest.hs" - - let renamed = fromJust $ GHC.tm_renamed_source t - let Just (GHC.L _ n) = locToName (19, 1) renamed - (showGhcQual n) `shouldBe` "TokenTest.foo" - - let - comp = do - parsed <- getRefactParsed - decls <- liftT $ hsDecls parsed - let decl = head $ drop 3 decls - newName <- mkNewGhcName Nothing "bar2" - new <- renamePN n newName False decl - - parsed' <- liftT $ replaceDecls parsed (take 3 decls ++ [new] ++ drop 4 decls) - putRefactParsed parsed' emptyAnns - - return (new,newName) - - ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual n) `shouldBe` "TokenTest.foo" - (sourceFromState s) `shouldBe` "module TokenTest where\n\n-- Test new style token manager\n\nbob a b = x\n where x = 3\n\nbib a b = x\n where\n x = 3\n\n\nbab a b =\n let bar = 3\n in b + bar -- ^trailing comment\n\n\n-- leading comment\nbar2 x y =\n do c <- getChar\n return c\n\n\n\n\n" - (showGhcQual nb) `shouldBe` "bar2 x y\n = do { c <- getChar;\n return c }" - -- (showToks $ take 20 $ toksFromState s) `shouldBe` "" - - ------------------------------------ - - it "replaces a name in a data declaration too" $ do - t <- ct $ parsedFileGhc "./Renaming/Field1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let Just (GHC.L _l n) = locToName (5, 19) renamed - let - comp = do - newName <- mkNewGhcName Nothing "pointx1" - new <- renamePN n newName False parsed - - putRefactParsed new emptyAnns - - return (new,newName) - let - - ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual n) `shouldBe` "Field1.pointx" - (sourceFromState s) `shouldBe` "module Field1 where\n\n--Rename field name 'pointx' to 'pointx1'\n\ndata Point = Pt {pointx1, pointy :: Float}\n\nabsPoint :: Point -> Float\nabsPoint p = sqrt (pointx1 p * pointx1 p +\n pointy p * pointy p)\n\n" - (unspace $ showGhcQual nb) `shouldBe` "module Field1 where\ndata Point = Pt {pointx1, pointy :: Float}\nabsPoint :: Point -> Float\nabsPoint p = sqrt (pointx1 p * pointx1 p + pointy p * pointy p)" - - - ------------------------------------ - - it "replaces a name in a type signature too" $ do - t <- ct $ parsedFileGhc "./Renaming/Field1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let Just (GHC.L _l n) = locToName (5, 6) renamed - let - comp = do - logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) - newName <- mkNewGhcName Nothing "NewPoint" - new <- renamePN n newName False parsed - - putRefactParsed new emptyAnns - - return (new,newName) - let - - ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- ((nb,nn),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - (showGhcQual n) `shouldBe` "Field1.Point" - (sourceFromState s) `shouldBe` "module Field1 where\n\n--Rename field name 'pointx' to 'pointx1'\n\ndata NewPoint = Pt {pointx, pointy :: Float}\n\nabsPoint :: NewPoint -> Float\nabsPoint p = sqrt (pointx p * pointx p +\n pointy p * pointy p)\n\n" - (unspace $ showGhcQual nb) `shouldBe` "module Field1 where\ndata NewPoint = Pt {pointx, pointy :: Float}\nabsPoint :: NewPoint -> Float\nabsPoint p = sqrt (pointx p * pointx p + pointy p * pointy p)" - - ------------------------------------ - - it "replace a name in a FunBind with multiple patterns" $ do - t <- ct $ parsedFileGhc "./LocToName.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let Just (GHC.L _l n) = locToName (20, 1) renamed - let - comp = do - newName <- mkNewGhcName Nothing "newPoint" - new <- renamePN n newName False parsed - - putRefactParsed new emptyAnns - - return (new,newName) - let - - ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - (showGhcQual n) `shouldBe` "LocToName.sumSquares" - (sourceFromState s) `shouldBe` "module LocToName where\n\n{-\n\n\n\n\n\n\n\n\n-}\n\n\n\n\n\n\n\nnewPoint (x:xs) = x ^2 + newPoint xs\n -- where sq x = x ^pow \n -- pow = 2\n\nnewPoint [] = 0\n" - (unspace $ showGhcQual nb) `shouldBe` "module LocToName where\nnewPoint (x : xs) = x ^ 2 + newPoint xs\nnewPoint [] = 0" - - ------------------------------------ - - it "replaces a qualified name in a FunBind with multiple patterns" $ do - t <- ct $ parsedFileGhc "./LocToName.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let modu = GHC.mkModule (GHC.stringToPackageKey "mypackage-1.0") (GHC.mkModuleName "LocToName") - - let Just (GHC.L _l n) = locToName (20, 1) renamed - let - comp = do - logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) - newName <- mkNewGhcName (Just modu) "newPoint" - new <- renamePN n newName True parsed - - putRefactParsed new emptyAnns - - return (new,newName) - - ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- ((nb,_nn),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - (showGhcQual n) `shouldBe` "LocToName.sumSquares" - (unspace $ showGhcQual nb) `shouldBe` "module LocToName where\nLocToName.newPoint (x : xs) = x ^ 2 + LocToName.newPoint xs\nLocToName.newPoint [] = 0" - (sourceFromState s) `shouldBe` "module LocToName where\n\n{-\n\n\n\n\n\n\n\n\n-}\n\n\n\n\n\n\n\nnewPoint (x:xs) = x ^2 + LocToName.newPoint xs\n -- where sq x = x ^pow \n -- pow = 2\n\nnewPoint [] = 0\n" - - - ------------------------------------ - - it "replaces a parameter name in a FunBind" $ do - t <- ct $ parsedFileGhc "./Renaming/LayoutIn2.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let Just (GHC.L _ n) = locToName (8, 7) renamed - let - comp = do - logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) - - newName <- mkNewGhcName Nothing "ls" - new <- renamePN n newName False parsed - - putRefactParsed new emptyAnns - - return (new,newName) - - ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- (showGhcQual $ sourceTreeFromState s) `shouldBe` "" - (sourceFromState s) `shouldBe` "module LayoutIn2 where\n\n--Layout rule applies after 'where','let','do' and 'of'\n\n--In this Example: rename 'list' to 'ls'.\n\nsilly :: [Int] -> Int\nsilly ls = case ls of (1:xs) -> 1\n--There is a comment\n (2:xs)\n | x < 10 -> 4 where x = last xs\n otherwise -> 12\n\n" - (unspace $ showGhcQual nb) `shouldBe` "module LayoutIn2 where\nsilly :: [Int] -> Int\nsilly ls\n = case ls of {\n (1 : xs) -> 1\n (2 : xs)\n | x < 10 -> 4\n where\n x = last xs\n otherwise -> 12 }" - - - ------------------------------------ - - it "does not qualify a name in an import hiding clause" $ do - t <- ct $ parsedFileGhc "./ScopeAndQual.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let modu = GHC.mkModule (GHC.stringToPackageKey "mypackage-1.0") (GHC.mkModuleName "LocToName") - - let Just (GHC.L _l n) = locToName (4, 24) renamed - let - comp = do - newName <- mkNewGhcName (Just modu) "mySum" - new <- renamePN n newName True parsed - - putRefactParsed new emptyAnns - - return (new,newName) - - ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- ((nb,_nn),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual n) `shouldBe` "Data.Foldable.sum" - (sourceFromState s) `shouldBe` "module ScopeAndQual where\n\nimport qualified Data.List as L\nimport Prelude hiding (mySum)\n\nmain :: IO ()\nmain = putStrLn (show $ L.mySum [1,2,3])\n\nsum a b = a + b\n\nsumSquares xs = L.mySum $ map (\\x -> x*x) xs\n\nmySumSq = sumSquares\n" - (unspace $ showGhcQual nb) `shouldBe` "module ScopeAndQual where\nimport qualified Data.List as L\nimport Prelude hiding ( mySum )\nmain :: IO ()\nmain = putStrLn (show $ L.mySum [1, 2, 3])\nsum a b = a + b\nsumSquares xs = L.mySum $ map (\\ x -> x * x) xs\nmySumSq = sumSquares" - - - ------------------------------------ - - it "does not qualify the subject of a type signature" $ do - t <- ct $ parsedFileGhc "./Renaming/C7.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let modu = GHC.mkModule (GHC.stringToPackageKey "mypackage-1.0") (GHC.mkModuleName "LocToName") - - let Just (GHC.L _l n) = locToName (5, 1) renamed - let - comp = do - logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) - newName <- mkNewGhcName (Just modu) "myNewFringe" - - new <- renamePN n newName True parsed - putRefactParsed new emptyAnns - - return (new,newName) - - ((nb,_nn),s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- ((nb,_nn),s) <- ct $ runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual n) `shouldBe` "Renaming.C7.myFringe" - (sourceFromState s) `shouldBe` "module Renaming.C7(LocToName.myNewFringe) where\n\nimport Renaming.D7\n\nmyNewFringe:: Tree a -> [a]\nmyNewFringe (Leaf x ) = [x]\nmyNewFringe (Branch left right) = LocToName.myNewFringe left ++ fringe right\n\n\n\n\n" - (unspace $ showGhcQual nb) `shouldBe` "module Renaming.C7 (\n LocToName.myNewFringe\n ) where\nimport Renaming.D7\nmyNewFringe :: Tree a -> [a]\nLocToName.myNewFringe (Leaf x) = [x]\nLocToName.myNewFringe (Branch left right)\n = LocToName.myNewFringe left ++ fringe right" - - ------------------------------------ - - it "realigns toks in a case for a shorter name" $ do - t <- ct $ parsedFileGhc "./Renaming/LayoutIn2.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let Just (GHC.L _l n) = locToName (8, 7) renamed - let - comp = do - logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) - - newName <- mkNewGhcName Nothing "ls" - new <- renamePN n newName False parsed - - putRefactParsed new emptyAnns - - return (new,newName) - - ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual n) `shouldBe` "list" - (sourceFromState s) `shouldBe` "module LayoutIn2 where\n\n--Layout rule applies after 'where','let','do' and 'of'\n\n--In this Example: rename 'list' to 'ls'.\n\nsilly :: [Int] -> Int\nsilly ls = case ls of (1:xs) -> 1\n--There is a comment\n (2:xs)\n | x < 10 -> 4 where x = last xs\n otherwise -> 12\n\n" - (unspace $ showGhcQual nb) `shouldBe` "module LayoutIn2 where\nsilly :: [Int] -> Int\nsilly ls\n = case ls of {\n (1 : xs) -> 1\n (2 : xs)\n | x < 10 -> 4\n where\n x = last xs\n otherwise -> 12 }" - - - - ------------------------------------ - - it "realigns toks in a case for a longer name" $ do - t <- ct $ parsedFileGhc "./Renaming/LayoutIn2.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let Just (GHC.L _l n) = locToName (8, 7) renamed - let - comp = do - logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) - - newName <- mkNewGhcName Nothing "listlonger" - new <- renamePN n newName False parsed - - putRefactParsed new emptyAnns - - return (new,newName) - - ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual n) `shouldBe` "list" - (sourceFromState s) `shouldBe` "module LayoutIn2 where\n\n--Layout rule applies after 'where','let','do' and 'of'\n\n--In this Example: rename 'list' to 'ls'.\n\nsilly :: [Int] -> Int\nsilly listlonger = case listlonger of (1:xs) -> 1\n --There is a comment\n (2:xs)\n | x < 10 -> 4 where x = last xs\n otherwise -> 12\n\n" - (unspace $ showGhcQual nb) `shouldBe` "module LayoutIn2 where\nsilly :: [Int] -> Int\nsilly listlonger\n = case listlonger of {\n (1 : xs) -> 1\n (2 : xs)\n | x < 10 -> 4\n where\n x = last xs\n otherwise -> 12 }" - - - ------------------------------------ - - it "realigns toks in a do for a shorter name" $ do - t <- ct $ parsedFileGhc "./Renaming/LayoutIn4.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let Just (GHC.L _l n) = locToName (7, 8) renamed - let - comp = do - logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) - - newName <- mkNewGhcName Nothing "io" - new <- renamePN n newName False parsed - - putRefactParsed new emptyAnns - - return (new,newName) - - ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual n) `shouldBe` "ioFun" - (sourceFromState s) `shouldBe` "module LayoutIn4 where\n\n--Layout rule applies after 'where','let','do' and 'of'\n\n--In this Example: rename 'ioFun' to 'io'\n\nmain = io \"hello\" where io s= do let k = reverse s\n--There is a comment\n s <- getLine\n let q = (k ++ s)\n putStr q\n putStr \"foo\"\n\n" - (unspace $ showGhcQual nb) `shouldBe` "module LayoutIn4 where\nmain\n = io \"hello\"\n where\n io s\n = do { let k = reverse s;\n s <- getLine;\n let q = (k ++ s);\n putStr q;\n putStr \"foo\" }" - - - ------------------------------------ - - it "realigns toks in a do for a longer name" $ do - t <- ct $ parsedFileGhc "./Renaming/LayoutIn4.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let Just (GHC.L _l n) = locToName (7, 8) renamed - let - comp = do - logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) - - newName <- mkNewGhcName Nothing "ioFunLong" - new <- renamePN n newName False parsed - - putRefactParsed new emptyAnns - - return (new,newName) - - ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual n) `shouldBe` "ioFun" - (sourceFromState s) `shouldBe` "module LayoutIn4 where\n\n--Layout rule applies after 'where','let','do' and 'of'\n\n--In this Example: rename 'ioFun' to 'io'\n\nmain = ioFunLong \"hello\" where ioFunLong s= do let k = reverse s\n --There is a comment\n s <- getLine\n let q = (k ++ s)\n putStr q\n putStr \"foo\"\n\n" - (unspace $ showGhcQual nb) `shouldBe` "module LayoutIn4 where\nmain\n = ioFunLong \"hello\"\n where\n ioFunLong s\n = do { let k = reverse s;\n s <- getLine;\n let q = (k ++ s);\n putStr q;\n putStr \"foo\" }" - - ------------------------------------ - - it "realigns toks in a where for a shorter name" $ do - t <- ct $ parsedFileGhc "./Renaming/LayoutIn1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let Just (GHC.L _l n) = locToName (7, 17) renamed - let - comp = do - logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) - - newName <- mkNewGhcName Nothing "q" - new <- renamePN n newName False parsed - - putRefactParsed new emptyAnns - - return (new,newName) - - ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual n) `shouldBe` "sq" - (sourceFromState s) `shouldBe` "module LayoutIn1 where\n\n--Layout rule applies after 'where','let','do' and 'of'\n\n--In this Example: rename 'sq' to 'square'.\n\nsumSquares x y= q x + q y where q x= x^pow\n--There is a comment.\n pow=2\n" - (unspace $ showGhcQual nb) `shouldBe` "module LayoutIn1 where\nsumSquares x y\n = q x + q y\n where\n q x = x ^ pow\n pow = 2" - - - ------------------------------------ - - it "realigns toks in a where for a longer name" $ do - t <- ct $ parsedFileGhc "./Renaming/LayoutIn1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let Just (GHC.L _l n) = locToName (7, 17) renamed - let - comp = do - logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) - - newName <- mkNewGhcName Nothing "square" - new <- renamePN n newName False parsed - - putRefactParsed new emptyAnns - - return (new,newName) - - ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual n) `shouldBe` "sq" - (sourceFromState s) `shouldBe` "module LayoutIn1 where\n\n--Layout rule applies after 'where','let','do' and 'of'\n\n--In this Example: rename 'sq' to 'square'.\n\nsumSquares x y= square x + square y where square x= x^pow\n --There is a comment.\n pow=2\n" - (unspace $ showGhcQual nb) `shouldBe` "module LayoutIn1 where\nsumSquares x y\n = square x + square y\n where\n square x = x ^ pow\n pow = 2" - - ------------------------------------ - - it "realigns toks in a let/in for a shorter name" $ do - t <- ct $ parsedFileGhc "./TypeUtils/LayoutLet1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let Just (GHC.L _l n) = locToName (6, 6) renamed - let - comp = do - logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) - - newName <- mkNewGhcName Nothing "x" - new <- renamePN n newName False parsed - - putRefactParsed new emptyAnns - - return (new,newName) - - ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual n) `shouldBe` "xxx" - (sourceFromState s) `shouldBe` "module LayoutLet1 where\n\n-- Simple let expression, rename xxx to something longer or shorter\n-- and the let/in layout should adjust accordingly\n\nfoo x = let a = 1\n b = 2\n in x + a + b\n\n" - (unspace $ showGhcQual nb) `shouldBe` "module LayoutLet1 where\nfoo x\n = let\n a = 1\n b = 2\n in x + a + b" - - ------------------------------------ - - it "realigns toks in a let/in for a longer name 1" $ do - t <- ct $ parsedFileGhc "./TypeUtils/LayoutLet1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let Just (GHC.L _l n) = locToName (6, 6) renamed - let - comp = do - logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) - - newName <- mkNewGhcName Nothing "xxxlong" - -- new <- renamePN n newName False renamed - new <- renamePN n newName False parsed - - putRefactParsed new emptyAnns - - return (new,newName) - - ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- ((nb,nn),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual n) `shouldBe` "xxx" - (sourceFromState s) `shouldBe` "module LayoutLet1 where\n\n-- Simple let expression, rename xxx to something longer or shorter\n-- and the let/in layout should adjust accordingly\n\nfoo xxxlong = let a = 1\n b = 2\n in xxxlong + a + b\n\n" - (unspace $ showGhcQual nb) `shouldBe` "module LayoutLet1 where\nfoo xxxlong\n = let\n a = 1\n b = 2\n in xxxlong + a + b" - - - ------------------------------------ - - it "realigns toks in a let/in for a longer name 2" $ do - t <- ct $ parsedFileGhc "./TypeUtils/LayoutLet2.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let Just (GHC.L _l n) = locToName (7, 6) renamed - let - comp = do - logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) - - newName <- mkNewGhcName Nothing "xxxlong" - new <- renamePN n newName False parsed - - putRefactParsed new emptyAnns - - return (new,newName) - - ((nb,nn),s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- ((nb,nn),s) <- ct $ runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual (n,nn)) `shouldBe` "(xxx, xxxlong)" - (sourceFromState s) `shouldBe` "module LayoutLet2 where\n\n-- Simple let expression, rename xxx to something longer or shorter\n-- and the let/in layout should adjust accordingly\n-- In this case the tokens for xxx + a + b should also shift out\n\nfoo xxxlong = let a = 1\n b = 2 in xxxlong + a + b\n\n" - (unspace $ showGhcQual nb) `shouldBe` "module LayoutLet2 where\nfoo xxxlong\n = let\n a = 1\n b = 2\n in xxxlong + a + b" - - - ------------------------------------ - - it "renames an exported data type" $ do - t <- ct $ parsedFileGhc "./Renaming/RenameInExportedType2.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let Just (GHC.L _l n) = locToName (6, 24) renamed - let - comp = do - logm $ "parsed:" ++ (SYB.showData SYB.Parser 0 parsed) - - newName <- mkNewGhcName Nothing "NewType" - new <- renamePN n newName False parsed - - putRefactParsed new emptyAnns - logm $ "parsed:after" ++ (SYB.showData SYB.Parser 0 new) - - return (new,newName) - - ((_nb,nn),s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- ((_nb,nn),s) <- ct $ runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual (n,nn)) `shouldBe` "(Renaming.RenameInExportedType.NT, NewType)" - (sourceFromState s) `shouldBe` "module Renaming.RenameInExportedType\n (\n MyType (NewType)\n ) where\n\ndata MyType = MT Int | NewType\n\n\n" - - - -- --------------------------------------------- - - describe "qualifyToplevelName" $ do - it "qualifies a name at the top level" $ do - t <- ct $ parsedFileGhc "./Renaming/C7.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - - let Just (GHC.L _l n) = locToName (7, 1) renamed - let - comp = do - qualifyToplevelName n - - return () - let - - (_,s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual n) `shouldBe` "Renaming.C7.myFringe" - (sourceFromState s) `shouldBe` "module Renaming.C7(Renaming.C7.myFringe) where\n\nimport Renaming.D7\n\nmyFringe:: Tree a -> [a]\nmyFringe (Leaf x ) = [x]\nmyFringe (Branch left right) = Renaming.C7.myFringe left ++ fringe right\n\n\n\n\n" - - - - -- --------------------------------------------- - - describe "findEntity" $ do - it "returns true if a (Located) Name is part of a HsBind 1" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let - comp = do - parentr <- getRefactRenamed - - let mn = locToName (4,1) parentr - let (Just (ln@(GHC.L _ n))) = mn - - let declsr = hsBinds parentr - duplicatedDecls = definingDeclsNames [n] declsr True False - - res = findEntity ln duplicatedDecls - res2 = findEntity n duplicatedDecls - -- res = findEntity' ln duplicatedDecls - - return (res,res2,duplicatedDecls,ln) - ((r,r2,d,_l),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - (showGhcQual d) `shouldBe` "[DupDef.Dd1.toplevel x = DupDef.Dd1.c GHC.Num.* x]" - (showGhcQual _l) `shouldBe` "DupDef.Dd1.toplevel" - ("1" ++ show r) `shouldBe` "1True" - ("2" ++ show r2) `shouldBe` "2True" - - -- --------------------------------- - - it "returns true if a (Located) Name is part of a HsBind 2" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let - comp = do - parentr <- getRefactRenamed - - let mn = locToName (31,7) parentr - let (Just (ln@(GHC.L _ n))) = mn - - let mnd = locToName (30,1) parentr - let (Just ((GHC.L _ nd))) = mnd - - let declsr = hsBinds parentr - duplicatedDecls = definingDeclsNames [nd] declsr True False - - res = findEntity ln duplicatedDecls - res2 = findEntity n duplicatedDecls - - return (res,res2,duplicatedDecls,ln) - ((r,r2,d,_l),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - (showGhcQual d) `shouldBe` "[DupDef.Dd1.dd q\n = do { let ss = 5;\n"++ - " GHC.Base.return (ss GHC.Num.+ q) }]" - (showGhcQual _l) `shouldBe` "ss" - ("1" ++ show r) `shouldBe` "1True" - ("2" ++ show r2) `shouldBe` "2True" - - - -- ----------------------------------------------------------------- - - it "returns false if a syntax phrase is not part of another" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let - comp = do - parentr <- getRefactRenamed - - let mn = locToName (4,1) parentr - let (Just (ln@(GHC.L _ n))) = mn - - let mltup = locToName (11,1) parentr - let (Just ((GHC.L _ tup))) = mltup - - let declsr = hsBinds parentr - duplicatedDecls = definingDeclsNames [n] declsr True False - - res = findEntity tup duplicatedDecls - -- res = findEntity' ln duplicatedDecls - - return (res,duplicatedDecls,ln) - ((r,d,_l),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - (showGhcQual d) `shouldBe` "[DupDef.Dd1.toplevel x = DupDef.Dd1.c GHC.Num.* x]" - ("1" ++ show r) `shouldBe` "1False" - - -- ----------------------------------------------------------------- - - it "Finds an entity in [HsBind Name]" $ do - pending -- "write this test" - - -- ----------------------------------------------------------------- - - it "Finds an entity in (MatchGroup matches _)" $ do - pending -- "write this test" - - -- ----------------------------------------------------------------- - - it "Finds an entity in (HsLet decls _)" $ do - pending -- "write this test" - - -- ----------------------------------------------------------------- - - it "Finds an entity in (HsLet _ e1)" $ do - pending -- "write this test" - - -- ----------------------------------------------------------------- - - it "Finds an entity in (HsLet decls _)" $ do - pending -- "write this test" - - -- ----------------------------------------------------------------- - - it "Finds an entity in (PatBind pat rhs _ _ _)" $ do - pending -- "write this test" - - -- ----------------------------------------------------------------- - - it "Finds an entity in (Match _ _ rhs)" $ do - pending -- "write this test" - - -- ----------------------------------------------------------------- - - it "Finds an entity in (LetStmt binds)" $ do - pending -- "write this test" - - -- ----------------------------------------------------------------- - - it "Finds an entity in (BindStmt _ rhs _ _)" $ do - pending -- "write this test" - - - -- --------------------------------------------- - - describe "modIsExported" $ do - it "Returns True if the module is explicitly exported" $ do - t <- ct $ parsedFileGhc "./FreeAndDeclared/Declare.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let renamed = fromJust $ GHC.tm_renamed_source t - let (Just (modName,_)) = getModuleName parsed - - (modIsExported modName renamed) `shouldBe` True - - it "Returns True if the module is exported by default" $ do - t <- ct $ parsedFileGhc "./FreeAndDeclared/Declare1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let renamed = fromJust $ GHC.tm_renamed_source t - let (Just (modName,_)) = getModuleName parsed - - (modIsExported modName renamed) `shouldBe` True - - it "Returns False if the module is explicitly not exported" $ do - t <- ct $ parsedFileGhc "./FreeAndDeclared/Declare2.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let renamed = fromJust $ GHC.tm_renamed_source t - let (Just (modName,_)) = getModuleName parsed - - (modIsExported modName renamed) `shouldBe` False - - -- --------------------------------------------- - - describe "isExported" $ do - it "returns True if a GHC.Name is exported" $ do - t <- ct $ parsedFileGhc "./Renaming/B1.hs" - - let - comp = do - renamed <- getRefactRenamed - - let mn1 = locToName (11,1) renamed - let (Just (GHC.L _ myFringe)) = mn1 - - let mn2 = locToName (15,1) renamed - let (Just (GHC.L _ sumSquares)) = mn2 - - exMyFring <- isExported myFringe - exSumSquares <- isExported sumSquares - - return (myFringe,exMyFring,sumSquares,exSumSquares) - ((mf,emf,ss,ess),_s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t}) testOptions - - (showGhcQual mf) `shouldBe` "Renaming.B1.myFringe" - emf `shouldBe` True - (showGhcQual ss) `shouldBe` "Renaming.B1.sumSquares" - ess `shouldBe` False - - -- --------------------------------------------- - - describe "addHiding" $ do - it "add a hiding entry to the imports with no existing hiding" $ do - t1 <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let - comp = do - clearParsedModule - t2 <- parseSourceFileTest "./DupDef/Dd2.hs" - let renamed1 = fromJust $ GHC.tm_renamed_source t1 - let renamed2 = fromJust $ GHC.tm_renamed_source t2 - - let parsed1 = GHC.pm_parsed_source $ GHC.tm_parsed_module t1 - let parsed2 = GHC.pm_parsed_source $ GHC.tm_parsed_module t2 - - let mn = locToName (4,1) renamed1 - let (Just (GHC.L _ _n)) = mn - - let Just (modName,_) = getModuleName parsed1 - let - n1 = mkRdrName "n1" - n2 = mkRdrName "n2" - res <- addHiding modName parsed2 [n1,n2] - putRefactParsed res emptyAnns - - return (res,renamed2) - ((_r,_r2),s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t1}) testOptions - -- ((_r,_r2),s) <- ct $ runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t1}) testOptions - - (sourceFromState s) `shouldBe` "module DupDef.Dd2 where\n\nimport DupDef.Dd1 hiding (n1,n2)\n\n\nf2 x = ff (x+1)\n\nmm = 5\n\n\n" - - ------------------------------------ - - it "adds a hiding entry to the imports with an existing hiding" $ do - t1 <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let - comp = do - - clearParsedModule - t2 <- parseSourceFileTest "./DupDef/Dd3.hs" - let renamed1 = fromJust $ GHC.tm_renamed_source t1 - let renamed2 = fromJust $ GHC.tm_renamed_source t2 - - let parsed1 = GHC.pm_parsed_source $ GHC.tm_parsed_module t1 - let parsed2 = GHC.pm_parsed_source $ GHC.tm_parsed_module t2 - - let mn = locToName (4,1) renamed1 - let (Just (GHC.L _ _n)) = mn - - let Just (modName,_) = getModuleName parsed1 - let - n1 = mkRdrName "n1" - n2 = mkRdrName "n2" - res <- addHiding modName parsed2 [n1,n2] - - return (res,renamed2) - ((_r,_r2),s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t1}) testOptions - (sourceFromState s) `shouldBe` "module DupDef.Dd3 where\n\nimport DupDef.Dd1 hiding (dd,n1,n2)\n\n\nf2 x = ff (x+1)\n\nmm = 5\n\n\n" - - -- --------------------------------------------- - - describe "equivalentNameInNewMod" $ do - it "finds equivalent name for normal import" $ do - let - ctc = cdAndDo "./test/testdata/cabal/foo" - let - comp = do - parseSourceFileGhc "./src/Foo/Bar.hs" - renamed <- getRefactRenamed - let Just ((GHC.L _l old)) = locToName (3,1) renamed - parseSourceFileGhc "./src/Main.hs" - [equiv] <- equivalentNameInNewMod old - return (old,equiv) - - ((o,e),_s) <- ctc $ runRefactGhc comp initialState testOptions - (showGhcQual (o,e)) `shouldBe` "(Foo.Bar.bar, Foo.Bar.bar)" - -- (showGhcQual (GHC.nameUnique o,GHC.nameUnique e)) `shouldBe` "" - (GHC.nameUnique o == GHC.nameUnique e) `shouldBe` False - - -- --------------------------------- - - it "finds equivalent name for qualified import" $ do - let - ctc = cdAndDo "./test/testdata/cabal/cabal4" - let - comp = do - parseSourceFileGhc "./src/Foo/Bar.hs" - renamed <- getRefactRenamed - let Just ((GHC.L _l old)) = locToName (3,1) renamed - parseSourceFileGhc "./src/main4.hs" - [equiv] <- equivalentNameInNewMod old - - parsed <- getRefactParsed - let Just ((GHC.L _l new)) = locToRdrName (11,12) parsed - return (old,equiv,new) - - ((o,e,n),_s) <- ctc $ runRefactGhc comp initialState testOptions - (showGhcQual (o,e,n)) `shouldBe` "(Foo.Bar.baz, Foo.Bar.baz, B.baz)" - -- (showGhcQual (GHC.nameUnique o,GHC.nameUnique e)) `shouldBe` "" - (GHC.nameUnique o == GHC.nameUnique e) `shouldBe` False - - -- --------------------------------------------- - - describe "usedWithoutQualR" $ do - it "Returns True if the identifier is used unqualified" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let - comp = do - renamed <- getRefactRenamed - parsed <- getRefactParsed - - let Just n@(GHC.L _ name) = locToName (14,21) renamed - let res = usedWithoutQualR name parsed - return (res,n,name) - - ((r,n1,n2),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (GHC.getOccString n2) `shouldBe` "zip" - (showGhcQual n1) `shouldBe` "GHC.List.zip" - r `shouldBe` True - - -- --------------------------------- - - it "Returns False if the identifier is used qualified" $ do - t <- ct $ parsedFileGhc "./FreeAndDeclared/Declare.hs" - let - comp = do - renamed <- getRefactRenamed - parsed <- getRefactParsed - - let Just n@(GHC.L _ name) = locToName (36,12) renamed - let Just (GHC.L _ namep) = locToRdrName (36,12) parsed - let res = usedWithoutQualR name parsed - return (res,namep,name,n) - ((r,np,n1,n2),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (myShow np) `shouldBe` "Qual:G:gshow" - (myShow $ GHC.getRdrName n1) `shouldBe` "Exact:Data.Generics.Text.gshow" - (showGhcQual $ GHC.getRdrName n1) `shouldBe` "Data.Generics.Text.gshow" - (showGhcQual n2) `shouldBe` "Data.Generics.Text.gshow" - r `shouldBe` False - - -- --------------------------------------------- - - describe "isExplicitlyExported" $ do - it "Returns True if the identifier is explicitly exported" $ do - pending -- "write this " - - it "Returns False if the identifier is not explicitly exported" $ do - pending -- "write this " - - -- --------------------------------------------- - - describe "causeNameClashInExports" $ do - it "Returns True if there is a clash" $ do - - t <- ct $ parsedFileGhc "./Renaming/ConflictExport.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let modu = GHC.ms_mod $ GHC.pm_mod_summary $ GHC.tm_parsed_module t - - -- Is this the right module? - let Just (modName,_) = getModuleName parsed - - let Just (GHC.L _ myFringe) = locToName (9,1) renamed - (showGhcQual myFringe) `shouldBe` "Renaming.ConflictExport.myFringe" - - -- old name is myFringe - -- new name is "Renaming.ConflictExport.fringe" - let newName = mkTestGhcName 1 (Just modu) "fringe" - - (showGhcQual modu) `shouldBe` "main@main:Renaming.ConflictExport" - (showGhcQual newName) `shouldBe` "Renaming.ConflictExport.fringe" - - (showGhcQual $ GHC.localiseName newName) `shouldBe` "fringe" - - let res = causeNameClashInExports myFringe newName modName renamed - res `shouldBe` True - - it "Returns False if there is no clash" $ do - t <- ct $ parsedFileGhc "./Renaming/ConflictExport.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let modu = GHC.ms_mod $ GHC.pm_mod_summary $ GHC.tm_parsed_module t - - -- Is this the right module? - let Just (modName,_) = getModuleName parsed - - let Just (GHC.L _ myFringe) = locToName (9,1) renamed - (showGhcQual myFringe) `shouldBe` "Renaming.ConflictExport.myFringe" - - -- old name is myFringe - -- new name is "Renaming.ConflictExport.fringe" - let newName = mkTestGhcName 1 (Just modu) "fringeOk" - - (showGhcQual modu) `shouldBe` "main@main:Renaming.ConflictExport" - (showGhcQual newName) `shouldBe` "Renaming.ConflictExport.fringeOk" - - (showGhcQual $ GHC.localiseName newName) `shouldBe` "fringeOk" - - let res = causeNameClashInExports myFringe newName modName renamed - res `shouldBe` False - - -- --------------------------------------- - - describe "rmQualifier" $ do - it "removes the qualifiers from a list of identifiers in a given syntax phrase" $ do - let - comp = do - parseSourceFileGhc "./TypeUtils/Qualified.hs" - renamed <- getRefactRenamed - parsed <- getRefactParsed - decls <- liftT $ hsDecls parsed - nm <- getRefactNameMap - - let Just (GHC.L _ foo) = locToName (5, 1) renamed - let Just (GHC.L _ baz) = locToName (5, 27) renamed - - let [fooDecl] = definingDeclsRdrNames nm [foo] decls False False - - res <- rmQualifier [baz] fooDecl - return (res,fooDecl,baz) - - ((r,d,n1),_s) <- ct $ runRefactGhc comp initialState testOptions - (showGhcQual n1) `shouldBe` "TypeUtils.C.baz" - (showGhcQual d) `shouldBe` "main = return TypeUtils.C.baz" - (showGhcQual r) `shouldBe` "main = return baz" - - it "Removes the qualifiers and updates the tokens" $ do - pending -- "Is this needed?" - - -- --------------------------------------- - - describe "usedByRhs" $ do - it "returns True if a given identifier is used in the RHS of a syntax element" $ do - t <- ct $ parsedFileGhc "./MoveDef/Demote.hs" - let - comp = do - renamed <- getRefactRenamed - parsed <- getRefactParsed - declsp <- liftT $ hsDecls parsed - nm <- getRefactNameMap - - let Just (GHC.L _ tl) = locToName (4,1) renamed - let Just (GHC.L _ name) = locToName (7,1) renamed - let decls = definingDeclsRdrNames nm [tl] declsp False False - decls' <- rmQualifier [name] decls - - let res = usedByRhsRdr nm decls' [name] - - return (res,decls,tl,name) - - ((r,d,n1,n2),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - (showGhcQual n1) `shouldBe` "MoveDef.Demote.toplevel" - (showGhcQual n2) `shouldBe` "MoveDef.Demote.c" - (showGhcQual d) `shouldBe` "[toplevel x = c * x]" - r `shouldBe` True - - -- --------------------------------------- - - describe "autoRenameLocalVar" $ do - it "renames an identifier if it is used and updates tokens" $ do - t <- ct $ parsedFileGhc "./Demote/WhereIn4.hs" - let - comp = do - renamed <- getRefactRenamed - parsed <- getRefactParsed - nm <- getRefactNameMap - tlDecls <- liftT $ hsDecls parsed - - let Just (GHC.L _ tl) = locToName (11,1) renamed - let Just (GHC.L _ name) = locToName (11,21) renamed - let [decls] = definingDeclsRdrNames nm [tl] tlDecls False True - decls' <- autoRenameLocalVar name decls - - return (decls',decls,tl,name) - - ((r,d,n1,n2),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- ((r,d,n1,n2),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - (showGhcQual n1) `shouldBe` "Demote.WhereIn4.sumSquares" - (showGhcQual n2) `shouldBe` "p" - (showGhcQual d) `shouldBe` "sumSquares x y\n = sq p x + sq p y\n where\n p = 2" - (showGhcQual r) `shouldBe` "sumSquares x y\n = sq p_1 x + sq p_1 y\n where\n p_1 = 2" - (exactPrintFromState s r) `shouldBe` "\n\n--A definition can be demoted to the local 'where' binding of a friend declaration,\n--if it is only used by this friend declaration.\n\n--Demoting a definition narrows down the scope of the definition.\n--In this example, demote the top level 'sq' to 'sumSquares'\n--In this case (there is single matches), if possible,\n--the parameters will be folded after demoting and type sigature will be removed.\n\nsumSquares x y = sq p_1 x + sq p_1 y\n where p_1=2" - - -- --------------------------------------- - - describe "mkNewName" $ do - it "Makes a new name that does not clash with existing ones" $ do - (mkNewName "f" ["f"] 0) `shouldBe` "f_1" - (mkNewName "f" ["g"] 0) `shouldBe` "f" - (mkNewName "f" ["g","f_1","f"] 0) `shouldBe` "f_2" - - -- --------------------------------------- - - describe "addImportDecl" $ do - it "adds an import entry to a module with already existing, non conflicting imports and other declarations" $ do - t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let - comp = do - clearParsedModule - parseSourceFileGhc "./DupDef/Dd2.hs" - renamed2 <- getRefactRenamed - parsed2 <- getRefactParsed - - let listModName = GHC.mkModuleName "Data.List" - res <- addImportDecl parsed2 listModName Nothing False False False Nothing False [] - putRefactParsed res emptyAnns - - return (res,renamed2) - ((_r,_r2),s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - (sourceFromState s) `shouldBe` "module DupDef.Dd2 where\n\nimport DupDef.Dd1\nimport Data.List\n\n\nf2 x = ff (x+1)\n\nmm = 5\n\n\n" - - -- --------------------------------- - - it "adds an import entry to a module with some declaration, but no explicit imports." $ do - t <- ct $ parsedFileGhc "./TypeUtils/Simplest.hs" - let - comp = do - - let renamed1 = fromJust $ GHC.tm_renamed_source t - parsed <- getRefactParsed - - let listModName = GHC.mkModuleName "Data.List" - res <- addImportDecl parsed listModName Nothing False False False Nothing False [] - putRefactParsed res emptyAnns - - return (res,renamed1) - ((_r,_r2),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - (sourceFromState s) `shouldBe` "module Simplest where\nimport Data.List\n\n\nsimple x = x\n" - - -- --------------------------------- - - it "adds an import entry to a module with explicit imports, but no declarations." $ do - t <- ct $ parsedFileGhc "./TypeUtils/JustImports.hs" - let - comp = do - let renamed1 = fromJust $ GHC.tm_renamed_source t - parsed <- getRefactParsed - - let listModName = GHC.mkModuleName "Data.List" - res <- addImportDecl parsed listModName Nothing False False False Nothing False [] - putRefactParsed res emptyAnns - - return (res,renamed1) - ((_r,_r2),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - (sourceFromState s) `shouldBe` "module JustImports where\n\nimport Data.Maybe\nimport Data.List\n" - - -- --------------------------------- - - it "adds an import entry to a module with no declarations and no explicit imports" $ do - t <- ct $ parsedFileGhc "./TypeUtils/Empty.hs" - let - comp = do - renamed1 <- getRefactRenamed - parsed <- getRefactParsed - - let listModName = GHC.mkModuleName "Data.List" - res <- addImportDecl parsed listModName Nothing False False False Nothing False [] - putRefactParsed res emptyAnns - - return (res,renamed1) - ((_r,_r2),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - (sourceFromState s) `shouldBe` "module Empty where\nimport Data.List\n\n" - - - -- --------------------------------------- - - describe "addItemsToImport" $ do - it "adds an item to an import entry with no items" $ do - t <- ct $ parsedFileGhc "./TypeUtils/JustImports.hs" - let - comp = do - parsed <- getRefactParsed - - let modName = GHC.mkModuleName "Data.Maybe" - -- itemName <- mkNewGhcName Nothing "fromJust" - let itemName = mkRdrName "fromJust" - - res <- addItemsToImport modName parsed [itemName] - putRefactParsed res emptyAnns - - return (res) - ((_r),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - - -- This is the correct behavior. If the import doesn't have an import list, creating - -- one for an item effectively reduces the imported interface. - (sourceFromState s) `shouldBe` "module JustImports where\n\nimport Data.Maybe\n" - --- Not sure if this should be a test -{- it "Try adding more than one item to an existing import entry with no items, using separate calls." $ do - let - comp = do - (t1,_toks1) <- parseSourceFileTest "./TypeUtils/JustImports.hs" - -- clearParsedModule - let renamed1 = fromJust $ GHC.tm_renamed_source t1 - - let modName = GHC.mkModuleName "Data.Maybe" - itemName <- mkNewGhcName Nothing "fromJust" - - res <- addItemsToImport modName renamed1 [itemName] --listModName Nothing False False False Nothing False [] - - itemName2 <- mkNewGhcName Nothing "isJust" - - res2 <- addItemsToImport modName res [itemName2] - toks <- fetchToks - - return (res2,toks,renamed,_toks1) - ((_r,t,r2,tk2),s) <- ct $ runRefactGhcState comp - (GHC.showRichTokenStream t) `shouldBe` "module JustImports where\n\n import Data.Maybe (fromJust,isJust)\n " --} - - -- --------------------------------- - - it "adds an item to an import entry with existing items" $ do - t <- ct $ parsedFileGhc "./TypeUtils/SelectivelyImports.hs" - let - comp = do - parsed <-getRefactParsed - - let modName = GHC.mkModuleName "Data.Maybe" - let itemName = mkRdrName "isJust" - - res <- addItemsToImport modName parsed [itemName] - putRefactParsed res emptyAnns - return (res) - ((_r),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - (sourceFromState s) `shouldBe` "module SelectivelyImports where\n\nimport Data.Maybe (fromJust,isJust)\n\n__ = id\n" - -{- -- test after properly inserting conditional identifier - it "Add an item to an import entry with existing items, passing existing conditional identifier." $ do - let - comp = do - (t1,_toks1) <- parseSourceFileTest "./TypeUtils/SelectivelyImports.hs" - -- clearParsedModule - let renamed1 = fromJust $ GHC.tm_renamed_source t1 - - let modName = GHC.mkModuleName "Data.Maybe" - itemName <- mkNewGhcName Nothing "isJust" - conditionalId <- mkNewGhcName Nothing "fromJust" - - res <- addItemsToImport modName renamed1 [itemName] (Just conditionalId) - toks <- fetchToks - - return (res,toks,renamed1,_toks1) - ((_r,t,r2,tk2),s) <- ct $ runRefactGhcState comp - (GHC.showRichTokenStream t) `shouldBe` "module SelectivelyImports where\n\n import Data.Maybe (fromJust,isJust)\n\n __ = id\n " - - it "Add an item to an import entry with existing items, passing missing conditional identifier" $ do - let - comp = do - (t1,_toks1) <- parseSourceFileTest "./TypeUtils/SelectivelyImports.hs" - -- clearParsedModule - let renamed1 = fromJust $ GHC.tm_renamed_source t1 - - let modName = GHC.mkModuleName "Data.Maybe" - itemName <- mkNewGhcName Nothing "isJust" - - res <- addItemsToImport modName renamed1 [itemName] (Just itemName) - toks <- fetchToks - - return (res,toks,renamed1,_toks1) - ((_r,t,r2,tk2),s) <- ct $ runRefactGhcState comp - (GHC.showRichTokenStream t) `shouldBe` "module SelectivelyImports where\n\n import Data.Maybe (fromJust)\n\n __ = id\n " --} - - -- --------------------------------------- - - describe "hsValBinds" $ do - it "returns ValBinds for RenamedSource" $ do - t <- ct $ parsedFileGhc "./LiftOneLevel/D1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let vb = hsValBinds renamed - (showGhcQual vb) `shouldBe` "LiftOneLevel.D1.sumSquares (x : xs)\n = sq x GHC.Num.+ LiftOneLevel.D1.sumSquares xs\n where\n sq x = x GHC.Real.^ pow\n pow = 2\nLiftOneLevel.D1.sumSquares [] = 0\nLiftOneLevel.D1.main = LiftOneLevel.D1.sumSquares [1 .. 4]" - - -- --------------------------------- - - it "returns ValBinds for (HsGroup Name)" $ do - t <- ct $ parsedFileGhc "./LiftOneLevel/D1.hs" - let (g,_,_,_) = fromJust $ GHC.tm_renamed_source t - let vb = hsValBinds g - (showGhcQual vb) `shouldBe` "LiftOneLevel.D1.sumSquares (x : xs)\n = sq x GHC.Num.+ LiftOneLevel.D1.sumSquares xs\n where\n sq x = x GHC.Real.^ pow\n pow = 2\nLiftOneLevel.D1.sumSquares [] = 0\nLiftOneLevel.D1.main = LiftOneLevel.D1.sumSquares [1 .. 4]" - - -- --------------------------------------- - - describe "stripLeadingSpaces" $ do - it "Strips the longest common space prefix from a list of Strings" $ do - (stripLeadingSpaces []) `shouldBe` [] - (stripLeadingSpaces ["a"," b"," c"]) `shouldBe` ["a"," b"," c"] - (stripLeadingSpaces [" a"," b"," c"]) `shouldBe` ["a","b"," c"] - - -- --------------------------------------- - - describe "unspace" $ do - it "Reduces all sequences of more than one space to a single one" $ do - (unspace []) `shouldBe` [] - (unspace "a") `shouldBe` "a" - (unspace "a bc") `shouldBe` "a bc" - (unspace "a bc") `shouldBe` "a bc" - (unspace "ab c") `shouldBe` "ab c" - (unspace " ab c") `shouldBe` " ab c" - (unspace "abc ") `shouldBe` "abc " - - -- --------------------------------------- - - describe "isFieldName" $ do - it "returns True if a Name is a field name" $ do - t <- ct $ parsedFileGhc "./Renaming/Field3.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let Just (GHC.L _ nf) = locToName (10,21) renamed - let Just (GHC.L _ n) = locToName (10,1) renamed - - (showGhcQual n) `shouldBe` "Field3.absPoint" - (showGhcQual nf) `shouldBe` "Field3.pointx" - - -- --------------------------------------- - - describe "name predicates" $ do - it "classifies names" $ do - t <- ct $ parsedFileGhc "./Cons.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let Just (GHC.L _ n1) = locToName (3,6) renamed - let Just (GHC.L _ n2) = locToName (3,12) renamed - let Just (GHC.L _ n3) = locToName (3,16) renamed - let Just (GHC.L _ n4) = locToName (5,1) renamed - let Just (GHC.L _ n5) = locToName (8,5) renamed - - (showGhcQual n1) `shouldBe` "Main.Foo" - "11" ++ (show $ GHC.isTyVarName n1) `shouldBe` "11False" - "12" ++ (show $ GHC.isTyConName n1) `shouldBe` "12True" - "13" ++ (show $ GHC.isDataConName n1) `shouldBe` "13False" - "14" ++ (show $ GHC.isValName n1) `shouldBe` "14False" - "15" ++ (show $ GHC.isVarName n1) `shouldBe` "15False" - - (showGhcQual n2) `shouldBe` "Main.Ff" - "21" ++ (show $ GHC.isTyVarName n2) `shouldBe` "21False" - "22" ++ (show $ GHC.isTyConName n2) `shouldBe` "22False" - "23" ++ (show $ GHC.isDataConName n2) `shouldBe` "23True" - "24" ++ (show $ GHC.isValName n2) `shouldBe` "24True" - "25" ++ (show $ GHC.isVarName n2) `shouldBe` "25False" - - (showGhcQual n3) `shouldBe` "Main.fooA" -- field name - "31" ++ (show $ GHC.isTyVarName n3) `shouldBe` "31False" - "32" ++ (show $ GHC.isTyConName n3) `shouldBe` "32False" - "33" ++ (show $ GHC.isDataConName n3) `shouldBe` "33False" - "34" ++ (show $ GHC.isValName n3) `shouldBe` "34True" - "35" ++ (show $ GHC.isVarName n3) `shouldBe` "35True" - - (showGhcQual n4) `shouldBe` "Main.xx" - "41" ++ (show $ GHC.isTyVarName n4) `shouldBe` "41False" - "42" ++ (show $ GHC.isTyConName n4) `shouldBe` "42False" - "43" ++ (show $ GHC.isDataConName n4) `shouldBe` "43False" - "44" ++ (show $ GHC.isValName n4) `shouldBe` "44True" - "45" ++ (show $ GHC.isVarName n4) `shouldBe` "45True" - - (showGhcQual n5) `shouldBe` "GHC.Classes.==" - "51" ++ (show $ GHC.isTyVarName n5) `shouldBe` "51False" - "52" ++ (show $ GHC.isTyConName n5) `shouldBe` "52False" - "53" ++ (show $ GHC.isDataConName n5) `shouldBe` "53False" - "54" ++ (show $ GHC.isValName n5) `shouldBe` "54True" - "55" ++ (show $ GHC.isVarName n5) `shouldBe` "55True" - - -- --------------------------------------------------------------------- - - describe "rdrName2Name" $ do - - it "finds a Name for a top-level RdrName" $ do - t <- ct $ parsedFileGhc "./TokenTest.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let - comp = do - let (Just rdr) = locToRdrName (5,1) parsed - (Just name) = locToName (5,1) renamed - nname <- rdrName2Name rdr - return (rdr,name,nname) - ((r,n,nn),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- ((r,n,nn),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual (r,n,nn)) `shouldBe` "(bob, TokenTest.bob, TokenTest.bob)" - - -- --------------------------------- - - it "finds a Name for a local RdrName" $ do - t <- ct $ parsedFileGhc "./TokenTest.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - - let - comp = do - let (Just rdr) = locToRdrName (14,7) parsed - (Just name) = locToName (14,7) renamed - nname <- rdrName2Name rdr - return (rdr,name,nname) - ((r,n,nn),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions - -- ((r,n,nn),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - - (showGhcQual (r,n,nn)) `shouldBe` "(bar, bar, bar)" +{-# LANGUAGE CPP #-} +module TypeUtilsSpec (main, spec) where + +import Test.Hspec + +import TestUtils + +import qualified GHC.SYB.Utils as SYB + +import qualified GHC as GHC +import qualified GhcMonad as GHC +import qualified Name as GHC +import qualified RdrName as GHC +import qualified Module as GHC + +import Data.Maybe + +import Language.Haskell.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint.Parsers +import Language.Haskell.GHC.ExactPrint.Types + +import Language.Haskell.Refact.Utils.GhcVersionSpecific +import Language.Haskell.Refact.Utils.LocUtils +import Language.Haskell.Refact.Utils.Monad +import Language.Haskell.Refact.Utils.MonadFunctions +import Language.Haskell.Refact.Utils.TypeUtils +import Language.Haskell.Refact.Utils.Utils +import Language.Haskell.Refact.Utils.Variables + +import Data.List + +main :: IO () +main = do + hspec spec + +spec :: Spec +spec = do + + -- ------------------------------------------------------------------- +{- + describe "findAllNameOccurences" $ do + it "finds all occurrences of the given name in a syntax phrase" $ do + t <- ct $ parsedFileGhc "./TypeUtils/S.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (4,5) parsed + (showGhcQual n) `shouldBe` "x" + + let res = findAllNameOccurences n renamed + (showGhcQual res) `shouldBe` "[x, x]" + -- NOTE: does not get the x's in line 8 + (showGhcQual $ map startEndLocGhc res) `shouldBe` "[((4, 5), (4, 6)), ((4, 17), (4, 18))]" +-} + -- ------------------------------------------------------------------- + + describe "locToName" $ do + it "returns a GHC.Name for a given source location, if it falls anywhere in an identifier #1" $ do + t <- ct $ parsedFileGhc "./TypeUtils/B.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just (res'@(GHC.L l _)) = locToRdrName (7,3) parsed + n = rdrName2NamePure nm res' + res = GHC.L l n + showGhcQual l `shouldBe` "TypeUtils/B.hs:7:1-3" + getLocatedStart res `shouldBe` (7,1) + showGhcQual n `shouldBe` "TypeUtils.B.foo" + + -- --------------------------------- + + it "returns a GHC.Name for a given source location, if it falls anywhere in an identifier #2" $ do + t <- ct $ parsedFileGhc "./TypeUtils/B.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just (res'@(GHC.L l _)) = locToRdrName (25,8) parsed + n = rdrName2NamePure nm res' + res = GHC.L l n + showGhcQual n `shouldBe` "TypeUtils.B.bob" + showGhcQual l `shouldBe` "TypeUtils/B.hs:25:7-9" + getLocatedStart res `shouldBe` (25,7) + + -- --------------------------------- + + it "returns Nothing for a given source location, if it does not fall in an identifier" $ do + t <- ct $ parsedFileGhc "TypeUtils/B.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let res = locToNameRdrPure nm (7,7) parsed + (showGhcQual res) `shouldBe` "Nothing" + + -- --------------------------------- + + it "gets a short name too" $ do + t <- ct $ parsedFileGhc "./Demote/WhereIn2.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just (res'@(GHC.L l _)) = locToRdrName (14,1) parsed + n = rdrName2NamePure nm res' + res = GHC.L l n + showGhcQual n `shouldBe` "Demote.WhereIn2.sq" + showGhcQual l `shouldBe` "Demote/WhereIn2.hs:14:1-2" + getLocatedStart res `shouldBe` (14,1) + + -- --------------------------------- + + it "gets a type variable name" $ do + t <- ct $ parsedFileGhc "./Renaming/ConstructorIn3.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just (res'@(GHC.L l _)) = locToRdrName (9,12) parsed + n = rdrName2NamePure nm res' + res = GHC.L l n + showGhcQual n `shouldBe` "a" + -- Note: loc does not line up due to multiple matches in FunBind + showGhcQual l `shouldBe` "Renaming/ConstructorIn3.hs:9:12" + getLocatedStart res `shouldBe` (9,12) + + -- --------------------------------- + + it "gets an instance class name" $ do + t <- ct $ parsedFileGhc "./Renaming/ClassIn3.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + let Just (res'@(GHC.L l _)) = locToRdrName (16,10) parsed + n = rdrName2NamePure nm res' + res = GHC.L l n + showGhcQual n `shouldBe` "GHC.Classes.Eq" + showGhcQual l `shouldBe` "Renaming/ClassIn3.hs:16:10-11" + getLocatedStart res `shouldBe` (16,10) + + -- ------------------------------------------------------------------- + + describe "locToRdrName" $ do + it "returns a GHC.RdrName for a given source location, if it falls anywhere in an identifier" $ do + t <- ct $ parsedFileGhc "./Renaming/D5.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just (res@(GHC.L l n)) = locToRdrName (20,1) parsed + (show $ ss2span l) `shouldBe` "((20,1),(20,11))" + getLocatedStart res `shouldBe` (20,1) + showGhcQual n `shouldBe` "sumSquares" + + it "returns a GHC.RdrName for a source location, in a MatchGroup" $ do + t <- ct $ parsedFileGhc "./LocToName.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just (res@(GHC.L l n)) = locToRdrName (24,2) parsed + showGhcQual n `shouldBe` "sumSquares" + getLocatedStart res `shouldBe` (24,1) + showGhcQual l `shouldBe` "LocToName.hs:24:1-10" + + -- ------------------------------------------------------------------- + + describe "getName" $ do + it "gets a qualified Name at the top level" $ do + t <- ct $ parsedFileGhc "./TypeUtils/B.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let Just n = getName "TypeUtils.B.foo'" renamed + (showGhcQual n) `shouldBe` "TypeUtils.B.foo'" + (showGhcQual $ GHC.getSrcSpan n) `shouldBe` "TypeUtils/B.hs:14:1-4" + + it "gets any instance of an unqualified Name" $ do + t <- ct $ parsedFileGhc "./TypeUtils/B.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let Just n = getName "foo" renamed + (showGhcQual n) `shouldBe` "foo" + (showGhcQual $ GHC.getSrcSpan n) `shouldBe` "TypeUtils/B.hs:9:15-17" + + it "returns Nothing if the Name is not found" $ do + t <- ct $ parsedFileGhc "./TypeUtils/B.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let res = getName "baz" renamed + (showGhcQual res) `shouldBe` "Nothing" + + -- ------------------------------------------------------------------- + + describe "definingDeclsRdrNames" $ do + it "returns [] if not found" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let nm = initRdrNameMap t + let Just n = locToNameRdrPure nm (16,6) parsed + let decls = GHC.hsmodDecls $ GHC.unLoc parsed + let res = definingDeclsRdrNames nm [n] decls False False + showGhcQual res `shouldBe` "[]" + + -- --------------------------------- + + it "finds declarations at the top level" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (3,3) parsed + let decls = GHC.hsmodDecls $ GHC.unLoc parsed + let res = definingDeclsRdrNames nm [n] decls False False + showGhcQual res `shouldBe` "[toplevel x = c * x]" + + -- --------------------------------- + + it "finds declarations not at the top level 1" $ do + t <- ct $ parsedFileGhc "./LiftToToplevel/WhereIn6.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (13,29) parsed + let decls = GHC.hsmodDecls $ GHC.unLoc parsed + let res = definingDeclsRdrNames nm [n] decls False True + showGhcQual n `shouldBe` "pow" + showGhcQual res `shouldBe` "[pow = 2]" + + -- --------------------------------- + + it "finds declarations not at the top level 2" $ do + t <- ct $ parsedFileGhc "./LiftToToplevel/LetIn1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (11,22) parsed + let decls = GHC.hsmodDecls $ GHC.unLoc parsed + let res = definingDeclsRdrNames nm [n] decls False True + showGhcQual n `shouldBe` "sq" + showGhcQual res `shouldBe` "[sq 0 = 0\n sq z = z ^ pow]" + + -- --------------------------------- + + it "finds in a patbind" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (14,1) parsed + let decls = GHC.hsmodDecls $ GHC.unLoc parsed + let res = definingDeclsRdrNames nm [n] decls False False + showGhcQual res `shouldBe` "[tup@(h, t)\n = head $ zip [1 .. 10] [3 .. ff]\n where\n ff :: Int\n ff = 15]" + + -- --------------------------------- + + it "finds recursively in sub-binds" $ do + {- + modInfo@((_, _, mod@(GHC.L l (GHC.HsModule name exps imps ds _ _))), toks) <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let res = definingDecls [(PN (mkRdrName "zz"))] ds False True + showGhcQual res `shouldBe` "[zz n = n + 1]" -- TODO: Currently fails, will come back to it + -} + pending -- "Currently fails, will come back to it" + + -- --------------------------------- + + it "only finds recursively in sub-binds if asked" $ do + {- + modInfo@((_, _, mod@(GHC.L l (GHC.HsModule name exps imps ds _ _))), toks) <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let res = definingDecls [(PN (mkRdrName "zz"))] ds False False + showGhcQual res `shouldBe` "[]" + -} + pending -- "Convert to definingDeclsNames" + + -- ------------------------------------------------------------------- +{- + describe "definingDeclsNames" $ do + it "returns [] if not found" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (16,6) parsed + let res = definingDeclsNames [n] (hsBinds renamed) False False + showGhcQual res `shouldBe` "[]" + + it "finds declarations at the top level" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (3,3) parsed + let res = definingDeclsNames [n] (hsBinds renamed) False False + showGhcQual res `shouldBe` "[DupDef.Dd1.toplevel x = DupDef.Dd1.c GHC.Num.* x]" + + + it "finds in a patbind" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (14,1) parsed + let res = definingDeclsNames [n] (hsBinds renamed) False False + showGhcQual res `shouldBe` "[DupDef.Dd1.tup@(DupDef.Dd1.h, DupDef.Dd1.t)\n = GHC.List.head GHC.Base.$ GHC.List.zip [1 .. 10] [3 .. ff]\n where\n ff :: GHC.Types.Int\n ff = 15]" + + + it "finds recursively in sub-binds" $ do + {- + modInfo@((_, _, mod@(GHC.L l (GHC.HsModule name exps imps ds _ _))), toks) <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let res = definingDecls [(PN (mkRdrName "zz"))] ds False True + showGhcQual res `shouldBe` "[zz n = n + 1]" -- TODO: Currently fails, will come back to it + -} + pending -- "Currently fails, will come back to it" + + it "only finds recursively in sub-binds if asked" $ do + {- + modInfo@((_, _, mod@(GHC.L l (GHC.HsModule name exps imps ds _ _))), toks) <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let res = definingDecls [(PN (mkRdrName "zz"))] ds False False + showGhcQual res `shouldBe` "[]" + -} + pending -- "Convert to definingDeclsNames" +-} + -- ------------------------------------------------------------------- + + describe "definingSigsRdrNames" $ do + it "returns [] if not found" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (21,1) parsed + showGhcQual n `shouldBe` "DupDef.Dd1.ff" + let res = definingSigsRdrNames nm [n] parsed + showGhcQual res `shouldBe` "[]" + + -- --------------------------------- + + it "finds signatures at the top level" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (4,1) parsed + showGhcQual n `shouldBe` "DupDef.Dd1.toplevel" + let res = definingSigsRdrNames nm [n] parsed + showGhcQual res `shouldBe` "[toplevel :: Integer -> Integer]" + + -- --------------------------------- + + it "returns only the single signature where there are others too" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (7,1) parsed + showGhcQual n `shouldBe` "DupDef.Dd1.c" + let res = definingSigsRdrNames nm [n] parsed + showGhcQual res `shouldBe` "[c :: Integer]" + + -- --------------------------------- + + it "finds signatures at lower levels" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (16,5) parsed + showGhcQual n `shouldBe` "ff" + let res = definingSigsRdrNames nm [n] parsed + showGhcQual res `shouldBe` "[ff :: Int]" + + -- --------------------------------- + + it "finds multiple signatures 1" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let nm = initRdrNameMap t + + let Just n1 = locToNameRdrPure nm (21,1) parsed + showGhcQual n1 `shouldBe` "DupDef.Dd1.ff" + + let Just n2 = locToNameRdrPure nm (16,5) parsed + showGhcQual n2 `shouldBe` "ff" + + let Just n3 = locToNameRdrPure nm (4,1) parsed + showGhcQual n3 `shouldBe` "DupDef.Dd1.toplevel" + + let res = definingSigsRdrNames nm [n1,n2,n3] parsed + showGhcQual res `shouldBe` "[toplevel :: Integer -> Integer, ff :: Int]" + + -- --------------------------------- + + it "finds multiple signatures 2" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let nm = initRdrNameMap t + + let Just n1 = locToNameRdrPure nm (14,1) parsed + showGhcQual n1 `shouldBe` "DupDef.Dd1.tup" + + let Just n2 = locToNameRdrPure nm (14,6) parsed + showGhcQual n2 `shouldBe` "DupDef.Dd1.h" + + let Just n3 = locToNameRdrPure nm (14,8) parsed + showGhcQual n3 `shouldBe` "DupDef.Dd1.t" + + let res = definingSigsRdrNames nm [n1,n2,n3] parsed + showGhcQual res `shouldBe` "[tup :: (Int, Int), h :: Int, t :: Int]" + + -- ------------------------------------------------------------------- + + describe "definingTyClDeclsNames" $ do + it "returns [] if not found" $ do + t <- ct $ parsedFileGhc "./TypeUtils/TyClDecls.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (10,29) parsed + let res = definingTyClDeclsNames nm [n] parsed + showGhcQual res `shouldBe` "[]" + + -- --------------------------------- + + it "finds foreign type declarations" $ do + pending + + -- --------------------------------- + + it "finds family declarations" $ do + t <- ct $ parsedFileGhc "./TypeUtils/TyClDecls.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + -- putStrLn $ "parsed:" ++ SYB.showData SYB.Parser 0 parsed + + let Just n = locToNameRdrPure nm (7,14) parsed + let res = definingTyClDeclsNames nm [n] parsed + showGhcQual res `shouldBe` "[data family XList a]" + + -- --------------------------------- + + it "finds data declarations" $ do + t <- ct $ parsedFileGhc "./TypeUtils/TyClDecls.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (12,6) parsed + let res = definingTyClDeclsNames nm [n] parsed + (unspace $ showGhcQual res) `shouldBe` "[data Foo = Foo Int]" + + -- --------------------------------- + + it "finds type declarations" $ do + t <- ct $ parsedFileGhc "./TypeUtils/TyClDecls.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (14,6) parsed + let res = definingTyClDeclsNames nm [n] parsed + showGhcQual res `shouldBe` "[type Foo2 = String]" + + -- --------------------------------- + + it "finds class declarations" $ do + t <- ct $ parsedFileGhc "./TypeUtils/TyClDecls.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (16,7) parsed + let res = definingTyClDeclsNames nm [n] parsed + showGhcQual res `shouldBe` "[class Bar a where\n bar :: a -> Bool]" + + -- --------------------------------- + + it "finds multiple declarations" $ do + t <- ct $ parsedFileGhc "./TypeUtils/TyClDecls.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n1 = locToNameRdrPure nm (14,6) parsed + let Just n2 = locToNameRdrPure nm (16,7) parsed + let res = definingTyClDeclsNames nm [n1,n2] parsed + showGhcQual res `shouldBe` "[type Foo2 = String,\n class Bar a where\n bar :: a -> Bool]" + + + -- ------------------------------------------------------------------- + + describe "isFunBindR" $ do + it "Returns False if not a function definition" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let decls = getHsDecls parsed + let Just tup = getName "DupDef.Dd1.tup" renamed + let [GHC.L l (GHC.ValD decl)] = definingDeclsRdrNames nm [tup] decls False False + isFunBindR (GHC.L l decl) `shouldBe` False + + it "Returns True if a function definition" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let (GHC.L _l (GHC.HsModule _name _exps _imps _ds _ _)) = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just toplevel = getName "DupDef.Dd1.toplevel" renamed + let [GHC.L l (GHC.ValD decl)] = definingDeclsRdrNames nm [toplevel] (getHsDecls parsed) False False + isFunBindR (GHC.L l decl) `shouldBe` True + + -- ------------------------------------------------------------------- + + describe "isFunOrPatName" $ do + it "return True if a PName is a function/pattern name defined in t" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + -- putStrLn $ "parsed:\n" ++ SYB.showData SYB.Parser 0 parsed + let Just tup = getName "DupDef.Dd1.tup" renamed + (showGhcQual tup) `shouldBe` "DupDef.Dd1.tup" + isFunOrPatName nm tup parsed `shouldBe` True + + -- --------------------------------- + + it "return False if a PName is a function/pattern name defined in t" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + t2 <- ct $ parsedFileGhc "./DupDef/Dd2.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed2 = GHC.pm_parsed_source $ GHC.tm_parsed_module t2 + nm2 = initRdrNameMap t2 + + let Just tup = getName "DupDef.Dd1.tup" renamed + isFunOrPatName nm2 tup parsed2 `shouldBe` False + + + -- ------------------------------------------------------------------- + + describe "hsFreeAndDeclaredXXXX" $ do + + it "finds declared in type class definitions" $ do + t <- ct $ parsedFileGhc "./FreeAndDeclared/DeclareTypes.hs" + + let + comp = do + parsed <- getRefactParsed + decls <- liftT $ hsDecls parsed + tdss <- mapM getDeclaredTypesRdr decls + let tds = nub $ concat tdss + return (tds) + ((res),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- ((res),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (res)) `shouldBe` + "[(FreeAndDeclared.DeclareTypes.XList, (8, 1)),\n"++ + " (FreeAndDeclared.DeclareTypes.X, (19, 1)),\n"++ + " (FreeAndDeclared.DeclareTypes.Y, (19, 10)),\n"++ + " (FreeAndDeclared.DeclareTypes.Z, (19, 22)),\n"++ + " (FreeAndDeclared.DeclareTypes.W, (19, 26)),\n"++ + " (FreeAndDeclared.DeclareTypes.Foo, (21, 1)),\n"++ + " (FreeAndDeclared.DeclareTypes.Bar, (23, 1)),\n"++ + " (FreeAndDeclared.DeclareTypes.doBar, (27, 3)),\n"++ + " (FreeAndDeclared.DeclareTypes.BarVar, (24, 3)),\n"++ + " (FreeAndDeclared.DeclareTypes.BarData, (25, 3))]" + + -- --------------------------------- + + it "finds declared HsVar" $ do + t <- ct $ parsedFileGhc "./FreeAndDeclared/Declare.hs" + let + comp = do + parsed <- getRefactParsed + nm <- getRefactNameMap + logDataWithAnns "parsed:" parsed + let rr = hsFreeAndDeclaredRdr nm parsed + rg <- hsFreeAndDeclaredPNs parsed + return (rg,rr) + -- ((resg,(FN fr,DN dr)),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + ((resg,(FN fr,DN dr)),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + -- --------------------- + -- Free Vars - parsed + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) fr) `shouldBe` + "[(GHC.Integer.Type.Integer, (-1, -1)), "++ + "(GHC.Num.*, (-1, -1)),\n "++ + "(GHC.Types.Int, (-1, -1)), "++ + "(GHC.Base.$, (-1, -1)),\n "++ + "(GHC.List.head, (-1, -1)), "++ + "(GHC.List.zip, (-1, -1)),\n "++ + "(System.IO.getChar, (-1, -1)), "++ + "(System.IO.putStrLn, (-1, -1)),\n "++ + "(Data.Generics.Text.gshow, (-1, -1))]" + + -- Declared Vars - parsed + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) dr) `shouldBe` + "[(FreeAndDeclared.Declare.toplevel, (6, 1)),\n "++ + "(FreeAndDeclared.Declare.c, (9, 1)),\n "++ + "(FreeAndDeclared.Declare.d, (10, 1)),\n "++ + "(FreeAndDeclared.Declare.tup, (16, 1)),\n "++ + "(FreeAndDeclared.Declare.h, (16, 6)),\n "++ + "(FreeAndDeclared.Declare.t, (16, 8)),\n "++ + "(FreeAndDeclared.Declare.D, (18, 1)),\n "++ + "(FreeAndDeclared.Declare.A, (18, 10)),\n "++ + "(FreeAndDeclared.Declare.B, (18, 14)),\n "++ + "(FreeAndDeclared.Declare.C, (18, 25)),\n "++ + "(FreeAndDeclared.Declare.unD, (21, 1)),\n "++ + "(FreeAndDeclared.Declare.F, (25, 1)),\n "++ + "(FreeAndDeclared.Declare.G, (25, 10)),\n "++ + "(FreeAndDeclared.Declare.:|, (25, 14)),\n "++ + "(FreeAndDeclared.Declare.unF, (27, 1)),\n "++ + "(FreeAndDeclared.Declare.main, (30, 1)),\n "++ + "(FreeAndDeclared.Declare.mkT, (34, 1)),\n "++ + "(FreeAndDeclared.Declare.ff, (36, 1))]" + + -- --------------------- + -- GHC version + -- Free Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst resg)) `shouldBe` + "[(GHC.Integer.Type.Integer, (-1, -1)), "++ + "(GHC.Num.*, (-1, -1)),\n "++ + "(GHC.Types.Int, (-1, -1)), "++ + "(GHC.Base.$, (-1, -1)),\n "++ + "(GHC.List.head, (-1, -1)), "++ + "(GHC.List.zip, (-1, -1)),\n "++ + "(System.IO.getChar, (-1, -1)), "++ + "(System.IO.putStrLn, (-1, -1)),\n "++ + "(Data.Generics.Text.gshow, (-1, -1))]" + + -- Declared Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd resg)) `shouldBe` + "[(FreeAndDeclared.Declare.toplevel, (6, 1)),\n "++ + "(FreeAndDeclared.Declare.c, (9, 1)),\n "++ + "(FreeAndDeclared.Declare.d, (10, 1)),\n "++ + "(FreeAndDeclared.Declare.tup, (16, 1)),\n "++ + "(FreeAndDeclared.Declare.h, (16, 6)),\n "++ + "(FreeAndDeclared.Declare.t, (16, 8)),\n "++ + "(FreeAndDeclared.Declare.D, (18, 1)),\n "++ + "(FreeAndDeclared.Declare.A, (18, 10)),\n "++ + "(FreeAndDeclared.Declare.B, (18, 14)),\n "++ + "(FreeAndDeclared.Declare.C, (18, 25)),\n "++ + "(FreeAndDeclared.Declare.unD, (21, 1)),\n "++ + "(FreeAndDeclared.Declare.F, (25, 1)),\n "++ + "(FreeAndDeclared.Declare.G, (25, 10)),\n "++ + "(FreeAndDeclared.Declare.:|, (25, 14)),\n "++ + "(FreeAndDeclared.Declare.unF, (27, 1)),\n "++ + "(FreeAndDeclared.Declare.main, (30, 1)),\n "++ + "(FreeAndDeclared.Declare.mkT, (34, 1)),\n "++ + "(FreeAndDeclared.Declare.ff, (36, 1))]" + + + -- --------------------------------- + + it "finds free and declared in a single bind PrefixCon" $ do + t <- ct $ parsedFileGhc "./FreeAndDeclared/Declare.hs" + -- (SYB.showData SYB.Renamer 0 renamed) `shouldBe` "" + + let + comp = do + parsed <- getRefactParsed + decls <- liftT $ hsDecls parsed + -- let b = head $ drop 4 $ hsBinds renamed + let b = head $ drop 10 $ decls + rg <- hsFreeAndDeclaredPNs [b] + return (b,rg) + ((bb,resg),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + + (showGhcQual bb) `shouldBe` "unD (B y) = y" + -- (SYB.showData SYB.Renamer 0 bb) `shouldBe` "" + + -- GHC version + -- Free Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst resg)) `shouldBe` + "[(FreeAndDeclared.Declare.B, (18, 14))]" + + -- Declared Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd resg)) `shouldBe` + "[(FreeAndDeclared.Declare.unD, (21, 1))]" + + -- --------------------------------- + + it "finds free and declared in a single bind InfixCon" $ do + t <- ct $ parsedFileGhc "./FreeAndDeclared/Declare.hs" + + let + comp = do + parsed <- getRefactParsed + decls <- liftT $ hsDecls parsed + -- let b = head $ drop 3 $ hsBinds renamed + let b = head $ drop 12 $ decls + rg <- hsFreeAndDeclaredPNs [b] + return (b,rg) + ((bb,resg),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual bb) `shouldBe` "unF (a :| b) = (a, b)" + -- (SYB.showData SYB.Renamer 0 bb) `shouldBe` "" + + -- GHC version + -- Free Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst resg)) `shouldBe` + "[(FreeAndDeclared.Declare.:|, (25, 14))]" + + -- Declared Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd resg)) `shouldBe` + "[(FreeAndDeclared.Declare.unF, (27, 1))]" + + -- --------------------------------- + + it "finds free and declared in a single bind RecCon" $ do + t <- ct $ parsedFileGhc "./FreeAndDeclared/DeclareRec.hs" + + let + comp = do + parsed <- getRefactParsed + decls <- liftT $ hsDecls parsed + -- let b = head $ drop 0 $ hsBinds renamed + let b = head $ drop 2 decls + rg <- hsFreeAndDeclaredPNs [b] + return (b,rg) + ((bb,resg),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + + (showGhcQual bb) `shouldBe` "unR2 (RCon {r1 = a}) = a" + -- (SYB.showData SYB.Renamer 0 bb) `shouldBe` "" + + -- GHC version + -- Free Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst resg)) `shouldBe` + "[(FreeAndDeclared.DeclareRec.RCon, (3, 10))]" + + -- Declared Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd resg)) `shouldBe` + "[(FreeAndDeclared.DeclareRec.unR2, (7, 1))]" + + -- ----------------------------------------------------------------- + + it "hsFreeAndDeclaredPNs simplest" $ do + t <- ct $ parsedFileGhc "./FreeAndDeclared/DeclareS.hs" + let + comp = do + parsed <- getRefactParsed + r <- hsFreeAndDeclaredPNs parsed + return r + ((res),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + -- Free Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst res)) `shouldBe` "[]" + + -- Declared Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd res)) `shouldBe` "[(FreeAndDeclared.DeclareS.c, (6, 1))]" + + -- ----------------------------------------------------------------- + + it "finds free and declared in a single bind #2" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just tup = getName "DupDef.Dd1.ff" renamed + + let + comp = do + parsed <- getRefactParsed + nm <- getRefactNameMap + decls <- liftT $ hsDecls parsed + let [decl] = definingDeclsRdrNames nm [tup] decls False False + r <- hsFreeAndDeclaredPNs [decl] + return (r,decl) + ((res,d),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual d) `shouldBe` "ff y\n = y + zz\n where\n zz = 1" + -- (SYB.showData SYB.Renamer 0 d) `shouldBe` "" + + -- Free Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst res)) `shouldBe` + "[(GHC.Num.+, (-1, -1))]" + + -- Declared Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd res)) `shouldBe` + "[(DupDef.Dd1.ff, (21, 1))]" + + -- ----------------------------------------------------------------- + + it "finds free and declared at the top level 1" $ do + t <- ct $ parsedFileGhc "./LiftToToplevel/WhereIn1.hs" + + let + comp = do + parsed <- getRefactParsed + -- r <- hsFreeAndDeclaredPNs $ hsBinds renamed + r <- hsFreeAndDeclaredPNs parsed + return r + ((res),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + -- Declared Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd res)) `shouldBe` + "[(LiftToToplevel.WhereIn1.sumSquares, (9, 1)),\n "++ + "(LiftToToplevel.WhereIn1.anotherFun, (15, 1))]" + + -- Free Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst res)) `shouldBe` + "[(GHC.Num.+, (-1, -1)), (GHC.Real.^, (-1, -1))]" + + -- ----------------------------------------------------------------- + + it "finds free and declared at the top level 2" $ do + t <- ct $ parsedFileGhc "./Renaming/IdIn3.hs" + + let + comp = do + parsed <- getRefactParsed + r <- hsFreeAndDeclaredPNs parsed + return r + ((res),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + -- Declared Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd res)) `shouldBe` + "[(IdIn3.x, (10, 1)), "++ + "(IdIn3.foo, (12, 1)), "++ + "(IdIn3.bar, (14, 1)),\n "++ + "(IdIn3.main, (18, 1))]" + + -- Free Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst res)) `shouldBe` + "[(GHC.Num.+, (-1, -1))]" + + -- ----------------------------------------------------------------- + + it "finds free and declared in a GRHSs" $ do + t <- ct $ parsedFileGhc "./LiftOneLevel/LetIn2.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just tup = getName "LiftOneLevel.LetIn2.sumSquares" renamed + let + comp = do + nm <- getRefactNameMap + parsed <- getRefactParsed + decls <- liftT $ hsDecls parsed + let [decl] = definingDeclsRdrNames nm [tup] decls False False + +#if __GLASGOW_HASKELL__ <= 710 + let (GHC.L _ (GHC.ValD (GHC.FunBind _ _ (GHC.MG [match] _ _ _) _ _ _))) = decl +#else + let (GHC.L _ (GHC.ValD (GHC.FunBind _ (GHC.MG (GHC.L _ [match]) _ _ _) _ _ _))) = decl +#endif + let (GHC.L _ (GHC.Match _ _pat _ grhss)) = match + + r <- hsFreeAndDeclaredPNs grhss + return r + ((res),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + + -- Declared Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd res)) `shouldBe` + "[]" + + -- Free Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst res)) `shouldBe` + "[(GHC.Real.^, (-1, -1)), (GHC.Num.+, (-1, -1)), (x, (10, 12)),\n (y, (10, 14))]" + + -- ----------------------------------------------------------------- + + it "finds free and declared in a single bind" $ do + pending -- "fix the prior test" + + -- --------------------------------------------------------------------- + + + describe "hsFDsFromInsideRdr" $ do + it "does something useful" $ do + pendingWith "need to convert to using Parsed source" -- "Complete this" + + describe "hsFDsFromInside" $ do + it "does something useful" $ do + pending -- "Complete this" + + describe "hsFDNamesFromInside" $ do + it "does something useful" $ do + pending -- "Complete this" + + -- --------------------------------------------------------------------- + + describe "hsVisibleNames" $ do + it "does something useful" $ do + pending -- "Complete this" + + -- --------------------------------------------------------------------- + + describe "hsVisibleDsRdr" $ do + + -- --------------------------------- + + it "returns [] if e does not occur in t" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just tl1 = locToExp (4,13) (4,40) parsed :: (Maybe (GHC.Located (GHC.HsExpr GHC.RdrName))) + let Just tup = getName "DupDef.Dd1.tup" renamed + let + comp = do + DN r <- hsVisibleDsRdr nm tup tl1 + return r + ((res),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (null res) `shouldBe` True + + -- ----------------------------------------------------------------- + + it "returns visible vars if e does occur in t #1" $ do + pendingWith "no longer relevant?" +{- + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just tl1 = locToExp (28,4) (28,12) parsed :: (Maybe (GHC.LHsExpr GHC.RdrName)) + (showGhcQual tl1) `shouldBe` "ll + z" + + let Just tup = getName "DupDef.Dd1.l" renamed + + let + comp = do + decls <- liftT $ hsDecls parsed + let [decl] = definingDeclsRdrNames nm [tup] decls False False + r <- hsVisibleDsRdr nm (rdrName2NamePure nm tl1) decl + return (r,decl) + ((res,d),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual d) `shouldBe` "l z = let ll = 34 in ll + z" + (showGhcQual res ) `shouldBe` "[z, ll]" + -- (showGhcQual res2 ) `shouldBe` "[z, ll]" +-} + -- ----------------------------------------------------------------- + + it "returns visible vars if e does occur in t #2" $ do + pendingWith "no longer relevant?" + {- + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just tl1 = locToExp (28,4) (28,12) parsed :: (Maybe (GHC.LHsExpr GHC.RdrName)) + (showGhcQual tl1) `shouldBe` "ll + z" + + let Just rhs = locToExp (26,1) (28,12) parsed :: (Maybe (GHC.LHsExpr GHC.RdrName)) + (showGhcQual rhs) `shouldBe` "let ll = 34 in ll + z" + + let + comp = do + r <- hsVisibleDsRdr nm (rdrName2NamePure nm tl1) rhs + return r + ((res),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual res) `shouldBe` "[ll]" +-} + -- --------------------------------- + + it "Rdr:finds function arguments visible in RHS 1" $ do + pendingWith "no longer relevant?" + {- + t <- ct $ parsedFileGhc "./Visible/Simple.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just e = locToExp (5,11) (5,19) parsed :: (Maybe (GHC.LHsExpr GHC.RdrName)) + (showGhcQual e) `shouldBe` "a + b" + + let Just n = getName "Visible.Simple.params" renamed + + let + comp = do + nm <- getRefactNameMap + declsp <- liftT $ hsDecls parsed + let [decl] = definingDeclsRdrNames nm [n] declsp False False + fds' <- hsVisibleDsRdr nm (rdrName2NamePure nm e) decl + return (fds') + -- ((fds),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + ((fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (show fds) `shouldBe` "DN [a, b, GHC.Num.+]" +-} + -- ----------------------------------- + + it "finds function arguments visible in RHS 2" $ do + pendingWith "no longer relevant?" + {- + t <- ct $ parsedFileGhc "./Visible/Simple.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + -- (SYB.showData SYB.Renamer 0 renamed) `shouldBe` "" + + let Just e = locToExp (9,15) (9,17) parsed :: (Maybe (GHC.LHsExpr GHC.RdrName)) + (showGhcQual e) `shouldBe` "x" + + let Just n = getName "Visible.Simple.param2" renamed + + let + comp = do + nm <- getRefactNameMap + declsp <- liftT $ hsDecls parsed + let [decl] = definingDeclsRdrNames nm [n] declsp False False + fds' <- hsVisibleDsRdr nm (rdrName2NamePure nm e) decl + return (fds') + -- ((fds),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + ((fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (show fds) `shouldBe` "DN [x]" +-} + -- ----------------------------------- + + it "finds visible vars inside a function" $ do + t <- ct $ parsedFileGhc "./Renaming/IdIn5.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just rhs = locToExp (14,6) (15,14) parsed :: (Maybe (GHC.LHsExpr GHC.RdrName)) + (showGhcQual rhs) `shouldBe` "x + y + z" + + -- let Just er = getName "IdIn5.x" renamed + let Just e = locToRdrName (14,7) parsed + (showGhcQual e) `shouldBe` "x" + (SYB.showData SYB.Parser 0 e) `shouldBe` "\n(L {Renaming/IdIn5.hs:14:7} \n (Unqual {OccName: x}))" + + let + comp = do + nm <- getRefactNameMap + fds' <- hsVisibleDsRdr nm (rdrName2NamePure nm e) rhs + -- ffds <- hsFreeAndDeclaredGhc rhsr + let ffds = hsFreeAndDeclaredRdr nm rhs + return (fds',ffds) + -- ((fds,_fds),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + ((fds,_fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (show _fds) `shouldBe` "(FN [GHC.Num.+, IdIn5.x, y, z],DN [])" + (show fds) `shouldBe` "DN [GHC.Num.+, IdIn5.x, y, z]" + + -- ----------------------------------- + + it "finds visible vars inside a data declaration" $ do + t <- ct $ parsedFileGhc "./Renaming/D1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just ln = locToRdrName (6, 6) parsed + (showGhcQual ln) `shouldBe` "Tree" + (SYB.showData SYB.Parser 0 ln) `shouldBe` "\n(L {Renaming/D1.hs:6:6-9} \n (Unqual {OccName: Tree}))" + + let + comp = do + -- logDataWithAnns "parsed" parsed + nm <- getRefactNameMap + fds' <- hsVisibleDsRdr nm (rdrName2NamePure nm ln) parsed + -- ffds <- hsFreeAndDeclaredGhc renamed + let ffds = hsFreeAndDeclaredRdr nm parsed + return (fds',ffds) + ((fds,_fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- ((fds,_fds),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + + (show _fds) `shouldBe` "(FN [a, "++ + "GHC.Base.++, "++ + "GHC.Types.Int, "++ + "GHC.Classes.==, "++ + "GHC.Classes./=, "++ + ":,\n "++ + "GHC.Num.+, "++ + "GHC.Real.^, "++ + "[]],"++ + "DN [Renaming.D1.Tree, "++ + "Renaming.D1.Leaf, "++ + "Renaming.D1.Branch,\n "++ + "Renaming.D1.fringe, "++ + "Renaming.D1.SameOrNot, "++ + "Renaming.D1.isSame,\n "++ + "Renaming.D1.isNotSame, "++ + "Renaming.D1.sumSquares])" + + (show fds) `shouldBe` "DN [Renaming.D1.Tree, Renaming.D1.Leaf, Renaming.D1.Branch]" + + -- ----------------------------------- + + it "finds visible vars inIdIn5" $ do + t <- ct $ parsedFileGhc "./Renaming/IdIn5.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just ln = locToRdrName (10, 1) parsed + (showGhcQual ln) `shouldBe` "x" + (SYB.showData SYB.Parser 0 ln) `shouldBe` "\n(L {Renaming/IdIn5.hs:10:1} \n (Unqual {OccName: x}))" + + let + comp = do + logDataWithAnns "parsed" parsed + nm <- getRefactNameMap + fds' <- hsVisibleDsRdr nm (rdrName2NamePure nm ln) parsed + let ffds = hsFreeAndDeclaredRdr nm parsed + return (fds',ffds) + ((fds,_fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- ((fds,_fds),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + + (show _fds) `shouldBe` "(FN [GHC.Num.+],"++ + "DN [IdIn5.x, IdIn5.foo, IdIn5.bar, IdIn5.main])" + + (show fds) `shouldBe` "DN [GHC.Num.+, IdIn5.x, z, y, IdIn5.foo, IdIn5.bar]" + + + -- --------------------------------------------------------------------- + + describe "hsFreeAndDeclaredRdr" $ do + it "finds function arguments visible in RHS fd" $ do + t <- ct $ parsedFileGhc "./Visible/Simple.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just e = locToExp (5,11) (5,19) parsed :: (Maybe (GHC.Located (GHC.HsExpr GHC.RdrName))) + (showGhcQual e) `shouldBe` "a + b" + + let Just n = getName "Visible.Simple.params" renamed + + let + comp = do + decls <- liftT $ hsDecls parsed + let [decl] = definingDeclsRdrNames nm [n] decls False False + let fds' = hsFreeAndDeclaredRdr nm decl + return (fds') + -- ((fds),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + ((fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (show fds) `shouldBe` "(FN [GHC.Num.+],DN [Visible.Simple.params])" + + -- ----------------------------------- + + it "finds function arguments and free vars visible in RHS" $ do + t <- ct $ parsedFileGhc "./Visible/Simple.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just e = locToExp (9,15) (9,17) parsed :: Maybe (GHC.LHsExpr GHC.RdrName) + (showGhcQual e) `shouldBe` "x" + + let Just n = getName "Visible.Simple.param2" renamed + let + comp = do + decls <- liftT $ hsDecls parsed + let [decl] = definingDeclsRdrNames nm [n] decls False False + +#if __GLASGOW_HASKELL__ <= 710 + let (GHC.L _ (GHC.ValD (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _))) = decl +#else + let (GHC.L _ (GHC.ValD (GHC.FunBind _ (GHC.MG (GHC.L _ matches) _ _ _) _ _ _))) = decl +#endif + let [(GHC.L _ (GHC.Match _ pats _ _))] = matches + let lpat = head pats + logDataWithAnns "lpat" lpat + + -- fds' <- hsFreeAndDeclaredGhc $ lpat + let fds' = hsFreeAndDeclaredRdr nm lpat + return (fds') + -- ((fds),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + ((fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (show fds) `shouldBe` "(FN [Visible.Simple.B],DN [x])" + + -- ----------------------------------- + + it "finds imported functions used in the rhs" $ do + t <- ct $ parsedFileGhc "./FreeAndDeclared/Declare.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just n = getName "FreeAndDeclared.Declare.tup" renamed + + let + comp = do + nm <- getRefactNameMap + decls <- liftT $ hsDecls parsed + let [decl] = definingDeclsRdrNames nm [n] decls False False + let fds' = hsFreeAndDeclaredRdr nm decl + return (fds') + ((fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (show fds) `shouldBe` + "(FN [GHC.Base.$, GHC.List.head, GHC.List.zip],"++ + "DN [FreeAndDeclared.Declare.tup, FreeAndDeclared.Declare.h,\n "++ + "FreeAndDeclared.Declare.t])" + + -- ----------------------------------- + + it "finds free vars in HsWithBndrs" $ do + t <- ct $ parsedFileGhc "./FreeAndDeclared/Binders.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just n = getName "FreeAndDeclared.Binders.findNewPName" renamed + let + comp = do + nm <- getRefactNameMap + parsed <- getRefactParsed + -- logDataWithAnns "parsed" parsed + decls <- liftT $ hsDecls parsed + let [decl] = definingDeclsRdrNames nm [n] decls False False +#if __GLASGOW_HASKELL__ <= 710 + let (GHC.L _ (GHC.ValD (GHC.FunBind _ _ (GHC.MG [match] _ _ _) _ _ _))) = decl +#else + let (GHC.L _ (GHC.ValD (GHC.FunBind _ (GHC.MG (GHC.L _ [match]) _ _ _) _ _ _))) = decl +#endif + let (GHC.L _ (GHC.Match _ _pats _rhs binds)) = match + + logDataWithAnns "binds" binds + -- fds' <- hsFreeAndDeclaredGhc $ binds + let fds' = hsFreeAndDeclaredRdr nm binds + return (fds') + -- ((fds),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + ((fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (show fds) `shouldBe` + "(FN [FreeAndDeclared.Binders.gfromJust,\n "++ + "FreeAndDeclared.Binders.somethingStaged,\n "++ + "FreeAndDeclared.Binders.Renamer, "++ + "GHC.Base.Nothing, "++ + "renamed,\n "++ + "FreeAndDeclared.Binders.Name, "++ + "GHC.Classes.==, "++ + "GHC.Base.$,\n "++ + "FreeAndDeclared.Binders.occNameString,\n "++ + "FreeAndDeclared.Binders.getOccName, "++ + "name, "++ + "GHC.Base.Just],"++ + "DN [res, worker])" + + -- ----------------------------------- + + it "finds free vars in TH files" $ do + t <- ct $ parsedFileGhc "./TH/Main.hs" + let + comp = do + parseSourceFileGhc "./TH/Main.hs" + parsed <- getRefactParsed + nm <- getRefactNameMap + let fds' = hsFreeAndDeclaredRdr nm parsed + return (fds') + ((fds),_s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (show fds) `shouldBe` + "(FN [System.IO.putStrLn, pr],"++ + "DN [TH.Main.main, TH.Main.baz, TH.Main.sillyString])" + + -- --------------------------------------------- + + describe "isLocalPN" $ do + it "returns True if the name is local to the module" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + let Just n = locToNameRdrPure nm (17, 5) parsed + (showGhcQual n) `shouldBe` "ff" + isLocalPN n `shouldBe` True + + it "returns False if the name is not local to the module" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + let Just n = locToNameRdrPure nm (21, 1) parsed + (showGhcQual n) `shouldBe` "DupDef.Dd1.ff" + isLocalPN n `shouldBe` False + + -- --------------------------------------------- + + describe "isTopLevelPN" $ do + it "returns False if the name is not defined at the top level of the module" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let + comp = do + parsed <- getRefactParsed + nm <- getRefactNameMap + let Just n = locToNameRdrPure nm (17, 5) parsed + topLevel <- isTopLevelPN n + return (n,topLevel) + ((nf,tl),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + (showGhcQual nf) `shouldBe` "ff" + tl `shouldBe` False + + it "returns True if the name is defined at the top level of the module" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let + comp = do + parsed <- getRefactParsed + nm <- getRefactNameMap + let Just n = locToNameRdrPure nm (21, 1) parsed + topLevel <- isTopLevelPN n + return (n,topLevel) + + ((nf,tl),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + (showGhcQual nf) `shouldBe` "DupDef.Dd1.ff" + tl `shouldBe` True + + -- --------------------------------------------- + + describe "definedPNsRdr" $ do + it "gets the PNs defined in a declaration" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just pn = locToNameRdrPure nm (3, 1) parsed + (showGhcQual pn) `shouldBe` "DupDef.Dd1.toplevel" + + let origDecls = getHsDecls parsed + let demotedDecls'= definingDeclsRdrNames nm [pn] origDecls True False + let declaredPns = nub $ concatMap definedPNsRdr demotedDecls' + + (showGhcQual declaredPns) `shouldBe` "[toplevel]" + + -- --------------------------------- + + it "gets the PNs defined in an as-match" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just pn = locToNameRdrPure nm (14, 1) parsed + (showGhcQual pn) `shouldBe` "DupDef.Dd1.tup" + + let origDecls = getHsDecls parsed + let demotedDecls'= definingDeclsRdrNames nm [pn] origDecls True False + let declaredPns = nub $ concatMap definedPNsRdr demotedDecls' + + (showGhcQual declaredPns) `shouldBe` "[tup, h, t]" + + + -- --------------------------------------------- + + describe "inScopeInfo" $ do + it "returns 4 element tuples for in scope names" $ do + pending -- "is this still needed?" + {- + ((inscopes, _renamed, _parsed), _toks) <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let info = inScopeInfo inscopes + (show $ head info) `shouldBe` "foo" + -- (show $ info) `shouldBe` "foo" + -} + + -- --------------------------------------------- + + describe "isInScopeAndUnqualified" $ do + it "True if the identifier is in scope and unqualified" $ do + pending -- "needed?" + {- + ((inscopes, _renamed, _parsed), _toks) <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let info = inScopeInfo inscopes + (show $ head info) `shouldBe` "foo" + -} +-- inScopeInfo for c is +-- (\"DupDef.Dd1.c\",VarName,DupDef.Dd1,Nothing) + + -- --------------------------------------------- + + describe "isInScopeAndUnqualifiedGhc" $ do + it "True if the identifier is in scope and unqualified" $ do + let + comp = do + parseSourceFileGhc "./DupDef/Dd1.hs" + ctx <- GHC.getContext + res1 <- isInScopeAndUnqualifiedGhc "c" Nothing + res2 <- isInScopeAndUnqualifiedGhc "DupDef.Dd1.c" Nothing + res3 <- isInScopeAndUnqualifiedGhc "nonexistent" Nothing + return (res1,res2,res3,ctx) + ((r1,r2,r3,_c),_s) <- ct $ runRefactGhc comp (initialState { rsModule = Nothing }) testOptions + r1 `shouldBe` True + r2 `shouldBe` True + r3 `shouldBe` False + + -- --------------------------------- + + it "requires qualification on name clash with an import" $ do + t <- ct $ parsedFileGhc "./ScopeAndQual.hs" + let + comp = do + parseSourceFileGhc "./ScopeAndQual.hs" + -- putParsedModule t + renamed <- getRefactRenamed + parsed <- getRefactParsed + nm <- getRefactNameMap + + logm $ "renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++ + + ctx <- GHC.getContext + + let Just sumSquares = locToNameRdrPure nm (13,15) parsed + ssUnqual <- isQualifiedPN sumSquares + names <- GHC.parseName "sum" + names2 <- GHC.parseName "mySumSq" + res1 <- isInScopeAndUnqualifiedGhc "sum" Nothing + res2 <- isInScopeAndUnqualifiedGhc "L.sum" Nothing + return (res1,res2,names,names2,sumSquares,ssUnqual,ctx) + ((r1,r2,ns,ns2,ss,ssu,_c),_s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (prettyprint ss) `shouldBe` "sumSquares" + (showGhcQual ss) `shouldBe` "ScopeAndQual.sumSquares" + (show $ ssu) `shouldBe` "False" + (showGhcQual ns) `shouldBe` "[ScopeAndQual.sum]" + (showGhcQual ns2) `shouldBe` "[ScopeAndQual.mySumSq]" + "1" ++ (show r1) `shouldBe` "1True" + "2" ++ (show r2) `shouldBe` "2True" + + -- --------------------------------------------- + + describe "mkNewGhcName" $ do + it "Creates a new GHC.Name" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let + comp = do + parsed <- getRefactParsed + nm <- getRefactNameMap + let Just topLevel = locToNameRdrPure nm (3,1) parsed + + name1 <- mkNewGhcName Nothing "foo" + name2 <- mkNewGhcName Nothing "bar" + name3 <- mkNewGhcName (Just (GHC.nameModule topLevel)) "baz" + + return (name1,name2,name3) + ((n1,n2,n3),_s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + GHC.getOccString n1 `shouldBe` "foo" + showGhcQual n1 `shouldBe` "foo" + GHC.getOccString n2 `shouldBe` "bar" + showGhcQual n2 `shouldBe` "bar" + (showGhcQual $ GHC.nameModule n3) `shouldBe` "main@main:DupDef.Dd1" + (SYB.showData SYB.Renamer 0 n3) `shouldBe` "{Name: baz}" + GHC.getOccString n3 `shouldBe` "baz" + showGhcQual n3 `shouldBe` "DupDef.Dd1.baz" + (showGhcQual $ GHC.nameUnique n1) `shouldBe` "H2" + (showGhcQual $ GHC.nameUnique n2) `shouldBe` "H3" + (showGhcQual $ GHC.nameUnique n3) `shouldBe` "H4" + + -- --------------------------------------------- + + describe "prettyprint" $ do + it "Prints a GHC.Name ready for parsing into tokens" $ do + -- (_t, _toks, _tgt) <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let + comp = do + name1 <- mkNewGhcName Nothing "foo" + name2 <- mkNewGhcName Nothing "bar" + return (name1,name2) + ((n1,n2),_s) <- ct $ runRefactGhcState comp + GHC.getOccString n1 `shouldBe` "foo" + showGhcQual n1 `shouldBe` "foo" + GHC.getOccString n2 `shouldBe` "bar" + showGhcQual n2 `shouldBe` "bar" + showGhcQual n1 `shouldBe` "foo" + + -- --------------------------------------------- + + describe "duplicateDecl" $ do + it "duplicates a bind only" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (3, 1) parsed + let + comp = do + -- parsed <- getRefactParsed + declsp <- liftT $ hsDecls parsed + newName2 <- mkNewGhcName Nothing "bar2" + newBindings <- duplicateDecl declsp n newName2 + parsed' <- liftT $ replaceDecls parsed newBindings + putRefactParsed parsed' emptyAnns + + return newBindings + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + (showGhcQual n) `shouldBe` "DupDef.Dd1.toplevel" + (sourceFromState s) `shouldBe` "module DupDef.Dd1 where\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nbar2 :: Integer -> Integer\nbar2 x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nff y = y + zz\n where\n zz = 1\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\n" + + -- --------------------------------------------- + + it "duplicates a bind with a signature, and an offset" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just np = locToNameRdrPure nm (14, 1) parsed + (showGhcQual np) `shouldBe` "DupDef.Dd1.tup" + + let Just ln'@(GHC.L l _) = locToRdrName (17, 6) parsed + n = rdrName2NamePure nm ln' + ln = GHC.L l n + (showGhcQual n) `shouldBe` "ff" + let + comp = do + newName2 <- mkNewGhcName Nothing "gg" + + -- parsed <- getRefactParsed + decls <- liftT $ hsDecls parsed + + (front,[parent],back) <- divideDecls decls ln + + (parent',Just (funBinding,declsToDup,declsp')) <- modifyValD (GHC.getLoc parent) parent $ \_m declsp -> do + let + declsToDup = definingDeclsRdrNames nm [n] declsp True True + funBinding = filter isFunOrPatBindP declsToDup --get the fun binding. + + declsp' <- duplicateDecl declsp n newName2 + + return (declsp',Just (funBinding,declsToDup,declsp')) + + parsed' <- liftT $ replaceDecls parsed (front ++ [parent'] ++ back) + putRefactParsed parsed' emptyAnns + + return (funBinding,declsToDup,declsp') + + ((fb,dd,newb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- ((fb,dd,newb),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual n) `shouldBe` "ff" + (showGhcQual dd) `shouldBe` "[ff = 15]" + (showGhcQual fb) `shouldBe` "[ff = 15]" + (show $ getStartEndLoc fb) `shouldBe` "((17,5),(17,12))" + (sourceFromState s) `shouldBe` "module DupDef.Dd1 where\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\n gg :: Int\n gg = 15\n\ndata D = A | B String | C\n\nff y = y + zz\n where\n zz = 1\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\n" + (showGhcQual newb) `shouldBe` "[ff :: Int, ff = 15, gg :: Int, gg = 15]" + (showGhcQual fb) `shouldBe` "[ff = 15]" + + + -- --------------------------------------------- + + describe "addParamsToDecl" $ do + it "adds parameters to a declaration" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (3, 1) parsed + let + comp = do + declsp <- liftT $ hsDecls parsed + let newName2 = mkRdrName "bar2" + declsp' <- addParamsToDecls declsp n [newName2] + parsed' <- liftT $ replaceDecls parsed declsp' + putRefactParsed parsed' emptyAnns + + return declsp' + (nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual n) `shouldBe` "MoveDef.Md1.toplevel" + (sourceFromState s) `shouldBe` "module MoveDef.Md1 where\n\ntoplevel :: Integer -> Integer\ntoplevel bar2 x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nff :: Int -> Int\nff y = y + zz\n where\n zz = 1\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\nzz1 a = 1 + toplevel a\n\n-- General Comment\n-- |haddock comment\ntlFunc :: Integer -> Integer\ntlFunc x = c * x\n-- Comment at end\n\n\n" + (showGhcQual $ head $ tail nb) `shouldBe` "toplevel bar2 x = c * x" + + -- --------------------------------- + + it "adds parameters to a declaration with multiple matches" $ do + t <- ct $ parsedFileGhc "./AddParams1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (3, 1) parsed + let + comp = do + declsp <- liftT $ hsDecls parsed + let newName = mkRdrName "pow" + declsp' <- addParamsToDecls declsp n [newName] + parsed' <- liftT $ replaceDecls parsed declsp' + putRefactParsed parsed' emptyAnns + return declsp' + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual n) `shouldBe` "AddParams1.sq" + (sourceFromState s) `shouldBe` "module AddParams1 where\n\nsq pow 0 = 0\nsq pow z = z^2\n\nfoo = 3\n\n" + + -- --------------------------------- + + it "adds parameters to a declaration with no existing ones" $ do + t <- ct $ parsedFileGhc "./AddParams1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (6, 1) parsed + let + comp = do + declsp <- liftT $ hsDecls parsed + let newName1 = mkRdrName "baz" + let newName2 = mkRdrName "bar" + declsp' <- addParamsToDecls declsp n [newName1,newName2] + parsed' <- liftT $ replaceDecls parsed declsp' + putRefactParsed parsed' emptyAnns + + return declsp' + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual n) `shouldBe` "AddParams1.foo" + (sourceFromState s) `shouldBe` "module AddParams1 where\n\nsq 0 = 0\nsq z = z^2\n\nfoo baz bar = 3\n\n" + + -- --------------------------------------------- + + describe "addActualParamsToRhs" $ do + it "adds a parameter to the rhs of a declaration" $ do + t <- ct $ parsedFileGhc "./LiftToToplevel/D1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (6, 21) parsed + let + comp = do + -- parsed <- getRefactParsed + declsp <- liftT $ hsDecls parsed + let decl = head declsp + let newName2 = mkRdrName "bar2" + newBinding <- addActualParamsToRhs n [newName2] decl + + return (newBinding,decl) + ((nb,decl'),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- ((nb,decl'),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + -- putStrLn $ "nb[]\n" ++ showAnnDataItemFromState s nb ++ "\n]" + (showGhcQual decl') `shouldBe` "sumSquares (x : xs)\n = sq x + sumSquares xs\n where\n sq x = x ^ pow\n pow = 2\nsumSquares [] = 0" + (showGhcQual n) `shouldBe` "sq" + (showGhcQual nb) `shouldBe` "sumSquares (x : xs)\n = (sq bar2) x + sumSquares xs\n where\n sq x = x ^ pow\n pow = 2\nsumSquares [] = 0" + (exactPrintFromState s nb) `shouldBe` "\n\n{-lift 'sq' to top level. This refactoring\n affects module 'D1' and 'C1' -}\n\nsumSquares (x:xs) = (sq bar2) x + sumSquares xs\n where\n sq x = x ^ pow\n pow =2\n\nsumSquares [] = 0" + + -- -------------------- + + it "adds parameters to a complex rhs of a declaration" $ do + t <- ct $ parsedFileGhc "./LiftToToplevel/WhereIn7.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (10, 17) parsed + let + comp = do + -- parsed <- getRefactParsed + declsp <- liftT $ hsDecls parsed + let decl = head declsp + + let newName1 = mkRdrName "x1" + let newName2 = mkRdrName "y1" + let newName3 = mkRdrName "z1" + newBinding <- addActualParamsToRhs n [newName1,newName2,newName3] decl + + return (newBinding,decl) + ((nb,decl'),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + (showGhcQual decl') `shouldBe` "fun x y z\n = inc addthree\n where\n inc a = a + 1\n addthree = x + y + z" + (showGhcQual n) `shouldBe` "addthree" + (showGhcQual nb) `shouldBe` "fun x y z\n = inc (addthree x1 y1 z1)\n where\n inc a = a + 1\n addthree = x + y + z" + (exactPrintFromState s nb) `shouldBe` "\n\n--A definition can be lifted from a where or let to the top level binding group.\n--Lifting a definition widens the scope of the definition.\n\n--In this example, lift 'addthree' defined in 'fun'.\n--This example aims to test adding parenthese.\n\n\nfun x y z =inc (addthree x1 y1 z1)\n where inc a =a +1\n addthree=x+y+z" + + + -- --------------------------------------------- + + describe "rmDecl" $ do + it "removes a top level declaration, leaving type signature 1" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md1a.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + let Just n = locToNameRdrPure nm (6, 1) parsed + let + comp = do + (parsed',_removedDecl,_removedSig) <- rmDecl n False parsed + putRefactParsed parsed' emptyAnns + + return parsed' + -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual n) `shouldBe` "MoveDef.Md1a.ff" + (sourceFromState s) `shouldBe` "module MoveDef.Md1a where\n\ndata D = A | B String | C\n\nff :: Int -> Int\n\nl = 1\n\n" + + -- --------------------------------- + + it "removes a top level declaration, leaving type signature 2b" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md1b.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + let Just n = locToNameRdrPure nm (6, 1) parsed + let + comp = do + (parsed',_removedDecl,_removedSig) <- rmDecl n False parsed + putRefactParsed parsed' emptyAnns + return parsed' + -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual n) `shouldBe` "MoveDef.Md1b.ff" + (sourceFromState s) `shouldBe` "module MoveDef.Md1b where\n\ndata D = A | C\n\nff :: Int -> Int\n\nl z =\n let\n ll = 34\n in ll + z\n\n" + + -- --------------------------------- + + it "removes a top level declaration, leaving type signature 2" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + let Just n = locToNameRdrPure nm (22, 1) parsed + let + comp = do + (parsed',_removedDecl,_removedSig) <- rmDecl n False parsed + putRefactParsed parsed' emptyAnns + logDataWithAnns "parsed'" parsed' + return parsed' + -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual n) `shouldBe` "MoveDef.Md1.ff" + (sourceFromState s) `shouldBe` "module MoveDef.Md1 where\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nff :: Int -> Int\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\nzz1 a = 1 + toplevel a\n\n-- General Comment\n-- |haddock comment\ntlFunc :: Integer -> Integer\ntlFunc x = c * x\n-- Comment at end\n\n\n" + + -- --------------------------------- + + it "removes a top level declaration, and type signature" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (22, 1) parsed + let + comp = do + (newDecls,_removedDecl,_removedSig) <- rmDecl n True parsed + putRefactParsed newDecls emptyAnns + return newDecls + -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual n) `shouldBe` "MoveDef.Md1.ff" + (sourceFromState s) `shouldBe` "module MoveDef.Md1 where\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\nzz1 a = 1 + toplevel a\n\n-- General Comment\n-- |haddock comment\ntlFunc :: Integer -> Integer\ntlFunc x = c * x\n-- Comment at end\n\n\n" + + -- ----------------------------------- + + it "removes the last local decl in a let/in clause" $ do + t <- ct $ parsedFileGhc "./LiftToToplevel/LetIn1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (11, 22) parsed + let + comp = do + -- parsed <- getRefactParsed + (parsed',_removedDecl,_removedSig) <- rmDecl n True parsed + + putRefactParsed parsed' emptyAnns + + return parsed' + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual n) `shouldBe` "sq" + -- (showToks $ take 20 $ toksFromState s) `shouldBe` "" + (sourceFromState s) `shouldBe` "module LiftToToplevel.LetIn1 where\n\n--A definition can be lifted from a where or let to the top level binding group.\n--Lifting a definition widens the scope of the definition.\n\n--In this example, lift 'sq' in 'sumSquares'\n--This example aims to test lifting a definition from a let clause to top level,\n--and the elimination of the keywords 'let' and 'in'\n\nsumSquares x y = sq x + sq y\n where pow=2\n\nanotherFun 0 y = sq y\n where sq x = x^2\n" + + -- ----------------------------------- + + it "removes the last local decl in a where clause" $ do + t <- ct $ parsedFileGhc "./RmDecl3.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (6, 5) parsed + let + comp = do + (parsed',_removedDecl,_removedSig) <- rmDecl n True parsed + + putRefactParsed parsed' emptyAnns + + return parsed' + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual n) `shouldBe` "zz" + (sourceFromState s) `shouldBe` "module RmDecl3 where\n\n-- Remove last declaration from a where clause, where should disappear too\nff y = y + zz\n\n-- EOF\n" + + -- ----------------------------------- + + it "removes the first local decl in a where clause" $ do + t <- ct $ parsedFileGhc "./RmDecl4.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + -- (SYB.showData SYB.Renamer 0 renamed) `shouldBe` "" + + let Just n = locToNameRdrPure nm (7, 5) parsed + let + comp = do + (parsed',_removedDecl,_removedSig) <- rmDecl n True parsed + + putRefactParsed parsed' emptyAnns + + return parsed' + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual n) `shouldBe` "zz" + (sourceFromState s) `shouldBe` "{-# LANGUAGE FlexibleContexts #-}\nmodule RmDecl4 where\n\n-- Remove first declaration from a where clause, rest should still be indented\nff y = y + zz ++ xx\n where\n xx = 2\n\n-- EOF\n" + + -- ----------------------------------- + + it "removes the non last local decl in a let/in clause 1" $ do + t <- ct $ parsedFileGhc "./Demote/LetIn1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + -- (SYB.showData SYB.Renamer 0 renamed) `shouldBe` "" + + let Just n = locToNameRdrPure nm (12, 22) parsed + let + comp = do + (parsed',_removedDecl,_removedSig) <- rmDecl n False parsed + putRefactParsed parsed' emptyAnns + + return parsed' + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual n) `shouldBe` "pow" + (sourceFromState s) `shouldBe` "module Demote.LetIn1 where\n\n--A definition can be demoted to the local 'where' binding of a friend declaration,\n--if it is only used by this friend declaration.\n\n--Demoting a definition narrows down the scope of the definition.\n--In this example, demote the local 'pow' to 'sq'\n--This example also aims to test the demoting a local declaration in 'let'.\n\nsumSquares x y = let sq 0=0\n sq z=z^pow\n in sq x + sq y\n\n\nanotherFun 0 y = sq y\n where sq x = x^2\n\n " + + -- ----------------------------------- + + it "removes the non last local decl in a let/in clause 2" $ do + t <- ct $ parsedFileGhc "./Demote/LetIn2.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (10, 22) parsed + let + comp = do + (parsed',_removedDecl,_removedSig) <- rmDecl n False parsed + putRefactParsed parsed' emptyAnns + + return parsed' + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual n) `shouldBe` "sq" + (sourceFromState s) `shouldBe` "module Demote.LetIn2 where\n\n--A definition can be demoted to the local 'where' binding of a friend declaration,\n--if it is only used by this friend declaration.\n\n--Demoting a definition narrows down the scope of the definition.\n--In this example, demote the local 'pow' will fail.\n\nsumSquares x y = let pow=2\n in sq x + sq y +pow\n\n\nanotherFun 0 y = sq y\n where sq x = x^2\n\n " + + -- ----------------------------------------------------------------- + + it "removes a decl with a trailing comment" $ do + t <- ct $ parsedFileGhc "./Demote/WhereIn3.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + let Just n = locToNameRdrPure nm (14, 1) parsed + let + comp = do + (parsed',_removedDecl,_removedSig1) <- rmDecl n False parsed + putRefactParsed parsed' emptyAnns + + return parsed' + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + (showGhcQual n) `shouldBe` "Demote.WhereIn3.sq" + (sourceFromState s) `shouldBe` "module Demote.WhereIn3 where\n\n--A definition can be demoted to the local 'where' binding of a friend declaration,\n--if it is only used by this friend declaration.\n\n--Demoting a definition narrows down the scope of the definition.\n--In this example, demote the top level 'sq' to 'sumSquares'\n--In this case (there are multi matches), the parameters are not folded after demoting.\n\nsumSquares x y = sq p x + sq p y\n where p=2 {-There is a comment-}\n\nsq :: Int -> Int -> Int\n\n{- foo bar -}\nanotherFun 0 y = sq y\n where sq x = x^2\n" + + + -- ----------------------------------------------------------------- + + it "removes a sub decl liftOneLevel D1" $ do + t <- ct $ parsedFileGhc "./LiftOneLevel/D1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + let Just n = locToNameRdrPure nm (8, 6) parsed + let + comp = do + (parsed',_removedDecl,_removedSig1) <- rmDecl n False parsed + putRefactParsed parsed' emptyAnns + + return parsed' + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + (showGhcQual n) `shouldBe` "sq" + (sourceFromState s) `shouldBe` "module LiftOneLevel.D1 where\n\n{-lift 'sq' to top level. This refactoring\naffects module 'D1' and 'C1' -}\n\nsumSquares (x:xs) = sq x + sumSquares xs\n where\n pow =2\n\nsumSquares [] = 0\n\nmain = sumSquares [1..4]\n" + + + -- --------------------------------------------- + + describe "rmTypeSig" $ do + it "removes a type signature from the top level 1" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + let Just n = locToNameRdrPure nm (22, 1) parsed + let + comp = do + (renamed',sigRemoved) <- rmTypeSig n parsed + putRefactParsed renamed' emptyAnns + return (renamed',sigRemoved) + ((_nb,os),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- ((_nb,os),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual n) `shouldBe` "MoveDef.Md1.ff" + (sourceFromState s) `shouldBe` "module MoveDef.Md1 where\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nff y = y + zz\n where\n zz = 1\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\nzz1 a = 1 + toplevel a\n\n-- General Comment\n-- |haddock comment\ntlFunc :: Integer -> Integer\ntlFunc x = c * x\n-- Comment at end\n\n\n" + (showGhcQual os) `shouldBe` "Just ff :: Int -> Int" + + -- ----------------------------------------------------------------- + + it "removes a type signature from the top level, after decl removed" $ do + t <- ct $ parsedFileGhc "./Demote/WhereIn3.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + let Just n = locToNameRdrPure nm (14, 1) parsed + let + comp = do + (parsed',_removedDecl,_removedSig1) <- rmDecl n False parsed + (parsed2,_removedSig2) <- rmTypeSig n parsed' + putRefactParsed parsed2 emptyAnns + + return parsed2 + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + (showGhcQual n) `shouldBe` "Demote.WhereIn3.sq" + (sourceFromState s) `shouldBe` "module Demote.WhereIn3 where\n\n--A definition can be demoted to the local 'where' binding of a friend declaration,\n--if it is only used by this friend declaration.\n\n--Demoting a definition narrows down the scope of the definition.\n--In this example, demote the top level 'sq' to 'sumSquares'\n--In this case (there are multi matches), the parameters are not folded after demoting.\n\nsumSquares x y = sq p x + sq p y\n where p=2 {-There is a comment-}\n\n{- foo bar -}\nanotherFun 0 y = sq y\n where sq x = x^2\n" + + + -- ----------------------------------------------------------------- + + it "removes a type signature from non-top level" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + let Just n = locToNameRdrPure nm (16, 5) parsed + let + comp = do + (renamed',_removedSig) <- rmTypeSig n parsed + putRefactParsed renamed' emptyAnns + return renamed' + -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual n) `shouldBe` "ff" + -- (showToks $ take 20 $ toksFromState s) `shouldBe` "" + (sourceFromState s) `shouldBe` "module MoveDef.Md1 where\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff = 15\n\ndata D = A | B String | C\n\nff :: Int -> Int\nff y = y + zz\n where\n zz = 1\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\nzz1 a = 1 + toplevel a\n\n-- General Comment\n-- |haddock comment\ntlFunc :: Integer -> Integer\ntlFunc x = c * x\n-- Comment at end\n\n\n" + + -- ----------------------------------------------------------------- + + it "removes a type signature within multi signatures 1" $ do + t <- ct $ parsedFileGhc "./TypeUtils/TypeSigs.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + let Just b = locToNameRdrPure nm (12, 1) parsed + let + comp = do + (renamed',removedSig) <- rmTypeSig b parsed + putRefactParsed renamed' emptyAnns + return (renamed',removedSig) + ((_nb,os),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + (exactPrintFromState s (fromJust os)) `shouldBe` "\n\nb::Int->Integer->Char" + (showGhcQual b) `shouldBe` "TypeSigs.b" + (sourceFromState s) `shouldBe` "module TypeSigs where\n\nsq,anotherFun :: Int -> Int\nsq 0 = 0\nsq z = z^2\n\nanotherFun x = x^2\n\na,c::Int->Integer->Char\n\na x y = undefined\nb x y = undefined\nc x y = undefined\n\n" + + -- ----------------------------------------------------------------- + + it "removes a type signature within multi signatures 2" $ do + t <- ct $ parsedFileGhc "./TypeUtils/TypeSigs.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + let Just n = locToNameRdrPure nm (4, 1) parsed + let + comp = do + (renamed',removedSig) <- rmTypeSig n parsed + putRefactParsed renamed' emptyAnns + return (renamed',removedSig) + -- ((_nb,os),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + ((_nb,os),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- putStrLn $ "anntree\n" ++ showAnnDataFromState s + (exactPrintFromState s (fromJust os)) `shouldBe` "\n\nsq :: Int -> Int" + (showGhcQual n) `shouldBe` "TypeSigs.sq" + (sourceFromState s) `shouldBe` "module TypeSigs where\n\nanotherFun :: Int -> Int\nsq 0 = 0\nsq z = z^2\n\nanotherFun x = x^2\n\na,b,c::Int->Integer->Char\n\na x y = undefined\nb x y = undefined\nc x y = undefined\n\n" + (showGhcQual os) `shouldBe` "Just sq :: Int -> Int" + + -- ----------------------------------------------------------------- + + it "removes a type signature within multi signatures 3" $ do + t <- ct $ parsedFileGhc "./Demote/WhereIn7.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + let Just n = locToNameRdrPure nm (12, 1) parsed + let + comp = do + (parsed',removedSig) <- rmTypeSig n parsed + putRefactParsed parsed' emptyAnns + return (parsed',removedSig) + -- ((_nb,os),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + ((_nb,os),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + (showGhcQual n) `shouldBe` "WhereIn7.sq" + (exactPrintFromState s (fromJust os)) `shouldBe` "\n\nsq :: Int -> Int" + (sourceFromState s) `shouldBe` "module WhereIn7 where\n\n--A definition can be demoted to the local 'where' binding of a friend declaration,\n--if it is only used by this friend declaration.\n\n--Demoting a definition narrows down the scope of the definition.\n--In this example, demote the top level 'sq' to 'sumSquares'\n--This example also aims to test the split of type signature.\n\nsumSquares x y = sq x + sq y\n\nanotherFun :: Int -> Int\nsq 0 = 0\nsq z = z^pow\n where pow=2\n\nanotherFun x = x^2\n " + (showGhcQual os) `shouldBe` "Just sq :: Int -> Int" + + -- ----------------------------------------------------------------- +{- + it "removes a type signature for a pattern in a bind" $ do + t <- ct $ parsedFileGhc "./LiftToToplevel/PatBindIn1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let Just (GHC.L _ n) = locToName (GHC.mkFastString "./test/testdata/LiftToToplevel/PatBindIn1.hs") (18, 7) renamed + let + comp = do + (renamed',removedSig) <- rmTypeSig n renamed + let (Just (GHC.L ss _)) = removedSig + oldSigToks <- getToksForSpan ss + return (renamed',removedSig,oldSigToks) + -- ((nb,os,ot),s) <- runRefactGhc comp $ initialState { rsModule = initRefactModule [] t } + ((nb,os,ot),s) <- runRefactGhc comp $ initialLogOnState { rsModule = initRefactModule [] t } + (showGhcQual n) `shouldBe` "tup" + -- (showToks $ take 20 $ toksFromState s) `shouldBe` "" + (sourceFromState s) `shouldBe` "module LiftToToplevel.PatBindIn1 where\n\n --A definition can be lifted from a where or let into the surrounding binding group.\n --Lifting a definition widens the scope of the definition.\n\n --In this example, lift 'tup' defined in 'foo'\n --This example aims to test renaming and the lifting of type signatures.\n\n main :: Int\n main = foo 3\n\n foo :: Int -> Int\n foo x = h + t + (snd tup)\n where\n \n \n\n tup@(h,t) = head $ zip [1..10] [3..15]\n " + (showGhcQual nb) `shouldBe` "" + (showGhcQual os) `shouldBe` "" + (GHC.showRichTokenStream ot) `shouldBe` "" +-} + -- --------------------------------------------- + + describe "addDecl" $ do + it "adds a top level declaration without a type signature, in default pos" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" + let + comp = do + parsed <- getRefactParsed + (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "a" "nn = n2") + -- let declAnns' = setPrecedingLines declAnns newDecl 2 + parsed' <- addDecl parsed Nothing ([decl],Just declAnns) + putRefactParsed parsed' emptyAnns + return parsed' + (nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- (nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + + (sourceFromState s) `shouldBe` "module MoveDef.Md1 where\n\nnn = n2\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nff :: Int -> Int\nff y = y + zz\n where\n zz = 1\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\nzz1 a = 1 + toplevel a\n\n-- General Comment\n-- |haddock comment\ntlFunc :: Integer -> Integer\ntlFunc x = c * x\n-- Comment at end\n\n\n" + (unspace $ showGhcQual nb) `shouldBe` unspace "module MoveDef.Md1 where\nnn = n2\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\nc, d :: Integer\nc = 7\nd = 9\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h, t)\n = head $ zip [1 .. 10] [3 .. ff]\n where\n ff :: Int\n ff = 15\ndata D = A | B String | C\nff :: Int -> Int\nff y\n = y + zz\n where\n zz = 1\nl z = let ll = 34 in ll + z\ndd q\n = do { let ss = 5;\n return (ss + q) }\nzz1 a = 1 + toplevel a\ntlFunc :: Integer -> Integer\ntlFunc x = c * x" + + -- ------------------------------------------- + + it "adds a top level declaration with a type signature 1" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" + let + comp = do + parsed <- getRefactParsed + (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "decl" "nn = 2") + (sig, sigAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "sig" "nn :: Int") + parsed' <- addDecl parsed Nothing ([sig,decl],Just $ mergeAnns sigAnns declAnns) + putRefactParsed parsed' emptyAnns + return (sig,parsed') + ((_hs,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + (sourceFromState s) `shouldBe` "module MoveDef.Md1 where\n\nnn :: Int\nnn = 2\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nff :: Int -> Int\nff y = y + zz\n where\n zz = 1\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\nzz1 a = 1 + toplevel a\n\n-- General Comment\n-- |haddock comment\ntlFunc :: Integer -> Integer\ntlFunc x = c * x\n-- Comment at end\n\n\n" + (unspace $ showGhcQual nb) `shouldBe` unspace "module MoveDef.Md1 where\nnn :: Int\nnn = 2\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\nc, d :: Integer\nc = 7\nd = 9\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h, t)\n = head $ zip [1 .. 10] [3 .. ff]\n where\n ff :: Int\n ff = 15\ndata D = A | B String | C\nff :: Int -> Int\nff y\n = y + zz\n where\n zz = 1\nl z = let ll = 34 in ll + z\ndd q\n = do { let ss = 5;\n return (ss + q) }\nzz1 a = 1 + toplevel a\ntlFunc :: Integer -> Integer\ntlFunc x = c * x" + + -- ------------------------------------------- + + it "adds a top level declaration after a specified one 1" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" + let + comp = do + parsed <- getRefactParsed + (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "a" "nn = nn2") + nm <- getRefactNameMap + let Just n = locToNameRdrPure nm (21, 1) parsed + parsed' <- addDecl parsed (Just n) ([decl],Just declAnns) + putRefactParsed parsed' emptyAnns + return (n,parsed') + ((n,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- ((n,nb),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + (showGhcQual n) `shouldBe` "MoveDef.Md1.ff" + (sourceFromState s) `shouldBe` "module MoveDef.Md1 where\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nff :: Int -> Int\nff y = y + zz\n where\n zz = 1\n\nnn = nn2\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\nzz1 a = 1 + toplevel a\n\n-- General Comment\n-- |haddock comment\ntlFunc :: Integer -> Integer\ntlFunc x = c * x\n-- Comment at end\n\n\n" + (unspace $ showGhcQual nb) `shouldBe` unspace "module MoveDef.Md1 where\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\nc, d :: Integer\nc = 7\nd = 9\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h, t)\n = head $ zip [1 .. 10] [3 .. ff]\n where\n ff :: Int\n ff = 15\ndata D = A | B String | C\nff :: Int -> Int\nff y\n = y + zz\n where\n zz = 1\nnn = nn2\nl z = let ll = 34 in ll + z\ndd q\n = do { let ss = 5;\n return (ss + q) }\nzz1 a = 1 + toplevel a\ntlFunc :: Integer -> Integer\ntlFunc x = c * x" + + + -- ------------------------------------------- + + it "adds a top level declaration after a specified one 2" $ do + t <- ct $ parsedFileGhc "./AddOneParameter/FunIn1.hs" + let + comp = do + parsed <- getRefactParsed + (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "a" "nn = nn2") + nm <- getRefactNameMap + let Just n = locToNameRdrPure nm (7, 1) parsed + parsed' <- addDecl parsed (Just n) ([decl],Just declAnns) + putRefactParsed parsed' emptyAnns + return (n,parsed') + ((n,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- ((n,nb),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + (showGhcQual n) `shouldBe` "FunIn1.foo" + -- putStrLn (sourceFromState s) + (sourceFromState s) `shouldBe` "module FunIn1 where\n\n--Default parameters can be added to definition of functions and simple constants.\n\n--In this example: add parameter 'y' to 'foo'\nfoo :: Int -> Int\nfoo x= h + t where (h,t) = head $ zip [1..x] [3..15] {-There\nis a comment-}\n\nnn = nn2\n\nmain :: Int\nmain = foo 4\n" + (unspace $ showGhcQual nb) `shouldBe` unspace "module FunIn1 where\nfoo :: Int -> Int\nfoo x\n = h + t\n where\n (h, t) = head $ zip [1 .. x] [3 .. 15]\nnn = nn2\nmain :: Int\nmain = foo 4" + + + -- ------------------------------------------- + + it "adds a top level declaration with a type signature after a specified one" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" + let + comp = do + parsed <- getRefactParsed + nm <- getRefactNameMap + let Just n = locToNameRdrPure nm (21, 1) parsed + (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "decl" "nn = nn2") + (sig, sigAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "sig" "nn :: Int") + parsed' <- addDecl parsed (Just n) ([sig,decl],Just $ mergeAnns sigAnns declAnns) + putRefactParsed parsed' emptyAnns + return (n,parsed') + ((nn,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + (showGhcQual nn) `shouldBe` "MoveDef.Md1.ff" + (sourceFromState s) `shouldBe`"module MoveDef.Md1 where\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nff :: Int -> Int\nff y = y + zz\n where\n zz = 1\n\nnn :: Int\nnn = nn2\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\nzz1 a = 1 + toplevel a\n\n-- General Comment\n-- |haddock comment\ntlFunc :: Integer -> Integer\ntlFunc x = c * x\n-- Comment at end\n\n\n" + (unspace $ showGhcQual nb) `shouldBe` unspace "module MoveDef.Md1 where\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\nc, d :: Integer\nc = 7\nd = 9\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h, t)\n = head $ zip [1 .. 10] [3 .. ff]\n where\n ff :: Int\n ff = 15\ndata D = A | B String | C\nff :: Int -> Int\nff y\n = y + zz\n where\n zz = 1\nnn :: Int\nnn = nn2\nl z = let ll = 34 in ll + z\ndd q\n = do { let ss = 5;\n return (ss + q) }\nzz1 a = 1 + toplevel a\ntlFunc :: Integer -> Integer\ntlFunc x = c * x" + + + -- ------------------------------------------- + + it "adds a local declaration without a type signature 1" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" + + let + comp = do + parsed <- getRefactParsed + nm <- getRefactNameMap + + let Just tl = locToNameRdrPure nm (4, 1) parsed + decls <- liftT (hsDecls parsed) + let + [tlDecl] = definingDeclsRdrNames nm [tl] decls True False + + (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "decl" "nn = nn2") + + newDecl <- addDecl tlDecl Nothing ([decl],Just declAnns) + + logm $ "test:addDecl done" + + return (tlDecl,newDecl) + -- ((tl,nb),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + ((tl,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + (showGhcQual tl) `shouldBe` "toplevel x = c * x" + (exactPrintFromState s nb) `shouldBe` "\ntoplevel x = c * x\n where\n nn = nn2" + (showGhcQual nb) `shouldBe` "toplevel x\n = c * x\n where\n nn = nn2" + + -- ------------------------------------------- + + it "adds a local declaration with a type signature 1" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" + let + comp = do + parsed <- getRefactParsed + nm <- getRefactNameMap + + let Just tl = locToNameRdrPure nm (4, 1) parsed + decls <- liftT (hsDecls parsed) + let + [tlDecl] = definingDeclsRdrNames nm [tl] decls True False + + (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "decl" "nn = nn2") + (sig, sigAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "sig" "nn :: Int") + + newDecl <- addDecl tlDecl Nothing ([sig,decl],Just $ mergeAnns sigAnns declAnns) + + return (tlDecl,newDecl) + ((tl,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- ((tl,nb),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + (showGhcQual tl) `shouldBe` "toplevel x = c * x" + -- putStrLn (showAnnDataItemFromState s nb) + (exactPrintFromState s nb) `shouldBe` "\ntoplevel x = c * x\n where\n nn :: Int\n nn = nn2" + (showGhcQual nb) `shouldBe` "toplevel x\n = c * x\n where\n nn = nn2\n nn :: Int" + -- ------------------------------------------- + + it "adds a local declaration with a where clause" $ do + t <- ct $ parsedFileGhc "./MoveDef/Demote.hs" + let + comp = do + + parsed <- getRefactParsed + nm <- getRefactNameMap + + let Just tl = locToNameRdrPure nm (4, 1) parsed + decls <- liftT (hsDecls parsed) + let + [tlDecl] = definingDeclsRdrNames nm [tl] decls True False + + (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "decl" "nn = nn2") + + newDecl <- addDecl tlDecl Nothing ([decl],Just declAnns) + + return (tlDecl,newDecl) + ((tl,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + (showGhcQual tl) `shouldBe` "toplevel x = c * x" + (exactPrintFromState s nb) `shouldBe` "\ntoplevel x = c * x\n where\n nn = nn2" + (showGhcQual nb) `shouldBe` "toplevel x\n = c * x\n where\n nn = nn2" + + -- ------------------------------------------- + + it "adds a local declaration to an existing one" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md2.hs" + let + comp = do + + parsed <- getRefactParsed + nm <- getRefactNameMap + + let Just tl = locToNameRdrPure nm (4, 1) parsed + decls <- liftT (hsDecls parsed) + let + [tlDecl] = definingDeclsRdrNames nm [tl] decls True False + + (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "decl" "nn = nn2") + + newDecl <- addDecl tlDecl Nothing ([decl],Just declAnns) + + return (tlDecl,newDecl) + ((tl,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- ((tl,nb),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + (showGhcQual tl) `shouldBe` "toplevel x\n = c * x * b\n where\n b = 3" + (exactPrintFromState s nb) `shouldBe` "\ntoplevel x = c * x * b\n where\n nn = nn2\n\n b = 3" + (showGhcQual nb) `shouldBe` "toplevel x\n = c * x * b\n where\n b = 3\n nn = nn2" + + -- ------------------------------------------- + + it "adds a local declaration with a type signature to an existing one" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md2.hs" + let + comp = do + + parsed <- getRefactParsed + nm <- getRefactNameMap + + let Just tl = locToNameRdrPure nm (4, 1) parsed + decls <- liftT (hsDecls parsed) + let + [tlDecl] = definingDeclsRdrNames nm [tl] decls True False + + (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "decl" "nn = nn2") + (sig, sigAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "sig" "nn :: Int") + + newDecl <- addDecl tlDecl Nothing ([sig,decl],Just $ mergeAnns sigAnns declAnns) + + return (tlDecl,newDecl) + ((tl,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + (showGhcQual tl) `shouldBe` "toplevel x\n = c * x * b\n where\n b = 3" + (exactPrintFromState s nb) `shouldBe` "\ntoplevel x = c * x * b\n where\n nn :: Int\n nn = nn2\n\n b = 3" + (showGhcQual nb) `shouldBe` "toplevel x\n = c * x * b\n where\n b = 3\n nn = nn2\n nn :: Int" + + -- ------------------------------------------- + + it "adds a local decl with type signature to an existing one, with a comment" $ do + t <- ct $ parsedFileGhc "./Demote/WhereIn3.hs" + let + comp = do + parsed <- getRefactParsed + nm <- getRefactNameMap + + let Just tl = locToNameRdrPure nm (10, 1) parsed + decls <- liftT (hsDecls parsed) + let [tlDecl] = definingDeclsRdrNames nm [tl] decls True False + + let Just sq = locToNameRdrPure nm (14, 1) parsed + let Just af = locToNameRdrPure nm (18, 1) parsed + + let [sqSig] = definingSigsRdrNames nm [sq] parsed + [sqDecl] = definingDeclsRdrNames nm [sq] decls False False + [afDecl] = definingDeclsRdrNames nm [af] decls False False + + let sqSigDecl = wrapSig sqSig + liftT (balanceComments tlDecl sqSigDecl) + liftT (balanceComments sqDecl afDecl) + + newDecl <- addDecl tlDecl Nothing ([sqSigDecl,sqDecl],Nothing) + + return (sqSig,sqDecl,tlDecl,afDecl,newDecl) + -- ((sigs,_sd,tl,aa,nb),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + ((sigs,_sd,tl,aa,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + (showGhcQual sigs) `shouldBe` "sq :: Int -> Int -> Int" + (showGhcQual tl) `shouldBe` "sumSquares x y\n = sq p x + sq p y\n where\n p = 2" + (showGhcQual aa) `shouldBe` "anotherFun 0 y\n = sq y\n where\n sq x = x ^ 2" + (exactPrintFromState s nb) `shouldBe` "\n\n--A definition can be demoted to the local 'where' binding of a friend declaration,\n--if it is only used by this friend declaration.\n\n--Demoting a definition narrows down the scope of the definition.\n--In this example, demote the top level 'sq' to 'sumSquares'\n--In this case (there are multi matches), the parameters are not folded after demoting.\n\nsumSquares x y = sq p x + sq p y\n where sq :: Int -> Int -> Int\n sq pow 0 = 0\n sq pow z = z^pow --there is a comment\n\n p=2 {-There is a comment-}" + (showGhcQual nb) `shouldBe` "sumSquares x y\n = sq p x + sq p y\n where\n p = 2\n sq :: Int -> Int -> Int\n sq pow 0 = 0\n sq pow z = z ^ pow" + + -- ------------------------------------------- + + it "does not add a local decl to a FunBind with multiple matches" $ do + t <- ct $ parsedFileGhc "./MoveDef/MultiFunBind1.hs" + let + comp = do + parsed <- getRefactParsed + nm <- getRefactNameMap + + let Just tl = locToNameRdrPure nm (3, 1) parsed + decls <- liftT (hsDecls parsed) + let -- decls = hsBinds parsed + [tlDecl] = definingDeclsRdrNames nm [tl] decls True False + + let Just y = locToNameRdrPure nm (6, 1) parsed + + let [yDecl] = definingDeclsRdrNames nm [y] decls False False + + newDecl <- addDecl tlDecl Nothing ([yDecl],Nothing) + + return (yDecl,tlDecl,newDecl) + Just r <- catchException $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + (isPrefixOf "addDecl:Cannot add a local decl to a FunBind with multiple matches" r) `shouldBe` True + + -- ------------------------------------------- + + it "adds a local declaration to a PatBind" $ do + t <- ct $ parsedFileGhc "./MoveDef/PatBind1.hs" + let + comp = do + + parsed <- getRefactParsed + nm <- getRefactNameMap + + let Just tl = locToNameRdrPure nm (3, 1) parsed + decls <- liftT (hsDecls parsed) + let + [tlDecl] = definingDeclsRdrNames nm [tl] decls True False + + (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "decl" "nn = nn2") + + newDecl <- addDecl tlDecl Nothing ([decl],Just declAnns) + + return (tlDecl,newDecl) + ((tl,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- ((tl,nb),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + (showGhcQual tl) `shouldBe` "tup@(h, t) = (x, 1)" + (exactPrintFromState s nb) `shouldBe` "\n\ntup@(h,t) = (x,1)\n where\n nn = nn2" + (showGhcQual nb) `shouldBe` "tup@(h, t)\n = (x, 1)\n where\n nn = nn2" + + -- --------------------------------------------- + + describe "renamePN" $ do + it "replaces a Name with another 1" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let + comp = do + parsed <- getRefactParsed + nm <- getRefactNameMap + let Just n' = locToNameRdrPure nm (3, 1) parsed + newName <- mkNewGhcName Nothing "bar2" + new <- renamePN n' newName PreserveQualify parsed + putRefactParsed new emptyAnns + return (new,newName,n') + let + + ((nb,nn,n),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + (showGhcQual (n,nn)) `shouldBe` "(DupDef.Dd1.toplevel, bar2)" + (sourceFromState s) `shouldBe` "module DupDef.Dd1 where\n\nbar2 :: Integer -> Integer\nbar2 x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nff y = y + zz\n where\n zz = 1\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\n" + (showGhcQual nb) `shouldBe` "module DupDef.Dd1 where\nbar2 :: Integer -> Integer\nbar2 x = c * x\nc, d :: Integer\nc = 7\nd = 9\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h, t)\n = head $ zip [1 .. 10] [3 .. ff]\n where\n ff :: Int\n ff = 15\ndata D = A | B String | C\nff y\n = y + zz\n where\n zz = 1\nl z = let ll = 34 in ll + z\ndd q\n = do { let ss = 5;\n return (ss + q) }" + + -- ----------------------------------------------------------------- + + it "replaces a Name with another 2" $ do + t <- ct $ parsedFileGhc "./Demote/WhereIn4.hs" + + let + comp = do + parsed <- getRefactParsed + nm <- getRefactNameMap + declsr <- liftT $ hsDecls parsed + let decl = head $ drop 0 declsr + let Just n' = locToNameRdrPure nm (11, 21) parsed + newName <- mkNewGhcName Nothing "p_1" + new <- renamePN n' newName PreserveQualify decl + parsed' <- liftT $ replaceDecls parsed (new:tail declsr) + putRefactParsed parsed' emptyAnns + return (new,newName,decl,n') + let + ((nb,nn,d,n),s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + (showGhcQual d) `shouldBe` "sumSquares x y\n = sq p x + sq p y\n where\n p = 2" + (showGhcQual (n,nn)) `shouldBe` "(p, p_1)" + (sourceFromState s) `shouldBe` "module Demote.WhereIn4 where\n\n--A definition can be demoted to the local 'where' binding of a friend declaration,\n--if it is only used by this friend declaration.\n\n--Demoting a definition narrows down the scope of the definition.\n--In this example, demote the top level 'sq' to 'sumSquares'\n--In this case (there is single matches), if possible,\n--the parameters will be folded after demoting and type sigature will be removed.\n\nsumSquares x y = sq p_1 x + sq p_1 y\n where p_1=2 {-There is a comment-}\n\nsq::Int->Int->Int\nsq pow z = z^pow --there is a comment\n\nanotherFun 0 y = sq y\n where sq x = x^2\n\n" + (showGhcQual nb) `shouldBe` "sumSquares x y\n = sq p_1 x + sq p_1 y\n where\n p_1 = 2" + + + -- --------------------------------- + + it "replaces a Name with another in limited scope 1" $ do + t <- ct $ parsedFileGhc "./TokenTest.hs" + + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + let Just n = locToNameRdrPure nm (19, 1) parsed + (showGhcQual n) `shouldBe` "TokenTest.foo" + + let + comp = do + -- parsed <- getRefactParsed + decls <- liftT $ hsDecls parsed + newName <- mkNewGhcName Nothing "bar2" + new <- renamePN n newName PreserveQualify (head $ drop 3 decls) + parsed' <- liftT $ replaceDecls parsed (take 3 decls ++ [new] ++ drop 4 decls) + putRefactParsed parsed' emptyAnns + return (new,newName) + let + + ((nb,nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- ((nb,nn),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + (showGhcQual (n,nn)) `shouldBe` "(TokenTest.foo, bar2)" + (sourceFromState s) `shouldBe` "module TokenTest where\n\n-- Test new style token manager\n\nbob a b = x\n where x = 3\n\nbib a b = x\n where\n x = 3\n\n\nbab a b =\n let bar = 3\n in b + bar -- ^trailing comment\n\n\n-- leading comment\nbar2 x y =\n do c <- getChar\n return c\n\n\n\n\n" + (showGhcQual nb) `shouldBe` "bar2 x y\n = do { c <- getChar;\n return c }" + -- (showToks $ take 20 $ toksFromState s) `shouldBe` "" + + -- --------------------------------- + + it "replace a Name with another in limited scope 2" $ do + t <- ct $ parsedFileGhc "./TokenTest.hs" + + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + let Just n = locToNameRdrPure nm (19, 1) parsed + (showGhcQual n) `shouldBe` "TokenTest.foo" + + let + comp = do + -- parsed <- getRefactParsed + decls <- liftT $ hsDecls parsed + let decl = head $ drop 3 decls + newName <- mkNewGhcName Nothing "bar2" + new <- renamePN n newName PreserveQualify decl + + parsed' <- liftT $ replaceDecls parsed (take 3 decls ++ [new] ++ drop 4 decls) + putRefactParsed parsed' emptyAnns + + return (new,newName) + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual n) `shouldBe` "TokenTest.foo" + (sourceFromState s) `shouldBe` "module TokenTest where\n\n-- Test new style token manager\n\nbob a b = x\n where x = 3\n\nbib a b = x\n where\n x = 3\n\n\nbab a b =\n let bar = 3\n in b + bar -- ^trailing comment\n\n\n-- leading comment\nbar2 x y =\n do c <- getChar\n return c\n\n\n\n\n" + (showGhcQual nb) `shouldBe` "bar2 x y\n = do { c <- getChar;\n return c }" + -- (showToks $ take 20 $ toksFromState s) `shouldBe` "" + + ------------------------------------ + + it "replaces a name in a data declaration too" $ do + t <- ct $ parsedFileGhc "./Renaming/Field1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (5, 19) parsed + let + comp = do + logParsedSource "parsed" + logm $ "nm:" ++ showNameMap nm + logm $ "n:nameUnique:" ++ show (GHC.nameUnique n) + newName <- mkNewGhcName Nothing "pointx1" + new <- renamePN n newName PreserveQualify parsed + + putRefactParsed new emptyAnns + logParsedSource "parsed:after" + return (new,newName) + let + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- ((nb,_nn),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual n) `shouldBe` "Field1.pointx" + (sourceFromState s) `shouldBe` "module Field1 where\n\n--Rename field name 'pointx' to 'pointx1'\n\ndata Point = Pt {pointx1, pointy :: Float}\n\nabsPoint :: Point -> Float\nabsPoint p = sqrt (pointx1 p * pointx1 p +\n pointy p * pointy p)\n\n" + (unspace $ showGhcQual nb) `shouldBe` "module Field1 where\ndata Point = Pt {pointx1, pointy :: Float}\nabsPoint :: Point -> Float\nabsPoint p = sqrt (pointx1 p * pointx1 p + pointy p * pointy p)" + + + ------------------------------------ + + it "replaces a name in a type signature too" $ do + t <- ct $ parsedFileGhc "./Renaming/Field1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (5, 6) parsed + let + comp = do + logParsedSource "parsed" + newName <- mkNewGhcName Nothing "NewPoint" + new <- renamePN n newName PreserveQualify parsed + + putRefactParsed new emptyAnns + logParsedSource "parsed:after" + + return (new,newName) + let + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- ((nb,nn),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + (showGhcQual n) `shouldBe` "Field1.Point" + (sourceFromState s) `shouldBe` "module Field1 where\n\n--Rename field name 'pointx' to 'pointx1'\n\ndata NewPoint = Pt {pointx, pointy :: Float}\n\nabsPoint :: NewPoint -> Float\nabsPoint p = sqrt (pointx p * pointx p +\n pointy p * pointy p)\n\n" + (unspace $ showGhcQual nb) `shouldBe` "module Field1 where\ndata NewPoint = Pt {pointx, pointy :: Float}\nabsPoint :: NewPoint -> Float\nabsPoint p = sqrt (pointx p * pointx p + pointy p * pointy p)" + + ------------------------------------ + + it "replace a name in a FunBind with multiple patterns" $ do + t <- ct $ parsedFileGhc "./LocToName.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (20, 1) parsed + let + comp = do + newName <- mkNewGhcName Nothing "newPoint" + new <- renamePN n newName PreserveQualify parsed + + putRefactParsed new emptyAnns + + return (new,newName) + let + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + (showGhcQual n) `shouldBe` "LocToName.sumSquares" + (sourceFromState s) `shouldBe` "module LocToName where\n\n{-\n\n\n\n\n\n\n\n\n-}\n\n\n\n\n\n\n\nnewPoint (x:xs) = x ^2 + newPoint xs\n -- where sq x = x ^pow \n -- pow = 2\n\nnewPoint [] = 0\n" + (unspace $ showGhcQual nb) `shouldBe` "module LocToName where\nnewPoint (x : xs) = x ^ 2 + newPoint xs\nnewPoint [] = 0" + + ------------------------------------ + + it "replaces a qualified name in a FunBind with multiple patterns" $ do + t <- ct $ parsedFileGhc "./LocToName.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t +#if __GLASGOW_HASKELL__ <= 710 + let modu = GHC.mkModule (GHC.stringToPackageKey "mypackage-1.0") (GHC.mkModuleName "LocToName") +#else + let modu = GHC.mkModule (GHC.stringToUnitId "mypackage-1.0") (GHC.mkModuleName "LocToName") +#endif + + let Just n = locToNameRdrPure nm (20, 1) parsed + let + comp = do + -- logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) + logDataWithAnns "parsed" parsed + newName <- mkNewGhcName (Just modu) "newPoint" + new <- renamePN n newName Qualify parsed + + putRefactParsed new emptyAnns + -- logParsedSource "parsed:after" + + return (new,newName) + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- ((nb,_nn),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + (showGhcQual n) `shouldBe` "LocToName.sumSquares" + (unspace $ showGhcQual nb) `shouldBe` "module LocToName where\nLocToName.newPoint (x : xs) = x ^ 2 + LocToName.newPoint xs\nLocToName.newPoint [] = 0" + (sourceFromState s) `shouldBe` "module LocToName where\n\n{-\n\n\n\n\n\n\n\n\n-}\n\n\n\n\n\n\n\nnewPoint (x:xs) = x ^2 + LocToName.newPoint xs\n -- where sq x = x ^pow \n -- pow = 2\n\nnewPoint [] = 0\n" + + + ------------------------------------ + + it "replaces a parameter name in a FunBind" $ do + t <- ct $ parsedFileGhc "./Renaming/LayoutIn2.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (8, 7) parsed + let + comp = do + logParsedSource "parsed" + + newName <- mkNewGhcName Nothing "ls" + new <- renamePN n newName PreserveQualify parsed + + putRefactParsed new emptyAnns + logParsedSource "parsed:after" + + return (new,newName) + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- ((nb,_nn),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + (sourceFromState s) `shouldBe` "module LayoutIn2 where\n\n--Layout rule applies after 'where','let','do' and 'of'\n\n--In this Example: rename 'list' to 'ls'.\n\nsilly :: [Int] -> Int\nsilly ls = case ls of (1:xs) -> 1\n--There is a comment\n (2:xs)\n | x < 10 -> 4 where x = last xs\n otherwise -> 12\n" + (unspace $ showGhcQual nb) `shouldBe` "module LayoutIn2 where\nsilly :: [Int] -> Int\nsilly ls\n = case ls of {\n (1 : xs) -> 1\n (2 : xs)\n | x < 10 -> 4\n where\n x = last xs\n otherwise -> 12 }" + + + ------------------------------------ + + it "does not qualify a name in an import hiding clause" $ do + t <- ct $ parsedFileGhc "./ScopeAndQual.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t +#if __GLASGOW_HASKELL__ <= 710 + let modu = GHC.mkModule (GHC.stringToPackageKey "mypackage-1.0") (GHC.mkModuleName "LocToName") +#else + let modu = GHC.mkModule (GHC.stringToUnitId "mypackage-1.0") (GHC.mkModuleName "LocToName") +#endif + + let Just n = locToNameRdrPure nm (4, 24) parsed + let + comp = do + logParsedSource "parsed" + newName <- mkNewGhcName (Just modu) "mySum" + new <- renamePN n newName Qualify parsed + + putRefactParsed new emptyAnns + + return (new,newName) + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- ((nb,_nn),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual n) `shouldBe` "Data.Foldable.sum" + (sourceFromState s) `shouldBe` "module ScopeAndQual where\n\nimport qualified Data.List as L\nimport Prelude hiding (mySum)\n\nmain :: IO ()\nmain = putStrLn (show $ L.mySum [1,2,3])\n\nsum a b = a + b\n\nsumSquares xs = L.mySum $ map (\\x -> x*x) xs\n\nmySumSq = sumSquares\n" + (unspace $ showGhcQual nb) `shouldBe` "module ScopeAndQual where\nimport qualified Data.List as L\nimport Prelude hiding ( mySum )\nmain :: IO ()\nmain = putStrLn (show $ L.mySum [1, 2, 3])\nsum a b = a + b\nsumSquares xs = L.mySum $ map (\\ x -> x * x) xs\nmySumSq = sumSquares" + + + ------------------------------------ + + it "does not qualify the subject of a type signature" $ do + t <- ct $ parsedFileGhc "./Renaming/C7.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t +#if __GLASGOW_HASKELL__ <= 710 + let modu = GHC.mkModule (GHC.stringToPackageKey "mypackage-1.0") (GHC.mkModuleName "LocToName") +#else + let modu = GHC.mkModule (GHC.stringToUnitId "mypackage-1.0") (GHC.mkModuleName "LocToName") +#endif + + let Just n = locToNameRdrPure nm (5, 1) parsed + let + comp = do + logParsedSource "parsed" + newName <- mkNewGhcName (Just modu) "myNewFringe" + + new <- renamePN n newName Qualify parsed + putRefactParsed new emptyAnns + + return (new,newName) + + ((nb,_nn),s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- ((nb,_nn),s) <- ct $ runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual n) `shouldBe` "Renaming.C7.myFringe" + (sourceFromState s) `shouldBe` "module Renaming.C7(LocToName.myNewFringe) where\n\nimport Renaming.D7\n\nmyNewFringe:: Tree a -> [a]\nmyNewFringe (Leaf x ) = [x]\nmyNewFringe (Branch left right) = LocToName.myNewFringe left ++ fringe right\n\n\n\n\n" + (unspace $ showGhcQual nb) `shouldBe` "module Renaming.C7 (\n LocToName.myNewFringe\n ) where\nimport Renaming.D7\nmyNewFringe :: Tree a -> [a]\nLocToName.myNewFringe (Leaf x) = [x]\nLocToName.myNewFringe (Branch left right)\n = LocToName.myNewFringe left ++ fringe right" + + ------------------------------------ + + it "realigns in a case for a shorter name" $ do + t <- ct $ parsedFileGhc "./Renaming/LayoutIn2.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (8, 7) parsed + let + comp = do + logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) + + newName <- mkNewGhcName Nothing "ls" + new <- renamePN n newName PreserveQualify parsed + + putRefactParsed new emptyAnns + + return (new,newName) + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual n) `shouldBe` "list" + (sourceFromState s) `shouldBe` "module LayoutIn2 where\n\n--Layout rule applies after 'where','let','do' and 'of'\n\n--In this Example: rename 'list' to 'ls'.\n\nsilly :: [Int] -> Int\nsilly ls = case ls of (1:xs) -> 1\n--There is a comment\n (2:xs)\n | x < 10 -> 4 where x = last xs\n otherwise -> 12\n" + (unspace $ showGhcQual nb) `shouldBe` "module LayoutIn2 where\nsilly :: [Int] -> Int\nsilly ls\n = case ls of {\n (1 : xs) -> 1\n (2 : xs)\n | x < 10 -> 4\n where\n x = last xs\n otherwise -> 12 }" + + + + ------------------------------------ + + it "realigns in a case for a longer name" $ do + t <- ct $ parsedFileGhc "./Renaming/LayoutIn2.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (8, 7) parsed + let + comp = do + logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) + + newName <- mkNewGhcName Nothing "listlonger" + new <- renamePN n newName PreserveQualify parsed + + putRefactParsed new emptyAnns + + return (new,newName) + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual n) `shouldBe` "list" + (sourceFromState s) `shouldBe` "module LayoutIn2 where\n\n--Layout rule applies after 'where','let','do' and 'of'\n\n--In this Example: rename 'list' to 'ls'.\n\nsilly :: [Int] -> Int\nsilly listlonger = case listlonger of (1:xs) -> 1\n --There is a comment\n (2:xs)\n | x < 10 -> 4 where x = last xs\n otherwise -> 12\n" + (unspace $ showGhcQual nb) `shouldBe` "module LayoutIn2 where\nsilly :: [Int] -> Int\nsilly listlonger\n = case listlonger of {\n (1 : xs) -> 1\n (2 : xs)\n | x < 10 -> 4\n where\n x = last xs\n otherwise -> 12 }" + + + ------------------------------------ + + it "realigns in a do for a shorter name" $ do + t <- ct $ parsedFileGhc "./Renaming/LayoutIn4.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (7, 8) parsed + let + comp = do + logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) + + newName <- mkNewGhcName Nothing "io" + new <- renamePN n newName PreserveQualify parsed + + putRefactParsed new emptyAnns + + return (new,newName) + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual n) `shouldBe` "ioFun" + (sourceFromState s) `shouldBe` "module LayoutIn4 where\n\n--Layout rule applies after 'where','let','do' and 'of'\n\n--In this Example: rename 'ioFun' to 'io'\n\nmain = io \"hello\" where io s= do let k = reverse s\n--There is a comment\n s <- getLine\n let q = (k ++ s)\n putStr q\n putStr \"foo\"\n\n" + (unspace $ showGhcQual nb) `shouldBe` "module LayoutIn4 where\nmain\n = io \"hello\"\n where\n io s\n = do { let k = reverse s;\n s <- getLine;\n let q = (k ++ s);\n putStr q;\n putStr \"foo\" }" + + + ------------------------------------ + + it "realigns in a do for a longer name" $ do + t <- ct $ parsedFileGhc "./Renaming/LayoutIn4.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (7, 8) parsed + let + comp = do + logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) + + newName <- mkNewGhcName Nothing "ioFunLong" + new <- renamePN n newName PreserveQualify parsed + + putRefactParsed new emptyAnns + + return (new,newName) + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual n) `shouldBe` "ioFun" + (sourceFromState s) `shouldBe` "module LayoutIn4 where\n\n--Layout rule applies after 'where','let','do' and 'of'\n\n--In this Example: rename 'ioFun' to 'io'\n\nmain = ioFunLong \"hello\" where ioFunLong s= do let k = reverse s\n --There is a comment\n s <- getLine\n let q = (k ++ s)\n putStr q\n putStr \"foo\"\n\n" + (unspace $ showGhcQual nb) `shouldBe` "module LayoutIn4 where\nmain\n = ioFunLong \"hello\"\n where\n ioFunLong s\n = do { let k = reverse s;\n s <- getLine;\n let q = (k ++ s);\n putStr q;\n putStr \"foo\" }" + + ------------------------------------ + + it "realigns in a where for a shorter name" $ do + t <- ct $ parsedFileGhc "./Renaming/LayoutIn1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (7, 17) parsed + let + comp = do + logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) + + newName <- mkNewGhcName Nothing "q" + new <- renamePN n newName PreserveQualify parsed + + putRefactParsed new emptyAnns + + return (new,newName) + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual n) `shouldBe` "sq" + (sourceFromState s) `shouldBe` "module LayoutIn1 where\n\n--Layout rule applies after 'where','let','do' and 'of'\n\n--In this Example: rename 'sq' to 'square'.\n\nsumSquares x y= q x + q y where q x= x^pow\n--There is a comment.\n pow=2\n" + (unspace $ showGhcQual nb) `shouldBe` "module LayoutIn1 where\nsumSquares x y\n = q x + q y\n where\n q x = x ^ pow\n pow = 2" + + + ------------------------------------ + + it "realigns in a where for a longer name" $ do + t <- ct $ parsedFileGhc "./Renaming/LayoutIn1.hs" + -- let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (7, 17) parsed + let + comp = do + -- logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) + logParsedSource "parsed" + + newName <- mkNewGhcName Nothing "square" + new <- renamePN n newName PreserveQualify parsed + + putRefactParsed new emptyAnns + + return (new,newName) + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- ((nb,_nn),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual n) `shouldBe` "sq" + (sourceFromState s) `shouldBe` "module LayoutIn1 where\n\n--Layout rule applies after 'where','let','do' and 'of'\n\n--In this Example: rename 'sq' to 'square'.\n\nsumSquares x y= square x + square y where square x= x^pow\n --There is a comment.\n pow=2\n" + (unspace $ showGhcQual nb) `shouldBe` "module LayoutIn1 where\nsumSquares x y\n = square x + square y\n where\n square x = x ^ pow\n pow = 2" + + ------------------------------------ + + it "realigns in a let/in for a shorter name" $ do + t <- ct $ parsedFileGhc "./TypeUtils/LayoutLet1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (6, 6) parsed + let + comp = do + logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) + + newName <- mkNewGhcName Nothing "x" + new <- renamePN n newName PreserveQualify parsed + + putRefactParsed new emptyAnns + + return (new,newName) + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual n) `shouldBe` "xxx" + (sourceFromState s) `shouldBe` "module LayoutLet1 where\n\n-- Simple let expression, rename xxx to something longer or shorter\n-- and the let/in layout should adjust accordingly\n\nfoo x = let a = 1\n b = 2\n in x + a + b\n\n" + (unspace $ showGhcQual nb) `shouldBe` "module LayoutLet1 where\nfoo x\n = let\n a = 1\n b = 2\n in x + a + b" + + ------------------------------------ + + it "realigns in a let/in for a longer name 1" $ do + t <- ct $ parsedFileGhc "./TypeUtils/LayoutLet1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (6, 6) parsed + let + comp = do + logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) + + newName <- mkNewGhcName Nothing "xxxlong" + -- new <- renamePN n newName False renamed + new <- renamePN n newName PreserveQualify parsed + + putRefactParsed new emptyAnns + + return (new,newName) + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- ((nb,nn),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual n) `shouldBe` "xxx" + (sourceFromState s) `shouldBe` "module LayoutLet1 where\n\n-- Simple let expression, rename xxx to something longer or shorter\n-- and the let/in layout should adjust accordingly\n\nfoo xxxlong = let a = 1\n b = 2\n in xxxlong + a + b\n\n" + (unspace $ showGhcQual nb) `shouldBe` "module LayoutLet1 where\nfoo xxxlong\n = let\n a = 1\n b = 2\n in xxxlong + a + b" + + + ------------------------------------ + + it "realigns in a let/in for a longer name 2" $ do + t <- ct $ parsedFileGhc "./TypeUtils/LayoutLet2.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (7, 6) parsed + let + comp = do + logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) + + newName <- mkNewGhcName Nothing "xxxlong" + new <- renamePN n newName PreserveQualify parsed + + putRefactParsed new emptyAnns + + return (new,newName) + + ((nb,nn),s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- ((nb,nn),s) <- ct $ runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual (n,nn)) `shouldBe` "(xxx, xxxlong)" + (sourceFromState s) `shouldBe` "module LayoutLet2 where\n\n-- Simple let expression, rename xxx to something longer or shorter\n-- and the let/in layout should adjust accordingly\n-- In this case the tokens for xxx + a + b should also shift out\n\nfoo xxxlong = let a = 1\n b = 2 in xxxlong + a + b\n\n" + (unspace $ showGhcQual nb) `shouldBe` "module LayoutLet2 where\nfoo xxxlong\n = let\n a = 1\n b = 2\n in xxxlong + a + b" + + + ------------------------------------ + + it "renames an exported data type" $ do + t <- ct $ parsedFileGhc "./Renaming/RenameInExportedType2.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (6, 24) parsed + let + comp = do + logm $ "parsed:" ++ (SYB.showData SYB.Parser 0 parsed) + + newName <- mkNewGhcName Nothing "NewType" + new <- renamePN n newName PreserveQualify parsed + + putRefactParsed new emptyAnns + logm $ "parsed:after" ++ (SYB.showData SYB.Parser 0 new) + + return (new,newName) + + ((_nb,nn),s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- ((_nb,nn),s) <- ct $ runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual (n,nn)) `shouldBe` "(Renaming.RenameInExportedType.NT, NewType)" + (sourceFromState s) `shouldBe` "module Renaming.RenameInExportedType\n (\n MyType (NewType)\n ) where\n\ndata MyType = MT Int | NewType\n\n\n" + + ------------------------------------ + + it "renames a qualified usage of a name" $ do + t <- ct $ parsedFileGhc "./Renaming/QualClient.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (10, 10) parsed + let + comp = do + logm $ "parsed:" ++ (SYB.showData SYB.Parser 0 parsed) + + newName <- mkNewGhcName Nothing "foo1" + new <- renamePN n newName PreserveQualify parsed + + putRefactParsed new emptyAnns + logm $ "parsed:after" ++ (SYB.showData SYB.Parser 0 new) + + return (new,newName) + + ((_nb,nn),s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- ((_nb,nn),s) <- ct $ runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual (n,nn)) `shouldBe` "(Renaming.QualServer.foo, foo1)" + (sourceFromState s) `shouldBe` "module Renaming.QualClient where\n\n{- foo is imported qualified as in QualClient. Renaming should\n preserve the qualification there\n-}\n\nimport qualified Renaming.QualServer as QS\n\nbaz :: String\nbaz = QS.foo1 : \"hello\"\n" + + ------------------------------------ + + it "renames a class op signature" $ do + t <- ct $ parsedFileGhc "./Renaming/D4.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (13, 5) parsed + let + comp = do + logm $ "parsed:" ++ (SYB.showData SYB.Parser 0 parsed) + + newName <- mkNewGhcName Nothing "isSameOrNot" + new <- renamePN n newName PreserveQualify parsed + + putRefactParsed new emptyAnns + logm $ "parsed:after" ++ (SYB.showData SYB.Parser 0 new) + + return (new,newName) + + ((_nb,nn),s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- ((_nb,nn),s) <- ct $ runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual (n,nn)) `shouldBe` "(Renaming.D4.isSame, isSameOrNot)" + (sourceFromState s) `shouldBe` "module Renaming.D4 where\n\n{-Rename instance name 'isSame'' to 'sameOrNot'.\n This refactoring affects module `D4', 'B4' and 'C4' -}\n\ndata Tree a = Leaf a | Branch (Tree a) (Tree a)\n\nfringe :: Tree a -> [a]\nfringe (Leaf x ) = [x]\nfringe (Branch left right) = fringe left ++ fringe right\n\nclass SameOrNot a where\n isSameOrNot :: a -> a -> Bool\n isNotSame :: a -> a -> Bool\n\ninstance SameOrNot Int where\n isSameOrNot a b = a == b\n isNotSame a b = a /= b\n\nsumSquares (x:xs) = sq x + sumSquares xs\n where sq x = x ^pow\n pow = 2\n\nsumSquares [] = 0\n" + + + ------------------------------------ + + it "renames a data decl parameter" $ do + t <- ct $ parsedFileGhc "./Renaming/ConstructorIn3.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (9, 13) parsed + let + comp = do + logParsedSource "parsed" + + newName <- mkNewGhcName Nothing "b" + new <- renamePN n newName PreserveQualify parsed + + putRefactParsed new emptyAnns + logParsedSource "parsed:after" + + return (new,newName) + + ((_nb,nn),s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- ((_nb,nn),s) <- ct $ runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual (n,nn)) `shouldBe` "(a, b)" + (sourceFromState s) `shouldBe` "module ConstructorIn3 where\n\n\n--Any type/data constructor name declared in this module can be renamed.\n--Any type variable can be renamed.\n\n--Rename tyoe variable 'a' in BTree to 'b'\n\ndata BTree b = Empty | T b (BTree b) (BTree b)\n deriving Show\n\nbuildtree :: Ord a => [a] -> BTree a\nbuildtree [] = Empty\nbuildtree (x:xs) = insert x (buildtree xs)\n\ninsert :: Ord a => a -> BTree a -> BTree a\ninsert val Empty = T val Empty Empty\ninsert val tree@(T tval left right)\n | val > tval = T tval left (insert val right)\n | otherwise = T tval (insert val left) right\n\nmain :: BTree Int\nmain = buildtree [3,1,2]\n" + + + -- --------------------------------------------- + + describe "qualifyToplevelName" $ do + it "qualifies a name at the top level" $ do + t <- ct $ parsedFileGhc "./Renaming/C7.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (7, 1) parsed + let + comp = do + qualifyToplevelName n + + return () + let + + (_,s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- (_,s) <- ct $ runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual n) `shouldBe` "Renaming.C7.myFringe" + (sourceFromState s) `shouldBe` "module Renaming.C7(Renaming.C7.myFringe) where\n\nimport Renaming.D7\n\nmyFringe:: Tree a -> [a]\nmyFringe (Leaf x ) = [x]\nmyFringe (Branch left right) = Renaming.C7.myFringe left ++ fringe right\n\n\n\n\n" + + + + -- --------------------------------------------- + + describe "findEntity" $ do + it "returns true if a (Located) Name is part of a HsBind 1" $ do + pendingWith "this may go away" + {- + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let + comp = do + parentr <- getRefactRenamed + parsed <- getRefactParsed + nm <- getRefactNameMap + + let (Just ln'@(GHC.L l _)) = locToRdrName (4,1) parsed + let n = rdrName2NamePure nm ln' + ln = GHC.L l n + + let declsr = hsBinds parentr + duplicatedDecls = definingDeclsNames [n] declsr True False + + res = findEntity ln duplicatedDecls + res2 = findEntity n duplicatedDecls + -- res = findEntity' ln duplicatedDecls + + return (res,res2,duplicatedDecls,ln) + ((r,r2,d,_l),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + (showGhcQual d) `shouldBe` "[DupDef.Dd1.toplevel x = DupDef.Dd1.c GHC.Num.* x]" + (showGhcQual _l) `shouldBe` "DupDef.Dd1.toplevel" + ("1" ++ show r) `shouldBe` "1True" + ("2" ++ show r2) `shouldBe` "2True" + -} + + -- --------------------------------- + + it "returns true if a (Located) Name is part of a HsBind 2" $ do + pendingWith "this may go away" + {- + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let + comp = do + parentr <- getRefactRenamed + parsed <- getRefactParsed + nm <- getRefactNameMap + + let (Just ln'@(GHC.L l _)) = locToRdrName (31,7) parsed + let n = rdrName2NamePure nm ln' + ln = GHC.L l n + + let (Just nd) = locToNameRdrPure nm (30,1) parsed + + let declsr = hsBinds parentr + duplicatedDecls = definingDeclsNames [nd] declsr True False + + res = findEntity ln duplicatedDecls + res2 = findEntity n duplicatedDecls + + return (res,res2,duplicatedDecls,ln) + ((r,r2,d,_l),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + (showGhcQual d) `shouldBe` "[DupDef.Dd1.dd q\n = do { let ss = 5;\n"++ + " GHC.Base.return (ss GHC.Num.+ q) }]" + (showGhcQual _l) `shouldBe` "ss" + ("1" ++ show r) `shouldBe` "1True" + ("2" ++ show r2) `shouldBe` "2True" + -} + + -- ----------------------------------------------------------------- + + it "returns false if a syntax phrase is not part of another" $ do + pendingWith "this may go away" + {- + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let + comp = do + parentr <- getRefactRenamed + parsed <- getRefactParsed + nm <- getRefactNameMap + + let (Just n) = locToNameRdrPure nm (4,1) parsed + + let (Just tup) = locToNameRdrPure nm (11,1) parsed + + let declsr = hsBinds parentr + duplicatedDecls = definingDeclsNames [n] declsr True False + + res = findEntity tup duplicatedDecls + -- res = findEntity' ln duplicatedDecls + + return (res,duplicatedDecls) + ((r,d),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + (showGhcQual d) `shouldBe` "[DupDef.Dd1.toplevel x = DupDef.Dd1.c GHC.Num.* x]" + ("1" ++ show r) `shouldBe` "1False" + -} + + -- ----------------------------------------------------------------- + + it "Finds an entity in [HsBind Name]" $ do + pending -- "write this test" + + -- ----------------------------------------------------------------- + + it "Finds an entity in (MatchGroup matches _)" $ do + pending -- "write this test" + + -- ----------------------------------------------------------------- + + it "Finds an entity in (HsLet decls _)" $ do + pending -- "write this test" + + -- ----------------------------------------------------------------- + + it "Finds an entity in (HsLet _ e1)" $ do + pending -- "write this test" + + -- ----------------------------------------------------------------- + + it "Finds an entity in (HsLet decls _)" $ do + pending -- "write this test" + + -- ----------------------------------------------------------------- + + it "Finds an entity in (PatBind pat rhs _ _ _)" $ do + pending -- "write this test" + + -- ----------------------------------------------------------------- + + it "Finds an entity in (Match _ _ rhs)" $ do + pending -- "write this test" + + -- ----------------------------------------------------------------- + + it "Finds an entity in (LetStmt binds)" $ do + pending -- "write this test" + + -- ----------------------------------------------------------------- + + it "Finds an entity in (BindStmt _ rhs _ _)" $ do + pending -- "write this test" + + + -- --------------------------------------------- + + describe "modIsExported" $ do + it "Returns True if the module is explicitly exported" $ do + t <- ct $ parsedFileGhc "./FreeAndDeclared/Declare.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = fromJust $ GHC.tm_renamed_source t + let (Just (modName,_)) = getModuleName parsed + + (modIsExported modName renamed) `shouldBe` True + + it "Returns True if the module is exported by default" $ do + t <- ct $ parsedFileGhc "./FreeAndDeclared/Declare1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = fromJust $ GHC.tm_renamed_source t + let (Just (modName,_)) = getModuleName parsed + + (modIsExported modName renamed) `shouldBe` True + + it "Returns False if the module is explicitly not exported" $ do + t <- ct $ parsedFileGhc "./FreeAndDeclared/Declare2.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = fromJust $ GHC.tm_renamed_source t + let (Just (modName,_)) = getModuleName parsed + + (modIsExported modName renamed) `shouldBe` False + + -- --------------------------------------------- + + describe "isExported" $ do + it "returns True if a GHC.Name is exported" $ do + t <- ct $ parsedFileGhc "./Renaming/B1.hs" + + let + comp = do + parsed <- getRefactParsed + nm <- getRefactNameMap + + let (Just myFringe) = locToNameRdrPure nm (11,1) parsed + let (Just sumSquares) = locToNameRdrPure nm (15,1) parsed + + exMyFring <- isExported myFringe + exSumSquares <- isExported sumSquares + + return (myFringe,exMyFring,sumSquares,exSumSquares) + ((mf,emf,ss,ess),_s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t}) testOptions + + (showGhcQual mf) `shouldBe` "Renaming.B1.myFringe" + emf `shouldBe` True + (showGhcQual ss) `shouldBe` "Renaming.B1.sumSquares" + ess `shouldBe` False + + -- --------------------------------------------- + + describe "addHiding" $ do + it "add a hiding entry to the imports with no existing hiding" $ do + t1 <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let + comp = do + clearParsedModule + t2 <- parseSourceFileTest "./DupDef/Dd2.hs" + let renamed2 = fromJust $ GHC.tm_renamed_source t2 + + let parsed1 = GHC.pm_parsed_source $ GHC.tm_parsed_module t1 + let parsed2 = GHC.pm_parsed_source $ GHC.tm_parsed_module t2 + + -- let mn = locToName (4,1) renamed1 + -- let (Just (GHC.L _ _n)) = mn + + let Just (modName,_) = getModuleName parsed1 + let + n1 = mkRdrName "n1" + n2 = mkRdrName "n2" + res <- addHiding modName parsed2 [n1,n2] + putRefactParsed res emptyAnns + + return (res,renamed2) + ((_r,_r2),s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t1}) testOptions + -- ((_r,_r2),s) <- ct $ runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t1}) testOptions + + (sourceFromState s) `shouldBe` "module DupDef.Dd2 where\n\nimport DupDef.Dd1 hiding (n1,n2)\n\n\nf2 x = ff (x+1)\n\nmm = 5\n\n\n" + + ------------------------------------ + + it "adds a hiding entry to the imports with an existing hiding" $ do + t1 <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let + comp = do + + clearParsedModule + t2 <- parseSourceFileTest "./DupDef/Dd3.hs" + let renamed2 = fromJust $ GHC.tm_renamed_source t2 + + let parsed1 = GHC.pm_parsed_source $ GHC.tm_parsed_module t1 + let parsed2 = GHC.pm_parsed_source $ GHC.tm_parsed_module t2 + + -- let mn = locToName (4,1) renamed1 + -- let (Just (GHC.L _ _n)) = mn + + let Just (modName,_) = getModuleName parsed1 + let + n1 = mkRdrName "n1" + n2 = mkRdrName "n2" + res <- addHiding modName parsed2 [n1,n2] + + return (res,renamed2) + ((_r,_r2),s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t1}) testOptions + (sourceFromState s) `shouldBe` "module DupDef.Dd3 where\n\nimport DupDef.Dd1 hiding (dd,n1,n2)\n\n\nf2 x = ff (x+1)\n\nmm = 5\n\n\n" + + -- --------------------------------------------- + + describe "equivalentNameInNewMod" $ do + it "finds equivalent name for normal import" $ do + let + ctc = cdAndDo "./test/testdata/cabal/foo" + let + comp = do + parseSourceFileGhc "./src/Foo/Bar.hs" + parsed <- getRefactParsed + nm <- getRefactNameMap + let Just old = locToNameRdrPure nm (3,1) parsed + parseSourceFileGhc "./src/Main.hs" + [equiv] <- equivalentNameInNewMod old + return (old,equiv) + + ((o,e),_s) <- ctc $ runRefactGhc comp initialState testOptions + -- ((o,e),_s) <- ctc $ runRefactGhc comp initialLogOnState testOptions + (showGhcQual (o,e)) `shouldBe` "(Foo.Bar.bar, Foo.Bar.bar)" + -- putStrLn( "(GHC.nameUnique o,GHC.nameUnique e)" ++ (showGhcQual (GHC.nameUnique o,GHC.nameUnique e))) + -- (GHC.nameUnique o == GHC.nameUnique e) `shouldBe` True -- seems to reuse the already loaded names? + + -- --------------------------------- + + it "finds equivalent name for qualified import" $ do + let + ctc = cdAndDo "./test/testdata/cabal/cabal4" + let + comp = do + parseSourceFileGhc "./src/Foo/Bar.hs" + parsed <- getRefactParsed + nm <- getRefactNameMap + let Just old = locToNameRdrPure nm (3,1) parsed + parseSourceFileGhc "./src/main4.hs" + parsed' <- getRefactParsed + [equiv] <- equivalentNameInNewMod old + + let Just ((GHC.L _l new)) = locToRdrName (11,12) parsed' + return (old,equiv,new) + + ((o,e,n),_s) <- ctc $ runRefactGhc comp initialState testOptions + (showGhcQual (o,e,n)) `shouldBe` "(Foo.Bar.baz, Foo.Bar.baz, B.baz)" + -- (showGhcQual (GHC.nameUnique o,GHC.nameUnique e)) `shouldBe` "" + -- (GHC.nameUnique o == GHC.nameUnique e) `shouldBe` True -- seems to reuse the already loaded names? + + -- --------------------------------------------- + + describe "usedWithoutQualR" $ do + it "returns True if the identifier is used unqualified Dd1" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let + comp = do + parsed <- getRefactParsed + nm <- getRefactNameMap + + let Just n@name = locToNameRdrPure nm (14,21) parsed + let res = usedWithoutQualR name parsed + return (res,n,name) + + ((r,n1,n2),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (GHC.getOccString n2) `shouldBe` "zip" + (showGhcQual n1) `shouldBe` "GHC.List.zip" + r `shouldBe` True + + -- --------------------------------- + + it "returns True if the identifier is used unqualified Dd3" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd3.hs" + let + comp = do + parsed <- getRefactParsed + nm <- getRefactNameMap + + let Just n@name = locToNameRdrPure nm (8,1) parsed + let res = usedWithoutQualR name parsed + return (res,n,name) + + ((r,n1,n2),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (GHC.getOccString n2) `shouldBe` "mm" + (showGhcQual n1) `shouldBe` "DupDef.Dd3.mm" + r `shouldBe` True + + -- --------------------------------- + + it "returns False if the identifier is used qualified" $ do + t <- ct $ parsedFileGhc "./FreeAndDeclared/Declare.hs" + let + comp = do + parsed <- getRefactParsed + nm <- getRefactNameMap + + let Just n@name = locToNameRdrPure nm (36,12) parsed + let Just (GHC.L _ namep) = locToRdrName (36,12) parsed + let res = usedWithoutQualR name parsed + return (res,namep,name,n) + ((r,np,n1,n2),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (myShow np) `shouldBe` "Qual:G:gshow" + (myShow $ GHC.getRdrName n1) `shouldBe` "Exact:Data.Generics.Text.gshow" + (showGhcQual $ GHC.getRdrName n1) `shouldBe` "Data.Generics.Text.gshow" + (showGhcQual n2) `shouldBe` "Data.Generics.Text.gshow" + r `shouldBe` False + + -- --------------------------------------------- + + describe "isExplicitlyExported" $ do + it "Returns True if the identifier is explicitly exported" $ do + pending -- "write this " + + it "Returns False if the identifier is not explicitly exported" $ do + pending -- "write this " + + -- --------------------------------------------- + + describe "causeNameClashInExports" $ do + it "Returns True if there is a clash" $ do + + t <- ct $ parsedFileGhc "./Renaming/ConflictExport.hs" + let nm = initRdrNameMap t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let modu = GHC.ms_mod $ GHC.pm_mod_summary $ GHC.tm_parsed_module t + + -- Is this the right module? + let Just (modName,_) = getModuleName parsed + + let Just myFringe = locToNameRdrPure nm (9,1) parsed + (showGhcQual myFringe) `shouldBe` "Renaming.ConflictExport.myFringe" + + -- old name is myFringe + -- new name is "Renaming.ConflictExport.fringe" + let newName = mkTestGhcName 1 (Just modu) "fringe" + + (showGhcQual modu) `shouldBe` "main@main:Renaming.ConflictExport" + (showGhcQual newName) `shouldBe` "Renaming.ConflictExport.fringe" + + (showGhcQual $ GHC.localiseName newName) `shouldBe` "fringe" + + let res = causeNameClashInExports nm myFringe newName modName parsed + res `shouldBe` True + + it "Returns False if there is no clash" $ do + t <- ct $ parsedFileGhc "./Renaming/ConflictExport.hs" + let nm = initRdrNameMap t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let modu = GHC.ms_mod $ GHC.pm_mod_summary $ GHC.tm_parsed_module t + + -- Is this the right module? + let Just (modName,_) = getModuleName parsed + + let Just myFringe = locToNameRdrPure nm (9,1) parsed + (showGhcQual myFringe) `shouldBe` "Renaming.ConflictExport.myFringe" + + -- old name is myFringe + -- new name is "Renaming.ConflictExport.fringe" + let newName = mkTestGhcName 1 (Just modu) "fringeOk" + + (showGhcQual modu) `shouldBe` "main@main:Renaming.ConflictExport" + (showGhcQual newName) `shouldBe` "Renaming.ConflictExport.fringeOk" + + (showGhcQual $ GHC.localiseName newName) `shouldBe` "fringeOk" + + let res = causeNameClashInExports nm myFringe newName modName parsed + res `shouldBe` False + + -- --------------------------------------- + + describe "rmQualifier" $ do + it "removes the qualifiers from a list of identifiers in a given syntax phrase" $ do + let + comp = do + parseSourceFileGhc "./TypeUtils/Qualified.hs" + parsed <- getRefactParsed + decls <- liftT $ hsDecls parsed + nm <- getRefactNameMap + + let Just foo = locToNameRdrPure nm (5, 1) parsed + let Just baz = locToNameRdrPure nm (5, 27) parsed + + let [fooDecl] = definingDeclsRdrNames nm [foo] decls False False + + res <- rmQualifier [baz] fooDecl + return (res,fooDecl,baz) + + ((r,d,n1),_s) <- ct $ runRefactGhc comp initialState testOptions + (showGhcQual n1) `shouldBe` "TypeUtils.C.baz" + (showGhcQual d) `shouldBe` "main = return TypeUtils.C.baz" + (showGhcQual r) `shouldBe` "main = return baz" + + it "Removes the qualifiers and updates the tokens" $ do + pending -- "Is this needed?" + + -- --------------------------------------- + + describe "usedByRhs" $ do + it "returns True if a given identifier is used in the RHS of a syntax element" $ do + t <- ct $ parsedFileGhc "./MoveDef/Demote.hs" + let + comp = do + parsed <- getRefactParsed + declsp <- liftT $ hsDecls parsed + nm <- getRefactNameMap + + let Just tl = locToNameRdrPure nm (4,1) parsed + let Just name = locToNameRdrPure nm (7,1) parsed + let decls = definingDeclsRdrNames nm [tl] declsp False False + decls' <- rmQualifier [name] decls + + let res = usedByRhsRdr nm decls' [name] + + return (res,decls,tl,name) + + ((r,d,n1,n2),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + (showGhcQual n1) `shouldBe` "MoveDef.Demote.toplevel" + (showGhcQual n2) `shouldBe` "MoveDef.Demote.c" + (showGhcQual d) `shouldBe` "[toplevel x = c * x]" + r `shouldBe` True + + -- --------------------------------------- + + describe "autoRenameLocalVar" $ do + it "renames an identifier if it is used and updates tokens" $ do + t <- ct $ parsedFileGhc "./Demote/WhereIn4.hs" + let + comp = do + parsed <- getRefactParsed + nm <- getRefactNameMap + tlDecls <- liftT $ hsDecls parsed + + let Just tl = locToNameRdrPure nm (11,1) parsed + let Just name = locToNameRdrPure nm (11,21) parsed + let [decls] = definingDeclsRdrNames nm [tl] tlDecls False True + decls' <- autoRenameLocalVar name decls + + return (decls',decls,tl,name) + + ((r,d,n1,n2),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- ((r,d,n1,n2),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + (showGhcQual n1) `shouldBe` "Demote.WhereIn4.sumSquares" + (showGhcQual n2) `shouldBe` "p" + (showGhcQual d) `shouldBe` "sumSquares x y\n = sq p x + sq p y\n where\n p = 2" + (showGhcQual r) `shouldBe` "sumSquares x y\n = sq p_1 x + sq p_1 y\n where\n p_1 = 2" + (exactPrintFromState s r) `shouldBe` "\n\n--A definition can be demoted to the local 'where' binding of a friend declaration,\n--if it is only used by this friend declaration.\n\n--Demoting a definition narrows down the scope of the definition.\n--In this example, demote the top level 'sq' to 'sumSquares'\n--In this case (there is single matches), if possible,\n--the parameters will be folded after demoting and type sigature will be removed.\n\nsumSquares x y = sq p_1 x + sq p_1 y\n where p_1=2" + + -- --------------------------------------- + + describe "mkNewName" $ do + it "Makes a new name that does not clash with existing ones" $ do + (mkNewName "f" ["f"] 0) `shouldBe` "f_1" + (mkNewName "f" ["g"] 0) `shouldBe` "f" + (mkNewName "f" ["g","f_1","f"] 0) `shouldBe` "f_2" + + -- --------------------------------------- + + describe "addImportDecl" $ do + it "adds an import entry to a module with already existing, non conflicting imports and other declarations" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let + comp = do + clearParsedModule + parseSourceFileGhc "./DupDef/Dd2.hs" + renamed2 <- getRefactRenamed + parsed2 <- getRefactParsed + + let listModName = GHC.mkModuleName "Data.List" + res <- addImportDecl parsed2 listModName Nothing False False False Nothing False [] + putRefactParsed res emptyAnns + + return (res,renamed2) + ((_r,_r2),s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + (sourceFromState s) `shouldBe` "module DupDef.Dd2 where\n\nimport DupDef.Dd1\nimport Data.List\n\n\nf2 x = ff (x+1)\n\nmm = 5\n\n\n" + + -- --------------------------------- + + it "adds an import entry to a module with some declaration, but no explicit imports." $ do + t <- ct $ parsedFileGhc "./TypeUtils/Simplest.hs" + let + comp = do + + let renamed1 = fromJust $ GHC.tm_renamed_source t + parsed <- getRefactParsed + + let listModName = GHC.mkModuleName "Data.List" + res <- addImportDecl parsed listModName Nothing False False False Nothing False [] + putRefactParsed res emptyAnns + + return (res,renamed1) + ((_r,_r2),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + (sourceFromState s) `shouldBe` "module Simplest where\nimport Data.List\n\n\nsimple x = x\n" + + -- --------------------------------- + + it "adds an import entry to a module with explicit imports, but no declarations." $ do + t <- ct $ parsedFileGhc "./TypeUtils/JustImports.hs" + let + comp = do + let renamed1 = fromJust $ GHC.tm_renamed_source t + parsed <- getRefactParsed + + let listModName = GHC.mkModuleName "Data.List" + res <- addImportDecl parsed listModName Nothing False False False Nothing False [] + putRefactParsed res emptyAnns + + return (res,renamed1) + ((_r,_r2),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + (sourceFromState s) `shouldBe` "module JustImports where\n\nimport Data.Maybe\nimport Data.List\n" + + -- --------------------------------- + + it "adds an import entry to a module with no declarations and no explicit imports" $ do + t <- ct $ parsedFileGhc "./TypeUtils/Empty.hs" + let + comp = do + renamed1 <- getRefactRenamed + parsed <- getRefactParsed + + let listModName = GHC.mkModuleName "Data.List" + res <- addImportDecl parsed listModName Nothing False False False Nothing False [] + putRefactParsed res emptyAnns + + return (res,renamed1) + ((_r,_r2),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (sourceFromState s) `shouldBe` "module Empty where\nimport Data.List\n\n" + + + -- --------------------------------------- + + describe "addItemsToImport" $ do + it "adds an item to an import entry with no items" $ do + t <- ct $ parsedFileGhc "./TypeUtils/JustImports.hs" + let + comp = do + parsed <- getRefactParsed + + let modName = GHC.mkModuleName "Data.Maybe" + -- itemName <- mkNewGhcName Nothing "fromJust" + let itemName = mkRdrName "fromJust" + + res <- addItemsToImport modName Nothing (Left [itemName]) parsed + putRefactParsed res emptyAnns + + return (res) + ((_r),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + -- This is the correct behavior. If the import doesn't have an import list, creating + -- one for an item effectively reduces the imported interface. + (sourceFromState s) `shouldBe` "module JustImports where\n\nimport Data.Maybe\n" + +-- Not sure if this should be a test +{- it "Try adding more than one item to an existing import entry with no items, using separate calls." $ do + let + comp = do + (t1,_toks1) <- parseSourceFileTest "./TypeUtils/JustImports.hs" + -- clearParsedModule + let renamed1 = fromJust $ GHC.tm_renamed_source t1 + + let modName = GHC.mkModuleName "Data.Maybe" + itemName <- mkNewGhcName Nothing "fromJust" + + res <- addItemsToImport modName renamed1 [itemName] --listModName Nothing False False False Nothing False [] + + itemName2 <- mkNewGhcName Nothing "isJust" + + res2 <- addItemsToImport modName res [itemName2] + toks <- fetchToks + + return (res2,toks,renamed,_toks1) + ((_r,t,r2,tk2),s) <- ct $ runRefactGhcState comp + (GHC.showRichTokenStream t) `shouldBe` "module JustImports where\n\n import Data.Maybe (fromJust,isJust)\n " +-} + + -- --------------------------------- + + it "adds an item to an import entry with existing items" $ do + t <- ct $ parsedFileGhc "./TypeUtils/SelectivelyImports.hs" + let + comp = do + parsed <-getRefactParsed + + let modName = GHC.mkModuleName "Data.Maybe" + let itemName = mkRdrName "isJust" + + res <- addItemsToImport modName Nothing (Left [itemName]) parsed + putRefactParsed res emptyAnns + return (res) + ((_r),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + (sourceFromState s) `shouldBe` "module SelectivelyImports where\n\nimport Data.Maybe (fromJust,isJust)\n\n__ = id\n" + +{- -- test after properly inserting conditional identifier + it "Add an item to an import entry with existing items, passing existing conditional identifier." $ do + let + comp = do + (t1,_toks1) <- parseSourceFileTest "./TypeUtils/SelectivelyImports.hs" + -- clearParsedModule + let renamed1 = fromJust $ GHC.tm_renamed_source t1 + + let modName = GHC.mkModuleName "Data.Maybe" + itemName <- mkNewGhcName Nothing "isJust" + conditionalId <- mkNewGhcName Nothing "fromJust" + + res <- addItemsToImport modName renamed1 [itemName] (Just conditionalId) + toks <- fetchToks + + return (res,toks,renamed1,_toks1) + ((_r,t,r2,tk2),s) <- ct $ runRefactGhcState comp + (GHC.showRichTokenStream t) `shouldBe` "module SelectivelyImports where\n\n import Data.Maybe (fromJust,isJust)\n\n __ = id\n " + + it "Add an item to an import entry with existing items, passing missing conditional identifier" $ do + let + comp = do + (t1,_toks1) <- parseSourceFileTest "./TypeUtils/SelectivelyImports.hs" + -- clearParsedModule + let renamed1 = fromJust $ GHC.tm_renamed_source t1 + + let modName = GHC.mkModuleName "Data.Maybe" + itemName <- mkNewGhcName Nothing "isJust" + + res <- addItemsToImport modName renamed1 [itemName] (Just itemName) + toks <- fetchToks + + return (res,toks,renamed1,_toks1) + ((_r,t,r2,tk2),s) <- ct $ runRefactGhcState comp + (GHC.showRichTokenStream t) `shouldBe` "module SelectivelyImports where\n\n import Data.Maybe (fromJust)\n\n __ = id\n " +-} + + -- --------------------------------------- + + describe "addItemsToExport" $ do + it "adds an item to an export entry with no items" $ do + pendingWith "write these tests" + + -- --------------------------------------- + + describe "unspace" $ do + it "Reduces all sequences of more than one space to a single one" $ do + (unspace []) `shouldBe` [] + (unspace "a") `shouldBe` "a" + (unspace "a bc") `shouldBe` "a bc" + (unspace "a bc") `shouldBe` "a bc" + (unspace "ab c") `shouldBe` "ab c" + (unspace " ab c") `shouldBe` " ab c" + (unspace "abc ") `shouldBe` "abc " + + -- --------------------------------------- + + describe "isFieldName" $ do + it "returns True if a Name is a field name" $ do + t <- ct $ parsedFileGhc "./Renaming/Field3.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let nm = initRdrNameMap t + + let Just nf = locToNameRdrPure nm (10,21) parsed + let Just n = locToNameRdrPure nm (10,1) parsed + + (showGhcQual n) `shouldBe` "Field3.absPoint" + (showGhcQual nf) `shouldBe` "Field3.pointx" + + -- --------------------------------------- + + describe "name predicates" $ do + it "classifies names" $ do + t <- ct $ parsedFileGhc "./Cons.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let nm = initRdrNameMap t + + let Just n1 = locToNameRdrPure nm (3,6) parsed + let Just n2 = locToNameRdrPure nm (3,12) parsed + let Just n3 = locToNameRdrPure nm (3,16) parsed + let Just n4 = locToNameRdrPure nm (5,1) parsed + let Just n5 = locToNameRdrPure nm (8,5) parsed + + (showGhcQual n1) `shouldBe` "Main.Foo" + "11" ++ (show $ GHC.isTyVarName n1) `shouldBe` "11False" + "12" ++ (show $ GHC.isTyConName n1) `shouldBe` "12True" + "13" ++ (show $ GHC.isDataConName n1) `shouldBe` "13False" + "14" ++ (show $ GHC.isValName n1) `shouldBe` "14False" + "15" ++ (show $ GHC.isVarName n1) `shouldBe` "15False" + + (showGhcQual n2) `shouldBe` "Main.Ff" + "21" ++ (show $ GHC.isTyVarName n2) `shouldBe` "21False" + "22" ++ (show $ GHC.isTyConName n2) `shouldBe` "22False" + "23" ++ (show $ GHC.isDataConName n2) `shouldBe` "23True" + "24" ++ (show $ GHC.isValName n2) `shouldBe` "24True" + "25" ++ (show $ GHC.isVarName n2) `shouldBe` "25False" + + (showGhcQual n3) `shouldBe` "Main.fooA" -- field name + "31" ++ (show $ GHC.isTyVarName n3) `shouldBe` "31False" + "32" ++ (show $ GHC.isTyConName n3) `shouldBe` "32False" + "33" ++ (show $ GHC.isDataConName n3) `shouldBe` "33False" + "34" ++ (show $ GHC.isValName n3) `shouldBe` "34True" + "35" ++ (show $ GHC.isVarName n3) `shouldBe` "35True" + + (showGhcQual n4) `shouldBe` "Main.xx" + "41" ++ (show $ GHC.isTyVarName n4) `shouldBe` "41False" + "42" ++ (show $ GHC.isTyConName n4) `shouldBe` "42False" + "43" ++ (show $ GHC.isDataConName n4) `shouldBe` "43False" + "44" ++ (show $ GHC.isValName n4) `shouldBe` "44True" + "45" ++ (show $ GHC.isVarName n4) `shouldBe` "45True" + + (showGhcQual n5) `shouldBe` "GHC.Classes.==" + "51" ++ (show $ GHC.isTyVarName n5) `shouldBe` "51False" + "52" ++ (show $ GHC.isTyConName n5) `shouldBe` "52False" + "53" ++ (show $ GHC.isDataConName n5) `shouldBe` "53False" + "54" ++ (show $ GHC.isValName n5) `shouldBe` "54True" + "55" ++ (show $ GHC.isVarName n5) `shouldBe` "55True" + + -- --------------------------------------------------------------------- + + describe "rdrName2Name" $ do + + it "finds a Name for a top-level RdrName" $ do + t <- ct $ parsedFileGhc "./TokenTest.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let + comp = do + let (Just rdr) = locToRdrName (5,1) parsed + -- (Just name) = locToName (5,1) renamed + nname <- rdrName2Name rdr + return (rdr,nname) + ((r,n),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- ((r,n),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual (r,n)) `shouldBe` "(bob, TokenTest.bob)" + + -- --------------------------------- + + it "finds a Name for a local RdrName" $ do + t <- ct $ parsedFileGhc "./TokenTest.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let + comp = do + let (Just rdr) = locToRdrName (14,7) parsed + nname <- rdrName2Name rdr + return (rdr,nname) + ((r,n),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + -- ((r,n),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual (r,n)) `shouldBe` "(bar, bar)" -- --------------------------------------- diff --git a/test/UtilsSpec.hs b/test/UtilsSpec.hs --- a/test/UtilsSpec.hs +++ b/test/UtilsSpec.hs @@ -582,11 +582,11 @@ it "loads a file from a sub directory" $ do t <- ct $ parsedFileGhc "./FreeAndDeclared/DeclareS.hs" fileName <- canonicalizePath "./test/testdata/FreeAndDeclared/DeclareS.hs" - let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t let comp = do parseSourceFileGhc fileName - r <- hsFreeAndDeclaredPNs renamed + r <- hsFreeAndDeclaredPNs parsed return r ((res),_s) <- cdAndDo "./test/testdata/FreeAndDeclared" $ runRefactGhc comp initialState testOptions @@ -597,5 +597,19 @@ -- Declared Vars (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd res)) `shouldBe` "[(FreeAndDeclared.DeclareS.c, (6, 1))]" --- --------------------------------------------------------------------- + -- ------------------------------------------------------------------- + describe "stripCallStack" $ do + it "strips a call stack from the end of an error string" $ do + let s = "\nThe identifier is not a local function/pattern name!\nCallStack (from HasCallStack):\n error, called at ../src/Language/Haskell/Refact/Refactoring/MoveDef.hs:155:12 in main:Language.Haskell.Refact.Refactoring.MoveDef" + (stripCallStack s) `shouldBe` "\nThe identifier is not a local function/pattern name!" + + it "noops if no call stack from the end of an error string" $ do + let s = "\nThe identifier is not a local function/pattern name!" + (stripCallStack s) `shouldBe` "\nThe identifier is not a local function/pattern name!" + + it "noops if no call stack from the end of an error string, trailing nl" $ do + let s = "\nThe identifier is not a local function/pattern name!\n" + (stripCallStack s) `shouldBe` "\nThe identifier is not a local function/pattern name!\n" + +-- --------------------------------------------------------------------- diff --git a/test/testdata/AddOneParameter/A1.expected.hs b/test/testdata/AddOneParameter/A1.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/A1.expected.hs @@ -0,0 +1,10 @@ +module AddOneParameter.A1 where + +import AddOneParameter.C1 + +import AddOneParameter.D1 + +sumSq xs = sum (map (sq sq_f) xs) + sumSquares xs + sumSquares1 xs + +main = sumSq [1..4] + diff --git a/test/testdata/AddOneParameter/A1.hs b/test/testdata/AddOneParameter/A1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/A1.hs @@ -0,0 +1,10 @@ +module AddOneParameter.A1 where + +import AddOneParameter.C1 + +import AddOneParameter.D1 + +sumSq xs = sum (map sq xs) + sumSquares xs + sumSquares1 xs + +main = sumSq [1..4] + diff --git a/test/testdata/AddOneParameter/A2.expected.hs b/test/testdata/AddOneParameter/A2.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/A2.expected.hs @@ -0,0 +1,12 @@ +module AddOneParameter.A2 where + +import AddOneParameter.C2 + +import AddOneParameter.D2 + +sumSq xs = sum (map (sq sq_f) xs) + sumSquares xs + sumSquares1 xs + +sq_f_2 = 2 + +main = sumSq [1..4] + diff --git a/test/testdata/AddOneParameter/A2.hs b/test/testdata/AddOneParameter/A2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/A2.hs @@ -0,0 +1,12 @@ +module AddOneParameter.A2 where + +import AddOneParameter.C2 + +import AddOneParameter.D2 + +sumSq xs = sum (map sq xs) + sumSquares xs + sumSquares1 xs + +sq_f_2 = 2 + +main = sumSq [1..4] + diff --git a/test/testdata/AddOneParameter/A3.expected.hs b/test/testdata/AddOneParameter/A3.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/A3.expected.hs @@ -0,0 +1,6 @@ +module AddOneParameter.A3 where + +import AddOneParameter.D3 + +main = (sumSquares sumSquares_y) [1..4] + diff --git a/test/testdata/AddOneParameter/A3.hs b/test/testdata/AddOneParameter/A3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/A3.hs @@ -0,0 +1,6 @@ +module AddOneParameter.A3 where + +import AddOneParameter.D3 + +main = sumSquares [1..4] + diff --git a/test/testdata/AddOneParameter/C1.expected.hs b/test/testdata/AddOneParameter/C1.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/C1.expected.hs @@ -0,0 +1,10 @@ +module AddOneParameter.C1 where + +import AddOneParameter.D1 + +sumSquares1 (x:xs) = (sq sq_f) x + sumSquares1 xs + +sumSquares1 [] = 0 + + + diff --git a/test/testdata/AddOneParameter/C1.hs b/test/testdata/AddOneParameter/C1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/C1.hs @@ -0,0 +1,10 @@ +module AddOneParameter.C1 where + +import AddOneParameter.D1 + +sumSquares1 (x:xs) = sq x + sumSquares1 xs + +sumSquares1 [] = 0 + + + diff --git a/test/testdata/AddOneParameter/C2.expected.hs b/test/testdata/AddOneParameter/C2.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/C2.expected.hs @@ -0,0 +1,12 @@ +module AddOneParameter.C2 where + +import AddOneParameter.D2 + +sumSquares1 (x:xs) = (sq sq_f) x + sumSquares1 xs + +sumSquares1 [] = 0 + +sq_f_1 = 0 + + + diff --git a/test/testdata/AddOneParameter/C2.hs b/test/testdata/AddOneParameter/C2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/C2.hs @@ -0,0 +1,12 @@ +module AddOneParameter.C2 where + +import AddOneParameter.D2 + +sumSquares1 (x:xs) = sq x + sumSquares1 xs + +sumSquares1 [] = 0 + +sq_f_1 = 0 + + + diff --git a/test/testdata/AddOneParameter/D1.expected.hs b/test/testdata/AddOneParameter/D1.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/D1.expected.hs @@ -0,0 +1,15 @@ +module AddOneParameter.D1 where + +{-add parameter 'f' to function 'sq' . This refactoring + affects module 'D1', 'C1' and 'A1'-} + +sumSquares (x:xs) = (sq sq_f) x + sumSquares xs + +sumSquares [] = 0 + +sq f x = x ^ pow + +sq_f = undefined + +pow =2 + diff --git a/test/testdata/AddOneParameter/D1.hs b/test/testdata/AddOneParameter/D1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/D1.hs @@ -0,0 +1,13 @@ +module AddOneParameter.D1 where + +{-add parameter 'f' to function 'sq' . This refactoring + affects module 'D1', 'C1' and 'A1'-} + +sumSquares (x:xs) = sq x + sumSquares xs + +sumSquares [] = 0 + +sq x = x ^ pow + +pow =2 + diff --git a/test/testdata/AddOneParameter/D2.expected.hs b/test/testdata/AddOneParameter/D2.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/D2.expected.hs @@ -0,0 +1,16 @@ +module AddOneParameter.D2 where + +{-add parameter 'f' to function 'sq' . This refactoring + affects module 'D2', 'C2' and 'A2'. It aims to test the + creating of default parameter name.-} + +sumSquares (x:xs) = (sq sq_f) x + sumSquares xs + +sumSquares [] = 0 + +sq f x = x ^ pow + +sq_f = undefined + +pow =2 + diff --git a/test/testdata/AddOneParameter/D2.hs b/test/testdata/AddOneParameter/D2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/D2.hs @@ -0,0 +1,14 @@ +module AddOneParameter.D2 where + +{-add parameter 'f' to function 'sq' . This refactoring + affects module 'D2', 'C2' and 'A2'. It aims to test the + creating of default parameter name.-} + +sumSquares (x:xs) = sq x + sumSquares xs + +sumSquares [] = 0 + +sq x = x ^ pow + +pow =2 + diff --git a/test/testdata/AddOneParameter/D3.expected.hs b/test/testdata/AddOneParameter/D3.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/D3.expected.hs @@ -0,0 +1,14 @@ +module AddOneParameter.D3(sumSquares,sumSquares_y) where + +{- add parameter 'y' to 'sumSquares'. 'sumSquares_y_1' to be added to the + export list -} + +sumSquares y (x:xs) = sq x + (sumSquares y) xs +sumSquares y [] = 0 + +sumSquares_y = undefined + +sq x = x ^ pow + +pow =2 + diff --git a/test/testdata/AddOneParameter/D3.hs b/test/testdata/AddOneParameter/D3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/D3.hs @@ -0,0 +1,12 @@ +module AddOneParameter.D3(sumSquares) where + +{- add parameter 'y' to 'sumSquares'. 'sumSquares_y_1' to be added to the + export list -} + +sumSquares (x:xs) = sq x + sumSquares xs +sumSquares [] = 0 + +sq x = x ^ pow + +pow =2 + diff --git a/test/testdata/AddOneParameter/FunIn1.expected.hs b/test/testdata/AddOneParameter/FunIn1.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/FunIn1.expected.hs @@ -0,0 +1,13 @@ +module FunIn1 where + +--Default parameters can be added to definition of functions and simple constants. + +--In this example: add parameter 'y' to 'foo' +foo :: a -> Int -> Int +foo y x= h + t where (h,t) = head $ zip [1..x] [3..15] {-There +is a comment-} + +foo_y = undefined + +main :: Int +main = (foo foo_y) 4 diff --git a/test/testdata/AddOneParameter/FunIn1.hs b/test/testdata/AddOneParameter/FunIn1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/FunIn1.hs @@ -0,0 +1,11 @@ +module FunIn1 where + +--Default parameters can be added to definition of functions and simple constants. + +--In this example: add parameter 'y' to 'foo' +foo :: Int -> Int +foo x= h + t where (h,t) = head $ zip [1..x] [3..15] {-There +is a comment-} + +main :: Int +main = foo 4 diff --git a/test/testdata/AddOneParameter/FunIn2.expected.hs b/test/testdata/AddOneParameter/FunIn2.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/FunIn2.expected.hs @@ -0,0 +1,13 @@ +module FunIn2 where + +--Default parameters can be added to definition of functions and simple constants. + +--In this example: add parameter 'y' to 'foo' + +main::Int->Int +main =(foo foo_y) where foo :: a -> Int -> Int + foo_y_1 =15 + foo y x= h + t where (h,t) = head $ zip [1..x] [3..foo_y_1] + + foo_y = undefined + diff --git a/test/testdata/AddOneParameter/FunIn2.hs b/test/testdata/AddOneParameter/FunIn2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/FunIn2.hs @@ -0,0 +1,11 @@ +module FunIn2 where + +--Default parameters can be added to definition of functions and simple constants. + +--In this example: add parameter 'y' to 'foo' + +main::Int->Int +main =foo where foo :: Int -> Int + foo_y_1 =15 + foo x= h + t where (h,t) = head $ zip [1..x] [3..foo_y_1] + diff --git a/test/testdata/AddOneParameter/FunIn3.expected.hs b/test/testdata/AddOneParameter/FunIn3.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/FunIn3.expected.hs @@ -0,0 +1,14 @@ +module FunIn3 where + +--Default parameters can be added to definition of functions and simple constants. + +--In this example: add parameter 'y' to 'foo' + +main::Int +main =let foo :: a -> Int -> Int + foo y x= h + t + where (h,t) = head $ zip [1..x] [3..15] + + foo_y = undefined in (let a=10 + b=10 + in (foo foo_y) 5+a+b) diff --git a/test/testdata/AddOneParameter/FunIn3.hs b/test/testdata/AddOneParameter/FunIn3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/FunIn3.hs @@ -0,0 +1,12 @@ +module FunIn3 where + +--Default parameters can be added to definition of functions and simple constants. + +--In this example: add parameter 'y' to 'foo' + +main::Int +main =let foo :: Int -> Int + foo x= h + t + where (h,t) = head $ zip [1..x] [3..15] in (let a=10 + b=10 + in foo 5+a+b) diff --git a/test/testdata/AddOneParameter/FunIn4.expected.hs b/test/testdata/AddOneParameter/FunIn4.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/FunIn4.expected.hs @@ -0,0 +1,11 @@ +module FunIn4 where + +--Default parameters can be added to definition of functions and simple constants. + +--In this example: add parameter 'y' to 'foo' + +main::Int +main = sum [x+4 |let foo y =[1..4] + + foo_y = undefined, x<-(foo foo_y)] + diff --git a/test/testdata/AddOneParameter/FunIn4.hs b/test/testdata/AddOneParameter/FunIn4.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/FunIn4.hs @@ -0,0 +1,9 @@ +module FunIn4 where + +--Default parameters can be added to definition of functions and simple constants. + +--In this example: add parameter 'y' to 'foo' + +main::Int +main = sum [x+4 |let foo =[1..4], x<-foo] + diff --git a/test/testdata/AddOneParameter/FunIn5.hs b/test/testdata/AddOneParameter/FunIn5.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/FunIn5.hs @@ -0,0 +1,12 @@ +module FunIn5 where + +--Default parameters can be added to definition of functions and simple constants. + +--In this example: add parameter 'h' to 'foo' will fail because of name clash. + +foo :: Int -> Int +foo x= h + t where (h,t) = head $ zip [1..x] [3..15] + +main :: Int +main = foo 4 + diff --git a/test/testdata/AddOneParameter/FunIn6.expected.hs b/test/testdata/AddOneParameter/FunIn6.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/FunIn6.expected.hs @@ -0,0 +1,13 @@ +module FunIn6 where + +--Default parameters can be added to definition of functions and simple constants. + +--In this example: add parameter 'y' to 'foo' + +main :: IO Integer +main = do + let foo y = return [1..4] + + foo_y = undefined + x <- (foo foo_y) + return (sum x) diff --git a/test/testdata/AddOneParameter/FunIn6.hs b/test/testdata/AddOneParameter/FunIn6.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/FunIn6.hs @@ -0,0 +1,11 @@ +module FunIn6 where + +--Default parameters can be added to definition of functions and simple constants. + +--In this example: add parameter 'y' to 'foo' + +main :: IO Integer +main = do + let foo = return [1..4] + x <- foo + return (sum x) diff --git a/test/testdata/AddOneParameter/MultiFun1.expected.hs b/test/testdata/AddOneParameter/MultiFun1.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/MultiFun1.expected.hs @@ -0,0 +1,13 @@ +module MultiFun1 where + +{- + +Add a parameter to every equation for the function foo. + +-} + +foo x [] = [] +foo x xs = [1] + +foo_x = undefined + diff --git a/test/testdata/AddOneParameter/MultiFun1.hs b/test/testdata/AddOneParameter/MultiFun1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/MultiFun1.hs @@ -0,0 +1,11 @@ +module MultiFun1 where + +{- + +Add a parameter to every equation for the function foo. + +-} + +foo [] = [] +foo xs = [1] + diff --git a/test/testdata/AddOneParameter/Nested.expected.hs b/test/testdata/AddOneParameter/Nested.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/Nested.expected.hs @@ -0,0 +1,14 @@ +module AddOneParameter.Nested(sumSquares,sumSquares_y) where + +{- add parameter 'y' to 'sumSquares'. 'sumSquares_y_1' to be added to the + export list -} + +sumSquares y (x:xs) = sq x + (sumSquares y) xs + foo xs + where foo a = (sumSquares y) a + 1 +sumSquares y [] = 0 + +sumSquares_y = undefined + +sq x = x ^ pow + +pow =2 diff --git a/test/testdata/AddOneParameter/Nested.hs b/test/testdata/AddOneParameter/Nested.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/Nested.hs @@ -0,0 +1,12 @@ +module AddOneParameter.Nested(sumSquares) where + +{- add parameter 'y' to 'sumSquares'. 'sumSquares_y_1' to be added to the + export list -} + +sumSquares (x:xs) = sq x + sumSquares xs + foo xs + where foo a = sumSquares a + 1 +sumSquares [] = 0 + +sq x = x ^ pow + +pow =2 diff --git a/test/testdata/AddOneParameter/PatIn1.expected.hs b/test/testdata/AddOneParameter/PatIn1.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/PatIn1.expected.hs @@ -0,0 +1,12 @@ +module PatIn1 where + +--Default parameters can be added to definition of functions and simple constants. + +--In this example: add parameter 'x' to 'foo' +foo :: a -> Int +foo x = h + t where (h,t) = head $ zip [1..10] [3..15] + +foo_x = undefined + +main :: Int +main = (foo foo_x) diff --git a/test/testdata/AddOneParameter/PatIn1.hs b/test/testdata/AddOneParameter/PatIn1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/PatIn1.hs @@ -0,0 +1,10 @@ +module PatIn1 where + +--Default parameters can be added to definition of functions and simple constants. + +--In this example: add parameter 'x' to 'foo' +foo :: Int +foo = h + t where (h,t) = head $ zip [1..10] [3..15] + +main :: Int +main = foo diff --git a/test/testdata/AddOneParameter/PatIn2.hs b/test/testdata/AddOneParameter/PatIn2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddOneParameter/PatIn2.hs @@ -0,0 +1,10 @@ +module PatIn2 where + +--Default parameters can be added to definition of functions and simple constants. + +--In this example: add parameter 'x' to '(h,t)' will fail. +foo :: Int +foo = h + t where (h,t) = head $ zip [1..10] [3..15] + +main :: Int +main = foo diff --git a/test/testdata/LiftOneLevel/C1.hs b/test/testdata/LiftOneLevel/C1.hs --- a/test/testdata/LiftOneLevel/C1.hs +++ b/test/testdata/LiftOneLevel/C1.hs @@ -3,10 +3,9 @@ import LiftOneLevel.D1 hiding (main) sumSquares1 (x:xs) = sq x + sumSquares1 xs - + sumSquares1 [] = 0 - + sq x =x ^pow pow = 2 - diff --git a/test/testdata/LiftOneLevel/C1.hs.expected b/test/testdata/LiftOneLevel/C1.hs.expected --- a/test/testdata/LiftOneLevel/C1.hs.expected +++ b/test/testdata/LiftOneLevel/C1.hs.expected @@ -9,4 +9,3 @@ sq x =x ^pow pow = 2 - diff --git a/test/testdata/LiftOneLevel/D1.hs b/test/testdata/LiftOneLevel/D1.hs --- a/test/testdata/LiftOneLevel/D1.hs +++ b/test/testdata/LiftOneLevel/D1.hs @@ -7,7 +7,7 @@ where sq x = x ^ pow pow =2 - + sumSquares [] = 0 main = sumSquares [1..4] diff --git a/test/testdata/Renaming/ConstructorIn3.hs b/test/testdata/Renaming/ConstructorIn3.hs --- a/test/testdata/Renaming/ConstructorIn3.hs +++ b/test/testdata/Renaming/ConstructorIn3.hs @@ -5,7 +5,7 @@ --Any type variable can be renamed. --Rename tyoe variable 'a' in BTree to 'b' - + data BTree a = Empty | T a (BTree a) (BTree a) deriving Show @@ -20,4 +20,4 @@ | otherwise = T tval (insert val left) right main :: BTree Int -main = buildtree [3,1,2] +main = buildtree [3,1,2] diff --git a/test/testdata/Renaming/D1.hs b/test/testdata/Renaming/D1.hs --- a/test/testdata/Renaming/D1.hs +++ b/test/testdata/Renaming/D1.hs @@ -2,9 +2,9 @@ {-Rename data constructor `Tree` to `AnotherTree`. This refactoring affects module `D1', 'B1' and 'C1' -} - -data Tree a = Leaf a | Branch (Tree a) (Tree a) +data Tree a = Leaf a | Branch (Tree a) (Tree a) + fringe :: Tree a -> [a] fringe (Leaf x ) = [x] fringe (Branch left right) = fringe left ++ fringe right @@ -18,7 +18,7 @@ isNotSame a b = a /= b sumSquares (x:xs) = sq x + sumSquares xs - where sq x = x ^pow + where sq x = x ^pow pow = 2 sumSquares [] = 0 diff --git a/test/testdata/Renaming/D3.hs b/test/testdata/Renaming/D3.hs --- a/test/testdata/Renaming/D3.hs +++ b/test/testdata/Renaming/D3.hs @@ -2,9 +2,9 @@ {-Rename class name 'SameOrNot' to 'Same'. This refactoring affects module `D3', 'B3' and 'C3' -} - -data Tree a = Leaf a | Branch (Tree a) (Tree a) +data Tree a = Leaf a | Branch (Tree a) (Tree a) + fringe :: Tree a -> [a] fringe (Leaf x ) = [x] fringe (Branch left right) = fringe left ++ fringe right @@ -18,7 +18,7 @@ isNotSame a b = a /= b sumSquares (x:xs) = sq x + sumSquares xs - where sq x = x ^pow + where sq x = x ^pow pow = 2 sumSquares [] = 0 diff --git a/test/testdata/Renaming/D4.hs b/test/testdata/Renaming/D4.hs --- a/test/testdata/Renaming/D4.hs +++ b/test/testdata/Renaming/D4.hs @@ -2,9 +2,9 @@ {-Rename instance name 'isSame'' to 'sameOrNot'. This refactoring affects module `D4', 'B4' and 'C4' -} - -data Tree a = Leaf a | Branch (Tree a) (Tree a) +data Tree a = Leaf a | Branch (Tree a) (Tree a) + fringe :: Tree a -> [a] fringe (Leaf x ) = [x] fringe (Branch left right) = fringe left ++ fringe right @@ -18,7 +18,7 @@ isNotSame a b = a /= b sumSquares (x:xs) = sq x + sumSquares xs - where sq x = x ^pow + where sq x = x ^pow pow = 2 sumSquares [] = 0 diff --git a/test/testdata/Renaming/LayoutIn2.hs b/test/testdata/Renaming/LayoutIn2.hs --- a/test/testdata/Renaming/LayoutIn2.hs +++ b/test/testdata/Renaming/LayoutIn2.hs @@ -8,6 +8,5 @@ silly list = case list of (1:xs) -> 1 --There is a comment (2:xs) - | x < 10 -> 4 where x = last xs - otherwise -> 12 - + | x < 10 -> 4 where x = last xs + otherwise -> 12 diff --git a/test/testdata/Renaming/LayoutIn2.hs.expected b/test/testdata/Renaming/LayoutIn2.hs.expected --- a/test/testdata/Renaming/LayoutIn2.hs.expected +++ b/test/testdata/Renaming/LayoutIn2.hs.expected @@ -10,4 +10,3 @@ (2:xs) | x < 10 -> 4 where x = last xs otherwise -> 12 - diff --git a/test/testdata/RmOneParameter/A1.expected.hs b/test/testdata/RmOneParameter/A1.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/A1.expected.hs @@ -0,0 +1,8 @@ +module RmOneParameter.A1 where + +import RmOneParameter.D1 + +sumSq xs ys= sum (map sq xs) + sumSquares xs + +main = sumSq [1..4] + diff --git a/test/testdata/RmOneParameter/A1.hs b/test/testdata/RmOneParameter/A1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/A1.hs @@ -0,0 +1,8 @@ +module RmOneParameter.A1 where + +import RmOneParameter.D1 + +sumSq xs ys= sum (map sq xs) + sumSquares xs ys + +main = sumSq [1..4] + diff --git a/test/testdata/RmOneParameter/A2.expected.hs b/test/testdata/RmOneParameter/A2.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/A2.expected.hs @@ -0,0 +1,8 @@ +module RmOneParameter.A2 where + +import RmOneParameter.D2 + +sumSq xs ys= sum (map sq xs) + sumSquares xs + +main = sumSq [1..4] + diff --git a/test/testdata/RmOneParameter/A2.hs b/test/testdata/RmOneParameter/A2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/A2.hs @@ -0,0 +1,8 @@ +module RmOneParameter.A2 where + +import RmOneParameter.D2 + +sumSq xs ys= sum (map sq xs) + sumSquares xs ys + +main = sumSq [1..4] + diff --git a/test/testdata/RmOneParameter/D1.expected.hs b/test/testdata/RmOneParameter/D1.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/D1.expected.hs @@ -0,0 +1,13 @@ +module RmOneParameter.D1 where + +{-remove parameter 'ys' from function 'sumSquares'. This refactoring + affects module 'D1', and 'A1'-} + +sumSquares (x:xs) = sq x + sumSquares xs + +sumSquares [] = 0 + +sq x = x ^ pow + +pow =2 + diff --git a/test/testdata/RmOneParameter/D1.hs b/test/testdata/RmOneParameter/D1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/D1.hs @@ -0,0 +1,13 @@ +module RmOneParameter.D1 where + +{-remove parameter 'ys' from function 'sumSquares'. This refactoring + affects module 'D1', and 'A1'-} + +sumSquares (x:xs) ys = sq x + sumSquares xs xs + +sumSquares [] ys = 0 + +sq x = x ^ pow + +pow =2 + diff --git a/test/testdata/RmOneParameter/D2.expected.hs b/test/testdata/RmOneParameter/D2.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/D2.expected.hs @@ -0,0 +1,14 @@ +module RmOneParameter.D2 where + +{-remove parameter 'ys' from function 'sumSquares'. This refactoring + affects module 'D1', and 'A1'. This aims to test removing a + parameter from a recursion function-} + +sumSquares (x:xs) = sq x + sumSquares xs + +sumSquares [] = 0 + +sq x = x ^ pow + +pow =2 + diff --git a/test/testdata/RmOneParameter/D2.hs b/test/testdata/RmOneParameter/D2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/D2.hs @@ -0,0 +1,14 @@ +module RmOneParameter.D2 where + +{-remove parameter 'ys' from function 'sumSquares'. This refactoring + affects module 'D1', and 'A1'. This aims to test removing a + parameter from a recursion function-} + +sumSquares (x:xs) ys = sq x + sumSquares xs ys + +sumSquares [] ys = 0 + +sq x = x ^ pow + +pow =2 + diff --git a/test/testdata/RmOneParameter/FunIn0.expected.hs b/test/testdata/RmOneParameter/FunIn0.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/FunIn0.expected.hs @@ -0,0 +1,13 @@ +module FunIn0 where + +--Any unused parameter to a definition can be removed. + +--To select a formal parameter, just need to stop the cursor at any position between the start +--end position of this formal paramter. + +--In this example, remove '[x,y]' + +foo = h + t where (h,t) = head $ zip [1..10] [3..10] + +main :: Int +main = foo diff --git a/test/testdata/RmOneParameter/FunIn0.hs b/test/testdata/RmOneParameter/FunIn0.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/FunIn0.hs @@ -0,0 +1,13 @@ +module FunIn0 where + +--Any unused parameter to a definition can be removed. + +--To select a formal parameter, just need to stop the cursor at any position between the start +--end position of this formal paramter. + +--In this example, remove '[x,y]' + +foo [x,y]= h + t where (h,t) = head $ zip [1..10] [3..10] + +main :: Int +main = foo [4,5] diff --git a/test/testdata/RmOneParameter/FunIn1.expected.hs b/test/testdata/RmOneParameter/FunIn1.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/FunIn1.expected.hs @@ -0,0 +1,12 @@ +module FunIn1 where + +--Any unused parameter to a definition can be removed. + +--In this example: remove the parameter 'x' to 'foo' + +foo :: Int +foo = h + t where (h,t) = head $ zip [1..7] [3..15] + +main :: Int +main = foo + diff --git a/test/testdata/RmOneParameter/FunIn1.hs b/test/testdata/RmOneParameter/FunIn1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/FunIn1.hs @@ -0,0 +1,12 @@ +module FunIn1 where + +--Any unused parameter to a definition can be removed. + +--In this example: remove the parameter 'x' to 'foo' + +foo :: Int -> Int +foo x= h + t where (h,t) = head $ zip [1..7] [3..15] + +main :: Int +main = foo 4 + diff --git a/test/testdata/RmOneParameter/FunIn2.expected.hs b/test/testdata/RmOneParameter/FunIn2.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/FunIn2.expected.hs @@ -0,0 +1,16 @@ +module FunIn2 where + +--Any unused parameter to a definition can be removed. + +--In this example: remove the parameter 'x' to 'foo' + +inc :: Int -> Int + +foo :: Int +foo = h + t where (h,t) = head $ zip [1..7] [3..15] + +inc x=x+1 + +main :: Int +main = foo + diff --git a/test/testdata/RmOneParameter/FunIn2.hs b/test/testdata/RmOneParameter/FunIn2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/FunIn2.hs @@ -0,0 +1,14 @@ +module FunIn2 where + +--Any unused parameter to a definition can be removed. + +--In this example: remove the parameter 'x' to 'foo' + +foo,inc :: Int -> Int +foo x= h + t where (h,t) = head $ zip [1..7] [3..15] + +inc x=x+1 + +main :: Int +main = foo 4 + diff --git a/test/testdata/RmOneParameter/FunIn2a.expected.hs b/test/testdata/RmOneParameter/FunIn2a.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/FunIn2a.expected.hs @@ -0,0 +1,16 @@ +module FunIn2a where + +--Any unused parameter to a definition can be removed. + +--In this example: remove the parameter 'x' to 'foo' + +inc :: Int -> Int + +foo :: Int +foo = h + t where (h,t) = head $ zip [1..7] [3..15] + +inc x=x+1 + +main :: Int +main = foo + diff --git a/test/testdata/RmOneParameter/FunIn2a.hs b/test/testdata/RmOneParameter/FunIn2a.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/FunIn2a.hs @@ -0,0 +1,14 @@ +module FunIn2a where + +--Any unused parameter to a definition can be removed. + +--In this example: remove the parameter 'x' to 'foo' + +inc,foo :: Int -> Int +foo x= h + t where (h,t) = head $ zip [1..7] [3..15] + +inc x=x+1 + +main :: Int +main = foo 4 + diff --git a/test/testdata/RmOneParameter/FunIn3.expected.hs b/test/testdata/RmOneParameter/FunIn3.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/FunIn3.expected.hs @@ -0,0 +1,11 @@ +module FunIn3 where + +--Any unused parameter to a definition can be removed. + +--In this example: remove the parameter 'x' (or 'z') to 'foo' + +foo y = h + t where (h,t) = head $ zip [1..7] [3..y] + +main :: Int +main = foo 20 + diff --git a/test/testdata/RmOneParameter/FunIn3.hs b/test/testdata/RmOneParameter/FunIn3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/FunIn3.hs @@ -0,0 +1,11 @@ +module FunIn3 where + +--Any unused parameter to a definition can be removed. + +--In this example: remove the parameter 'x' (or 'z') to 'foo' + +foo z@x y = h + t where (h,t) = head $ zip [1..7] [3..y] + +main :: Int +main = foo 10 20 + diff --git a/test/testdata/RmOneParameter/FunIn4.expected.hs b/test/testdata/RmOneParameter/FunIn4.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/FunIn4.expected.hs @@ -0,0 +1,11 @@ +module FunIn4 where + +--Any unused parameter to a definition can be removed. + +--In this example: remove 'x' will fail, as (x,y) is treated as one parameter and 'y' is used. + +foo (x,y) = h + t where (h,t) = head $ zip [1..7] [3..y] + +main :: Int +main = foo (10, 20) + diff --git a/test/testdata/RmOneParameter/FunIn4.hs b/test/testdata/RmOneParameter/FunIn4.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/FunIn4.hs @@ -0,0 +1,11 @@ +module FunIn4 where + +--Any unused parameter to a definition can be removed. + +--In this example: remove 'x' will fail, as (x,y) is treated as one parameter and 'y' is used. + +foo (x,y) = h + t where (h,t) = head $ zip [1..7] [3..y] + +main :: Int +main = foo (10, 20) + diff --git a/test/testdata/RmOneParameter/FunIn5.expected.hs b/test/testdata/RmOneParameter/FunIn5.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/FunIn5.expected.hs @@ -0,0 +1,13 @@ +module FunIn5 where + +--Any unused parameter to a definition can be removed. + +--In this example: remove (x,y) (stop the cursor at 'x' or 'y') + +foo = h + t where (h,t) = head $ zip [1..a] [3..b] + a=10 + b=17 + +main :: Int +main = foo + diff --git a/test/testdata/RmOneParameter/FunIn5.hs b/test/testdata/RmOneParameter/FunIn5.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/FunIn5.hs @@ -0,0 +1,13 @@ +module FunIn5 where + +--Any unused parameter to a definition can be removed. + +--In this example: remove (x,y) (stop the cursor at 'x' or 'y') + +foo (x,y) = h + t where (h,t) = head $ zip [1..a] [3..b] + a=10 + b=17 + +main :: Int +main = foo (10, 20) + diff --git a/test/testdata/RmOneParameter/FunIn6.expected.hs b/test/testdata/RmOneParameter/FunIn6.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/FunIn6.expected.hs @@ -0,0 +1,10 @@ +module FunIn6 where + +--Any unused parameter to a definition can be removed. + +--In this example: remove x. The brackets enclosing 'foo' will also be removed. + +foo = h + t where (h,t) = head $ zip [1..10] [3..10] + +main :: Int +main = foo + foo diff --git a/test/testdata/RmOneParameter/FunIn6.hs b/test/testdata/RmOneParameter/FunIn6.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/FunIn6.hs @@ -0,0 +1,10 @@ +module FunIn6 where + +--Any unused parameter to a definition can be removed. + +--In this example: remove x. The brackets enclosing 'foo' will also be removed. + +foo x = h + t where (h,t) = head $ zip [1..10] [3..10] + +main :: Int +main = (foo 4) + (foo 5) diff --git a/test/testdata/RmOneParameter/FunIn7.expected.hs b/test/testdata/RmOneParameter/FunIn7.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/FunIn7.expected.hs @@ -0,0 +1,13 @@ +module FunIn7 where + +--Any unused parameter to a definition can be removed. + +--To select a formal parameter, just need to stop the cursor at any position between the start +--end position of this formal paramter. + +--In this example, remove '[x,y]' with a invalid cursor position + +foo [x,y]= h + t where (h,t) = head $ zip [1..10] [3..10] + +main :: Int +main = foo [4,5] diff --git a/test/testdata/RmOneParameter/FunIn7.hs b/test/testdata/RmOneParameter/FunIn7.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/FunIn7.hs @@ -0,0 +1,13 @@ +module FunIn7 where + +--Any unused parameter to a definition can be removed. + +--To select a formal parameter, just need to stop the cursor at any position between the start +--end position of this formal paramter. + +--In this example, remove '[x,y]' with a invalid cursor position + +foo [x,y]= h + t where (h,t) = head $ zip [1..10] [3..10] + +main :: Int +main = foo [4,5] diff --git a/test/testdata/RmOneParameter/MultiFun1.expected.hs b/test/testdata/RmOneParameter/MultiFun1.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/MultiFun1.expected.hs @@ -0,0 +1,11 @@ +module MultiFun1 where + +{- + +Remove the second parameter from every equation for the function foo. + +-} + +foo [] = [] +foo xs = [1] + diff --git a/test/testdata/RmOneParameter/MultiFun1.hs b/test/testdata/RmOneParameter/MultiFun1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/MultiFun1.hs @@ -0,0 +1,11 @@ +module MultiFun1 where + +{- + +Remove the second parameter from every equation for the function foo. + +-} + +foo [] x = [] +foo xs x = [1] + diff --git a/test/testdata/RmOneParameter/SubFun1.expected.hs b/test/testdata/RmOneParameter/SubFun1.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/SubFun1.expected.hs @@ -0,0 +1,10 @@ +module SubFun1 where + +--Any unused parameter to a definition can be removed. + +--In this example: remove x. The brackets enclosing 'foo' will also be removed. + +main :: Int +main = foo + foo + where + foo = h + t where (h,t) = head $ zip [1..10] [3..10] diff --git a/test/testdata/RmOneParameter/SubFun1.hs b/test/testdata/RmOneParameter/SubFun1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/SubFun1.hs @@ -0,0 +1,10 @@ +module SubFun1 where + +--Any unused parameter to a definition can be removed. + +--In this example: remove x. The brackets enclosing 'foo' will also be removed. + +main :: Int +main = (foo 4) + (foo 5) + where + foo x = h + t where (h,t) = head $ zip [1..10] [3..10] diff --git a/test/testdata/RmOneParameter/SubFun2.expected.hs b/test/testdata/RmOneParameter/SubFun2.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/SubFun2.expected.hs @@ -0,0 +1,12 @@ +module SubFun2 where + +--Any unused parameter to a definition can be removed. + +--In this example: remove x. The brackets enclosing 'foo' will also be removed. + +main :: Int +main = + let + foo = h + t where (h,t) = head $ zip [1..10] [3..10] + in + foo + foo diff --git a/test/testdata/RmOneParameter/SubFun2.hs b/test/testdata/RmOneParameter/SubFun2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/SubFun2.hs @@ -0,0 +1,12 @@ +module SubFun2 where + +--Any unused parameter to a definition can be removed. + +--In this example: remove x. The brackets enclosing 'foo' will also be removed. + +main :: Int +main = + let + foo x = h + t where (h,t) = head $ zip [1..10] [3..10] + in + (foo 4) + (foo 5) diff --git a/test/testdata/RmOneParameter/SubFun3.expected.hs b/test/testdata/RmOneParameter/SubFun3.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/SubFun3.expected.hs @@ -0,0 +1,11 @@ +module SubFun3 where + +--Any unused parameter to a definition can be removed. + +--In this example: remove x. The brackets enclosing 'foo' will also be removed. + +main :: IO Int +main = do + let + foo = h + t where (h,t) = head $ zip [1..10] [3..10] + return $ foo + foo diff --git a/test/testdata/RmOneParameter/SubFun3.hs b/test/testdata/RmOneParameter/SubFun3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmOneParameter/SubFun3.hs @@ -0,0 +1,11 @@ +module SubFun3 where + +--Any unused parameter to a definition can be removed. + +--In this example: remove x. The brackets enclosing 'foo' will also be removed. + +main :: IO Int +main = do + let + foo x = h + t where (h,t) = head $ zip [1..10] [3..10] + return $ (foo 4) + (foo 5) diff --git a/test/testdata/cabal/foo/foo.cabal b/test/testdata/cabal/foo/foo.cabal --- a/test/testdata/cabal/foo/foo.cabal +++ b/test/testdata/cabal/foo/foo.cabal @@ -16,7 +16,7 @@ cabal-version: >=1.10 Library - Build-Depends: base >= 4.0 && < 4.9 + Build-Depends: base >= 4.0 && < 5 Hs-Source-Dirs: src Exposed-modules: Foo.Bar @@ -27,6 +27,6 @@ main-is: Main.hs -- other-modules: -- other-extensions: - build-depends: base >=4.8 && <4.9 + build-depends: base >=4.8 && < 5 hs-source-dirs: src default-language: Haskell2010 diff --git a/test/testdata/testdata.cabal b/test/testdata/testdata.cabal --- a/test/testdata/testdata.cabal +++ b/test/testdata/testdata.cabal @@ -8,80 +8,80 @@ Executable bcpp Main-Is: BCpp.hs - Build-Depends: base >= 4.0 && < 4.9 + Build-Depends: base >= 4.0 && < 5 , syb default-language: Haskell2010 Executable foo Main-Is: TokenTest.hs - Build-Depends: base >= 4.0 && < 4.9 + Build-Depends: base >= 4.0 && < 5 , syb default-language: Haskell2010 Executable dd2 Main-Is: DupDef/Dd2.hs - Build-Depends: base >= 4.0 && < 4.9 + Build-Depends: base >= 4.0 && < 5 , syb default-language: Haskell2010 Executable dd3 Main-Is: DupDef/Dd3.hs - Build-Depends: base >= 4.0 && < 4.9 + Build-Depends: base >= 4.0 && < 5 default-language: Haskell2010 Executable m Main-Is: M.hs Hs-Source-Dirs: . - Build-Depends: base >= 4.0 && < 4.9 + Build-Depends: base >= 4.0 && < 5 , syb default-language: Haskell2010 Executable a1 Main-Is: Renaming/A1.hs - Build-Depends: base >= 4.0 && < 4.9 + Build-Depends: base >= 4.0 && < 5 , syb default-language: Haskell2010 Executable a2 Main-Is: Renaming/A2.hs - Build-Depends: base >= 4.0 && < 4.9 + Build-Depends: base >= 4.0 && < 5 , syb default-language: Haskell2010 Executable a3 Main-Is: Renaming/A3.hs - Build-Depends: base >= 4.0 && < 4.9 + Build-Depends: base >= 4.0 && < 5 , syb default-language: Haskell2010 Executable a4 Main-Is: Renaming/A4.hs - Build-Depends: base >= 4.0 && < 4.9 + Build-Depends: base >= 4.0 && < 5 , syb default-language: Haskell2010 Executable a5 Main-Is: Renaming/A5.hs - Build-Depends: base >= 4.0 && < 4.9 + Build-Depends: base >= 4.0 && < 5 , syb default-language: Haskell2010 Executable c7 Main-Is: Renaming/C7.hs Other-Modules : Renaming.D7 - Build-Depends: base >= 4.0 && < 4.9 + Build-Depends: base >= 4.0 && < 5 , syb default-language: Haskell2010 Executable qualclient Main-Is: Renaming/QualClient.hs - Build-Depends: base >= 4.0 && < 4.9 + Build-Depends: base >= 4.0 && < 5 , syb default-language: Haskell2010 Executable th Main-Is: TH/Main.hs - Build-Depends: base >= 4.0 && < 4.9 + Build-Depends: base >= 4.0 && < 5 , syb , template-haskell default-language: Haskell2010 @@ -93,7 +93,7 @@ Main-Is: LiftToToplevel/A1.hs Other-Modules : LiftToToplevel.C1 LiftToToplevel.D1 - Build-Depends: base >= 4.0 && < 4.9 + Build-Depends: base >= 4.0 && < 5 default-language: Haskell2010 @@ -102,7 +102,7 @@ Main-Is: LiftToToplevel/A2.hs Other-Modules : LiftToToplevel.C2 LiftToToplevel.D2 - Build-Depends: base >= 4.0 && < 4.9 + Build-Depends: base >= 4.0 && < 5 default-language: Haskell2010 -- --------------------------------------------------------------------- @@ -111,7 +111,7 @@ Main-Is: LiftOneLevel/A1.hs Other-Modules : LiftOneLevel.C1 LiftOneLevel.D1 - Build-Depends: base >= 4.0 && < 4.9 + Build-Depends: base >= 4.0 && < 5 default-language: Haskell2010 @@ -119,7 +119,7 @@ Main-Is: LiftOneLevel/A2.hs Other-Modules : LiftOneLevel.C2 LiftOneLevel.D2 - Build-Depends: base >= 4.0 && < 4.9 + Build-Depends: base >= 4.0 && < 5 default-language: Haskell2010 @@ -127,7 +127,7 @@ Main-Is: LiftOneLevel/A3.hs Other-Modules : LiftOneLevel.C3 LiftOneLevel.D3 - Build-Depends: base >= 4.0 && < 4.9 + Build-Depends: base >= 4.0 && < 5 default-language: Haskell2010 -- --------------------------------------------------------------------- @@ -136,7 +136,7 @@ Main-Is: Demote/A1.hs Other-Modules : Demote.C1 Demote.D1 - Build-Depends: base >= 4.0 && < 4.9 + Build-Depends: base >= 4.0 && < 5 default-language: Haskell2010 @@ -144,7 +144,7 @@ Main-Is: Demote/A2.hs Other-Modules : Demote.C2 Demote.D2 - Build-Depends: base >= 4.0 && < 4.9 + Build-Depends: base >= 4.0 && < 5 default-language: Haskell2010 -- --------------------------------------------------------------------- @@ -152,5 +152,45 @@ Executable qualified Main-Is: TypeUtils/Qualified.hs Other-Modules : TypeUtils.C - Build-Depends: base >= 4.0 && < 4.9 + Build-Depends: base >= 4.0 && < 5 default-language: Haskell2010 + +-- --------------------------------------------------------------------- + +Executable addoneparama1 + Main-Is: AddOneParameter/A1.hs + Other-Modules : AddOneParameter.C1 + Other-Modules : AddOneParameter.D1 + Build-Depends: base >= 4.0 && < 5 + default-language: Haskell2010 + +Executable addoneparama2 + Main-Is: AddOneParameter/A2.hs + Other-Modules : AddOneParameter.C2 + Other-Modules : AddOneParameter.D2 + Build-Depends: base >= 4.0 && < 5 + default-language: Haskell2010 + +Executable addoneparama3 + Main-Is: AddOneParameter/A3.hs + Other-Modules : AddOneParameter.D3 + Build-Depends: base >= 4.0 && < 5 + default-language: Haskell2010 + +-- --------------------------------------------------------------------- + +Executable rmoneparama1 + Main-Is: RmOneParameter/A1.hs + Other-Modules : RmOneParameter.D1 + Build-Depends: base >= 4.0 && < 5 + default-language: Haskell2010 + +-- --------------------------------------------------------------------- + +Executable rmoneparama2 + Main-Is: RmOneParameter/A2.hs + Other-Modules : RmOneParameter.D2 + Build-Depends: base >= 4.0 && < 5 + default-language: Haskell2010 + +-- ---------------------------------------------------------------------