HaRe 0.7.1.7 → 0.7.2.0
raw patch · 25 files changed
+7160/−9615 lines, 25 filesdep ~HaRe
Dependency ranges changed: HaRe
Files
- ChangeLog +8/−0
- HaRe.cabal +12/−11
- src/Language/Haskell/Refact/API.hs +381/−0
- src/Language/Haskell/Refact/Case.hs +0/−235
- src/Language/Haskell/Refact/DupDef.hs +0/−268
- src/Language/Haskell/Refact/HaRe.hs +28/−0
- src/Language/Haskell/Refact/MoveDef.hs +0/−1569
- src/Language/Haskell/Refact/Refactoring/Case.hs +228/−0
- src/Language/Haskell/Refact/Refactoring/DupDef.hs +232/−0
- src/Language/Haskell/Refact/Refactoring/MoveDef.hs +1475/−0
- src/Language/Haskell/Refact/Refactoring/Renaming.hs +350/−0
- src/Language/Haskell/Refact/Refactoring/SwapArgs.hs +110/−0
- src/Language/Haskell/Refact/Renaming.hs +0/−658
- src/Language/Haskell/Refact/SwapArgs.hs +0/−158
- src/Language/Haskell/Refact/Utils/DualTree.hs +0/−38
- src/Language/Haskell/Refact/Utils/Layout.hs +10/−2
- src/Language/Haskell/Refact/Utils/LayoutTypes.hs +0/−8
- src/Language/Haskell/Refact/Utils/LocUtils.hs +1/−358
- src/Language/Haskell/Refact/Utils/Monad.hs +3/−2
- src/Language/Haskell/Refact/Utils/MonadFunctions.hs +0/−40
- src/Language/Haskell/Refact/Utils/RenamedSourceUtils.hs +0/−33
- src/Language/Haskell/Refact/Utils/TokenUtils.hs +21/−570
- src/Language/Haskell/Refact/Utils/TypeUtils.hs +4293/−5547
- src/Language/Haskell/Refact/Utils/Utils.hs +2/−92
- src/MainHaRe.hs +6/−26
ChangeLog view
@@ -1,3 +1,11 @@+2014-03-23 v0.7.2.0+ * Reorganised package structure to have+ Language.Haskell.Refact.HaRe which provides all the functions+ needed to call the refactorer from external code, and+ Language.Haskell.Refact.API which provides the interfaces to write+ new refactorings+ * liftToMod of last local decl having preceding comment now removes 'where'+ * Correctly determine the location for a demoted decl 2014-03-22 v0.7.1.7 * Correctly determine what parameters to add when lifting a decl * Do not demote a decl if it is used in more than one match
HaRe.cabal view
@@ -1,5 +1,5 @@ Name: HaRe-Version: 0.7.1.7+Version: 0.7.2.0 Author: Chris Brown, Huiqing Li, Simon Thompson, Alan Zimmerman Maintainer: Alan Zimmerman Stability: Alpha@@ -26,7 +26,8 @@ process the original file is renamed to have the current date/time as a suffix. Thus it should be possible to (manually) undo changes. .- The renaming refactoring seems reasonably reliable, as does lifting.+ The renaming refactoring seems reasonably reliable, as does lifting+ and demoting . Synopsis: the Haskell Refactorer.@@ -69,11 +70,13 @@ Hs-Source-Dirs: src -- Other-Modules: Paths_HaRe Exposed-modules:- Language.Haskell.Refact.Case- , Language.Haskell.Refact.DupDef- , Language.Haskell.Refact.MoveDef- , Language.Haskell.Refact.Renaming- , Language.Haskell.Refact.SwapArgs+ Language.Haskell.Refact.API+ , Language.Haskell.Refact.HaRe+ , Language.Haskell.Refact.Refactoring.Case+ , Language.Haskell.Refact.Refactoring.DupDef+ , Language.Haskell.Refact.Refactoring.MoveDef+ , Language.Haskell.Refact.Refactoring.Renaming+ , Language.Haskell.Refact.Refactoring.SwapArgs , Language.Haskell.Refact.Utils.DualTree , Language.Haskell.Refact.Utils.GhcBugWorkArounds , Language.Haskell.Refact.Utils.GhcModuleGraph@@ -84,7 +87,6 @@ , Language.Haskell.Refact.Utils.LocUtils , Language.Haskell.Refact.Utils.Monad , Language.Haskell.Refact.Utils.MonadFunctions- , Language.Haskell.Refact.Utils.RenamedSourceUtils , Language.Haskell.Refact.Utils.TokenUtils , Language.Haskell.Refact.Utils.TokenUtilsTypes , Language.Haskell.Refact.Utils.TypeSyn@@ -129,7 +131,7 @@ , hslogger , Strafunski-StrategyLib , syz- , HaRe >= 0.7.0.8+ , HaRe >= 0.7.1.6 Extensions: CPP @@ -169,7 +171,6 @@ , ghc-syb-utils , ghc-mod >= 3.1.6 , hspec- -- , hspec-discover , mtl , old-time , process@@ -182,7 +183,7 @@ , hslogger , Strafunski-StrategyLib , syz- , HaRe >= 0.7.0.8+ , HaRe >= 0.7.1.6 Extensions: CPP source-repository head
+ src/Language/Haskell/Refact/API.hs view
@@ -0,0 +1,381 @@+module Language.Haskell.Refact.API+ (+ -- * from `Language.Haskell.Refact.Utils.Monad`+ ParseResult+ , VerboseLevel(..)+ , RefactSettings(..)+ , TargetModule+ , RefactFlags(..)+ , StateStorage(..)++ -- ** The GHC Monad+ , RefactGhc+ , runRefactGhc+ , getRefacSettings+ , defaultSettings+ , logSettings+ , initGhcSession++ , loadModuleGraphGhc+ , ensureTargetLoaded+ , canonicalizeGraph++ , logm++ -- * from `Language.Haskell.Refact.Utils.Utils`+ , sameOccurrence++ -- ** Managing the GHC / project environment+ -- , loadModuleGraphGhc+ , getModuleGhc+ , parseSourceFileGhc+ , activateModule+ , getModuleDetails++ -- ** The bits that do the work+ , runRefacSession+ , applyRefac+ , refactDone+ , ApplyRefacResult+ , RefacSource(..)++ , update+ , fileNameToModName+ , fileNameFromModSummary+ , getModuleName+ , clientModsAndFiles+ , serverModsAndFiles+++ -- * from `Language.Haskell.Refact.Utils.MonadFunctions`++ -- ** Conveniences for state access++ , fetchToksFinal+ , fetchLinesFinal+ , fetchOrigToks+ , fetchToks -- Deprecated+ , getTypecheckedModule+ , getRefactStreamModified+ , getRefactInscopes+ , getRefactRenamed+ , putRefactRenamed+ , getRefactParsed+ , putParsedModule+ , clearParsedModule+ , getRefactFileName++ -- ** TokenUtils API+ , replaceToken+ , putToksForSpan+ , putDeclToksForSpan+ , getToksForSpan+ , getToksForSpanNoInv+ , getToksForSpanWithIntros+ , getToksBeforeSpan+ , putToksForPos+ , putToksAfterSpan+ , putToksAfterPos+ , putDeclToksAfterSpan+ , removeToksForSpan+ , removeToksForPos+ , syncDeclToLatestStash+ , indentDeclAndToks++ -- ** LayoutUtils API++ -- ** For debugging+ , drawTokenTree+ , drawTokenTreeDetailed+ , getTokenTree+ , showLinesDebug++ -- ** State flags for managing generic traversals+ , getRefactDone+ , setRefactDone+ , clearRefactDone++ , setStateStorage+ , getStateStorage++ -- , logm++ , updateToks+ , updateToksWithPos++ -- * from `Language.Haskell.Refact.Utils.LocUtils`++ , SimpPos,unmodified,modified+ , simpPos0+ , nullSrcSpan+ , showToks+ , whiteSpaceTokens+ , realSrcLocFromTok+ , isWhite+ , notWhite+ , isWhiteSpace+ , isWhiteSpaceOrIgnored+ , isIgnored+ , isIgnoredNonComment+ {-+ ,isNewLn,isCommentStart -},isComment {-,+ isNestedComment-},isMultiLineComment {-,isOpenBracket,isCloseBracket, -}+ ,isOpenSquareBracket,isCloseSquareBracket {- ,isOpenBrace,isConid,+ isLit,isWhereOrLet,isWhere,isLet-},isIn {- ,isCase,isDo,isIf,isForall,+ isHiding,isModule-} ,isComma {-,isEqual,isLambda,isIrrefute -},isBar --,isMinus,+ ,endsWithNewLn,startsWithNewLn,hasNewLn {- ,startsWithEmptyLn,+ lastNonSpaceToken,firstNonSpaceToken -} ,compressPreNewLns,compressEndNewLns++ , lengthOfLastLine+ , getToks+ -- , replaceToks,replaceTok+ ,replaceTokNoReAlign,deleteToks,doRmWhites -- ,doAddWhites+ , srcLocs+ , getSrcSpan, getAllSrcLocs+ -- , ghcSrcLocs -- Test version+ -- , getLocatedStart+ -- , getLocatedEnd+ , getBiggestStartEndLoc+ {-+ , getStartEndLoc2,+ startEndLoc,extendBothSides -},extendForwards,extendBackwards+ , startEndLocIncFowComment{- ,startEndLocIncFowNewLn -}+ , startEndLocIncComments, startEndLocIncComments'+ , tokenise+ , basicTokenise+ , prettyprintPatList+ , groupTokensByLine+ , toksOnSameLine+ , addLocInfo+ -- , getIndentOffset+ , getLineOffset+ -- , splitToks+ -- , splitOnNewLn+ {-+ , insertComments,+ extractComments, insertTerms+ -}+ , tokenCol+ , tokenColEnd+ , tokenRow+ , tokenPos+ , tokenPosEnd+ , tokenSrcSpan+ , tokenCon+ , increaseSrcSpan+ , getGhcLoc+ , getGhcLocEnd+ , getLocatedStart+ , getLocatedEnd+ , getStartEndLoc+ , startEndLocGhc+ , realSrcLocEndTok+ , fileNameFromTok+ , splitToks+ , emptyList, nonEmptyList+ , divideComments+ , notWhiteSpace+ , isDoubleColon+ , isEmpty+ , isWhereOrLet+ , isWhere+ , isLet+ , isElse+ , isThen+ , isOf+ , isDo+ , getIndentOffset+ , splitOnNewLn+ , tokenLen+ , newLnToken+ , newLinesToken+ , monotonicLineToks+ , reSequenceToks+ , mkToken+ , mkZeroToken+ , markToken+ , isMarked+ , addOffsetToToks+ , matchTokenPos+ , rmOffsetFromToks++ -- * from `Language.Haskell.Refact.Utils.TypeSyn`+ , InScopes+ , PosToken(..)+ , ghead+ , glast+ , gtail+ , gfromJust++ -- * from `Language.Haskell.Refact.Utils.TypeUtils`++ -- ** Program Analysis+ -- ** Imports and exports+ , inScopeInfo, isInScopeAndUnqualified, isInScopeAndUnqualifiedGhc, inScopeNames+ -- , hsQualifier, {-This function should be removed-} rmPrelude+ {-,exportInfo -}, isExported, isExplicitlyExported, modIsExported++ -- *** Variable analysis+ , isFieldName+ , isClassName+ , isInstanceName+ ,hsPNs -- ,hsDataConstrs,hsTypeConstrsAndClasses, hsTypeVbls+ {- ,hsClassMembers -} , hsBinds, replaceBinds, HsValBinds(..)+ ,isDeclaredIn+ ,hsFreeAndDeclaredPNsOld, hsFreeAndDeclaredNameStrings+ ,hsFreeAndDeclaredPNs+ ,hsFreeAndDeclaredGhc+ ,getDeclaredTypes+ ,getFvs, getFreeVars, getDeclaredVars -- These two should replace hsFreeAndDeclaredPNs++ ,hsVisiblePNs {- , hsVisiblePNsOld -}, hsVisibleNames+ ,hsFDsFromInside, hsFDNamesFromInside+ ,hsVisibleDs++ -- *** Property checking+ ,isVarId,isConId,isOperator,isTopLevelPN,isLocalPN,isNonLibraryName -- ,isTopLevelPNT+ ,isQualifiedPN {- , isFunName, isPatName-}, isFunOrPatName {-,isTypeCon-} ,isTypeSig+ ,isFunBindP,isFunBindR,isPatBindP,isPatBindR,isSimplePatBind+ ,isComplexPatBind,isFunOrPatBindP,isFunOrPatBindR -- ,isClassDecl,isInstDecl -- ,isDirectRecursiveDef+ ,usedWithoutQualR {- ,canBeQualified, hasFreeVars -},isUsedInRhs+ ,findPNT,findPN,findAllNameOccurences+ ,findPNs, findEntity, findEntity'+ ,sameOccurrence+ ,defines, definesP,definesTypeSig -- , isTypeSigOf+ -- ,HasModName(hasModName), HasNameSpace(hasNameSpace)+ ,sameBind+ {- ,usedByRhs -},UsedByRhs(..)++ -- *** Modules and files+ -- ,clientModsAndFiles,serverModsAndFiles,isAnExistingMod+ -- ,fileNameToModName, strToModName, modNameToStr+ , isMainModule+ , getModule++ -- *** Locations+ ,defineLoc, useLoc, locToExp -- , getStartEndLoc+ ,locToName, locToRdrName+ ,getName++ -- * Program transformation+ -- *** Adding+ ,addDecl, addItemsToImport, addHiding --, rmItemsFromImport, addItemsToExport+ ,addParamsToDecls, addActualParamsToRhs {- , addGuardsToRhs-}, addImportDecl, duplicateDecl -- , moveDecl+ -- *** Removing+ ,rmDecl, rmTypeSig, rmTypeSigs -- , commentOutTypeSig, rmParams+ -- ,rmItemsFromExport, rmSubEntsFromExport, Delete(delete)++ -- *** Updating+ -- ,Update(update)+ {- ,qualifyPName-},rmQualifier,qualifyToplevelName,renamePN {- ,replaceNameInPN -},autoRenameLocalVar++ -- ** Miscellous+ -- *** Parsing, writing and showing+ {- ,parseSourceFile,writeRefactoredFiles-}, showEntities,showPNwithLoc -- , newProj, addFile, chase+ -- *** Locations+ -- ,toRelativeLocs, rmLocs+ -- *** Default values+ ,defaultPN {- ,defaultPNT -},defaultName {-,defaultModName-},defaultExp -- ,defaultPat, defaultExpUnTyped+++ -- *** Identifiers, expressions, patterns and declarations+ ,ghcToPN,lghcToPN, expToName+ ,nameToString+ {- ,expToPNT, expToPN, nameToExp,pNtoExp -},patToPNT {- , patToPN --, nameToPat -},pNtoPat+ {- ,definingDecls -}, definedPNs+ ,definingDeclsNames, definingDeclsNames', definingSigsNames+ , allNames+ -- ,simplifyDecl++ -- *** Others+ , mkRdrName,mkNewGhcName,mkNewName,mkNewToplevelName++ -- The following functions are not in the the API yet.+ , causeNameClashInExports {- , inRegion , unmodified -}++ , removeOffset++ -- ** Typed AST traversals (added by CMB)+ -- ** Miscellous+ -- ,removeFromInts, getDataName, checkTypes, getPNs, getPN, getPNPats, mapASTOverTAST++ -- ** Debug stuff+ , getDeclAndToks, getSigAndToks+ , getToksForDecl, removeToksOffset -- ++AZ++ remove this after debuggging+ , getParsedForRenamedLPat+ , getParsedForRenamedName+ , getParsedForRenamedLocated+ -- , allPNT+ -- , allPNTLens+ , newNameTok+ , stripLeadingSpaces+ -- , lookupNameGhc++ -- ** from `Language.Haskell.Refact.Utils.GhcUtils`+ -- ** SYB versions+ , everythingButStaged+ , somethingStaged+ , everythingStaged+ , somewhereMStaged+ , somewhereMStagedBu+ , everywhereMStaged+ , everywhereMStaged'+ , everywhereStaged+ , everywhereStaged'+ , onelayerStaged+ , listifyStaged++ -- *** SYB Utility+ , checkItemRenamer++ -- ** Strafunski StrategyLib versions+ , full_tdTUGhc+ , stop_tdTUGhc+ , stop_tdTPGhc+ , allTUGhc'+ , once_tdTPGhc+ , once_buTPGhc+ , oneTPGhc+ , allTUGhc++ -- *** Strafunski utility+ , checkItemStage'+ , checkItemRenamer'++ -- ** Scrap Your Zipper versions+ , zeverywhereStaged+ , zopenStaged+ , zsomewhereStaged+ , transZ+ , transZM+ , zopenStaged'+ , ztransformStagedM+ -- *** SYZ utilities+ , checkZipperStaged+ , upUntil+ , findAbove++ -- * from `Language.Haskell.Refact.Utils.GhcVersionSpecific`+ , showGhc+ , prettyprint+ , prettyprint2+ , lexStringToRichTokens+ , getDataConstructors+ , setGhcContext++ -- * from `Language.Haskell.Refact.Utils.TokenUtils`+ , Positioning(..)+ , reIndentToks+ , srcSpanToForestSpan+ ) where++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.TokenUtils+import Language.Haskell.Refact.Utils.TypeSyn+import Language.Haskell.Refact.Utils.TypeUtils+import Language.Haskell.Refact.Utils.Utils+
− src/Language/Haskell/Refact/Case.hs
@@ -1,235 +0,0 @@-module Language.Haskell.Refact.Case(ifToCase) where--import qualified Data.Generics as SYB-import qualified GHC.SYB.Utils as SYB--import qualified GHC as GHC--import Control.Monad-import Control.Monad.IO.Class-import Language.Haskell.GhcMod-import Language.Haskell.Refact.Utils.Utils-import Language.Haskell.Refact.Utils.GhcUtils-import Language.Haskell.Refact.Utils.LocUtils-import Language.Haskell.Refact.Utils.Monad-import Language.Haskell.Refact.Utils.MonadFunctions-import Language.Haskell.Refact.Utils.TokenUtils-import Language.Haskell.Refact.Utils.TypeUtils-import Language.Haskell.Refact.Utils.TypeSyn---- ------------------------------------------------------------------------- | Convert an if expression to a case expression-ifToCase :: RefactSettings -> Cradle -> FilePath -> SimpPos -> SimpPos -> IO [FilePath]-ifToCase settings cradle fileName beginPos endPos =- runRefacSession settings cradle (comp fileName beginPos endPos)--comp :: FilePath -> SimpPos -> SimpPos -> RefactGhc [ApplyRefacResult]-comp fileName beginPos endPos = do- getModuleGhc fileName- renamed <- getRefactRenamed- logm $ "Case.comp:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++- let expr = locToExp beginPos endPos renamed- -- logm $ "Case.comp:expr=" ++ (SYB.showData SYB.Renamer 0 expr) -- ++AZ++- case expr of- Just exp1@(GHC.L _ (GHC.HsIf _ _ _ _))- -> do (refactoredMod,_) <- applyRefac (doIfToCaseInternal exp1) RSAlreadyLoaded- return [refactoredMod]- _ -> error $ "You haven't selected an if-then-else expression!" -- ++ (show (beginPos,endPos,fileName)) ++ "]:" ++ (SYB.showData SYB.Parser 0 $ ast)--doIfToCaseInternal ::- GHC.Located (GHC.HsExpr GHC.Name)- -> RefactGhc ()-doIfToCaseInternal expr = do- rs <- getRefactRenamed- reallyDoIfToCase expr rs--reallyDoIfToCase ::- GHC.Located (GHC.HsExpr GHC.Name)- -> GHC.RenamedSource- -> RefactGhc ()-reallyDoIfToCase expr rs = do-- void $ everywhereMStaged SYB.Renamer (SYB.mkM inExp) rs- showLinesDebug "after refactoring"- return ()- where- inExp :: (GHC.Located (GHC.HsExpr GHC.Name)) -> RefactGhc (GHC.Located (GHC.HsExpr GHC.Name))- inExp exp1@(GHC.L l (GHC.HsIf _se (GHC.L l1 _) (GHC.L l2 _) (GHC.L l3 _)))- | sameOccurrence expr exp1- = do- -- drawTokenTreeDetailed "reallyDoIfToCase" -- ++AZ++ debug- newExp <- ifToCaseTransform exp1-- let (GHC.RealSrcLoc rl) = GHC.srcSpanStart l- caseTok <- liftIO $ tokenise rl 0 False "case"- condToks <- getToksForSpan l1- ofTok <- liftIO $ tokenise (realSrcLocFromTok (glast "reallyDoIfToCase" condToks)) 1 True "of"- trueToks <- liftIO $ basicTokenise "True ->"- falseToks <- liftIO $ basicTokenise "False ->"- thenToksRaw <- getToksForSpan l2- elseToksRaw <- getToksForSpan l3-- let thenToks = dropWhile isEmpty thenToksRaw- let elseToks = dropWhile isEmpty elseToksRaw-- logm $ "reallyDoIfToCase:elseToks=" ++ (show elseToks)-- let t0 = reIndentToks PlaceAdjacent caseTok condToks- let t1' = reIndentToks PlaceAdjacent (caseTok ++ t0) ofTok- let t1 = caseTok ++ t0 ++ t1'-- let t2 = reIndentToks (PlaceIndent 1 4 0) t1 trueToks- let t3 = reIndentToks PlaceAdjacent (t1++t2) thenToks-- let (_,col) = tokenPos $ ghead "reallyDoIfToCase" t2-- let t4 = reIndentToks (PlaceAbsCol 1 col 0) (t1++t2++t3) falseToks- -- logm $ "reallyDoIfToCase:(t1++t2++t3++t4)=" ++ (show (t1++t2++t3++t4))- let t5 = reIndentToks PlaceAdjacent (t1++t2++t3++t4) elseToks-- let caseToks = t1++t2++t3++t4++t5 ++ [newLnToken (last t5)]-- logm $ "reallyDoIfToCase:t1=[" ++ (GHC.showRichTokenStream t1) ++ "]"- logm $ "reallyDoIfToCase:t2=[" ++ (GHC.showRichTokenStream t2) ++ "]"- logm $ "reallyDoIfToCase:t3=[" ++ (GHC.showRichTokenStream t3) ++ "]"-- -- logm $ "reallyDoIfToCase:t1++t2++t3=" ++ (show (t1++t2++t3))-- logm $ "reallyDoIfToCase:t4=[" ++ (GHC.showRichTokenStream t4) ++ "]"- logm $ "reallyDoIfToCase:t5=[" ++ (GHC.showRichTokenStream t5) ++ "]"-- logm $ "reallyDoIfToCase:caseToks=" ++ (show caseToks)-- -- drawTokenTreeDetailed "reallyDoIfToCase"-- void $ putToksForSpan l caseToks-- -- drawTokenTree "reallyDoIfToCase after putToks"- -- drawTokenTreeDetailed "reallyDoIfToCase after putToks"-- return newExp-- inExp e = return e---- TODO: rearrange the structure and preserve the comments in the original, e.g. in e1,e2,e3-ifToCaseTransform :: GHC.Located (GHC.HsExpr GHC.Name) -> RefactGhc (GHC.Located (GHC.HsExpr GHC.Name))-ifToCaseTransform (GHC.L l (GHC.HsIf _se e1 e2 e3)) = do- trueName <- mkNewGhcName Nothing "True"- falseName <- mkNewGhcName Nothing "False"- let ret = GHC.L l (GHC.HsCase e1- (GHC.MatchGroup- [- (GHC.noLoc $ GHC.Match- [- GHC.noLoc $ GHC.ConPatIn (GHC.noLoc trueName) (GHC.PrefixCon [])- ]- Nothing- ((GHC.GRHSs- [- GHC.noLoc $ GHC.GRHS [] e2- ] GHC.EmptyLocalBinds))- )- , (GHC.noLoc $ GHC.Match- [- GHC.noLoc $ GHC.ConPatIn (GHC.noLoc falseName) (GHC.PrefixCon [])- ]- Nothing- ((GHC.GRHSs- [- GHC.noLoc $ GHC.GRHS [] e3- ] GHC.EmptyLocalBinds))- )- ] undefined))- return ret-ifToCaseTransform x = return x---- ----------------------------------------------------------------------{--HsIf (Maybe (SyntaxExpr id)) (LHsExpr id) (LHsExpr id) (LHsExpr id)--[Can ignore The SyntaxExpr]---HsCase (LHsExpr id) (MatchGroup id)---}--{--Need to move to--(L {test/testdata/Case/B.hs:(9,10)-(11,17)} - (HsCase - (L {test/testdata/Case/B.hs:9:15-21} - (HsPar - (L {test/testdata/Case/B.hs:9:16-20} - (HsApp - (L {test/testdata/Case/B.hs:9:16-18} - (HsVar {Name: GHC.Real.odd})) - (L {test/testdata/Case/B.hs:9:20} - (HsVar {Name: x})))))) - (MatchGroup - [- (L {test/testdata/Case/B.hs:10:3-15} - (Match - [- (L {test/testdata/Case/B.hs:10:3-6} - (ConPatIn - (L {test/testdata/Case/B.hs:10:3-6} {Name: GHC.Types.True}) - (PrefixCon - [])))] - (Nothing) - (GRHSs - [- (L {test/testdata/Case/B.hs:10:11-15} - (GRHS - [] - (L {test/testdata/Case/B.hs:10:11-15} - (HsLit - (HsString {FastString: "Odd"})))))] - (EmptyLocalBinds)))),- (L {test/testdata/Case/B.hs:11:3-17} - (Match - [- (L {test/testdata/Case/B.hs:11:3-7} - (ConPatIn - (L {test/testdata/Case/B.hs:11:3-7} {Name: GHC.Types.False}) - (PrefixCon - [])))] - (Nothing) - (GRHSs - [- (L {test/testdata/Case/B.hs:11:12-17} - (GRHS - [] - (L {test/testdata/Case/B.hs:11:12-17} - (HsLit - (HsString {FastString: "Even"})))))] - (EmptyLocalBinds))))] {!type placeholder here?!})))--from -----(L {test/testdata/Case/B.hs:4:9-41} - (HsIf - (Nothing) - (L {test/testdata/Case/B.hs:4:12-18} - (HsPar - (L {test/testdata/Case/B.hs:4:13-17} - (HsApp - (L {test/testdata/Case/B.hs:4:13-15} - (HsVar {Name: GHC.Real.odd})) - (L {test/testdata/Case/B.hs:4:17} - (HsVar {Name: x})))))) - (L {test/testdata/Case/B.hs:4:25-29} - (HsLit - (HsString {FastString: "Odd"}))) - (L {test/testdata/Case/B.hs:4:36-41} - (HsLit - (HsString {FastString: "Even"})))))---}---- EOF---
− src/Language/Haskell/Refact/DupDef.hs
@@ -1,268 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-module Language.Haskell.Refact.DupDef(duplicateDef) where--import qualified Data.Generics as SYB-import qualified GHC.SYB.Utils as SYB--import qualified GHC-import qualified OccName as GHC--import Control.Monad-import Data.List-import Data.Maybe--import Language.Haskell.GhcMod-import Language.Haskell.Refact.Utils.Utils-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.TypeUtils---- ------------------------------------------------------------------------ | This refactoring duplicates a definition (function binding or--- simple pattern binding) at the same level with a new name provided by--- the user. The new name should not cause name clash/capture.-duplicateDef :: RefactSettings -> Cradle -> FilePath -> String -> SimpPos -> IO [FilePath]-duplicateDef settings cradle fileName newName (row,col) =- runRefacSession settings cradle (comp fileName newName (row,col))--comp :: FilePath -> String -> SimpPos- -> RefactGhc [ApplyRefacResult]-comp fileName newName (row, col) = do- if isVarId newName- then do- getModuleGhc fileName- renamed <- getRefactRenamed- parsed <- getRefactParsed-- let (Just (modName,_)) = getModuleName parsed- let maybePn = locToName (row, col) renamed- case maybePn of- Just pn ->- do- -- refactoredMod@((_fp,ismod),(_toks',renamed')) <- applyRefac (doDuplicating pn newName) (Just modInfo) fileName- (refactoredMod@((_fp,ismod),(_,_toks',renamed')),_) <- applyRefac (doDuplicating pn newName) (RSFile fileName)- case (ismod) of- False -> error "The selected identifier is not a function/simple pattern name, or is not defined in this module "- True -> return ()-- if modIsExported modName renamed- then do clients <- clientModsAndFiles modName- logm ("DupDef: clients=" ++ (showGhc clients)) -- ++AZ++ debug- refactoredClients <- mapM (refactorInClientMod (GHC.unLoc pn) modName - (findNewPName newName renamed')) clients- return $ refactoredMod:refactoredClients- else return [refactoredMod]- Nothing -> error "Invalid cursor position!"- else error $ "Invalid new function name:" ++ newName ++ "!"----doDuplicating :: GHC.Located GHC.Name -> String- -> RefactGhc ()-doDuplicating pn newName = do- inscopes <- getRefactInscopes- renamed <- getRefactRenamed- reallyDoDuplicating pn newName inscopes renamed---reallyDoDuplicating :: GHC.Located GHC.Name -> String- -> InScopes -> GHC.RenamedSource- -> RefactGhc ()-reallyDoDuplicating pn newName inscopes renamed = do-- renamed' <- everywhereMStaged SYB.Renamer (SYB.mkM dupInMod- `SYB.extM` dupInMatch- `SYB.extM` dupInPat- `SYB.extM` dupInLet- `SYB.extM` dupInLetStmt- ) renamed- putRefactRenamed renamed'- return ()-- where- --1. The definition to be duplicated is at top level.- -- dupInMod :: (GHC.HsGroup GHC.Name)-> RefactGhc (GHC.HsGroup GHC.Name)- dupInMod (grp :: (GHC.HsGroup GHC.Name))- | not $ emptyList (findFunOrPatBind pn (hsBinds grp)) = doDuplicating' inscopes grp pn- dupInMod grp = return grp-- --2. The definition to be duplicated is a local declaration in a match- dupInMatch (match@(GHC.Match _pats _typ rhs)::GHC.Match GHC.Name)- | not $ emptyList (findFunOrPatBind pn (hsBinds rhs)) = doDuplicating' inscopes match pn- dupInMatch match = return match-- --3. The definition to be duplicated is a local declaration in a pattern binding- dupInPat (pat@(GHC.PatBind _p rhs _typ _fvs _) :: GHC.HsBind GHC.Name)- | not $ emptyList (findFunOrPatBind pn (hsBinds rhs)) = doDuplicating' inscopes pat pn- dupInPat pat = return pat-- --4: The defintion to be duplicated is a local decl in a Let expression- dupInLet (letExp@(GHC.HsLet ds _e):: GHC.HsExpr GHC.Name)- | not $ emptyList (findFunOrPatBind pn (hsBinds ds)) = doDuplicating' inscopes letExp pn- dupInLet letExp = return letExp-- --5. The definition to be duplicated is a local decl in a case alternative.- -- Note: The local declarations in a case alternative are covered in #2 above.-- --6.The definition to be duplicated is a local decl in a Let statement.- dupInLetStmt (letStmt@(GHC.LetStmt ds):: GHC.Stmt GHC.Name)- -- was |findFunOrPatBind pn ds /=[]=doDuplicating' inscps letStmt pn- |not $ emptyList (findFunOrPatBind pn (hsBinds ds)) = doDuplicating' inscopes letStmt pn- dupInLetStmt letStmt = return letStmt--- -- findFunOrPatBind :: (SYB.Data t) => GHC.Located GHC.Name -> t -> [GHC.LHsBind GHC.Name]- findFunOrPatBind (GHC.L _ n) ds = filter (\d->isFunBindR d || isSimplePatBind d) $ definingDeclsNames [n] ds True False--- doDuplicating' :: (HsValBinds t) => InScopes -> t -> GHC.Located GHC.Name- -> RefactGhc (t)- doDuplicating' _inscps parentr ln@(GHC.L _ n)- = do let- declsr = hsBinds parentr-- duplicatedDecls = definingDeclsNames [n] declsr True False- -- (after,before) = break (definesP pn) (reverse declsp)-- (f,d) <- hsFDNamesFromInside parentr- --f: names that might be shadowd by the new name,- --d: names that might clash with the new name-- dv <- hsVisibleNames ln declsr --dv: names may shadow new name- let vars = nub (f `union` d `union` dv)-- newNameGhc <- mkNewGhcName Nothing newName- -- TODO: Where definition is of form tup@(h,t), test each element of it for clashes, or disallow- nameAlreadyInScope <- isInScopeAndUnqualifiedGhc newName Nothing-- -- logm ("DupDef: nameAlreadyInScope =" ++ (show nameAlreadyInScope)) -- ++AZ++ debug- -- logm ("DupDef: ln =" ++ (show ln)) -- ++AZ++ debug-- if elem newName vars || (nameAlreadyInScope && findEntity ln duplicatedDecls) - then error ("The new name'"++newName++"' will cause name clash/capture or ambiguity problem after "- ++ "duplicating, please select another name!")- else do newBinding <- duplicateDecl declsr parentr n newNameGhc- -- let newDecls = replaceDecls declsr (declsr ++ newBinding)- let newDecls = replaceBinds declsr (declsr ++ newBinding)- return $ replaceBinds parentr newDecls------ | Find the the new definition name in GHC.Name format.-findNewPName :: String -> GHC.RenamedSource -> GHC.Name-findNewPName name renamed = gfromJust "findNewPName" res- where- res = somethingStaged SYB.Renamer Nothing- (Nothing `SYB.mkQ` worker) renamed-- worker (pname::GHC.Name)- | (GHC.occNameString $ GHC.getOccName pname) == name = Just pname- worker _ = Nothing----- | Do refactoring in the client module. That is to hide the--- identifer in the import declaration if it will cause any problem in--- the client module.-refactorInClientMod :: GHC.Name -> GHC.ModuleName -> GHC.Name -> TargetModule- -> RefactGhc ApplyRefacResult-refactorInClientMod oldPN serverModName newPName targetModule@(_,modSummary)- = do- logm ("refactorInClientMod: (serverModName,newPName)=" ++ (showGhc (serverModName,newPName))) -- ++AZ++ debug- void $ activateModule targetModule-- let fileName = gfromJust "refactorInClientMod" $ GHC.ml_hs_file $ GHC.ms_location modSummary-{-- -- modInfo@(t,ts) <- getModuleGhc fileName- getModuleGhc fileName--}- renamed <- getRefactRenamed- parsed <- getRefactParsed-- let modNames = willBeUnQualImportedBy serverModName renamed- logm ("refactorInClientMod: (modNames)=" ++ (showGhc (modNames))) -- ++AZ++ debug-- -- if isJust modNames && needToBeHided (pNtoName newPName) exps parsed- mustHide <- needToBeHided newPName renamed parsed- logm ("refactorInClientMod: (mustHide)=" ++ (showGhc (mustHide))) -- ++AZ++ debug- if isJust modNames && mustHide- then do- -- refactoredMod <- applyRefac (doDuplicatingClient serverModName [newPName]) (Just modInfo) fileName- (refactoredMod,_) <- applyRefac (doDuplicatingClient serverModName [newPName]) (RSFile fileName)- return refactoredMod- else return ((fileName,unmodified),([],[],renamed))- where- needToBeHided :: GHC.Name -> GHC.RenamedSource -> GHC.ParsedSource -> RefactGhc Bool- needToBeHided name exps parsed = do- let usedUnqual = usedWithoutQualR name parsed- logm ("refactorInClientMod: (usedUnqual)=" ++ (showGhc (usedUnqual))) -- ++AZ++ debug- return $ usedUnqual || causeNameClashInExports oldPN name serverModName exps--doDuplicatingClient :: GHC.ModuleName -> [GHC.Name]- -> RefactGhc ()-doDuplicatingClient serverModName newPNames = do- renamed <- getRefactRenamed- renamed' <- addHiding serverModName renamed newPNames- putRefactRenamed renamed'- return ()--{----Do refactoring in the client module.--- that is to hide the identifer in the import declaration if it will cause any problem in the client module.-refactorInClientMod serverModName newPName (modName, fileName)- = do (inscps, exps,parsed ,ts) <- parseSourceFile fileName- let modNames = willBeUnQualImportedBy serverModName parsed- if isJust modNames && needToBeHided (pNtoName newPName) exps parsed- then do (parsed', ((ts',m),_))<-runStateT (addHiding serverModName parsed [newPName]) ((ts,unmodified),fileName)- return ((fileName,m), (ts',parsed'))- else return ((fileName,unmodified),(ts,parsed))- where- needToBeHided name exps parsed- =usedWithoutQual name (hsModDecls parsed)- || causeNameClashInExports newPName name parsed exps--}------Check here:--- | get the module name or alias name by which the duplicated--- definition will be imported automatically.-willBeUnQualImportedBy :: GHC.ModuleName -> GHC.RenamedSource -> Maybe [GHC.ModuleName]-willBeUnQualImportedBy modName (_,imps,_,_)- = let- ms = filter (\(GHC.L _ (GHC.ImportDecl (GHC.L _ modName1) _qualify _source _safe isQualified _isImplicit _as h))- -> modName == modName1- && not isQualified- && (isNothing h -- not hiding- ||- (isJust h && ((fst (gfromJust "willBeUnQualImportedBy" h))==True))- ))- imps- in if (emptyList ms) then Nothing- else Just $ nub $ map getModName ms-- where getModName (GHC.L _ (GHC.ImportDecl _modName1 _qualify _source _safe _isQualified _isImplicit as _h))- = if isJust as then (fromJust as)- else modName- -- simpModName (SN m loc) = m--{- ++AZ++ original---Check here:---get the module name or alias name by which the duplicated definition will be imported automatically.-willBeUnQualImportedBy::HsName.ModuleName->HsModuleP->Maybe [HsName.ModuleName]-willBeUnQualImportedBy modName parsed- = let imps = hsModImports parsed- ms = filter (\(HsImportDecl _ (SN modName1 _) qualify as h)->modName==modName1 && (not qualify) && - (isNothing h || (isJust h && ((fst (fromJust h))==True)))) imps- in if ms==[] then Nothing- else Just $ nub $ map getModName ms-- where getModName (HsImportDecl _ (SN modName _) qualify as h)- = if isJust as then simpModName (fromJust as)- else modName- simpModName (SN m loc) = m---}
+ src/Language/Haskell/Refact/HaRe.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Language.Haskell.Refact.HaRe+ (+ -- * Data Structures+ RefactSettings(..)+ , VerboseLevel (..)+ , defaultSettings+ , SimpPos++ -- * Refactorings+ -- |Note: the 'Cradle' in the type signatures is the one from ghc-mod+ , ifToCase+ , duplicateDef+ , liftToTopLevel+ , liftOneLevel+ , demote+ , rename+ , swapArgs+ )+where++import Language.Haskell.Refact.Refactoring.Case+import Language.Haskell.Refact.Refactoring.DupDef+import Language.Haskell.Refact.Refactoring.MoveDef+import Language.Haskell.Refact.Refactoring.Renaming+import Language.Haskell.Refact.Refactoring.SwapArgs+import Language.Haskell.Refact.Utils.Monad+import Language.Haskell.Refact.Utils.TypeSyn
− src/Language/Haskell/Refact/MoveDef.hs
@@ -1,1569 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}--module Language.Haskell.Refact.MoveDef- ( liftToTopLevel- , liftOneLevel- , demote- -- ,liftingInClientMod- ) where--import qualified Data.Generics as SYB-import qualified GHC.SYB.Utils as SYB--import qualified Exception as GHC-import qualified GHC-import qualified Name as GHC-import qualified Outputable as GHC--import Control.Exception-import Control.Monad.State-import qualified Data.Generics.Zipper as Z-import Data.List-import Data.Maybe--import Language.Haskell.GhcMod-import Language.Haskell.Refact.Utils.Utils-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.TokenUtils-import Language.Haskell.Refact.Utils.TypeSyn-import Language.Haskell.Refact.Utils.TypeUtils--import Data.Generics.Strafunski.StrategyLib.StrategyLib---- import Debug.Trace---- ------------------------------------------------------------------------- data Direction = UptoTopLevel | UpOneLevel | Down--{--------This function handles refactorings involving moving a definition---------- According to the Haskell's syntax, a declaration may occur in one of-the following six contexts:-- 1. A top level declaration in the module:- old: HsModule SrcLoc ModuleName (Maybe [HsExportSpecI i]) [HsImportDeclI i] ds- new: (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], Maybe LHsDocString)- HsGroup hs_valds :: HsValBinds id ...-- 2. A local declaration in a Match: (of a FunBind)- old: HsMatch SrcLoc i [p] (HsRhs e) ds- new: Match [LPat id] (Maybe (LHsType id)) (GRHSs id)-- 3. A local declaration in a pattern binding:- old: HsPatBind SrcLoc p (HsRhs e) ds- new: PatBind (LPat idL) (GRHSs idR) PostTcType NameSet (Maybe tickish)-- 4. A local declaration in a Let expression:- old: HsLet ds e- new: HsLet (HsLocalBinds id) (LHsExpr id)-- 5. A local declaration in a Case alternative:- old: HsAlt SrcLoc p (HsRhs e) ds- new: HsCase (LHsExpr id) (MatchGroup id)- new is same as in a FunBind.-- 6. A local declaration in a Do statement:- old: HsLetStmt ds (HsStmt e p ds)- new: LetStmt (HsLocalBindsLR idL idR)- in context GRHS [LStmt id] (LHsExpr id)--}---- | Lift a definition to the top level-liftToTopLevel :: RefactSettings -> Cradle -> FilePath -> SimpPos -> IO [FilePath]-liftToTopLevel settings cradle fileName (row,col) =- runRefacSession settings cradle (compLiftToTopLevel fileName (row,col))---compLiftToTopLevel :: FilePath -> SimpPos- -> RefactGhc [ApplyRefacResult]-compLiftToTopLevel fileName (row,col) = do- getModuleGhc fileName- renamed <- getRefactRenamed- parsed <- getRefactParsed-- let (Just (modName,_)) = getModuleName parsed- let maybePn = locToName (row, col) renamed- case maybePn of- Just pn -> do- liftToTopLevel' modName pn- _ -> error "\nInvalid cursor position!\n"----- ------------------------------------------------------------------------- | Move a definition one level up from where it is now-liftOneLevel :: RefactSettings -> Cradle -> FilePath -> SimpPos -> IO [FilePath]-liftOneLevel settings cradle fileName (row,col) =- runRefacSession settings cradle (compLiftOneLevel fileName (row,col))---compLiftOneLevel :: FilePath -> SimpPos- -> RefactGhc [ApplyRefacResult]-compLiftOneLevel fileName (row,col) = do- getModuleGhc fileName- renamed <- getRefactRenamed- parsed <- getRefactParsed-- -- logm $ "compLiftOneLevel:(fileName,row,col)="++(show (fileName,row,col))- -- logm $ "compLiftOneLevel:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++-- let (Just (modName,_)) = getModuleName parsed- let maybePn = locToName (row, col) renamed- case maybePn of- Just pn -> do- rs <- liftOneLevel' modName pn- logm $ "compLiftOneLevel:rs=" ++ (show $ (refactDone rs,map (\((_,d),_) -> d) rs))- if (refactDone rs)- then return rs- else error ( "Lifting this definition failed. "++- " This might be because that the definition to be "++- "lifted is defined in a class/instance declaration.")- _ -> error "\nInvalid cursor position!\n"------ ------------------------------------------------------------------------- | Move a definition one level down-demote :: RefactSettings -> Cradle -> FilePath -> SimpPos -> IO [FilePath]-demote settings cradle fileName (row,col) =- runRefacSession settings cradle (compDemote fileName (row,col))--compDemote ::FilePath -> SimpPos- -> RefactGhc [ApplyRefacResult]-compDemote fileName (row,col) = do- getModuleGhc fileName- renamed <- getRefactRenamed- parsed <- getRefactParsed-- -- 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- case maybePn of- Just pn -> do- demote' modName pn- _ -> error "\nInvalid cursor position!\n"---{--demote args- = do let fileName = ghead "filename" args- row = read (args!!1)::Int- col = read (args!!2)::Int- modName <- fileNameToModName fileName- (inscps, _, mod, toks) <- parseSourceFile fileName- let pnt = locToPNT fileName (row, col) mod- pn = pNTtoPN pnt- if pn /= defaultPN- then demote' modName fileName (mod, toks) pn- else error "\nInvalid cursor position!\n"--move direction args- = do let fileName = ghead "filename" args- row = read (args!!1)::Int- col = read (args!!2)::Int- modName <- fileNameToModName fileName- (inscps, _, mod, toks) <- parseSourceFile fileName- let pnt = locToPNT fileName (row, col) mod- pn = pNTtoPN pnt- if pn /= defaultPN- then- case direction of- UptoTopLevel ->liftToTopLevel' modName fileName (inscps, mod, toks) pnt- UpOneLevel ->liftOneLevel' modName fileName (inscps, mod, toks) pnt- Down ->demote' modName fileName (mod, toks) pn- else error "\nInvalid cursor position!\n"---{- Refactoring Names: 'liftToTopLevel'-- This refactoring lifts a local function/pattern binding to the top- level of the module, so as to make it accessible to other functions in- the current module, and those modules that import current module.-- In the current implementation, a definition will be lifted only if- none of the identifiers defined in this definition will cause name- clash/capture problems in the current module after lifting.-- In the case that the whole current module is exported implicitly,- the lifted identifier will be exported automatically after lifting. If- the identifier will cause name clash/ambiguous occurrence problem in a- client module, it will be hided in the import declaration of the- client module (Note: this might not be the best solution, we prefer- hiding it in the server module instead of in the client module in the- final version).-- In the case of indirect importing, it might be time-consuming to- trace whether the lifted identifier will cause any problem in a client- module that indirectly imports the current module. The current- solution is: suppose a defintion is lifted to top level in module A,- and module A is imported and exported by module B, then the lifted- identifier will be hided in the import declaration of B no matter- whether it causes problems in module B or not.-- Function name: liftToTopLevel- parameters: fileName--current file name.- mod -- the scoped abstract syntax tree of the module.- pn -- the function/pattern name to be lifted.--}---}--liftToTopLevel' :: GHC.ModuleName -- -> (ParseResult,[PosToken]) -> FilePath- -> GHC.Located GHC.Name- -> RefactGhc [ApplyRefacResult]-liftToTopLevel' modName pn@(GHC.L _ n) = do- renamed <- getRefactRenamed- -- logm $ "liftToTopLevel':renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++- logm $ "liftToTopLevel':pn=" ++ (showGhc pn)- if isLocalFunOrPatName n renamed- then do- (refactoredMod,declPns) <- applyRefac (liftToMod) RSAlreadyLoaded-- logm $ "liftToTopLevel' applyRefac done "- -- logm $ "liftToTopLevel' applyRefac done:toks= " ++ (show (fst $ snd refactoredMod))-- if modIsExported modName renamed- then do clients <- clientModsAndFiles modName- logm $ "liftToTopLevel':(clients,declPns)=" ++ (showGhc (clients,declPns))- refactoredClients <- mapM (liftingInClientMod modName declPns) clients- return (refactoredMod:(concat refactoredClients))- else do return [refactoredMod]- 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'.- 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.- step4. test whether there are any names need to be renamed.- -}- liftToMod = do- renamed <- getRefactRenamed- let declsr = hsBinds renamed- let (before,parent,after) = divideDecls declsr pn- -- error ("liftToMod:(before,parent,after)=" ++ (showGhc (before,parent,after))) -- ++AZ++- {- ++AZ++ : 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)- $ error "Sorry, the refactorer cannot lift a definition from an instance declaration!"- -}- let liftedDecls = definingDeclsNames [n] parent True True- declaredPns = nub $ concatMap definedPNs liftedDecls-- -- TODO: what about declarations between this- -- one and the top level that are used in this one?-- -- logm $ "liftToMod:(liftedDecls,declaredPns)=" ++ (showGhc (liftedDecls,declaredPns))- -- original : pns<-pnsNeedRenaming inscps mod parent liftedDecls declaredPns- pns <- pnsNeedRenaming renamed parent liftedDecls declaredPns-- -- (_,dd) <- hsFreeAndDeclaredPNs renamed- let dd = getDeclaredVars $ hsBinds renamed- logm $ "liftToMod:(ddd)=" ++ (showGhc dd)-- -- drawTokenTree "liftToMod.a"-- if pns==[]- then do- -- TODO: change the order, first move the decls then add params,- -- else the liftedDecls get mangled while still in the parent- (parent',liftedDecls',_paramAdded) <- addParamsToParentAndLiftedDecl n dd parent liftedDecls- -- let liftedDecls''=if paramAdded then filter isFunOrPatBindR liftedDecls'- -- else liftedDecls'-- -- drawTokenTree "liftToMod.c"- -- logm $ "liftToMod:(declaredPns)=" ++ (showGhc declaredPns)- -- logm $ "liftToMod:(liftedDecls')=" ++ (showGhc liftedDecls')-- -- error ("liftToMod:newBinds=" ++ (showGhc (replaceBinds declsr (before++parent'++after)))) -- ++AZ++-- void $ moveDecl1 (replaceBinds renamed (before++parent'++after))- (Just (ghead "liftToMod" (definedPNs (ghead "liftToMod2" parent'))))- [GHC.unLoc pn] (Just liftedDecls') declaredPns True-- -- drawTokenTree "liftToMod.b"-- return declaredPns-- else askRenamingMsg pns "lifting"------ -----------------------------------------------------------------------moveDecl1 :: (HsValBinds t)- => t -- ^ The syntax element to update- -> Maybe GHC.Name -- ^ If specified, add defn after this one-- -- TODO: make this next parameter a single value, not a list,- -- after module complete- -> [GHC.Name] -- ^ The first one is the decl to move- -> Maybe [GHC.LHsBind GHC.Name]- -> [GHC.Name] -- ^ The signatures to remove. May be multiple if- -- decl being moved has a patbind.- -> Bool -- ^ True if moving to the top level- -> RefactGhc t -- ^ The updated syntax element (and tokens in monad)-moveDecl1 t defName ns mliftedDecls sigNames topLevel = do- -- logm $ "moveDecl1:t=" ++ (SYB.showData SYB.Renamer 0 t) -- ++AZ++- -- logm $ "moveDecl1:mliftedDecls=" ++ (showGhc mliftedDecls)- -- drawTokenTree "moveDecl1 on entry"-- -- TODO: work with all of ns, not just the first- let n = ghead "moveDecl1" ns- -- let funBinding = definingDeclsNames [n] (hsBinds t) True True- let funBinding = case mliftedDecls of- Nothing -> definingDeclsNames' [n] t- Just liftedDecls -> liftedDecls-- -- logm $ "moveDecl1: (ns,funBinding)=" ++ (showGhc (ns,funBinding)) -- ++AZ++-- let Just sspan = getSrcSpan funBinding- -- drawTokenTree "before getting toks" -- ++AZ++- funToks <- getToksForSpan sspan- -- logm $ "moveDecl1:funToks=" ++ (showToks funToks)- -- drawTokenTree "moveDecl1:after getting toks" -- ++AZ++ 'in' present- --- drawTokenTreeDetailed "moveDecl1:after getting toks" -- ++AZ++-- -- (t'',sigsRemoved) <- rmTypeSigs ns t- (t'',sigsRemoved) <- rmTypeSigs sigNames t- -- drawTokenTree "moveDecl1:after rmTypeSigs" -- ++AZ++- -- drawTokenTreeDetailed "moveDecl1:after rmTypeSigs" -- ++AZ++- -- logm $ "moveDecl1:t''=" ++ (SYB.showData SYB.Renamer 0 t'') -- ++AZ++- (t',_declRemoved,_sigRemoved) <- rmDecl (ghead "moveDecl3.1" ns) False t''- -- logm $ "moveDecl1:t'=" ++ (SYB.showData SYB.Renamer 0 t') -- ++AZ++- -- drawTokenTree "moveDecl1:after rmDecl" -- ++AZ++- -- drawTokenTreeDetailed "moveDecl1:after rmDecl" -- ++AZ++ 'in' missing-- let getToksForMaybeSig (GHC.L ss _) =- do- sigToks <- getToksForSpan ss- return sigToks-- -- maybeToksSigMulti <- mapM getToksForMaybeSig sigsRemoved- maybeToksSigMulti <- mapM getToksForMaybeSig- $ sortBy (\(GHC.L s1 _) (GHC.L s2 _) -> compare (srcSpanToForestSpan s1) (srcSpanToForestSpan s2))- sigsRemoved- let maybeToksSig = concat maybeToksSigMulti-- -- logm $ "moveDecl1:maybeToksSig=" ++ (show maybeToksSig) -- ++AZ++- -- logm $ "moveDecl1:(defName,topLevel)" ++ (showGhc (defName,topLevel)) -- ++AZ++-- -- drawTokenTree "moveDecl1 about to addDecl"- r <- addDecl t' defName (ghead "moveDecl1 2" funBinding,sigsRemoved,Just (maybeToksSig ++ funToks)) topLevel- -- drawTokenTree "moveDecl1 done"- return r---askRenamingMsg :: [GHC.Name] -> String -> t-askRenamingMsg pns str- = error ("The identifier(s): " ++ (intercalate "," $ map showPN pns) ++- " will cause name clash/capture or ambiguity occurrence problem after "- ++ str ++", please do renaming first!")-- where- showPN pn = showGhc (pn,GHC.nameSrcLoc pn)---- |Get the subset of 'pns' that need to be renamed before lifting.-pnsNeedRenaming :: (SYB.Data t1) =>- t1 -> [GHC.LHsBind GHC.Name] -> t2 -> [GHC.Name]- -> RefactGhc [GHC.Name]-pnsNeedRenaming dest parent _liftedDecls pns- =do- r <- mapM pnsNeedRenaming' pns- return (concat r)- where- pnsNeedRenaming' pn- = do- (f,d) <- hsFDsFromInside dest --f: free variable names that may be shadowed by pn- --d: declaread variables names that may clash with pn- vs <- hsVisiblePNs pn parent --vs: declarad variables that may shadow pn- let -- inscpNames = map (\(x,_,_,_)->x) $ inScopeInfo inscps- vars = map pNtoName (nub (f `union` d `union` vs) \\ [pn]) -- `union` inscpNames- -- if elem (pNtoName pn) vars || isInScopeAndUnqualified (pNtoName pn) inscps && findEntity pn dest- 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- then return [pn]- else return []- --This pNtoName takes into account the qualifier.- pNtoName = showGhc---addParamsToParent :: (HsValBinds t) => GHC.Name -> [GHC.Name] -> t -> RefactGhc t-addParamsToParent _pn [] t = return t-addParamsToParent pn params t = do- logm $ "addParamsToParent:(pn,params)" ++ (showGhc (pn,params))- addActualParamsToRhs True pn params t----- |Do refactoring in the client module. that is to hide the identifer--- in the import declaration if it will cause any problem in the--- client module.-liftingInClientMod :: GHC.ModuleName -> [GHC.Name] -> TargetModule- -> RefactGhc [ApplyRefacResult]-liftingInClientMod serverModName pns targetModule@(_,modSummary) = do- void $ activateModule targetModule- renamed <- getRefactRenamed- -- logm $ "liftingInClientMod:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++- let clientModule = GHC.ms_mod modSummary- logm $ "liftingInClientMod:clientModule=" ++ (showGhc clientModule)- -- = do (inscps, exps ,mod ,ts) <- parseSourceFile fileName- -- let modNames = willBeUnQualImportedBy serverModName mod- modNames <- willBeUnQualImportedBy serverModName- logm $ "liftingInClientMod:modNames=" ++ (showGhc modNames)- if isJust modNames- then do- pns' <- namesNeedToBeHided clientModule (gfromJust "liftingInClientMod" modNames) pns- logm $ "liftingInClientMod:pns'=" ++ (showGhc pns')- -- in if pns' /= []- if (nonEmptyList pns')- -- then do <-runStateT (addHiding serverModName mod pns') ((ts,unmodified),(-1000,0))- then do (refactoredMod,_) <- applyRefac (addHiding serverModName renamed pns') RSAlreadyLoaded- return [refactoredMod]- else return []- else return []---- |Test whether an identifier defined in the modules specified by--- 'names' will be exported by current module.-willBeExportedByClientMod :: [GHC.ModuleName] -> GHC.RenamedSource -> Bool-willBeExportedByClientMod names renamed =- let (_,_,exps,_) = renamed- in if isNothing exps- then False- else any isJust $ map (\y-> (find (\x-> (simpModule x==Just y)) (gfromJust "willBeExportedByClientMod" exps))) names- where simpModule (GHC.L _ (GHC.IEModuleContents m)) = Just m- simpModule _ = Nothing---- |get the module name or alias name by which the lifted identifier--- will be imported automatically.--- TODO: maybe move this into TypeUtils--- willBeUnQualImportedBy::HsName.ModuleName->HsModuleP->Maybe [HsName.ModuleName]-willBeUnQualImportedBy :: GHC.ModuleName -> RefactGhc (Maybe [GHC.ModuleName])-willBeUnQualImportedBy modName = do- (_,imps,_,_) <- getRefactRenamed- let ms = filter (\(GHC.L _ (GHC.ImportDecl (GHC.L _ modName1) _qualify _source _safe isQualified _isImplicit _as h))- -> modName == modName1 && (not isQualified) && (isNothing h || (isJust h && ((fst (fromJust h)) == True))))- imps-- res = if (emptyList ms) then Nothing- else Just $ nub $ map getModName ms-- getModName (GHC.L _ (GHC.ImportDecl (GHC.L _ modName2) _qualify _source _safe _isQualified _isImplicit as _h))- = if isJust as then simpModName (fromJust as)- else modName2-- simpModName m = m-- logm $ "willBeUnQualImportedBy:(ms,res)=" ++ (showGhc (ms,res))-- return res----- |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.-namesNeedToBeHided :: GHC.Module -> [GHC.ModuleName] -> [GHC.Name]- -> RefactGhc [GHC.Name]-namesNeedToBeHided clientModule modNames pns = do- renamed <- getRefactRenamed- parsed <- getRefactParsed- logm $ "namesNeedToBeHided:willBeExportedByClientMod=" ++ (show $ willBeExportedByClientMod modNames renamed)- gnames <- GHC.getNamesInScope- let clientInscopes = filter (\n -> clientModule == GHC.nameModule n) gnames- logm $ "namesNeedToBeHided:(clientInscopes)=" ++ (showGhc (clientInscopes))-- pnsMapped <- mapM getLocalEquiv pns- logm $ "namesNeedToBeHided:pnsMapped=" ++ (showGhc pnsMapped)-- let pnsMapped' = filter (\(_,_,ns) -> not $ emptyList ns) pnsMapped-- if willBeExportedByClientMod modNames renamed- then return pns- else do- ff <- mapM (needToBeHided parsed) pnsMapped'- return $ concat ff- where- -- | Strip the package prefix from the name and return the- -- stripped name together with any names in the local module that- -- may match the stripped one- getLocalEquiv :: GHC.Name -> RefactGhc (GHC.Name,String,[GHC.Name])- getLocalEquiv pn = do- let pnStr = stripPackage $ showGhc pn- logm $ "MoveDef getLocalEquiv: about to parseName:" ++ (show pnStr)- ecns <- GHC.gtry $ GHC.parseName pnStr- let cns = case ecns of- Left (_e::SomeException) -> []- Right v -> v- logm $ "MoveDef getLocalEquiv: cns:" ++ (showGhc cns)- return (pn,pnStr,cns)-- stripPackage :: String -> String- stripPackage str = reverse s- where- (s,_) = break (== '.') $ reverse str-- needToBeHided :: GHC.ParsedSource -> (GHC.Name,String,[GHC.Name]) -> RefactGhc [GHC.Name]- needToBeHided parsed (pn,_pnStr,pnsLocal) = do- let uwoq = map (\n -> usedWithoutQualR n parsed) pnsLocal-- -- logm $ "needToBeHided:(hsBinds renamed)=" ++ (showGhc (hsBinds renamed))- logm $ "needToBeHided:(pn,uwoq)=" ++ (showGhc (pn,uwoq))-- if (any (== True) uwoq --the same name is used in the module unqualifiedly or- --is exported unqualifiedly by an Ent decl-- -- was || causeNameClashInExports pn modNames renamed)- -- TODO: ++AZ++ check if next line needs to be reinstated- -- was || any (\m -> causeNameClashInExports oldPN pn m renamed) modNames)- || False)- then return [pn]- else return []----- **************************************************************************************************************----{- Refactoring Names: 'liftOneLevel'- Descritption:- this refactoring lifts a local function/pattern binding only one level up.- By 'lifting one-level up' ,I mean:-- case1: In a module (HsModule SrcLoc ModuleName (Maybe [HsExportSpecI i]) [HsImportDeclI i] ds):- A local declaration D will be lifted to the same level as the 'ds', if D is in the - where clause of one of ds's element declaration.-- new: (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], Maybe LHsDocString)- HsGroup hs_valds :: HsValBinds id ...---- case2: In a match ( HsMatch SrcLoc i [p] (HsRhs e) ds) :- A local declaration D will be lifted to the same level as the 'ds', if D is in the - where clause of one of ds's element declaration.- A declaration D,say,in the rhs expression 'e' will be lifted to 'ds' if D is Not local to- other declaration list in 'e'-- (in a FunBind)- new: Match [LPat id] (Maybe (LHsType id)) (GRHSs id)--- case3: In a pattern binding (HsPatBind SrcLoc p (HsRhs e) ds):- A local declaration D will be lifted to the same level as the 'ds', if D is in the - where clause of one of ds's element declaration.- A declaration D,say,in the rhs expression 'e' will be lifted to 'ds' if D is Not local to- other declaration list in 'e'-- new: PatBind (LPat idL) (GRHSs idR) PostTcType NameSet (Maybe tickish)---- case4: In the Let expression (Exp (HsLet ds e):- A local declaration D will be lifted to the same level as the 'ds', if D is in the - where clause of one of ds's element declaration.- A declaration D, say, in the expression 'e' will be lifted to 'ds' if D is not local to- other declaration list in 'e'-- new: HsLet (HsLocalBinds id) (LHsExpr id)--- case5: In the case Alternative expression:(HsAlt loc p rhs ds)- A local declaration D will be lifted to the same level as the 'ds', if D is in the - where clause of one of ds's element declaration.- A declaration D in 'rhs' will be lifted to 'ds' if D is not local to other declaration - list in 'rhs'.-- new: HsCase (LHsExpr id) (MatchGroup id)- new is same as in a FunBind.--- case6: In the do statement expression:(HsLetStmt ds stmts)- A local declaration D will be lifted to the same level as the 'ds', if D is in the - where clause of one of ds's element declaration.- A declaration D in 'stmts' will be lifted to 'ds' if D is not local to other declaration - list in 'stmts'.-- new: LetStmt (HsLocalBindsLR idL idR)- in context GRHS [LStmt id] (LHsExpr id)---Function name: liftOneLevel-parameters: fileName--current file name.- mod -- the scoped abstract syntax tree of the module.- pn -- the function/pattern name to be lifted.---}--liftOneLevel' :: GHC.ModuleName- -> GHC.Located GHC.Name- -> RefactGhc [ApplyRefacResult]--liftOneLevel' modName pn@(GHC.L _ n) = do- renamed <- getRefactRenamed- if isLocalFunOrPatName n renamed- then do -- (mod', ((toks',m),_))<-liftOneLevel''- (refactoredMod,_) <- applyRefac (liftOneLevel'') RSAlreadyLoaded- let (b, pns) = liftedToTopLevel pn renamed- if b && modIsExported modName renamed- then do clients<-clientModsAndFiles modName- -- logm $ "liftOneLevel':(clients,declPns)=" ++ (showGhc (clients,declPns))- refactoredClients <- mapM (liftingInClientMod modName pns) clients- return (refactoredMod:(concat refactoredClients))- else do return [refactoredMod]- else error "\nThe identifer is not a function/pattern name!"-- where- liftOneLevel''= do- logm $ "in liftOneLevel''"- renamed <- getRefactRenamed- ztransformStagedM SYB.Renamer (Nothing- `SYB.mkQ` liftToModQ- `SYB.extQ` liftToMatchQ'- `SYB.extQ` liftToLet'- -- `SYB.mkQ` liftToMatchQ- -- `SYB.extQ` liftToLet- ) (Z.toZipper renamed)-- where- isValBinds :: GHC.HsValBinds GHC.Name -> Bool- isValBinds _ = True-- isGRHSs :: GHC.GRHSs GHC.Name -> Bool- isGRHSs _ = True-- isHsLet :: GHC.HsExpr GHC.Name -> Bool- isHsLet (GHC.HsLet _ _) = True- isHsLet _ = False-- liftToModQ ((g,_imps,_exps,_docs):: GHC.RenamedSource)- | nonEmptyList candidateBinds- = Just (doLiftZ candidateBinds)- | otherwise = Nothing- where- candidateBinds = map snd- $ filter (\(l,_bs) -> nonEmptyList l)- $ map (\bs -> (definingDeclsNames [n] (hsBinds bs) False False,bs))- $ (hsBinds g)-- liftToMatchQ' :: (SYB.Data a) => GHC.Match GHC.Name -> Maybe (SYB.Stage -> Z.Zipper a -> RefactGhc (Z.Zipper a))- liftToMatchQ' ((GHC.Match _pats _mtyp (GHC.GRHSs rhs ds))::GHC.Match GHC.Name)- | (nonEmptyList (definingDeclsNames [n] (hsBinds ds) False False))- = Just (doLiftZ ds)- | (nonEmptyList (definingDeclsNames [n] (hsBinds rhs) False False))- = Just (doLiftZ rhs)- | otherwise = Nothing-- liftToLet' :: GHC.HsExpr GHC.Name -> Maybe (SYB.Stage -> Z.Zipper a -> RefactGhc (Z.Zipper a))- liftToLet' ((GHC.HsLet ds _e)::GHC.HsExpr GHC.Name)- | nonEmptyList (definingDeclsNames [n] (hsBinds ds) False False)- = Just (doLiftZ ds)- | otherwise = Nothing- liftToLet' _ = Nothing-- doLiftZ :: (HsValBinds t)- => t -> SYB.Stage -> Z.Zipper a- -> RefactGhc (Z.Zipper a)- doLiftZ ds _stage z =- do- logm $ "in liftOneLevel''.liftToLet in ds"-- let zu = case (Z.up z) of- Just zz -> fromMaybe (error "MoveDef.liftToLet.1")- $ upUntil (False `SYB.mkQ` isGRHSs- `SYB.extQ` isHsLet- `SYB.extQ` isValBinds)- zz- Nothing -> z-- let- wtop (ren::GHC.RenamedSource) = do- worker ren (hsBinds ds) pn True-- wgrhs (grhss::GHC.GRHSs GHC.Name) = do- (_,dd) <- (hsFreeAndDeclaredPNs grhss)- worker1 grhss (hsBinds ds) pn dd False-- wlet :: GHC.HsExpr GHC.Name -> RefactGhc (GHC.HsExpr GHC.Name)- wlet l@(GHC.HsLet dsl _e) = do- (_,dd) <- hsFreeAndDeclaredPNs dsl- dsl' <- worker1 l (hsBinds ds) pn dd False- return dsl'- wlet x = return x-- wvalbinds (vb::GHC.HsValBinds GHC.Name) = do- (_,dd) <- (hsFreeAndDeclaredPNs vb)- worker1 vb (hsBinds ds) pn dd False-- ds' <- Z.transM (SYB.mkM wtop `SYB.extM` wgrhs- `SYB.extM` wlet `SYB.extM` wvalbinds) zu-- return ds'-- -- TODO: merge worker and worker1- worker :: (HsValBinds t,GHC.Outputable t)- => t -- ^The destination of the lift operation- -> [GHC.LHsBind GHC.Name] -- ^ list containing the- -- decl to be lifted- -> GHC.Located GHC.Name -- ^ The name of the decl to- -- be lifted- -> Bool -- ^True if lifting to the top level- -> RefactGhc t- worker dest ds pnn toToplevel- =do let (before,parent,after)=divideDecls ds pnn -- parent is misnomer, it is the decl to be moved- -- liftedDecls=definingDeclsNames [n] parent True False- liftedDecls=definingDeclsNames [n] parent True True- declaredPns=nub $ concatMap definedPNs liftedDecls- -- logm $ "MoveDef.worker: (dest)=" ++ (SYB.showData SYB.Renamer 0 dest)- -- logm $ "MoveDef.worker: (ds)=" ++ (showGhc (ds))- -- logm $ "MoveDef.worker: parent=" ++ (showGhc parent)- (_, dd) <- hsFreeAndDeclaredPNs dest- -- pns<-pnsNeedRenaming inscps dest parent liftedDecls declaredPns- pns<-pnsNeedRenaming dest parent liftedDecls declaredPns- logm $ "MoveDef.worker: pns=" ++ (showGhc pns)- if pns==[]- then do- (parent',liftedDecls',_paramAdded)<-addParamsToParentAndLiftedDecl n dd- parent liftedDecls- -- let liftedDecls''=if paramAdded then filter isFunOrPatBindR liftedDecls'- -- else liftedDecls'- --True means the new decl will be at the same level with its parant. - dest' <- moveDecl1 (replaceBinds dest (before++parent'++after))- (Just (ghead "worker" (definedPNs (ghead "worker" parent'))))- [n] (Just liftedDecls') declaredPns toToplevel -- False -- ++AZ++ TODO: should be True for toplevel move- return dest'- --parent'<-doMoving declaredPns (ghead "worker" parent) True paramAdded parent'- --return (before++parent'++liftedDecls''++after)- else askRenamingMsg pns "lifting"-- worker1 :: (HsValBinds t,GHC.Outputable t)- => t -- ^The destination of the lift operation- -> [GHC.LHsBind GHC.Name] -- ^ list containing the- -- decl to be lifted- -> GHC.Located GHC.Name -- ^ The name of the decl to- -- be lifted- -> [GHC.Name] -- ^Declared variables in the destination- -> Bool -- ^True if lifting to the top level- -> RefactGhc t- worker1 dest ds pnn dd toToplevel- {-- Actions required- 1. add parameters to original decls if required- 2. add parameters to any points that call the lifted decl- once it is lifted- 3. Replace the above in the AST- 4. Do the move- -}-- =do let (_before,decl,_after)=divideDecls ds pnn- liftedDecls=definingDeclsNames [n] decl True True- declaredPns=nub $ concatMap definedPNs liftedDecls- -- logm $ "MoveDef.worker1: (dest)=" ++ (SYB.showData SYB.Renamer 0 dest)- -- logm $ "MoveDef.worker1: (ds)=" ++ (showGhc (ds))- -- logm $ "MoveDef.worker1: decl=" ++ (showGhc decl)- -- logm $ "MoveDef.worker1: dd=" ++ (showGhc dd)-- pns <- pnsNeedRenaming dest decl liftedDecls declaredPns- logm $ "MoveDef.worker1: pns=" ++ (showGhc pns)- if pns==[]- then do- (parent',liftedDecls',_paramAdded)- -- <- addParamsToParentAndLiftedDecl n dd decl liftedDecls - <- addParamsToParentAndLiftedDecl n dd dest liftedDecls- -- let liftedDecls''=if paramAdded then filter isFunOrPatBindR liftedDecls'- -- else liftedDecls'- -- logm $ "MoveDef.worker1:liftedDecls''=" ++ (showGhc liftedDecls'')- -- logm $ "MoveDef.worker1:dest'=" ++ (SYB.showData SYB.Renamer 0 dest')- --True means the new decl will be at the same level with its parant. - parent'' <- moveDecl1 parent' Nothing- [n] (Just liftedDecls') declaredPns toToplevel -- False -- ++AZ++ TODO: should be True for toplevel move- return parent''- --decl'<-doMoving declaredPns (ghead "worker" decl) True paramAdded decl'- --return (before++decl'++liftedDecls''++after)- else askRenamingMsg pns "lifting"---liftedToTopLevel :: GHC.Located GHC.Name -> GHC.RenamedSource -> (Bool,[GHC.Name])-liftedToTopLevel pnt@(GHC.L _ pn) renamed- = if nonEmptyList (definingDeclsNames [pn] (hsBinds renamed) False True)- then let (_, parent,_) = divideDecls (hsBinds renamed) pnt- liftedDecls=definingDeclsNames [pn] (hsBinds parent) True True- declaredPns = nub $ concatMap definedPNs liftedDecls- in (True, declaredPns)- else (False, [])---addParamsToParentAndLiftedDecl :: (HsValBinds t,GHC.Outputable t) =>- GHC.Name -- ^name of decl being lifted- -> [GHC.Name] -- ^Declared names in parent- -> t -- ^parent- -> [GHC.LHsBind GHC.Name] -- ^decls being lifted- -> RefactGhc (t, [GHC.LHsBind GHC.Name], Bool)-addParamsToParentAndLiftedDecl pn dd parent liftedDecls- =do (ef,_) <- hsFreeAndDeclaredPNs parent- (lf,_) <- hsFreeAndDeclaredPNs liftedDecls-- -- logm $ "addParamsToParentAndLiftedDecl:parent=" ++ (showGhc parent)-- -- parameters to be added to pn because of lifting- let newParams=((nub lf) \\ (nub ef)) \\ dd-- logm $ "addParamsToParentAndLiftedDecl:(newParams,ef,lf,dd)=" ++ (showGhc (newParams,ef,lf,dd))-- if newParams /= []- then if (any isComplexPatBind liftedDecls)- then error "This pattern binding cannot be lifted, as it uses some other local bindings!"- else do -- first remove the decls to be lifted, so they are not disturbed- (parent'',liftedDecls'',_msig) <- rmDecl pn False parent- -- drawTokenTree "addParamsToParentAndLiftedDecl: rmDecl done"- -- logm $ "addParamsToParentAndLiftedDecl:parent''=" ++ (SYB.showData SYB.Renamer 0 parent'')- -- logm $ "addParamsToParentAndLiftedDecl:parent''=" ++ (showGhc parent'')-- parent' <- addParamsToParent pn newParams parent''- -- let parent' = parent- -- logm $ "addParamsToParentAndLiftedDecl: parent done"- -- drawTokenTree "addParamsToParentAndLiftedDecl: parent params done"-- liftedDecls' <- addParamsToDecls [liftedDecls''] pn newParams True- -- logm $ "addParamsToParentAndLiftedDecl: liftedDecls done"- -- drawTokenTree "addParamsToParentAndLiftedDecl: liftedDecls done"-- return (parent', liftedDecls',True)- else return (parent,liftedDecls,False)-----------------------------------End of Lifting-------------------------------------------{-Refactoring : demote a function/pattern binding(simpe or complex) to the declaration where it is used.- Descritption: if a declaration D, say, is only used by another declaration F,say, then D can be - demoted into the local declaration list (where clause) in F.- So currently, D can not be demoted if more than one declaration use it. -- In a multi-module context, a top-level definition can not be demoted if it is used- by other modules. In the case that the demoted identifer is in the hiding list of- import declaration in a client module, it should be removed from the hiding list.-- Function name:demote- parameters: fileName--current file name.- mod -- the scoped abstract syntax tree of the module.- pn -- the function/pattern name to be demoted.---}--demote' ::- GHC.ModuleName- -- -> FilePath- -- -> (ParseResult,[PosToken])- -> GHC.Located GHC.Name- -> RefactGhc [ApplyRefacResult]-demote' modName (GHC.L _ pn) = do- renamed <- getRefactRenamed- if isFunOrPatName pn renamed- then do- isTl <- isTopLevelPN pn- if isTl && isExplicitlyExported pn renamed- then error "This definition can not be demoted, as it is explicitly exported by the current module!"- else do -- (mod',((toks',m),_))<-doDemoting pn fileName mod toks- (refactoredMod,_) <- applyRefac (doDemoting pn) RSAlreadyLoaded- -- isTl <- isTopLevelPN pn- if isTl && modIsExported modName renamed- then do let demotedDecls'= definingDeclsNames [pn] (hsBinds renamed) True False- declaredPns = nub $ concatMap definedPNs demotedDecls'- clients <- clientModsAndFiles modName- logm $ "demote':clients=" ++ (showGhc clients)- refactoredClients <-mapM (demotingInClientMod declaredPns) clients- -- return (refactoredMod:[])- return (refactoredMod:refactoredClients)- else do return [refactoredMod]- else error "\nInvalid cursor position!"----- |Do refactoring in the client module, that is:--- a) Check whether the identifier is used in the module body--- b) If the identifier is not used but is hided by the import--- declaration, then remove it from the hiding.-demotingInClientMod ::- [GHC.Name] -> TargetModule- -> RefactGhc ApplyRefacResult-demotingInClientMod pns targetModule@(_,modSummary) = do- void $ activateModule targetModule- (refactoredMod,_) <- applyRefac (doDemotingInClientMod pns (GHC.ms_mod modSummary)) RSAlreadyLoaded- return refactoredMod---doDemotingInClientMod :: [GHC.Name] -> GHC.Module -> RefactGhc ()-doDemotingInClientMod pns modName = do- renamed@(_g,imps,exps,_docs) <- getRefactRenamed- -- if any (\pn->findPN pn (hsModDecls mod) || findPN pn (hsModExports mod)) pns- if any (\pn->findPN pn (hsBinds renamed) || findPN pn (exps)) 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- -- TODO: reinstate this- then do -- (mod',((ts',m),_))<-runStateT (rmItemsFromImport mod pns) ((ts,unmodified),(-1000,0))- return ()- else return ()--doDemoting :: GHC.Name -> RefactGhc ()-doDemoting pn = do-- clearRefactDone -- Only do this action once-- renamed <- getRefactRenamed- -- logm $ "MoveDef.doDemoting:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++- -- everywhereMStaged' is top-down- renamed' <- everywhereMStaged' SYB.Renamer (SYB.mkM demoteInMod- `SYB.extM` demoteInMatch- `SYB.extM` demoteInPat- `SYB.extM` demoteInLet- `SYB.extM` demoteInStmt- ) renamed- -- error ("doDemoting:renamed'=" ++ (showGhc renamed'))- putRefactRenamed renamed'- -- ren <- getRefactRenamed- -- error ("doDemoting:ren=" ++ (showGhc ren))- showLinesDebug "doDemoting done"- return ()- where- --1. demote from top level- -- demoteInMod (mod@(HsModule loc name exps imps ds):: HsModuleP)- demoteInMod (renamed :: GHC.RenamedSource)- | not $ emptyList decls- = do- logm "MoveDef:demoteInMod" -- ++AZ++- demoted <- doDemoting' renamed pn- return demoted- where- decls = (definingDeclsNames [pn] (hsBinds renamed) False False)- demoteInMod x = return x-- --2. The demoted definition is a local decl in a match- -- demoteInMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP)- demoteInMatch (match@(GHC.Match _pats _mt rhs)::GHC.Match GHC.Name)- -- was | definingDecls [pn] ds False False/=[]- | not $ emptyList (definingDeclsNames [pn] (hsBinds rhs) False False)- = do- logm "MoveDef:demoteInMatch" -- ++AZ++- done <- getRefactDone- match' <- if (not done)- then doDemoting' match pn- else return match- return match'- demoteInMatch x = return x-- --3. The demoted definition is a local decl in a pattern binding- -- demoteInPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP)- demoteInPat (pat@((GHC.PatBind _p rhs _ _ _))::GHC.HsBind GHC.Name)- -- was | definingDecls [pn] ds False False /=[]- | not $ emptyList (definingDeclsNames [pn] (hsBinds rhs) False False)- = do- logm "MoveDef:demoteInPat" -- ++AZ++- done <- getRefactDone- pat' <- if (not done)- then doDemoting' pat pn- else return pat- return pat'- demoteInPat x = return x-- --4: The demoted definition is a local decl in a Let expression- -- demoteInLet (letExp@(Exp (HsLet ds e))::HsExpP)- demoteInLet (letExp@(GHC.HsLet ds _e)::GHC.HsExpr GHC.Name)- -- was | definingDecls [pn] ds False False/=[]- | not $ emptyList (definingDeclsNames [pn] (hsBinds ds) False False)- = do- logm "MoveDef:demoteInLet" -- ++AZ++- done <- getRefactDone- letExp' <- if (not done)- then doDemoting' letExp pn- else return letExp- return letExp'- demoteInLet x = return x-- -- TODO: the rest of these cases below-{-- --5. The demoted definition is a local decl in a case alternative.- demoteInAlt (alt@(HsAlt loc p rhs ds)::(HsAlt (HsExpP) (HsPatP) [HsDeclP]))- | definingDecls [pn] ds False False /=[]- = doDemoting' alt pn- demoteInAlt _=mzero--}-- --6.The demoted definition is a local decl in a Let statement.- -- demoteInStmt (letStmt@(HsLetStmt ds stmts):: (HsStmt (HsExpP) (HsPatP) [HsDeclP]))- demoteInStmt (letStmt@(GHC.LetStmt binds)::GHC.Stmt GHC.Name)- -- was | definingDecls [pn] ds False False /=[]- | not $ emptyList (definingDeclsNames [pn] (hsBinds binds) False False)- = do- logm "MoveDef:demoteInStmt" -- ++AZ++- done <- getRefactDone- letStmt' <- if (not done)- then doDemoting' letStmt pn- else return letStmt- return letStmt'- demoteInStmt x =return x-- -- TODO: the rest of these cases below-{-- failure=idTP `adhocTP` mod- where- mod (m::HsModuleP)- = error "Refactoring failed!" --SHOULD GIVE MORE DETAILED ERROR MESSAGE--}------ |Demote the declaration of 'pn' in the context of 't'.-doDemoting' :: (HsValBinds t, UsedByRhs t) => t -> GHC.Name -> RefactGhc t-doDemoting' t pn- = let origDecls = hsBinds t- demotedDecls'= definingDeclsNames [pn] origDecls True False- declaredPns = nub $ concatMap definedPNs demotedDecls'- in if not (usedByRhs t declaredPns)- then do- -- drawTokenTree "" -- ++AZ++ debug- let demotedDecls = definingDeclsNames [pn] (hsBinds t) True True- -- logm $ "doDemoting':demotedDecls=" ++ (showGhc demotedDecls) -- ++AZ++- -- find how many matches/pattern bindings (except the binding defining pn) use 'pn'- -- uselist <- uses declaredPns (hsBinds t\\demotedDecls)- let -- uselist = uses declaredPns (hsBinds t\\demotedDecls)- otherBinds = (deleteFirstsBy sameBind (hsBinds t) demotedDecls)- -- uselist = uses declaredPns otherBinds- {- From 'hsDecls t' to 'hsDecls t \\ demotedDecls'.- Bug fixed 06/09/2004 to handle direct recursive function.- -}- -- uselist = concatMap (\r -> if (emptyList r) then [] else ["Used"]) $ map (\b -> uses declaredPns [b]) otherBinds- xx = map (\b -> (b,uses declaredPns [b])) otherBinds- uselist = concatMap (\(b,r) -> if (emptyList r) then [] else [b]) xx- useCount = sum $ concatMap snd xx- logm $ "doDemoting': uses xx=" ++ (showGhc xx)- logm $ "doDemoting': uses uselist=" ++ (showGhc uselist)- logm $ "doDemoting': uses useCount=" ++ (show useCount)-- -- case length uselist of- case useCount of- 0 ->do error "\n Nowhere to demote this function!\n"- 1 -> --This function is only used by one friend function- do- -- drawTokenTree "" -- ++AZ++ debug- logm "MoveDef.doDemoting':target location found" -- ++AZ++- -- (f,d)<-hsFreeAndDeclaredPNs demotedDecls- (f,_d) <- hsFreeAndDeclaredPNs demotedDecls- -- remove demoted declarations- (ds,removedDecl,_sigRemoved) <- rmDecl pn False (hsBinds t)- (t',demotedSigs) <- rmTypeSigs declaredPns t-- let (GHC.L ssd _) = removedDecl- demotedToks <- getToksForSpan ssd-- -- TODO: move this to its own fn- let getToksForMaybeSig (GHC.L ss _) = do- sigToks <- getToksForSpan ss- return sigToks-- demotedSigToksLists <- mapM getToksForMaybeSig demotedSigs- let demotedSigToks = concat demotedSigToksLists- -- end TODO-- logm $ "MoveDef:declaredPns=" ++ (showGhc declaredPns) -- ++AZ++- -- logm $ "MoveDef:demotedSigToks=" ++ (show demotedSigToks) -- ++AZ++-- -- logm $ "MoveDef:sig and decl toks[" ++ (GHC.showRichTokenStream (demotedSigToks ++ demotedToks)) ++ "]" -- ++AZ++-- --get those variables declared at where the demotedDecls will be demoted to- -- let dl = map (flip declaredNamesInTargetPlace ds) declaredPns- dl <- mapM (flip declaredNamesInTargetPlace ds) declaredPns- logm $ "mapM declaredNamesInTargetPlace done"- --make sure free variable in 'f' do not clash with variables in 'dl',- --otherwise do renaming.- let clashedNames=filter (\x-> elem (id x) (map id f)) $ (nub.concat) dl- --rename clashed names to new names created automatically,update TOKEN STREAM as well.- if clashedNames/=[]- then error ("The identifier(s):" ++ showGhc clashedNames ++- ", declared in where the definition will be demoted to, will cause name clash/capture"- ++" after demoting, please do renaming first!")- --ds'<-foldM (flip (autoRenameLocalVar True)) ds clashedNames- else --duplicate demoted declarations to the right place.- do- logm $ "MoveDef: about to duplicateDecls"- -- ds'' <- duplicateDecls declaredPns removedDecl demotedSigs (Just (demotedSigToks ++ demotedToks)) origDecls- ds'' <- duplicateDecls declaredPns removedDecl demotedSigs (Just (demotedSigToks ++ demotedToks)) ds- logm $ "MoveDef:duplicateDecls done"-- -- drawTokenTree "" -- ++AZ++ debug-- return (replaceBinds t' ds'')- _ ->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"--- where- ---find how many matches/pattern bindings use 'pn'-------- uses :: [GHC.Name] -> [GHC.LHsBind GHC.Name] -> [Int]- uses pns t2- = concatMap used t2- where-- used :: GHC.LHsBind GHC.Name -> [Int]- used (GHC.L _ (GHC.FunBind _n _ (GHC.MatchGroup matches _) _ _ _))- = concatMap (usedInMatch pns) matches-- used (GHC.L _ (GHC.PatBind pat rhs _ _ _))- -- was | hsPNs p `intersect` pns ==[] && any (flip findPN pat) pns- | (not $ findPNs pns pat) && findPNs pns rhs- = [1::Int]- used _ = []-- usedInMatch pns (GHC.L _ (GHC.Match pats _ rhs))- -- was | isNothing (find (==pname) pns) && any (flip findPN match) pns- | (not $ findPNs pns pats) && findPNs pns rhs- = [1::Int]- usedInMatch _ _ = []--- uses' :: [GHC.Name] -> [GHC.LHsBind GHC.Name] -> [Int]- uses' pns t2- = concat $ SYB.everythingStaged SYB.Renamer (++) []- ([] `SYB.mkQ` usedInMatch- `SYB.extQ` usedInPat) t2- where- -- ++AZ++ Not in pattern, but is in RHS- -- usedInMatch (match@(HsMatch _ (PNT pname _ _) _ _ _)::HsMatchP)- usedInMatch ((GHC.Match pats _ rhs) :: GHC.Match GHC.Name)- -- was | isNothing (find (==pname) pns) && any (flip findPN match) pns- | (not $ findPNs pns pats) && findPNs pns rhs- = return [1::Int]- usedInMatch _ = return []- -- usedInMatch _ = mzero-- -- usedInPat (pat@(Dec (HsPatBind _ p _ _)):: HsDeclP)- usedInPat ((GHC.PatBind pat rhs _ _ _) :: GHC.HsBind GHC.Name)- -- was | hsPNs p `intersect` pns ==[] && any (flip findPN pat) pns- | (not $ findPNs pns pat) && findPNs pns rhs- = return [1::Int]- usedInPat _ = return []- -- usedInPat _ = mzero--- -- duplicate demotedDecls to the right place (the outer most level where it is used).- -- duplicateDecls :: [GHC.Name] -> [GHC.LHsBind GHC.Name] -> RefactGhc [GHC.LHsBind GHC.Name]- duplicateDecls :: [GHC.Name] -- ^ function names to be demoted- -> GHC.LHsBind GHC.Name -- ^Bind being demoted- -> [GHC.LSig GHC.Name] -- ^Signatures being demoted, if any- -> Maybe [PosToken] -- ^Tokens if provided- -> [GHC.LHsBind GHC.Name] -- ^Binds of original top level entiity, including src and dst- -> RefactGhc [GHC.LHsBind GHC.Name]- -- duplicateDecls :: (SYB.Data t) =>[GHC.Name] -> t -> RefactGhc [GHC.LHsBind GHC.Name]- duplicateDecls pns demoted dsig dtoks decls- -- = do everywhereMStaged SYB.Renamer (SYB.mkM dupInMatch- = do- -- logm "duplicateDecls:clearing done" -- ++AZ++- -- clearRefactDone- everywhereMStaged' SYB.Renamer (SYB.mkM dupInMatch -- top-down approach- -- = do somewhereMStaged SYB.Renamer (SYB.mkM dupInMatch -- need working MonadPlus for somewhereMStaged- `SYB.extM` dupInPat) decls- {-- = do applyTP (once_tdTP (failTP `adhocTP` dupInMatch- `adhocTP` dupInPat)) decls- --error (show decls' ++ "\n" ++ prettyprint decls')- -- rmDecl (ghead "moveDecl3" pns) False =<<foldM (flip rmTypeSig) decls' pns - -}- where- -- dupInMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP)- dupInMatch (match@(GHC.Match pats _mt rhs) :: GHC.Match GHC.Name)- -- was | any (flip findPN match) pns && not (any (flip findPN name) pns)- | (not $ findPNs pns pats) && findPNs pns rhs- = do- done <- getRefactDone- logm $ "duplicateDecls:value of done=" ++ (show done) -- ++AZ++- if done- then return match- else do- logm "duplicateDecls:setting done" -- ++AZ++- setRefactDone- --If not fold parameters.- -- moveDecl pns pats False decls False- {- ++AZ++ foldParams instead- rhs' <- addDecl rhs Nothing (demoted,dsig,dtoks) False- return (GHC.Match pats mt rhs')- -}- -- If fold parameters.- -- error "dupInMatch" -- ++AZ++- match' <- foldParams pns match decls demoted dsig dtoks- return match'- -- dupInMatch _ =mzero- dupInMatch x = return x-- -- dupInPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP)- dupInPat ((GHC.PatBind pat rhs ty fvs ticks) :: GHC.HsBind GHC.Name)- -- was |any (flip findPN pat) pns && not (any (flip findPN p) pns)- | (not $ findPNs pns pat) && findPNs pns rhs- -- = moveDecl pns pat False decls False- = do- -- rhs' <- moveDecl pns rhs False decls False- -- TODO: what wbout dtoks?- -- error "dupInPat" -- ++AZ++- rhs' <- moveDecl1 rhs Nothing pns Nothing pns False- return (GHC.PatBind pat rhs' ty fvs ticks)- -- dupInPat _ =mzero- dupInPat x = return x-- -- demotedDecls = definingDecls pns decls True False- ---------------------------------------------------------------------- {-- declaredNamesInTargetPlace :: (Term t, MonadPlus m)=>PName->t->m [PName]- declaredNamesInTargetPlace pn=applyTU (stop_tdTU (failTU- `adhocTU` inMatch- `adhocTU` inPat))- -}- declaredNamesInTargetPlace :: (SYB.Data t)- => GHC.Name -> t- -- -> RefactGhc [GHC.Name]- -> RefactGhc [GHC.Name]-- declaredNamesInTargetPlace pn' t' = do- logm $ "declaredNamesInTargetPlace:pn=" ++ (showGhc pn')- res <- applyTU (stop_tdTUGhc (failTU- `adhocTU` inMatch- `adhocTU` inPat)) t'- logm $ "declaredNamesInTargetPlace:res=" ++ (showGhc res)- return res- where- -- inMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP)- inMatch ((GHC.Match _pats _ rhs) :: GHC.Match GHC.Name)- | findPN pn' rhs = do- logm $ "declaredNamesInTargetPlace:inMatch"- fds <- hsFDsFromInside rhs- return $ snd fds- -- (return.snd) =<< hsFDsFromInside rhs- -- inMatch _ = mzero- inMatch _ = return mzero-- -- inPat (pat@(Dec (HsPatBind loc p rhs ds)):: HsDeclP)- inPat ((GHC.PatBind pat rhs _ _ _) :: GHC.HsBind GHC.Name)- |findPN pn' rhs = do- logm $ "declaredNamesInTargetPlace:inPat"- fds <- hsFDsFromInside pat- return $ snd fds- -- (return.snd) =<< hsFDsFromInside pat- -- inPat _= mzero- inPat _= return mzero------ --------------------------------------------------------------------------{- foldParams:remove parameters in the demotedDecls if possible- parameters: pn -- the function/pattern name to be demoted in PName format- match--where the demotedDecls will be demoted to- demotedDecls -- the declarations to be demoted.- example:- module Test where demote 'sq' module Test where- sumSquares x y ===> sumSquares x y =(sq 0) + (sq y)- = sq x 0+ sq x y where sq y=x ^ y- sq x y=x^y--}---PROBLEM: TYPE SIGNATURE SHOULD BE CHANGED.---- TEST THIS FUNCTION!!!-foldParams :: [GHC.Name] -- ^The (list?) function name being demoted- -> GHC.Match GHC.Name -- ^The RHS of the place to receive the demoted decls- -> [GHC.LHsBind GHC.Name] -- ^Binds of original top level entiity, including src and dst- -> GHC.LHsBind GHC.Name -- ^The decls being demoted- -> [GHC.LSig GHC.Name] -- ^Signatures being demoted, if any- -> Maybe [PosToken] -- ^Tokens if provided- -> RefactGhc (GHC.Match GHC.Name)-foldParams pns ((GHC.Match pats mt rhs)::GHC.Match GHC.Name) _decls demotedDecls dsig dtoks-- =do- logm $ "MoveDef.foldParams entered"- -- logm $ "MoveDef.foldParams:match=" ++ (SYB.showData SYB.Renamer 0 match)-- let matches=concatMap matchesInDecls [GHC.unLoc demotedDecls]- pn=ghead "foldParams" pns --pns /=[]- params <- allParams pn rhs []- if (length.nub.map length) params==1 -- have same number of param - && ((length matches)==1) -- only one 'match' in the demoted declaration- then do- let patsInDemotedDecls=(patsInMatch.(ghead "foldParams")) matches- subst=mkSubst patsInDemotedDecls params- fstSubst=map fst subst- sndSubst=map snd subst-- -- logm $ "MoveDef.foldParams before rmParamsInParent"- rhs' <- rmParamsInParent pn sndSubst rhs- -- logm $ "MoveDef.foldParams after rmParamsInParent"-- -- ls<-mapM hsFreeAndDeclaredPNs sndSubst- -- ls <- mapM hsFreeAndDeclaredPNs sndSubst- ls <- mapM hsFreeAndDeclaredPNs sndSubst- -- newNames contains the newly introduced names to the demoted decls---- -- let newNames=(map pNtoName (concatMap fst ls)) \\ (map pNtoName fstSubst)- let newNames=((concatMap fst ls)) \\ (fstSubst)- --There may be name clashing because of introducing new names.- clashedNames<-getClashedNames fstSubst newNames (ghead "foldParams" matches)-- logm $ "MoveDef.foldParams about to foldInDemotedDecls"-- -- decls' <- foldInDemotedDecls pns clashedNames subst decls- -- let demotedDecls''' = definingDeclsNames pns decls' True False- demotedDecls''' <- foldInDemotedDecls pns clashedNames subst [demotedDecls]- logm $ "MoveDef.foldParams foldInDemotedDecls done"-- let [(GHC.L declSpan _)] = demotedDecls'''- declToks <- getToksForSpan declSpan- -- logm $ "MoveDef.foldParams addDecl adding to (hsBinds):[" ++ (SYB.showData SYB.Renamer 0 $ hsBinds rhs') ++ "]" -- ++AZ++- rhs'' <- addDecl rhs' Nothing (ghead "foldParams 2" demotedDecls''',[],Just declToks) False- logm $ "MoveDef.foldParams addDecl done"- return (GHC.Match pats mt rhs'')- else do -- moveDecl pns match False decls True- -- return (HsMatch loc1 name pats rhs (ds++demotedDecls)) -- no parameter folding - -- logm $ "MoveDef.foldParams about to addDecl:dtoks=" ++ (show dtoks)- -- drawTokenTree "" -- ++AZ++ debug- rhs' <- addDecl rhs Nothing (demotedDecls,dsig,dtoks) False- return (GHC.Match pats mt rhs')-- -- return match- where-- -- matchesInDecls ((Dec (HsFunBind loc matches))::HsDeclP)=matches- matchesInDecls (GHC.FunBind _ _ (GHC.MatchGroup matches _) _ _ _) = matches- matchesInDecls _x = []-- -- patsInMatch ((HsMatch loc1 name pats rhs ds)::HsMatchP)- -- =pats- patsInMatch (GHC.L _ (GHC.Match pats' _ _)) = pats'-- -- demotedDecls = map GHC.unLoc $ definingDeclsNames pns decls True False--- foldInDemotedDecls :: [GHC.Name] -- ^The (list?) of names to be demoted- -> [GHC.Name] -- ^Any names that clash- -> [(GHC.Name, GHC.HsExpr GHC.Name)] -- ^Parameter substitutions required- -> [GHC.LHsBind GHC.Name] -- ^Binds of original top level entiity, including src and dst- -> RefactGhc [GHC.LHsBind GHC.Name]- foldInDemotedDecls pns' clashedNames subst decls- = everywhereMStaged SYB.Renamer (SYB.mkM worker) decls- where- -- worker (match@(HsMatch loc1 (PNT pname _ _) pats rhs ds)::HsMatchP)- worker (match@(GHC.FunBind (GHC.L _ pname) _ (GHC.MatchGroup _matches _) _ _ _) :: GHC.HsBind GHC.Name)- | isJust (find (==pname) pns')- = do- match' <- foldM (flip (autoRenameLocalVar True)) match clashedNames- match'' <- foldM replaceExpWithUpdToks match' subst- rmParamsInDemotedDecls (map fst subst) match''-- worker x = return x-- ------Get all of the paramaters supplied to pn ---------------------------- {- eg. sumSquares x1 y1 x2 y2 = rt x1 y1 + rt x2 y2- rt x y = x+y- demote 'rt' to 'sumSquares',- 'allParams pn rhs []' returns [[x1,x2],[y1,y2]]- where pn is 'rt' and rhs is 'rt x1 y1 + rt x2 y2'- -}-- allParams :: GHC.Name -> GHC.GRHSs GHC.Name -> [[GHC.HsExpr GHC.Name]]- -> RefactGhc [[GHC.HsExpr GHC.Name]]- allParams pn rhs1 initial -- pn: demoted function/pattern name.- =do -- p<-getOneParam pn rhs- let p = getOneParam pn rhs1- -- putStrLn (show p)- if (nonEmptyList p) then do rhs' <- rmOneParam pn rhs1- -- error $ "allParams: rhs=" ++ (SYB.showData SYB.Renamer 0 rhs) -- ++AZ++- -- error $ "allParams: rhs'=" ++ (SYB.showData SYB.Renamer 0 rhs') -- ++AZ++- allParams pn rhs' (initial++[p])- else return initial- where- getOneParam :: (SYB.Data t) => GHC.Name -> t -> [GHC.HsExpr GHC.Name]- getOneParam pn1- = SYB.everythingStaged SYB.Renamer (++) []- ([] `SYB.mkQ` worker)- -- =applyTU (stop_tdTU (failTU `adhocTU` worker))- where- worker :: GHC.HsExpr GHC.Name -> [GHC.HsExpr GHC.Name]- worker (GHC.HsApp e1 e2)- |(expToName e1==pn1) = [GHC.unLoc e2]- worker _ = []- rmOneParam :: (SYB.Data t) => GHC.Name -> t -> RefactGhc t- rmOneParam pn1 t- -- This genuinely needs to be done once only. Damn.- -- =applyTP (stop_tdTP (failTP `adhocTP` worker))- = do- -- _ <- clearRefactDone- everywhereMStaged' SYB.Renamer (SYB.mkM worker) t- where- {-- worker :: GHC.HsExpr GHC.Name -> RefactGhc (GHC.HsExpr GHC.Name)- worker e@(GHC.HsApp e1 e2 ) = do -- The param being removed is e2- done <- getRefactDone- case (not done) && expToName e1==pn1 of- True -> do setRefactDone- return (GHC.unLoc e1)- False -> return e- worker x = return x- -}- worker (GHC.HsApp e1 _e2 ) -- The param being removed is e2- |expToName e1==pn1 = return (GHC.unLoc e1)- worker x = return x-{-- AST output-- addthree x y z-- becomes-- (HsApp- (L {test/testdata/Demote/WhereIn6.hs:10:17-28}- (HsApp- (L {test/testdata/Demote/WhereIn6.hs:10:17-26}- (HsApp- (L {test/testdata/Demote/WhereIn6.hs:10:17-24}- (HsVar {Name: WhereIn6.addthree}))- (L {test/testdata/Demote/WhereIn6.hs:10:26}- (HsVar {Name: x}))))- (L {test/testdata/Demote/WhereIn6.hs:10:28}- (HsVar {Name: y}))))- (L {test/testdata/Demote/WhereIn6.hs:10:30}- (HsVar {Name: z})))-------- (HsApp- (HsApp- (HsApp- (HsVar {Name: WhereIn6.addthree}))- (HsVar {Name: x}))))- (HsVar {Name: y}))))- (HsVar {Name: z})))--------- sq p x-- becomes-- (HsApp- (HsApp- (HsVar {Name: Demote.WhereIn4.sq}))- (HsVar {Name: p}))))- (HsVar {Name: x})))------- sq x-- becomes-- (HsApp- (HsVar {Name: sq}))- (HsVar {Name: x})))--}--- -----------remove parameters in demotedDecls-------------------------------- rmParamsInDemotedDecls :: [GHC.Name] -> GHC.HsBind GHC.Name- -> RefactGhc (GHC.HsBind GHC.Name)- rmParamsInDemotedDecls ps bind- -- = error $ "rmParamsInDemotedDecls: (ps,bind)=" ++ (showGhc (ps,bind)) -- ++AZ++- -- =applyTP (once_tdTP (failTP `adhocTP` worker))- = everywhereMStaged SYB.Renamer (SYB.mkM worker) bind- -- where worker ((HsMatch loc1 name pats rhs ds)::HsMatchP)- where worker (GHC.Match pats2 typ rhs1)- = do- let pats'=filter (\x->not ((patToPNT x /= Nothing) &&- elem (gfromJust "rmParamsInDemotedDecls" $ patToPNT x) ps)) pats2-- let (startPos,endPos) = getBiggestStartEndLoc pats2- -- error $ "rmParamsInDemotedDecls:(startPos,endPos)=" ++ (show (startPos,endPos)) -- ++AZ++- -- error $ "rmParamsInDemotedDecls:(prettyprint pats')=" ++ (prettyprint pats) -- ++AZ++- if (emptyList pats')- then removeToksForPos (startPos,endPos)- else -- updateToksWithPos (startPos,endPos) pats' prettyprint False- updateToksWithPos (startPos,endPos) pats' pprPat False- -- toks <- fetchToks- -- error $ "rmParamsInDemotedDecls:(toks)=" ++ (showToks toks) -- ++AZ++- -- let (toks1, _, toks2) = splitToks (startPos, (endRow,(endCol - 1))) toks- -- error $ "rmParamsInDemotedDecls:(last toks1,head toks2)=" ++ (showToks [last toks1, head toks2]) -- ++AZ++-- -- pats'' <- update pats pats' pats-- return (GHC.Match pats' typ rhs1)-- pprPat pat = intercalate " " $ map (\p -> (prettyprint p )) pat-- ----------remove parameters in the parent functions' rhs-------------------- --Attention: PNT i1 _ _==PNT i2 _ _ = i1 =i2- rmParamsInParent :: GHC.Name -> [GHC.HsExpr GHC.Name] -> GHC.GRHSs GHC.Name- -> RefactGhc (GHC.GRHSs GHC.Name)- rmParamsInParent pn es- -- =applyTP (full_buTP (idTP `adhocTP` worker))- = everywhereMStaged SYB.Renamer (SYB.mkM worker)- where worker expr@(GHC.L _ (GHC.HsApp e1 e2))- -- was | findPN pn e1 && (elem (GHC.unLoc e2) es)- | findPN pn e1 && (elem (showGhc (GHC.unLoc e2)) (map (showGhc) es))- = update expr e1 expr- worker (expr@(GHC.L _ (GHC.HsPar e1)))- |pn==expToName e1- = update expr e1 expr- worker x =return x--- getClashedNames oldNames newNames match- = do (_f,d) <- hsFDsFromInside match- -- ds' <- mapM (flip hsVisiblePNs match) oldNames- ds' <- mapM (flip hsVisiblePNs match) oldNames- -- return clashed names- return (filter (\x->elem ({- pNtoName -} x) newNames) --Attention: nub- ( nub (d `union` (nub.concat) ds')))-- ----- make Substitions between formal and actual parameters.------------------ mkSubst :: [GHC.LPat GHC.Name] -> [[GHC.HsExpr GHC.Name]] -> [(GHC.Name,GHC.HsExpr GHC.Name)]- mkSubst pats1 params- = catMaybes (zipWith (\x y -> if (patToPNT x/=Nothing) && (length (nub $ map showGhc y)==1)- then Just (gfromJust "mkSubst" $ patToPNT x,(ghead "mkSubst") y)- else Nothing) pats1 params)----- |substitute an old expression by new expression-replaceExpWithUpdToks :: (SYB.Data t)- => t -> (GHC.Name, GHC.HsExpr GHC.Name)- -> RefactGhc t-replaceExpWithUpdToks decls subst- -- = applyTP (full_buTP (idTP `adhocTP` worker)) decls- = everywhereMStaged' SYB.Renamer (SYB.mkM worker) decls- where worker (e@(GHC.L l _)::GHC.LHsExpr GHC.Name)- |(expToName e/=defaultName) && (expToName e)==(fst subst)- = update e (GHC.L l (snd subst)) e- worker x=return x----- | 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---- ------------------------------------------------------------------------- |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 -> ([t], [t], [t])-divideDecls ds pnt- -- = error "undefined divideDecls"- = let (before,after)=break (\x->findPNT pnt x) ds- in if (not $ emptyList after)- then (before, [ghead "divideDecls" after], tail after)- else (ds,[],[])
+ src/Language/Haskell/Refact/Refactoring/Case.hs view
@@ -0,0 +1,228 @@+module Language.Haskell.Refact.Refactoring.Case(ifToCase) where++import qualified Data.Generics as SYB+import qualified GHC.SYB.Utils as SYB++import qualified GHC as GHC++import Control.Monad+import Control.Monad.IO.Class+import Language.Haskell.GhcMod+import Language.Haskell.Refact.API++-- ---------------------------------------------------------------------++-- | Convert an if expression to a case expression+ifToCase :: RefactSettings -> Cradle -> FilePath -> SimpPos -> SimpPos -> IO [FilePath]+ifToCase settings cradle fileName beginPos endPos =+ runRefacSession settings cradle (comp fileName beginPos endPos)++comp :: FilePath -> SimpPos -> SimpPos -> RefactGhc [ApplyRefacResult]+comp fileName beginPos endPos = do+ getModuleGhc fileName+ renamed <- getRefactRenamed+ logm $ "Case.comp:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ+++ let expr = locToExp beginPos endPos renamed+ -- logm $ "Case.comp:expr=" ++ (SYB.showData SYB.Renamer 0 expr) -- ++AZ+++ case expr of+ Just exp1@(GHC.L _ (GHC.HsIf _ _ _ _))+ -> do (refactoredMod,_) <- applyRefac (doIfToCaseInternal exp1) RSAlreadyLoaded+ return [refactoredMod]+ _ -> error $ "You haven't selected an if-then-else expression!" -- ++ (show (beginPos,endPos,fileName)) ++ "]:" ++ (SYB.showData SYB.Parser 0 $ ast)++doIfToCaseInternal ::+ GHC.Located (GHC.HsExpr GHC.Name)+ -> RefactGhc ()+doIfToCaseInternal expr = do+ rs <- getRefactRenamed+ reallyDoIfToCase expr rs++reallyDoIfToCase ::+ GHC.Located (GHC.HsExpr GHC.Name)+ -> GHC.RenamedSource+ -> RefactGhc ()+reallyDoIfToCase expr rs = do++ void $ everywhereMStaged SYB.Renamer (SYB.mkM inExp) rs+ showLinesDebug "after refactoring"+ return ()+ where+ inExp :: (GHC.Located (GHC.HsExpr GHC.Name)) -> RefactGhc (GHC.Located (GHC.HsExpr GHC.Name))+ inExp exp1@(GHC.L l (GHC.HsIf _se (GHC.L l1 _) (GHC.L l2 _) (GHC.L l3 _)))+ | sameOccurrence expr exp1+ = do+ -- drawTokenTreeDetailed "reallyDoIfToCase" -- ++AZ++ debug+ newExp <- ifToCaseTransform exp1++ let (GHC.RealSrcLoc rl) = GHC.srcSpanStart l+ caseTok <- liftIO $ tokenise rl 0 False "case"+ condToks <- getToksForSpan l1+ ofTok <- liftIO $ tokenise (realSrcLocFromTok (glast "reallyDoIfToCase" condToks)) 1 True "of"+ trueToks <- liftIO $ basicTokenise "True ->"+ falseToks <- liftIO $ basicTokenise "False ->"+ thenToksRaw <- getToksForSpan l2+ elseToksRaw <- getToksForSpan l3++ let thenToks = dropWhile isEmpty thenToksRaw+ let elseToks = dropWhile isEmpty elseToksRaw++ logm $ "reallyDoIfToCase:elseToks=" ++ (show elseToks)++ let t0 = reIndentToks PlaceAdjacent caseTok condToks+ let t1' = reIndentToks PlaceAdjacent (caseTok ++ t0) ofTok+ let t1 = caseTok ++ t0 ++ t1'++ let t2 = reIndentToks (PlaceIndent 1 4 0) t1 trueToks+ let t3 = reIndentToks PlaceAdjacent (t1++t2) thenToks++ let (_,col) = tokenPos $ ghead "reallyDoIfToCase" t2++ let t4 = reIndentToks (PlaceAbsCol 1 col 0) (t1++t2++t3) falseToks+ -- logm $ "reallyDoIfToCase:(t1++t2++t3++t4)=" ++ (show (t1++t2++t3++t4))+ let t5 = reIndentToks PlaceAdjacent (t1++t2++t3++t4) elseToks++ let caseToks = t1++t2++t3++t4++t5 ++ [newLnToken (last t5)]++ logm $ "reallyDoIfToCase:t1=[" ++ (GHC.showRichTokenStream t1) ++ "]"+ logm $ "reallyDoIfToCase:t2=[" ++ (GHC.showRichTokenStream t2) ++ "]"+ logm $ "reallyDoIfToCase:t3=[" ++ (GHC.showRichTokenStream t3) ++ "]"++ -- logm $ "reallyDoIfToCase:t1++t2++t3=" ++ (show (t1++t2++t3))++ logm $ "reallyDoIfToCase:t4=[" ++ (GHC.showRichTokenStream t4) ++ "]"+ logm $ "reallyDoIfToCase:t5=[" ++ (GHC.showRichTokenStream t5) ++ "]"++ logm $ "reallyDoIfToCase:caseToks=" ++ (show caseToks)++ -- drawTokenTreeDetailed "reallyDoIfToCase"++ void $ putToksForSpan l caseToks++ -- drawTokenTree "reallyDoIfToCase after putToks"+ -- drawTokenTreeDetailed "reallyDoIfToCase after putToks"++ return newExp++ inExp e = return e++-- TODO: rearrange the structure and preserve the comments in the original, e.g. in e1,e2,e3+ifToCaseTransform :: GHC.Located (GHC.HsExpr GHC.Name) -> RefactGhc (GHC.Located (GHC.HsExpr GHC.Name))+ifToCaseTransform (GHC.L l (GHC.HsIf _se e1 e2 e3)) = do+ trueName <- mkNewGhcName Nothing "True"+ falseName <- mkNewGhcName Nothing "False"+ let ret = GHC.L l (GHC.HsCase e1+ (GHC.MatchGroup+ [+ (GHC.noLoc $ GHC.Match+ [+ GHC.noLoc $ GHC.ConPatIn (GHC.noLoc trueName) (GHC.PrefixCon [])+ ]+ Nothing+ ((GHC.GRHSs+ [+ GHC.noLoc $ GHC.GRHS [] e2+ ] GHC.EmptyLocalBinds))+ )+ , (GHC.noLoc $ GHC.Match+ [+ GHC.noLoc $ GHC.ConPatIn (GHC.noLoc falseName) (GHC.PrefixCon [])+ ]+ Nothing+ ((GHC.GRHSs+ [+ GHC.noLoc $ GHC.GRHS [] e3+ ] GHC.EmptyLocalBinds))+ )+ ] undefined))+ return ret+ifToCaseTransform x = return x++-- ---------------------------------------------------------------------+{-+HsIf (Maybe (SyntaxExpr id)) (LHsExpr id) (LHsExpr id) (LHsExpr id)++[Can ignore The SyntaxExpr]+++HsCase (LHsExpr id) (MatchGroup id)++-}++{-+Need to move to++(L {test/testdata/Case/B.hs:(9,10)-(11,17)} + (HsCase + (L {test/testdata/Case/B.hs:9:15-21} + (HsPar + (L {test/testdata/Case/B.hs:9:16-20} + (HsApp + (L {test/testdata/Case/B.hs:9:16-18} + (HsVar {Name: GHC.Real.odd})) + (L {test/testdata/Case/B.hs:9:20} + (HsVar {Name: x})))))) + (MatchGroup + [+ (L {test/testdata/Case/B.hs:10:3-15} + (Match + [+ (L {test/testdata/Case/B.hs:10:3-6} + (ConPatIn + (L {test/testdata/Case/B.hs:10:3-6} {Name: GHC.Types.True}) + (PrefixCon + [])))] + (Nothing) + (GRHSs + [+ (L {test/testdata/Case/B.hs:10:11-15} + (GRHS + [] + (L {test/testdata/Case/B.hs:10:11-15} + (HsLit + (HsString {FastString: "Odd"})))))] + (EmptyLocalBinds)))),+ (L {test/testdata/Case/B.hs:11:3-17} + (Match + [+ (L {test/testdata/Case/B.hs:11:3-7} + (ConPatIn + (L {test/testdata/Case/B.hs:11:3-7} {Name: GHC.Types.False}) + (PrefixCon + [])))] + (Nothing) + (GRHSs + [+ (L {test/testdata/Case/B.hs:11:12-17} + (GRHS + [] + (L {test/testdata/Case/B.hs:11:12-17} + (HsLit + (HsString {FastString: "Even"})))))] + (EmptyLocalBinds))))] {!type placeholder here?!})))++from ---++(L {test/testdata/Case/B.hs:4:9-41} + (HsIf + (Nothing) + (L {test/testdata/Case/B.hs:4:12-18} + (HsPar + (L {test/testdata/Case/B.hs:4:13-17} + (HsApp + (L {test/testdata/Case/B.hs:4:13-15} + (HsVar {Name: GHC.Real.odd})) + (L {test/testdata/Case/B.hs:4:17} + (HsVar {Name: x})))))) + (L {test/testdata/Case/B.hs:4:25-29} + (HsLit + (HsString {FastString: "Odd"}))) + (L {test/testdata/Case/B.hs:4:36-41} + (HsLit + (HsString {FastString: "Even"})))))++-}++-- EOF+++
+ src/Language/Haskell/Refact/Refactoring/DupDef.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}++module Language.Haskell.Refact.Refactoring.DupDef(duplicateDef) where++import qualified Data.Generics as SYB+import qualified GHC.SYB.Utils as SYB++import qualified GHC+import qualified OccName as GHC++import Control.Monad+import Data.List+import Data.Maybe++import Language.Haskell.GhcMod+import Language.Haskell.Refact.API+++-- ---------------------------------------------------------------------+-- | This refactoring duplicates a definition (function binding or+-- simple pattern binding) at the same level with a new name provided by+-- the user. The new name should not cause name clash/capture.+duplicateDef :: RefactSettings -> Cradle -> FilePath -> String -> SimpPos -> IO [FilePath]+duplicateDef settings cradle fileName newName (row,col) =+ runRefacSession settings cradle (comp fileName newName (row,col))++comp :: FilePath -> String -> SimpPos+ -> RefactGhc [ApplyRefacResult]+comp fileName newName (row, col) = do+ if isVarId newName+ then do+ getModuleGhc fileName+ renamed <- getRefactRenamed+ parsed <- getRefactParsed++ let (Just (modName,_)) = getModuleName parsed+ let maybePn = locToName (row, col) renamed+ case maybePn of+ Just pn ->+ do+ -- refactoredMod@((_fp,ismod),(_toks',renamed')) <- applyRefac (doDuplicating pn newName) (Just modInfo) fileName+ (refactoredMod@((_fp,ismod),(_,_toks',renamed')),_) <- applyRefac (doDuplicating pn newName) (RSFile fileName)+ case (ismod) of+ False -> error "The selected identifier is not a function/simple pattern name, or is not defined in this module "+ True -> return ()++ if modIsExported modName renamed+ then do clients <- clientModsAndFiles modName+ logm ("DupDef: clients=" ++ (showGhc clients)) -- ++AZ++ debug+ refactoredClients <- mapM (refactorInClientMod (GHC.unLoc pn) modName + (findNewPName newName renamed')) clients+ return $ refactoredMod:refactoredClients+ else return [refactoredMod]+ Nothing -> error "Invalid cursor position!"+ else error $ "Invalid new function name:" ++ newName ++ "!"++++doDuplicating :: GHC.Located GHC.Name -> String+ -> RefactGhc ()+doDuplicating pn newName = do+ inscopes <- getRefactInscopes+ renamed <- getRefactRenamed+ reallyDoDuplicating pn newName inscopes renamed+++reallyDoDuplicating :: GHC.Located GHC.Name -> String+ -> InScopes -> GHC.RenamedSource+ -> RefactGhc ()+reallyDoDuplicating pn newName inscopes renamed = do++ renamed' <- everywhereMStaged SYB.Renamer (SYB.mkM dupInMod+ `SYB.extM` dupInMatch+ `SYB.extM` dupInPat+ `SYB.extM` dupInLet+ `SYB.extM` dupInLetStmt+ ) renamed+ putRefactRenamed renamed'+ return ()++ where+ --1. The definition to be duplicated is at top level.+ -- dupInMod :: (GHC.HsGroup GHC.Name)-> RefactGhc (GHC.HsGroup GHC.Name)+ dupInMod (grp :: (GHC.HsGroup GHC.Name))+ | not $ emptyList (findFunOrPatBind pn (hsBinds grp)) = doDuplicating' inscopes grp pn+ dupInMod grp = return grp++ --2. The definition to be duplicated is a local declaration in a match+ dupInMatch (match@(GHC.Match _pats _typ rhs)::GHC.Match GHC.Name)+ | not $ emptyList (findFunOrPatBind pn (hsBinds rhs)) = doDuplicating' inscopes match pn+ dupInMatch match = return match++ --3. The definition to be duplicated is a local declaration in a pattern binding+ dupInPat (pat@(GHC.PatBind _p rhs _typ _fvs _) :: GHC.HsBind GHC.Name)+ | not $ emptyList (findFunOrPatBind pn (hsBinds rhs)) = doDuplicating' inscopes pat pn+ dupInPat pat = return pat++ --4: The defintion to be duplicated is a local decl in a Let expression+ dupInLet (letExp@(GHC.HsLet ds _e):: GHC.HsExpr GHC.Name)+ | not $ emptyList (findFunOrPatBind pn (hsBinds ds)) = doDuplicating' inscopes letExp pn+ dupInLet letExp = return letExp++ --5. The definition to be duplicated is a local decl in a case alternative.+ -- Note: The local declarations in a case alternative are covered in #2 above.++ --6.The definition to be duplicated is a local decl in a Let statement.+ dupInLetStmt (letStmt@(GHC.LetStmt ds):: GHC.Stmt GHC.Name)+ -- was |findFunOrPatBind pn ds /=[]=doDuplicating' inscps letStmt pn+ |not $ emptyList (findFunOrPatBind pn (hsBinds ds)) = doDuplicating' inscopes letStmt pn+ dupInLetStmt letStmt = return letStmt+++ -- findFunOrPatBind :: (SYB.Data t) => GHC.Located GHC.Name -> t -> [GHC.LHsBind GHC.Name]+ findFunOrPatBind (GHC.L _ n) ds = filter (\d->isFunBindR d || isSimplePatBind d) $ definingDeclsNames [n] ds True False+++ doDuplicating' :: (HsValBinds t) => InScopes -> t -> GHC.Located GHC.Name+ -> RefactGhc (t)+ doDuplicating' _inscps parentr ln@(GHC.L _ n)+ = do let+ declsr = hsBinds parentr++ duplicatedDecls = definingDeclsNames [n] declsr True False+ -- (after,before) = break (definesP pn) (reverse declsp)++ (f,d) <- hsFDNamesFromInside parentr+ --f: names that might be shadowd by the new name,+ --d: names that might clash with the new name++ dv <- hsVisibleNames ln declsr --dv: names may shadow new name+ let vars = nub (f `union` d `union` dv)++ newNameGhc <- mkNewGhcName Nothing newName+ -- TODO: Where definition is of form tup@(h,t), test each element of it for clashes, or disallow+ nameAlreadyInScope <- isInScopeAndUnqualifiedGhc newName Nothing++ -- logm ("DupDef: nameAlreadyInScope =" ++ (show nameAlreadyInScope)) -- ++AZ++ debug+ -- logm ("DupDef: ln =" ++ (show ln)) -- ++AZ++ debug++ if elem newName vars || (nameAlreadyInScope && findEntity ln duplicatedDecls) + then error ("The new name'"++newName++"' will cause name clash/capture or ambiguity problem after "+ ++ "duplicating, please select another name!")+ else do newBinding <- duplicateDecl declsr parentr n newNameGhc+ -- let newDecls = replaceDecls declsr (declsr ++ newBinding)+ let newDecls = replaceBinds declsr (declsr ++ newBinding)+ return $ replaceBinds parentr newDecls++++-- | Find the the new definition name in GHC.Name format.+findNewPName :: String -> GHC.RenamedSource -> GHC.Name+findNewPName name renamed = gfromJust "findNewPName" res+ where+ res = somethingStaged SYB.Renamer Nothing+ (Nothing `SYB.mkQ` worker) renamed++ worker (pname::GHC.Name)+ | (GHC.occNameString $ GHC.getOccName pname) == name = Just pname+ worker _ = Nothing+++-- | Do refactoring in the client module. That is to hide the+-- identifer in the import declaration if it will cause any problem in+-- the client module.+refactorInClientMod :: GHC.Name -> GHC.ModuleName -> GHC.Name -> TargetModule+ -> RefactGhc ApplyRefacResult+refactorInClientMod oldPN serverModName newPName targetModule@(_,modSummary)+ = do+ logm ("refactorInClientMod: (serverModName,newPName)=" ++ (showGhc (serverModName,newPName))) -- ++AZ++ debug+ void $ activateModule targetModule++ let fileName = gfromJust "refactorInClientMod" $ GHC.ml_hs_file $ GHC.ms_location modSummary+{-+ -- modInfo@(t,ts) <- getModuleGhc fileName+ getModuleGhc fileName+-}+ renamed <- getRefactRenamed+ parsed <- getRefactParsed++ let modNames = willBeUnQualImportedBy serverModName renamed+ logm ("refactorInClientMod: (modNames)=" ++ (showGhc (modNames))) -- ++AZ++ debug++ -- if isJust modNames && needToBeHided (pNtoName newPName) exps parsed+ mustHide <- needToBeHided newPName renamed parsed+ logm ("refactorInClientMod: (mustHide)=" ++ (showGhc (mustHide))) -- ++AZ++ debug+ if isJust modNames && mustHide+ then do+ -- refactoredMod <- applyRefac (doDuplicatingClient serverModName [newPName]) (Just modInfo) fileName+ (refactoredMod,_) <- applyRefac (doDuplicatingClient serverModName [newPName]) (RSFile fileName)+ return refactoredMod+ else return ((fileName,unmodified),([],[],renamed))+ where+ needToBeHided :: GHC.Name -> GHC.RenamedSource -> GHC.ParsedSource -> RefactGhc Bool+ needToBeHided name exps parsed = do+ let usedUnqual = usedWithoutQualR name parsed+ logm ("refactorInClientMod: (usedUnqual)=" ++ (showGhc (usedUnqual))) -- ++AZ++ debug+ return $ usedUnqual || causeNameClashInExports oldPN name serverModName exps++doDuplicatingClient :: GHC.ModuleName -> [GHC.Name]+ -> RefactGhc ()+doDuplicatingClient serverModName newPNames = do+ renamed <- getRefactRenamed+ renamed' <- addHiding serverModName renamed newPNames+ putRefactRenamed renamed'+ return ()++++--Check here:+-- | get the module name or alias name by which the duplicated+-- definition will be imported automatically.+willBeUnQualImportedBy :: GHC.ModuleName -> GHC.RenamedSource -> Maybe [GHC.ModuleName]+willBeUnQualImportedBy modName (_,imps,_,_)+ = let+ ms = filter (\(GHC.L _ (GHC.ImportDecl (GHC.L _ modName1) _qualify _source _safe isQualified _isImplicit _as h))+ -> modName == modName1+ && not isQualified+ && (isNothing h -- not hiding+ ||+ (isJust h && ((fst (gfromJust "willBeUnQualImportedBy" h))==True))+ ))+ imps+ in if (emptyList ms) then Nothing+ else Just $ nub $ map getModName ms++ where getModName (GHC.L _ (GHC.ImportDecl _modName1 _qualify _source _safe _isQualified _isImplicit as _h))+ = if isJust as then (fromJust as)+ else modName+ -- simpModName (SN m loc) = m+
+ src/Language/Haskell/Refact/Refactoring/MoveDef.hs view
@@ -0,0 +1,1475 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}++module Language.Haskell.Refact.Refactoring.MoveDef+ ( liftToTopLevel+ , liftOneLevel+ , demote+ -- ,liftingInClientMod+ ) where++import qualified Data.Generics as SYB+import qualified GHC.SYB.Utils as SYB++import qualified Exception as GHC+import qualified GHC+import qualified Name as GHC+import qualified Outputable as GHC++import Control.Exception+import Control.Monad.State+import qualified Data.Generics.Zipper as Z+import Data.List+import Data.Maybe++import Language.Haskell.GhcMod+import Language.Haskell.Refact.API++import Data.Generics.Strafunski.StrategyLib.StrategyLib++-- import Debug.Trace++-- ---------------------------------------------------------------------++-- data Direction = UptoTopLevel | UpOneLevel | Down++{--------This function handles refactorings involving moving a definition--------++ According to the Haskell's syntax, a declaration may occur in one of+the following six contexts:++ 1. A top level declaration in the module:+ old: HsModule SrcLoc ModuleName (Maybe [HsExportSpecI i]) [HsImportDeclI i] ds+ new: (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], Maybe LHsDocString)+ HsGroup hs_valds :: HsValBinds id ...++ 2. A local declaration in a Match: (of a FunBind)+ old: HsMatch SrcLoc i [p] (HsRhs e) ds+ new: Match [LPat id] (Maybe (LHsType id)) (GRHSs id)++ 3. A local declaration in a pattern binding:+ old: HsPatBind SrcLoc p (HsRhs e) ds+ new: PatBind (LPat idL) (GRHSs idR) PostTcType NameSet (Maybe tickish)++ 4. A local declaration in a Let expression:+ old: HsLet ds e+ new: HsLet (HsLocalBinds id) (LHsExpr id)++ 5. A local declaration in a Case alternative:+ old: HsAlt SrcLoc p (HsRhs e) ds+ new: HsCase (LHsExpr id) (MatchGroup id)+ new is same as in a FunBind.++ 6. A local declaration in a Do statement:+ old: HsLetStmt ds (HsStmt e p ds)+ new: LetStmt (HsLocalBindsLR idL idR)+ in context GRHS [LStmt id] (LHsExpr id)+-}++-- | Lift a definition to the top level+liftToTopLevel :: RefactSettings -> Cradle -> FilePath -> SimpPos -> IO [FilePath]+liftToTopLevel settings cradle fileName (row,col) =+ runRefacSession settings cradle (compLiftToTopLevel fileName (row,col))+++compLiftToTopLevel :: FilePath -> SimpPos+ -> RefactGhc [ApplyRefacResult]+compLiftToTopLevel fileName (row,col) = do+ getModuleGhc fileName+ renamed <- getRefactRenamed+ parsed <- getRefactParsed++ let (Just (modName,_)) = getModuleName parsed+ let maybePn = locToName (row, col) renamed+ case maybePn of+ Just pn -> do+ liftToTopLevel' modName pn+ _ -> error "\nInvalid cursor position!\n"+++-- ---------------------------------------------------------------------++-- | Move a definition one level up from where it is now+liftOneLevel :: RefactSettings -> Cradle -> FilePath -> SimpPos -> IO [FilePath]+liftOneLevel settings cradle fileName (row,col) =+ runRefacSession settings cradle (compLiftOneLevel fileName (row,col))+++compLiftOneLevel :: FilePath -> SimpPos+ -> RefactGhc [ApplyRefacResult]+compLiftOneLevel fileName (row,col) = do+ getModuleGhc fileName+ renamed <- getRefactRenamed+ parsed <- getRefactParsed++ -- logm $ "compLiftOneLevel:(fileName,row,col)="++(show (fileName,row,col))+ -- logm $ "compLiftOneLevel:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++++ let (Just (modName,_)) = getModuleName parsed+ let maybePn = locToName (row, col) renamed+ case maybePn of+ Just pn -> do+ rs <- liftOneLevel' modName pn+ logm $ "compLiftOneLevel:rs=" ++ (show $ (refactDone rs,map (\((_,d),_) -> d) rs))+ if (refactDone rs)+ then return rs+ else error ( "Lifting this definition failed. "+++ " This might be because that the definition to be "+++ "lifted is defined in a class/instance declaration.")+ _ -> error "\nInvalid cursor position!\n"++++-- ---------------------------------------------------------------------++-- | Move a definition one level down+demote :: RefactSettings -> Cradle -> FilePath -> SimpPos -> IO [FilePath]+demote settings cradle fileName (row,col) =+ runRefacSession settings cradle (compDemote fileName (row,col))++compDemote ::FilePath -> SimpPos+ -> RefactGhc [ApplyRefacResult]+compDemote fileName (row,col) = do+ getModuleGhc fileName+ renamed <- getRefactRenamed+ parsed <- getRefactParsed++ -- 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+ case maybePn of+ Just pn -> do+ demote' modName pn+ _ -> error "\nInvalid cursor position!\n"+++{-+demote args+ = do let fileName = ghead "filename" args+ row = read (args!!1)::Int+ col = read (args!!2)::Int+ modName <- fileNameToModName fileName+ (inscps, _, mod, toks) <- parseSourceFile fileName+ let pnt = locToPNT fileName (row, col) mod+ pn = pNTtoPN pnt+ if pn /= defaultPN+ then demote' modName fileName (mod, toks) pn+ else error "\nInvalid cursor position!\n"++move direction args+ = do let fileName = ghead "filename" args+ row = read (args!!1)::Int+ col = read (args!!2)::Int+ modName <- fileNameToModName fileName+ (inscps, _, mod, toks) <- parseSourceFile fileName+ let pnt = locToPNT fileName (row, col) mod+ pn = pNTtoPN pnt+ if pn /= defaultPN+ then+ case direction of+ UptoTopLevel ->liftToTopLevel' modName fileName (inscps, mod, toks) pnt+ UpOneLevel ->liftOneLevel' modName fileName (inscps, mod, toks) pnt+ Down ->demote' modName fileName (mod, toks) pn+ else error "\nInvalid cursor position!\n"+++{- Refactoring Names: 'liftToTopLevel'++ This refactoring lifts a local function/pattern binding to the top+ level of the module, so as to make it accessible to other functions in+ the current module, and those modules that import current module.++ In the current implementation, a definition will be lifted only if+ none of the identifiers defined in this definition will cause name+ clash/capture problems in the current module after lifting.++ In the case that the whole current module is exported implicitly,+ the lifted identifier will be exported automatically after lifting. If+ the identifier will cause name clash/ambiguous occurrence problem in a+ client module, it will be hided in the import declaration of the+ client module (Note: this might not be the best solution, we prefer+ hiding it in the server module instead of in the client module in the+ final version).++ In the case of indirect importing, it might be time-consuming to+ trace whether the lifted identifier will cause any problem in a client+ module that indirectly imports the current module. The current+ solution is: suppose a defintion is lifted to top level in module A,+ and module A is imported and exported by module B, then the lifted+ identifier will be hided in the import declaration of B no matter+ whether it causes problems in module B or not.++ Function name: liftToTopLevel+ parameters: fileName--current file name.+ mod -- the scoped abstract syntax tree of the module.+ pn -- the function/pattern name to be lifted.+-}++-}++liftToTopLevel' :: GHC.ModuleName -- -> (ParseResult,[PosToken]) -> FilePath+ -> GHC.Located GHC.Name+ -> RefactGhc [ApplyRefacResult]+liftToTopLevel' modName pn@(GHC.L _ n) = do+ renamed <- getRefactRenamed+ -- logm $ "liftToTopLevel':renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ+++ logm $ "liftToTopLevel':pn=" ++ (showGhc pn)+ if isLocalFunOrPatName n renamed+ then do+ (refactoredMod,declPns) <- applyRefac (liftToMod) RSAlreadyLoaded++ logm $ "liftToTopLevel' applyRefac done "+ -- logm $ "liftToTopLevel' applyRefac done:toks= " ++ (show (fst $ snd refactoredMod))++ if modIsExported modName renamed+ then do clients <- clientModsAndFiles modName+ logm $ "liftToTopLevel':(clients,declPns)=" ++ (showGhc (clients,declPns))+ refactoredClients <- mapM (liftingInClientMod modName declPns) clients+ return (refactoredMod:(concat refactoredClients))+ else do return [refactoredMod]+ 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'.+ 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.+ step4. test whether there are any names need to be renamed.+ -}+ liftToMod = do+ renamed <- getRefactRenamed+ let declsr = hsBinds renamed+ let (before,parent,after) = divideDecls declsr pn+ -- error ("liftToMod:(before,parent,after)=" ++ (showGhc (before,parent,after))) -- ++AZ+++ {- ++AZ++ : 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)+ $ error "Sorry, the refactorer cannot lift a definition from an instance declaration!"+ -}+ let liftedDecls = definingDeclsNames [n] parent True True+ declaredPns = nub $ concatMap definedPNs liftedDecls++ -- TODO: what about declarations between this+ -- one and the top level that are used in this one?++ -- logm $ "liftToMod:(liftedDecls,declaredPns)=" ++ (showGhc (liftedDecls,declaredPns))+ -- original : pns<-pnsNeedRenaming inscps mod parent liftedDecls declaredPns+ pns <- pnsNeedRenaming renamed parent liftedDecls declaredPns++ -- (_,dd) <- hsFreeAndDeclaredPNs renamed+ let dd = getDeclaredVars $ hsBinds renamed+ logm $ "liftToMod:(ddd)=" ++ (showGhc dd)++ -- drawTokenTree "liftToMod.a"++ if pns==[]+ then do+ -- TODO: change the order, first move the decls then add params,+ -- else the liftedDecls get mangled while still in the parent+ (parent',liftedDecls',_paramAdded) <- addParamsToParentAndLiftedDecl n dd parent liftedDecls+ -- let liftedDecls''=if paramAdded then filter isFunOrPatBindR liftedDecls'+ -- else liftedDecls'++ -- drawTokenTree "liftToMod.c"+ -- logm $ "liftToMod:(declaredPns)=" ++ (showGhc declaredPns)+ -- logm $ "liftToMod:(liftedDecls')=" ++ (showGhc liftedDecls')++ -- error ("liftToMod:newBinds=" ++ (showGhc (replaceBinds declsr (before++parent'++after)))) -- ++AZ++++ void $ moveDecl1 (replaceBinds renamed (before++parent'++after))+ (Just (ghead "liftToMod" (definedPNs (ghead "liftToMod2" parent'))))+ [GHC.unLoc pn] (Just liftedDecls') declaredPns True++ -- drawTokenTree "liftToMod.b"++ return declaredPns++ else askRenamingMsg pns "lifting"++++-- ---------------------------------------------------------------------++moveDecl1 :: (HsValBinds t)+ => t -- ^ The syntax element to update+ -> Maybe GHC.Name -- ^ If specified, add defn after this one++ -- TODO: make this next parameter a single value, not a list,+ -- after module complete+ -> [GHC.Name] -- ^ The first one is the decl to move+ -> Maybe [GHC.LHsBind GHC.Name]+ -> [GHC.Name] -- ^ The signatures to remove. May be multiple if+ -- decl being moved has a patbind.+ -> Bool -- ^ True if moving to the top level+ -> RefactGhc t -- ^ The updated syntax element (and tokens in monad)+moveDecl1 t defName ns mliftedDecls sigNames topLevel = do++ -- TODO: work with all of ns, not just the first+ let n = ghead "moveDecl1" ns+ let funBinding = case mliftedDecls of+ Nothing -> definingDeclsNames' [n] t+ Just liftedDecls -> liftedDecls++ let Just sspan = getSrcSpan funBinding+ funToks <- getToksForSpan sspan++ (t'',sigsRemoved) <- rmTypeSigs sigNames t+ (t',_declRemoved,_sigRemoved) <- rmDecl (ghead "moveDecl3.1" ns) False t''++ let getToksForMaybeSig (GHC.L ss _) =+ do+ sigToks <- getToksForSpan ss+ return sigToks++ maybeToksSigMulti <- mapM getToksForMaybeSig+ $ sortBy (\(GHC.L s1 _) (GHC.L s2 _) -> compare (srcSpanToForestSpan s1) (srcSpanToForestSpan s2))+ sigsRemoved+ let maybeToksSig = concat maybeToksSigMulti++ r <- addDecl t' defName (ghead "moveDecl1 2" funBinding,sigsRemoved,Just (maybeToksSig ++ funToks)) topLevel++ return r+++askRenamingMsg :: [GHC.Name] -> String -> t+askRenamingMsg pns str+ = error ("The identifier(s): " ++ (intercalate "," $ map showPN pns) +++ " will cause name clash/capture or ambiguity occurrence problem after "+ ++ str ++", please do renaming first!")++ where+ showPN pn = showGhc (pn,GHC.nameSrcLoc pn)++-- |Get the subset of 'pns' that need to be renamed before lifting.+pnsNeedRenaming :: (SYB.Data t1) =>+ t1 -> [GHC.LHsBind GHC.Name] -> t2 -> [GHC.Name]+ -> RefactGhc [GHC.Name]+pnsNeedRenaming dest parent _liftedDecls pns+ =do+ r <- mapM pnsNeedRenaming' pns+ return (concat r)+ where+ pnsNeedRenaming' pn+ = do+ (f,d) <- hsFDsFromInside dest --f: free variable names that may be shadowed by pn+ --d: declaread variables names that may clash with pn+ vs <- hsVisiblePNs pn parent --vs: declarad variables that may shadow pn+ let -- inscpNames = map (\(x,_,_,_)->x) $ inScopeInfo inscps+ vars = map pNtoName (nub (f `union` d `union` vs) \\ [pn]) -- `union` inscpNames+ -- if elem (pNtoName pn) vars || isInScopeAndUnqualified (pNtoName pn) inscps && findEntity pn dest+ 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+ then return [pn]+ else return []+ --This pNtoName takes into account the qualifier.+ pNtoName = showGhc+++addParamsToParent :: (HsValBinds t) => GHC.Name -> [GHC.Name] -> t -> RefactGhc t+addParamsToParent _pn [] t = return t+addParamsToParent pn params t = do+ logm $ "addParamsToParent:(pn,params)" ++ (showGhc (pn,params))+ addActualParamsToRhs True pn params t+++-- |Do refactoring in the client module. that is to hide the identifer+-- in the import declaration if it will cause any problem in the+-- client module.+liftingInClientMod :: GHC.ModuleName -> [GHC.Name] -> TargetModule+ -> RefactGhc [ApplyRefacResult]+liftingInClientMod serverModName pns targetModule@(_,modSummary) = do+ void $ activateModule targetModule+ renamed <- getRefactRenamed+ -- logm $ "liftingInClientMod:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ+++ let clientModule = GHC.ms_mod modSummary+ logm $ "liftingInClientMod:clientModule=" ++ (showGhc clientModule)+ -- = do (inscps, exps ,mod ,ts) <- parseSourceFile fileName+ -- let modNames = willBeUnQualImportedBy serverModName mod+ modNames <- willBeUnQualImportedBy serverModName+ logm $ "liftingInClientMod:modNames=" ++ (showGhc modNames)+ if isJust modNames+ then do+ pns' <- namesNeedToBeHided clientModule (gfromJust "liftingInClientMod" modNames) pns+ logm $ "liftingInClientMod:pns'=" ++ (showGhc pns')+ -- in if pns' /= []+ if (nonEmptyList pns')+ -- then do <-runStateT (addHiding serverModName mod pns') ((ts,unmodified),(-1000,0))+ then do (refactoredMod,_) <- applyRefac (addHiding serverModName renamed pns') RSAlreadyLoaded+ return [refactoredMod]+ else return []+ else return []++-- |Test whether an identifier defined in the modules specified by+-- 'names' will be exported by current module.+willBeExportedByClientMod :: [GHC.ModuleName] -> GHC.RenamedSource -> Bool+willBeExportedByClientMod names renamed =+ let (_,_,exps,_) = renamed+ in if isNothing exps+ then False+ else any isJust $ map (\y-> (find (\x-> (simpModule x==Just y)) (gfromJust "willBeExportedByClientMod" exps))) names+ where simpModule (GHC.L _ (GHC.IEModuleContents m)) = Just m+ simpModule _ = Nothing++-- |get the module name or alias name by which the lifted identifier+-- will be imported automatically.+-- TODO: maybe move this into TypeUtils+-- willBeUnQualImportedBy::HsName.ModuleName->HsModuleP->Maybe [HsName.ModuleName]+willBeUnQualImportedBy :: GHC.ModuleName -> RefactGhc (Maybe [GHC.ModuleName])+willBeUnQualImportedBy modName = do+ (_,imps,_,_) <- getRefactRenamed+ let ms = filter (\(GHC.L _ (GHC.ImportDecl (GHC.L _ modName1) _qualify _source _safe isQualified _isImplicit _as h))+ -> modName == modName1 && (not isQualified) && (isNothing h || (isJust h && ((fst (fromJust h)) == True))))+ imps++ res = if (emptyList ms) then Nothing+ else Just $ nub $ map getModName ms++ getModName (GHC.L _ (GHC.ImportDecl (GHC.L _ modName2) _qualify _source _safe _isQualified _isImplicit as _h))+ = if isJust as then simpModName (fromJust as)+ else modName2++ simpModName m = m++ logm $ "willBeUnQualImportedBy:(ms,res)=" ++ (showGhc (ms,res))++ return res+++-- |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.+namesNeedToBeHided :: GHC.Module -> [GHC.ModuleName] -> [GHC.Name]+ -> RefactGhc [GHC.Name]+namesNeedToBeHided clientModule modNames pns = do+ renamed <- getRefactRenamed+ parsed <- getRefactParsed+ logm $ "namesNeedToBeHided:willBeExportedByClientMod=" ++ (show $ willBeExportedByClientMod modNames renamed)+ gnames <- GHC.getNamesInScope+ let clientInscopes = filter (\n -> clientModule == GHC.nameModule n) gnames+ logm $ "namesNeedToBeHided:(clientInscopes)=" ++ (showGhc (clientInscopes))++ pnsMapped <- mapM getLocalEquiv pns+ logm $ "namesNeedToBeHided:pnsMapped=" ++ (showGhc pnsMapped)++ let pnsMapped' = filter (\(_,_,ns) -> not $ emptyList ns) pnsMapped++ if willBeExportedByClientMod modNames renamed+ then return pns+ else do+ ff <- mapM (needToBeHided parsed) pnsMapped'+ return $ concat ff+ where+ -- | Strip the package prefix from the name and return the+ -- stripped name together with any names in the local module that+ -- may match the stripped one+ getLocalEquiv :: GHC.Name -> RefactGhc (GHC.Name,String,[GHC.Name])+ getLocalEquiv pn = do+ let pnStr = stripPackage $ showGhc pn+ logm $ "MoveDef getLocalEquiv: about to parseName:" ++ (show pnStr)+ ecns <- GHC.gtry $ GHC.parseName pnStr+ let cns = case ecns of+ Left (_e::SomeException) -> []+ Right v -> v+ logm $ "MoveDef getLocalEquiv: cns:" ++ (showGhc cns)+ return (pn,pnStr,cns)++ stripPackage :: String -> String+ stripPackage str = reverse s+ where+ (s,_) = break (== '.') $ reverse str++ needToBeHided :: GHC.ParsedSource -> (GHC.Name,String,[GHC.Name]) -> RefactGhc [GHC.Name]+ needToBeHided parsed (pn,_pnStr,pnsLocal) = do+ let uwoq = map (\n -> usedWithoutQualR n parsed) pnsLocal++ -- logm $ "needToBeHided:(hsBinds renamed)=" ++ (showGhc (hsBinds renamed))+ logm $ "needToBeHided:(pn,uwoq)=" ++ (showGhc (pn,uwoq))++ if (any (== True) uwoq --the same name is used in the module unqualifiedly or+ --is exported unqualifiedly by an Ent decl++ -- was || causeNameClashInExports pn modNames renamed)+ -- TODO: ++AZ++ check if next line needs to be reinstated+ -- was || any (\m -> causeNameClashInExports oldPN pn m renamed) modNames)+ || False)+ then return [pn]+ else return []+++-- **************************************************************************************************************--++{- Refactoring Names: 'liftOneLevel'+ Descritption:+ this refactoring lifts a local function/pattern binding only one level up.+ By 'lifting one-level up' ,I mean:++ case1: In a module (HsModule SrcLoc ModuleName (Maybe [HsExportSpecI i]) [HsImportDeclI i] ds):+ A local declaration D will be lifted to the same level as the 'ds', if D is in the + where clause of one of ds's element declaration.++ new: (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], Maybe LHsDocString)+ HsGroup hs_valds :: HsValBinds id ...++++ case2: In a match ( HsMatch SrcLoc i [p] (HsRhs e) ds) :+ A local declaration D will be lifted to the same level as the 'ds', if D is in the + where clause of one of ds's element declaration.+ A declaration D,say,in the rhs expression 'e' will be lifted to 'ds' if D is Not local to+ other declaration list in 'e'++ (in a FunBind)+ new: Match [LPat id] (Maybe (LHsType id)) (GRHSs id)+++ case3: In a pattern binding (HsPatBind SrcLoc p (HsRhs e) ds):+ A local declaration D will be lifted to the same level as the 'ds', if D is in the + where clause of one of ds's element declaration.+ A declaration D,say,in the rhs expression 'e' will be lifted to 'ds' if D is Not local to+ other declaration list in 'e'++ new: PatBind (LPat idL) (GRHSs idR) PostTcType NameSet (Maybe tickish)++++ case4: In the Let expression (Exp (HsLet ds e):+ A local declaration D will be lifted to the same level as the 'ds', if D is in the + where clause of one of ds's element declaration.+ A declaration D, say, in the expression 'e' will be lifted to 'ds' if D is not local to+ other declaration list in 'e'++ new: HsLet (HsLocalBinds id) (LHsExpr id)+++ case5: In the case Alternative expression:(HsAlt loc p rhs ds)+ A local declaration D will be lifted to the same level as the 'ds', if D is in the + where clause of one of ds's element declaration.+ A declaration D in 'rhs' will be lifted to 'ds' if D is not local to other declaration + list in 'rhs'.++ new: HsCase (LHsExpr id) (MatchGroup id)+ new is same as in a FunBind.+++ case6: In the do statement expression:(HsLetStmt ds stmts)+ A local declaration D will be lifted to the same level as the 'ds', if D is in the + where clause of one of ds's element declaration.+ A declaration D in 'stmts' will be lifted to 'ds' if D is not local to other declaration + list in 'stmts'.++ new: LetStmt (HsLocalBindsLR idL idR)+ in context GRHS [LStmt id] (LHsExpr id)+++Function name: liftOneLevel+parameters: fileName--current file name.+ mod -- the scoped abstract syntax tree of the module.+ pn -- the function/pattern name to be lifted.++-}++liftOneLevel' :: GHC.ModuleName+ -> GHC.Located GHC.Name+ -> RefactGhc [ApplyRefacResult]++liftOneLevel' modName pn@(GHC.L _ n) = do+ renamed <- getRefactRenamed+ if isLocalFunOrPatName n renamed+ then do -- (mod', ((toks',m),_))<-liftOneLevel''+ (refactoredMod,_) <- applyRefac (liftOneLevel'') RSAlreadyLoaded+ let (b, pns) = liftedToTopLevel pn renamed+ if b && modIsExported modName renamed+ then do clients<-clientModsAndFiles modName+ -- logm $ "liftOneLevel':(clients,declPns)=" ++ (showGhc (clients,declPns))+ refactoredClients <- mapM (liftingInClientMod modName pns) clients+ return (refactoredMod:(concat refactoredClients))+ else do return [refactoredMod]+ else error "\nThe identifer is not a function/pattern name!"++ where+ liftOneLevel''= do+ logm $ "in liftOneLevel''"+ renamed <- getRefactRenamed+ ztransformStagedM SYB.Renamer (Nothing+ `SYB.mkQ` liftToModQ+ `SYB.extQ` liftToMatchQ'+ `SYB.extQ` liftToLet'+ -- `SYB.mkQ` liftToMatchQ+ -- `SYB.extQ` liftToLet+ ) (Z.toZipper renamed)++ where+ isValBinds :: GHC.HsValBinds GHC.Name -> Bool+ isValBinds _ = True++ isGRHSs :: GHC.GRHSs GHC.Name -> Bool+ isGRHSs _ = True++ isHsLet :: GHC.HsExpr GHC.Name -> Bool+ isHsLet (GHC.HsLet _ _) = True+ isHsLet _ = False++ liftToModQ ((g,_imps,_exps,_docs):: GHC.RenamedSource)+ | nonEmptyList candidateBinds+ = Just (doLiftZ candidateBinds)+ | otherwise = Nothing+ where+ candidateBinds = map snd+ $ filter (\(l,_bs) -> nonEmptyList l)+ $ map (\bs -> (definingDeclsNames [n] (hsBinds bs) False False,bs))+ $ (hsBinds g)++ liftToMatchQ' :: (SYB.Data a) => GHC.Match GHC.Name -> Maybe (SYB.Stage -> Z.Zipper a -> RefactGhc (Z.Zipper a))+ liftToMatchQ' ((GHC.Match _pats _mtyp (GHC.GRHSs rhs ds))::GHC.Match GHC.Name)+ | (nonEmptyList (definingDeclsNames [n] (hsBinds ds) False False))+ = Just (doLiftZ ds)+ | (nonEmptyList (definingDeclsNames [n] (hsBinds rhs) False False))+ = Just (doLiftZ rhs)+ | otherwise = Nothing++ liftToLet' :: GHC.HsExpr GHC.Name -> Maybe (SYB.Stage -> Z.Zipper a -> RefactGhc (Z.Zipper a))+ liftToLet' ((GHC.HsLet ds _e)::GHC.HsExpr GHC.Name)+ | nonEmptyList (definingDeclsNames [n] (hsBinds ds) False False)+ = Just (doLiftZ ds)+ | otherwise = Nothing+ liftToLet' _ = Nothing++ doLiftZ :: (HsValBinds t)+ => t -> SYB.Stage -> Z.Zipper a+ -> RefactGhc (Z.Zipper a)+ doLiftZ ds _stage z =+ do+ logm $ "in liftOneLevel''.liftToLet in ds"++ let zu = case (Z.up z) of+ Just zz -> fromMaybe (error "MoveDef.liftToLet.1")+ $ upUntil (False `SYB.mkQ` isGRHSs+ `SYB.extQ` isHsLet+ `SYB.extQ` isValBinds)+ zz+ Nothing -> z++ let+ wtop (ren::GHC.RenamedSource) = do+ worker ren (hsBinds ds) pn True++ wgrhs (grhss::GHC.GRHSs GHC.Name) = do+ (_,dd) <- (hsFreeAndDeclaredPNs grhss)+ worker1 grhss (hsBinds ds) pn dd False++ wlet :: GHC.HsExpr GHC.Name -> RefactGhc (GHC.HsExpr GHC.Name)+ wlet l@(GHC.HsLet dsl _e) = do+ (_,dd) <- hsFreeAndDeclaredPNs dsl+ dsl' <- worker1 l (hsBinds ds) pn dd False+ return dsl'+ wlet x = return x++ wvalbinds (vb::GHC.HsValBinds GHC.Name) = do+ (_,dd) <- (hsFreeAndDeclaredPNs vb)+ worker1 vb (hsBinds ds) pn dd False++ ds' <- Z.transM (SYB.mkM wtop `SYB.extM` wgrhs+ `SYB.extM` wlet `SYB.extM` wvalbinds) zu++ return ds'++ -- TODO: merge worker and worker1+ worker :: (HsValBinds t,GHC.Outputable t)+ => t -- ^The destination of the lift operation+ -> [GHC.LHsBind GHC.Name] -- ^ list containing the+ -- decl to be lifted+ -> GHC.Located GHC.Name -- ^ The name of the decl to+ -- be lifted+ -> Bool -- ^True if lifting to the top level+ -> RefactGhc t+ worker dest ds pnn toToplevel+ =do let (before,parent,after)=divideDecls ds pnn -- parent is misnomer, it is the decl to be moved+ liftedDecls=definingDeclsNames [n] parent True True+ declaredPns=nub $ concatMap definedPNs liftedDecls+ (_, dd) <- hsFreeAndDeclaredPNs dest+ pns<-pnsNeedRenaming dest parent liftedDecls declaredPns+ logm $ "MoveDef.worker: pns=" ++ (showGhc pns)+ if pns==[]+ then do+ (parent',liftedDecls',_paramAdded)<-addParamsToParentAndLiftedDecl n dd+ parent liftedDecls+ --True means the new decl will be at the same level with its parant. + dest' <- moveDecl1 (replaceBinds dest (before++parent'++after))+ (Just (ghead "worker" (definedPNs (ghead "worker" parent'))))+ [n] (Just liftedDecls') declaredPns toToplevel -- False -- ++AZ++ TODO: should be True for toplevel move+ return dest'+ --parent'<-doMoving declaredPns (ghead "worker" parent) True paramAdded parent'+ --return (before++parent'++liftedDecls''++after)+ else askRenamingMsg pns "lifting"++ worker1 :: (HsValBinds t,GHC.Outputable t)+ => t -- ^The destination of the lift operation+ -> [GHC.LHsBind GHC.Name] -- ^ list containing the+ -- decl to be lifted+ -> GHC.Located GHC.Name -- ^ The name of the decl to+ -- be lifted+ -> [GHC.Name] -- ^Declared variables in the destination+ -> Bool -- ^True if lifting to the top level+ -> RefactGhc t+ worker1 dest ds pnn dd toToplevel+ {-+ Actions required+ 1. add parameters to original decls if required+ 2. add parameters to any points that call the lifted decl+ once it is lifted+ 3. Replace the above in the AST+ 4. Do the move+ -}++ =do let (_before,decl,_after)=divideDecls ds pnn+ liftedDecls=definingDeclsNames [n] decl True True+ declaredPns=nub $ concatMap definedPNs liftedDecls++ pns <- pnsNeedRenaming dest decl liftedDecls declaredPns+ logm $ "MoveDef.worker1: pns=" ++ (showGhc pns)+ if pns==[]+ then do+ (parent',liftedDecls',_paramAdded)+ <- addParamsToParentAndLiftedDecl n dd dest liftedDecls+ --True means the new decl will be at the same level with its parant. + parent'' <- moveDecl1 parent' Nothing+ [n] (Just liftedDecls') declaredPns toToplevel -- False -- ++AZ++ TODO: should be True for toplevel move+ return parent''+ --decl'<-doMoving declaredPns (ghead "worker" decl) True paramAdded decl'+ --return (before++decl'++liftedDecls''++after)+ else askRenamingMsg pns "lifting"+++liftedToTopLevel :: GHC.Located GHC.Name -> GHC.RenamedSource -> (Bool,[GHC.Name])+liftedToTopLevel pnt@(GHC.L _ pn) renamed+ = if nonEmptyList (definingDeclsNames [pn] (hsBinds renamed) False True)+ then let (_, parent,_) = divideDecls (hsBinds renamed) pnt+ liftedDecls=definingDeclsNames [pn] (hsBinds parent) True True+ declaredPns = nub $ concatMap definedPNs liftedDecls+ in (True, declaredPns)+ else (False, [])+++addParamsToParentAndLiftedDecl :: (HsValBinds t,GHC.Outputable t) =>+ GHC.Name -- ^name of decl being lifted+ -> [GHC.Name] -- ^Declared names in parent+ -> t -- ^parent+ -> [GHC.LHsBind GHC.Name] -- ^decls being lifted+ -> RefactGhc (t, [GHC.LHsBind GHC.Name], Bool)+addParamsToParentAndLiftedDecl pn dd parent liftedDecls+ =do (ef,_) <- hsFreeAndDeclaredPNs parent+ (lf,_) <- hsFreeAndDeclaredPNs liftedDecls++ -- logm $ "addParamsToParentAndLiftedDecl:parent=" ++ (showGhc parent)++ -- parameters to be added to pn because of lifting+ let newParams=((nub lf) \\ (nub ef)) \\ dd++ logm $ "addParamsToParentAndLiftedDecl:(newParams,ef,lf,dd)=" ++ (showGhc (newParams,ef,lf,dd))++ if newParams /= []+ then if (any isComplexPatBind liftedDecls)+ then error "This pattern binding cannot be lifted, as it uses some other local bindings!"+ else do -- first remove the decls to be lifted, so they are not disturbed+ (parent'',liftedDecls'',_msig) <- rmDecl pn False parent++ parent' <- addParamsToParent pn newParams parent''++ liftedDecls' <- addParamsToDecls [liftedDecls''] pn newParams True++ return (parent', liftedDecls',True)+ else return (parent,liftedDecls,False)+++--------------------------------End of Lifting-----------------------------------------++{-Refactoring : demote a function/pattern binding(simpe or complex) to the declaration where it is used.+ Descritption: if a declaration D, say, is only used by another declaration F,say, then D can be + demoted into the local declaration list (where clause) in F.+ So currently, D can not be demoted if more than one declaration use it. ++ In a multi-module context, a top-level definition can not be demoted if it is used+ by other modules. In the case that the demoted identifer is in the hiding list of+ import declaration in a client module, it should be removed from the hiding list.++ Function name:demote+ parameters: fileName--current file name.+ mod -- the scoped abstract syntax tree of the module.+ pn -- the function/pattern name to be demoted.++-}++demote' ::+ GHC.ModuleName+ -- -> FilePath+ -- -> (ParseResult,[PosToken])+ -> GHC.Located GHC.Name+ -> RefactGhc [ApplyRefacResult]+demote' modName (GHC.L _ pn) = do+ renamed <- getRefactRenamed+ if isFunOrPatName pn renamed+ then do+ isTl <- isTopLevelPN pn+ if isTl && isExplicitlyExported pn renamed+ then error "This definition can not be demoted, as it is explicitly exported by the current module!"+ else do -- (mod',((toks',m),_))<-doDemoting pn fileName mod toks+ (refactoredMod,_) <- applyRefac (doDemoting pn) RSAlreadyLoaded+ -- isTl <- isTopLevelPN pn+ if isTl && modIsExported modName renamed+ then do let demotedDecls'= definingDeclsNames [pn] (hsBinds renamed) True False+ declaredPns = nub $ concatMap definedPNs demotedDecls'+ clients <- clientModsAndFiles modName+ logm $ "demote':clients=" ++ (showGhc clients)+ refactoredClients <-mapM (demotingInClientMod declaredPns) clients+ -- return (refactoredMod:[])+ return (refactoredMod:refactoredClients)+ else do return [refactoredMod]+ else error "\nInvalid cursor position!"+++-- |Do refactoring in the client module, that is:+-- a) Check whether the identifier is used in the module body+-- b) If the identifier is not used but is hided by the import+-- declaration, then remove it from the hiding.+demotingInClientMod ::+ [GHC.Name] -> TargetModule+ -> RefactGhc ApplyRefacResult+demotingInClientMod pns targetModule@(_,modSummary) = do+ void $ activateModule targetModule+ (refactoredMod,_) <- applyRefac (doDemotingInClientMod pns (GHC.ms_mod modSummary)) RSAlreadyLoaded+ return refactoredMod+++doDemotingInClientMod :: [GHC.Name] -> GHC.Module -> RefactGhc ()+doDemotingInClientMod pns modName = do+ renamed@(_g,imps,exps,_docs) <- getRefactRenamed+ if any (\pn->findPN pn (hsBinds renamed) || findPN pn (exps)) 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+ -- TODO: reinstate this+ then do -- (mod',((ts',m),_))<-runStateT (rmItemsFromImport mod pns) ((ts,unmodified),(-1000,0))+ return ()+ else return ()++doDemoting :: GHC.Name -> RefactGhc ()+doDemoting pn = do++ clearRefactDone -- Only do this action once++ renamed <- getRefactRenamed+ -- logm $ "MoveDef.doDemoting:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++++ -- everywhereMStaged' is top-down, does all+ renamed' <- everywhereMStaged' SYB.Renamer (SYB.mkM demoteInMod+ `SYB.extM` demoteInMatch+ `SYB.extM` demoteInPat+ `SYB.extM` demoteInLet+ `SYB.extM` demoteInStmt+ ) renamed+ -- error ("doDemoting:renamed'=" ++ (showGhc renamed'))+ putRefactRenamed renamed'+ -- ren <- getRefactRenamed+ -- error ("doDemoting:ren=" ++ (showGhc ren))+ showLinesDebug "doDemoting done"+ return ()+ where+ --1. demote from top level+ -- demoteInMod (mod@(HsModule loc name exps imps ds):: HsModuleP)+ demoteInMod (renamed :: GHC.RenamedSource)+ | not $ emptyList decls+ = do+ logm "MoveDef:demoteInMod" -- ++AZ+++ demoted <- doDemoting' renamed pn+ return demoted+ where+ decls = (definingDeclsNames [pn] (hsBinds renamed) False False)+ demoteInMod x = return x++ --2. The demoted definition is a local decl in a match+ -- demoteInMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP)+ demoteInMatch (match@(GHC.Match _pats _mt (GHC.GRHSs _ ds))::GHC.Match GHC.Name)+ -- was | definingDecls [pn] ds False False/=[]+ | not $ emptyList (definingDeclsNames [pn] (hsBinds ds) False False)+ = do+ logm "MoveDef:demoteInMatch" -- ++AZ+++ done <- getRefactDone+ match' <- if (not done)+ then doDemoting' match pn+ else return match+ return match'+ demoteInMatch x = return x++ --3. The demoted definition is a local decl in a pattern binding+ -- demoteInPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP)+ demoteInPat (pat@((GHC.PatBind _p rhs _ _ _))::GHC.HsBind GHC.Name)+ -- was | definingDecls [pn] ds False False /=[]+ | not $ emptyList (definingDeclsNames [pn] (hsBinds rhs) False False)+ = do+ logm "MoveDef:demoteInPat" -- ++AZ+++ done <- getRefactDone+ pat' <- if (not done)+ then doDemoting' pat pn+ else return pat+ return pat'+ demoteInPat x = return x++ --4: The demoted definition is a local decl in a Let expression+ -- demoteInLet (letExp@(Exp (HsLet ds e))::HsExpP)+ demoteInLet (letExp@(GHC.L _ (GHC.HsLet ds _e))::GHC.LHsExpr GHC.Name)+ -- was | definingDecls [pn] ds False False/=[]+ | not $ emptyList (definingDeclsNames [pn] (hsBinds ds) False False)+ = do+ logm "MoveDef:demoteInLet" -- ++AZ+++ done <- getRefactDone+ letExp' <- if (not done)+ then doDemoting' letExp pn+ else return letExp+ return letExp'+ demoteInLet x = return x++ -- TODO: the rest of these cases below+{-+ --5. The demoted definition is a local decl in a case alternative.+ demoteInAlt (alt@(HsAlt loc p rhs ds)::(HsAlt (HsExpP) (HsPatP) [HsDeclP]))+ | definingDecls [pn] ds False False /=[]+ = doDemoting' alt pn+ demoteInAlt _=mzero+-}++ --6.The demoted definition is a local decl in a Let statement.+ -- demoteInStmt (letStmt@(HsLetStmt ds stmts):: (HsStmt (HsExpP) (HsPatP) [HsDeclP]))+ demoteInStmt (letStmt@(GHC.LetStmt binds)::GHC.Stmt GHC.Name)+ -- was | definingDecls [pn] ds False False /=[]+ | not $ emptyList (definingDeclsNames [pn] (hsBinds binds) False False)+ = do+ logm "MoveDef:demoteInStmt" -- ++AZ+++ done <- getRefactDone+ letStmt' <- if (not done)+ then doDemoting' letStmt pn+ else return letStmt+ return letStmt'+ demoteInStmt x =return x++ -- TODO: the rest of these cases below+{-+ failure=idTP `adhocTP` mod+ where+ mod (m::HsModuleP)+ = error "Refactoring failed!" --SHOULD GIVE MORE DETAILED ERROR MESSAGE+-}++++-- |Demote the declaration of 'pn' in the context of 't'.+doDemoting' :: (HsValBinds t, UsedByRhs t) => t -> GHC.Name -> RefactGhc t+doDemoting' t pn = do+ let origDecls = hsBinds t+ demotedDecls'= definingDeclsNames [pn] origDecls True False+ declaredPns = nub $ concatMap definedPNs demotedDecls'+ pnsUsed = usedByRhs t declaredPns+ logm $ "doDemoting':(pn,declaredPns)=" ++ showGhc (pn,declaredPns)+ -- logm $ "doDemoting':t=" ++ (SYB.showData SYB.Renamer 0 t)+ logm $ "doDemoting':(declaredPns,pnsUsed)=" ++ showGhc (declaredPns,pnsUsed)+ r <- if not pnsUsed -- (usedByRhs t declaredPns)+ then do+ -- drawTokenTree "" -- ++AZ++ debug+ let demotedDecls = definingDeclsNames [pn] (hsBinds t) True True+ let+ otherBinds = (deleteFirstsBy sameBind (hsBinds t) demotedDecls)+ -- uselist = uses declaredPns otherBinds+ {- From 'hsDecls t' to 'hsDecls t \\ demotedDecls'.+ Bug fixed 06/09/2004 to handle direct recursive function.+ -}+ -- uselist = concatMap (\r -> if (emptyList r) then [] else ["Used"]) $ map (\b -> uses declaredPns [b]) otherBinds+ xx = map (\b -> (b,uses declaredPns [b])) otherBinds+ useCount = sum $ concatMap snd xx+ -- logm $ "doDemoting': uses xx=" ++ (showGhc xx)+ -- logm $ "doDemoting': uses useCount=" ++ (show useCount)++ case useCount of+ 0 ->do error "\n Nowhere to demote this function!\n"+ 1 -> --This function is only used by one friend function+ do+ logm "MoveDef.doDemoting':target location found" -- ++AZ++++ (f,_d) <- hsFreeAndDeclaredPNs demotedDecls+ (ds,removedDecl,_sigRemoved) <- rmDecl pn False t++ (t',demotedSigs) <- rmTypeSigs declaredPns ds++ let (GHC.L ssd _) = removedDecl+ demotedToks <- getToksForSpan ssd++ -- TODO: move this to its own fn+ let getToksForMaybeSig (GHC.L ss _) = do+ sigToks <- getToksForSpan ss+ return sigToks++ demotedSigToksLists <- mapM getToksForMaybeSig demotedSigs+ let demotedSigToks = concat demotedSigToksLists+ -- end TODO++ logm $ "MoveDef:declaredPns=" ++ (showGhc declaredPns) -- ++AZ++++ --get those variables declared at where the demotedDecls will be demoted to+ -- let dl = map (flip declaredNamesInTargetPlace ds) declaredPns+ dl <- mapM (flip declaredNamesInTargetPlace ds) declaredPns+ logm $ "mapM declaredNamesInTargetPlace done"+ --make sure free variable in 'f' do not clash with variables in 'dl',+ --otherwise do renaming.+ let clashedNames=filter (\x-> elem (id x) (map id f)) $ (nub.concat) dl+ --rename clashed names to new names created automatically,update TOKEN STREAM as well.+ if clashedNames/=[]+ then error ("The identifier(s):" ++ showGhc clashedNames +++ ", declared in where the definition will be demoted to, will cause name clash/capture"+ ++" after demoting, please do renaming first!")+ --ds'<-foldM (flip (autoRenameLocalVar True)) ds clashedNames+ else --duplicate demoted declarations to the right place.+ do+ logm $ "MoveDef: about to duplicateDecls"+ ds'' <- duplicateDecls declaredPns removedDecl demotedSigs (Just (demotedSigToks ++ demotedToks)) (hsBinds ds)+ logm $ "MoveDef:duplicateDecls done"++ return (replaceBinds t' ds'')+ _ ->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"++ return r++ where+ ---find how many matches/pattern bindings use 'pn'-------+ -- uses :: [GHC.Name] -> [GHC.LHsBind GHC.Name] -> [Int]+ uses pns t2+ = concatMap used t2+ where++ used :: GHC.LHsBind GHC.Name -> [Int]+ used (GHC.L _ (GHC.FunBind _n _ (GHC.MatchGroup matches _) _ _ _))+ = concatMap (usedInMatch pns) matches++ used (GHC.L _ (GHC.PatBind pat rhs _ _ _))+ -- was | hsPNs p `intersect` pns ==[] && any (flip findPN pat) pns+ | (not $ findPNs pns pat) && findPNs pns rhs+ = [1::Int]+ used _ = []++ usedInMatch pns (GHC.L _ (GHC.Match pats _ rhs))+ -- was | isNothing (find (==pname) pns) && any (flip findPN match) pns+ | (not $ findPNs pns pats) && findPNs pns rhs+ = [1::Int]+ usedInMatch _ _ = []+++ -- duplicate demotedDecls to the right place (the outer most level where it is used).+ duplicateDecls :: [GHC.Name] -- ^ function names to be demoted+ -> GHC.LHsBind GHC.Name -- ^Bind being demoted+ -> [GHC.LSig GHC.Name] -- ^Signatures being demoted, if any+ -> Maybe [PosToken] -- ^Tokens if provided+ -> [GHC.LHsBind GHC.Name] -- ^Binds of original top level entiity, including src and dst+ -> RefactGhc [GHC.LHsBind GHC.Name]+ duplicateDecls pns demoted dsig dtoks decls+ -- = do everywhereMStaged SYB.Renamer (SYB.mkM dupInMatch+ = do+ -- logm "duplicateDecls:clearing done" -- ++AZ+++ -- clearRefactDone+ everywhereMStaged' SYB.Renamer (SYB.mkM dupInMatch -- top-down approach+ -- = do somewhereMStaged SYB.Renamer (SYB.mkM dupInMatch -- need working MonadPlus for somewhereMStaged+ `SYB.extM` dupInPat) decls+ {-+ = do applyTP (once_tdTP (failTP `adhocTP` dupInMatch+ `adhocTP` dupInPat)) decls+ --error (show decls' ++ "\n" ++ prettyprint decls')+ -- rmDecl (ghead "moveDecl3" pns) False =<<foldM (flip rmTypeSig) decls' pns + -}+ where+ -- dupInMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP)+ dupInMatch (match@(GHC.Match pats _mt rhs) :: GHC.Match GHC.Name)+ -- was | any (flip findPN match) pns && not (any (flip findPN name) pns)+ | (not $ findPNs pns pats) && findPNs pns rhs+ = do+ done <- getRefactDone+ logm $ "duplicateDecls.dupInMatch:value of done=" ++ (show done) -- ++AZ+++ if done+ then return match+ else do+ logm "duplicateDecls:setting done" -- ++AZ+++ setRefactDone+ --If not fold parameters.+ -- moveDecl pns pats False decls False+ {- ++AZ++ foldParams instead+ rhs' <- addDecl rhs Nothing (demoted,dsig,dtoks) False+ return (GHC.Match pats mt rhs')+ -}+ -- If fold parameters.+ -- error "dupInMatch" -- ++AZ+++ match' <- foldParams pns match decls demoted dsig dtoks+ return match'+ -- dupInMatch _ =mzero+ dupInMatch x = return x++ -- dupInPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP)+ dupInPat ((GHC.PatBind pat rhs ty fvs ticks) :: GHC.HsBind GHC.Name)+ -- was |any (flip findPN pat) pns && not (any (flip findPN p) pns)+ | (not $ findPNs pns pat) && findPNs pns rhs+ -- = moveDecl pns pat False decls False+ = do+ logm $ "duplicateDecls.dupInPat"+ -- rhs' <- moveDecl pns rhs False decls False+ -- TODO: what wbout dtoks?+ -- error "dupInPat" -- ++AZ+++ rhs' <- moveDecl1 rhs Nothing pns Nothing pns False+ return (GHC.PatBind pat rhs' ty fvs ticks)+ -- dupInPat _ =mzero+ dupInPat x = return x++ -- demotedDecls = definingDecls pns decls True False+ ---------------------------------------------------------------------+ {-+ declaredNamesInTargetPlace :: (Term t, MonadPlus m)=>PName->t->m [PName]+ declaredNamesInTargetPlace pn=applyTU (stop_tdTU (failTU+ `adhocTU` inMatch+ `adhocTU` inPat))+ -}+ declaredNamesInTargetPlace :: (SYB.Data t)+ => GHC.Name -> t+ -- -> RefactGhc [GHC.Name]+ -> RefactGhc [GHC.Name]++ declaredNamesInTargetPlace pn' t' = do+ logm $ "declaredNamesInTargetPlace:pn=" ++ (showGhc pn')+ res <- applyTU (stop_tdTUGhc (failTU+ `adhocTU` inMatch+ `adhocTU` inPat)) t'+ logm $ "declaredNamesInTargetPlace:res=" ++ (showGhc res)+ return res+ where+ -- inMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP)+ inMatch ((GHC.Match _pats _ rhs) :: GHC.Match GHC.Name)+ | findPN pn' rhs = do+ logm $ "declaredNamesInTargetPlace:inMatch"+ fds <- hsFDsFromInside rhs+ return $ snd fds+ -- (return.snd) =<< hsFDsFromInside rhs+ -- inMatch _ = mzero+ inMatch _ = return mzero++ -- inPat (pat@(Dec (HsPatBind loc p rhs ds)):: HsDeclP)+ inPat ((GHC.PatBind pat rhs _ _ _) :: GHC.HsBind GHC.Name)+ |findPN pn' rhs = do+ logm $ "declaredNamesInTargetPlace:inPat"+ fds <- hsFDsFromInside pat+ return $ snd fds+ -- (return.snd) =<< hsFDsFromInside pat+ -- inPat _= mzero+ inPat _= return mzero++++-- ---------------------------------------------------------------------+++++{- foldParams:remove parameters in the demotedDecls if possible+ parameters: pn -- the function/pattern name to be demoted in PName format+ match--where the demotedDecls will be demoted to+ demotedDecls -- the declarations to be demoted.+ example:+ module Test where demote 'sq' module Test where+ sumSquares x y ===> sumSquares x y =(sq 0) + (sq y)+ = sq x 0+ sq x y where sq y=x ^ y+ sq x y=x^y+-}+--PROBLEM: TYPE SIGNATURE SHOULD BE CHANGED.+--- TEST THIS FUNCTION!!!+foldParams :: [GHC.Name] -- ^The (list?) function name being demoted+ -> GHC.Match GHC.Name -- ^The RHS of the place to receive the demoted decls+ -> [GHC.LHsBind GHC.Name] -- ^Binds of original top level entiity, including src and dst+ -> GHC.LHsBind GHC.Name -- ^The decls being demoted+ -> [GHC.LSig GHC.Name] -- ^Signatures being demoted, if any+ -> Maybe [PosToken] -- ^Tokens if provided+ -> RefactGhc (GHC.Match GHC.Name)+foldParams pns ((GHC.Match pats mt rhs)::GHC.Match GHC.Name) _decls demotedDecls dsig dtoks++ =do+ logm $ "MoveDef.foldParams entered"+ -- logm $ "MoveDef.foldParams:match=" ++ (SYB.showData SYB.Renamer 0 match)++ let matches=concatMap matchesInDecls [GHC.unLoc demotedDecls]+ pn=ghead "foldParams" pns --pns /=[]+ params <- allParams pn rhs []+ if (length.nub.map length) params==1 -- have same number of param + && ((length matches)==1) -- only one 'match' in the demoted declaration+ then do+ let patsInDemotedDecls=(patsInMatch.(ghead "foldParams")) matches+ subst=mkSubst patsInDemotedDecls params+ fstSubst=map fst subst+ sndSubst=map snd subst++ -- logm $ "MoveDef.foldParams before rmParamsInParent"+ rhs' <- rmParamsInParent pn sndSubst rhs+ -- logm $ "MoveDef.foldParams after rmParamsInParent"++ -- ls<-mapM hsFreeAndDeclaredPNs sndSubst+ -- ls <- mapM hsFreeAndDeclaredPNs sndSubst+ ls <- mapM hsFreeAndDeclaredPNs sndSubst+ -- newNames contains the newly introduced names to the demoted decls---+ -- let newNames=(map pNtoName (concatMap fst ls)) \\ (map pNtoName fstSubst)+ let newNames=((concatMap fst ls)) \\ (fstSubst)+ --There may be name clashing because of introducing new names.+ clashedNames<-getClashedNames fstSubst newNames (ghead "foldParams" matches)++ logm $ "MoveDef.foldParams about to foldInDemotedDecls"++ -- decls' <- foldInDemotedDecls pns clashedNames subst decls+ -- let demotedDecls''' = definingDeclsNames pns decls' True False+ demotedDecls''' <- foldInDemotedDecls pns clashedNames subst [demotedDecls]+ logm $ "MoveDef.foldParams foldInDemotedDecls done"++ let [(GHC.L declSpan _)] = demotedDecls'''+ declToks <- getToksForSpan declSpan+ -- logm $ "MoveDef.foldParams addDecl adding to (hsBinds):[" ++ (SYB.showData SYB.Renamer 0 $ hsBinds rhs') ++ "]" -- ++AZ+++ rhs'' <- addDecl rhs' Nothing (ghead "foldParams 2" demotedDecls''',[],Just declToks) False+ logm $ "MoveDef.foldParams addDecl done 1"+ return (GHC.Match pats mt rhs'')+ else do -- moveDecl pns match False decls True+ -- return (HsMatch loc1 name pats rhs (ds++demotedDecls)) -- no parameter folding + -- logm $ "MoveDef.foldParams about to addDecl:dtoks=" ++ (show dtoks)+ -- drawTokenTree "" -- ++AZ++ debug+ rhs' <- addDecl rhs Nothing (demotedDecls,dsig,dtoks) False+ logm $ "MoveDef.foldParams addDecl done 2"+ return (GHC.Match pats mt rhs')++ -- return match+ where++ -- matchesInDecls ((Dec (HsFunBind loc matches))::HsDeclP)=matches+ matchesInDecls (GHC.FunBind _ _ (GHC.MatchGroup matches _) _ _ _) = matches+ matchesInDecls _x = []++ -- patsInMatch ((HsMatch loc1 name pats rhs ds)::HsMatchP)+ -- =pats+ patsInMatch (GHC.L _ (GHC.Match pats' _ _)) = pats'++ -- demotedDecls = map GHC.unLoc $ definingDeclsNames pns decls True False+++ foldInDemotedDecls :: [GHC.Name] -- ^The (list?) of names to be demoted+ -> [GHC.Name] -- ^Any names that clash+ -> [(GHC.Name, GHC.HsExpr GHC.Name)] -- ^Parameter substitutions required+ -> [GHC.LHsBind GHC.Name] -- ^Binds of original top level entiity, including src and dst+ -> RefactGhc [GHC.LHsBind GHC.Name]+ foldInDemotedDecls pns' clashedNames subst decls+ = everywhereMStaged SYB.Renamer (SYB.mkM worker) decls+ where+ -- worker (match@(HsMatch loc1 (PNT pname _ _) pats rhs ds)::HsMatchP)+ worker (match@(GHC.FunBind (GHC.L _ pname) _ (GHC.MatchGroup _matches _) _ _ _) :: GHC.HsBind GHC.Name)+ | isJust (find (==pname) pns')+ = do+ match' <- foldM (flip (autoRenameLocalVar True)) match clashedNames+ match'' <- foldM replaceExpWithUpdToks match' subst+ rmParamsInDemotedDecls (map fst subst) match''++ worker x = return x++ ------Get all of the paramaters supplied to pn ---------------------------+ {- eg. sumSquares x1 y1 x2 y2 = rt x1 y1 + rt x2 y2+ rt x y = x+y+ demote 'rt' to 'sumSquares',+ 'allParams pn rhs []' returns [[x1,x2],[y1,y2]]+ where pn is 'rt' and rhs is 'rt x1 y1 + rt x2 y2'+ -}++ allParams :: GHC.Name -> GHC.GRHSs GHC.Name -> [[GHC.HsExpr GHC.Name]]+ -> RefactGhc [[GHC.HsExpr GHC.Name]]+ allParams pn rhs1 initial -- pn: demoted function/pattern name.+ =do -- p<-getOneParam pn rhs+ let p = getOneParam pn rhs1+ -- putStrLn (show p)+ if (nonEmptyList p) then do rhs' <- rmOneParam pn rhs1+ allParams pn rhs' (initial++[p])+ else return initial+ where+ getOneParam :: (SYB.Data t) => GHC.Name -> t -> [GHC.HsExpr GHC.Name]+ getOneParam pn1+ = SYB.everythingStaged SYB.Renamer (++) []+ ([] `SYB.mkQ` worker)+ -- =applyTU (stop_tdTU (failTU `adhocTU` worker))+ where+ worker :: GHC.HsExpr GHC.Name -> [GHC.HsExpr GHC.Name]+ worker (GHC.HsApp e1 e2)+ |(expToName e1==pn1) = [GHC.unLoc e2]+ worker _ = []+ rmOneParam :: (SYB.Data t) => GHC.Name -> t -> RefactGhc t+ rmOneParam pn1 t+ -- This genuinely needs to be done once only. Damn.+ -- =applyTP (stop_tdTP (failTP `adhocTP` worker))+ = do+ -- _ <- clearRefactDone+ everywhereMStaged' SYB.Renamer (SYB.mkM worker) t+ where+ {-+ worker :: GHC.HsExpr GHC.Name -> RefactGhc (GHC.HsExpr GHC.Name)+ worker e@(GHC.HsApp e1 e2 ) = do -- The param being removed is e2+ done <- getRefactDone+ case (not done) && expToName e1==pn1 of+ True -> do setRefactDone+ return (GHC.unLoc e1)+ False -> return e+ worker x = return x+ -}+ worker (GHC.HsApp e1 _e2 ) -- The param being removed is e2+ |expToName e1==pn1 = return (GHC.unLoc e1)+ worker x = return x+{-+ AST output++ addthree x y z++ becomes++ (HsApp+ (L {test/testdata/Demote/WhereIn6.hs:10:17-28}+ (HsApp+ (L {test/testdata/Demote/WhereIn6.hs:10:17-26}+ (HsApp+ (L {test/testdata/Demote/WhereIn6.hs:10:17-24}+ (HsVar {Name: WhereIn6.addthree}))+ (L {test/testdata/Demote/WhereIn6.hs:10:26}+ (HsVar {Name: x}))))+ (L {test/testdata/Demote/WhereIn6.hs:10:28}+ (HsVar {Name: y}))))+ (L {test/testdata/Demote/WhereIn6.hs:10:30}+ (HsVar {Name: z})))++-----+ (HsApp+ (HsApp+ (HsApp+ (HsVar {Name: WhereIn6.addthree}))+ (HsVar {Name: x}))))+ (HsVar {Name: y}))))+ (HsVar {Name: z})))++-----++ sq p x++ becomes++ (HsApp+ (HsApp+ (HsVar {Name: Demote.WhereIn4.sq}))+ (HsVar {Name: p}))))+ (HsVar {Name: x})))++----+ sq x++ becomes++ (HsApp+ (HsVar {Name: sq}))+ (HsVar {Name: x})))+-}+++ -----------remove parameters in demotedDecls-------------------------------+ rmParamsInDemotedDecls :: [GHC.Name] -> GHC.HsBind GHC.Name+ -> RefactGhc (GHC.HsBind GHC.Name)+ rmParamsInDemotedDecls ps bind+ -- = error $ "rmParamsInDemotedDecls: (ps,bind)=" ++ (showGhc (ps,bind)) -- ++AZ+++ -- =applyTP (once_tdTP (failTP `adhocTP` worker))+ = everywhereMStaged SYB.Renamer (SYB.mkM worker) bind+ -- where worker ((HsMatch loc1 name pats rhs ds)::HsMatchP)+ where worker (GHC.Match pats2 typ rhs1)+ = do+ let pats'=filter (\x->not ((patToPNT x /= Nothing) &&+ elem (gfromJust "rmParamsInDemotedDecls" $ patToPNT x) ps)) pats2++ let (startPos,endPos) = getBiggestStartEndLoc pats2+ if (emptyList pats')+ then removeToksForPos (startPos,endPos)+ else -- updateToksWithPos (startPos,endPos) pats' prettyprint False+ updateToksWithPos (startPos,endPos) pats' pprPat False++ -- pats'' <- update pats pats' pats++ return (GHC.Match pats' typ rhs1)++ pprPat pat = intercalate " " $ map (\p -> (prettyprint p )) pat++ ----------remove parameters in the parent functions' rhs-------------------+ --Attention: PNT i1 _ _==PNT i2 _ _ = i1 =i2+ rmParamsInParent :: GHC.Name -> [GHC.HsExpr GHC.Name] -> GHC.GRHSs GHC.Name+ -> RefactGhc (GHC.GRHSs GHC.Name)+ rmParamsInParent pn es+ -- =applyTP (full_buTP (idTP `adhocTP` worker))+ = everywhereMStaged SYB.Renamer (SYB.mkM worker)+ where worker expr@(GHC.L _ (GHC.HsApp e1 e2))+ -- was | findPN pn e1 && (elem (GHC.unLoc e2) es)+ | findPN pn e1 && (elem (showGhc (GHC.unLoc e2)) (map (showGhc) es))+ = update expr e1 expr+ worker (expr@(GHC.L _ (GHC.HsPar e1)))+ |pn==expToName e1+ = update expr e1 expr+ worker x =return x+++ getClashedNames oldNames newNames match+ = do (_f,d) <- hsFDsFromInside match+ -- ds' <- mapM (flip hsVisiblePNs match) oldNames+ ds' <- mapM (flip hsVisiblePNs match) oldNames+ -- return clashed names+ return (filter (\x->elem ({- pNtoName -} x) newNames) --Attention: nub+ ( nub (d `union` (nub.concat) ds')))++ ----- make Substitions between formal and actual parameters.-----------------+ mkSubst :: [GHC.LPat GHC.Name] -> [[GHC.HsExpr GHC.Name]] -> [(GHC.Name,GHC.HsExpr GHC.Name)]+ mkSubst pats1 params+ = catMaybes (zipWith (\x y -> if (patToPNT x/=Nothing) && (length (nub $ map showGhc y)==1)+ then Just (gfromJust "mkSubst" $ patToPNT x,(ghead "mkSubst") y)+ else Nothing) pats1 params)+++-- |substitute an old expression by new expression+replaceExpWithUpdToks :: (SYB.Data t)+ => t -> (GHC.Name, GHC.HsExpr GHC.Name)+ -> RefactGhc t+replaceExpWithUpdToks decls subst+ -- = applyTP (full_buTP (idTP `adhocTP` worker)) decls+ = everywhereMStaged' SYB.Renamer (SYB.mkM worker) decls+ where worker (e@(GHC.L l _)::GHC.LHsExpr GHC.Name)+ |(expToName e/=defaultName) && (expToName e)==(fst subst)+ = update e (GHC.L l (snd subst)) e+ worker x=return x+++-- | 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++-- ---------------------------------------------------------------------++-- |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 -> ([t], [t], [t])+divideDecls ds pnt+ -- = error "undefined divideDecls"+ = let (before,after)=break (\x->findPNT pnt x) ds+ in if (not $ emptyList after)+ then (before, [ghead "divideDecls" after], tail after)+ else (ds,[],[])
+ src/Language/Haskell/Refact/Refactoring/Renaming.hs view
@@ -0,0 +1,350 @@+module Language.Haskell.Refact.Refactoring.Renaming(rename) 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+import qualified Name as GHC+import qualified RdrName as GHC++import Control.Monad+import Data.List+import Exception++import Language.Haskell.GhcMod+import Language.Haskell.Refact.API++-- import Language.Haskell.Refact.Utils.GhcVersionSpecific++{-This refactoring renames an indentifier to a user-specified name.++ Conditions:+ a: the indentifier to be renamed should be defined in the current module.+ b. the user provided name should be a valid name with regard to the name+ space of the identifier.+ c. the new name should not change the semantics of the program, and+ should not cause any name clash/conflict/ambiguity problem in the+ program.++ Attention:+ a. To select an identifier, stop the cursor at the beginning position of+ any occurrence of the identifier.+ b. Renaming a qualified name will not change the qualifier;+ c. In current module, an unqualified name won't become qualified after+ renaming; but, in client modules, an unqualified name might become+ qualified after renaming to avoid ambiguity prolem. In case the new+ name, say 'f', will cause ambiguous occurrence in the current module+ (this is because the identifier 'f' is imported from other modules),+ the user will be prompted to choose another new name or qualify the+ use of 'f' before doing renaming.+ -}++{-In the current implementation, we assume that module name is same as+the file name, but we should keep in mind that people also use unnamed+modules.+-}++-- | Rename the given identifier.+rename :: RefactSettings -> Cradle+ -> FilePath -> String -> SimpPos+ -> IO [FilePath]+rename settings cradle fileName newName (row,col) =+ runRefacSession settings cradle (comp fileName newName (row,col))++-- | Body of the refactoring+comp :: FilePath -> String -> SimpPos -> RefactGhc [ApplyRefacResult]+comp fileName newName (row,col) = do+ logm $ "Renaming.comp: (fileName,newName,(row,col))=" ++ (show (fileName,newName,(row,col)))+ getModuleGhc fileName+ renamed <- getRefactRenamed+ parsed <- getRefactParsed+ -- logm $ "comp:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ+++ -- logm $ "comp:parsed=" ++ (SYB.showData SYB.Parser 0 parsed) -- ++AZ++++ modu <- getModule+ -- let (Just (modName,_)) = getModuleName parsed+ let modName = case (getModuleName parsed) of+ Just (mn,_) -> mn+ Nothing -> GHC.mkModuleName "Main"+ let maybePn = locToName (row, col) renamed+ logm $ "Renamed.comp:maybePn=" ++ (showGhc maybePn) -- ++AZ+++ case maybePn of+ Just pn@(GHC.L _ n) -> do+ logm $ "Renaming:(n,modu)=" ++ (showGhc (n,modu))+ -- let (GHC.L _ rdrName') = gfromJust "Renaming.comp.1" $ locToRdrName (row, col) parsed+ -- logm $ "Renaming.comp:rdrName'=" ++ (showGhc rdrName')++ let (GHC.L _ rdrName) = gfromJust "Renaming.comp.2" $ locToRdrName (row, col) parsed+ let rdrNameStr = GHC.occNameString $ GHC.rdrNameOcc rdrName+ logm $ "Renaming: rdrName=" ++ (SYB.showData SYB.Parser 0 rdrName)+ logm $ "Renaming: occname rdrName=" ++ (show $ GHC.occNameString $ GHC.rdrNameOcc rdrName)++ unless (nameToString n /= newName) $ error "The new name is same as the old name"+ unless (isValidNewName n rdrNameStr newName) $ error $ "Invalid new name:" ++ newName ++ "!"+++ logm $ "Renaming.comp: before GHC.nameModule,n=" ++ (showGhc n)+ -- let defineMod = GHC.moduleName $ GHC.nameModule n++ let defineMod = case GHC.nameModule_maybe n of+ Just mn -> GHC.moduleName mn+ Nothing -> modName++ -- TODO: why do we have this restriction?+ unless (defineMod == modName ) ( error ("This identifier is defined in module " ++ (show defineMod) +++ ", please do renaming in that module!"))+ -- logm $ "Renaming.comp:(isMainModule modu,pn)=" ++ (showGhc (isMainModule modu,pn))+ if isMainModule modu && (showGhc pn) == "Main.main"+ then error ("The 'main' function defined in a 'Main' module should not be renamed!")+ else do+ logm $ "Renaming.comp: not main module"+ newNameGhc <- mkNewGhcName (Just modu) newName+ (refactoredMod,nIsExported) <- applyRefac (doRenaming pn rdrNameStr newName newNameGhc modName) RSAlreadyLoaded+ logm $ "Renaming:nIsExported=" ++ (show nIsExported)+ if nIsExported --no matter whether this pn is used or not.+ then do clients <- clientModsAndFiles modName+ logm ("Renaming: clients=" ++ (showGhc clients)) -- ++AZ++ debug+ refactoredClients <- mapM (renameInClientMod n newName newNameGhc) clients+ return $ refactoredMod:(concat refactoredClients)+ else return [refactoredMod]+ Nothing -> error "Invalid cursor position!"+++-- |Actually do the renaming, split into the various things that can+-- be renamed. Returns True if the name is exported+doRenaming :: GHC.Located GHC.Name -> String -> String -> GHC.Name -> GHC.ModuleName -> RefactGhc Bool++--------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+ {-+ r' <- applyTP (once_buTPGhc (failTP `adhocTP` renameInMod+ -- `adhocTP` renameInMatch+ -- `adhocTP` renameInPattern+ -- `adhocTP` renameInExp+ -- `adhocTP` renameInAlt+ -- `adhocTP` renameInStmts+ )) renamed+ -}+ -- somewhereMStagedBu SYB.Renamer (SYB.mkM renameInMod+ void $ everywhereMStaged SYB.Renamer (SYB.mkM renameInMod+ ) renamed+ logm $ "doRenaming done"+ nIsExported <- isExported oldn+ return nIsExported+ where+ -- 1. The name is declared in a module(top level name)+ -- renameInMod (mod::HsModuleP)+ renameInMod :: GHC.RenamedSource -> RefactGhc GHC.RenamedSource+ renameInMod ren+ -- was | isDeclaredIn oldn ren = do+ | True = do+ logm $ "renameInMod"+ renameTopLevelVarName oldn newNameStr newNameGhc modName ren True True+ -- renameInMod _ren = mzero+++renameTopLevelVarName :: GHC.Name -> String -> GHC.Name -> GHC.ModuleName -> GHC.RenamedSource+ -> Bool -> Bool -> RefactGhc GHC.RenamedSource+renameTopLevelVarName oldPN newName newNameGhc modName renamed existChecking exportChecking = do+ logm $ "renameTopLevelVarName:(existChecking,exportChecking)=" ++ (show (existChecking,exportChecking))+ causeAmbiguity <- causeAmbiguityInExports oldPN newNameGhc+ -- f' contains names imported from other modules;+ -- d' contains the top level names declared in this module;+ (f',d') <- hsFDsFromInside renamed+ --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')+ logm $ "renameTopLevelVarName:f=" ++ (show f)+ logm $ "renameTopLevelVarName:d=" ++ (show d)+ let newNameStr = nameToString newNameGhc+ logm $ "renameTopLevelVarName:(newName,newNameStr)=" ++ (show (newName,newNameStr))+ scopeClashNames <- inScopeNames newName+ logm $ "renameTopLevelVarName:(f')=" ++ (showGhc f')+ logm $ "renameTopLevelVarName:(scopeClashNames,intersection)=" ++ (showGhc (scopeClashNames,intersect scopeClashNames f'))+ logm $ "renameTopLevelVarName:(oldPN,modName)=" ++ (showGhc (oldPN,modName))+ if (nonEmptyList $ intersect scopeClashNames f')+ -- if elem newNameStr f+ then error ("The new name will cause ambiguous occurrence problem,"+ ++" please select another new name or qualify the use of ' "+ ++ newName ++ "' before renaming!\n") -- Another implementation option is to add the qualifier+ -- to newName automatically.+ else if existChecking && elem newNameStr (d \\ [nameToString oldPN]) --only check the declared names here.+ then error ("Name '"++newName++"' already existed\n") --the same name has been declared in this module.+ else if exportChecking && causeNameClashInExports oldPN newNameGhc modName renamed+ then error ("The new name will cause conflicting exports, please select another new name!")+ else if exportChecking && causeAmbiguity -- causeAmbiguityInExports oldPN newNameGhc {- inscps -} renamed+ then error $"The new name will cause ambiguity in the exports of module "++ show modName ++ ", please select another name!"+ else do -- get all of those declared names visible to oldPN at where oldPN is used.++ logm $ "renameTopLevelVarName:basic tests done"++ -- isInScopeUnqual <- isInScopeAndUnqualifiedGhc newName Nothing+ isInScopeUnqual <- isInScopeAndUnqualifiedGhc newName (Just newNameGhc)+ logm $ "renameTopLevelVarName:after isInScopeUnqual"+ logm $ "renameTopLevelVarName:oldPN=" ++ showGhc oldPN+ ds <- hsVisibleNames oldPN renamed+ logm $ "renameTopLevelVarName:ds computed=" ++ (show ds)+ -- '\\[pNtoName oldPN]' handles the case in which the new name is same as the old name + if existChecking && elem newName ((nub (ds `union` f)) \\[nameToString oldPN])+ then error ("Name '"++newName++"' already existed, or rename '"+ ++nameToString oldPN++ "' to '"++newName+++ "' will change the program's semantics!\n")+ else if exportChecking && isInScopeUnqual -- isInScopeAndUnqualifiedGhc newName Nothing+ then do+ logm $ "renameTopLevelVarName start..:should have qualified"+ void $ renamePN oldPN newNameGhc True True renamed+ logm $ "renameTopLevelVarName done:should have qualified"+ -- drawTokenTreeDetailed "should be qualified" -- ++AZ++ debug+ r' <- getRefactRenamed+ return r'+ else do+ logm $ "renameTopLevelVarName start.."+ void $ renamePN oldPN newNameGhc True False renamed+ logm $ "renameTopLevelVarName done"+ r' <- getRefactRenamed+ return r'+++renameInClientMod :: GHC.Name -> String -> GHC.Name -> TargetModule+ -> RefactGhc [ApplyRefacResult]+renameInClientMod oldPN newName newNameGhc targetModule@(_,modSummary) = do+ logm $ "renameInClientMod:(oldPN,newNameGhc,modSummary)=" ++ (showGhc (oldPN,newNameGhc,targetModule)) -- ++AZ+++ void $ activateModule targetModule+ {- ++AZ++ debug stuff -}+ names <- ghandle handler (GHC.parseName $ nameToString oldPN)+ nameInfo <- mapM GHC.lookupName names+ logm $ "renameInClientMod: nameInfo=" ++ (showGhc nameInfo)+ {- ++AZ++ debug stuff end -}++ renamed <- getRefactRenamed+ let modName = GHC.moduleName $ GHC.ms_mod modSummary+ -- causeNameClashInExports oldPN newName mod exps+ -- logm $ "renameInClientMod:causeNameClashInExports oldPN modName renamed=" ++ (show $ causeNameClashInExports oldPN modName renamed)++ -- 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+ -- 2. Is the new name module imported qualified, and so needs to+ -- be qualified in the replacement, according to the import+ isInScopeUnqual <- isInScopeAndUnqualifiedGhc (nameToString oldPN) Nothing+ isInScopeUnqualNew <- isInScopeAndUnqualifiedGhc newName Nothing+ logm $ "renameInClientMod: (isInScopeAndUnqual,isInScopeUnqualNew)=" ++ (show (isInScopeUnqual,isInScopeUnqualNew)) -- ++AZ+++ -- if qualifier == [] --this name is not imported, but it maybe used in the import list+ -- if isInScopeUnqual+ if isInScopeUnqualNew+ then+ -- do (mod', ((ts',m),f))<-runStateT (renamePN oldPN Nothing newName True mod) ((ts,unmodified), fileName)+ do+ (refactoredMod,_) <- applyRefac (refactRenameSimple oldPN newName newNameGhc True) RSAlreadyLoaded+ return [refactoredMod]+ else+ do if causeNameClashInExports oldPN newNameGhc modName renamed+ then error $"The new name will cause conflicting exports in module "++ show newName ++ ", please select another name!"+ else do+ (refactoredMod,_) <- applyRefac (refactRenameComplex oldPN newName newNameGhc) RSAlreadyLoaded+ -- TODO: implement rest of this+ return [refactoredMod]+ where+ handler:: (GHC.GhcMonad m) => SomeException -> m [GHC.Name]+ handler _ = return []++ refactRenameSimple :: GHC.Name -> String -> GHC.Name -> Bool -> RefactGhc ()+ refactRenameSimple old newStr new useQual = do+ qualifyTopLevelVar newStr+ renamed <- getRefactRenamed+ logm $ "renameInClientMod.refactRename:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ+++ void $ renamePN old new True useQual renamed+ return ()++ refactRenameComplex :: GHC.Name -> String -> GHC.Name -> RefactGhc ()+ refactRenameComplex old new newGhc = do+ qualifyTopLevelVar new+ worker old new newGhc++ qualifyTopLevelVar :: String -> RefactGhc ()+ qualifyTopLevelVar new = do+ toQualify <- inScopeNames new+ logm $ "renameInClientMod.qualifyTopLevelVar:new:toQualify=" ++ (show new) ++ ":" ++ (showGhc toQualify)+ -- renamed <- getRefactRenamed+ -- renamePN new new True True renamed+ mapM_ qualifyToplevelName toQualify+ return ()++ worker :: GHC.Name -> String -> GHC.Name -> RefactGhc ()+ worker oldPN' newName' newNameGhc' = do+ logm $ "renameInClientMod.worker"+ renamed <- getRefactRenamed+ isInScopeUnqualNew <- isInScopeAndUnqualifiedGhc newName' Nothing+ vs <- hsVisibleNames oldPN' renamed --Does this check names other than variable names?+ if elem newName' ((nub vs) \\ [nameToString oldPN']) || isInScopeUnqualNew+ then void $ renamePN oldPN' newNameGhc' True True renamed --rename to qualified Name+ else void $ renamePN oldPN' newNameGhc' True False renamed -- do not qualify+ return ()+++causeAmbiguityInExports :: GHC.Name -> GHC.Name -> RefactGhc Bool+causeAmbiguityInExports old newName {- inscps -} = do+ (GHC.L _ (GHC.HsModule _ exps _imps _decls _ _)) <- getRefactParsed+ isInScopeUnqual <- isInScopeAndUnqualifiedGhc (nameToString old) Nothing+ let usedUnqual = usedWithoutQualR newName exps+ logm $ "causeAmbiguityInExports:(isInScopeUnqual,usedUnqual)" ++ (show (isInScopeUnqual,usedUnqual))+ return (isInScopeUnqual && usedUnqual)+++isValidNewName :: GHC.Name -> String -> String -> Bool+isValidNewName oldName rdrNameStr newName = res+ where+ doTest :: Bool -> Bool -> String -> Bool+ doTest isCategory isRightType errStr =+ if isCategory+ then if isRightType+ then True+ else error errStr+ else True++ tyconOk = doTest (GHC.isTyConName oldName)+ (isConId newName)+ "Invalid type constructor/class name!"++ -- classOk = if isClassName oldName && isConId newName+ -- then True+ -- else error "Invalid class name!"++ dataConOk = doTest (GHC.isDataConName oldName)+ (isConId newName)+ "Invalid data constructor name!"++ -- fieldOk = doTest (isFieldName oldName)+ -- (isVarId newName)+ -- "Invalid field name!"++ -- instanceOk = doTest (isInstanceName oldName)+ -- (isVarId newName)+ -- "Invalid class instance name!"++ tyVarOk = doTest (GHC.isTyVarName oldName)+ (isVarId newName)+ "Invalid type variable name!"++ oldName' = rdrNameStr+ matchNamesOk+ | {- GHC.isValName oldName || -} GHC.isVarName oldName+ = if isVarId oldName' && not (isVarId newName)+ then error "The new name should be an identifier!"+ else if isOperator oldName' && not (isOperator newName)+ then error "The new name should be an operator!"+ else if (isVarId oldName' && isVarId newName) ||+ (isOperator oldName' && isOperator newName)+ then True+ -- else error "Invalid new name!"+ else error $ "Invalid new name!" ++ (show (oldName',newName,isVarId oldName',isVarId newName,isOperator oldName',isOperator newName))+ | otherwise = True++ res = tyconOk && dataConOk {- && fieldOk && instanceOk -} &&+ tyVarOk && matchNamesOk++ -- res = error $ "isValidNewName:(tyconOk,dataConOk`,fieldOk,instanceOk,tyVarOk,matchNamesOk)=" ++ (show (tyconOk,dataConOk,fieldOk,instanceOk,tyVarOk,matchNamesOk))+
+ src/Language/Haskell/Refact/Refactoring/SwapArgs.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Language.Haskell.Refact.Refactoring.SwapArgs (swapArgs) where++import qualified Data.Generics.Aliases as SYB+import qualified GHC.SYB.Utils as SYB++import qualified Name as GHC+import qualified GHC++import Language.Haskell.GhcMod+import Language.Haskell.Refact.API++-- TODO: replace args with specific parameters+swapArgs :: RefactSettings -> Cradle -> [String] -> IO [FilePath]+swapArgs settings cradle args+ = do let fileName = args!!0+ row = (read (args!!1)::Int)+ col = (read (args!!2)::Int)+ runRefacSession settings cradle (comp fileName (row,col))+++comp :: String -> SimpPos+ -> RefactGhc [ApplyRefacResult]+comp fileName (row, col) = do+ getModuleGhc fileName+ renamed <- getRefactRenamed++ let name = locToName (row, col) renamed++ case name of+ -- (Just pn) -> do refactoredMod@(_, (_t, s)) <- applyRefac (doSwap pnt pn) (Just modInfo) fileName+ (Just pn) -> do+ (refactoredMod,_) <- applyRefac (doSwap pn) (RSFile fileName)+ return [refactoredMod]+ Nothing -> error "Incorrect identifier selected!"+ --if isFunPNT pnt mod -- Add this back in ++ CMB ++++ -- then do+ -- rs <-if isExported pnt exps+ -- then applyRefacToClientMods (doSwap pnt) fileName+ -- else return []+ -- writeRefactoredFiles False (r:rs)+ -- else error "\nInvalid cursor position!"++ -- putStrLn (showToks t)+ -- writeRefactoredFiles False [refactoredMod]+ -- putStrLn ("here" ++ (SYB.showData SYB.Parser 0 mod)) -- $ show [fileName, beginPos, endPos]+ -- putStrLn "Completd"+++doSwap ::+ (GHC.Located GHC.Name) -> RefactGhc () -- m GHC.ParsedSource+doSwap name = do+ -- inscopes <- getRefactInscopes+ renamed <- getRefactRenamed+ -- parsed <- getRefactParsed+ reallyDoSwap name renamed++reallyDoSwap :: (GHC.Located GHC.Name) -> GHC.RenamedSource -> RefactGhc ()+reallyDoSwap (GHC.L _s n1) renamed = do+ renamed' <- everywhereMStaged SYB.Renamer (SYB.mkM inMod `SYB.extM` inExp `SYB.extM` inType) renamed -- this needs to be bottom up +++ CMB ++++ putRefactRenamed renamed'+ return ()++ where+ -- 1. The definition is at top level...+ inMod (_func@(GHC.FunBind (GHC.L x n2) infixity (GHC.MatchGroup matches p) a locals tick)::(GHC.HsBindLR GHC.Name GHC.Name ))+ | GHC.nameUnique n1 == GHC.nameUnique n2+ = do logm ("inMatch>" ++ SYB.showData SYB.Parser 0 (GHC.L x n2) ++ "<")+ newMatches <- updateMatches matches+ return (GHC.FunBind (GHC.L x n2) infixity (GHC.MatchGroup newMatches p) a locals tick)+ inMod func = return func++ -- 2. All call sites of the function...+ inExp expr@((GHC.L _x (GHC.HsApp (GHC.L _y (GHC.HsApp e e1)) e2))::GHC.Located (GHC.HsExpr GHC.Name))+ | GHC.nameUnique (expToName e) == GHC.nameUnique n1+ = update e2 e1 =<< update e1 e2 expr+ inExp e = return e++ -- 3. Type signature...+ inType (GHC.L x (GHC.TypeSig [GHC.L x2 name] types)::GHC.LSig GHC.Name)+ | GHC.nameUnique name == GHC.nameUnique n1+ = do let (t1:t2:ts) = tyFunToList types+ t1' <- update t1 t2 t1+ t2' <- update t2 t1 t2+ return (GHC.L x (GHC.TypeSig [GHC.L x2 name] (tyListToFun (t1':t2':ts))))++ inType (GHC.L _x (GHC.TypeSig (n:ns) _types)::GHC.LSig GHC.Name)+ | GHC.nameUnique n1 `elem` (map (\(GHC.L _ n') -> GHC.nameUnique n') (n:ns))+ = error "Error in swapping arguments in type signature: signauture bound to muliple entities!"++ inType ty = return ty++ tyFunToList (GHC.L _ (GHC.HsForAllTy _ _ _ (GHC.L _ (GHC.HsFunTy t1 t2)))) = t1 : (tyFunToList t2)+ tyFunToList (GHC.L _ (GHC.HsFunTy t1 t2)) = t1 : (tyFunToList t2)+ tyFunToList t = [t]++ tyListToFun [t1] = t1+ tyListToFun (t1:ts) = GHC.noLoc (GHC.HsFunTy t1 (tyListToFun ts))++ updateMatches [] = return []+ updateMatches ((GHC.L x (GHC.Match pats nothing rhs)::GHC.Located (GHC.Match GHC.Name)):matches)+ = case pats of+ (p1:p2:ps) -> do p1' <- update p1 p2 p1+ p2' <- update p2 p1 p2+ matches' <- updateMatches matches+ return ((GHC.L x (GHC.Match (p1':p2':ps) nothing rhs)):matches')+ [p] -> return [GHC.L x (GHC.Match [p] nothing rhs)]+ [] -> return [GHC.L x (GHC.Match [] nothing rhs)]++
− src/Language/Haskell/Refact/Renaming.hs
@@ -1,658 +0,0 @@-module Language.Haskell.Refact.Renaming(rename) 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-import qualified Name as GHC-import qualified RdrName as GHC--import Control.Monad-import Data.List-import Exception--import Language.Haskell.GhcMod-import Language.Haskell.Refact.Utils.Utils-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.TypeUtils--{-This refactoring renames an indentifier to a user-specified name.-- Conditions:- a: the indentifier to be renamed should be defined in the current module.- b. the user provided name should be a valid name with regard to the name- space of the identifier.- c. the new name should not change the semantics of the program, and- should not cause any name clash/conflict/ambiguity problem in the- program.-- Attention:- a. To select an identifier, stop the cursor at the beginning position of- any occurrence of the identifier.- b. Renaming a qualified name will not change the qualifier;- c. In current module, an unqualified name won't become qualified after- renaming; but, in client modules, an unqualified name might become- qualified after renaming to avoid ambiguity prolem. In case the new- name, say 'f', will cause ambiguous occurrence in the current module- (this is because the identifier 'f' is imported from other modules),- the user will be prompted to choose another new name or qualify the- use of 'f' before doing renaming.- -}--{-In the current implementation, we assume that module name is same as-the file name, but we should keep in mind that people also use unnamed-modules.--}---- | Rename the given identifier.-rename :: RefactSettings -> Cradle- -> FilePath -> String -> SimpPos- -> IO [FilePath]-rename settings cradle fileName newName (row,col) =- runRefacSession settings cradle (comp fileName newName (row,col))---- | Body of the refactoring-comp :: FilePath -> String -> SimpPos -> RefactGhc [ApplyRefacResult]-comp fileName newName (row,col) = do- logm $ "Renaming.comp: (fileName,newName,(row,col))=" ++ (show (fileName,newName,(row,col)))- getModuleGhc fileName- renamed <- getRefactRenamed- parsed <- getRefactParsed- -- logm $ "comp:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++- -- logm $ "comp:parsed=" ++ (SYB.showData SYB.Parser 0 parsed) -- ++AZ++-- modu <- getModule- -- let (Just (modName,_)) = getModuleName parsed- let modName = case (getModuleName parsed) of- Just (mn,_) -> mn- Nothing -> GHC.mkModuleName "Main"- let maybePn = locToName (row, col) renamed- logm $ "Renamed.comp:maybePn=" ++ (showGhc maybePn) -- ++AZ++- case maybePn of- Just pn@(GHC.L _ n) -> do- logm $ "Renaming:(n,modu)=" ++ (showGhc (n,modu))- -- let (GHC.L _ rdrName') = gfromJust "Renaming.comp.1" $ locToRdrName (row, col) parsed- -- logm $ "Renaming.comp:rdrName'=" ++ (showGhc rdrName')-- let (GHC.L _ rdrName) = gfromJust "Renaming.comp.2" $ locToRdrName (row, col) parsed- let rdrNameStr = GHC.occNameString $ GHC.rdrNameOcc rdrName- logm $ "Renaming: rdrName=" ++ (SYB.showData SYB.Parser 0 rdrName)- logm $ "Renaming: occname rdrName=" ++ (show $ GHC.occNameString $ GHC.rdrNameOcc rdrName)-- unless (nameToString n /= newName) $ error "The new name is same as the old name"- unless (isValidNewName n rdrNameStr newName) $ error $ "Invalid new name:" ++ newName ++ "!"--- logm $ "Renaming.comp: before GHC.nameModule,n=" ++ (showGhc n)- -- let defineMod = GHC.moduleName $ GHC.nameModule n-- let defineMod = case GHC.nameModule_maybe n of- Just mn -> GHC.moduleName mn- Nothing -> modName-- -- TODO: why do we have this restriction?- unless (defineMod == modName ) ( error ("This identifier is defined in module " ++ (show defineMod) ++- ", please do renaming in that module!"))- -- logm $ "Renaming.comp:(isMainModule modu,pn)=" ++ (showGhc (isMainModule modu,pn))- if isMainModule modu && (showGhc pn) == "Main.main"- then error ("The 'main' function defined in a 'Main' module should not be renamed!")- else do- logm $ "Renaming.comp: not main module"- newNameGhc <- mkNewGhcName (Just modu) newName- (refactoredMod,nIsExported) <- applyRefac (doRenaming pn rdrNameStr newName newNameGhc modName) RSAlreadyLoaded- logm $ "Renaming:nIsExported=" ++ (show nIsExported)- if nIsExported --no matter whether this pn is used or not.- then do clients <- clientModsAndFiles modName- logm ("Renaming: clients=" ++ (showGhc clients)) -- ++AZ++ debug- refactoredClients <- mapM (renameInClientMod n newName newNameGhc) clients- return $ refactoredMod:(concat refactoredClients)- else return [refactoredMod]- Nothing -> error "Invalid cursor position!"--{- original--rename args- = do let fileName = args!!0- newName = args!!1- row = read (args!!2)::Int- col = read (args!!3)::Int-- modName <- fileNameToModName fileName- AbstractIO.putStrLn $ show modName- (inscps, exps, mod,tokList) <- parseSourceFile fileName--- --AbstractIO.putStrLn x- -- i <- lift $ ghcTypeCheck "Fish.hs"- -- AbstractIO.putStrLn i- let pnt = locToPNT fileName (row, col) mod- defineMod = if isTopLevelPN (pNTtoPN pnt)- then (fromJust (hasModName pnt))- else modName-- unless (pnt /= defaultPNT && isValidNewName pnt newName)- $ error "Invalid cursor position or the new name is invalid!\n"- unless (pNTtoName pnt/=newName) $ error "The new name is same as the old name" - unless (defineMod == modName ) ( error ("This idenifier is defined in module " ++ modNameToStr defineMod ++ - ", please do renaming in that module!"))- if isMainModule modName && pNTtoName pnt == "main"- then error ("The 'main' function defined in a 'Main' module should not be renamed!")- else do (mod',((tokList',modified),_))<-doRenaming pnt newName modName mod inscps exps- ((tokList,unmodified),fileName)- if isExported pnt exps --no matter whether this pn is used or not.- then do clients<-clientModsAndFiles modName --returns [(module name ,filename)] - refactoredClients <- mapM (renameInClientMod pnt newName) clients - writeRefactoredFiles False $ ((fileName,modified),(tokList',mod')):refactoredClients- else writeRefactoredFiles False [((fileName,modified), (tokList',mod'))]--}----- |Actually do the renaming, split into the various things that can--- be renamed. Returns True if the name is exported-doRenaming :: GHC.Located GHC.Name -> String -> String -> GHC.Name -> GHC.ModuleName -> RefactGhc Bool--- doRenaming pn@(GHC.L _ n) rdrNameStr newNameStr = do--- logm $ "doRenaming:(pn,rdrNameStr,newNameStr) = " ++ (showGhc (pn,rdrNameStr,newNameStr))--- error "fubar"-{--doRenaming pn@(GHC.L _ n) newNameStr = do- logm $ "doRenaming:(pn,newNameStr) = " ++ (showGhc (pn,newNameStr))- renamed <- getRefactRenamed- logm $ "doRenaming:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++- newName <- mkNewGhcName newNameStr- renamePN n newName True renamed- return ()--}--{-----------Rename a type constructor---------------------------doRenaming oldPNT@(PNT (PN _ (G _ _ _)) (Type _) _) newName modName mod inscps exps env- =doRenaming' oldPNT newName mod mod (hsTypeConstrsAndClasses modName) exps env-----------Rename a class name----------------------------------doRenaming oldPNT@(PNT _ (Class _ _) _) newName modName mod inscps exps env- =doRenaming' oldPNT newName mod mod (hsTypeConstrsAndClasses modName) exps env -----------Rename a data structure------------------------------doRenaming oldPNT@(PNT _ (ConstrOf _ _) _) newName modName mod inscps exps env- =doRenaming' oldPNT newName mod mod (hsDataConstrs modName) exps env-----------Rename an instance name------------------------------doRenaming oldPNT@(PNT _ (MethodOf i _ _) _) newName modName mod inscps exps env -- Claus- =runStateT (renameTopLevelVarName oldPNT newName modName inscps exps mod True True) env-----------Rename a type variable name-------------------------------doRenaming oldPNT@(PNT oldPN@(PN i (S loc)) (Type _) _) newName modName mod inscps exps env- = do let (before, parent, after)=divideDecls (hsDecls mod) oldPNT- (parent',toks)<-doRenaming' oldPNT newName parent mod hsTypeVbls exps env- return ((replaceDecls mod (before++parent'++after)),toks)--}--{-----------Rename a field name --------------------------------------doRenaming pn@(GHC.L _ n) newNameStr- | isFieldName n = do- logm $ "doRenaming:fieldName=" ++ (showGhc n)--}-{- old-doRenaming oldPNT@(PNT _ (FieldOf con typeInfo) _) newName modName mod inscps exps env - =do let (before,parent,after)=divideDecls (hsDecls mod) oldPNT- siblingNames=siblingFieldNames oldPNT- (f',d') <- hsFDsFromInside (before++after)- if elem newName (siblingNames ++ map pNtoName d')- then error("Name '"++newName++"' already existed\n")- else if elem newName $ fieldNames oldPNT- then runStateT (renameTopLevelVarName oldPNT newName modName inscps exps mod False False) env- else runStateT (renameTopLevelVarName oldPNT newName modName inscps exps mod False True) env--}-----------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- {-- r' <- applyTP (once_buTPGhc (failTP `adhocTP` renameInMod- -- `adhocTP` renameInMatch- -- `adhocTP` renameInPattern- -- `adhocTP` renameInExp- -- `adhocTP` renameInAlt- -- `adhocTP` renameInStmts- )) renamed- -}- -- somewhereMStagedBu SYB.Renamer (SYB.mkM renameInMod- void $ everywhereMStaged SYB.Renamer (SYB.mkM renameInMod- ) renamed- logm $ "doRenaming done"- nIsExported <- isExported oldn- return nIsExported- where- -- 1. The name is declared in a module(top level name)- -- renameInMod (mod::HsModuleP)- renameInMod :: GHC.RenamedSource -> RefactGhc GHC.RenamedSource- renameInMod ren- -- was | isDeclaredIn oldn ren = do- | True = do- logm $ "renameInMod"- renameTopLevelVarName oldn newNameStr newNameGhc modName ren True True- -- renameInMod _ren = mzero--{- original-doRenaming oldPNT@(PNT oldPN Value loc) newName modName mod inscps exps env- = runStateT (applyTP (once_buTP (failTP `adhocTP` renameInMod- `adhocTP` renameInMatch- `adhocTP` renameInPattern- `adhocTP` renameInExp- `adhocTP` renameInAlt- `adhocTP` renameInStmts)) mod) env- where- -- 1. The name is declared in a module(top level name)- renameInMod (mod::HsModuleP)- |isDeclaredIn oldPN mod=renameTopLevelVarName oldPNT newName modName inscps exps mod True True- renameInMod mod=mzero-- -- 2. The name is declared in a match- renameInMatch (match::HsMatchP)- |isDeclaredIn oldPN match=renameLocalVarName oldPN newName match- renameInMatch match=mzero-- -- 3. The name is declared in a pattern binding.- renameInPattern (pat:: HsDeclP)- |isDeclaredIn oldPN pat=renameLocalVarName oldPN newName pat- renameInPattern pat=mzero-- --4.The name is declared in a expression- renameInExp (exp::HsExpP)- |isDeclaredIn oldPN exp=renameLocalVarName oldPN newName exp- renameInExp exp=mzero-- --5.The name is declared in a case alternative- renameInAlt (alt::HsAltP)- |isDeclaredIn oldPN alt=renameLocalVarName oldPN newName alt- renameInAlt alt=mzero-- --6: The name is declared in a statment expression- renameInStmts (stmts::HsExpP)- |isDeclaredIn oldPN stmts=renameLocalVarName oldPN newName stmts- renameInStmts stmts=mzero--}--{--doRenaming' :: GHC.Name -> String -> RefactGhc ()--- doRenaming' oldPNT@(PNT oldPN _ _) newName parent mod fun exps env-doRenaming' oldPN newName- = error "undefined doRenaming'"--}-{-- = let (f',d')= fun parent- (f,d) =((nub.map pNtoName.filter (not.isQualifiedPN)) f', (nub.map pNtoName) d')- in if elem newName (d \\ [pNtoName oldPN])- then error("Name '"++newName++"' already existed\n")- else if elem newName f- then error ("The new name will cause ambiguous occurrence problem,"- ++" please select another new name or qualify the use of "- ++ newName ++ " before renaming!\n")- else if causeNameClashInExports oldPN newName mod exps- then error ("The new name will cause cause conflicting exports, please select another new name!")- else runStateT (renamePN oldPN Nothing newName True parent) env --}--{- old-doRenaming' oldPNT@(PNT oldPN _ _) newName parent mod fun exps env- = let (f',d')= fun parent- (f,d) =((nub.map pNtoName.filter (not.isQualifiedPN)) f', (nub.map pNtoName) d')- in if elem newName (d \\ [pNtoName oldPN])- then error("Name '"++newName++"' already existed\n")- else if elem newName f- then error ("The new name will cause ambiguous occurrence problem,"- ++" please select another new name or qualify the use of "- ++ newName ++ " before renaming!\n")- else if causeNameClashInExports oldPN newName mod exps- then error ("The new name will cause cause conflicting exports, please select another new name!")- else runStateT (renamePN oldPN Nothing newName True parent) env --}--renameTopLevelVarName :: GHC.Name -> String -> GHC.Name -> GHC.ModuleName -> GHC.RenamedSource- -> Bool -> Bool -> RefactGhc GHC.RenamedSource-renameTopLevelVarName oldPN newName newNameGhc modName renamed existChecking exportChecking = do- logm $ "renameTopLevelVarName:(existChecking,exportChecking)=" ++ (show (existChecking,exportChecking))- causeAmbiguity <- causeAmbiguityInExports oldPN newNameGhc- -- f' contains names imported from other modules;- -- d' contains the top level names declared in this module;- (f',d') <- hsFDsFromInside renamed- --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')- logm $ "renameTopLevelVarName:f=" ++ (show f)- logm $ "renameTopLevelVarName:d=" ++ (show d)- let newNameStr = nameToString newNameGhc- logm $ "renameTopLevelVarName:(newName,newNameStr)=" ++ (show (newName,newNameStr))- scopeClashNames <- inScopeNames newName- logm $ "renameTopLevelVarName:(f')=" ++ (showGhc f')- logm $ "renameTopLevelVarName:(scopeClashNames,intersection)=" ++ (showGhc (scopeClashNames,intersect scopeClashNames f'))- logm $ "renameTopLevelVarName:(oldPN,modName)=" ++ (showGhc (oldPN,modName))- if (nonEmptyList $ intersect scopeClashNames f')- -- if elem newNameStr f- then error ("The new name will cause ambiguous occurrence problem,"- ++" please select another new name or qualify the use of ' "- ++ newName ++ "' before renaming!\n") -- Another implementation option is to add the qualifier- -- to newName automatically.- else if existChecking && elem newNameStr (d \\ [nameToString oldPN]) --only check the declared names here.- then error ("Name '"++newName++"' already existed\n") --the same name has been declared in this module.- else if exportChecking && causeNameClashInExports oldPN newNameGhc modName renamed- then error ("The new name will cause conflicting exports, please select another new name!")- else if exportChecking && causeAmbiguity -- causeAmbiguityInExports oldPN newNameGhc {- inscps -} renamed- then error $"The new name will cause ambiguity in the exports of module "++ show modName ++ ", please select another name!"- else do -- get all of those declared names visible to oldPN at where oldPN is used.-- logm $ "renameTopLevelVarName:basic tests done"-- -- isInScopeUnqual <- isInScopeAndUnqualifiedGhc newName Nothing- isInScopeUnqual <- isInScopeAndUnqualifiedGhc newName (Just newNameGhc)- logm $ "renameTopLevelVarName:after isInScopeUnqual"- logm $ "renameTopLevelVarName:oldPN=" ++ showGhc oldPN- ds <- hsVisibleNames oldPN renamed- logm $ "renameTopLevelVarName:ds computed=" ++ (show ds)- -- '\\[pNtoName oldPN]' handles the case in which the new name is same as the old name - if existChecking && elem newName ((nub (ds `union` f)) \\[nameToString oldPN])- then error ("Name '"++newName++"' already existed, or rename '"- ++nameToString oldPN++ "' to '"++newName++- "' will change the program's semantics!\n")- else if exportChecking && isInScopeUnqual -- isInScopeAndUnqualifiedGhc newName Nothing- then do- logm $ "renameTopLevelVarName start..:should have qualified"- void $ renamePN oldPN newNameGhc True True renamed- logm $ "renameTopLevelVarName done:should have qualified"- -- drawTokenTreeDetailed "should be qualified" -- ++AZ++ debug- r' <- getRefactRenamed- return r'- else do- logm $ "renameTopLevelVarName start.."- void $ renamePN oldPN newNameGhc True False renamed- logm $ "renameTopLevelVarName done"- r' <- getRefactRenamed- return r'--{- original-renameTopLevelVarName oldPNT@(PNT oldPN _ _) newName modName inscps exps mod existChecking exportChecking- =do -- f' contains names imported from other modules;- -- d' contains the top level names declared in this module;- (f',d') <- hsFDsFromInside mod- --filter those qualified free variables in f'- let (f,d) = ((nub.map pNtoName.filter (not.isQualifiedPN)) f', (nub.map pNtoName) d')- if elem newName f- then error ("The new name will cause ambiguous occurrence problem,"- ++" please select another new name or qualify the use of ' "- ++ newName ++ "' before renaming!\n") -- Another implementation option is to add the qualifier- -- to newName automatically.- else if existChecking && elem newName (d \\ [pNtoName oldPN]) --only check the declared names here.- then error ("Name '"++newName++"' already existed\n") --the same name has been declared in this module.- else if exportChecking && causeNameClashInExports oldPN newName mod exps- then error ("The new name will cause conflicting exports, please select another new name!") - else if exportChecking && causeAmbiguityInExports oldPN newName inscps mod- then error $"The new name will cause ambiguity in the exports of module "++ show modName ++ ", please select another name!" - else do -- get all of those declared names visible to oldPN at where oldPN is used.- ds<-hsVisibleNames oldPN mod- -- '\\[pNtoName oldPN]' handles the case in which the new name is same as the old name - if existChecking && elem newName ((nub (ds `union` f)) \\[pNtoName oldPN])- then error ("Name '"++newName++"' already existed, or rename '"- ++pNtoName oldPN++ "' to '"++newName++- "' will change the program's semantics!\n")- else if exportChecking && isInScopeAndUnqualified newName inscps- then renamePN oldPN (Just modName) newName True mod- else renamePN oldPN Nothing newName True mod --}--{--renameLocalVarName oldPN newName t- =do (f,d) <- hsFDNamesFromInside t- if elem newName (d \\ [pNtoName oldPN]) --only check the declared names here.- then error ("Name '"++newName++"' already existed\n")- else do -- get all of those declared names visible to oldPN at where oldPN is used.- ds<-hsVisibleNames oldPN t- -- '\\[pNtoName oldPN]' handles the case in which the new name is same as the old name - if elem newName ((nub (ds `union` f)) \\[pNtoName oldPN])- then error ("Name '"++newName++"' already existed, or rename '"- ++pNtoName oldPN++ "' to '"++newName++- "' will change the program's semantics!\n")- else renamePN oldPN Nothing newName True t--}--renameInClientMod :: GHC.Name -> String -> GHC.Name -> TargetModule- -> RefactGhc [ApplyRefacResult]-renameInClientMod oldPN newName newNameGhc targetModule@(_,modSummary) = do- logm $ "renameInClientMod:(oldPN,newNameGhc,modSummary)=" ++ (showGhc (oldPN,newNameGhc,targetModule)) -- ++AZ++- void $ activateModule targetModule- {- ++AZ++ debug stuff -}- names <- ghandle handler (GHC.parseName $ nameToString oldPN)- nameInfo <- mapM GHC.lookupName names- logm $ "renameInClientMod: nameInfo=" ++ (showGhc nameInfo)- {- ++AZ++ debug stuff end -}-- renamed <- getRefactRenamed- let modName = GHC.moduleName $ GHC.ms_mod modSummary- -- causeNameClashInExports oldPN newName mod exps- -- logm $ "renameInClientMod:causeNameClashInExports oldPN modName renamed=" ++ (show $ causeNameClashInExports oldPN modName renamed)-- -- 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- -- 2. Is the new name module imported qualified, and so needs to- -- be qualified in the replacement, according to the import- isInScopeUnqual <- isInScopeAndUnqualifiedGhc (nameToString oldPN) Nothing- isInScopeUnqualNew <- isInScopeAndUnqualifiedGhc newName Nothing- logm $ "renameInClientMod: (isInScopeAndUnqual,isInScopeUnqualNew)=" ++ (show (isInScopeUnqual,isInScopeUnqualNew)) -- ++AZ++- -- if qualifier == [] --this name is not imported, but it maybe used in the import list- -- if isInScopeUnqual- if isInScopeUnqualNew- then- -- do (mod', ((ts',m),f))<-runStateT (renamePN oldPN Nothing newName True mod) ((ts,unmodified), fileName)- do- (refactoredMod,_) <- applyRefac (refactRenameSimple oldPN newName newNameGhc True) RSAlreadyLoaded- return [refactoredMod]- else- do if causeNameClashInExports oldPN newNameGhc modName renamed- then error $"The new name will cause conflicting exports in module "++ show newName ++ ", please select another name!"- else do- (refactoredMod,_) <- applyRefac (refactRenameComplex oldPN newName newNameGhc) RSAlreadyLoaded- -- TODO: implement rest of this- return [refactoredMod]- where- handler:: (GHC.GhcMonad m) => SomeException -> m [GHC.Name]- handler _ = return []-- refactRenameSimple :: GHC.Name -> String -> GHC.Name -> Bool -> RefactGhc ()- refactRenameSimple old newStr new useQual = do- qualifyTopLevelVar newStr- renamed <- getRefactRenamed- logm $ "renameInClientMod.refactRename:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++- void $ renamePN old new True useQual renamed- return ()-- refactRenameComplex :: GHC.Name -> String -> GHC.Name -> RefactGhc ()- refactRenameComplex old new newGhc = do- qualifyTopLevelVar new- worker old new newGhc-- qualifyTopLevelVar :: String -> RefactGhc ()- qualifyTopLevelVar new = do- toQualify <- inScopeNames new- logm $ "renameInClientMod.qualifyTopLevelVar:new:toQualify=" ++ (show new) ++ ":" ++ (showGhc toQualify)- -- renamed <- getRefactRenamed- -- renamePN new new True True renamed- mapM_ qualifyToplevelName toQualify- return ()-- worker :: GHC.Name -> String -> GHC.Name -> RefactGhc ()- worker oldPN' newName' newNameGhc' = do- logm $ "renameInClientMod.worker"- renamed <- getRefactRenamed- isInScopeUnqualNew <- isInScopeAndUnqualifiedGhc newName' Nothing- vs <- hsVisibleNames oldPN' renamed --Does this check names other than variable names?- if elem newName' ((nub vs) \\ [nameToString oldPN']) || isInScopeUnqualNew- then void $ renamePN oldPN' newNameGhc' True True renamed --rename to qualified Name- else void $ renamePN oldPN' newNameGhc' True False renamed -- do not qualify- return ()--{- original-renameInClientMod pnt@(PNT oldPN _ _) newName (m, fileName)- =do (inscps, exps ,mod ,ts) <-parseSourceFile fileName- let qualifier= hsQualifier pnt inscps- if qualifier == [] --this name is not imported, but it maybe used in the import list- then- do (mod', ((ts',m),f))<-runStateT (renamePN oldPN Nothing newName True mod) ((ts,unmodified), fileName) - return ((f,m),(ts',mod'))- else- do if causeNameClashInExports oldPN newName mod exps- then error $"The new name will cause conflicting exports in module "++ show m ++ ", please select another name!"- else do (mod',((ts',modified),f))<-runStateT (do mod'<-qualifyTopLevelVar newName inscps mod- worker oldPN newName mod' inscps (head qualifier))- ((ts,unmodified),fileName)- return ((f,modified), (ts',mod'))-- where- qualifyTopLevelVar name inscps t- = applyTP(full_tdTP(adhocTP idTP atPnt)) t- where- atPnt pnt@(PNT pn ty loc@(N (Just (SrcLoc fileName _ row col))))- | isTopLevelPNT pnt && pNTtoName pnt == name && canBeQualified pnt t - = do let qualifier = ghead "qualfyTopLevelVar" $ hsQualifier pnt inscps - renamePN pn (Just qualifier) name True pnt- atPnt x = return x-- worker oldPN newName mod inscps qual- = do vs<-hsVisibleNames oldPN mod --Does this check names other than variable names?- if elem newName ((nub vs) \\[pNtoName oldPN]) || isInScopeAndUnqualified newName inscps- then renamePN oldPN (Just qual) newName True mod --rename to qualified Name- else do renamePN oldPN Nothing newName True mod-------------------------------------------------}--causeAmbiguityInExports :: GHC.Name -> GHC.Name -> RefactGhc Bool-causeAmbiguityInExports old newName {- inscps -} = do- (GHC.L _ (GHC.HsModule _ exps _imps _decls _ _)) <- getRefactParsed- isInScopeUnqual <- isInScopeAndUnqualifiedGhc (nameToString old) Nothing- let usedUnqual = usedWithoutQualR newName exps- logm $ "causeAmbiguityInExports:(isInScopeUnqual,usedUnqual)" ++ (show (isInScopeUnqual,usedUnqual))- return (isInScopeUnqual && usedUnqual)--{--siblingFieldNames (PNT pn (FieldOf con typeInfo) loc)- = let cons=constructors typeInfo- orig1 = pNtoLoc pn- con=filter (\x->elem orig1 (map pNtoLoc (fromMaybe [] (conFields x)))) cons- in if con==[] then []- else (map pNtoName1 (fromMaybe [] (conFields (head con))))\\ [pNtoName pn]- where- pNtoLoc (PN _ orig1) = orig1- pNtoName1 (PN i _) = i--fieldNames (PNT pn (FieldOf con typeInfo) _)- =let cons=constructors typeInfo- in (nub. map pNtoName) $ concatMap (fromMaybe [].conFields) cons- where pNtoName (PN i _) = i--}--isValidNewName :: GHC.Name -> String -> String -> Bool-isValidNewName oldName rdrNameStr newName = res- where- doTest :: Bool -> Bool -> String -> Bool- doTest isCategory isRightType errStr =- if isCategory- then if isRightType- then True- else error errStr- else True-- tyconOk = doTest (GHC.isTyConName oldName)- (isConId newName)- "Invalid type constructor/class name!"-- -- classOk = if isClassName oldName && isConId newName- -- then True- -- else error "Invalid class name!"-- dataConOk = doTest (GHC.isDataConName oldName)- (isConId newName)- "Invalid data constructor name!"-- -- fieldOk = doTest (isFieldName oldName)- -- (isVarId newName)- -- "Invalid field name!"-- -- instanceOk = doTest (isInstanceName oldName)- -- (isVarId newName)- -- "Invalid class instance name!"-- tyVarOk = doTest (GHC.isTyVarName oldName)- (isVarId newName)- "Invalid type variable name!"-- oldName' = rdrNameStr- matchNamesOk- | {- GHC.isValName oldName || -} GHC.isVarName oldName- = if isVarId oldName' && not (isVarId newName)- then error "The new name should be an identifier!"- else if isOperator oldName' && not (isOperator newName)- then error "The new name should be an operator!"- else if (isVarId oldName' && isVarId newName) ||- (isOperator oldName' && isOperator newName)- then True- -- else error "Invalid new name!"- else error $ "Invalid new name!" ++ (show (oldName',newName,isVarId oldName',isVarId newName,isOperator oldName',isOperator newName))- | otherwise = True-- res = tyconOk && dataConOk {- && fieldOk && instanceOk -} &&- tyVarOk && matchNamesOk-- -- res = error $ "isValidNewName:(tyconOk,dataConOk`,fieldOk,instanceOk,tyVarOk,matchNamesOk)=" ++ (show (tyconOk,dataConOk,fieldOk,instanceOk,tyVarOk,matchNamesOk))--{- old-isValidNewName oldName newName- = case oldName of- (PNT (PN i (G _ _ _)) (Type _) _) ->if isConId newName then True- else error "Invalid type constructor name!" - (PNT _ (Class _ _) _) ->if isConId newName then True- else error "Invalid class name!"- (PNT _ (ConstrOf _ _) _) ->if isConId newName then True- else error "Invalid data constructor name!"-- (PNT _ (FieldOf _ _ ) _ ) ->if isVarId newName then True- else error "Invalid field name!" -- (PNT _ (MethodOf i _ _) _) ->if isVarId newName then True- else error "Invalid class instance name!"-- (PNT (PN i (S loc)) (Type _) _) ->if isVarId newName then True- else error "Invalid type variable name!"-- (PNT oldPN Value loc)- -> let oldName' = pNTtoName oldName- in if isVarId oldName' && not (isVarId newName)- then error "The new name should be an identifier!"- else if isOperator oldName' && not (isOperator newName)- then error "The new name should be an operator!"- else if (isVarId oldName' && isVarId newName) ||- (isOperator oldName' && isOperator newName)- then True- else error "Invalid new name!"---- |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::[HsDeclP]->PNT->([HsDeclP],[HsDeclP],[HsDeclP])-divideDecls ds pnt- = let (before,after)=break (\x->findPNT pnt x) ds- in if (after/=[])- then (before, [head after], tail after)- else (ds,[],[])---}-
− src/Language/Haskell/Refact/SwapArgs.hs
@@ -1,158 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-module Language.Haskell.Refact.SwapArgs (swapArgs) where---- import qualified Data.Generics.Schemes as SYB-import qualified Data.Generics.Aliases as SYB-import qualified GHC.SYB.Utils as SYB---- import qualified FastString as GHC-import qualified Name as GHC-import qualified GHC--- import qualified DynFlags as GHC--- import qualified Outputable as GHC--- import qualified MonadUtils as GHC--- import qualified RdrName as GHC--- import qualified OccName as GHC--import Language.Haskell.GhcMod-import Language.Haskell.Refact.Utils.Utils-import Language.Haskell.Refact.Utils.GhcUtils-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 Debug.Trace---- TODO: replace args with specific parameters-swapArgs :: RefactSettings -> Cradle -> [String] -> IO [FilePath]-swapArgs settings cradle args- = do let fileName = args!!0- row = (read (args!!1)::Int)- col = (read (args!!2)::Int)- runRefacSession settings cradle (comp fileName (row,col))---comp :: String -> SimpPos- -> RefactGhc [ApplyRefacResult]-comp fileName (row, col) = do- -- loadModuleGraphGhc maybeMainFile- -- modInfo@(_t, _tokList) <- getModuleGhc fileName- getModuleGhc fileName- renamed <- getRefactRenamed- -- parsed <- getRefactParsed- -- modInfo@((_, renamed, mod), toks) <- parseSourceFileGhc fileName- -- putStrLn $ showParsedModule mod- -- let pnt = locToPNT fileName (row, col) mod-- let name = locToName (row, col) renamed- -- error (SYB.showData SYB.Parser 0 name)-- case name of- -- (Just pn) -> do refactoredMod@(_, (_t, s)) <- applyRefac (doSwap pnt pn) (Just modInfo) fileName- (Just pn) -> do- -- let pnt = locToPNT (GHC.mkFastString fileName) (row, col) renamed- -- let pnt = gfromJust "SwapArgs.comp" $ locToRdrName (GHC.mkFastString fileName) (row, col) renamed-- (refactoredMod,_) <- applyRefac (doSwap pn) (RSFile fileName)- return [refactoredMod]- Nothing -> error "Incorrect identifier selected!"- --if isFunPNT pnt mod -- Add this back in ++ CMB +++- -- then do- -- rs <-if isExported pnt exps- -- then applyRefacToClientMods (doSwap pnt) fileName- -- else return []- -- writeRefactoredFiles False (r:rs)- -- else error "\nInvalid cursor position!"-- -- putStrLn (showToks t)- -- writeRefactoredFiles False [refactoredMod]- -- putStrLn ("here" ++ (SYB.showData SYB.Parser 0 mod)) -- $ show [fileName, beginPos, endPos]- -- putStrLn "Completd"---doSwap ::- (GHC.Located GHC.Name) -> RefactGhc () -- m GHC.ParsedSource-doSwap name = do- -- inscopes <- getRefactInscopes- renamed <- getRefactRenamed- -- parsed <- getRefactParsed- reallyDoSwap name renamed--reallyDoSwap :: (GHC.Located GHC.Name) -> GHC.RenamedSource -> RefactGhc ()-reallyDoSwap (GHC.L _s n1) renamed = do- renamed' <- everywhereMStaged SYB.Renamer (SYB.mkM inMod `SYB.extM` inExp `SYB.extM` inType) renamed -- this needs to be bottom up +++ CMB +++- putRefactRenamed renamed'- return ()-- where- -- 1. The definition is at top level...- inMod (_func@(GHC.FunBind (GHC.L x n2) infixity (GHC.MatchGroup matches p) a locals tick)::(GHC.HsBindLR GHC.Name GHC.Name ))- | GHC.nameUnique n1 == GHC.nameUnique n2- = do logm ("inMatch>" ++ SYB.showData SYB.Parser 0 (GHC.L x n2) ++ "<")- newMatches <- updateMatches matches- return (GHC.FunBind (GHC.L x n2) infixity (GHC.MatchGroup newMatches p) a locals tick)- inMod func = return func-- -- 2. All call sites of the function...- inExp expr@((GHC.L _x (GHC.HsApp (GHC.L _y (GHC.HsApp e e1)) e2))::GHC.Located (GHC.HsExpr GHC.Name))- | GHC.nameUnique (expToName e) == GHC.nameUnique n1- = update e2 e1 =<< update e1 e2 expr- inExp e = return e-- -- 3. Type signature...- inType (GHC.L x (GHC.TypeSig [GHC.L x2 name] types)::GHC.LSig GHC.Name)- | GHC.nameUnique name == GHC.nameUnique n1- = do let (t1:t2:ts) = tyFunToList types- t1' <- update t1 t2 t1- t2' <- update t2 t1 t2- return (GHC.L x (GHC.TypeSig [GHC.L x2 name] (tyListToFun (t1':t2':ts))))-- inType (GHC.L _x (GHC.TypeSig (n:ns) _types)::GHC.LSig GHC.Name)- | GHC.nameUnique n1 `elem` (map (\(GHC.L _ n') -> GHC.nameUnique n') (n:ns))- = error "Error in swapping arguments in type signature: signauture bound to muliple entities!"-- inType ty = return ty-- tyFunToList (GHC.L _ (GHC.HsForAllTy _ _ _ (GHC.L _ (GHC.HsFunTy t1 t2)))) = t1 : (tyFunToList t2)- tyFunToList (GHC.L _ (GHC.HsFunTy t1 t2)) = t1 : (tyFunToList t2)- tyFunToList t = [t]-- tyListToFun [t1] = t1- tyListToFun (t1:ts) = GHC.noLoc (GHC.HsFunTy t1 (tyListToFun ts))-- updateMatches [] = return []- updateMatches ((GHC.L x (GHC.Match pats nothing rhs)::GHC.Located (GHC.Match GHC.Name)):matches)- = case pats of- (p1:p2:ps) -> do p1' <- update p1 p2 p1- p2' <- update p2 p1 p2- matches' <- updateMatches matches- return ((GHC.L x (GHC.Match (p1':p2':ps) nothing rhs)):matches')- [p] -> return [GHC.L x (GHC.Match [p] nothing rhs)]- [] -> return [GHC.L x (GHC.Match [] nothing rhs)]---{- inMatch i@(GHC.L x m@(GHC.Match (p1:p2:ps) nothing rhs)::GHC.Located (GHC.Match GHC.RdrName) )- -- = error (SYB.showData SYB.Parser 0 pnt)- | GHC.srcSpanStart s == GHC.srcSpanStart x- = do logm ("inMatch>" ++ SYB.showData SYB.Parser 0 (p1:p2:ps) ++ "<")- p1' <- update p1 p2 p1 --pats- p2' <- update p2 p1 p2- return (GHC.L x (GHC.Match (p1':p2':ps) nothing rhs))- inMatch i = return i-- inExp exp@((GHC.L x (GHC.HsApp (GHC.L y (GHC.HsApp e e1)) e2))::GHC.Located (GHC.HsExpr GHC.RdrName))- {- | (fromJust $ expToName e) == (GHC.L s (GHC.nameRdrName n))-} -- = error (SYB.showData SYB.Parser 0 (GHC.L s (GHC.nameRdrName n))) -- update e2 e1 =<< update e1 e2 exp- -- inExp e = return e -}- -- In the call-site.- {- inExp exp@((Exp (HsApp (Exp (HsApp e e1)) e2))::HsExpP)- | expToPNT e == pnt- = update e2 e1 =<< update e1 e2 exp- inExp e = return e -}--- pats nothing rhss ds)---- expToPNT x = undefined---- prettyprint :: (GHC.Outputable a) => a -> String--- prettyprint x = GHC.showSDoc $ GHC.ppr x-
src/Language/Haskell/Refact/Utils/DualTree.hs view
@@ -234,8 +234,6 @@ go ci ((Line r c _o _f _s str):ls') = do newPos r (c+ci) addString (GHC.showRichTokenStream str)- -- addString (GHC.showRichTokenStream $ reAlignMarked str)- -- addString (GHC.showRichTokenStream $ reAlignMarked str) go ci ls' -- State operations ----------------@@ -418,42 +416,6 @@ {- --Should be 7 7 0 on second line-- (Up- (Span (5, 7) (7, 19)) ANone- [(Line 5 7 0 SOriginal OGroup \"let park = 3\"),- (Line 7 5 0 SOriginal OGroup \"let expr = 2\")]- []),--combining (where "park" was originally "parsed" i.e. 2 letters shorter-- [((Up- (Span (5, 7) (5, 21)) ANone- [(Line 5 7 0 SOriginal OGroup \"let park = 3\")]- []),-- ((Up- (Span (7, 7) (7, 19)) ANone- [(Line 7 7 0 SOriginal OGroup \"let expr = 2\")]- []),------------------------------------------------------------------------ ((((36,23),(41,25)),ITblockComment \" ++AZ++ : hsBinds does not re
src/Language/Haskell/Refact/Utils/Layout.hs view
@@ -599,7 +599,7 @@ )] #endif -allocLTyClDecl x _ = error $ "allocLTyClDecl:unknown value:" ++ showGhc x+-- allocLTyClDecl x _ = error $ "allocLTyClDecl:unknown value:" ++ showGhc x -- --------------------------------------------------------------------- @@ -1186,6 +1186,13 @@ (s1,toksBinds,toks1) = splitToksIncComments (start,end) toks + -- s1 will contain the 'where' token, split into prior comments,+ -- the token, and post comments so that if the 'where' token must+ -- be removed the comments will stay+ (s1p,s1r) = break isWhereOrLet s1+ (w,s1a) = break (not.isWhereOrLet) s1r+ whereLayout = makeLeafFromToks s1p ++ makeLeafFromToks w ++ makeLeafFromToks s1a+ firstBindTok = ghead "allocLocalBinds" $ dropWhile isWhiteSpaceOrIgnored toksBinds p1 = (tokenRow firstBindTok,tokenCol firstBindTok) (ro,co) = case (filter isWhereOrLet s1) of@@ -1203,7 +1210,8 @@ [] -> [] bs -> [placeAbove so p1 (rt,ct) bs] - r = strip $ (makeLeafFromToks s1) ++ bindsLayout ++ (makeLeafFromToks toks1)+ -- r = strip $ (makeLeafFromToks s1) ++ bindsLayout ++ (makeLeafFromToks toks1)+ r = strip $ whereLayout ++ bindsLayout ++ (makeLeafFromToks toks1) allocLocalBinds (GHC.HsValBinds (GHC.ValBindsOut _ _)) _ = error "allocLocalBinds (GHC.HsValBinds (GHC.ValBindsOut..)) should not be required"
src/Language/Haskell/Refact/Utils/LayoutTypes.hs view
@@ -23,14 +23,6 @@ -- --------------------------------------------------------------------- -{--data LayoutTree a = Group GHC.SrcSpan Layout [LayoutTree a] -- Same as current- -- TokenUtils internal tree node- | Leaf GHC.SrcSpan Layout [PosToken] -- Same as current- -- TokenUtils leaf node- deriving (Foldable,Traversable,Functor)--}- data Label = Label GHC.SrcSpan Layout [PosToken]
src/Language/Haskell/Refact/Utils/LocUtils.hs view
@@ -52,8 +52,7 @@ -} , tokenise , basicTokenise- , lexStringToRichTokens- , prettyprint -- , prettyprintGhc+ -- , prettyprint -- , prettyprintGhc , prettyprintPatList , groupTokensByLine , toksOnSameLine@@ -112,19 +111,10 @@ ) where --- import qualified BasicTypes as GHC--- import qualified DynFlags as GHC import qualified FastString as GHC import qualified GHC as GHC--- import qualified GHC.Paths as GHC--- import qualified HsSyn as GHC import qualified Lexer as GHC--- import qualified Module as GHC--- import qualified MonadUtils as GHC--- import qualified Outputable as GHC--- import qualified RdrName as GHC import qualified SrcLoc as GHC--- import qualified StringBuffer as GHC import qualified Data.Generics as SYB import qualified GHC.SYB.Utils as SYB@@ -136,7 +126,6 @@ import Data.Maybe import Data.List--- import Debug.Trace -- --------------------------------------------------------------------- @@ -157,15 +146,7 @@ --- some default values---- simpPos0 :: (Int,Int) simpPos0 = (0,0)-{--extractComments :: (SimpPos, SimpPos) -> [PosToken] -> [PosToken]-extractComments ((startPosl, startPosr), endPos) toks- = let (toks1, toks21, toks22) = splitToks ((startPosl, startPosr), endPos) toks- in toks1 ---------------------------------------------------}- nullSrcSpan :: GHC.SrcSpan nullSrcSpan = GHC.UnhelpfulSpan $ GHC.mkFastString "HaRe nullSrcSpan" @@ -277,7 +258,6 @@ -- |get the last non-ignored token in a token stream. lastNonSpaceToken::[PosToken] -> PosToken--- lastNonSpaceToken toks=case dropWhile isWhiteSpace (reverse toks) of lastNonSpaceToken toks=case dropWhile isWhiteSpaceOrIgnored (reverse toks) of [] -> defaultToken l -> ghead "lastNonSpaceToken" l@@ -292,59 +272,15 @@ -- | Remove the extra preceding empty lines. compressPreNewLns::[PosToken] -> [PosToken] compressPreNewLns toks = toks-{- ++AZ++: is this still needed?-compressPreNewLns toks= let (toks1, toks2) = break (not.(\t->isNewLn t || isWhiteSpace t)) toks- groupedToks = groupTokensByLine toks1- in if length groupedToks>1 then (last groupedToks)++toks2- else toks--} - -- |Remove the following extra empty lines. compressEndNewLns::[PosToken]->[PosToken] compressEndNewLns toks = toks-{--prettyprintPatList beginWithSpace t- = replaceTabBySpaces $ if beginWithSpace then format1 t else format2 t- where- format1 t = foldl (\x y -> x++ " "++(render.ppi) y) "" t - format2 [] = ""- format2 [p] = (render.ppi) p- format2 (p:ps) = (render.ppi) p ++" " ++ format2 ps--prettyprint = replaceTabBySpaces.render.ppi--prettyprintGuardsAlt = replaceTabBySpaces.render.(ppRhs rarrow)-----Replace Tab by white spaces. (1 Tab=8 white spaces)-replaceTabBySpaces::String->String-replaceTabBySpaces []=[]-replaceTabBySpaces (s:ss)- =if s=='\t' then replicate 8 ' ' ++replaceTabBySpaces ss- else s:replaceTabBySpaces ss---}--{---- |Compose a new token using the given arguments.-mkToken::GHC.Token -> SimpPos -> String -> PosToken-mkToken t (row,col) c = ((GHC.L l t),c)- where- filename = (GHC.mkFastString "f")- l = GHC.mkSrcSpan (GHC.mkSrcLoc filename row col) (GHC.mkSrcLoc filename row (col + (length c) ))---mkZeroToken :: PosToken-mkZeroToken = mkToken GHC.ITsemi (0,0) ""--} ---Restriction: the refactorer should not modify refactorer-modified/created tokens. defaultToken :: PosToken defaultToken = (GHC.noLoc (GHC.ITlineComment "defaultToken"), "defaultToken") --- defaultToken = (Whitespace, (pos0," "))- -- --------------------------------------------------------------------- prettyprintPatList :: (t -> String) -> Bool -> [t] -> String@@ -406,70 +342,7 @@ addLocInfo :: (GHC.LHsBind GHC.Name,[PosToken]) -> RefactGhc (GHC.LHsBind GHC.Name,[PosToken]) addLocInfo (decl, toks) = return (decl, toks)- -- = error "undefined addLocInfo"-{-++AZ++ Need to see it this is actually needed....- -- = runStateT (applyTP (full_tdTP (idTP `adhocTP` inPnt- -- `adhocTP` inSN)) decl) toks- = everywhereMStaged SYB.Renamer (SYB.mkM inPnt `SYB.extM` inSN)- where- inPnt (PNT pname ty (N (Just loc)))- = do loc' <- findLoc (pNtoName pname)- return (PNT pname ty (N (Just loc')))- inPnt x = return x - inSN (SN (PlainModule modName) (SrcLoc _ _ row col))- = do loc' <- findLoc modName- return (SN (PlainModule modName) loc')- inSN x = return x-- pNtoName (PN (UnQual i) _)=i- pNtoName (PN (Qual (PlainModule modName) i) _) = modName++"."++i- pNtoName (PN (Qual (MainModule _) i) _) = "Main."++i-- findLoc name- = do let name' = if name =="Prelude.[]" || name == "[]" then "["- else if name=="Prelude.(,)" || name == "(,)" || name == "()" then "("- else name ----Check this again.- toks' = dropWhile (\t->tokenCon t /= name') toks- (row, col) =if toks'==[] then error ("HaRe: Error in addLocInfo while looking for" ++ name' ++ " !")- else tokenPos $ ghead "findLoc" toks'- return (SrcLoc "unknown" 0 row col)-++AZ++ end -}---{- ++original++---Should add cases for literals.-addLocInfo (decl, toks)- = runStateT (applyTP (full_tdTP (idTP `adhocTP` inPnt- `adhocTP` inSN)) decl) toks- where- inPnt (PNT pname ty (N (Just loc)))- = do loc' <- findLoc (pNtoName pname)- return (PNT pname ty (N (Just loc')))- inPnt x = return x-- inSN (SN (PlainModule modName) (SrcLoc _ _ row col))- = do loc' <- findLoc modName- return (SN (PlainModule modName) loc')- inSN x = return x--- pNtoName (PN (UnQual i) _)=i- pNtoName (PN (Qual (PlainModule modName) i) _) = modName++"."++i- pNtoName (PN (Qual (MainModule _) i) _) = "Main."++i- findLoc name- = do let name' = if name =="Prelude.[]" || name == "[]" then "["- else if name=="Prelude.(,)" || name == "(,)" || name == "()" then "("- else name ----Check this again.- toks' = dropWhile (\t->tokenCon t /= name') toks- (row, col) =if toks'==[] then error ("HaRe: Error in addLocInfo while looking for" ++ name' ++ " !")- else tokenPos $ ghead "findLoc" toks'- return (SrcLoc "unknown" 0 row col)----++original end -}- -- --------------------------------------------------------------------- -- |Given a token stream covering multi-lines, calculate the length of the last line@@ -541,50 +414,6 @@ -- --------------------------------------------------------------------- --{--srcLocs::(Data t)=> t->[SimpPos]-srcLocs t =(nub.srcLocs') t \\ [simpPos0]- where srcLocs' = everywhere (++) ([] `mkQ`--- srcLocs'=runIdentity.(applyTU (full_tdTU (constTU []- `adhocTU` pnt- `adhocTU` sn- `adhocTU` literalInExp- `adhocTU` literalInPat)))-- pnt (PNT pname _ (N (Just (SrcLoc _ _ row col))))=return [(row,col)]- pnt _=return []-- sn (SN (PlainModule modName) (SrcLoc _ _ row col))- = return [(row, col)]- sn _ = return []-- literalInExp ((Exp (HsLit (SrcLoc _ _ row col) _))::HsExpP) = return [(row,col)]- literalInExp (Exp _) =return []-- literalInPat ((Pat (HsPLit (SrcLoc _ _ row col) _))::HsPatP) = return [(row,col)]- literalInPat (Pat (HsPNeg (SrcLoc _ _ row col) _)) = return [(row,col)]- literalInPat _ =return []--}----{--{- Delete an syntax phrase from the token stream, this function (instead of the following one)- should be the interface function for deleting tokens.--}--- deleteFromToks::( (MonadState (([PosToken], Bool), t1) m), StartEndLoc t,Printable t,Term t)=>t->m ()-deleteFromToks t getLocFun- =do ((toks,_),others)<-get- let (startPos,endPos)=getLocFun toks t- toks'=deleteToks toks startPos endPos- put ((toks',modified),others)--}---- ---------------------------------------------------------------------- -- |Delete a sequence of tokens specified by the start position and -- end position from the token stream, then adjust the remaining token -- stream to preserve layout@@ -627,94 +456,13 @@ in if (emptyList ts) then ts -- ++AZ++ error "Sorry, HaRe failed to finish this refactoring. deleteToks" else ts -{- ++ original ++-{-Delete a sequence of tokens specified by the start position and end position from the token stream,- then adjust the remaining token stream to preserve layout-}-deleteToks::[PosToken]->SimpPos->SimpPos->[PosToken]-deleteToks toks startPos@(startRow, startCol) endPos@(endRow, endCol)- = case after of- (_:_) -> let nextPos =tokenPos $ ghead "deleteToks1" after- oldOffset = getOffset toks nextPos- newOffset = getOffset (toks1++before++after) nextPos- in toks1++before++adjustLayout (after++toks22) oldOffset newOffset- _ -> if toks22 == []- then toks1++before- else let toks22'=let nextOffset = getOffset toks (tokenPos (ghead "deleteToks2" toks22))- in if isMultiLineComment (lastNonSpaceToken toks21)- then whiteSpaceTokens (-1111, 0) (nextOffset-1) ++ toks22- else toks22- in if endsWithNewLn (last (toks1++before)) || startsWithNewLn (ghead "deleteToks3" toks22')- then toks1++before++toks22'- --avoiding layout adjustment by adding a `\n', sometimes may produce extra lines.- else toks1++before++[newLnToken]++toks22'- -- else toks1 ++ before ++ toks22'- where-- (toks1, toks2) = let (ts1, ts2) = break (\t->tokenPos t == startPos) toks- (ts11, ts12) = break hasNewLn (reverse ts1)- in (reverse ts12, reverse ts11 ++ ts2)- (toks21, toks22)=let (ts1, ts2) = break (\t -> tokenPos t == endPos) toks2- (ts11, ts12) = break hasNewLn ts2- in (ts1++ts11++if ts12==[] then [] else [ghead "deleteToks4" ts12], if ts12==[] then [] else gtail "deleteToks5" ts12)-- -- tokens before the tokens to be deleted at the same line- before = takeWhile (\t->tokenPos t/=startPos) toks21-- -- tokens after the tokens to be deleted at the same line.- after = let t= dropWhile (\t->tokenPos t /=endPos) toks21- in if t == [] then error "Sorry, HaRe failed to finish this refactoring. DeleteToks"- else gtail "deleteToks6" t---}- -- --------------------------------------------------------------------- -- | Adjust the layout to compensate the change in the token stream. adjustLayout:: [PosToken] -> Int -> Int -> [PosToken] adjustLayout [] _ _ = [] adjustLayout toks _oldOffset _newOffset = toks -- ++AZ++ temporary while plumbing the rest-{- ++AZ++ TODO: restore and fix this-adjustLayout toks oldOffset newOffset- | oldOffset == newOffset = toks -adjustLayout toks oldOffset newOffset- = case layoutRuleApplies of- True -> let (ts:ts') = groupTokensByLine toks- in ts ++ addRmSpaces (newOffset-oldOffset) oldOffset ts' -- THIS IS PROBLEMETIC.- _ -> toks- where-- layoutRuleApplies- = let ts = dropWhile (\t-> (not.elem (tokenCon t)) keyWords)- -- $ filter notWhite- $ takeWhile (not.hasNewLn) toks -- ++AZ++ TODO: pretty sure hasNewLn will not give expected result, no whitespace toks in GHC- in case ts of- (_: t: _) -> tokenCon t /= "{"- _ -> False-- keyWords = ["where","let","do","of"]-- addRmSpaces n col [] = []- addRmSpaces n col toks@(ts:ts')- =case find notWhite ts of- Just t -> if length (concatMap tokenCon ts1) >= col- then (addRmSpaces' n ts) ++ addRmSpaces n col ts'- else concat toks- _ -> ts ++ addRmSpaces n col ts'- where- (ts1, ts2) = break notWhite ts-- addRmSpaces' 0 ts = ts- addRmSpaces' _ [] = []- addRmSpaces' n ts@(t:ts')- = case n >0 of- True -> whiteSpaceTokens (tokenRow t,0) n ++ ts -- CHECK THIS.- _ -> if isWhiteSpace t- then addRmSpaces' (n+1) ts'- else error $ "Layout adjusting failed at line:"- ++ show (tokenRow t)++ "."-++AZ++ -}- -- | remove at most n white space tokens from the beginning of ts doRmWhites::Int -> [PosToken] -> [PosToken] doRmWhites 0 ts = ts@@ -732,12 +480,6 @@ -- ++AZ++ : not sure if this is still needed whiteSpaceTokens :: (Int,Int) -> Int -> [PosToken] whiteSpaceTokens (_row, _col) _n = []-{--whiteSpaceTokens (row, col) n- = if n<=0- then []- else (mkToken Whitespace (row,col) " "):whiteSpaceTokens (row,col+1) (n-1)--} -- --------------------------------------------------------------------- @@ -767,56 +509,6 @@ -- --------------------------------------------------------------------- -{----given an AST phrase, 'startEndLoc' gets its start and end position in the program source.--- TODO: ++AZ++ get rid of this class-class StartEndLoc t where- startEndLoc :: [PosToken]-> t ->(SimpPos,SimpPos)---instance StartEndLoc (GHC.HsExpr GHC.RdrName) where- -- TODO: do this properly- startEndLoc toks e =- case e of- GHC.HsVar id -> ((0,0),(0,0))--instance StartEndLoc (GHC.Pat GHC.RdrName) where-- startEndLoc toks p =- case p of- GHC.VarPat id -> ((0,0),(0,0))--instance StartEndLoc [GHC.Pat GHC.RdrName] where-- startEndLoc toks ps = ((0,0),(0,0))--}---- ----------------------------------------------------------------------{---- | Get the start and end location of the given AST phrase in the--- original source-getStartEndLoc::(SYB.Data t)=> t -> (SimpPos,SimpPos)-getStartEndLoc t- = let (startPos',endPos') = (simpPos0,simpPos0)- locs = srcLocs t- (startPos,endPos) = (if startPos' == simpPos0 && locs /=[] then ghead "getStartEndLoc" locs- else startPos',- if endPos' == simpPos0 && locs /= [] then glast "getStartEndLoc" locs- else endPos')- in (startPos, endPos)-{--getStartEndLoc t- = let (startPos',endPos') = startEndLocGhc t- locs = srcLocs t- (startPos,endPos) = (if startPos' == simpPos0 && locs /=[] then ghead "getStartEndLoc" locs- else startPos',- if endPos' == simpPos0 && locs /= [] then glast "getStartEndLoc" locs- else endPos')- in (startPos, endPos)--}--}--- ---------------------------------------------------------------------- getBiggestStartEndLoc :: (SYB.Data t) => t -> (SimpPos,SimpPos) getBiggestStartEndLoc t = (start,end) where@@ -869,22 +561,6 @@ -- --------------------------------------------------------------------- -{--getStartEndLoc2::(SYB.Data t)=>[PosToken]->[GHC.GenLocated GHC.SrcSpan t] ->(SimpPos,SimpPos)-getStartEndLoc2 toks ts- = let (startPos',_) = startEndLocGhc (ghead "getStartEndLoc2" ts)- (_ , endPos') = startEndLocGhc (glast "getStartEndLoc2" ts)- locs = srcLocs ts- (startPos,endPos) = (if startPos' == simpPos0 && locs /=[] then ghead "getStartEndLoc" locs- else startPos',- if endPos' == simpPos0 && locs /= [] then glast "getStartEndLoc" locs- else endPos')- in (startPos, endPos)--}---- ----------------------------------------------------------------------- -- |Extend the given position backwards to the front of the file while -- the supplied condition holds extendBackwards :: [PosToken] -> (SimpPos ,SimpPos) -> (PosToken -> Bool)@@ -924,21 +600,7 @@ (_,endLocIncComments) = startEndLocIncComments toks t in (startLoc, endLocIncComments) -{--adjustOffset::Int->[PosToken]->Bool->[PosToken]-adjustOffset offset [] _ = []-adjustOffset offset toks firstLineIncluded- = let groupedToks = groupBy (\x y->tokenRow x==tokenRow y) toks --groupedToks/=[], no problem with 'head'- --if firstLineIncluded is False, the offset of the first line won't be ajusted.- in if offset>=0 then if firstLineIncluded- then concatMap (doAddWhites offset) groupedToks- else ghead "adjustOffset" groupedToks ++ concatMap (doAddWhites offset) (tail groupedToks)- else if firstLineIncluded- then concatMap (doRmWhites (-offset)) groupedToks- else ghead "adjustOffset" groupedToks ++ concatMap (doRmWhites (-offset)) (tail groupedToks) --}- -- --------------------------------------------------------------------- -- Returned from TokenUtils @@ -1103,8 +765,6 @@ if (emptyList middle') then ((0,0),(0,0)) else ((tokenPos $ ghead "startEndLocIncComments 4" middle'),(tokenPosEnd $ last middle'))- -- else error $ "startEndLocIncComments: (prevLine,firstLine) reverse leadr =" ++ (show (prevLine,firstLine)) ++ "," ++ (showToks $ reverse leadr)- -- else error $ "startEndLocIncComments: (prevLine,firstLine) reverse leadinr =" ++ (show (prevLine,firstLine)) ++ "," ++ (showToks $ reverse leadinr) ++ (show (_nonleadComments,leadComments')) -- --------------------------------------------------------------------- @@ -1112,8 +772,6 @@ -- and those that belong with the endLine divideComments :: Int -> Int -> [PosToken] -> ([PosToken],[PosToken]) divideComments startLine endLine toks = (first,second)- -- error $ "divideComments:groupGaps=" ++ (show groupGaps)- -- error $ "divideComments:(firsts,seconds)=" ++ (show (firsts,seconds)) where groups = groupBy groupByAdjacent toks groupLines = map (\ts -> ((tokenRow $ ghead "divideComments" ts,tokenRow $ glast "divideComments" ts),ts)) groups@@ -1232,9 +890,6 @@ -- --------------------------------------------------------------------- ---- ---------------------------------------------------------------------- -- | Get the first SrcSpan found, in top down traversal getSrcSpan::(SYB.Data t) => t -> Maybe GHC.SrcSpan getSrcSpan t = res t@@ -1346,18 +1001,6 @@ toksOnSameLine :: PosToken -> PosToken -> Bool toksOnSameLine t1 t2 = tokenRow t1 == tokenRow t2--{--groupTokensByLine :: [PosToken] -> [[PosToken]]-groupTokensByLine [] = []-groupTokensByLine (xs) =- let x = head xs- (xs', xs'') = break (\x' -> tokenRow x /= tokenRow x') xs- in case xs'' of- [] -> [xs']- _ -> (xs'++ [ghead "groupTokensByLine" xs''])- : groupTokensByLine (gtail "groupTokensByLine" xs'')--} -- ---------------------------------------------------------------------
src/Language/Haskell/Refact/Utils/Monad.hs view
@@ -5,7 +5,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Haskell.Refact.Utils.Monad- ( ParseResult+ (+ ParseResult , VerboseLevel(..) , RefactSettings(..) , RefactState(..)@@ -15,7 +16,7 @@ , RefactFlags(..) , StateStorage(..) - -- GHC monad stuff+ -- The GHC Monad , RefactGhc , runRefactGhc , getRefacSettings
src/Language/Haskell/Refact/Utils/MonadFunctions.hs view
@@ -115,19 +115,7 @@ logm $ "fetchToksFinal (not showing toks)" return toks --- TODO: get rid of this, superseded by dualtree-{- -- |fetch the final tokens in Ppr format-fetchPprFinal :: RefactGhc [Ppr]-fetchPprFinal = do- Just tm <- gets rsModule- let pprVal = retrieveTokensPpr $ (tkCache $ rsTokenCache tm) Map.! mainTid- -- logm $ "fetchToks" ++ (showToks toks)- logm $ "fetchPprFinal (not showing ppr)"- return pprVal--}---- |fetch the final tokens in Ppr format fetchLinesFinal :: RefactGhc [Line] fetchLinesFinal = do Just tm <- gets rsModule@@ -401,34 +389,6 @@ -- drawTokenTree "indentDeclToks result" return t' --- =====================================================================--- Layout Tree stuff--- ----------------------------------------------------------------------{--getLayoutForSpan :: GHC.SrcSpan -> RefactGhc LayoutTree-getLayoutForSpan sspan = do- st <- get- let Just tm = rsModule st- let lay = getLayoutFor sspan (rsTokenLayout tm)- logm $ "getLayoutForSpan " ++ (showGhc sspan) ++ ":" ++ (showGhc lay)- return lay--}-{--putDeclLayoutAfterSpan :: (SYB.Data t)- => GHC.SrcSpan -> GHC.Located t -> Positioning -> LayoutTree- -> RefactGhc (GHC.Located t)-putDeclLayoutAfterSpan oldSpan t pos lay = do- logm $ "putDeclLayoutAfterSpan " ++ (showGhc oldSpan) ++ ":" ++ (show (showSrcSpanF oldSpan,pos,lay))- st <- get- let Just tm = rsModule st- let (TL layoutTree) = rsTokenLayout tm- let (tl',_newSpan, t') = addDeclLayoutAfterSrcSpan layoutTree oldSpan pos lay t- let rsModule' = Just (tm {rsTokenLayout = tl', rsStreamModified = True})- put $ st { rsModule = rsModule' }- return t'--}---- ===================================================================== getTypecheckedModule :: RefactGhc GHC.TypecheckedModule getTypecheckedModule = do
− src/Language/Haskell/Refact/Utils/RenamedSourceUtils.hs
@@ -1,33 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--- |------ This module contains utilities that operate on the GHC RenamedSource----module Language.Haskell.Refact.Utils.RenamedSourceUtils- (- getFreeVariables- ) where---- Modules from GHC-import qualified GHC as GHC-import qualified NameSet as GHC--import qualified Data.Generics as SYB-import qualified GHC.SYB.Utils as SYB---- -----------------------------------------------------------------------getFreeVariables :: (SYB.Data t, SYB.Typeable t) => t -> [GHC.NameSet]-getFreeVariables t = res- where- res = SYB.everythingStaged SYB.Renamer (++) []- ([] `SYB.mkQ` bind) t-- -- bind :: (SYB.Data a, SYB.Typeable a) => a -> [GHC.NameSet]- bind ((GHC.FunBind _ _ _ _ fvs _)::(GHC.HsBindLR GHC.Name GHC.Name)) = [fvs]- bind ((GHC.PatBind _ _ _ fvs _) ::(GHC.HsBindLR GHC.Name GHC.Name)) = [fvs]- bind _ = []----
src/Language/Haskell/Refact/Utils/TokenUtils.hs view
@@ -571,25 +571,7 @@ treeIdFromForestSpan ((ForestLine _ tr _ _,_),(ForestLine _ _ _ _,_)) = TId tr -- ----------------------------------------------------------------------{--data Module = Module- { mTypecheckedMod :: GHC.TypecheckedModule- , mOrigTokenStream :: [PosToken] -- ^Original Token stream for the current module- , mTokenCache :: Tree Entry -- ^Any modifications to the token stream.- } -initModule :: GHC.TypecheckedModule -> [PosToken] -> Module-initModule typeChecked tokens- = Module- { mTypecheckedMod = typeChecked- , mOrigTokenStream = tokens- , mTokenCache = mkTreeFromTokens tokens- }--}---- Initially work with non-monadic code, can build it into the--- RefactGhc monad later- initTokenCache :: [PosToken] -> TokenCache initTokenCache toks = TK (Map.fromList [((TId 0),(mkTreeFromTokens toks))]) (TId 0) @@ -694,9 +676,6 @@ -- the given AST to the most recent stash entry syncAstToLatestCache :: (SYB.Data t) => TokenCache -> GHC.Located t -> GHC.Located t syncAstToLatestCache tk t = t'- -- = error $ "syncAstToLatestCache:pos=" ++ (show pos)- -- = error $ "syncAstToLatestCache:fs=" ++ (show fs)- -- = error $ "syncAstToLatestCache:sspan=" ++ (show sspan) where mainForest = (tkCache tk) Map.! mainTid forest@(Node (Entry fspan _ _) _) = (tkCache tk) Map.! (tkLastTreeId tk)@@ -712,8 +691,8 @@ getTokensFor :: Bool -> Tree Entry -> GHC.SrcSpan -> (Tree Entry,[PosToken]) getTokensFor checkInvariant forest sspan = (forest'', tokens) where- forest' = if (not checkInvariant) || invariantOk forest -- short- -- circuit eval+ forest' = if (not checkInvariant) || invariantOk forest+ -- short circuit eval then forest else error $ "getTokensFor:invariant failed:" ++ (show $ invariant forest) (forest'',tree) = getSrcSpanFor forest' (srcSpanToForestSpan sspan)@@ -799,9 +778,6 @@ (forest',tree@(Node (Entry _s _ _) _)) = getSrcSpanFor forest (srcSpanToForestSpan sspan) prevToks = retrieveTokensInterim tree - -- endComments = reverse $ takeWhile isWhiteSpace $ reverse toks- -- startComments = takeWhile isWhiteSpace $ toks- endComments = reverse $ takeWhile isWhiteSpaceOrIgnored $ reverse toks startComments = takeWhile isWhiteSpaceOrIgnored $ toks @@ -815,11 +791,9 @@ else -- Must reuse any pre-existing start or end comments, and -- resync the tokens across all three. let- -- origEndComments = reverse $ takeWhile isWhiteSpace $ reverse prevToks- -- origStartComments = takeWhile isWhiteSpace $ prevToks origEndComments = reverse $ takeWhile isWhiteSpaceOrIgnored $ reverse prevToks origStartComments = takeWhile isWhiteSpaceOrIgnored $ prevToks- -- core = reIndentToks (PlaceAbsolute (tokenRow newTokStart) (tokenCol newTokStart)) prevToks toks+ ((startRow,startCol),_) = forestSpanToGhcPos $ srcSpanToForestSpan sspan core = reIndentToks (PlaceAbsolute startRow startCol) prevToks toks trail = if (emptyList origEndComments)@@ -845,10 +819,6 @@ zf' = Z.setTree (Node (Entry (srcSpanToForestSpan newSpan) NoChange toks'') []) zf forest'' = Z.toTree zf'- -- forest'' = error $ "updateTokensForSrcSpan: toks''=" ++ (show toks'') -- ++AZ++- -- forest'' = error $ "updateTokensForSrcSpan: (posToSrcSpan forest (startPos,endPos))=" ++ (showGhc $ posToSrcSpan forest (startPos,endPos)) -- ++AZ++- -- forest'' = error $ "updateTokensForSrcSpan: tree=" ++ (show tree) -- ++AZ++- -- (forest'',newSpan') = addNewSrcSpanAndToksAfter forest sspan newSpan pos toks'' oldTree = tree @@ -904,21 +874,32 @@ (startLoc,endLoc) = startEndLocIncComments' toks (tokStartPos,tokEndPos) (startToks,middleToks,endToks) = splitToks (startLoc,endLoc) toks- -- tree1 = if (emptyList $ filter (\t -> not $ isEmpty t) startToks)+ tree1 = if (nonCommentSpan startToks == ((0,0),(0,0))) then [] else [mkTreeFromTokens startToks] tree2 = [mkTreeFromSpanTokens sspan middleToks]- -- tree3 = if (emptyList $ filter (\t -> not $ isEmpty t) endToks)+ tree3 = if (nonCommentSpan endToks == ((0,0),(0,0))) then [] else [mkTreeFromTokens endToks] subTree = tree1 ++ tree2 ++ tree3 subTree' = filter (\t -> treeStartEnd t /= nullSpan) subTree- (Entry sspan2 _ _) = Z.label z+ -- (Entry sspan2 _ _) = Z.label z+ sspan2 = case Z.label z of+ (Entry ss _ _) -> ss+ (Deleted ss _ _) -> ss - z' = Z.setTree (Node (Entry sspan2 NoChange []) subTree') z++ -- z' = Z.setTree (Node (Entry sspan2 NoChange []) subTree') z+ z' = case Z.label z of+ (Entry _ _ _) -> Z.setTree (Node (Entry sspan2 NoChange []) subTree') z+ (Deleted _ _ _) -> Z.setTree (Node (Entry sspan2 NoChange []) subTreeD) z+ where+ (tb,tm,te) = splitSubToks (Z.tree z) sspan+ subTreeD = tb ++ tm ++ te+ forest'' = Z.toTree z' in forest'' else@@ -934,11 +915,6 @@ forest'' = Z.toTree z' in forest''- -- error $ "insertSrcSpan:(before,middle,end)=" ++ (show (before,middle,end)) -- ++AZ++- -- forest'' = error $ "insertSrcSpan:(startToks,endToks)=" ++ (show (startToks,endToks)) -- ++AZ++- -- forest'' = error $ "insertSrcSpan:(Z.toTree z')=" ++ (show (Z.toTree z')) -- ++AZ++- -- forest'' = error $ "insertSrcSpan:(startLoc,endLoc)=" ++ (show (startLoc,endLoc)) -- ++AZ++- -- forest'' = error $ "insertSrcSpan:(tokStartPos,tokEndPos,toks)=" ++ (show (tokStartPos,tokEndPos,toks)) -- ++AZ++ -- ---------------------------------------------------------------------@@ -968,10 +944,9 @@ (x,y,[]) -> (x,y,[]) xxx -> error $ "doSplitTree:eb populated:" ++ (show (sspan,tree,xxx)) - -- ( bb,mb,[]) = doSplitTree (ghead "doSplitTree.2" xx) sspan ( [],me,ee) = doSplitTree (glast "doSplitTree.2" xx) sspan- -- ( bbb,me,ee) = doSplitTree (glast "doSplitTree.2" xx) sspan+ mm = tail $ init xx -- xx = (head xx) ++ mm ++ (last xx) b' = bb@@ -1056,7 +1031,6 @@ (True, True) -> (b'',m'',e'') -- Start and End where- -- (toksb,toksm,tokse) = splitToks (forestSpanToSimpPos (treeStart,treeEnd)) toks (toksb,toksm,tokse) = splitToks (forestSpanToSimpPos (sspanStart,sspanEnd)) toks b'' = mkTreeListFromTokens toksb (treeStart, sspanStart) False m'' = mkTreeListFromTokens toksm (sspanStart, sspanEnd) True@@ -1136,22 +1110,17 @@ z = openZipperToSpan sspan $ Z.fromTree forest' zp = gfromJust "removeSrcSpan" $ Z.parent z -{-- pg = error $ "removeSrcSpan: need calcPriorGap"- eg = calcEndGap forest' sspan--} ((pg,_),eg) = calcPriorAndEndGap forest' sspan pt = Z.tree zp- -- subTree = filter (\t -> not (treeStartEnd t == sspan)) $ subForest pt+ subTree = map (\t -> if (treeStartEnd t == sspan) then (Node (Deleted sspan pg eg) []) else t) $ subForest pt z' = Z.setTree (pt { subForest = subTree}) zp forest'' = Z.toTree z'- -- forest'' = error $ "removeSrcSpan: initial tree\n" ++ (drawTreeEntry forest) -- ++AZ++- -- forest'' = error $ "removeSrcSpan: after insertSrcSpan\n" ++ (drawTreeEntry forest') -- ++AZ++ delTree = Z.tree z+ -- forest'' = error $ "removeSrcSpan: forest'=" ++ drawTreeCompact forest' -- --------------------------------------------------------------------- @@ -1198,8 +1167,6 @@ -- TODO: what about comments before the span? spanStartRow may be off pg = (spanStartRow - tokRowPg, spanStartCol - tokColPg)- -- pg = error $ "calcPriorAndEndGap : (tokRowPg,tokColPg):" ++ (show $ ((tokRowPg,tokColPg),(spanStartRow,spanStartCol)))- -- pg = error $ "calcPriorAndEndGap : (head before):" ++ (show $ last before) -- ---------------------------------------------------------------------@@ -1247,281 +1214,6 @@ -- --------------------------------------------------------------------- -{---- |Retrieve the tokens in a ppr format, so they can be rendered-retrieveTokensPpr :: Tree Entry -> [Ppr]-retrieveTokensPpr forest = pps'''- where- -- forest' = adjustLinesForDeleted forest- (pps,_,lastLine) = retrieveTokensPpr' ([],Original,[]) forest- pps' = pps ++ (mkPprFromLineToks lastLine)- pps'' = mergeDeletesPpr pps'- pps''' = adjustPprForDeleted pps''--retrieveTokensPpr' :: ([Ppr],PprOrigin,[PosToken]) -> Tree Entry -> ([Ppr],PprOrigin,[PosToken])--retrieveTokensPpr' acc (Node (Deleted _sspan _pg ( 0,_cd) ) _) = acc-retrieveTokensPpr' acc (Node (Deleted sspan pg (rd,_cd) ) _) = acc'- where- (ac,o,curLineToks) = acc- ll = mkPprFromLineToksSrc o curLineToks- ((rs,cs),(re,_ce)) = forestSpanToSimpPos sspan- ol = re - rs- acc' = (ac ++ ll ++ [PprDeleted rs cs pg ol rd],o,[])--retrieveTokensPpr' acc (Node (Entry _sspan NoChange []) subs)- = foldl' retrieveTokensPpr' acc subs--retrieveTokensPpr' acc (Node (Entry _sspan (Above so _ (r,c) eo) []) subs) = acc'- where- (ac,_o,curLineToks) = acc- (sss,o2,cl2) = foldl' retrieveTokensPpr' ([],Original,[]) subs- cl2Acc = mkPprFromLineToksSrc o2 cl2- ll = mkPprFromLineToks curLineToks- acc' = (ac ++ ll ++ [PprAbove so (r,c) eo (normaliseColumns (sss++cl2Acc))],o2,[])--retrieveTokensPpr' (acc,oi,curLineToks) (Node (Entry sspan _ toks) []) = (acc++accNew,o,curLineToks')- where- o = if (forestSpanVersionSet sspan) then Added else Original- oi' = if o == Added || oi == Added then Added else Original- toksByLine = groupTokensByLine toks- (accNew,curLineToks') = case curLineToks of- [] -> case toksByLine of- [] -> ([],[])- [x] -> ([],x)- xs -> (concatMap (mkPprFromLineToksSrc o) (init xs),last xs)-- _ -> case toksByLine of- [] -> ([],[])- [x] -> if (toksOnSameLine (last curLineToks) (head x))- then ([],curLineToks ++ x)- else (mkPprFromLineToksSrc oi curLineToks,x)- (x:xs) -> if (toksOnSameLine (last curLineToks) (head x))- then ((mkPprFromLineToksSrc oi' (curLineToks++x)) ++ concatMap (mkPprFromLineToksSrc o) ( init xs),last xs)- else ((mkPprFromLineToksSrc oi curLineToks ) ++ concatMap (mkPprFromLineToksSrc o) (x:init xs),last xs)---- Keep -Wall happy-retrieveTokensPpr' _acc n@(Node (Entry _sspan (Above _so _ (_r,_c) _eo) _toks) _subs)- = error $ "retrieveTokensPpr': Above entry with toks:" ++ (show n)--- retrieveTokensPpr' _acc n@(Node (Entry _sspan (Offset _r _c) _toks) _subs)--- = error $ "retrieveTokensPpr': Offset entry with toks:" ++ (show n)-retrieveTokensPpr' _acc n@(Node (Entry _sspan (NoChange) _toks) _subs)- = error $ "retrieveTokensPpr': NoChange entry with toks:" ++ (show n)--}--{--mkPprFromLineToks :: [PosToken] -> [Ppr]-mkPprFromLineToks toks = mkPprFromLineToksSrc Original toks--mkPprFromLineToksSrc :: PprOrigin -> [PosToken] -> [Ppr]-mkPprFromLineToksSrc _ [] = []-mkPprFromLineToksSrc o toks = [PprText ro co o str]- where- ro' = tokenRow $ head toks- co' = tokenCol $ head toks- (ro,co) = srcPosToSimpPos (tokenRow $ head toks, tokenCol $ head toks)- toks' = addOffsetToToks (-ro',-co') toks- str = GHC.showRichTokenStream toks'----- | The PprAbove construct needs all the starting columns to be reset to zero-normaliseColumns :: [Ppr] -> [Ppr]-normaliseColumns [] = []-normaliseColumns ps = ps'- where- offset = case (head ps) of- PprText _r c _ _ -> c - 1- PprDeleted _r c _ _ _ -> c - 1- _ -> 0- ps' = map removeOffset ps-- removeOffset (PprText r c o toks) = (PprText r (c - offset) o toks)- removeOffset (PprDeleted r c p l e) = (PprDeleted r (c - offset) p l e)- removeOffset x = x--}--- ----------------------------------------------------------------------{--adjustPprForDeleted :: [Ppr] -> [Ppr]-adjustPprForDeleted [] = []-adjustPprForDeleted pps = pps'- where- (_,pps') = foldl' go ((0,0),[]) pps-- go :: ((Int,Int),[Ppr]) -> Ppr -> ((Int,Int),[Ppr])- go ((ro,co),acc) (PprText r c Original str) = ((ro, co),acc++[PprText (r-ro) (c-co) Original str])- go ((ro,co),acc) (PprText r c Added str) = ((ro-1,co),acc++[PprText (r ) (c ) Added str])- -- go ((ro,co),acc) (PprDeleted r c rd) = ((ro - rd,co),acc)- go ((ro,co),acc) (PprDeleted r c pg l eg)- = ((ro + (pg + l + eg) - (max pg eg),co),acc++[PprDeleted r c pg l eg])- -- NOTE: see below for derivation of the above calc- go ((ro,co),acc) (PprAbove so p1 eo subs) = ((ro',co'),acc++[PprAbove so' p1' eo' subs'])- where- so' = so- p1' = p1- eo' = eo- ((ro',co'),subs') = foldl' go ((ro,co),[]) subs--}-{---Case 1--Code is------3:data D = A | B String | C-4:-5:ff :: Int -> Int <<<line to be deleted-6:ff y = y + zz-7: where-8: zz = 1-------PprDeleted 5 1 2 0 1-So pg is 2 (5 - 3)- l is 0 (5 - 5)- eg is 1 (6 - 5)--New location needs to be 5, so-ro needs to be 1-----------------Case 2--Code is------ 5:ff :: Int -> Int- 6:ff y = y + zz <<<line to be deleted- 7: where <<<line to be deleted- 8: zz = 1 <<<line to be deleted- 9:-10:x = 3-------PprDeleted 6 1 1 2 2-So pg is 1 ( 6 - 5)- l is 2 ( 8 - 6)- eg is 2 (10 - 8)--New location needs to be 7, so-ro needs to be 3--so (pg - 1) + (l + 1) or pg + l------------------Case 3--Code is------ 4:ff :: Int -> Int- 5:- 6:ff y = y + zz <<<line to be deleted- 7: where <<<line to be deleted- 8: zz = 1 <<<line to be deleted- 9:-10:x = 3-------PprDeleted 6 1 2 2 2-So pg is 2 ( 6 - 4)- l is 2 ( 8 - 6)- eg is 2 (10 - 8)--New location needs to be 6, so-ro needs to be 4--so (pg - 1) + (l + 1) or pg + l--=================================--First principles.--We have- sr : last non-blank line before deletion area- dr : first non-blank line after deletion area-- fd : first line of deletion area- ld : last line of deletion area--We need to calculate the offset to bring dr to have the same end-gap as for the original.-- Case 1 Case 2 Case 3- sr 3 5 4- fd 5 6 6- ld 5 8 8- dr 6 10 10-- pg 2 1 2- eg 1 2 2-- np 5 7 6- ro 1 3 4--i.e. we need to apply the largest of (pg,eg) to the original sr.--so- np = sr + max(pg,eg)-- ro = dr - np--Hence-- ro = dr - sr - max(pg,eg)--In PprDeleted, dr - sr is same as (pg + l + eg)-- ro = (pg + l + eg) - max(pg,eg)---}---- ----------------------------------------------------------------------{--mergeDeletesPpr :: [Ppr] -> [Ppr]-mergeDeletesPpr [] = []-mergeDeletesPpr ((PprDeleted r1 c1 pg1 l1 eg1):(PprDeleted _r _c pg2 l2 eg2):ps)- = (PprDeleted r1 c1 pg1 (l1 + eg1 + pg2 + l2 - 1) eg2) : mergeDeletesPpr ps--}-{--The total gap taken up by each delete is pg+l+eg.--We have- pg1 + l1 + eg1 + pg2 + l2 + eg2--The combined span has- pg1 + (l1 + eg1 + pg2 + l2) + eg2--Why do we need the (-1)? TBD--pg1 : fb - sr-eg1 : dr - lb- l1 : lb - fb-sum: (fb - sr) + (dr - lb) + (lb - fb)- = -sr + dr -- fb and lb cancels out- = dr - sr-so we have (dr1 - sr1) + (dr2 - sr2)-bu, dr1 == sr2-so (dr1 - sr1 + dr2 - dr1)-or dr2 - sr1--}-{--mergeDeletesPpr (p:ps) = p : mergeDeletesPpr ps--}--- ----------------------------------------------------------------------{--getPprStartRow :: Ppr -> Row-getPprStartRow (PprText r _ _ _) = r-getPprStartRow (PprDeleted r _ _ _ _) = r-getPprStartRow (PprAbove _ _ _ []) = error "getPprStartRow: PprAbove with no subs"-getPprStartRow (PprAbove _ _ _ subs) = getPprStartRow $ head subs--getPprEndRow :: Ppr -> Row-getPprEndRow (PprText r _ _ _) = r-getPprEndRow (PprDeleted r _ _ _ _) = r-getPprEndRow (PprAbove _ _ _ []) = error "getPprEndRow: PprAbove with no subs"-getPprEndRow (PprAbove _ _ _ subs) = getPprEndRow $ last subs--}---- ---------------------------------------------------------------------- -- TODO: deprecated, doing this at the Ppr level now adjustLinesForDeleted :: Tree Entry -> Tree Entry adjustLinesForDeleted forest = forest'@@ -1555,137 +1247,7 @@ applyOffsetToTreeShallow _ n@(Node (Deleted _ _ _) _) = n -- ----------------------------------------------------------------------{--renderPpr :: [Ppr] -> String-renderPpr ps = res- where- (_,(_,res)) = runState (go 0 ps) ((1,1),"") - go _ [] = return ()-- go ci (ppt@(PprText _rt _ct _ _toks):ppa@(PprAbove so (_,_cc) eo _subs):ps') = do- renderPprText ci ppt- addOffset so- (_,c) <- getRC- renderPprAbove c ppa- (cr,_cc) <- getRC- -- addOffset eo- if ps' /= []- then- case eo of- FromAlignCol (ero,eco) -> newPos (cr+ero) (ci+eco)- SameLine _ -> addOffset eo- None -> return ()- else return ()- -- (r',c') <- getRC- -- addDebugString $ "(eo:" ++ show (ci,(r',c')) ++ ")" -- ++AZ++ debug- go ci ps'-- go ci (p@(PprText _rt _ct _ _toks):ps') = do- renderPprText ci p- go ci ps'-- go ci ((PprDeleted _ _ _ _ _):ps') = go ci ps'-- go _ pps = error $ "renderPpr: unmatched in go:" ++ (show pps)-- -------------------------------------- renderPprAbove _ci (PprAbove _ _ _ []) = return ()- renderPprAbove ci (PprAbove _ _ _ subs) = go ci subs-- renderPprAbove _ ppr = error $ "renderPprAbove:unexpected ppr:" ++ (show ppr)-- -------------------------------------- -- renderPprText :: Col -> Ppr -> String- renderPprText ci (PprText rt ct _ str) = do- -- (r',c') <- getRC- -- addDebugString $ "(op" ++ (show (ci,(r',c'),(rt,ct))) ++ ")" -- ++AZ++ for debugging- newPos rt (ci + ct)- -- (r,c) <- getRC- -- addDebugString $ "(np:" ++ (show (r,c)) ++ ")" -- ++AZ++ for debugging- addString str- -- addDebugString $ "(fp:" ++ (show (r,c)) ++ ")" -- ++AZ++ for debugging-- renderPprText _ ppr = error $ "renderPprText:unexpected ppr:" ++ (show ppr)-- -------------------------------------- addOffset None = return ()- addOffset (SameLine co) = do- (r,c) <- getRC- newPos r (c+co)- addOffset (FromAlignCol (ro,co)) = do- (r,c) <- getRC- newPos (r+ro) (c+co)-- newPos newRow newCol = do- (oldRow',oldCol) <- getRC-- -- Allow for out of order additions that result from additions- -- to the tree. Will break the invariant.- let oldRow = if oldRow' <= newRow then oldRow' else (newRow - 1)- putRC (oldRow,oldCol)-- if oldRow == newRow- then addString (take (newCol - oldCol) $ repeat ' ')- else- addString ( (take (newRow - oldRow) $ repeat '\n') ++- (take (newCol - 1) $ repeat ' ') )- checkInvariant $ "newPos:" ++ (show (newRow,newCol))--- -- Check invariant- -- 1. r == number of '\n' + 1- -- 2. c == number of chars in last line.- -- We assume the c val refers to positions between characters- -- of output.- checkInvariant str = do-{-- ((r,c),cur) <- get- let ll = 1 + (length $ filter (=='\n') cur)- let lc = 1 + (length $ takeWhile (/='\n') $ reverse cur)- if r /= ll- then error $ "renderPpr.newPos: r /= ll :" ++ (show (r,ll,cur,str))- else return ()- if c /= lc- then error $ "renderPpr.newPos: c /= lc :" ++ (show (c,lc,cur,str))- else return ()--}- return ()-- -- State operations ------------------ getRC = do- (rc,_) <- get- return rc-- putRC (r,c) = do- (_,str) <- get- put ((r,c),str)-- addString [] = return ()- addString str = do- ((r,c),curr) <- get- let ll = (length $ filter (=='\n') str)- let c'' = (length $ takeWhile (/='\n') $ reverse str)--- let (r',c') = case ll of- 0 -> (r,c + c'')- _ -> (r + ll, c'' + 1)- put ((r',c'),curr++str)-- checkInvariant $ "addString" ++ show str-- addDebugString str = do- ((r,c),curr) <- get- put ((r,c),curr++str)--}---- ---------------------------------------------------------------------- -- |Retrieve all the tokens at the leaves of the tree, in order. No -- adjustments are made to address gaps or re-alignment of the tokens retrieveTokensInterim :: Tree Entry -> [PosToken]@@ -1744,34 +1306,6 @@ t1' = map (increaseSrcSpan (fr,fc)) t1 -{------- | Process the leaf nodes of a tree to remove all deleted spans-deleteGapsToks' :: [Entry] -> [(SimpPos,String,ForestSpan,[PosToken])]-deleteGapsToks' toks = goDeleteGapsToks' (0,0) toks--goDeleteGapsToks' :: SimpPos -> [Entry] -> [(SimpPos,String,ForestSpan,[PosToken])]-goDeleteGapsToks' _ [] = [((0,0), "N",nullSpan, [])]-goDeleteGapsToks' offset [Entry ss _ t] = [(offset,"E1",ss,map (increaseSrcSpan offset) t)]-goDeleteGapsToks' _ [Deleted _ _] = [((0,0), "D1",nullSpan, [])]-goDeleteGapsToks' offset (Deleted _ _:ts) = (offset, "D0",nullSpan, []):goDeleteGapsToks' offset ts-goDeleteGapsToks' offset [Entry ss _ t,Deleted _ _] = [(offset,"[ED]",ss,map (increaseSrcSpan offset) t)]-goDeleteGapsToks' offset (Entry ss _ t1:e@(Entry _ _ _):ts) =(offset,"EE", ss, (map (increaseSrcSpan offset) t1)):goDeleteGapsToks' offset (e:ts)-goDeleteGapsToks' (fr,fc) (Entry ss _ t1:Deleted _ _:t2:ts)- = ((fr,fc),"ED",ss,t1') : goDeleteGapsToks' offset' (t2:ts)- where- -- TODO: use actual first and last toks, may be comments- -- TODO: what about deletion within a line?- (_,(sr,_sc)) = forestSpanToSimpPos ss- ((dr,_dc),_) = forestSpanToSimpPos $ forestSpanFromEntry t2- offset' = (fr + sr - dr + 2, fc)- -- offset' = (fr + sr - dr + 1, fc)-- t1' = map (increaseSrcSpan (fr,fc)) t1------}- -- --------------------------------------------------------------------- -- |Starting from a point in the zipper, retrieve all tokens backwards@@ -1790,15 +1324,6 @@ -- res' = reverse $ (concat (go z)) ++ prevToks res' = reverse $ concat $ reverse (prevToks : (go z)) -- -- res' = (reverse prevToks) ++ (concat (go z))-- -- res' = error $ "retrievePrevLineToks:res'=" ++ (show (dropWhile (\tok -> isWhiteSpace tok || tokenRow tok < endLine) res))- -- res' = error $ "retrievePrevLineToks:prevToks=" ++ (show prevToks)- -- res' = error $ "retrievePrevLineToks:prevToks=" ++ (show res)- -- res' = error $ "retrievePrevLineToks:(prevToks : (go z))=" ++ (show (prevToks : (go z)))- -- res' = error $ "retrievePrevLineToks:(prevToks : (go z))=" ++ (show $ concat $ reverse (prevToks : (go z)))- -- TODO: ++AZ++ what is this actually doing? go :: Z.TreePos Z.Full Entry -> [[PosToken]] go zz@@ -1997,8 +1522,6 @@ reIndentToks :: Positioning -> [PosToken] -> [PosToken] -> [PosToken] reIndentToks _ _ [] = [] reIndentToks pos prevToks toks = toks''- -- = error $ "reIndentToks:(pos,prevToks)=" ++ (show (pos,prevToks)) -- ++AZ++- -- = error $ "reIndentToks:((isComment lastTok),(tokenRow lastNonCommentTok),lastTokEndLine)=" ++ (show ((isComment lastTok),(tokenRow lastNonCommentTok),lastTokEndLine)) where newTokStart = ghead "reIndentToks.1" $ dropWhile (\tok -> isComment tok || isEmpty tok) $ toks@@ -2040,12 +1563,8 @@ -- TODO: Should this not be prevOffset? colStart = tokenCol $ ghead "reIndentToks.4" $ dropWhile isWhiteSpaceOrIgnored prevToks- -- colStart = prevOffset- -- colStart = error $ "reIndentToks:prevToks=" ++ (show prevToks) lineStart = (tokenRow (lastTok)) -- + 1- -- lineStart = error $ "reIndentToks:PlaceOffset:lastTok=" ++ show lastTok- -- lineStart = error $ "reIndentToks:PlaceOffset:firstTok=" ++ show firstTok lineOffset' = rowIndent + lineStart - (tokenRow firstTok) colOffset' = colIndent + colStart - (tokenCol newTokStart)@@ -2063,7 +1582,6 @@ toks' = addOffsetToToks (lineOffset,colOffset) toks toks'' = if endNewlines > 0- -- then toks' ++ [(newLinesToken endNewlines $ glast "reIndentToks.3" toks')] then toks' ++ [(newLinesToken (endNewlines - 1) $ glast "reIndentToks.3" toks')] else toks' @@ -2340,50 +1858,10 @@ -{- -examples- forest = [((1,1),(10,5)), ((100001,1),(10,5)), ((11,1),(14,3))]- sspan = ((10,1),(11,5)) -Should bring all of them- Can we use starts only?-- Or, work from the front for begin, checking starts only, and back- for end checking ends only---}-- -- --------------------------------------------------------------------- -{---- | Look a SrcSpan up in the forest.--- There are three possibilities--- 1. It is not there--- 2. It is there, exactly--- 3. It is not there exactly, but is a sub-element of something that--- is there. In this case return the smallest containing element.--- This may be a list of trees, if the desired span crosses multiple--- trees.-lookupSrcSpan :: Forest Entry -> ForestSpan -> [Tree Entry]-lookupSrcSpan forest sspan = res- where- -- Assuming invariants hold, the forest is sorted,- -- So, move through trees until ones containing the span are- -- found.- -- If it is contained in a single tree, drill into it to find the- -- smallest set of trees containing the span-- (_,middle,_) = splitForestOnSpan forest sspan- res = case middle of- [Node _ []] -> middle- [Node _ sub] -> lookupSrcSpan sub sspan- _ -> middle--}---- ---------------------------------------------------------------------- -- |Utility function to either return True or throw an error to report the problem invariantOk :: Tree Entry -> Bool invariantOk forest = ok@@ -2778,32 +2256,5 @@ fs' = ((ForestLine chls trls vls lls,cls),(ForestLine chhe trhe vhe lhe,che)) -{---- | Combines two 'SrcSpan' into one that spans at least all the characters--- within both spans. Assumes the "file" part is the same in both inputs-combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan-combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful-combineSrcSpans l (UnhelpfulSpan _) = l-combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2)- = RealSrcSpan (combineRealSrcSpans span1 span2)---- | Combines two 'SrcSpan' into one that spans at least all the characters--- within both spans. Assumes the "file" part is the same in both inputs-combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan-combineRealSrcSpans span1 span2- = if line_start == line_end- then if col_start == col_end- then SrcSpanPoint file line_start col_start- else SrcSpanOneLine file line_start col_start col_end- else SrcSpanMultiLine file line_start col_start line_end col_end- where- (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1)- (srcSpanStartLine span2, srcSpanStartCol span2)- (line_end, col_end) = max (srcSpanEndLine span1, srcSpanEndCol span1)- (srcSpanEndLine span2, srcSpanEndCol span2)- file = srcSpanFile span1----} -- EOF
src/Language/Haskell/Refact/Utils/TypeUtils.hs view
@@ -118,5553 +118,4299 @@ , mkRdrName,mkNewGhcName,mkNewName,mkNewToplevelName -- The following functions are not in the the API yet.- , causeNameClashInExports {- , inRegion , unmodified -}, prettyprint, prettyprint2-- , removeOffset-- -- * Typed AST traversals (added by CMB)- -- * Miscellous- -- ,removeFromInts, getDataName, checkTypes, getPNs, getPN, getPNPats, mapASTOverTAST-- -- * Debug stuff- , getDeclAndToks, getSigAndToks- , getToksForDecl, removeToksOffset -- ++AZ++ remove this after debuggging- , getParsedForRenamedLPat- , getParsedForRenamedName- , getParsedForRenamedLocated- -- , allPNT- -- , allPNTLens- , newNameTok- , stripLeadingSpaces- -- , lookupNameGhc- ) where--import Exception-import Control.Monad.State-import Data.Char-import Data.List-import Data.Maybe-import Data.Monoid-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.TokenUtils-import Language.Haskell.Refact.Utils.TokenUtilsTypes-import Language.Haskell.Refact.Utils.TypeSyn---- Modules from GHC-import qualified Bag as GHC-import qualified BasicTypes as GHC--- import qualified DataCon as GHC--- import qualified DynFlags as GHC--- import qualified ErrUtils as GHC--- import qualified FamInstEnv as GHC-import qualified FastString as GHC-import qualified GHC as GHC--- import qualified HscMain as GHC--- import qualified HsPat as GHC--- import qualified HscTypes as GHC--- import qualified Id as GHC--- import qualified InstEnv as GHC-import qualified Lexer as GHC hiding (getSrcLoc)-import qualified Module as GHC-import qualified Name as GHC--- import qualified NameEnv as GHC-import qualified NameSet as GHC-import qualified Outputable as GHC--- import qualified PrelNames as GHC-import qualified RdrName as GHC--- import qualified RnBinds as GHC--- import qualified RnEnv as GHC--- import qualified RnPat as GHC--- import qualified RnSource as GHC-import qualified SrcLoc as GHC--- import qualified SysTools as GHC--- import qualified TcEnv as GHC--- import qualified TcEvidence as GHC--- import qualified TcExpr as GHC--- import qualified TcHsSyn as GHC--- import qualified TcMType as GHC--- import qualified TcRnDriver as GHC--- import qualified TcRnMonad as GHC--- import qualified TcRnTypes as GHC--- import qualified TcSimplify as GHC--- import qualified TcType as GHC--- import qualified TyCon as GHC-import qualified UniqSet as GHC-import qualified Unique as GHC--- import qualified Util as GHC--- import qualified VarEnv as GHC--- import qualified VarSet as GHC--import qualified Data.Generics as SYB-import qualified GHC.SYB.Utils as SYB--- import qualified Data.Generics.Zipper as Z--import Data.Generics.Strafunski.StrategyLib.StrategyLib--- import Data.IORef---- import Debug.Trace--- debug = flip trace---- ------------------------------------------------------------------------- | For free variables-data FreeNames = FN [GHC.Name]---- | For declared variables-data DeclaredNames = DN [GHC.Name]--instance Show FreeNames where- show (FN ls) = "FN " ++ showGhc ls--instance Show DeclaredNames where- show (DN ls) = "DN " ++ showGhc 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 [])---- ------------------------------------------------------------------------ |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-- -- getEntInfo (qual, ent@(Ent modName ident _))- -- =(identToName ident, hasNameSpace ent, modName, getQualifier qual)--{---- | Process the export relation returned from the parsing and module analysis pass, and--- return a list of trhee-element tuples. Each tuple contains an identifier name, the--- identifier's namespace info, and the identifier's define module.-exportInfo::Exports -- ^ The export relation.- -> [(String, NameSpace, ModuleName)] -- ^ The result-exportInfo exports = nub $ map getEntInfo exports- where- getEntInfo (_, ent@(Ent modName ident _))- =(identToName ident, hasNameSpace ent, modName)--}---- | 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---- isInScopeAndUnqualified id inScopeRel--- = isJust $ find (\ (x, _,_, qual) -> x == id && isNothing qual ) $ inScopeInfo inScopeRel---- | 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 -> (GHC.nameUnique x) /= (GHC.nameUnique n')) names- Just n' -> filter (\x -> (showGhc x) /= (showGhc 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 []--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 []---- ----------------------------------------------------------------------{---- | Return True if the identifier is inscope and can be used without--- a qualifier. The identifier name string may have a qualifier already-lookupNameGhc :: String -- ^ The identifier name.- -> RefactGhc [GHC.Name] -- ^ The result.-lookupNameGhc n = do- names <- ghandle handler (GHC.parseName n)- nameInfo <- mapM GHC.lookupName names- let nameList = map (\(GHC.AnId n) -> GHCV.varName n) $ filter isId $ catMaybes nameInfo- return nameList-- where- isId (GHC.AnId _) = True- isId _ = False-- -- handler:: (Exception e,GHC.GhcMonad m) => e -> m [GHC.Name]- handler:: (GHC.GhcMonad m) => SomeException -> m [GHC.Name]- handler _ = return []--}---- ------------------------------------------------------------------------ | Show a PName in a format like: 'pn'(at row:r, col: c).-showPNwithLoc:: GHC.Located GHC.Name -> String-showPNwithLoc pn@(GHC.L l _n)- = let (r,c) = getGhcLoc l- -- in " '"++pNtoName pn++"'" ++"(at row:"++show r ++ ",col:" ++ show c ++")"- in " '"++showGhc pn++"'" ++"(at row:"++show r ++ ",col:" ++ show c ++")"---- -----------------------------------------------------------------------{- ++AZ++ getting rid of PNT--- | Default identifier in the PNT format.--- defaultPNT:: GHC.GenLocated GHC.SrcSpan GHC.RdrName -- GHC.RdrName-defaultPNT:: PNT-defaultPNT = PNT (GHC.L GHC.noSrcSpan (mkRdrName "nothing"))--}--defaultPN :: PName-defaultPN = PN (mkRdrName "nothing")--defaultName :: GHC.Name-defaultName = n- where- un = GHC.mkUnique 'H' 0 -- H for HaRe :)- n = GHC.localiseName $ GHC.mkSystemName un (GHC.mkVarOcc "nothing")---- | Default expression.-defaultExp::HsExpP--- defaultExp=Exp (HsId (HsVar defaultPNT))-defaultExp=GHC.HsVar $ mkRdrName "nothing"---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) }-- let un = GHC.mkUnique 'H' (u+1) -- H for HaRe :)- -- n = GHC.mkSystemName un (GHC.mkVarOcc name)- n = case maybeMod of- Nothing -> GHC.localiseName $ GHC.mkSystemName un (GHC.mkVarOcc name)- Just modu -> GHC.mkExternalName un modu (GHC.mkVarOcc name) nullSrcSpan- return n--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.mkSystemName un (GHC.mkVarOcc name)- -- n = GHC.localiseName $ GHC.mkSystemName un (GHC.mkVarOcc name)-- -- mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name- 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 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 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- -- in error $ "causeNameClashInExports:modNames=" ++ (showGhc modNames)- -- in error $ "causeNameClashInExports:explicitlyExported=" ++ (showGhc (isExplicitlyExported pn renamed))- -- in error $ "causeNameClashInExports:any unqualImp=" ++ (showGhc (any (modIsUnQualifedImported renamed) modNames))- where- isImpVar (GHC.L _ x) = case x of- GHC.IEVar _ -> True- _ -> False-- modIsUnQualifedImported _mod' modName'- =let -- imps =hsModImports mod- -- imp@(GHC.L _ (GHC.ImportDecl (GHC.L _ modName) qualify _source _safe isQualified _isImplicit as h))- in isJust $ find (\(GHC.L _ (GHC.ImportDecl (GHC.L _ modName1) _qualify _source _safe isQualified _isImplicit _as _h))- -> modName1 == modName' && (not isQualified)) imps- -- in isJust $ find (\(HsImportDecl _ (SN modName1 _) qualify _ h) -> modName == modName1 && (not qualify)) 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-{---modNames capture potential clashes e.g.--@-module Exports (head) where--import Data.Text (head)-@--So if the new name was 'head', then the modNames would be- [Data.Text]---}---{- ++AZ++ Original---- Note that in the abstract representation of exps, there is no qualified entities.-causeNameClashInExports pn newName mod exps- = let modNames=nub (concatMap (\(x, Ent modName _ _)->if show x==show newName- then [modName]- else []) exps)- in (isExplicitlyExported pn mod) &&- ( any (modIsUnQualifedImported mod) modNames- || elem (let (SN modName1 _) =hsModName mod- in modName1) modNames)- where- modIsUnQualifedImported mod modName- =let imps =hsModImports mod- in isJust $ find (\(HsImportDecl _ (SN modName1 _) qualify _ h)->modName==modName1 && (not qualify)) imps---}---- ------------------------------------------------------------------------ | 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- -- cc :: Maybe ([GHC.Name],[GHC.Name]) -> Maybe ([GHC.Name],[GHC.Name]) -> Maybe ([GHC.Name],[GHC.Name])- -- cc = mappend- -- cc Nothing Nothing = Nothing- -- -- cc (Just (f1,d1)) (Just (f2,d2)) = Just (f1++f2,d1++d2)- -- cc (Just (f1,d1)) (Just (f2,d2)) = Just (f1,d1)- -- cc Nothing x = x- -- cc x Nothing = x-{-- -- hsFreeAndDeclared' :: RefactGhc (Maybe ([GHC.Name],[GHC.Name]))- hsFreeAndDeclared' :: Maybe ([GHC.Name],[GHC.Name])- hsFreeAndDeclared' = somethingStaged SYB.Renamer Nothing- -- hsFreeAndDeclared' = everythingStaged SYB.Renamer cc Nothing- (Nothing- `SYB.mkQ` expr- `SYB.extQ` pattern- `SYB.extQ` bindList- `SYB.extQ` binds- `SYB.extQ` match- `SYB.extQ` stmts- `SYB.extQ` rhs- ) t--}-- hsFreeAndDeclared' = applyTU (stop_tdTUGhc (failTU- `adhocTU` expr- `adhocTU` pattern- `adhocTU` binds- `adhocTU` bindList- `adhocTU` match- `adhocTU` stmts- `adhocTU` rhs- )) t-- -- TODO: ++AZ++ Note:After renaming, HsBindLR has field bind_fvs- -- containing locally bound free vars-- -- expr --- expr (GHC.HsVar n) = return ([n],[])-- expr (GHC.OpApp e1 (GHC.L _ (GHC.HsVar n)) _ e2) = do- -- (ef,ed) <- hsFreeAndDeclaredPNs' [e1,e2]- -- (f,d) <- addFree n (ef,ed)- efed <- hsFreeAndDeclaredPNs' [e1,e2]- fd <- addFree n efed- return fd-- expr ((GHC.HsLam (GHC.MatchGroup 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)- = do (df,dd) <- hsFreeAndDeclaredPNs' g- (ef,ed) <- hsFreeAndDeclaredPNs' ds- return (df ++ ef, dd ++ ed)-- -- rhs _ = mzero-- -- pat --- 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.MatchGroup matches _) _ _fvs _) :: GHC.HsBind GHC.Name)- = do- (pf,_pd) <- hsFreeAndDeclaredPNs' matches-- -- ((pf `union` ((rf `union` df) \\ (dd `union` pd `union` [fun]))),[fun])- -- return ((GHC.uniqSetToList fvs),[n])- 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 pats _mtype mrhs) :: GHC.Match 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) = do- -- TODO ++AZ++ : Not sure it is meaningful to pull- -- anything out of bindOp/failOp- (pf,pd) <- hsFreeAndDeclaredPNs' pat- (ef,_ed) <- hsFreeAndDeclaredPNs' expre- -- sf_sd <- hsFreeAndDeclaredPNs' [bindOp,failOp]- -- let (sf,_sd) = fromMaybe ([],[]) sf_sd- let sf1 = []- return (pf `union` ef `union` (sf1\\pd),[]) -- pd) -- Check this-- stmts ((GHC.LetStmt binds') :: GHC.Stmt 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))---{--hsFreeAndDeclaredPNs:: (Term t, MonadPlus m)=> t-> m ([PName],[PName])-hsFreeAndDeclaredPNs t=do (f,d)<-hsFreeAndDeclared' t- return (nub f, nub d)- where- hsFreeAndDeclared'=applyTU (stop_tdTU (failTU `adhocTU` exp- `adhocTU` pat- `adhocTU` match- `adhocTU` patBind- `adhocTU` alt- `adhocTU` decls- `adhocTU` stmts- `adhocTU` recDecl))-- exp (TiDecorate.Exp (HsId (HsVar (PNT pn _ _))))=return ([pn],[])- exp (TiDecorate.Exp (HsId (HsCon (PNT pn _ _))))=return ([pn],[])- exp (TiDecorate.Exp (HsInfixApp e1 (HsVar (PNT pn _ _)) e2))- =addFree pn (hsFreeAndDeclaredPNs [e1,e2])- exp (TiDecorate.Exp (HsLambda pats body))- = do (pf,pd) <-hsFreeAndDeclaredPNs pats- (bf,_) <-hsFreeAndDeclaredPNs body- return ((bf `union` pf) \\ pd, [])- exp (TiDecorate.Exp (HsLet decls exp))- = do (df,dd)<- hsFreeAndDeclaredPNs decls- (ef,_)<- hsFreeAndDeclaredPNs exp- return ((df `union` (ef \\ dd)),[])- exp (TiDecorate.Exp (HsRecConstr _ (PNT pn _ _) e))- =addFree pn (hsFreeAndDeclaredPNs e) --Need Testing- exp (TiDecorate.Exp (HsAsPat (PNT pn _ _) e))- =addFree pn (hsFreeAndDeclaredPNs e)- exp _ = mzero--- pat (TiDecorate.Pat (HsPId (HsVar (PNT pn _ _))))=return ([],[pn])- pat (TiDecorate.Pat (HsPInfixApp p1 (PNT pn _ _) p2))=addFree pn (hsFreeAndDeclaredPNs [p1,p2])- pat (TiDecorate.Pat (HsPApp (PNT pn _ _) pats))=addFree pn (hsFreeAndDeclaredPNs pats)- pat (TiDecorate.Pat (HsPRec (PNT pn _ _) fields))=addFree pn (hsFreeAndDeclaredPNs fields)- pat _ =mzero--- match ((HsMatch _ (PNT fun _ _) pats rhs decls)::HsMatchP)- = do (pf,pd) <- hsFreeAndDeclaredPNs pats- (rf,rd) <- hsFreeAndDeclaredPNs rhs- (df,dd) <- hsFreeAndDeclaredPNs decls- return ((pf `union` ((rf `union` df) \\ (dd `union` pd `union` [fun]))),[fun])-- -------Added by Huiqing Li--------------------------------------------------------------------- patBind ((TiDecorate.Dec (HsPatBind _ pat (HsBody rhs) decls))::HsDeclP)- =do (pf,pd) <- hsFreeAndDeclaredPNs pat- (rf,rd) <- hsFreeAndDeclaredPNs rhs- (df,dd) <- hsFreeAndDeclaredPNs decls- return (pf `union` ((rf `union` df) \\(dd `union` pd)),pd)- patBind _=mzero- ------------------------------------------------------------------------------------------- -- alt ((HsAlt _ pat exp decls)::(HsAlt (HsExpP) (HsPatP) HsDeclsP))- = do (pf,pd) <- hsFreeAndDeclaredPNs pat- (ef,ed) <- hsFreeAndDeclaredPNs exp- (df,dd) <- hsFreeAndDeclaredPNs decls- return (pf `union` (((ef \\ dd) `union` df) \\ pd),[])--- decls (ds :: [HsDeclP])- =do (f,d) <-hsFreeAndDeclaredList ds- return (f\\d,d)-- stmts ((HsGenerator _ pat exp stmts) :: HsStmt (HsExpP) (HsPatP) HsDeclsP) -- Claus- =do (pf,pd) <-hsFreeAndDeclaredPNs pat- (ef,ed) <-hsFreeAndDeclaredPNs exp- (sf,sd) <-hsFreeAndDeclaredPNs stmts- return (pf `union` ef `union` (sf\\pd),[]) -- pd) -- Check this -- stmts ((HsLetStmt decls stmts) :: HsStmt (HsExpP) (HsPatP) HsDeclsP)- =do (df,dd) <-hsFreeAndDeclaredPNs decls- (sf,sd) <-hsFreeAndDeclaredPNs stmts- return (df `union` (sf \\dd),[])- stmts _ =mzero-- recDecl ((HsRecDecl _ _ _ _ is) :: HsConDeclI PNT (HsTypeI PNT) [HsTypeI PNT])- =do let d=map pNTtoPN $ concatMap fst is- return ([],d)- recDecl _ =mzero--- addFree free mfd=do (f,d)<-mfd- return ([free] `union` f, d)-- 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)---- hsFreeAndDeclaredNames::(Term t, MonadPlus m)=> t->m([String],[String])--- hsFreeAndDeclaredNames t =do (f1,d1)<-hsFreeAndDeclaredPNs t--- return ((nub.map pNtoName) f1, (nub.map pNtoName) d1)--{---- | 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-hsFreeAndDeclaredPNsOld2 :: (HsValBinds t) => t -> ([GHC.Name],[GHC.Name])-hsFreeAndDeclaredPNsOld2 t = res- where- bs = hsBinds t-- getFd :: (GHC.NameSet,[GHC.Name]) -> GHC.LHsBind GHC.Name -> (GHC.NameSet,[GHC.Name])- getFd (facc,dacc) b = (GHC.unionNameSets facc f,dacc ++ d)- where- [(d,f)] = getFvs [b]-- tds = concatMap getDeclaredTypes $ concat $ hsTyDecls t- (fs,ds) = foldl' getFd (GHC.emptyNameSet,[]) bs-- fs' = GHC.nameSetToList $ GHC.minusNameSet fs (GHC.mkNameSet (ds ++ tds))- res = (fs',ds ++ tds)--}--hsFreeAndDeclaredPNs :: (SYB.Data t, GHC.Outputable 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) => t -> RefactGhc (FreeNames,DeclaredNames)-hsFreeAndDeclaredGhc t = do- -- logm $ "hsFreeAndDeclaredGhc:t=" ++ showGhc t- (FN f,DN d) <- res- -- let f' = nub $ filter isNonLibraryName f- -- let d' = nub $ filter isNonLibraryName d- let f' = nub f- let d' = nub d- -- logm $ "hsFreeAndDeclaredGhc:res=" ++ showGhc (f',d')- return (FN (f' \\ d'), DN d')-- where- res = (const err -- emptyFD- `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-#if __GLASGOW_HASKELL__ > 704- `SYB.extQ` bndrs-#endif- `SYB.extQ` ltydecls- `SYB.extQ` ltydecl-#if __GLASGOW_HASKELL__ > 704- `SYB.extQ` lfaminstdecls- `SYB.extQ` lfaminstdecl-#endif- `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- gfds <- hsFreeAndDeclaredGhc $ GHC.hs_valds g- let tds = concatMap getDeclaredTypes $ concat (GHC.hs_tyclds g)- return $ gfds <> (FN [],DN tds)--- lhsbinds :: [GHC.LHsBind GHC.Name] -> RefactGhc (FreeNames,DeclaredNames)- lhsbinds bs = do- (FN fn,DN dn) <- recurseList bs- let r = (FN (fn \\ dn),DN dn)- -- 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.MatchGroup matches _) _ _ _) = do- -- logm $ "hsFreeAndDeclaredGhc.hsbind:b=" ++ (showGhc b)- let d = GHC.collectHsBindBinders b- -- let pats = concatMap (\(GHC.L _ (GHC.Match pat _ _)) -> pat) matches- (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- dn = GHC.collectPatBinders lp-- -- logm $ "hsFreeAndDeclaredGhc.lpat p=" ++ (SYB.showData SYB.Renamer 0 p)-- (FN fn,DN _dn) <- pat p- -- logm $ "hsFreeAndDeclaredGhc.lpat:(fn,dn)=" ++ (showGhc (fn,dn))- return (FN fn,DN dn)-- 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- -- logm $ "hsFreeAndDeclaredGhc.pat.SigPatIn:p=" ++ showGhc _p- -- logm $ "hsFreeAndDeclaredGhc.pat.SigPatIn:(fdp,(FN fb,DN db))=" ++ show (fdp,(FN fb,DN db))-#if __GLASGOW_HASKELL__ > 704- return $ fdp <> (FN fb,DN [])-#else- return $ fdp <> (FN _db,DN [])-#endif- pat (GHC.SigPatOut (GHC.L _ p) _) = pat p- pat (GHC.CoPat _ p _) = pat p-- pat p = error $ "hsFreeAndDeclaredGhc.pat:unimplemented:" ++ (showGhc p)-- -- HsConDetails (LPat id) (HsRecFields id (LPat id))- 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- -- error $ "hsFreeAndDeclaredGhc.pat:unimplemented:" ++ (showGhc recf)- -- error $ "hsFreeAndDeclaredGhc.pat:unimplemented:" ++ (SYB.showData SYB.Renamer 0 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.HsRecField _ (GHC.L _ arg) _) -> arg) fields- fds <- mapM pat args- return $ mconcat fds-- -- -------------------------#if __GLASGOW_HASKELL__ > 704- bndrs :: GHC.HsWithBndrs (GHC.LHsType GHC.Name) -> RefactGhc (FreeNames,DeclaredNames)- bndrs (GHC.HsWB (GHC.L _ thing) _kindVars _typeVars) = do- (_ft,DN dt) <- hsFreeAndDeclaredGhc thing- -- logm $ "hsFreeAndDeclaredGhc.bndrs (_ft,dt)=" ++ show (_ft,DN dt)- return (FN dt,DN [])-#endif-- -- ------------------------- 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])-#if __GLASGOW_HASKELL__ > 704- ltydecl (GHC.L _ (GHC.TyDecl (GHC.L _ n) _bndrs _defn fvs))- = return (FN (GHC.nameSetToList fvs),DN [n])-#else- ltydecl (GHC.L _ (GHC.TyData _ _ctx (GHC.L _ n) _vars _pats _kind _cons _derivs)) - = return (FN [],DN [n]) -- TODO: calc fvs for cons- ltydecl (GHC.L _ (GHC.TySynonym (GHC.L _ n) _vars _pats _rhs))- = return (FN [],DN [n]) -- TODO fvs?-#endif-#if __GLASGOW_HASKELL__ > 704- ltydecl (GHC.L _ (GHC.ClassDecl _ctx (GHC.L _ n) _tyvars- _fds _sigs meths ats atds _docs fvs)) = do-#else- ltydecl (GHC.L _ (GHC.ClassDecl _ctx (GHC.L _ n) _tyvars- _fds _sigs meths ats atds _docs)) = do-#endif- -- (_,td) <- hsFreeAndDeclaredGhc tyvars- (_,md) <- hsFreeAndDeclaredGhc meths- (_,ad) <- hsFreeAndDeclaredGhc ats- (_,atd) <- hsFreeAndDeclaredGhc atds-#if __GLASGOW_HASKELL__ > 704- return (FN (GHC.nameSetToList fvs),DN [n] <> md <> ad <> atd)-#else- return (FN [],DN [n] <> md <> ad <> atd) -- TODO: fvs-#endif--#if __GLASGOW_HASKELL__ > 704- lfaminstdecls :: [GHC.LFamInstDecl GHC.Name] -> RefactGhc (FreeNames,DeclaredNames)- lfaminstdecls ds = do- fds <- mapM hsFreeAndDeclaredGhc ds- return $ mconcat fds-#endif--#if __GLASGOW_HASKELL__ > 704- 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.nameSetToList fvs), DN [n])-#else- -- lfaminstdecl (GHC.L _ (GHC.InstDecl typ binds sigs decls))-#endif-- -- ------------------------- 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-- -- ------------------------- 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--#if __GLASGOW_HASKELL__ > 704- expr ((GHC.HsLamCase _ mg)) = hsFreeAndDeclaredGhc mg-#endif-- 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.Missing _) = []- bb (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--#if __GLASGOW_HASKELL__ > 704- expr ((GHC.HsMultiIf _typ rhs))- = hsFreeAndDeclaredGhc rhs-#endif-- 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 _typ 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.HsBracketOut 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.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 e = error $ "hsFreeAndDeclaredGhc.expr: unimplemented for"- -- ++ (SYB.showData SYB.Renamer 0 e)-- -- ------------------------- name :: GHC.Name -> RefactGhc (FreeNames,DeclaredNames)- name n = return (FN [],DN [n])-- -- ------------------------ lstmts :: [GHC.LStmt GHC.Name] -> RefactGhc (FreeNames,DeclaredNames)- lstmts ss = recurseList ss--- lstmt :: GHC.LStmt 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.ExprStmt e _ _ _)) = hsFreeAndDeclaredGhc e- lstmt (GHC.L _ (GHC.LetStmt bs)) = hsFreeAndDeclaredGhc bs-#if __GLASGOW_HASKELL__ > 704- lstmt (GHC.L _ (GHC.ParStmt ps _ _)) = hsFreeAndDeclaredGhc ps-#else- lstmt (GHC.L _ (GHC.ParStmt ps _ _ _)) = hsFreeAndDeclaredGhc ps-#endif- 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 _ fvs _) = return (FN (GHC.nameSetToList fvs),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-#if __GLASGOW_HASKELL__ > 704- hstype (GHC.HsTyLit _) = return emptyFD-#endif- hstype (GHC.HsWrapTy _ typ) = hsFreeAndDeclaredGhc typ--- -- ------------------------- grhs_s :: [GHC.LGRHS GHC.Name] -> RefactGhc (FreeNames,DeclaredNames)- grhs_s gs = recurseList gs-- -- ------------------------- grhs :: GHC.LGRHS 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] -> RefactGhc (FreeNames,DeclaredNames)- grhsss gs = recurseList gs-- -- ------------------------- grhss :: GHC.GRHSs 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 -> RefactGhc (FreeNames,DeclaredNames)- matchgroup (GHC.MatchGroup matches _) = recurseList matches-- -- ------------------------- lmatches :: [GHC.LMatch GHC.Name] -> RefactGhc (FreeNames,DeclaredNames)- lmatches ms = recurseList ms-- -- ------------------------- lmatch :: GHC.LMatch GHC.Name -> RefactGhc (FreeNames,DeclaredNames)- lmatch (GHC.L _ _m@(GHC.Match pats _ rhs)) = do- -- logm $ "hsFreeAndDeclaredGhc.lmatch for:" ++ (showGhc _m)- (fp,DN dp) <- recurseList pats- -- logm $ "hsFreeAndDeclaredGhc.lmatch pats done"- (FN fr,DN dr) <- hsFreeAndDeclaredGhc rhs- -- logm $ "hsFreeAndDeclaredGhc.lmatch:(fp,dp)=" ++ (show (fp,DN dp))- -- logm $ "hsFreeAndDeclaredGhc.lmatch:fdr=" ++ (showGhc (fr,dr))- let r = (fp,DN []) <> (FN (fr \\ (dr ++ dp)), DN [])- -- logm $ "hsFreeAndDeclaredGhc.lmatch end:r=" ++ (show r)- 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 = error $ "hsFreeAndDeclaredGhc:not matched:" ++ (SYB.showData SYB.Renamer 0 t)-- -- ----------------------------------- recurseList xs = do- fds <- mapM hsFreeAndDeclaredGhc xs- return $ mconcat fds---- -------------------------------------------------------------------------- -----------------------------------------------------------------------{--inRnM2 :: GHC.HscEnv -> GHC.GlobalRdrEnv -> GHC.TcRn r -> IO (GHC.Messages, Maybe r)-inRnM2 hsc_env glbRdrEnv fn = do- let ictxt = (GHC.hsc_IC hsc_env) { GHC.ic_rn_gbl_env = glbRdrEnv }- GHC.initTcPrintErrors hsc_env GHC.iNTERACTIVE $ setInteractiveContext hsc_env ictxt fn---inRnM :: GHC.HscEnv -> GHC.GlobalRdrEnv {- -> GHC.Module -} -> GHC.TcRn r -> IO (GHC.Messages, Maybe r)-inRnM hsc_env glbRdrEnv {- modu -} fn = do- GHC.initTc hsc_env GHC.HsSrcFile True GHC.iNTERACTIVE fn--}--- initTc :: HscEnv -> HscSource -> Bool -> Module -> TcM r -> IO (Messages, Maybe r)-{---- inRnM3 :: GHC.HscEnv -> GHC.GlobalRdrEnv -> GHC.LocalRdrEnv -> GHC.TcRnIf GHC.GlobalRdrEnv GHC.LocalRdrEnv a -> IO a-inRnM3 :: GHC.HscEnv -> GHC.TcGblEnv -> GHC.TcRn a -> IO (GHC.Messages,Maybe a)-inRnM3 hsc_env glbRdrEnv do_this = do-- errs_var <- newIORef (GHC.emptyBag, GHC.emptyBag) ;- meta_var <- newIORef GHC.initTyVarUnique ;- tvs_var <- newIORef GHC.emptyVarSet ;- -- keep_var <- newIORef GHC.emptyNameSet ;- -- used_rdr_var <- newIORef Set.empty ;- -- th_var <- newIORef False ;- -- th_splice_var<- newIORef False ;- -- infer_var <- newIORef True ;- lie_var <- newIORef GHC.emptyWC ;- -- dfun_n_var <- newIORef GHC.emptyOccSet ;-{-- type_env_var <- case hsc_type_env_var hsc_env of {- Just (_mod, te_var) -> return te_var ;- Nothing -> newIORef emptyNameEnv } ;--}-- let lcl_env = GHC.TcLclEnv {- GHC.tcl_errs = errs_var,- GHC.tcl_loc = GHC.mkGeneralSrcSpan (GHC.fsLit "Top level"),- GHC.tcl_ctxt = [],- GHC.tcl_rdr = GHC.emptyLocalRdrEnv,- -- GHC.tcl_rdr = localRdrEnv- GHC.tcl_th_ctxt = GHC.topStage,- GHC.tcl_arrow_ctxt = GHC.NoArrowCtxt,- GHC.tcl_env = GHC.emptyNameEnv,- GHC.tcl_tidy = GHC.emptyTidyEnv,- GHC.tcl_tyvars = tvs_var,- GHC.tcl_lie = lie_var,- GHC.tcl_meta = meta_var,- GHC.tcl_untch = GHC.initTyVarUnique- }-- -- putStrLn $ "inRnM3: about to do it"-- maybe_res <- GHC.initTcRnIf 'a' hsc_env glbRdrEnv lcl_env $- do { r <- GHC.tryM do_this- ; case r of- Right res -> return (Just res)- Left _ -> return Nothing } ;- putStrLn $ "inRnM3: done"-- -- Collect any error messages- msgs <- readIORef errs_var ;-- let { dflags = GHC.hsc_dflags hsc_env- ; final_res | GHC.errorsFound dflags msgs = Nothing- | otherwise = maybe_res } ;-- return (msgs,final_res)--}--- initTcRnIf :: Char -> HscEnv -> gbl -> lcl -> TcRnIf gbl lcl a -> IO a--- type TcRn a = TcRnIf TcGblEnv TcLclEnv a--- ------------------------------------------------------------------------- | 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 = 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 ||- stripForestLineFromGhc lp == stripForestLineFromGhc 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 = somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` lname) t-- lname :: (GHC.Located b) -> (Maybe (GHC.Located b))- lname p@(GHC.L lp _)- | lp == l ||- stripForestLineFromGhc lp == stripForestLineFromGhc 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 = 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 ||- stripForestLineFromGhc lp == stripForestLineFromGhc l = Just p- lname _ = Nothing---- -----------------------------------------------------------------------getDeclaredTypes :: GHC.LTyClDecl GHC.Name -> [GHC.Name]-getDeclaredTypes (GHC.L _ (GHC.ForeignType (GHC.L _ n) _)) = [n]-getDeclaredTypes (GHC.L _ (GHC.TyFamily _ (GHC.L _ n) _bs _)) = [n]-#if __GLASGOW_HASKELL__ > 704-getDeclaredTypes (GHC.L _ (GHC.TyDecl (GHC.L _ n) _vars defn _fvs)) = nub $ [n] ++ dsn- where- dsn = getHsTyDefn defn-#else--- data,-getDeclaredTypes (GHC.L _ (GHC.TyData _ _ctx (GHC.L _ n) _vars _pats _kind cons _derivs)) - = nub $ [n] ++ cs- where- getConDecl (GHC.L _ (GHC.ConDecl (GHC.L _ n2) _ _ _ _ _ _ _)) = n2- cs = map getConDecl cons--- synonym-getDeclaredTypes (GHC.L _ (GHC.TySynonym (GHC.L _ n) _vars _pats _rhs)) = [n]-#endif-#if __GLASGOW_HASKELL__ > 704-getDeclaredTypes (GHC.L _ (GHC.ClassDecl _ (GHC.L _ n) _vars _fds sigs meths ats _atdefs _ _fvs))-#else-getDeclaredTypes (GHC.L _ (GHC.ClassDecl _ (GHC.L _ n) _vars _fds sigs meths ats _atdefs _))-#endif- = 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 _)) = []-- ssn = concatMap getLSig sigs- msn = getDeclaredVars $ hsBinds meths- asn = concatMap getDeclaredTypes ats---- ---------------------------------------#if __GLASGOW_HASKELL__ > 704-getHsTyDefn :: GHC.HsTyDefn GHC.Name -> [GHC.Name]-getHsTyDefn (GHC.TySynonym _) = []-getHsTyDefn (GHC.TyData _ _ _ _ cons _) = r- where- getConDecl (GHC.L _ (GHC.ConDecl (GHC.L _ n) _ _ _ _ _ _ _)) = n- r = map getConDecl cons-#endif---- --------------------------------------{--getDeclaredTyVarBndrs :: [GHC.LHsTyVarBndrs GHC.Name] -> [GHC.Name]-getDeclaredTyVarBndrs bs = r- where- go-- r = []--}--- ------------------------------------------------------------------------ |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.nameSetToList fvs)- binds (GHC.L _ (GHC.PatBind _p _rhs _ty fvs _)) = (GHC.nameSetToList fvs)- binds _ = []--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 _ = []------------------------------------------------------------------------------------- | Same as `hsVisiblePNs' except that the returned identifiers are--- in String format.-hsVisibleNames:: (FindEntity t1, SYB.Data t1, SYB.Data t2,HsValBinds t2,GHC.Outputable t1)- => t1 -> t2 -> RefactGhc [String]-hsVisibleNames e t = do- d <- hsVisiblePNs 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 [].-hsVisiblePNsOld :: (FindEntity e, SYB.Data e, SYB.Data t,HsValBinds t)- => e -> t -> [GHC.Name]-hsVisiblePNsOld e t = res- where- {- -}- r = (applyTU (full_tdTUGhc (constTU [] `adhocTU` top- `adhocTU` expr- `adhocTU` decl- `adhocTU` match- `adhocTU` stmts)) t) :: Maybe [GHC.Name]- {- -}-{-- r <- SYB.everythingStaged SYB.Renamer (++) []- ([] `SYB.mkQ` top- `SYB.extQ` expr- `SYB.extQ` decl- `SYB.extQ` match- `SYB.extQ` stmts) t--}- res = fromMaybe [] r- -- where- top :: (MonadPlus m) => GHC.RenamedSource -> m [GHC.Name]- top ((groups,_,_,_) :: GHC.RenamedSource)- | findEntity e (GHC.hs_valds groups) = do -- ++AZ++:TODO: Should be GHC.HsValBinds GHC.Name, not groups- let (_df,dd) = hsFreeAndDeclaredPNs (GHC.hs_valds groups)- return dd- top _ = return []-- expr ((GHC.HsLet decls e1) :: GHC.HsExpr GHC.Name)- |findEntity e e1 || findEntity e decls = do- let (_df,dd) = hsFreeAndDeclaredPNs decls- return dd-- expr ((GHC.HsDo _ctx ss _) :: GHC.HsExpr GHC.Name)- | findEntity e ss = do- let (_df,dd) = hsFreeAndDeclaredPNs ss- return dd-- expr _ = return []-- decl ((GHC.FunBind n _ matches _ _fvs _) :: GHC.HsBind GHC.Name)- |findEntity e matches = do- let (_pf,pd) = hsFreeAndDeclaredPNs matches- return (pd)-- decl ((GHC.PatBind pat rhs _ _ _) :: GHC.HsBind GHC.Name)- |findEntity e rhs = do- let (_pf,pd) = hsFreeAndDeclaredPNs pat- let (_df,dd) = hsFreeAndDeclaredPNs rhs- return (pd `union` dd)- decl _ = return []-- -- Pick up from HsAlt etc- match ((GHC.Match pats _ rhs) :: GHC.Match GHC.Name)- |findEntity e rhs = do- let (_pf,pd) = hsFreeAndDeclaredPNs pats- let (_df,dd) = hsFreeAndDeclaredPNs rhs- return (pd `union` dd)- match _ = return []-- stmts ((GHC.LetStmt binds) :: GHC.Stmt GHC.Name)- | findEntity e binds = do- let (_df,dd) = hsFreeAndDeclaredPNs binds- return dd-- stmts ((GHC.BindStmt pat rhs _ _) :: GHC.Stmt GHC.Name)- | findEntity e rhs = do- let (_df,dd) = hsFreeAndDeclaredPNs pat- return dd-- stmts _ = return []--}--{- ++ original ++--- | Given syntax phrases e and t, if e occurs in t, then return those vairables--- which are declared in t and accessible to e, otherwise return [].-hsVisiblePNs :: (Term t1, Term t2, FindEntity t1, MonadPlus m) => t1 -> t2 -> m [PName]-hsVisiblePNs e t =applyTU (full_tdTU (constTU [] `adhocTU` mod- `adhocTU` exp- `adhocTU` match- `adhocTU` patBind- `adhocTU` alt- `adhocTU` stmts)) t- where- mod ((HsModule loc modName exps imps decls)::HsModuleP)- |findEntity e decls- =do (df,dd)<-hsFreeAndDeclaredPNs decls- return dd- mod _=return []-- exp ((Exp (HsLambda pats body))::HsExpP)- |findEntity e body- = do (pf,pd) <-hsFreeAndDeclaredPNs pats- return pd-- exp (Exp (HsLet decls e1))- |findEntity e e1 || findEntity e decls- = do (df,dd)<- hsFreeAndDeclaredPNs decls- return dd- exp _ =return []-- match (m@(HsMatch _ (PNT fun _ _) pats rhs decls)::HsMatchP)- |findEntity e rhs || findEntity e decls- = do (pf,pd) <- hsFreeAndDeclaredPNs pats- (df,dd) <- hsFreeAndDeclaredPNs decls- return (pd `union` dd `union` [fun])- match _=return []-- patBind (p@(Dec (HsPatBind _ pat rhs decls))::HsDeclP)- |findEntity e rhs || findEntity e decls- =do (pf,pd) <- hsFreeAndDeclaredPNs pat- (df,dd) <- hsFreeAndDeclaredPNs decls- return (pd `union` dd)- patBind _=return []-- alt ((HsAlt _ pat exp decls)::HsAltP)- |findEntity e exp || findEntity e decls- = do (pf,pd) <- hsFreeAndDeclaredPNs pat- (df,dd) <- hsFreeAndDeclaredPNs decls- return (pd `union` dd)- alt _=return []-- stmts ((HsGenerator _ pat exp stmts) :: HsStmtP)- |findEntity e stmts- =do (pf,pd) <-hsFreeAndDeclaredPNs pat- return pd-- stmts (HsLetStmt decls stmts)- |findEntity e decls || findEntity e stmts- =do (df,dd) <-hsFreeAndDeclaredPNs decls- return dd- stmts _ =return []---}------------------------------------------------------------------------------ | 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, SYB.Data e, SYB.Data t,HsValBinds t,GHC.Outputable e)- => e -> t -> RefactGhc [GHC.Name]-hsVisiblePNs e t = do- (DN dn) <- hsVisibleDs e t- return dn------------------------------------------------------------------------------ | 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, SYB.Data e, SYB.Data t,HsValBinds t,GHC.Outputable e)- => 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` 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- tfds <- hsVisibleDs e $ GHC.hs_tyclds g- ifds <- hsVisibleDs e $ GHC.hs_instds g- 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.MatchGroup 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) -> RefactGhc DeclaredNames- lmatch (GHC.L _ (GHC.Match pats _mtyp rhs))- | findEntity e pats = do- logm $ "hsVisibleDs.lmatch:in pats="- return (DN []) -- TODO: extend this- | findEntity e rhs = do- ( 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) -> RefactGhc DeclaredNames- grhss (GHC.GRHSs guardedRhss lstmts)- | findEntity e guardedRhss = do- fds <- mapM (hsVisibleDs e) guardedRhss- return $ mconcat fds- | findEntity e lstmts = hsVisibleDs e lstmts- grhss _ = return (DN [])-- lgrhs :: GHC.LGRHS GHC.Name -> RefactGhc DeclaredNames- lgrhs (GHC.L _ (GHC.GRHS stmts ex))- | findEntity e stmts = hsVisibleDs e stmts- | 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.e1:" ++ (showGhc (e1,_eOp,e2))- (FN efs,_) <- hsFreeAndDeclaredGhc expr- (FN _eefs,DN eeds) <- hsFreeAndDeclaredGhc e- -- return (DN e1fs <> DN eofs <> DN e2fs)- return (DN (efs \\ eeds))-- lexpr _ = 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- fds <- mapM (hsVisibleDs e) tcds- return $ mconcat fds- tycldecls _ = return (DN [])-- tycldecl :: GHC.LTyClDecl GHC.Name -> RefactGhc DeclaredNames- tycldecl tcd- | findEntity e tcd = do- (_,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-#if __GLASGOW_HASKELL__ > 704- instdecl (GHC.L _ (GHC.ClsInstD polytyp binds sigs faminsts))-#else- instdecl (GHC.L _ (GHC.InstDecl polytyp binds sigs faminsts))-#endif- | findEntity e polytyp = hsVisibleDs e polytyp- | findEntity e binds = hsVisibleDs e binds- | findEntity e sigs = hsVisibleDs e sigs- | findEntity e faminsts = hsVisibleDs e faminsts- instdecl _ = return (DN [])-- lhstype :: GHC.LHsType GHC.Name -> RefactGhc DeclaredNames- lhstype tv@(GHC.L _ (GHC.HsTyVar n))- | findEntity e tv = return (DN [n])- lhstype _ = 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)---- ------------------------------------------------------------------------ TODO:Drive parts of the renamer to pull out free variables--- See GHC source for TcRnDriver.tcRnDeclsi--- driverRenamer = do---- =======================================================================--- This next section is taken from the GHC compiler (7.6.3), as it is--- not all exposed in the GHC API.--- The intention is to use it as a reference, and put in a stripped--- down one doing only what we need.---{--tcRnDeclsi :: GHC.HscEnv- -> GHC.InteractiveContext- -> [GHC.LHsDecl GHC.RdrName]- -> IO (GHC.Messages, Maybe GHC.TcGblEnv)--tcRnDeclsi hsc_env ictxt local_decls =- -- ictxt = GHC.emptyInteractiveContext- GHC.initTcPrintErrors hsc_env GHC.iNTERACTIVE $- setInteractiveContext hsc_env ictxt $ do-- ((tcg_env, tclcl_env), lie) <-- GHC.captureConstraints $ tc_rn_src_decls GHC.emptyModDetails local_decls- GHC.setEnvs (tcg_env, tclcl_env) $ do-- new_ev_binds <- GHC.simplifyTop lie- GHC.failIfErrsM- let GHC.TcGblEnv { GHC.tcg_type_env = type_env,- GHC.tcg_binds = binds,- GHC.tcg_sigs = sig_ns,- GHC.tcg_ev_binds = cur_ev_binds,- GHC.tcg_imp_specs = imp_specs,- GHC.tcg_rules = rules,- GHC.tcg_vects = vects,- GHC.tcg_fords = fords } = tcg_env- all_ev_binds = cur_ev_binds `GHC.unionBags` new_ev_binds-- (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects')- <- GHC.zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords-- let --global_ids = map globaliseAndTidyId bind_ids- final_type_env = GHC.extendTypeEnvWithIds type_env bind_ids --global_ids- tcg_env' = tcg_env { GHC.tcg_binds = binds',- GHC.tcg_ev_binds = ev_binds',- GHC.tcg_imp_specs = imp_specs',- GHC.tcg_rules = rules',- GHC.tcg_vects = vects',- GHC.tcg_fords = fords' }-- tcg_env'' <- GHC.setGlobalTypeEnv tcg_env' final_type_env-- return tcg_env''----- ------------------------ From GHC TcRnDriver--setInteractiveContext :: GHC.HscEnv -> GHC.InteractiveContext -> GHC.TcRn a -> GHC.TcRn a-setInteractiveContext hsc_env icxt thing_inside- = let -- Initialise the tcg_inst_env with instances from all home modules.- -- This mimics the more selective call to hptInstances in tcRnImports- (home_insts, home_fam_insts) = GHC.hptInstances hsc_env (\_ -> True)- (ic_insts, ic_finsts) = GHC.ic_instances icxt-- -- Note [GHCi temporary Ids]- -- Ideally we would just make a type_env from ic_tythings- -- and ic_sys_vars, adding in implicit things. However, Ids- -- bound interactively might have some free type variables- -- (RuntimeUnk things), and if we don't register these free- -- TyVars as global TyVars then the typechecker will try to- -- quantify over them and fall over in zonkQuantifiedTyVar.- --- -- So we must add any free TyVars to the typechecker's global- -- TyVar set. This is what happens when the local environment- -- is extended, so we use tcExtendGhciEnv below which extends- -- the local environment with the Ids.- --- -- However, any Ids bound this way will shadow other Ids in- -- the GlobalRdrEnv, so we have to be careful to only add Ids- -- which are visible in the GlobalRdrEnv.- --- -- Perhaps it would be better to just extend the global TyVar- -- list from the free tyvars in the Ids here? Anyway, at least- -- this hack is localised.- --- -- Note [delete shadowed tcg_rdr_env entries]- -- We also *delete* entries from tcg_rdr_env that we have- -- shadowed in the local env (see above). This isn't strictly- -- necessary, but in an out-of-scope error when GHC suggests- -- names it can be confusing to see multiple identical- -- entries. (#5564)- --- (tmp_ids, types_n_classes) = GHC.partitionWith sel_id (GHC.ic_tythings icxt)- where sel_id (GHC.AnId id) = Left id- sel_id other = Right other-- type_env = GHC.mkTypeEnvWithImplicits- (map GHC.AnId (GHC.ic_sys_vars icxt) ++ types_n_classes)-- visible_tmp_ids = filter visible tmp_ids- where visible id = not (null (GHC.lookupGRE_Name (GHC.ic_rn_gbl_env icxt)- (GHC.idName id)))-- con_fields = [ (GHC.dataConName c, GHC.dataConFieldLabels c)- | GHC.ATyCon t <- types_n_classes- , c <- GHC.tyConDataCons t ]- in- GHC.updGblEnv (\env -> env {- GHC.tcg_rdr_env = GHC.delListFromOccEnv (GHC.ic_rn_gbl_env icxt)- (map GHC.getOccName visible_tmp_ids)- -- Note [delete shadowed tcg_rdr_env entries]- , GHC.tcg_type_env = type_env- , GHC.tcg_insts = ic_insts- , GHC.tcg_inst_env = GHC.extendInstEnvList- (GHC.extendInstEnvList (GHC.tcg_inst_env env) ic_insts)- home_insts- , GHC.tcg_fam_insts = ic_finsts- , GHC.tcg_fam_inst_env = GHC.extendFamInstEnvList- (GHC.extendFamInstEnvList (GHC.tcg_fam_inst_env env)- ic_finsts)- home_fam_insts- , GHC.tcg_field_env = GHC.RecFields (GHC.mkNameEnv con_fields)- (GHC.mkNameSet (concatMap snd con_fields))- -- setting tcg_field_env is necessary to make RecordWildCards work- -- (test: ghci049)- , GHC.tcg_fix_env = GHC.ic_fix_env icxt- , GHC.tcg_default = GHC.ic_default icxt- }) $-- GHC.tcExtendGhciEnv visible_tmp_ids $ -- Note [GHCi temporary Ids]- thing_inside--}--- -----------------------{--rnTopSrcDecls :: [GHC.Name] -> GHC.HsGroup GHC.RdrName -> GHC.TcM (GHC.TcGblEnv, GHC.HsGroup GHC.Name)--- Fails if there are any errors-rnTopSrcDecls extra_deps group- = do { -- Rename the source decls- GHC.traceTc "rn12" GHC.empty ;- (tcg_env, rn_decls) <- GHC.checkNoErrs $ GHC.rnSrcDecls extra_deps group ;- GHC.traceTc "rn13" GHC.empty ;-- -- save the renamed syntax, if we want it- let { tcg_env'- | Just grp <- GHC.tcg_rn_decls tcg_env- = tcg_env{ GHC.tcg_rn_decls = Just (GHC.appendGroups grp rn_decls) }- | otherwise- = tcg_env };-- -- Dump trace of renaming part- rnDump (GHC.ppr rn_decls) ;-- return (tcg_env', rn_decls)- }---checkMain :: GHC.TcM GHC.TcGblEnv--- If we are in module Main, check that 'main' is defined.-checkMain- = do { tcg_env <- GHC.getGblEnv ;- dflags <- GHC.getDynFlags ;- check_main dflags tcg_env- }--check_main :: GHC.DynFlags -> GHC.TcGblEnv -> GHC.TcM GHC.TcGblEnv-check_main dflags tcg_env- | mod /= main_mod- = GHC.traceTc "checkMain not" (GHC.ppr main_mod GHC.<+> GHC.ppr mod) >>- return tcg_env-- | otherwise- = do { mb_main <- GHC.lookupGlobalOccRn_maybe main_fn- -- Check that 'main' is in scope- -- It might be imported from another module!- ; case mb_main of {- Nothing -> do { GHC.traceTc "checkMain fail" (GHC.ppr main_mod GHC.<+> GHC.ppr main_fn)- ; complain_no_main- ; return tcg_env } ;- Just main_name -> do-- { GHC.traceTc "checkMain found" (GHC.ppr main_mod GHC.<+> GHC.ppr main_fn)- ; let loc = GHC.srcLocSpan (GHC.getSrcLoc main_name)- ; ioTyCon <- GHC.tcLookupTyCon GHC.ioTyConName- ; res_ty <- GHC.newFlexiTyVarTy GHC.liftedTypeKind- ; main_expr- <- GHC.addErrCtxt mainCtxt $- GHC.tcMonoExpr (GHC.L loc (GHC.HsVar main_name)) (GHC.mkTyConApp ioTyCon [res_ty])-- -- See Note [Root-main Id]- -- Construct the binding- -- :Main.main :: IO res_ty = runMainIO res_ty main- ; run_main_id <- GHC.tcLookupId GHC.runMainIOName- ; let { root_main_name = GHC.mkExternalName GHC.rootMainKey GHC.rOOT_MAIN- (GHC.mkVarOccFS (GHC.fsLit "main"))- (GHC.getSrcSpan main_name)- ; root_main_id = GHC.mkExportedLocalId root_main_name- (GHC.mkTyConApp ioTyCon [res_ty])- ; co = GHC.mkWpTyApps [res_ty]- ; rhs = GHC.nlHsApp (GHC.mkLHsWrap co (GHC.nlHsVar run_main_id)) main_expr- ; main_bind = GHC.mkVarBind root_main_id rhs }-- ; return (tcg_env { GHC.tcg_main = Just main_name,- GHC.tcg_binds = GHC.tcg_binds tcg_env- `GHC.snocBag` main_bind,- GHC.tcg_dus = GHC.tcg_dus tcg_env- `GHC.plusDU` GHC.usesOnly (GHC.unitFV main_name)- -- Record the use of 'main', so that we don't- -- complain about it being defined but not used- })- }}}- where- mod = GHC.tcg_mod tcg_env- main_mod = GHC.mainModIs dflags- main_fn = getMainFun dflags-- complain_no_main | GHC.ghcLink dflags == GHC.LinkInMemory = return ()- | otherwise = GHC.failWithTc noMainMsg- -- In interactive mode, don't worry about the absence of 'main'- -- In other modes, fail altogether, so that we don't go on- -- and complain a second time when processing the export list.-- mainCtxt = GHC.ptext (GHC.sLit "When checking the type of the") GHC.<+> pp_main_fn- noMainMsg = GHC.ptext (GHC.sLit "The") GHC.<+> pp_main_fn- GHC.<+> GHC.ptext (GHC.sLit "is not defined in module") GHC.<+> GHC.quotes (GHC.ppr main_mod)- pp_main_fn = ppMainFn main_fn--}--{--rnDump :: GHC.SDoc -> GHC.TcRn ()--- Dump, with a banner, if -ddump-rn-rnDump doc = do { GHC.dumpOptTcRn GHC.Opt_D_dump_rn (GHC.mkDumpDoc "Renamer" doc) }--ppMainFn :: GHC.RdrName -> GHC.SDoc-ppMainFn main_fn- | main_fn == GHC.main_RDR_Unqual- = GHC.ptext (GHC.sLit "function") GHC.<+> GHC.quotes (GHC.ppr main_fn)- | otherwise- = GHC.ptext (GHC.sLit "main function") GHC.<+> GHC.quotes (GHC.ppr main_fn)---- | Get the unqualified name of the function to use as the \"main\" for the main module.--- Either returns the default name or the one configured on the command line with -main-is-getMainFun :: GHC.DynFlags -> GHC.RdrName-getMainFun dflags = case (GHC.mainFunIs dflags) of- Just fn -> GHC.mkRdrUnqual (GHC.mkVarOccFS (GHC.mkFastString fn))- Nothing -> GHC.main_RDR_Unqual--}--- ========================================================================----------------------------------------------------------------------------{- ++ replaced by usedWithoutQualR--- | Return True if the identifier is unqualifiedly used in the given--- syntax phrase.-usedWithoutQual :: (SYB.Data t) => GHC.Name -> t -> RefactGhc Bool-usedWithoutQual name renamed = do- logm $ "usedWithoutQual:name=" ++ (showGhc (name,GHC.nameUnique name))- -- logm $ "usedWithoutQual:t=" ++ (SYB.showData SYB.Renamer 0 renamed)- let names = findAllNameOccurences name renamed- logm $ "usedWithoutQual:names=" ++ (showGhc names)-- -- let allNames = findAllNames renamed- -- logm $ "usedWithoutQual:allNames=" ++ (showGhc $ map (\(GHC.L _ n) -> (n,GHC.nameUnique n)) allNames)-- toks <- fetchToks- res <- mapM (isUsedWithoutQual toks) names- return $ or res- where- isUsedWithoutQual toks (GHC.L l _) = do- logm ("usedWithoutQual") -- ++AZ++ debug- let (_,s) = ghead "usedWithoutQual" $ getToks (getGhcLoc l, getGhcLocEnd l) toks- return $ not $ elem '.' s--}--{- ++original++--- | Return True if the identifier is unqualifiedly used in the given--- syntax phrase.-usedWithoutQual :: (SYB.Data t) => GHC.Name -> t -> RefactGhc Bool-usedWithoutQual name renamed = do- logm $ "usedWithoutQual:name=" ++ (showGhc name)- -- logm $ "usedWithoutQual:t=" ++ (SYB.showData SYB.Renamer 0 renamed)- case res of- Just (GHC.L l _) -> do- logm ("usedWithoutQual") -- ++AZ++ debug- toks <- fetchToks-- let (_,s) = ghead "usedWithoutQual" $ getToks (getGhcLoc l, getGhcLocEnd l) toks- return $ not $ elem '.' s- Nothing -> return False- where- res = somethingStaged SYB.Renamer Nothing- (Nothing `SYB.mkQ` worker- `SYB.extQ` workerBind- `SYB.extQ` workerExpr- ) renamed-- worker (pname :: GHC.Located GHC.Name) =- checkName pname-- workerBind (GHC.L l (GHC.VarPat n) :: (GHC.Located (GHC.Pat GHC.Name))) =- checkName (GHC.L l n)- workerBind _ = Nothing-- workerExpr ((GHC.L l (GHC.HsVar n)) :: (GHC.Located (GHC.HsExpr GHC.Name)))- = checkName (GHC.L l n)- workerExpr _ = Nothing-- -- ------------------ checkName (pname@(GHC.L _l pn)::GHC.Located GHC.Name)- | ((GHC.nameUnique pn) == (GHC.nameUnique name)) &&- isUsedInRhs pname renamed = Just pname- checkName _ = 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 = 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 pname parsed &&- isUsedInRhs (GHC.L l name) parsed &&- GHC.isUnqual pn = Just True- checkName _ = Nothing-- {-- =(fromMaybe False) (applyTU (once_tdTU (failTU `adhocTU` worker)) t)- where- worker (pnt::PNT)- |pNTtoName pnt ==name && isUsedInRhs pnt t && not (isQualifiedPN (pNTtoPN pnt)) - = Just True- worker _ =Nothing- -}---- -------------------------------------------------------------------------- |`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- -- (f,d) = fromMaybe ([],[]) $ hsFDsFromInside' t- -- res = (nub f, nub d)-- -- hsFDsFromInside' :: (SYB.Data t) => t -> Maybe ([GHC.Name],[GHC.Name])- 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') = fromMaybe ([],[]) r1- 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-- {- decls (ds::[HsDeclP]) --CHECK THIS.- = hsFreeAndDeclaredPNs decls--}- -- Match [LPat id] (Maybe (LHsType id)) (GRHSs id)- match :: GHC.Match GHC.Name -> RefactGhc ([GHC.Name],[GHC.Name])- match ((GHC.Match pats _type rhs):: GHC.Match 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.MatchGroup 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.MatchGroup matches _)) :: GHC.HsExpr GHC.Name) =- hsFreeAndDeclaredPNs matches-- expr ((GHC.HsCase e (GHC.MatchGroup matches _)) :: GHC.HsExpr GHC.Name) =- do- (ef,_) <- hsFreeAndDeclaredPNs e- (df,dd) <- hsFreeAndDeclaredPNs matches- return (nub (df `union` (ef \\ dd)), nub dd)-- -- expr _ = return ([],[])- expr _ = mzero-- stmts ((GHC.BindStmt pat e1 e2 e3) :: GHC.Stmt 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) =- hsFreeAndDeclaredPNs binds-- -- stmts _ = return ([],[])- stmts _ = mzero---- -------{--hsFDsFromInside:: (Term t, MonadPlus m)=> t-> m ([PName],[PName])-hsFDsFromInside t = do (f,d)<-hsFDsFromInside' t- return (nub f, nub d)- where- hsFDsFromInside' = applyTU (once_tdTU (failTU `adhocTU` mod- -- `adhocTU` decls- `adhocTU` decl- `adhocTU` match- `adhocTU` exp- `adhocTU` alt- `adhocTU` stmts ))--- mod ((HsModule loc modName exps imps ds)::HsModuleP)- = hsFreeAndDeclaredPNs ds-- {- decls (ds::[HsDeclP]) --CHECK THIS.- = hsFreeAndDeclaredPNs decls--}- match ((HsMatch loc1 (PNT fun _ _) pats rhs ds) ::HsMatchP)- = do (pf, pd) <-hsFreeAndDeclaredPNs pats- (rf, rd) <-hsFreeAndDeclaredPNs rhs- (df, dd) <-hsFreeAndDeclaredPNs ds- return (nub (pf `union` ((rf `union` df) \\ (dd `union` pd `union` [fun]))), - nub (pd `union` rd `union` dd `union` [fun]))-- decl ((TiDecorate.Dec (HsPatBind loc p rhs ds))::HsDeclP)- = do (pf, pd)<-hsFreeAndDeclaredPNs p- (rf, rd)<-hsFreeAndDeclaredPNs rhs- (df, dd)<-hsFreeAndDeclaredPNs ds- return (nub (pf `union` ((rf `union` df) \\ (dd `union` pd))),- nub ((pd `union` rd `union` dd)))-- decl (TiDecorate.Dec (HsFunBind loc matches))- =do fds <-mapM hsFDsFromInside matches- return (nub (concatMap fst fds), nub(concatMap snd fds))-- decl _ = mzero-- exp ((TiDecorate.Exp (HsLet decls exp))::HsExpP)- = do (df,dd)<- hsFreeAndDeclaredPNs decls- (ef,_)<- hsFreeAndDeclaredPNs exp- return (nub (df `union` (ef \\ dd)), nub dd)- exp (TiDecorate.Exp (HsLambda pats body))- = do (pf,pd) <-hsFreeAndDeclaredPNs pats- (bf,_) <-hsFreeAndDeclaredPNs body- return (nub ((bf `union` pf) \\ pd), nub pd)- exp _ = mzero-- alt ((HsAlt _ pat exp decls)::HsAltP)- = do (pf,pd) <- hsFreeAndDeclaredPNs pat- (ef,ed) <- hsFreeAndDeclaredPNs exp- (df,dd) <- hsFreeAndDeclaredPNs decls- return (nub (pf `union` (((ef \\ dd) `union` df) \\ pd)), nub (pd `union` dd)) -- stmts ((HsLetStmt decls stmts)::HsStmtP)- = do (df,dd) <-hsFreeAndDeclaredPNs decls- (sf,sd) <-hsFreeAndDeclaredPNs stmts- return (nub (df `union` (sf \\dd)),[]) -- dd)-- stmts (HsGenerator _ pat exp stmts)- = do (pf,pd) <-hsFreeAndDeclaredPNs pat- (ef,ed) <-hsFreeAndDeclaredPNs exp- (sf,sd) <-hsFreeAndDeclaredPNs stmts- return (nub (pf `union` ef `union` (sf\\pd)),[]) -- pd)-- 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)--- hsFDNamesFromInside::(Term t, MonadPlus m)=>t->m ([String],[String])--- hsFDNamesFromInside t =do (f,d)<-hsFDsFromInside t--- return ((nub.map pNtoName) f, (nub.map pNtoName) d)----- ------------------------------------------------------------------------ | 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)]---- ------------------------------------------------------------------------- |Get all the names in the given syntax element-hsNamess :: (SYB.Data t) => t -> [GHC.Name]--- hsNamess t = (nub.ghead "hsNamess") res-hsNamess t = nub $ concat res- where- res = SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` inName) t-- inName (pname :: GHC.Name) = return [pname]----{---- | Collect the identifiers (in PNT format) in a given syntax phrase.-hsPNTs ::(Term t)=>t->[PNT]-hsPNTs =(nub.ghead "hsPNTs").applyTU (full_tdTU (constTU [] `adhocTU` inPnt))- where- inPnt pnt@(PNT _ _ _) = return [pnt]--}---------------------------------------------------------------------------------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--- isLocalPN (PN i (UniqueNames.S _)) = True--- isLocalPN _ = False---- |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 qualified PName.-isQualifiedPN::PName->Bool-isQualifiedPN (PN (Qual mod id) _)=True-isQualifiedPN _ =False---- |Return True if an PNT is a toplevel PNT.-isTopLevelPNT::PNT->Bool-isTopLevelPNT = isTopLevelPN.pNTtoPN--}---- |Return True if a PName is a function\/pattern name defined in t.-isFunOrPatName::(SYB.Data t) => GHC.Name -> t -> Bool-isFunOrPatName pn- =isJust.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` worker)- where- -- worker (decl::HsDeclP)- worker (decl::GHC.LHsBind GHC.Name)- | defines pn decl = Just True- worker _ = Nothing--{---- |Return True if a PNT is a function name defined in t.-isFunPNT::(Term t)=>PNT -> t -> Bool-isFunPNT pnt t = isFunName (pNTtoPN pnt) t--isFunName::(Term t)=>PName->t->Bool-isFunName pn- =isJust.(applyTU (once_tdTU (failTU `adhocTU` worker)))- where- worker (decl::HsDeclP)- | isFunBind decl && defines pn decl =Just True- worker _ =Nothing---- |Return True if a PName is a pattern name defined in t.-isPatName::(Term t)=>PName->t->Bool-isPatName pn- =isJust.(applyTU (once_tdTU (failTU `adhocTU` worker)))- where- worker (decl::HsDeclP)- | isPatBind decl && 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--{--isQualifiedPN' :: GHC.Name -> Bool-isQualifiedPN' name = GHC.isQual $ GHC.nameRdrName name--}--{-- = case (GHC.nameModule_maybe name) of- Just _ -> True- _ -> False--}--{---- | Return True if a PNT is a type constructor.-isTypeCon :: PNT -> Bool-isTypeCon (PNT pn (Type typeInfo) _) = defType typeInfo == Just TypedIds.Data-isTypeCon _ = False---- | Return True if a declaration is a type signature declaration.-isTypeSig ::HsDeclP->Bool-isTypeSig (TiDecorate.Dec (HsTypeSig loc is c tp))=True-isTypeSig _=False--}---- | Return True if a declaration is a type signature declaration.--- isTypeSig ::HsDeclP->Bool--- isTypeSig (TiDecorate.Dec (HsTypeSig loc is c tp))=True-isTypeSig :: GHC.Located (GHC.Sig a) -> Bool-isTypeSig (GHC.L _ (GHC.TypeSig _ _)) = True-isTypeSig _ = 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.-isSimplePatBind :: (SYB.Data t) => GHC.LHsBind t-> Bool-isSimplePatBind decl = case decl of- (GHC.L _l (GHC.PatBind p _rhs _ty _fvs _)) -> hsPNs p /= []- _ -> False--- isSimplePatBind :: HsDeclP -> Bool--- isSimplePatBind 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 but not a simple one.-isComplexPatBind::GHC.LHsBind GHC.Name -> Bool-isComplexPatBind decl = case decl of- (GHC.L _l (GHC.PatBind p _rhs _ty _fvs _)) -> patToPNT p /= Nothing- _ -> 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--{---- | Return True if a declaration is a Class declaration.-isClassDecl :: HsDeclP ->Bool-isClassDecl (TiDecorate.Dec (HsClassDecl _ _ _ _ _)) = True-isClassDecl _ = False---- | Return True if a declaration is a Class instance declaration.-isInstDecl :: HsDeclP -> Bool-isInstDecl (TiDecorate.Dec (HsInstDecl _ _ _ _ _)) = True-isInstDecl _ = False--}-{---- | Return True if a function is a directly recursive function.-isDirectRecursiveDef::HsDeclP->Bool-isDirectRecursiveDef (TiDecorate.Dec (HsFunBind loc ms))- = any isUsedInDef ms- where- isUsedInDef (HsMatch loc1 fun pats rhs ds)- = findEntity (pNTtoPN fun) rhs-isDirectRecursiveDef _ = False--}----------------------------------------------------------------------------------{- ++AZ++ This class is being removed-{- | The HsDecls class -}-class (SYB.Data t) => HsDecls t where-- -- | Return the declarations that are directly enclosed in the- -- given syntax phrase.- hsDecls :: t -> [HsDeclP]-- -- | Replace the directly enclosed declaration list by the given- -- declaration list. Note: This function does not modify the- -- token stream.- -- replaceDecls :: t -> HsDeclsP -> t -- ++AZ++ TODO: what are HsDeclsP?-- -- | Return True if the specified identifier is declared in the- -- given syntax phrase.- isDeclaredIn :: PName -> t -> Bool--instance HsDecls GHC.ParsedSource where- hsDecls (GHC.L _ (GHC.HsModule _ _ _ ds _ _)) = ds-- isDeclaredIn pn (GHC.L _ (GHC.HsModule _ _ _ ds _ _))- = length (definingDecls [pn] ds False False) /= 0-++AZ++ end -}--{---- | Replace the directly enclosed declaration list by the given--- declaration list. Note: This function does not modify the--- token stream.-replaceDecls :: [GHC.LHsBind GHC.Name] -> [GHC.LHsBind GHC.Name] -> [GHC.LHsBind GHC.Name]-replaceDecls t decls = decls--}--{--Note re ValBindsOut in the GHC source-- | ValBindsOut -- After renaming RHS; idR can be Name or Id- [(RecFlag, LHsBinds idL)] -- Dependency analysed, later bindings- -- in the list may depend on earlier- -- ones.- [LSig Name]--}--{--getValBinds :: GHC.HsValBinds t -> [GHC.LHsBind t]-getValBinds binds = case binds of- GHC.ValBindsIn binds _sigs -> GHC.bagToList binds- GHC.ValBindsOut rbinds _sigs -> GHC.bagToList $ GHC.unionManyBags $ map (\(_,b) -> b) rbinds--}--getValBindSigs :: GHC.HsValBinds GHC.Name -> [GHC.LSig GHC.Name]-getValBindSigs binds = case binds of- GHC.ValBindsIn _ sigs -> sigs- GHC.ValBindsOut _ sigs -> sigs--emptyValBinds :: GHC.HsValBinds GHC.Name-emptyValBinds = GHC.ValBindsIn (GHC.listToBag []) []--unionBinds :: [GHC.HsValBinds GHC.Name] -> GHC.HsValBinds GHC.Name-unionBinds [] = emptyValBinds-unionBinds [x] = x-unionBinds (x1:x2:xs) = unionBinds ((mergeBinds x1 x2):xs)- where- mergeBinds :: GHC.HsValBinds GHC.Name -> GHC.HsValBinds GHC.Name -> GHC.HsValBinds GHC.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 b1 s1) (GHC.ValBindsIn b2 s2) = (GHC.ValBindsOut (b1++[(GHC.NonRecursive,b2)]) (s1++s2))---- NOTE: ValBindsIn are found before the Renamer, ValBindsOut after--hsBinds :: (HsValBinds t) => t -> [GHC.LHsBind GHC.Name]-hsBinds t = case hsValBinds t of- GHC.ValBindsIn binds _sigs -> GHC.bagToList binds- GHC.ValBindsOut bs _sigs -> concatMap (\(_,b) -> GHC.bagToList b) bs--replaceBinds :: (HsValBinds t) => t -> [GHC.LHsBind GHC.Name] -> t--- replaceBinds t bs = replaceValBinds t (GHC.ValBindsIn (GHC.listToBag bs) [])-replaceBinds t bs = replaceValBinds t (GHC.ValBindsIn (GHC.listToBag bs) sigs)- where- sigs = case hsValBinds t of- GHC.ValBindsIn _ s -> s- GHC.ValBindsOut _ s -> s---- This class replaces the HsDecls one-class (SYB.Data t) => HsValBinds t where-- -- | Return the binds that are directly enclosed in the- -- given syntax phrase.- -- hsValBinds :: t -> [GHC.LHsBind GHC.Name]- hsValBinds :: t -> GHC.HsValBinds GHC.Name-- -- | Replace the directly enclosed bind list by the given- -- bind list. Note: This function does not modify the- -- token stream.- -- replaceBinds :: t -> [GHC.LHsBind GHC.Name] -> t- replaceValBinds :: t -> GHC.HsValBinds GHC.Name -> t-- -- | Return True if the specified identifier is declared in the- -- given syntax phrase.- -- isDeclaredIn :: GHC.Name -> t -> Bool-- -- | 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 GHC.Name]]---- ++AZ++ see if we can get away with one only..-isDeclaredIn :: (HsValBinds t) => GHC.Name -> t -> Bool-isDeclaredIn name t = nonEmptyList $ definingDeclsNames [name] (hsBinds t) False True---instance HsValBinds (GHC.RenamedSource) where- hsValBinds (grp,_,_,_) = (GHC.hs_valds grp)-- replaceValBinds (grp,imps,exps,docs) binds = (grp',imps,exps,docs)- where- grp' = grp {GHC.hs_valds = binds}-- hsTyDecls (grp,_,_,_) = (GHC.hs_tyclds grp)---instance HsValBinds (GHC.HsValBinds GHC.Name) where- hsValBinds vb = vb- replaceValBinds _old new = new- hsTyDecls _ = []--instance HsValBinds (GHC.HsGroup GHC.Name) where- hsValBinds grp = (GHC.hs_valds grp)-- replaceValBinds (GHC.HsGroup b t i d f de fo w a r v doc) binds- = (GHC.HsGroup b' t i d f de fo w a r v doc)- where b' = replaceValBinds b binds-- hsTyDecls _ = []--instance HsValBinds (GHC.HsLocalBinds GHC.Name) where- hsValBinds lb = case lb of- GHC.HsValBinds b -> b- GHC.HsIPBinds _ -> emptyValBinds- GHC.EmptyLocalBinds -> emptyValBinds-- replaceValBinds (GHC.HsValBinds _b) new = (GHC.HsValBinds new)- replaceValBinds (GHC.HsIPBinds _b) _new = error "undefined replaceValBinds HsIPBinds"- replaceValBinds (GHC.EmptyLocalBinds) new = (GHC.HsValBinds new)-- hsTyDecls _ = []--instance HsValBinds (GHC.GRHSs GHC.Name) where- hsValBinds (GHC.GRHSs _ lb) = hsValBinds lb-- replaceValBinds (GHC.GRHSs rhss b) new = (GHC.GRHSs rhss (replaceValBinds b new))-- hsTyDecls _ = []---- -----------------------------------------------------------------------instance HsValBinds (GHC.MatchGroup GHC.Name) where- hsValBinds (GHC.MatchGroup matches _) = hsValBinds matches-- replaceValBinds (GHC.MatchGroup matches a) newBinds- = (GHC.MatchGroup (replaceValBinds matches newBinds) a)-- hsTyDecls _ = []---- -----------------------------------------------------------------------instance HsValBinds [GHC.LMatch GHC.Name] where- hsValBinds ms = unionBinds $ map (\m -> hsValBinds $ GHC.unLoc m) ms-- replaceValBinds [] _ = error "empty match list in replaceValBinds [GHC.LMatch GHC.Name]"- replaceValBinds ms newBinds = (replaceValBinds (ghead "replaceValBinds" ms) newBinds):(tail ms)-- hsTyDecls _ = []---- -----------------------------------------------------------------------instance HsValBinds (GHC.LMatch GHC.Name) where- hsValBinds m = hsValBinds $ GHC.unLoc m-- replaceValBinds (GHC.L l m) newBinds = (GHC.L l (replaceValBinds m newBinds))-- hsTyDecls _ = []---- ------------------------------------------------------------------------instance HsValBinds (GHC.Match GHC.Name) where- hsValBinds (GHC.Match _ _ grhs) = hsValBinds grhs-- replaceValBinds (GHC.Match p t (GHC.GRHSs rhs _binds)) newBinds- = (GHC.Match p t (GHC.GRHSs rhs binds'))- where- binds' = (GHC.HsValBinds newBinds)-- hsTyDecls _ = []--instance HsValBinds (GHC.HsBind GHC.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 GHC.Name) undefined for:" ++ (showGhc other)-- replaceValBinds (GHC.PatBind p (GHC.GRHSs rhs _binds) typ fvs pt) newBinds- = (GHC.PatBind p (GHC.GRHSs rhs binds') typ fvs pt)- where- binds' = (GHC.HsValBinds newBinds)- replaceValBinds x _newBinds- = error $ "replaceValBinds (GHC.HsBind GHC.Name) undefined for:" ++ (showGhc x)-- hsTyDecls _ = []--instance HsValBinds (GHC.HsExpr GHC.Name) where- hsValBinds (GHC.HsLet ds _) = hsValBinds ds- hsValBinds x = error $ "TypeUtils.hsValBinds undefined for:" ++ showGhc x-- replaceValBinds (GHC.HsLet binds ex) new = (GHC.HsLet (replaceValBinds binds new) ex)- replaceValBinds old _new = error $ "undefined replaceValBinds (GHC.HsExpr GHC.Name) for:" ++ (showGhc old)-- hsTyDecls _ = []--instance HsValBinds (GHC.Stmt GHC.Name) where- hsValBinds (GHC.LetStmt ds) = hsValBinds ds- hsValBinds other = error $ "hsValBinds (GHC.Stmt GHC.Name) undefined for:" ++ (showGhc other)- replaceValBinds (GHC.LetStmt ds) new = (GHC.LetStmt (replaceValBinds ds new))- replaceValBinds old _new = error $ "replaceValBinds (GHC.Stmt GHC.Name) undefined for:" ++ (showGhc old)-- hsTyDecls _ = []---- -----------------------------------------------------------------------instance HsValBinds (GHC.LHsBinds GHC.Name) where- hsValBinds binds = hsValBinds $ GHC.bagToList binds- replaceValBinds old _new = error $ "replaceValBinds (GHC.LHsBinds GHC.Name) undefined for:" ++ (showGhc old)- hsTyDecls _ = []---- -----------------------------------------------------------------------instance HsValBinds (GHC.LHsBind GHC.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--- replaceValBinds (GHC.L l (GHC.FunBind a b matches c d e)) newBinds- = (GHC.L l (GHC.FunBind a b (replaceValBinds matches newBinds) c d e))- replaceValBinds (GHC.L l (GHC.PatBind a rhs b c d)) newBinds- = (GHC.L l (GHC.PatBind a (replaceValBinds rhs newBinds) b c d))- replaceValBinds (GHC.L l (GHC.VarBind a rhs b)) newBinds- = (GHC.L l (GHC.VarBind a (replaceValBinds rhs newBinds) b))- replaceValBinds (GHC.L l (GHC.AbsBinds a b c d binds)) newBinds- = (GHC.L l (GHC.AbsBinds a b c d (replaceValBinds binds newBinds)))-- hsTyDecls _ = []---- -----------------------------------------------------------------------instance HsValBinds ([GHC.LHsBind GHC.Name]) where- -- hsValBinds xs = concatMap hsValBinds xs -- As in original- hsValBinds xs = GHC.ValBindsIn (GHC.listToBag xs) []-- replaceValBinds _old (GHC.ValBindsIn b _sigs) = GHC.bagToList b- replaceValBinds _old (GHC.ValBindsOut rbinds _sigs) = GHC.bagToList $ GHC.unionManyBags $ map (\(_,b) -> b) rbinds-- -- replaceValBinds old new = error ("replaceValBinds (old,new)=" ++ (showGhc (old,new)))-- hsTyDecls _ = []--instance HsValBinds (GHC.LHsExpr GHC.Name) where- hsValBinds (GHC.L _ (GHC.HsLet binds _ex)) = hsValBinds binds- hsValBinds _ = emptyValBinds- replaceValBinds old _new = error $ "replaceValBinds (GHC.LHsExpr GHC.Name) undefined for:" ++ (showGhc old)- hsTyDecls _ = []---- -----------------------------------------------------------------------instance HsValBinds [GHC.LGRHS GHC.Name] where- hsValBinds xs = unionBinds $ map hsValBinds xs- replaceValBinds _old _new = error $ "replaceValBinds [GHC.LGRHS GHC.Name] undefined for:" -- ++ (showGhc old)- hsTyDecls _ = []---- -----------------------------------------------------------------------instance HsValBinds (GHC.LGRHS GHC.Name) where- hsValBinds (GHC.L _ (GHC.GRHS stmts _expr)) = hsValBinds stmts- replaceValBinds _old _new = error $ "replaceValBinds (GHC.LHGRHS GHC.Name) undefined for:" -- ++ (showGhc _old)- hsTyDecls _ = []---- -----------------------------------------------------------------------instance HsValBinds [GHC.LStmt GHC.Name] where- hsValBinds xs = unionBinds $ map hsValBinds xs- replaceValBinds old _new = error $ "replaceValBinds [GHC.LStmt GHC.Name] undefined for:" ++ (showGhc old)- hsTyDecls _ = []---- -----------------------------------------------------------------------instance HsValBinds (GHC.LStmt GHC.Name) where- hsValBinds (GHC.L _ (GHC.LetStmt binds)) = hsValBinds binds- hsValBinds _ = emptyValBinds- replaceValBinds old _new = error $ "replaceValBinds (GHC.LStmt GHC.Name) undefined for:" ++ (showGhc old)- hsTyDecls _ = []---- -----------------------------------------------------------------------instance HsValBinds [GHC.LPat GHC.Name] where- hsValBinds _ = emptyValBinds- replaceValBinds old _new = error $ "replaceValBinds (GHC.LPat GHC.Name) undefined for:" ++ (showGhc old)- hsTyDecls _ = []---- -----------------------------------------------------------------------instance HsValBinds (GHC.LPat GHC.Name) where- hsValBinds _ = emptyValBinds- replaceValBinds old _new = error $ "replaceValBinds (GHC.LPat GHC.Name) undefined for:" ++ (showGhc old)- hsTyDecls _ = []---- -----------------------------------------------------------------------instance HsValBinds (GHC.Name) where- hsValBinds _ = emptyValBinds- replaceValBinds old _new = error $ "replaceValBinds (GHC.Name) undefined for:" ++ (showGhc old)- hsTyDecls _ = []---- -----------------------------------------------------------------------instance HsValBinds [GHC.SyntaxExpr GHC.Name] where- hsValBinds _ = emptyValBinds- replaceValBinds old _new = error $ "replaceValBinds (GHC.SyntaxExpr GHC.Name) undefined for:" ++ (showGhc old)- hsTyDecls _ = []---- -----------------------------------------------------------------------instance HsValBinds [[GHC.LTyClDecl GHC.Name]] where- hsValBinds _ = emptyValBinds- replaceValBinds old _new = error $ "replaceValBinds [[GHC.LTyClDecl GHC.Name]] undefined for:" ++ (showGhc old)- hsTyDecls _ = []---- -----------------------------------------------------------------------instance HsValBinds [GHC.LTyClDecl GHC.Name] where- hsValBinds _ = emptyValBinds- replaceValBinds old _new = error $ "replaceValBinds [GHC.LTyClDecl GHC.Name] undefined for:" ++ (showGhc old)- hsTyDecls _ = []---- -----------------------------------------------------------------------instance HsValBinds (GHC.LTyClDecl GHC.Name) where- hsValBinds _ = error $ "hsValBinds (GHC.LTyClDecl GHC.Name) must pull out tcdMeths"- replaceValBinds old _new = error $ "replaceValBinds (GHC.LTyClDecl GHC.Name) undefined for:" ++ (showGhc old)- hsTyDecls _ = []---- -----------------------------------------------------------------------instance HsValBinds [GHC.LInstDecl GHC.Name] where- hsValBinds _ = emptyValBinds- replaceValBinds old _new = error $ "replaceValBinds [GHC.LInstDecl GHC.Name] undefined for:" ++ (showGhc old)- hsTyDecls _ = []---- -----------------------------------------------------------------------instance HsValBinds (GHC.LInstDecl GHC.Name) where- hsValBinds _ = emptyValBinds- replaceValBinds old _new = error $ "replaceValBinds (GHC.LInstDecl GHC.Name) undefined for:" ++ (showGhc old)- hsTyDecls _ = []---- -----------------------------------------------------------------------instance HsValBinds (GHC.LHsType GHC.Name) where- hsValBinds _ = emptyValBinds- replaceValBinds old _new = error $ "replaceValBinds (GHC.LHsType GHC.Name) undefined for:" ++ (showGhc old)- hsTyDecls _ = []---- -----------------------------------------------------------------------instance HsValBinds [GHC.LSig GHC.Name] where- hsValBinds _ = emptyValBinds- replaceValBinds old _new = error $ "replaceValBinds [GHC.LSig GHC.Name] undefined for:" ++ (showGhc old)- hsTyDecls _ = []---- -----------------------------------------------------------------------instance HsValBinds (GHC.LSig GHC.Name) where- hsValBinds _ = emptyValBinds- replaceValBinds old _new = error $ "replaceValBinds (GHC.LSig GHC.Name) undefined for:" ++ (showGhc old)- hsTyDecls _ = []---- -----------------------------------------------------------------------#if __GLASGOW_HASKELL__ > 704-instance HsValBinds [GHC.LFamInstDecl GHC.Name] where- hsValBinds _ = emptyValBinds- replaceValBinds old _new = error $ "replaceValBinds [GHC.LFamInstDecl GHC.Name] undefined for:" ++ (showGhc old)- hsTyDecls _ = []-#endif---- -----------------------------------------------------------------------#if __GLASGOW_HASKELL__ > 704-instance HsValBinds (GHC.LFamInstDecl GHC.Name) where- hsValBinds _ = emptyValBinds- replaceValBinds old _new = error $ "replaceValBinds (GHC.LFamInstDecl GHC.Name) undefined for:" ++ (showGhc old)- hsTyDecls _ = []-#endif---- -----------------------------------------------------------------------instance HsValBinds (GHC.HsIPBinds GHC.Name) where- hsValBinds _ = emptyValBinds- replaceValBinds old _new = error $ "replaceValBinds (GHC.HsIPBinds GHC.Name) undefined for:" ++ (showGhc old)- hsTyDecls _ = []---- --------------------------------------------------------------------------{--instance HsDecls HsMatchP where- hsDecls (HsMatch loc1 fun pats rhs ds@(Decs x y))=x-- replaceDecls (HsMatch loc1 fun pats rhs ds) ds'- =(HsMatch loc1 fun pats rhs ds')-- isDeclaredIn pn match@(HsMatch loc1 (PNT fun _ _) pats rhs ds)- =fromMaybe False ( do (_,d)<-hsFDsFromInside match- Just (elem pn (d \\ [fun])))-instance HsDecls HsDeclP where- hsDecls (TiDecorate.Dec (HsPatBind loc p rhs ds@(Decs x y)))=x- hsDecls (TiDecorate.Dec (HsFunBind loc matches))=concatMap hsDecls matches- hsDecls _ =[]-- replaceDecls (TiDecorate.Dec (HsPatBind loc p rhs ds)) ds'- =TiDecorate.Dec (HsPatBind loc p rhs ds')- replaceDecls x ds' =x-- isDeclaredIn pn (TiDecorate.Dec (HsPatBind loc p rhs ds))- = fromMaybe False (do (_, rd)<-hsFreeAndDeclaredPNs rhs- (_, dd)<-hsFreeAndDeclaredPNs ds- Just (elem pn (rd `union` dd)))- isDeclaredIn pn _ =False--instance HsDecls HsDeclsP where- hsDecls ds@(Decs x y) = concatMap hsDecls x- replaceDecls ds _ = ds- isDeclaredIn _ ds@(Decs x y) = False--instance HsDecls [HsDeclP] where- hsDecls ds= concatMap hsDecls ds- replaceDecls ds _ = ds -- This should not happen.- isDeclaredIn _ ds = False -- This should not happen.--instance HsDecls HsModuleP where- hsDecls (HsModule loc modName exps imps ds@(Decs x y))=x-- replaceDecls (HsModule loc modName exps imps ds) ds'- = HsModule loc modName exps imps ds'-- isDeclaredIn pn (HsModule loc modName exps imps ds)- =fromMaybe False (do (rf,rd)<-hsFreeAndDeclaredPNs ds- Just (elem pn rd))--instance HsDecls RhsP where- hsDecls rhs=fromMaybe [] (applyTU (stop_tdTU (failTU `adhocTU` inLet- `adhocTU` inAlt- `adhocTU` inStmt)) rhs) - where inLet ((TiDecorate.Exp (HsLet ds@(Decs x y) e)) ::HsExpP)=Just x- inLet _ =mzero-- inAlt ((HsAlt _ p rhs ds@(Decs x y))::HsAlt HsExpP HsPatP HsDeclsP)=Just x-- inStmt ((HsLetStmt ds@(Decs x y) _)::HsStmt HsExpP HsPatP HsDeclsP)=Just x- inStmt _=mzero-- replaceDecls rhs _ = rhs -- This should not happen.- isDeclaredIn _ _ = False -- This should not happen.--instance HsDecls HsExpP where- hsDecls rhs=fromMaybe [] (applyTU (stop_tdTU (failTU `adhocTU` inLet- `adhocTU` inAlt- `adhocTU` inStmt)) rhs)- where inLet ((TiDecorate.Exp (HsLet ds@(Decs x y) e)) ::HsExpP)=Just x- inLet (TiDecorate.Exp (HsListComp (HsLetStmt ds@(Decs x y) stmts)))=Just x- inLet (TiDecorate.Exp (HsDo (HsLetStmt ds@(Decs x y) stmts)))=Just x- inLet _ =Nothing-- inAlt ((HsAlt _ p rhs ds@(Decs x y))::HsAlt HsExpP HsPatP HsDeclsP)=Just x-- inStmt ((HsLetStmt ds@(Decs x y) _)::HsStmt HsExpP HsPatP HsDeclsP)=Just x- inStmt _=Nothing-- replaceDecls (TiDecorate.Exp (HsLet ds e)) ds'- =if ds'== Decs [] ([], [])- then e- else (TiDecorate.Exp (HsLet ds' e))-- replaceDecls (TiDecorate.Exp (HsListComp (HsLetStmt ds stmts))) ds'@(Decs x y)- =if x==[] && isLast stmts- then (TiDecorate.Exp (HsList [fromJust (expInLast stmts)]))- else (TiDecorate.Exp (HsListComp (HsLetStmt ds' stmts)))- where- isLast (HsLast e)=True- isLast _=False-- expInLast (HsLast e)=Just e- expInLast _=Nothing-- replaceDecls (TiDecorate.Exp (HsDo (HsLetStmt ds stmts))) ds'@(Decs x y)- =if x==[]- then (TiDecorate.Exp (HsDo stmts))- else (TiDecorate.Exp (HsDo (HsLetStmt ds' stmts)))- replaceDecls x ds'=x--- isDeclaredIn pn (TiDecorate.Exp (HsLambda pats body))- = fromMaybe False (do (pf,pd) <-hsFreeAndDeclaredPNs pats- Just (elem pn pd))-- isDeclaredIn pn (TiDecorate.Exp (HsLet decls e))- =fromMaybe False (do (df,dd)<- hsFreeAndDeclaredPNs decls- Just (elem pn dd))-- isDeclaredIn pn _=False---instance HsDecls HsStmtP where- hsDecls (HsLetStmt ds@(Decs x y) stmts)=x- hsDecls _ = []-- replaceDecls (HsLetStmt ds stmts) ds'@(Decs x y)- = if x/=[] then HsLetStmt ds' stmts- else stmts-- isDeclaredIn pn (HsGenerator _ pat exp stmts) -- Claus- =fromMaybe False (do (pf,pd) <-hsFreeAndDeclaredPNs pat- Just (elem pn pd))-- isDeclaredIn pn (HsLetStmt decls stmts)- =fromMaybe False (do (df,dd) <-hsFreeAndDeclaredPNs decls- Just (elem pn dd))-- isDeclaredIn pn _=False--instance HsDecls HsAltP where- hsDecls (HsAlt _ p rhs ds@(Decs x y))=x-- replaceDecls (HsAlt loc p rhs ds) ds'=HsAlt loc p rhs ds'-- isDeclaredIn pn (HsAlt _ pat exp decls)- =fromMaybe False ( do (pf,pd) <- hsFreeAndDeclaredPNs pat- (df,dd) <- hsFreeAndDeclaredPNs decls- Just (elem pn (pd `union` dd)))---}---- -----------------------------------------------------------------------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, SYB.Typeable b) => a -> b -> Bool---- -----------------------------------------------------------------------instance FindEntity GHC.Name where-- findEntity n t = fromMaybe False res- where- res = somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t-- worker (name::GHC.Name)- | n == name = Just True- worker _ = Nothing-{-- res = Just $ any (==True) $ catMaybes- $ onelayerStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` hsbind) t- -- res = error $ "findEntity:n:res=" ++ (show $ onelayerStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t)-- hsbind ((GHC.L _ (GHC.FunBind (GHC.L _ n') _ (GHC.MatchGroup matches _) _ _ _))::GHC.Located (GHC.HsBind GHC.Name))- | n' == n || isInMatch = Just True- where- isInMatch = any (==True) $ map (\(GHC.L _ (GHC.Match pats _mtyp _rhs)) -> findPN n pats) matches- hsbind _ = 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 = somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t-- worker (name::GHC.Located GHC.Name)- | n == name = Just True- worker _ = Nothing--{-- res = Just $ any (==True) $ catMaybes- $ onelayerStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` hsbind) t- -- res = error $ "findEntity:ln:res=" ++ (show $ onelayerStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` hsbind) t)-- hsbind ((GHC.L _ (GHC.FunBind n' _ (GHC.MatchGroup matches _) _ _ _))::GHC.Located (GHC.HsBind GHC.Name))- | n' == n || isInMatch = Just True- where- isInMatch = any (==True) $ map (\(GHC.L _ (GHC.Match pats _mtyp _rhs)) -> findPNT n pats) matches- hsbind _ = Nothing--}---- -----------------------------------------------------------------------instance FindEntity (GHC.Located (GHC.HsExpr GHC.Name)) where-- findEntity e t = fromMaybe False res- where- res = somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t-- worker (expr::GHC.Located (GHC.HsExpr 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 = 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 = somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t-- worker (decl::(GHC.Located (GHC.HsDecl GHC.Name)))- | sameOccurrence d decl = Just True- worker _ = Nothing---- -----------------------------------------------------------------------{---- | 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 -> Bool-findEntity a b = fromMaybe False res- where- res = somethingStaged SYB.Parser Nothing worker b-- worker :: (SYB.Typeable b, SYB.Data b) => b -> Maybe Bool- worker b = if SYB.typeOf a == SYB.typeOf b- -- then Just (getStartEndLoc b == getStartEndLoc a)- then Just True -- ++AZ++ test for now- else Nothing--}-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 = somethingStaged SYB.Parser Nothing worker b-- worker :: (SYB.Typeable c,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--{-- worker :: ( SYB.Typeable a{-, SYB.Typeable b-})- => Maybe Bool- -- -> (b -> r)- -> a- -> Maybe Bool- worker a = case SYB.cast a of- Just b -> Just True- Nothing -> r--}---- ------------------------------------------------------------------------- |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))- | defines' ns /= [] = [(GHC.L l (GHC.TypeSig (defines' ns) t))]- inSig _ = []-- defines' (p::[GHC.Located GHC.Name])- = filter (\(GHC.L _ n) -> n `elem` pns) p---- ------------------------------------------------------------------------- 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----- ------------------------------------------------------------------------- | 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) _ _ _ _ _))- = pname == n-defines n (GHC.L _ (GHC.PatBind p _rhs _ty _fvs _))- = elem n (hsNamess p)-defines _ _= 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---- defines::PName->HsDeclP->Bool--- defines pn (GHC.L l (GHC.ValD (GHC.FunBind (GHC.L _ pname) _ _ _ _ _)))--- = PN pname == pn--- defines pn (GHC.L l (GHC.ValD (GHC.PatBind p rhs ty fvs _)))--- = elem pn (hsPNs p)--- defines _ _= 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 pn $ map (\(GHC.L _ n)->n) names-definesTypeSig _ _ =False---{---- | Return True if the declaration defines the type signature of the specified identifier.-isTypeSigOf :: PNT -> HsDeclP -> Bool-isTypeSigOf pnt (TiDecorate.Dec (HsTypeSig loc is c tp))= elem pnt is-isTypeSigOf _ _ =False--}----- | 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]---- TODO: what about GHC.AbsBinds?-definedPNs _ = []--{---- |Return True if the given syntax phrase contains any free variables.-hasFreeVars::(Term t)=>t->Bool-hasFreeVars t = fromMaybe False (do (f,_)<-hsFreeAndDeclaredPNs t- if f/=[] then Just True- else Nothing)--}------------------------------------------------------------------------------------sameBind :: GHC.LHsBind GHC.Name -> GHC.LHsBind GHC.Name -> Bool-sameBind b1 b2 = (definedPNs b1) == (definedPNs b2)-{--sameBind b1 b2 = (definesNames b1) == (definesNames b2)- where- definesNames (GHC.L _ (GHC.PatBind p _rhs _ _ _)) = hsNamess p- definesNames (GHC.L _ (GHC.FunBind (GHC.L _ name) _ _ _ _ _)) = [name]- definesNames (GHC.L _ (GHC.VarBind name _ _)) = [name]--}---- ------------------------------------------------------------------------- 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--instance UsedByRhs GHC.RenamedSource where-- -- Defined like this in the original- usedByRhs _renamed _pns = False- -- usedByRhs renamed pns = usedByRhs (hsValBinds renamed) pns -- ++AZ++--instance UsedByRhs (GHC.LHsBinds GHC.Name) where- usedByRhs binds pns = or $ map (\b -> usedByRhs b pns) $ GHC.bagToList binds--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--instance UsedByRhs (GHC.Match GHC.Name) where- usedByRhs (GHC.Match _ _ rhs) pns = usedByRhs (hsValBinds rhs) pns--instance UsedByRhs [GHC.LHsBind GHC.Name] where- usedByRhs binds pns = or $ map (\b -> usedByRhs b pns) binds--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--instance UsedByRhs (GHC.LHsBind GHC.Name) where- usedByRhs (GHC.L _ bind) pns = usedByRhs bind pns--instance UsedByRhs (GHC.HsExpr GHC.Name) where- usedByRhs (GHC.HsLet _lb e) pns = findPNs pns e- usedByRhs e _pns = error $ "undefined usedByRhs:" ++ (showGhc e)--instance UsedByRhs (GHC.Stmt GHC.Name) where- usedByRhs (GHC.LetStmt lb) pns = findPNs pns lb- usedByRhs s _pns = error $ "undefined usedByRhs:" ++ (showGhc s)--{- ++ original-class (Term t) =>UsedByRhs t where-- usedByRhs:: t->[PName]->Bool--instance UsedByRhs HsExpP where- usedByRhs (Exp (HsLet ds e)) pns = or $ map (flip findPN e) pns--instance UsedByRhs HsAltP where- usedByRhs (HsAlt _ _ rhs _) pns =or $ map (flip findPN rhs) pns--instance UsedByRhs HsStmtP where- usedByRhs (HsLetStmt _ stmt) pns =or $ map (flip findPN stmt) pns--instance UsedByRhs HsMatchP where- usedByRhs (HsMatch loc1 fun pats rhs ds) pns =or $ map (flip findPN rhs) pns--instance UsedByRhs HsDeclP where- usedByRhs (Dec (HsPatBind loc p rhs ds)) pns =or $ map (flip findPN rhs) pns- usedByRhs _ pn=False--instance UsedByRhs HsModuleP where- usedByRhs mod pns=False--}-------------------------------------------------------------------------------------- |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' SYB.Renamer (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' SYB.Parser (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'::(SYB.Data t, SYB.Data a, Eq a,GHC.Outputable a)- =>SYB.Stage- ->SimpPos -- ^ The row and column number- ->t -- ^ The syntax phrase- -> Maybe (GHC.Located a) -- ^ The result-locToName' stage (row,col) t =- if res1 /= Nothing- then res1- else res2- where- res1 = somethingStaged stage Nothing- (Nothing `SYB.mkQ` worker- `SYB.extQ` workerBind- `SYB.extQ` workerExpr- `SYB.extQ` workerLIE- `SYB.extQ` workerHsTyVarBndr- `SYB.extQ` workerLHsType- ) t-- res2 = somethingStaged stage Nothing- (Nothing `SYB.mkQ` workerFunBind) t-- {-- res = reverse $ everythingStaged SYB.Renamer (++) []- ([] `SYB.mkQ` workerFunBind `SYB.extQ` worker `SYB.extQ` workerBind `SYB.extQ` workerExpr) t-- res' = case res of- [] -> Nothing- xs -> Just (head xs)- -}- -- A FunBind has a MatchGroup, which lists all the possible- -- bindings. Hence- -- x 0 = 0- -- x y = 2 * y- -- Will have a single FunBind, with name x and using the- -- specific (GHC.L l GHC.Name) of the x on the first line.- -- Attempting to find the variable x on the second line will- -- fail, it needs to be deduced from a FunBind having more- -- than one match. The Located Match includes the original- -- variable name in the location, but not in the match contents- workerFunBind ((GHC.FunBind pnt _ (GHC.MatchGroup matches _) _ _ _) :: (GHC.HsBindLR a a))- | nonEmptyList match = Just pnt- where- -- match = error $ "locToName':matches=" ++ (showGhc $ map (\(GHC.L l _) -> l) matches)- match = filter inScope (tail matches)- -- match = filter inScope (matches)- workerFunBind _ = Nothing-- worker (pnt :: (GHC.Located a))- | inScope pnt = Just pnt- worker _ = Nothing-- workerBind pnt@(GHC.L l (GHC.VarPat name) :: (GHC.Located (GHC.Pat a)))- | inScope pnt = Just (GHC.L l name)- workerBind _ = Nothing-- workerExpr (pnt@(GHC.L l (GHC.HsVar name)) :: (GHC.Located (GHC.HsExpr a)))- | inScope pnt = Just (GHC.L l name)- workerExpr _ = Nothing-- workerLIE (pnt@(GHC.L l (GHC.IEVar name)) :: (GHC.LIE a))- | inScope pnt = Just (GHC.L l name)- workerLIE _ = Nothing--#if __GLASGOW_HASKELL__ > 704- workerHsTyVarBndr (pnt@(GHC.L l (GHC.UserTyVar name)):: (GHC.LHsTyVarBndr a))-#else- workerHsTyVarBndr (pnt@(GHC.L l (GHC.UserTyVar name _typ)):: (GHC.LHsTyVarBndr a))-#endif- | inScope pnt = Just (GHC.L l name)- workerHsTyVarBndr _ = Nothing-- workerLHsType (pnt@(GHC.L l (GHC.HsTyVar name)):: (GHC.LHsType a))- | inScope pnt = Just (GHC.L l name)- workerLHsType _ = Nothing--- inScope :: GHC.Located e -> Bool- inScope (GHC.L l _) =- case l of- (GHC.UnhelpfulSpan _) -> False- (GHC.RealSrcSpan ss) ->- -- (GHC.srcSpanFile ss == fileName) &&- (GHC.srcSpanStartLine ss <= row) &&- (GHC.srcSpanEndLine ss >= row) &&- (col >= (GHC.srcSpanStartCol ss)) &&- (col <= (GHC.srcSpanEndCol ss))--------------------------------------------------------------------------------------- |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 _ = []---------------------------------------------------------------------------------------- |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 = somethingStaged SYB.Renamer Nothing- (Nothing `SYB.mkQ` worker `SYB.extQ` workerBind `SYB.extQ` workerExpr) t-- worker ((GHC.L _ n) :: (GHC.Located GHC.Name))- | showGhc n == str = Just n- worker _ = Nothing-- workerBind (GHC.L _ (GHC.VarPat name) :: (GHC.Located (GHC.Pat GHC.Name)))- | showGhc name == str = Just name- workerBind _ = Nothing--- workerExpr ((GHC.L _ (GHC.HsVar name)) :: (GHC.Located (GHC.HsExpr GHC.Name)))- | showGhc 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.-{--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--}--{--addItemsToImport::( )- =>ModuleName -- ^ The imported module name.- ->Maybe PName -- ^ The condition identifier.- ->Either [String] [EntSpecP] -- ^ The identifiers to add in either String or EntSpecP format.- ->t -- ^ The given syntax phrase.- ->m t -- ^ The result.--}--{--addItemsToImport::(Term t,MonadState (([PosToken],Bool),t1) m)- =>ModuleName -- ^ The imported module name.- ->Maybe PName -- ^ The condition identifier.- ->Either [String] [EntSpecP] -- ^ The identifiers to add in either String or EntSpecP format.- ->t -- ^ The given syntax phrase.- ->m t -- ^ The result.--addItemsToImport serverModName pn (Left []) t = return t-addItemsToImport serverModName pn (Right []) t = return t-addItemsToImport serverModName pn ids t- =applyTP (full_buTP (idTP `adhocTP` inImport)) t- where- inImport (imp@(HsImportDecl loc m@(SN modName _) qual as h):: HsImportDeclP)- | serverModName == modName && (if isJust pn then findPN (fromJust pn) h else True)- = case h of- Nothing -> return imp- Just (b, ents) -> do let ents'=case ids of- Left is' -> map (\x-> Var (nameToPNT x)) is'- Right es -> es- ((toks,_),others)<-get- let (_,endPos)=getStartEndLoc toks (glast "addItemsToImport" ents)- (t,(_,s))=ghead "addItemsToImport" $ getToks (endPos,endPos) toks- newToken = mkToken t endPos (s++","++showEntities (render.ppi) ents')- toks'=replaceToks toks endPos endPos [newToken]- put ((toks',modified),others)- return (HsImportDecl loc m qual as (Just (b, ents++ents')))- inImport imp = return imp--}---- -----------------------------------------------------------------------addImportDecl ::- GHC.RenamedSource- -> GHC.ModuleName- -> Maybe GHC.FastString -- ^qualifier- -> Bool -> Bool -> Bool- -> Maybe String -- ^alias- -> Bool- -> [GHC.Name]- -> RefactGhc GHC.RenamedSource-addImportDecl (groupedDecls,imp, b, c) modName pkgQual source safe qualify alias hide idNames- = do- toks <- fetchToks- let toks1- =if length imps' > 0- then let (_startLoc, endLoc) = getStartEndLoc $ last imps'- toks1' = getToks ((1,1),endLoc) toks- in toks1'- else if not $ isEmptyGroup groupedDecls- then- let startLoc = fst $ startEndLocIncComments toks groupedDecls- (toks1', _toks2') = break (\t ->tokenPos t==startLoc) toks- in toks1'- else toks-- -- drawTokenTreeDetailed "before starting"- logm $ "addImportDecl:toks =" ++ show toks- logm $ "addImportDecl:toks1=" ++ show toks1-- let lastTok = ghead "addImportDecl" $ dropWhile isWhiteSpace $ reverse toks1- let startPos = tokenPos lastTok- let endPos = tokenPosEnd lastTok-- newToks <- liftIO $ basicTokenise (showGhc impDecl)- logm $ "addImportDecl:newToks=" ++ (show newToks) -- ++AZ++- void $ putToksAfterPos (startPos,endPos) (PlaceOffset 1 0 1) newToks- return (groupedDecls, (imp++[(mkNewLSomething impDecl)]), b, c)- where-- alias' = case alias of- Just stringName -> Just $ GHC.mkModuleName stringName- _ -> Nothing-- impDecl = GHC.ImportDecl {- GHC.ideclName = mkNewLModuleName modName- , 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, map mkNewEnt idNames)))- }- imps' = rmPreludeImports imp-- mkNewLSomething :: a -> GHC.Located a- mkNewLSomething a = (GHC.L l a) where- filename = (GHC.mkFastString "f")- l = GHC.mkSrcSpan (GHC.mkSrcLoc filename 1 1) (GHC.mkSrcLoc filename 1 1)--- mkNewLModuleName :: GHC.ModuleName -> GHC.Located GHC.ModuleName- mkNewLModuleName moduName = mkNewLSomething moduName---- -----------------------------------------------------------------------isEmptyGroup :: GHC.HsGroup id -> Bool-isEmptyGroup x = (==0) $ sum $- [valds, tyclds, instds, derivds, fixds, defds, fords, warnds, annds, ruleds, vects, docs]- where- valds = size $ GHC.hs_valds x-- size :: GHC.HsValBindsLR idL idR -> Int- size (GHC.ValBindsIn lhsBinds sigs) = (length sigs) + (length . GHC.bagToList $ lhsBinds)- size (GHC.ValBindsOut recFlags lsigs) = (length lsigs) + (length recFlags)-- tyclds = length $ GHC.hs_tyclds x-- instds = length $ GHC.hs_instds x-- derivds = length $ GHC.hs_derivds x-- fixds = length $ GHC.hs_fixds x-- defds = length $ GHC.hs_defds x-- fords = length $ GHC.hs_fords x-- warnds = length $ GHC.hs_warnds x-- annds = length $ GHC.hs_annds x-- ruleds = length $ GHC.hs_ruleds x-- vects = length $ GHC.hs_vects x-- docs = length $ GHC.hs_docs x----- | Remove ImportDecl from the imports list, commonly returned from a RenamedSource type, so it can--- be further processed.---rmPreludeImports :: [GHC.Located (GHC.ImportDecl GHC.Name)] -> [GHC.Located (GHC.ImportDecl GHC.Name)]-rmPreludeImports ::- [GHC.Located (GHC.ImportDecl GHC.Name)]- -> [GHC.Located (GHC.ImportDecl GHC.Name)]-rmPreludeImports = filter isPrelude where- isPrelude = (/="Prelude") . GHC.moduleNameString . GHC.unLoc . GHC.ideclName . GHC.unLoc--{-addImportDecl mod@(HsModule _ _ _ imp decls) moduleName qualify alias hide idNames- = do ((toks, _),(v,v1)) <- get- let (toks1, toks2)- =if imps' /= []- then let (startLoc, endLoc) = startEndLocIncComments toks (last imps')- (toks1, toks2)= break (\t->tokenPos t==endLoc) toks- in (toks1 ++ [ghead "addImportDecl1" toks2], tail toks2)- else if decls /=[]- then let startLoc = fst $ startEndLocIncComments toks (ghead "addImportDecl1" decls)- (toks1, toks2) = break (\t ->tokenPos t==startLoc) toks- in (toks1, toks2)- else (toks,[])- before = if toks1/=[] && endsWithNewLn (glast "addImportDecl1" toks1) then "" else "\n"- after = if (toks2 /=[] && startsWithNewLn (ghead "addImportDecl1" toks2)) then "" else "\n"- colOffset = if imps'==[] && decls==[]- then 1- else getOffset toks- $ if imps'/=[] then fst $ startEndLoc toks (ghead "addImportDecl1" imps')- else fst $ startEndLoc toks (ghead "addImportDecl1" decls)- impToks =tokenise (Pos 0 v1 1) (colOffset-1) True- $ before++(render.ppi) impDecl++"\n" ++ after --- refactorer this- (impDecl', _) <- addLocInfo (impDecl,impToks)- let toks' = toks1++impToks++toks2- put ((toks',modified), ((tokenRow (glast "addImportDecl1" impToks) - 10,v1))) -- 10: step ; generalise this.- return (mod {hsModImports = imp ++ [impDecl']})- where- alias' = case alias of- Just m -> Just $ SN (PlainModule m) loc0- _ -> Nothing- impDecl = HsImportDecl loc0 (SN (PlainModule moduleName) loc0) qualify alias'- (if idNames==[] && hide==False- then Nothing- else (Just (hide, map nameToEnt idNames))) -- what about "Main"- imps' = imp \\ prelimps- nameToEnt name = Var (nameToPNT name)-}------ ------------------------------------------------------------------------- |Make a new set of tokens, originating at (0,0), for a given--- declaration and optional signature.--- NOTE: This function returns tokens originating at (0,0), to be--- stitched in at the right place by TokenUtils-makeNewToks :: (GHC.LHsBind GHC.Name, [GHC.LSig GHC.Name], Maybe [PosToken])- -> RefactGhc [PosToken]-makeNewToks (decl, maybeSig, declToks) = do- let- declStr = case declToks of- Just ts -> "\n" ++ (unlines $ dropWhile (\l -> l == "") $ lines $ GHC.showRichTokenStream $ reAlignMarked ts)- Nothing -> "\n"++(prettyprint decl)++"\n\n"- sigStr = case declToks of- Just _ts -> ""- Nothing -> "\n" ++ (intercalate "\n" $ map prettyprint maybeSig)- -- logm $ "makeNewToks:declStr=[" ++ declStr ++ "]"- newToks <- liftIO $ tokenise (realSrcLocFromTok mkZeroToken) 0 True (sigStr ++ declStr)- return newToks---- ------------------------------------------------------------------------- | 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,HsValBinds 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.LHsBind GHC.Name, [GHC.LSig GHC.Name], Maybe [PosToken])- -- ^ The declaration with optional signatures to be added,- -- in both AST and Token stream format (optional). If- -- signature and tokens provided, the tokens should- -- include the signature too- -> Bool -- ^ True means the declaration is a- -- toplevel declaration.- -> RefactGhc t--addDecl parent pn (decl, msig, declToks) topLevel- = if isJust pn- then appendDecl parent (gfromJust "addDecl" pn) (decl, msig, declToks)- else if topLevel- then addTopLevelDecl (decl, msig, declToks) parent- else addLocalDecl parent (decl,msig,declToks)- where-- -- ^Add a definition to the beginning of the definition declaration- -- list, but after the data type declarations if there is any. The- -- definition will be pretty-printed if its token stream is not- -- provided.- addTopLevelDecl :: (SYB.Data t, HsValBinds t)- => (GHC.LHsBind GHC.Name, [GHC.LSig GHC.Name], Maybe [PosToken])- -> t -> RefactGhc t- addTopLevelDecl (newDecl, maybeSig, maybeDeclToks) parent'- = do let binds = hsValBinds parent'- decls = hsBinds parent'- (decls1,decls2) = break (\x->isFunOrPatBindR x {- was || isTypeSig x -}) decls-- newToks <- makeNewToks (newDecl,maybeSig,maybeDeclToks)- logm $ "addTopLevelDecl:newToks=" ++ (show newToks)-- let Just sspan = if (emptyList decls2)- then getSrcSpan (glast "addTopLevelDecl" decls1)- else getSrcSpan (ghead "addTopLevelDecl" decls2)-- decl' <- putDeclToksAfterSpan sspan newDecl (PlaceOffset 2 0 2) newToks-- return (replaceValBinds parent' (GHC.ValBindsIn (GHC.listToBag (decls1++[decl']++decls2)) (maybeSig++(getValBindSigs binds))))-- appendDecl :: (SYB.Data t, HsValBinds t)- => t -- ^Original AST- -> GHC.Name -- ^Name to add the declaration after- -> (GHC.LHsBind GHC.Name, [GHC.LSig GHC.Name], Maybe [PosToken]) -- ^declaration and maybe sig/tokens- -> RefactGhc t -- ^updated AST- appendDecl parent' pn' (newDecl, maybeSig, declToks')- = do let binds = hsValBinds parent'- -- logm $ "appendDecl:declToks=" ++ (show declToks')- newToks <- makeNewToks (newDecl,maybeSig,declToks')- -- logm $ "appendDecl:newToks=" ++ (show newToks)-- let Just sspan = getSrcSpan $ ghead "appendDecl" after- decl' <- putDeclToksAfterSpan sspan newDecl (PlaceOffset 2 0 2) newToks-- let decls1 = before ++ [ghead "appendDecl14" after]- decls2 = gtail "appendDecl15" after- {-- case maybeSig of- Nothing -> return (replaceBinds parent (decls1++[decl']++decls2))- Just sig -> return (replaceValBinds parent (GHC.ValBindsIn (GHC.listToBag (decls1++[decl']++decls2)) (sig:(getValBindSigs binds))))- -}- return (replaceValBinds parent' (GHC.ValBindsIn (GHC.listToBag (decls1++[decl']++decls2)) (maybeSig++(getValBindSigs binds))))- where- decls = hsBinds parent'- (before,after) = break (defines pn') decls -- Need to handle the case that 'after' is empty?--- addLocalDecl :: (SYB.Data t, HsValBinds t)- => t -> (GHC.LHsBind GHC.Name, [GHC.LSig GHC.Name], Maybe [PosToken])- -> RefactGhc t- addLocalDecl parent' (newFun, maybeSig, newFunToks)- =do- let binds = hsValBinds parent'-- let (startLoc,endLoc)- = if (emptyList localDecls)- then getStartEndLoc parent'- else getStartEndLoc localDecls-- newToks <- liftIO $ basicTokenise newSource-- (newFun',_) <- addLocInfo (newFun, newToks)-- let colIndent = if (emptyList localDecls) then 4 else 0- rowIndent = 1-- if (emptyList localDecls)- then- void $ putToksAfterPos (startLoc,endLoc) (PlaceOffset rowIndent colIndent 2) newToks- -- putToksAfterPos (startLoc,endLoc) (PlaceAbsolute (r+1) c) newToks- else- void $ putToksAfterPos (startLoc,endLoc) (PlaceIndent rowIndent colIndent 2) newToks- -- void $ putToksAfterPos (startLoc,endLoc) (PlaceIndent rowIndent colIndent 3) newToks-- {-- case maybeSig of- Nothing -> return (replaceBinds parent ((hsBinds parent ++ [newFun']) ))- Just sig -> return (replaceValBinds parent (GHC.ValBindsIn (GHC.listToBag ((hsBinds parent ++ [newFun']))) (sig:(getValBindSigs binds))))- -}- return (replaceValBinds parent' (GHC.ValBindsIn (GHC.listToBag ((hsBinds parent' ++ [newFun']))) (maybeSig++(getValBindSigs binds))))- where- localDecls = hsBinds parent'-- -- TODO: where tokens are passed in, first normalise them to- -- the left column before adding in the where clause part- newSource = if (emptyList localDecls)- then "where\n"++ concatMap (\l-> " "++l++"\n") (lines newFun')- else ("" ++ newFun'++"\n")- where- newFun' = unlines $ stripLeadingSpaces $ lines $ sigStr ++ newFunBody- newFunBody = case newFunToks of- Just ts -> unlines $ dropWhile (\l -> l == "") $ lines $ GHC.showRichTokenStream $ reAlignMarked ts- Nothing -> prettyprint newFun-- sigStr = case newFunToks of- Just _ts -> ""- {-- Nothing -> case maybeSig of- Just sig -> (prettyprint sig) ++ "\n"- Nothing -> ""- -}- Nothing -> if (emptyList maybeSig)- then ""- else (intercalate "\n" $ map prettyprint maybeSig) ++ "\n"---- ------------------------------------------------------------------------- |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.RenamedSource -- ^ The current module- ->[GHC.Name] -- ^ The items to be added- ->RefactGhc GHC.RenamedSource -- ^ The result (with token stream updated)-addHiding a b c = addItemsToImport' a b c Hide---- | Creates a new entity for hiding a name in an ImportDecl.-mkNewEnt :: GHC.Name -> GHC.LIE GHC.Name-mkNewEnt pn = (GHC.L l (GHC.IEVar pn))- where- filename = (GHC.mkFastString "f")- l = GHC.mkSrcSpan (GHC.mkSrcLoc filename 1 1) (GHC.mkSrcLoc filename 1 1)---- | 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.RenamedSource -- ^ The current module- ->[GHC.Name] -- ^ The items to be added--- ->Maybe GHC.Name -- ^ The condition identifier.- ->RefactGhc GHC.RenamedSource -- ^ The result (with token stream updated)-addItemsToImport a b c = addItemsToImport' a b c 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.RenamedSource -- ^ The current module- ->[GHC.Name] -- ^ 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.RenamedSource -- ^ The result (with token stream updated)-addItemsToImport' serverModName (g,imps,e,d) pns impType = do- imps' <- mapM inImport imps- return (g,imps',e,d)- where- isHide = case impType of- Hide -> True- Import -> False-- inImport :: GHC.LImportDecl GHC.Name -> RefactGhc (GHC.LImportDecl GHC.Name)- inImport imp@(GHC.L _ (GHC.ImportDecl (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, ents) -> insertEnts imp ents False- inImport x = return x-- insertEnts ::- GHC.LImportDecl GHC.Name- -> [GHC.LIE GHC.Name]- -> Bool- -> RefactGhc ( GHC.LImportDecl GHC.Name )- insertEnts imp ents isNew =- if isNew && not isHide then return imp- else do- toks <- fetchToks- let (startPos,endPos) = getStartEndLoc imp- ((GHC.L l t),s) = ghead "addHiding" $ reverse $ getToks (startPos,endPos) toks- start = getGhcLoc l- end = getGhcLocEnd l-- beginning =- if isNew then- s ++ (if isHide then " hiding " else " ")++"("- else ","- ending = if isNew then ")" else s-- newToken=mkToken t start (beginning++showEntities showGhc pns ++ending)- -- toks'=replaceToks toks start end [newToken]- -- toks'=replaceTok toks start newToken-- void $ putToksForPos (start,end) [newToken]-- return (replaceHiding imp (Just (isHide, (map mkNewEnt pns)++ents)))--- replaceHiding (GHC.L l (GHC.ImportDecl mn q src safe isQ isImp as _h)) h1 =- (GHC.L l (GHC.ImportDecl mn q src safe isQ isImp as h1))---- -----------------------------------------------------------------------addParamsToDecls::- [GHC.LHsBind GHC.Name] -- ^ A declaration list where the function is defined and\/or used.- ->GHC.Name -- ^ The function name.- ->[GHC.Name] -- ^ The parameters to be added.- ->Bool -- ^ Modify the token stream or not.- ->RefactGhc [GHC.LHsBind GHC.Name] -- ^ The result.--addParamsToDecls decls pn paramPNames modifyToks = do- logm $ "addParamsToDecls (pn,paramPNames,modifyToks)=" ++ (showGhc (pn,paramPNames,modifyToks))- -- logm $ "addParamsToDecls: decls=" ++ (SYB.showData SYB.Renamer 0 decls)- if (paramPNames/=[])- then mapM addParamToDecl decls- else return decls- where- addParamToDecl :: GHC.LHsBind GHC.Name -> RefactGhc (GHC.LHsBind GHC.Name)- addParamToDecl (GHC.L l1 (GHC.FunBind (GHC.L l2 pname) i (GHC.MatchGroup matches ptt) co fvs t))- | pname == pn- = do matches' <- mapM addParamtoMatch matches- return (GHC.L l1 (GHC.FunBind (GHC.L l2 pname) i (GHC.MatchGroup matches' ptt) co fvs t))- where- -- addParamtoMatch (HsMatch loc fun pats rhs decls)- addParamtoMatch (GHC.L l (GHC.Match pats mtyp rhs))- = do rhs' <- addActualParamsToRhs modifyToks pn paramPNames rhs- let pats' = map GHC.noLoc $ map pNtoPat paramPNames- _pats'' <- if modifyToks- then do -- TODO: What happens if pats is []- -- Will only happen if there is a single match only.- logm $ "addParamtoMatch:l=" ++ (showGhc l)- if emptyList pats- then addFormalParams (Left l2) pats'- else addFormalParams (Right pats) pats'- return pats'-- else return pats'- -- return (HsMatch loc fun (pats'++pats) rhs' decls)- return (GHC.L l (GHC.Match (pats'++pats) mtyp rhs'))-- -- addParamToDecl (TiDecorate.Dec (HsPatBind loc p rhs ds))- addParamToDecl (GHC.L l1 (GHC.PatBind pat@(GHC.L _l2 (GHC.VarPat p)) rhs ty fvs t))- | p == pn- = do _rhs'<-addActualParamsToRhs modifyToks pn paramPNames rhs- let pats' = map GHC.noLoc $ map pNtoPat paramPNames- _pats'' <- if modifyToks then do _ <- addFormalParams (Right [pat]) pats'- return pats'- else return pats'- -- return (TiDecorate.Dec (HsFunBind loc [HsMatch loc (patToPNT p) pats' rhs ds]))- return (GHC.L l1 (GHC.PatBind pat rhs ty fvs t))- addParamToDecl x=return x----- | Add tokens corresponding to the new parameters to the end of the--- syntax element provided-addFormalParams- :: Either GHC.SrcSpan [(GHC.LPat GHC.Name)] -- location: SrcSpan only- -- if no existing params, else list- -- of current params- -> [(GHC.LPat GHC.Name)] -- params to add- -> RefactGhc ()-addFormalParams place newParams- = do- -- logm $ "addFormalParams:(place,newParams):" ++ (SYB.showData SYB.Renamer 0 (place,newParams))- -- newToks <- liftIO $ basicTokenise (prettyprintPatList prettyprint True newParams)- let newStr = (prettyprintPatList prettyprint True newParams)-- case place of- Left l@(GHC.RealSrcSpan ss) -> do- newToks' <- liftIO $ tokenise (GHC.realSrcSpanStart ss) 0 False newStr- let newToks = map markToken newToks'- _ <- putToksAfterSpan l PlaceAdjacent newToks- return ()- Left ss -> error $ "addFormalParams: expecting RealSrcSpan, got:" ++ (showGhc ss)- Right pats -> do- let l = GHC.combineLocs (ghead "addFormalParams" pats) (glast "addFormalParams" pats)- -- logm $ "addFormalParams:(l,pats)=" ++ (SYB.showData SYB.Renamer 0 (l,pats))- toks <- getToksForSpan l-- let oldStr = GHC.showRichTokenStream $ rmOffsetFromToks toks- combinedToks <- liftIO $ tokenise (realSrcLocFromTok- $ ghead "addFormalParams" toks)- 0 False (newStr ++ " " ++ oldStr)-- _ <- putToksForSpan l combinedToks-- return ()-- -- drawTokenTree "after addFormalParams"- -- drawTokenTreeDetailed "after addFormalParams"---- -----------------------------------------------------------------------addActualParamsToRhs :: (SYB.Typeable t, SYB.Data t) =>- Bool -> GHC.Name -> [GHC.Name] -> t -> RefactGhc t-addActualParamsToRhs modifyToks pn paramPNames rhs = do- -- logm $ "addActualParamsToRhs:rhs=" ++ (SYB.showData SYB.Renamer 0 $ rhs)-- -- = applyTP (stop_tdTP (failTP `adhocTP` worker))-- r <- applyTP (stop_tdTPGhc (failTP `adhocTP` grhs)) rhs- -- r <- everywhereMStaged SYB.Renamer (SYB.mkM grhs) rhs- return r- where-- -- |Limit the action to actual RHS elements- grhs :: (GHC.GRHSs GHC.Name) -> RefactGhc (GHC.GRHSs GHC.Name)- grhs (GHC.GRHSs g lb) = do- -- logm $ "addActualParamsToRhs.grhs:g=" ++ (SYB.showData SYB.Renamer 0 g)- g' <- everywhereMStaged SYB.Renamer (SYB.mkM worker) g- return (GHC.GRHSs g' lb)-- worker :: (GHC.Located (GHC.HsExpr GHC.Name)) -> RefactGhc (GHC.Located (GHC.HsExpr GHC.Name))- worker oldExp@(GHC.L l2 (GHC.HsVar pname))- | pname == pn = do- -- logm $ "addActualParamsToRhs:oldExp=" ++ (SYB.showData SYB.Renamer 0 oldExp)- let newExp' = foldl addParamToExp oldExp paramPNames- let newExp = (GHC.L l2 (GHC.HsPar newExp'))- -- TODO: updateToks must add a space at the end of the- -- new exp- if modifyToks then do _ <- updateToks oldExp newExp prettyprint False- return newExp- else return newExp- worker x = return x-- addParamToExp :: (GHC.LHsExpr GHC.Name) -> GHC.Name -> (GHC.LHsExpr GHC.Name)- addParamToExp expr param = GHC.noLoc (GHC.HsApp expr (GHC.noLoc (GHC.HsVar param)))---{--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}))))))))] ---}---{-- addActualParamsToRhs pn paramPNames- = applyTP (stop_tdTP (failTP `adhocTP` worker))- where- worker exp@(TiDecorate.Exp (HsId (HsVar (PNT pname ty loc))))- | pname==pn- = do let newExp=TiDecorate.Exp (HsParen (foldl addParamToExp exp (map pNtoExp paramPNames)))- if modifyToks then do (newExp', _) <- updateToks exp newExp prettyprint- return newExp'- else return newExp- worker x =mzero-- addParamToExp exp param=(TiDecorate.Exp (HsApp exp param))--}------ | Remove those specified items from the entity list in the import declaration.-{-- rmItemsFromImport::( )- =>HsModuleP -- ^ The module AST- ->[PName] -- ^ The items to be removed- ->m HsModuleP -- ^ The result--}--{--rmItemsFromImport::(MonadState (([PosToken],Bool),t1) m)- =>HsModuleP -- ^ The module AST- ->[PName] -- ^ The items to be removed- ->m HsModuleP -- ^ The result---rmItemsFromImport mod pns- = applyTP (full_buTP (idTP `adhocTP` inImport)) mod- where- inImport (imp@(HsImportDecl loc modName qual as h)::HsImportDeclP)- | any (flip findEntity imp) pns- = case h of- Just (b, ents) ->- do let matchedEnts=findEnts pns ents- if matchedEnts==[]- then return imp- else if length matchedEnts == length ents- then do ((toks,_),others)<-get- let (startPos,endPos)=getStartEndLoc toks ents- toks'=deleteToks toks startPos endPos- put ((toks',modified),others)- return (HsImportDecl loc modName qual as (Just (b,[])))- else do ((toks,_),others)<-get- let remainedEnts=concatMap (\pn->filter (not.match pn) ents) pns - toks'=foldl deleteEnt toks $ map (getStartEndLoc toks) matchedEnts- put ((toks',modified),others)- return (HsImportDecl loc modName qual as (Just (b, remainedEnts)))- _ ->return imp- inImport x = return x-- findEnts pns ents =nub $ concatMap (\pn->filter (match pn) ents) pns-- -- this function does not check this sub entities of the ListSubs. any problems?- match::PName -> EntSpec PNT ->Bool- match pn (Var pnt) = pNTtoPN pnt == pn- match pn (Abs pnt) = pNTtoPN pnt == pn- match pn (AllSubs pnt) = pNTtoPN pnt == pn- match pn (ListSubs pnt _) = pNTtoPN pnt == pn--}---{---- | Remove the sub entities of a type constructor or class from the export list.-rmSubEntsFromExport::(MonadState (([PosToken],Bool),(Int,Int)) m)- =>PName -- ^ The type constructor or class name- ->HsModuleP -- ^ The module AST- ->m HsModuleP -- ^ The result-rmSubEntsFromExport typeCon- = applyTP (full_buTP (idTP `adhocTP` inEntSpec))- where- inEntSpec (ent@(AllSubs pnt)::EntSpec PNT)- | pNTtoPN pnt == typeCon- =do (ent', _)<-updateToks ent (Abs pnt) prettyprint- return ent'- inEntSpec (ent@(ListSubs pnt _))- | pNTtoPN pnt == typeCon- = do (ent', _) <- updateToks ent (Abs pnt) prettyprint- return ent'- inEntSpec ent = return ent--}-------------------------------------------------------------------------------------------- | Remove the specified entities from the module's exports. The entities can be specified in either of two formats:--- i.e. either specify the module names and identifier names to be removed, so just given the exact AST for these entities.-{-rmItemsFromExport::( )- =>HsModuleP -- ^ The module AST.- ->Either ([ModuleName],[PName]) [HsExportEntP] -- ^ The entities to remove. - ->m HsModuleP -- ^ The result.--}-{--rmItemsFromExport::(MonadState (([PosToken],Bool),t1) m)- =>HsModuleP -- ^ The module AST.- ->Either ([ModuleName],[PName]) [HsExportEntP] -- ^ The entities to remove.- ->m HsModuleP -- ^ The result.--rmItemsFromExport mod@(HsModule loc modName exps imps ds) (Left (modNames, pns))- =if isNothing exps- then return mod- else do let ents =findEnts (modNames, pns) (fromJust exps)- rmItemsFromExport mod (Right ents)- where- findEnts (modNames, pns) ents- =let ms = concatMap (\m ->filter (\e -> case e of- ModuleE (SN m' _) -> m==m'- EntE e' -> False) ents) modNames- es =concatMap (\pn->filter (\e ->case e of- ModuleE _ -> False- EntE e' -> match pn e') ents) pns- in (ms++es)- match::PName -> EntSpec PNT ->Bool- match pn (Var pnt) = pNTtoPN pnt == pn- match pn (Abs pnt) = pNTtoPN pnt == pn- match pn (AllSubs pnt) = pNTtoPN pnt == pn- match pn (ListSubs pnt _) = pNTtoPN pnt == pn--rmItemsFromExport mod@(HsModule loc modName exps@(Just es) imps ds) (Right ents)- = do exps'<- if ents==[]- then return exps- else if length ents == length es- then do ((toks,_),others)<-get- let (startPos,endPos) = getStartEndLoc toks ents- toks'= deleteToks toks startPos endPos- put ((toks',modified),others)- return (Just [] ) -- should not remove the empty bracket!!!- else do ((toks,_),others)<-get- let toks' = foldl deleteEnt toks $ map (getStartEndLoc toks) ents- put ((toks',modified),others)- return (Just (es \\ ents))- return (HsModule loc modName exps' imps ds)-rmItemsFromExport mod _ = return mod--}---- ------------------------------------------------------------------------- | Duplicate a function\/pattern binding declaration under a new name--- right after the original one. Also updates the token stream.-duplicateDecl::(SYB.Data t) =>- [GHC.LHsBind GHC.Name] -- ^ The declaration list- ->t -- ^ Any signatures are in here- ->GHC.Name -- ^ The identifier whose definition is to be duplicated- ->GHC.Name -- ^ The new name (possibly qualified)- ->RefactGhc [GHC.LHsBind GHC.Name] -- ^ The result-duplicateDecl decls sigs n newFunName- = do- let Just sspan = getSrcSpan funBinding- toks <- getToksForSpan sspan- -- lay <- getLayoutForSpan sspan-- newSpan <- case typeSig of- [] -> return sspan- _ -> do- let Just sspanSig = getSrcSpan typeSig- toksSig <- getToksForSpan sspanSig- -- laySig <- getLayoutForSpan sspanSig-- let colStart = tokenCol $ ghead "duplicateDecl.sig"- $ dropWhile isWhiteSpace toksSig-- typeSig' <- putDeclToksAfterSpan sspan (ghead "duplicateDecl" typeSig) (PlaceAbsCol 2 colStart 0) toksSig- _typeSig'' <- renamePN n newFunName True False typeSig'-- let (GHC.L sspanSig' _) = typeSig'-- return sspanSig'-- let rowOffset = case typeSig of- [] -> 2- _ -> 1-- let colStart = tokenCol $ ghead "duplicateDecl.decl"- $ dropWhile isWhiteSpace toks-- funBinding' <- putDeclToksAfterSpan newSpan (ghead "duplicateDecl" funBinding) (PlaceAbsCol rowOffset colStart 2) toks- funBinding'' <- renamePN n newFunName True False funBinding'-- -- return (typeSig'++funBinding') -- ++AZ++ TODO: reinstate this- return [funBinding'']- where- declsToDup = definingDeclsNames [n] decls True False -- ++AZ++ should recursive be set true?- funBinding = filter isFunOrPatBindR declsToDup --get the fun binding.- typeSig = definingSigsNames [n] sigs---- ------------------------------------------------------------------------- | 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 declaration list.- -> RefactGhc- (t,- GHC.LHsBind GHC.Name,- Maybe (GHC.LSig GHC.Name)) -- ^ The result and the removed- -- declaration, with SrcSpans- -- adjusted to reflect the stashed- -- tokens and the possibly removed- -- siganture-rmDecl pn incSig t = do- logm $ "rmDecl:(pn,incSig)= " ++ (showGhc (pn,incSig)) -- ++AZ++- -- drawTokenTreeDetailed "rmDecl.entry tree" -- ++AZ++ 'in' present- setStateStorage StorageNone- t2 <- everywhereMStaged' SYB.Renamer (SYB.mkM inLet) t -- top down- -- drawTokenTreeDetailed "rmDecl.entry after inLet" -- ++AZ++ 'in' missing- -- drawTokenTree "rmDecl.entry after inLet" -- ++AZ++ 'in' missing- t' <- everywhereMStaged' SYB.Renamer (SYB.mkM inDecls `SYB.extM` inGRHSs) t2 -- top down-- -- applyTP (once_tdTP (failTP `adhocTP` inDecls)) t- -- t' <- everywhereMStaged SYB.Renamer (SYB.mkM inDecls) t- (t'',sig') <- if incSig- then rmTypeSig pn t'- else return (t', Nothing)- storage <- getStateStorage- let decl' = case storage of- StorageBind bind -> bind- x -> error $ "rmDecl: unexpected value in StateStorage:" ++ (show x)- return (t'',decl',sig')- where- inGRHSs ((GHC.GRHSs a localDecls)::GHC.GRHSs GHC.Name)- -- was | not $ emptyList (snd (break (defines pn) decls)) -- /=[]- | not $ emptyList (snd (break (defines pn) (hsBinds localDecls))) -- /=[]- = do- let decls = hsBinds localDecls- -- logm $ "rmDecl:inGRHSs decls=" ++ (SYB.showData SYB.Renamer 0 $ decls)- -- logm $ "rmDecl:inGRHSs localDecls=" ++ (SYB.showData SYB.Renamer 0 $ localDecls)- let (_decls1, decls2) = break (defines pn) decls- decl = ghead "rmDecl" decls2- topLevel <- isTopLevelPN pn- decls' <- case topLevel of- True -> rmTopLevelDecl decl decls- False -> rmLocalDecl decl decls- return (GHC.GRHSs a (replaceBinds localDecls decls'))- inGRHSs x = return x-- inDecls (decls::[GHC.LHsBind GHC.Name])- | not $ emptyList (snd (break (defines pn) decls)) -- /=[]- = do let (_decls1, decls2) = break (defines pn) decls- decl = ghead "rmDecl" decls2- -- error $ (render.ppi) t -- ecl ++ (show decl)- topLevel <- isTopLevelPN pn- case topLevel of- True -> rmTopLevelDecl decl decls- False -> rmLocalDecl decl decls- inDecls x = return x-- inLet :: GHC.LHsExpr GHC.Name -> RefactGhc (GHC.LHsExpr GHC.Name)- inLet (GHC.L ss (GHC.HsLet localDecls expr@(GHC.L l _)))- | not $ emptyList (snd (break (defines pn) (hsBinds localDecls)))- = do- -- putSrcSpan ss -- Make sure the tree includes a SrcSpan for- -- the HsLet, for when it is replaced later-- let decls = hsBinds localDecls- let (decls1, decls2) = break (defines pn) decls- decl = ghead "rmDecl" decls2-- -- drawTokenTreeDetailed "rmDecl.inLet tree" -- ++AZ++ present- toks <- getToksForSpan l- -- drawTokenTreeDetailed "rmDecl.inLet tree" -- ++AZ++ missing- -- toks <- getToksForSpanWithIntros l- removeToksForPos (getStartEndLoc decl)- -- drawTokenTree "rmDecl.inLet after removeToksForPos"- decl' <- syncDeclToLatestStash decl- setStateStorage (StorageBind decl')- -- drawTokenTree "rmDecl.inLet after syncDeclToLatestStash"- case length decls of- 1 -> do -- Removing the last declaration- logm $ "rmDecl.inLet:length decls = 1: expr=" ++ (SYB.showData SYB.Renamer 0 expr)- -- putToksForSpan ss toks- (_,expr') <- putDeclToksForSpan ss expr $ dropWhile (\tok -> isEmpty tok || isIn tok) toks- -- drawTokenTree "rmDecl.inLet after putToksForSpan"- return expr'- _ -> do- logm $ "rmDecl.inLet:length decls /= 1"- -- drawTokenTreeDetailed "rmDecl.inLet tree"- let decls2' = gtail "inLet" decls2- return $ (GHC.L ss (GHC.HsLet (replaceBinds localDecls (decls1 ++ decls2')) expr))-- inLet x = return x--- rmTopLevelDecl :: GHC.LHsBind GHC.Name -> [GHC.LHsBind GHC.Name]- -> RefactGhc [GHC.LHsBind GHC.Name]- rmTopLevelDecl decl decls- =do- logm $ "rmTopLevelDecl:" -- ++AZ++-- removeToksForPos (getStartEndLoc decl)- decl' <- syncDeclToLatestStash decl- setStateStorage (StorageBind decl')-- let (decls1, decls2) = break (defines pn) decls- decls2' = gtail "rmTopLevelDecl 1" decls2- return $ (decls1 ++ decls2')- -- return (decls \\ [decl])-- {- The difference between removing a top level declaration and a- local declaration is: if the local declaration to be removed is- the only declaration in current declaration list, then the 'where'/- 'let'/'in' enclosing this declaration should also be removed. Whereas,- when a only top level decl is removed, the 'where' can not be removed.- -}-- -- |Remove a location declaration that defines pn.- rmLocalDecl :: GHC.LHsBind GHC.Name -> [GHC.LHsBind GHC.Name]- -> RefactGhc [GHC.LHsBind GHC.Name]- rmLocalDecl decl@(GHC.L sspan _) decls- = do-- -- TODO: The let/in version is wrapped in a GHC.HsLet expression.- -- The sspan of HsLet runs from the let keyword to the end of- -- the in clause.- -- (GHC.L l (HsLet (HsLocalBinds id) (LHsExpr id))- -- So we must remove the tokens from the start of l to the- -- start of the LHsExpr-- logm $ "rmLocalDecl: decls=" ++ (showGhc decls)- -- drawTokenTreeDetailed $ "Before getToksForSpan :" ++ (show sspan) -- ++AZ++- prevToks <- getToksBeforeSpan sspan -- Need these before- -- sspan is deleted- removeToksForPos (getStartEndLoc decl)- decl' <- syncDeclToLatestStash decl- setStateStorage (StorageBind decl')-- case length decls of- 1 -> do- -- Get rid of preceding where or let token- -- prevToks <- getToksBeforeSpan sspan- let startPos = getGhcLoc sspan- (_toks1,toks2)=break (\t1->tokenPos t1 < startPos) $ reversedToks prevToks --divide the token stream.- --get the 'where' or 'let' token- rvToks1 = dropWhile (not.isWhereOrLet) toks2- --There must be a 'where' or 'let', so rvToks1 can not be empty.- whereOrLet=ghead "rmLocalDecl:whereOrLet" rvToks1- --drop the 'where' 'or 'let' token-- rmEndPos = tokenPosEnd $ ghead "rmLocalDecl.2" toks2- rmStartPos = tokenPos whereOrLet-- -- logm $ "rmLocalDecl: where/let tokens:" ++ (show (_toks1,toks2)) -- ++AZ++ - logm $ "rmLocalDecl: where/let tokens are at" ++ (show (rmStartPos,rmEndPos)) -- ++AZ++ - removeToksForPos (rmStartPos,rmEndPos)-- return ()- _ -> return ()-- let (decls1, decls2) = break (defines pn) decls- decls2' = gtail "rmLocalDecl 3" 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.Name])- -- ^ 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.Name))- -- ^ The result and removed signature, if there- -- was one-rmTypeSig pn t- = do- -- logm $ "rmTypeSig:t=" ++ (SYB.showData SYB.Renamer 0 t)-- setStateStorage StorageNone- t' <- everywhereMStaged SYB.Renamer (SYB.mkM inSigs) t- storage <- getStateStorage- let sig' = case storage of- StorageSig sig -> Just sig- StorageNone -> Nothing- x -> error $ "rmTypeSig: unexpected value in StateStorage:" ++ (show x)- return (t',sig')- where- inSigs (sigs::[GHC.LSig GHC.Name])- | not $ emptyList (snd (break (definesTypeSig pn) sigs)) -- /=[]- = do- let (decls1,decls2)= break (definesTypeSig pn) sigs- let sig@(GHC.L sspan (GHC.TypeSig names typ)) = ghead "rmTypeSig" decls2- if length names > 1- then do- -- We have the following cases- -- [pn,x..], [..x,pn,y..], [..x,pn]- -- We must handle the commas correctly in- -- all cases- -- so [pn,x..] : take front comma- -- [..x,pn,y..] : take either front or back comma,- -- but only one- -- [..x,pn] : take back comma- let newSig=(GHC.L sspan (GHC.TypeSig (filter (\(GHC.L _ x) -> x /= pn) names) typ))-- toks <- getToksForSpan sspan- logm $ "rmTypeSig: fetched toks:" ++ (show toks) -- ++AZ++- let pnt = ghead "rmTypeSig" (filter (\(GHC.L _ x) -> x == pn) names)- (startPos1, endPos1) =- let (startPos1', endPos1') = getStartEndLoc pnt- in if gfromJust "rmTypeSig" (elemIndex pnt names) == 0- then extendForwards toks (startPos1',endPos1') isComma- else extendBackwards toks (startPos1',endPos1') isComma- toks' = deleteToks toks startPos1 endPos1- void $ putToksForSpan sspan toks'-- -- Construct the old signature, by keeping the- -- signature part but discarding the other names- let oldSig = (GHC.L sspan (GHC.TypeSig [pnt] typ))- sig'@(GHC.L sspan' _) <- syncDeclToLatestStash oldSig- let typeLoc = extendBackwards toks (getStartEndLoc typ) isDoubleColon- let (_,typTok,_) = splitToks typeLoc toks- let (_,pntTok,_) = splitToks (getStartEndLoc pnt) toks- void $ putToksForSpan sspan' (pntTok ++ typTok)- setStateStorage (StorageSig sig')--- return (decls1++[newSig]++tail decls2)- else do- removeToksForSpan sspan- sig' <- syncDeclToLatestStash sig- setStateStorage (StorageSig sig')- return (decls1++tail decls2)- inSigs x = return x--{-- [- (L {test/testdata/LiftToToplevel/PatBindIn1.hs:15:7-14}- (TypeSig- [- (L {test/testdata/LiftToToplevel/PatBindIn1.hs:15:7} {Name: h})] - (L {test/testdata/LiftToToplevel/PatBindIn1.hs:15:12-14}- (HsTyVar {Name: GHC.Types.Int})))),- (L {test/testdata/LiftToToplevel/PatBindIn1.hs:16:7-14}- (TypeSig- [- (L {test/testdata/LiftToToplevel/PatBindIn1.hs:16:7} {Name: t})] - (L {test/testdata/LiftToToplevel/PatBindIn1.hs:16:12-14}- (HsTyVar {Name: GHC.Types.Int})))),- (L {test/testdata/LiftToToplevel/PatBindIn1.hs:17:7-22}- (TypeSig- [- (L {test/testdata/LiftToToplevel/PatBindIn1.hs:17:7-9} {Name: tup})] - (L {test/testdata/LiftToToplevel/PatBindIn1.hs:17:14-22}- (HsTupleTy- (HsBoxedOrConstraintTuple)- [- (L {test/testdata/LiftToToplevel/PatBindIn1.hs:17:15-17}- (HsTyVar {Name: GHC.Types.Int})),- (L {test/testdata/LiftToToplevel/PatBindIn1.hs:17:19-21}- (HsTyVar {Name: GHC.Types.Int}))]))))]--}---- -------------------------------------------------------------------------- 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 =- -- error "undefined rmQualifier"- everywhereMStaged SYB.Renamer (SYB.mkM rename) t- where- rename ((GHC.L l pn)::GHC.Located GHC.Name)- | elem pn pns- = do do -- toks <- fetchToks- -- let toks' = replaceToks toks (row,col) (row,col) [mkToken Varid (row,col) s]- let (rs,_) = break (=='.') $ reverse $ showGhc pn -- ++TODO: replace this with the appropriate formulation- s = reverse rs- {- TODO: reinstate token update if required- let (row,col) = getGhcLoc l- let toks' = replaceToks toks (row,col) (row,col) [mkToken (GHC.ITvarid (GHC.mkFastString s)) (row,col) s]- putToks toks' modified- -}- return (GHC.L l (GHC.mkInternalName (GHC.nameUnique pn) (GHC.mkVarOcc s) l))- rename x = return x---- ------------------------------------------------------------------------- | Replace all occurences of a top level GHC.Name with a qualified version.-qualifyToplevelName :: GHC.Name -> RefactGhc ()-qualifyToplevelName n = do- renamed <- getRefactRenamed- logm $ "qualifyToplevelName:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed)- _ <- renamePN n n True True renamed- return ()---- ------------------------------------------------------------------------- | Rename each occurrences of the identifier in the given syntax--- phrase with the new name. If the Bool parameter is True, then--- modify both the AST and the token stream, otherwise only modify the--- AST.--- 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 modifying the token stream as well.- ->Bool -- ^ True means use the qualified form for- -- the new name.- ->t -- ^ The syntax phrase- ->RefactGhc t-renamePN oldPN newName updateTokens useQual t = do- -- = error $ "renamePN: sspan=" ++ (showGhc sspan) -- ++AZ++- -- logm $ "renamePN': (oldPN,newName)=" ++ (showGhc (oldPN,newName))- logm $ "renamePN: t=" ++ (SYB.showData SYB.Renamer 0 t)- -- Note: bottom-up traversal- let isRenamed = somethingStaged SYB.Renamer Nothing- (Nothing `SYB.mkQ` isRenamedSource `SYB.extQ` isRenamedGroup) t--- t' <- if isRenamed == (Just True)- then- everywhereMStaged SYB.Renamer- (SYB.mkM renameRenamedSource- `SYB.extM` renameGroup- ) t- else- renamePNworker oldPN newName updateTokens useQual t- -- t'' <- adjustLayoutAfterRename oldPN newName t'- return t'- where- isRenamedSource :: GHC.RenamedSource -> Maybe Bool- isRenamedSource (_g,_i,_e,_d) = Just True-- isRenamedGroup :: GHC.HsGroup GHC.Name -> Maybe Bool- isRenamedGroup _g = Just True-- -- ----------------------------------- renameRenamedSource :: GHC.RenamedSource -> RefactGhc GHC.RenamedSource- renameRenamedSource (g,i,e,d) = do- i' <- renamePNworker oldPN newName updateTokens False i- e' <- renamePNworker oldPN newName updateTokens useQual e- return (g,i',e',d)-- renameGroup :: (GHC.HsGroup GHC.Name) -> RefactGhc (GHC.HsGroup GHC.Name)- renameGroup g- = do- logm $ "renamePN:renameGroup"- g' <- renamePNworker oldPN newName updateTokens useQual g- return g'- -- renameGroup x = return x---- ------------------------------------------------------------------------- | Rename each occurrences of the identifier in the given syntax--- phrase with the new name. If the Bool parameter is True, then--- modify both the AST and the token stream, otherwise only modify the--- AST.--- TODO: the syntax phrase is required to be GHC.Located, not sure how--- to specify this without breaking the everywhereMStaged call-renamePNworker::(SYB.Data t)- =>GHC.Name -- ^ The identifier to be renamed.- ->GHC.Name -- ^ The new name, including possible qualifier- ->Bool -- ^ True means modifying the token stream as well.- ->Bool -- ^ True means use the qualified form for- -- the new name.- ->t -- ^ The syntax phrase- ->RefactGhc t-renamePNworker oldPN newName updateTokens useQual t = do- -- logm $ "renamePN: (oldPN,newName)=" ++ (showGhc (oldPN,newName))- -- Note: bottom-up traversal (no ' at end)- everywhereMStaged SYB.Renamer (SYB.mkM rename- -- everywhereMStaged' SYB.Renamer (SYB.mkM rename- `SYB.extM` renameVar- `SYB.extM` renameTyVar- `SYB.extM` renameHsTyVarBndr- `SYB.extM` renameLIE- `SYB.extM` renameLPat- `SYB.extM` renameTypeSig- `SYB.extM` renameFunBind- ) t- where- rename :: (GHC.Located GHC.Name) -> RefactGhc (GHC.Located GHC.Name)- rename (GHC.L l n)- | (GHC.nameUnique n == GHC.nameUnique oldPN)- = do- logm $ "renamePNworker:rename at :" ++ (show l) ++ (showSrcSpanF l)- -- drawTokenTree "before worker" -- ++AZ++ debug- worker useQual l Nothing- return (GHC.L l newName)- rename x = return x-- renameVar :: (GHC.Located (GHC.HsExpr GHC.Name)) -> RefactGhc (GHC.Located (GHC.HsExpr GHC.Name))- renameVar v@(GHC.L l (GHC.HsVar n))- | (GHC.nameUnique n == GHC.nameUnique oldPN)- = do- logm $ "renamePNworker:renameVar at :" ++ (showGhc l)-- -- Get the original qualification, if any- rn <- (getParsedForRenamedLocated v :: RefactGhc (GHC.LHsExpr GHC.RdrName))- let (GHC.L _ (GHC.HsVar mqn)) = rn- let mrnq = GHC.isQual_maybe mqn- logm $ "renamePNworker:renameVar mrn,mrnq :" ++ (showGhc (rn,mrnq))-- worker useQual l mrnq- return (GHC.L l (GHC.HsVar newName))- renameVar x = return x-- -- HsTyVar {Name: Renaming.D1.Tree}))- renameTyVar :: (GHC.Located (GHC.HsType GHC.Name)) -> RefactGhc (GHC.Located (GHC.HsType GHC.Name))- renameTyVar v@(GHC.L l (GHC.HsTyVar n))- | (GHC.nameUnique n == GHC.nameUnique oldPN)- = do- logm $ "renamePNworker:renameTyVar at :" ++ (showGhc l)-- -- Get the original qualification, if any- rn <- (getParsedForRenamedLocated v :: RefactGhc (GHC.LHsType GHC.RdrName))- let (GHC.L _ (GHC.HsTyVar mqn)) = rn- let mrnq = GHC.isQual_maybe mqn- logm $ "renamePNworker:renameVar mrn,mrnq :" ++ (showGhc (rn,mrnq))-- worker useQual l mrnq- return (GHC.L l (GHC.HsTyVar newName))- renameTyVar x = return x--- renameHsTyVarBndr :: (GHC.LHsTyVarBndr GHC.Name) -> RefactGhc (GHC.LHsTyVarBndr GHC.Name)-#if __GLASGOW_HASKELL__ > 704- renameHsTyVarBndr v@(GHC.L l (GHC.UserTyVar n))-#else- renameHsTyVarBndr v@(GHC.L l (GHC.UserTyVar n typ))-#endif- | (GHC.nameUnique n == GHC.nameUnique oldPN)- = do- logm $ "renamePNworker:renameHsTyVarBndr at :" ++ (showGhc l)-- -- Get the original qualification, if any- rn <- (getParsedForRenamedLocated v :: RefactGhc (GHC.LHsTyVarBndr GHC.RdrName))-#if __GLASGOW_HASKELL__ > 704- let (GHC.L _ (GHC.UserTyVar mqn)) = rn-#else- let (GHC.L _ (GHC.UserTyVar mqn _)) = rn-#endif- let mrnq = GHC.isQual_maybe mqn- logm $ "renamePNworker:renameVar mrn,mrnq :" ++ (showGhc (rn,mrnq))-- worker useQual l mrnq-#if __GLASGOW_HASKELL__ > 704- return (GHC.L l (GHC.UserTyVar newName))-#else- return (GHC.L l (GHC.UserTyVar newName typ))-#endif- renameHsTyVarBndr x = return x-- renameLIE :: (GHC.LIE GHC.Name) -> RefactGhc (GHC.LIE GHC.Name)- renameLIE (GHC.L l (GHC.IEVar n))- | (GHC.nameUnique n == GHC.nameUnique oldPN)- = do- logm $ "renamePNworker:renameLIE at :" ++ (showGhc l)- worker useQual l Nothing- return (GHC.L l (GHC.IEVar newName))- renameLIE x = return x-- renameLPat :: (GHC.LPat GHC.Name) -> RefactGhc (GHC.LPat GHC.Name)- renameLPat v@(GHC.L l (GHC.VarPat n))- | (GHC.nameUnique n == GHC.nameUnique oldPN)- = do- logm $ "renamePNworker:renameLPat at :" ++ (showGhc l)-- -- Get the original qualification, if any- rn <- (getParsedForRenamedLocated v :: RefactGhc (GHC.LPat GHC.RdrName))- let (GHC.L _ (GHC.VarPat mqn)) = rn- let mrnq = GHC.isQual_maybe mqn- logm $ "renamePNworker:renameVar mrn,mrnq :" ++ (showGhc (rn,mrnq))-- worker False l mrnq- return (GHC.L l (GHC.VarPat newName))- renameLPat x = return x-- renameFunBind :: (GHC.LHsBindLR GHC.Name GHC.Name) -> RefactGhc (GHC.LHsBindLR GHC.Name GHC.Name)- renameFunBind (GHC.L l (GHC.FunBind (GHC.L ln n) fi (GHC.MatchGroup matches typ) co fvs tick))- | (GHC.nameUnique n == GHC.nameUnique oldPN) || (GHC.nameUnique n == GHC.nameUnique newName)- = 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) )- -- logm $ "renamePNWorker.renameFunBind"- worker False ln Nothing- -- Now do (b)- logm $ "renamePNWorker.renameFunBind.renameFunBind:starting matches"- let w (GHC.L lm _match) = worker False lm' Nothing- where- ((GHC.L lm' _),_) = newNameTok False lm oldPN- mapM_ w $ tail matches- logm $ "renamePNWorker.renameFunBind.renameFunBind.renameFunBind:matches done"- return (GHC.L l (GHC.FunBind (GHC.L ln newName) fi (GHC.MatchGroup matches typ) co fvs tick))- renameFunBind x = return x-- renameTypeSig :: (GHC.LSig GHC.Name) -> RefactGhc (GHC.LSig GHC.Name)- renameTypeSig (GHC.L l (GHC.TypeSig ns typ))- = do- -- logm $ "renamePNWorker:renameTypeSig"- _ns' <- renamePN oldPN newName updateTokens False ns- -- Has already been renamed, make sure qualifier is removed- ns' <- renamePN newName newName updateTokens False ns- typ' <- renamePN oldPN newName updateTokens False typ- -- logm $ "renamePNWorker:renameTypeSig done"- return (GHC.L l (GHC.TypeSig ns' typ'))- renameTypeSig x = return x-- -- The param l is only useful for the start of the token pos- worker :: Bool -> GHC.SrcSpan -> Maybe (GHC.ModuleName, GHC.OccName) -> RefactGhc ()- worker useQual' l mmo- = do if updateTokens- then do- newTok <- case mmo of- Nothing -> return $ newNameTok useQual' l newName- Just (modu,_) -> do- newName' <- mkNewGhcName (Just $ GHC.mkModule GHC.mainPackageId modu) (GHC.occNameString $ GHC.getOccName newName)- return $ newNameTok True l newName'- -- replaceToken l (markToken $ newNameTok useQual' l newName)- replaceToken l (markToken $ newTok)- return ()- else return ()---- ------------------------------------------------------------------------- | Create a new name token. If 'useQual' then use the qualified--- name, if it exists.--- The end position is not changed, so the eventual realignment can--- know what the difference in length in the token is-newNameTok :: Bool -> GHC.SrcSpan -> GHC.Name -> PosToken-newNameTok useQual l newName =- ((GHC.L l' (GHC.ITvarid (GHC.mkFastString newNameStr))),newNameStr)- where- newNameStr = if useQual then (showGhc newName)- else (GHC.occNameString $ GHC.getOccName newName)-- l' = case l of- GHC.RealSrcSpan ss ->- let- ((ForestLine _ _ _ startRow,startCol),_) = srcSpanToForestSpan l-- locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) startRow startCol- locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) startRow (length newNameStr + startCol)- in- GHC.mkSrcSpan locStart locEnd- _ -> l---------------------------------------------------------------------------------------------- | Check whether the specified identifier is declared in the given syntax phrase t,--- if so, rename the identifier by creating a new name automatically. If the Bool parameter --- is True, the token stream will be modified, otherwise only the AST is modified. --autoRenameLocalVar:: (HsValBinds t)- =>Bool -- ^ True means modfiying the token stream as well. - ->GHC.Name -- ^ The identifier.- ->t -- ^ The syntax phrase.- -> RefactGhc t -- ^ The result.-autoRenameLocalVar modifyToks pn t = do- logm $ "autoRenameLocalVar: (modifyToks,pn)=" ++ (showGhc (modifyToks,pn))- -- = everywhereMStaged SYB.Renamer (SYB.mkM renameInMatch)- if isDeclaredIn pn t- then do t' <- worker t- return t'- else do return t-- where- worker tt =do (f,d) <- hsFDNamesFromInside tt- ds <- hsVisibleNames pn (hsValBinds tt)- let newNameStr=mkNewName (nameToString pn) (nub (f `union` d `union` ds)) 1- newName <- mkNewGhcName Nothing newNameStr- if modifyToks- then renamePN pn newName True False tt- else renamePN pn newName False False tt---- ------------------------------------------------------------------------- | Show a list of entities, the parameter f is a function that--- specifies how to format an entity.-showEntities:: (t->String) -> [t] ->String-showEntities _ [] = ""-showEntities f [pn] = f pn-showEntities f (pn:pns) =f pn ++ "," ++ showEntities f pns----- ----------------------------------------------------------------------{---- | Return True if the identifier can become qualified.-canBeQualified::(Term t)=>PNT->t->Bool-canBeQualified pnt t- = isTopLevelPNT pnt && isUsedInRhs pnt t && not (findPntInImp pnt t)- where- findPntInImp pnt- = (fromMaybe False).(applyTU (once_tdTU (failTU `adhocTU` inImp)))- where- inImp ((HsImportDecl loc modName qual as h)::HsImportDeclP)- |findEntity pnt h = Just True- inImp _ = Nothing--}----- -----------------------------------------------------------------------isMainModule :: GHC.Module -> Bool-isMainModule modu = GHC.modulePackageId modu == GHC.mainPackageId---- ------------------------------------------------------------------------- | 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 $ somethingStaged SYB.Parser Nothing- (Nothing `SYB.mkQ` inMatch `SYB.extQ` inDecl) t- where- inMatch ((GHC.FunBind name _ (GHC.MatchGroup _matches _) _ _ _) :: GHC.HsBind t)- | isJust (find (sameOccurrence pnt) [name]) = Just True- inMatch _ = Nothing-- inDecl ((GHC.TypeSig is _) :: GHC.Sig t)- |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 _ = []---- ------------------------------------------------------------------------- | 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-{-- = isJust.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 the identifier occurs in the given syntax phrase.-findPN::(SYB.Data t)=> GHC.Name -> t -> Bool-findPN pn- = isJust.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.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---- ------------------------------------------------------------------------- | 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 = 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.Located (GHC.HsExpr GHC.Name) -> GHC.Name-expToName (GHC.L _ (GHC.HsVar pnt)) = pnt-expToName (GHC.L _ (GHC.HsPar e)) = expToName e-expToName _ = defaultName---nameToString :: GHC.Name -> String-nameToString name = showGhc name---- | 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------{---- | If a pattern consists of only one identifier then returns this identifier in the PName format,--- otherwise returns the default PName.-patToPN::HsPatP->PName-patToPN=pNTtoPN.patToPNT--}+ , causeNameClashInExports {- , inRegion , unmodified -}++ , removeOffset++ -- * Typed AST traversals (added by CMB)+ -- * Miscellous+ -- ,removeFromInts, getDataName, checkTypes, getPNs, getPN, getPNPats, mapASTOverTAST++ -- * Debug stuff+ , getDeclAndToks, getSigAndToks+ , getToksForDecl, removeToksOffset -- ++AZ++ remove this after debuggging+ , getParsedForRenamedLPat+ , getParsedForRenamedName+ , getParsedForRenamedLocated+ -- , allPNT+ -- , allPNTLens+ , newNameTok+ , stripLeadingSpaces+ -- , lookupNameGhc+ ) where++import Exception+import Control.Monad.State+import Data.Char+import Data.List+import Data.Maybe+import Data.Monoid+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.TokenUtils+import Language.Haskell.Refact.Utils.TokenUtilsTypes+import Language.Haskell.Refact.Utils.TypeSyn++-- Modules from GHC+import qualified Bag as GHC+import qualified BasicTypes as GHC+import qualified FastString as GHC+import qualified GHC as GHC+import qualified Lexer as GHC hiding (getSrcLoc)+import qualified Module as GHC+import qualified Name as GHC+import qualified NameSet as GHC+import qualified Outputable as GHC+import qualified RdrName as GHC+import qualified SrcLoc as GHC+import qualified UniqSet as GHC+import qualified Unique as GHC++import qualified Data.Generics as SYB+import qualified GHC.SYB.Utils as SYB++import Data.Generics.Strafunski.StrategyLib.StrategyLib++-- ---------------------------------------------------------------------++-- | For free variables+data FreeNames = FN [GHC.Name]++-- | For declared variables+data DeclaredNames = DN [GHC.Name]++instance Show FreeNames where+ show (FN ls) = "FN " ++ showGhc ls++instance Show DeclaredNames where+ show (DN ls) = "DN " ++ showGhc 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 [])++-- ---------------------------------------------------------------------+-- |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++ -- getEntInfo (qual, ent@(Ent modName ident _))+ -- =(identToName ident, hasNameSpace ent, modName, getQualifier qual)++{-+-- | Process the export relation returned from the parsing and module analysis pass, and+-- return a list of trhee-element tuples. Each tuple contains an identifier name, the+-- identifier's namespace info, and the identifier's define module.+exportInfo::Exports -- ^ The export relation.+ -> [(String, NameSpace, ModuleName)] -- ^ The result+exportInfo exports = nub $ map getEntInfo exports+ where+ getEntInfo (_, ent@(Ent modName ident _))+ =(identToName ident, hasNameSpace ent, modName)+-}++-- | 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 -> (GHC.nameUnique x) /= (GHC.nameUnique n')) names+ Just n' -> filter (\x -> (showGhc x) /= (showGhc 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 []++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 []++-- ---------------------------------------------------------------------+-- | Show a PName in a format like: 'pn'(at row:r, col: c).+showPNwithLoc:: GHC.Located GHC.Name -> String+showPNwithLoc pn@(GHC.L l _n)+ = let (r,c) = getGhcLoc l+ -- in " '"++pNtoName pn++"'" ++"(at row:"++show r ++ ",col:" ++ show c ++")"+ in " '"++showGhc pn++"'" ++"(at row:"++show r ++ ",col:" ++ show c ++")"++-- ---------------------------------------------------------------------++defaultPN :: PName+defaultPN = PN (mkRdrName "nothing")++defaultName :: GHC.Name+defaultName = n+ where+ un = GHC.mkUnique 'H' 0 -- H for HaRe :)+ n = GHC.localiseName $ GHC.mkSystemName un (GHC.mkVarOcc "nothing")++-- | Default expression.+defaultExp::HsExpP+-- defaultExp=Exp (HsId (HsVar defaultPNT))+defaultExp=GHC.HsVar $ mkRdrName "nothing"+++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) }++ let un = GHC.mkUnique 'H' (u+1) -- H for HaRe :)+ -- n = GHC.mkSystemName un (GHC.mkVarOcc name)+ n = case maybeMod of+ Nothing -> GHC.localiseName $ GHC.mkSystemName un (GHC.mkVarOcc name)+ Just modu -> GHC.mkExternalName un modu (GHC.mkVarOcc name) nullSrcSpan+ return n++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.mkSystemName un (GHC.mkVarOcc name)+ -- n = GHC.localiseName $ GHC.mkSystemName un (GHC.mkVarOcc name)++ -- mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name+ 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 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 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 -- imps =hsModImports mod+ -- imp@(GHC.L _ (GHC.ImportDecl (GHC.L _ modName) qualify _source _safe isQualified _isImplicit as h))+ in isJust $ find (\(GHC.L _ (GHC.ImportDecl (GHC.L _ modName1) _qualify _source _safe isQualified _isImplicit _as _h))+ -> modName1 == modName' && (not isQualified)) imps+ -- in isJust $ find (\(HsImportDecl _ (SN modName1 _) qualify _ h) -> modName == modName1 && (not qualify)) 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+{-++modNames capture potential clashes e.g.++@+module Exports (head) where++import Data.Text (head)+@++So if the new name was 'head', then the modNames would be+ [Data.Text]++-}+++{- ++AZ++ Original++-- Note that in the abstract representation of exps, there is no qualified entities.+causeNameClashInExports pn newName mod exps+ = let modNames=nub (concatMap (\(x, Ent modName _ _)->if show x==show newName+ then [modName]+ else []) exps)+ in (isExplicitlyExported pn mod) &&+ ( any (modIsUnQualifedImported mod) modNames+ || elem (let (SN modName1 _) =hsModName mod+ in modName1) modNames)+ where+ modIsUnQualifedImported mod modName+ =let imps =hsModImports mod+ in isJust $ find (\(HsImportDecl _ (SN modName1 _) qualify _ h)->modName==modName1 && (not qualify)) imps++-}++-- ---------------------------------------------------------------------+-- | 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_tdTUGhc (failTU+ `adhocTU` expr+ `adhocTU` pattern+ `adhocTU` binds+ `adhocTU` bindList+ `adhocTU` match+ `adhocTU` stmts+ `adhocTU` rhs+ )) t++ -- TODO: ++AZ++ Note:After renaming, HsBindLR has field bind_fvs+ -- containing locally bound free vars++ -- 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.MatchGroup 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)+ = do (df,dd) <- hsFreeAndDeclaredPNs' g+ (ef,ed) <- hsFreeAndDeclaredPNs' ds+ return (df ++ ef, dd ++ ed)+++ -- pat --+ 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.MatchGroup 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 pats _mtype mrhs) :: GHC.Match 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) = 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) =+ 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, GHC.Outputable 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) => t -> RefactGhc (FreeNames,DeclaredNames)+hsFreeAndDeclaredGhc t = do+ -- logm $ "hsFreeAndDeclaredGhc:t=" ++ showGhc 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 -- emptyFD+ `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+#if __GLASGOW_HASKELL__ > 704+ `SYB.extQ` bndrs+#endif+ `SYB.extQ` ltydecls+ `SYB.extQ` ltydecl+#if __GLASGOW_HASKELL__ > 704+ `SYB.extQ` lfaminstdecls+ `SYB.extQ` lfaminstdecl+#endif+ `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+ gfds <- hsFreeAndDeclaredGhc $ GHC.hs_valds g+ let tds = concatMap getDeclaredTypes $ concat (GHC.hs_tyclds g)+ return $ gfds <> (FN [],DN tds)+++ lhsbinds :: [GHC.LHsBind GHC.Name] -> RefactGhc (FreeNames,DeclaredNames)+ lhsbinds bs = do+ (FN fn,DN dn) <- recurseList bs+ let r = (FN (fn \\ dn),DN dn)+ -- 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.MatchGroup matches _) _ _ _) = do+ -- logm $ "hsFreeAndDeclaredGhc.hsbind:b=" ++ (showGhc b)+ let d = GHC.collectHsBindBinders b+ -- let pats = concatMap (\(GHC.L _ (GHC.Match pat _ _)) -> pat) matches+ (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+ dn = GHC.collectPatBinders lp++ -- logm $ "hsFreeAndDeclaredGhc.lpat p=" ++ (SYB.showData SYB.Renamer 0 p)++ (FN fn,DN _dn) <- pat p+ -- logm $ "hsFreeAndDeclaredGhc.lpat:(fn,dn)=" ++ (showGhc (fn,dn))+ return (FN fn,DN dn)++ 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+#if __GLASGOW_HASKELL__ > 704+ return $ fdp <> (FN fb,DN [])+#else+ return $ fdp <> (FN _db,DN [])+#endif+ pat (GHC.SigPatOut (GHC.L _ p) _) = pat p+ pat (GHC.CoPat _ p _) = pat p++ pat p = error $ "hsFreeAndDeclaredGhc.pat:unimplemented:" ++ (showGhc p)++ -- HsConDetails (LPat id) (HsRecFields id (LPat id))+ 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.HsRecField _ (GHC.L _ arg) _) -> arg) fields+ fds <- mapM pat args+ return $ mconcat fds++ -- -----------------------++#if __GLASGOW_HASKELL__ > 704+ bndrs :: GHC.HsWithBndrs (GHC.LHsType GHC.Name) -> RefactGhc (FreeNames,DeclaredNames)+ bndrs (GHC.HsWB (GHC.L _ thing) _kindVars _typeVars) = do+ (_ft,DN dt) <- hsFreeAndDeclaredGhc thing+ -- logm $ "hsFreeAndDeclaredGhc.bndrs (_ft,dt)=" ++ show (_ft,DN dt)+ return (FN dt,DN [])+#endif++ -- -----------------------++ 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])+#if __GLASGOW_HASKELL__ > 704+ ltydecl (GHC.L _ (GHC.TyDecl (GHC.L _ n) _bndrs _defn fvs))+ = return (FN (GHC.nameSetToList fvs),DN [n])+#else+ ltydecl (GHC.L _ (GHC.TyData _ _ctx (GHC.L _ n) _vars _pats _kind _cons _derivs)) + = return (FN [],DN [n]) -- TODO: calc fvs for cons+ ltydecl (GHC.L _ (GHC.TySynonym (GHC.L _ n) _vars _pats _rhs))+ = return (FN [],DN [n]) -- TODO fvs?+#endif+#if __GLASGOW_HASKELL__ > 704+ ltydecl (GHC.L _ (GHC.ClassDecl _ctx (GHC.L _ n) _tyvars+ _fds _sigs meths ats atds _docs fvs)) = do+#else+ ltydecl (GHC.L _ (GHC.ClassDecl _ctx (GHC.L _ n) _tyvars+ _fds _sigs meths ats atds _docs)) = do+#endif+ (_,md) <- hsFreeAndDeclaredGhc meths+ (_,ad) <- hsFreeAndDeclaredGhc ats+ (_,atd) <- hsFreeAndDeclaredGhc atds+#if __GLASGOW_HASKELL__ > 704+ return (FN (GHC.nameSetToList fvs),DN [n] <> md <> ad <> atd)+#else+ return (FN [],DN [n] <> md <> ad <> atd) -- TODO: fvs+#endif++#if __GLASGOW_HASKELL__ > 704+ lfaminstdecls :: [GHC.LFamInstDecl GHC.Name] -> RefactGhc (FreeNames,DeclaredNames)+ lfaminstdecls ds = do+ fds <- mapM hsFreeAndDeclaredGhc ds+ return $ mconcat fds+#endif++#if __GLASGOW_HASKELL__ > 704+ 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.nameSetToList fvs), DN [n])+#else+ -- lfaminstdecl (GHC.L _ (GHC.InstDecl typ binds sigs decls))+#endif++ -- -----------------------++ 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++ -- -----------------------++ 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++#if __GLASGOW_HASKELL__ > 704+ expr ((GHC.HsLamCase _ mg)) = hsFreeAndDeclaredGhc mg+#endif++ 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.Missing _) = []+ bb (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++#if __GLASGOW_HASKELL__ > 704+ expr ((GHC.HsMultiIf _typ rhs))+ = hsFreeAndDeclaredGhc rhs+#endif++ 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 _typ 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.HsBracketOut 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.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++ -- -----------------------++ name :: GHC.Name -> RefactGhc (FreeNames,DeclaredNames)+ name n = return (FN [],DN [n])++ -- -----------------------+ lstmts :: [GHC.LStmt GHC.Name] -> RefactGhc (FreeNames,DeclaredNames)+ lstmts ss = recurseList ss+++ lstmt :: GHC.LStmt 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.ExprStmt e _ _ _)) = hsFreeAndDeclaredGhc e+ lstmt (GHC.L _ (GHC.LetStmt bs)) = hsFreeAndDeclaredGhc bs+#if __GLASGOW_HASKELL__ > 704+ lstmt (GHC.L _ (GHC.ParStmt ps _ _)) = hsFreeAndDeclaredGhc ps+#else+ lstmt (GHC.L _ (GHC.ParStmt ps _ _ _)) = hsFreeAndDeclaredGhc ps+#endif+ 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 _ fvs _) = return (FN (GHC.nameSetToList fvs),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+#if __GLASGOW_HASKELL__ > 704+ hstype (GHC.HsTyLit _) = return emptyFD+#endif+ hstype (GHC.HsWrapTy _ typ) = hsFreeAndDeclaredGhc typ+++ -- -----------------------++ grhs_s :: [GHC.LGRHS GHC.Name] -> RefactGhc (FreeNames,DeclaredNames)+ grhs_s gs = recurseList gs++ -- -----------------------++ grhs :: GHC.LGRHS 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] -> RefactGhc (FreeNames,DeclaredNames)+ grhsss gs = recurseList gs++ -- -----------------------++ grhss :: GHC.GRHSs 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 -> RefactGhc (FreeNames,DeclaredNames)+ matchgroup (GHC.MatchGroup matches _) = recurseList matches++ -- -----------------------++ lmatches :: [GHC.LMatch GHC.Name] -> RefactGhc (FreeNames,DeclaredNames)+ lmatches ms = recurseList ms++ -- -----------------------++ lmatch :: GHC.LMatch GHC.Name -> RefactGhc (FreeNames,DeclaredNames)+ lmatch (GHC.L _ _m@(GHC.Match 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 = error $ "hsFreeAndDeclaredGhc:not matched:" ++ (SYB.showData SYB.Renamer 0 t)++ -- ---------------------------------++ recurseList xs = do+ fds <- mapM hsFreeAndDeclaredGhc xs+ return $ mconcat fds++-- ---------------------------------------------------------------------++-- | 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 = 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 ||+ stripForestLineFromGhc lp == stripForestLineFromGhc 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 = somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` lname) t++ lname :: (GHC.Located b) -> (Maybe (GHC.Located b))+ lname p@(GHC.L lp _)+ | lp == l ||+ stripForestLineFromGhc lp == stripForestLineFromGhc 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 = 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 ||+ stripForestLineFromGhc lp == stripForestLineFromGhc l = Just p+ lname _ = Nothing++-- ---------------------------------------------------------------------++getDeclaredTypes :: GHC.LTyClDecl GHC.Name -> [GHC.Name]+getDeclaredTypes (GHC.L _ (GHC.ForeignType (GHC.L _ n) _)) = [n]+getDeclaredTypes (GHC.L _ (GHC.TyFamily _ (GHC.L _ n) _bs _)) = [n]+#if __GLASGOW_HASKELL__ > 704+getDeclaredTypes (GHC.L _ (GHC.TyDecl (GHC.L _ n) _vars defn _fvs)) = nub $ [n] ++ dsn+ where+ dsn = getHsTyDefn defn+#else+-- data,+getDeclaredTypes (GHC.L _ (GHC.TyData _ _ctx (GHC.L _ n) _vars _pats _kind cons _derivs)) + = nub $ [n] ++ cs+ where+ getConDecl (GHC.L _ (GHC.ConDecl (GHC.L _ n2) _ _ _ _ _ _ _)) = n2+ cs = map getConDecl cons+-- synonym+getDeclaredTypes (GHC.L _ (GHC.TySynonym (GHC.L _ n) _vars _pats _rhs)) = [n]+#endif+#if __GLASGOW_HASKELL__ > 704+getDeclaredTypes (GHC.L _ (GHC.ClassDecl _ (GHC.L _ n) _vars _fds sigs meths ats _atdefs _ _fvs))+#else+getDeclaredTypes (GHC.L _ (GHC.ClassDecl _ (GHC.L _ n) _vars _fds sigs meths ats _atdefs _))+#endif+ = 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 _)) = []++ ssn = concatMap getLSig sigs+ msn = getDeclaredVars $ hsBinds meths+ asn = concatMap getDeclaredTypes ats++-- -------------------------------------++#if __GLASGOW_HASKELL__ > 704+getHsTyDefn :: GHC.HsTyDefn GHC.Name -> [GHC.Name]+getHsTyDefn (GHC.TySynonym _) = []+getHsTyDefn (GHC.TyData _ _ _ _ cons _) = r+ where+ getConDecl (GHC.L _ (GHC.ConDecl (GHC.L _ n) _ _ _ _ _ _ _)) = n+ r = map getConDecl cons+#endif++-- ---------------------------------------------------------------------+-- |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.nameSetToList fvs)+ binds (GHC.L _ (GHC.PatBind _p _rhs _ty fvs _)) = (GHC.nameSetToList fvs)+ binds _ = []++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 _ = []++--------------------------------------------------------------------------------+-- | Same as `hsVisiblePNs' except that the returned identifiers are+-- in String format.+hsVisibleNames:: (FindEntity t1, SYB.Data t1, SYB.Data t2,HsValBinds t2,GHC.Outputable t1)+ => t1 -> t2 -> RefactGhc [String]+hsVisibleNames e t = do+ d <- hsVisiblePNs 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 [].+hsVisiblePNs :: (FindEntity e, SYB.Data e, SYB.Data t,HsValBinds t,GHC.Outputable e)+ => e -> t -> RefactGhc [GHC.Name]+hsVisiblePNs e t = do+ (DN dn) <- hsVisibleDs e t+ return dn++------------------------------------------------------------------------++-- | 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, SYB.Data e, SYB.Data t,HsValBinds t,GHC.Outputable e)+ => 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` 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+ tfds <- hsVisibleDs e $ GHC.hs_tyclds g+ ifds <- hsVisibleDs e $ GHC.hs_instds g+ 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.MatchGroup 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) -> RefactGhc DeclaredNames+ lmatch (GHC.L _ (GHC.Match pats _mtyp rhs))+ | findEntity e pats = do+ logm $ "hsVisibleDs.lmatch:in pats="+ return (DN []) -- TODO: extend this+ | findEntity e rhs = do+ ( 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) -> RefactGhc DeclaredNames+ grhss (GHC.GRHSs guardedRhss lstmts)+ | findEntity e guardedRhss = do+ fds <- mapM (hsVisibleDs e) guardedRhss+ return $ mconcat fds+ | findEntity e lstmts = hsVisibleDs e lstmts+ grhss _ = return (DN [])++ lgrhs :: GHC.LGRHS GHC.Name -> RefactGhc DeclaredNames+ lgrhs (GHC.L _ (GHC.GRHS stmts ex))+ | findEntity e stmts = hsVisibleDs e stmts+ | 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.e1:" ++ (showGhc (e1,_eOp,e2))+ (FN efs,_) <- hsFreeAndDeclaredGhc expr+ (FN _eefs,DN eeds) <- hsFreeAndDeclaredGhc e+ -- return (DN e1fs <> DN eofs <> DN e2fs)+ return (DN (efs \\ eeds))++ lexpr _ = 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+ fds <- mapM (hsVisibleDs e) tcds+ return $ mconcat fds+ tycldecls _ = return (DN [])++ tycldecl :: GHC.LTyClDecl GHC.Name -> RefactGhc DeclaredNames+ tycldecl tcd+ | findEntity e tcd = do+ (_,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+#if __GLASGOW_HASKELL__ > 704+ instdecl (GHC.L _ (GHC.ClsInstD polytyp binds sigs faminsts))+#else+ instdecl (GHC.L _ (GHC.InstDecl polytyp binds sigs faminsts))+#endif+ | findEntity e polytyp = hsVisibleDs e polytyp+ | findEntity e binds = hsVisibleDs e binds+ | findEntity e sigs = hsVisibleDs e sigs+ | findEntity e faminsts = hsVisibleDs e faminsts+ instdecl _ = return (DN [])++ lhstype :: GHC.LHsType GHC.Name -> RefactGhc DeclaredNames+ lhstype tv@(GHC.L _ (GHC.HsTyVar n))+ | findEntity e tv = return (DN [n])+ lhstype _ = 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)+++------------------------------------------------------------------------++-- | 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 = 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 pname parsed &&+ isUsedInRhs (GHC.L l name) parsed &&+ GHC.isUnqual pn = Just True+ checkName _ = Nothing+++-- ---------------------------------------------------------------------+++-- |`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') = fromMaybe ([],[]) r1+ 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 [LPat id] (Maybe (LHsType id)) (GRHSs id)+ match :: GHC.Match GHC.Name -> RefactGhc ([GHC.Name],[GHC.Name])+ match ((GHC.Match pats _type rhs):: GHC.Match 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.MatchGroup 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.MatchGroup matches _)) :: GHC.HsExpr GHC.Name) =+ hsFreeAndDeclaredPNs matches++ expr ((GHC.HsCase e (GHC.MatchGroup matches _)) :: GHC.HsExpr GHC.Name) =+ do+ (ef,_) <- hsFreeAndDeclaredPNs e+ (df,dd) <- hsFreeAndDeclaredPNs matches+ return (nub (df `union` (ef \\ dd)), nub dd)++ -- expr _ = return ([],[])+ expr _ = mzero++ stmts ((GHC.BindStmt pat e1 e2 e3) :: GHC.Stmt 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) =+ hsFreeAndDeclaredPNs binds++ -- stmts _ = return ([],[])+ 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)++-- ---------------------------------------------------------------------+-- | 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)]++-- ---------------------------------------------------------------------++-- |Get all the names in the given syntax element+hsNamess :: (SYB.Data t) => t -> [GHC.Name]+-- hsNamess t = (nub.ghead "hsNamess") res+hsNamess t = nub $ concat res+ where+ res = SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` inName) t++ inName (pname :: GHC.Name) = return [pname]++-----------------------------------------------------------------------------++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+-- isLocalPN (PN i (UniqueNames.S _)) = True+-- isLocalPN _ = False++-- |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.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` worker)+ where+ -- worker (decl::HsDeclP)+ 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.Located (GHC.Sig a) -> Bool+isTypeSig (GHC.L _ (GHC.TypeSig _ _)) = True+isTypeSig _ = 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.+isSimplePatBind :: (SYB.Data 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.+isComplexPatBind::GHC.LHsBind GHC.Name -> Bool+isComplexPatBind decl = case decl of+ (GHC.L _l (GHC.PatBind p _rhs _ty _fvs _)) -> patToPNT p /= Nothing+ _ -> 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++{-+-- | Return True if a declaration is a Class declaration.+isClassDecl :: HsDeclP ->Bool+isClassDecl (TiDecorate.Dec (HsClassDecl _ _ _ _ _)) = True+isClassDecl _ = False++-- | Return True if a declaration is a Class instance declaration.+isInstDecl :: HsDeclP -> Bool+isInstDecl (TiDecorate.Dec (HsInstDecl _ _ _ _ _)) = True+isInstDecl _ = False+-}+{-+-- | Return True if a function is a directly recursive function.+isDirectRecursiveDef::HsDeclP->Bool+isDirectRecursiveDef (TiDecorate.Dec (HsFunBind loc ms))+ = any isUsedInDef ms+ where+ isUsedInDef (HsMatch loc1 fun pats rhs ds)+ = findEntity (pNTtoPN fun) rhs+isDirectRecursiveDef _ = False+-}+-------------------------------------------------------------------------------++getValBindSigs :: GHC.HsValBinds GHC.Name -> [GHC.LSig GHC.Name]+getValBindSigs binds = case binds of+ GHC.ValBindsIn _ sigs -> sigs+ GHC.ValBindsOut _ sigs -> sigs++emptyValBinds :: GHC.HsValBinds GHC.Name+emptyValBinds = GHC.ValBindsIn (GHC.listToBag []) []++unionBinds :: [GHC.HsValBinds GHC.Name] -> GHC.HsValBinds GHC.Name+unionBinds [] = emptyValBinds+unionBinds [x] = x+unionBinds (x1:x2:xs) = unionBinds ((mergeBinds x1 x2):xs)+ where+ mergeBinds :: GHC.HsValBinds GHC.Name -> GHC.HsValBinds GHC.Name -> GHC.HsValBinds GHC.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 b1 s1) (GHC.ValBindsIn b2 s2) = (GHC.ValBindsOut (b1++[(GHC.NonRecursive,b2)]) (s1++s2))++-- NOTE: ValBindsIn are found before the Renamer, ValBindsOut after++hsBinds :: (HsValBinds t) => t -> [GHC.LHsBind GHC.Name]+hsBinds t = case hsValBinds t of+ GHC.ValBindsIn binds _sigs -> GHC.bagToList binds+ GHC.ValBindsOut bs _sigs -> concatMap (\(_,b) -> GHC.bagToList b) bs++replaceBinds :: (HsValBinds t) => t -> [GHC.LHsBind GHC.Name] -> t+-- replaceBinds t bs = replaceValBinds t (GHC.ValBindsIn (GHC.listToBag bs) [])+replaceBinds t bs = replaceValBinds t (GHC.ValBindsIn (GHC.listToBag bs) sigs)+ where+ sigs = case hsValBinds t of+ GHC.ValBindsIn _ s -> s+ GHC.ValBindsOut _ s -> s++-- This class replaces the HsDecls one+class (SYB.Data t) => HsValBinds t where++ -- | Return the binds that are directly enclosed in the+ -- given syntax phrase.+ -- hsValBinds :: t -> [GHC.LHsBind GHC.Name]+ hsValBinds :: t -> GHC.HsValBinds GHC.Name++ -- | Replace the directly enclosed bind list by the given+ -- bind list. Note: This function does not modify the+ -- token stream.+ -- replaceBinds :: t -> [GHC.LHsBind GHC.Name] -> t+ replaceValBinds :: t -> GHC.HsValBinds GHC.Name -> t++ -- | Return True if the specified identifier is declared in the+ -- given syntax phrase.+ -- isDeclaredIn :: GHC.Name -> t -> Bool++ -- | 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 GHC.Name]]++-- ++AZ++ see if we can get away with one only..+isDeclaredIn :: (HsValBinds t) => GHC.Name -> t -> Bool+isDeclaredIn name t = nonEmptyList $ definingDeclsNames [name] (hsBinds t) False True+++instance HsValBinds (GHC.RenamedSource) where+ hsValBinds (grp,_,_,_) = (GHC.hs_valds grp)++ replaceValBinds (grp,imps,exps,docs) binds = (grp',imps,exps,docs)+ where+ grp' = grp {GHC.hs_valds = binds}++ hsTyDecls (grp,_,_,_) = (GHC.hs_tyclds grp)+++instance HsValBinds (GHC.HsValBinds GHC.Name) where+ hsValBinds vb = vb+ replaceValBinds _old new = new+ hsTyDecls _ = []++instance HsValBinds (GHC.HsGroup GHC.Name) where+ hsValBinds grp = (GHC.hs_valds grp)++ replaceValBinds (GHC.HsGroup b t i d f de fo w a r v doc) binds+ = (GHC.HsGroup b' t i d f de fo w a r v doc)+ where b' = replaceValBinds b binds++ hsTyDecls _ = []++instance HsValBinds (GHC.HsLocalBinds GHC.Name) where+ hsValBinds lb = case lb of+ GHC.HsValBinds b -> b+ GHC.HsIPBinds _ -> emptyValBinds+ GHC.EmptyLocalBinds -> emptyValBinds++ replaceValBinds (GHC.HsValBinds _b) new = (GHC.HsValBinds new)+ replaceValBinds (GHC.HsIPBinds _b) _new = error "undefined replaceValBinds HsIPBinds"+ replaceValBinds (GHC.EmptyLocalBinds) new = (GHC.HsValBinds new)++ hsTyDecls _ = []++instance HsValBinds (GHC.GRHSs GHC.Name) where+ hsValBinds (GHC.GRHSs _ lb) = hsValBinds lb++ replaceValBinds (GHC.GRHSs rhss b) new = (GHC.GRHSs rhss (replaceValBinds b new))++ hsTyDecls _ = []++-- ---------------------------------------------------------------------++instance HsValBinds (GHC.MatchGroup GHC.Name) where+ hsValBinds (GHC.MatchGroup matches _) = hsValBinds matches++ replaceValBinds (GHC.MatchGroup matches a) newBinds+ = (GHC.MatchGroup (replaceValBinds matches newBinds) a)++ hsTyDecls _ = []++-- ---------------------------------------------------------------------++instance HsValBinds [GHC.LMatch GHC.Name] where+ hsValBinds ms = unionBinds $ map (\m -> hsValBinds $ GHC.unLoc m) ms++ replaceValBinds [] _ = error "empty match list in replaceValBinds [GHC.LMatch GHC.Name]"+ replaceValBinds ms newBinds = (replaceValBinds (ghead "replaceValBinds" ms) newBinds):(tail ms)++ hsTyDecls _ = []++-- ---------------------------------------------------------------------++instance HsValBinds (GHC.LMatch GHC.Name) where+ hsValBinds m = hsValBinds $ GHC.unLoc m++ replaceValBinds (GHC.L l m) newBinds = (GHC.L l (replaceValBinds m newBinds))++ hsTyDecls _ = []++-- ---------------------------------------------------------------------+++instance HsValBinds (GHC.Match GHC.Name) where+ hsValBinds (GHC.Match _ _ grhs) = hsValBinds grhs++ replaceValBinds (GHC.Match p t (GHC.GRHSs rhs _binds)) newBinds+ = (GHC.Match p t (GHC.GRHSs rhs binds'))+ where+ binds' = (GHC.HsValBinds newBinds)++ hsTyDecls _ = []++instance HsValBinds (GHC.HsBind GHC.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 GHC.Name) undefined for:" ++ (showGhc other)++ replaceValBinds (GHC.PatBind p (GHC.GRHSs rhs _binds) typ fvs pt) newBinds+ = (GHC.PatBind p (GHC.GRHSs rhs binds') typ fvs pt)+ where+ binds' = (GHC.HsValBinds newBinds)+ replaceValBinds x _newBinds+ = error $ "replaceValBinds (GHC.HsBind GHC.Name) undefined for:" ++ (showGhc x)++ hsTyDecls _ = []++instance HsValBinds (GHC.HsExpr GHC.Name) where+ hsValBinds (GHC.HsLet ds _) = hsValBinds ds+ hsValBinds x = error $ "TypeUtils.hsValBinds undefined for:" ++ showGhc x++ replaceValBinds (GHC.HsLet binds ex) new = (GHC.HsLet (replaceValBinds binds new) ex)+ replaceValBinds old _new = error $ "undefined replaceValBinds (GHC.HsExpr GHC.Name) for:" ++ (showGhc old)++ hsTyDecls _ = []++instance HsValBinds (GHC.Stmt GHC.Name) where+ hsValBinds (GHC.LetStmt ds) = hsValBinds ds+ hsValBinds other = error $ "hsValBinds (GHC.Stmt GHC.Name) undefined for:" ++ (showGhc other)+ replaceValBinds (GHC.LetStmt ds) new = (GHC.LetStmt (replaceValBinds ds new))+ replaceValBinds old _new = error $ "replaceValBinds (GHC.Stmt GHC.Name) undefined for:" ++ (showGhc old)++ hsTyDecls _ = []++-- ---------------------------------------------------------------------++instance HsValBinds (GHC.LHsBinds GHC.Name) where+ hsValBinds binds = hsValBinds $ GHC.bagToList binds+ replaceValBinds old _new = error $ "replaceValBinds (GHC.LHsBinds GHC.Name) undefined for:" ++ (showGhc old)+ hsTyDecls _ = []++-- ---------------------------------------------------------------------++instance HsValBinds (GHC.LHsBind GHC.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+++ replaceValBinds (GHC.L l (GHC.FunBind a b matches c d e)) newBinds+ = (GHC.L l (GHC.FunBind a b (replaceValBinds matches newBinds) c d e))+ replaceValBinds (GHC.L l (GHC.PatBind a rhs b c d)) newBinds+ = (GHC.L l (GHC.PatBind a (replaceValBinds rhs newBinds) b c d))+ replaceValBinds (GHC.L l (GHC.VarBind a rhs b)) newBinds+ = (GHC.L l (GHC.VarBind a (replaceValBinds rhs newBinds) b))+ replaceValBinds (GHC.L l (GHC.AbsBinds a b c d binds)) newBinds+ = (GHC.L l (GHC.AbsBinds a b c d (replaceValBinds binds newBinds)))++ hsTyDecls _ = []++-- ---------------------------------------------------------------------++instance HsValBinds ([GHC.LHsBind GHC.Name]) where+ -- hsValBinds xs = concatMap hsValBinds xs -- As in original+ hsValBinds xs = GHC.ValBindsIn (GHC.listToBag xs) []++ replaceValBinds _old (GHC.ValBindsIn b _sigs) = GHC.bagToList b+ replaceValBinds _old (GHC.ValBindsOut rbinds _sigs) = GHC.bagToList $ GHC.unionManyBags $ map (\(_,b) -> b) rbinds++ -- replaceValBinds old new = error ("replaceValBinds (old,new)=" ++ (showGhc (old,new)))++ hsTyDecls _ = []++instance HsValBinds (GHC.LHsExpr GHC.Name) where+ hsValBinds (GHC.L _ (GHC.HsLet binds _ex)) = hsValBinds binds+ hsValBinds _ = emptyValBinds++ replaceValBinds (GHC.L l (GHC.HsLet binds ex)) newBinds+ = (GHC.L l (GHC.HsLet (replaceValBinds binds newBinds) ex))+ replaceValBinds old _new = error $ "replaceValBinds (GHC.LHsExpr GHC.Name) undefined for:" ++ (showGhc old)++ hsTyDecls _ = []++-- ---------------------------------------------------------------------++instance HsValBinds [GHC.LGRHS GHC.Name] where+ hsValBinds xs = unionBinds $ map hsValBinds xs+ replaceValBinds _old _new = error $ "replaceValBinds [GHC.LGRHS GHC.Name] undefined for:" -- ++ (showGhc old)+ hsTyDecls _ = []++-- ---------------------------------------------------------------------++instance HsValBinds (GHC.LGRHS GHC.Name) where+ hsValBinds (GHC.L _ (GHC.GRHS stmts _expr)) = hsValBinds stmts+ replaceValBinds _old _new = error $ "replaceValBinds (GHC.LHGRHS GHC.Name) undefined for:" -- ++ (showGhc _old)+ hsTyDecls _ = []++-- ---------------------------------------------------------------------++instance HsValBinds [GHC.LStmt GHC.Name] where+ hsValBinds xs = unionBinds $ map hsValBinds xs+ replaceValBinds old _new = error $ "replaceValBinds [GHC.LStmt GHC.Name] undefined for:" ++ (showGhc old)+ hsTyDecls _ = []++-- ---------------------------------------------------------------------++instance HsValBinds (GHC.LStmt GHC.Name) where+ hsValBinds (GHC.L _ (GHC.LetStmt binds)) = hsValBinds binds+ hsValBinds _ = emptyValBinds+ replaceValBinds old _new = error $ "replaceValBinds (GHC.LStmt GHC.Name) undefined for:" ++ (showGhc old)+ hsTyDecls _ = []++-- ---------------------------------------------------------------------++instance HsValBinds [GHC.LPat GHC.Name] where+ hsValBinds _ = emptyValBinds+ replaceValBinds old _new = error $ "replaceValBinds (GHC.LPat GHC.Name) undefined for:" ++ (showGhc old)+ hsTyDecls _ = []++-- ---------------------------------------------------------------------++instance HsValBinds (GHC.LPat GHC.Name) where+ hsValBinds _ = emptyValBinds+ replaceValBinds old _new = error $ "replaceValBinds (GHC.LPat GHC.Name) undefined for:" ++ (showGhc old)+ hsTyDecls _ = []++-- ---------------------------------------------------------------------++instance HsValBinds (GHC.Name) where+ hsValBinds _ = emptyValBinds+ replaceValBinds old _new = error $ "replaceValBinds (GHC.Name) undefined for:" ++ (showGhc old)+ hsTyDecls _ = []++-- ---------------------------------------------------------------------++instance HsValBinds [GHC.SyntaxExpr GHC.Name] where+ hsValBinds _ = emptyValBinds+ replaceValBinds old _new = error $ "replaceValBinds (GHC.SyntaxExpr GHC.Name) undefined for:" ++ (showGhc old)+ hsTyDecls _ = []++-- ---------------------------------------------------------------------++instance HsValBinds [[GHC.LTyClDecl GHC.Name]] where+ hsValBinds _ = emptyValBinds+ replaceValBinds old _new = error $ "replaceValBinds [[GHC.LTyClDecl GHC.Name]] undefined for:" ++ (showGhc old)+ hsTyDecls _ = []++-- ---------------------------------------------------------------------++instance HsValBinds [GHC.LTyClDecl GHC.Name] where+ hsValBinds _ = emptyValBinds+ replaceValBinds old _new = error $ "replaceValBinds [GHC.LTyClDecl GHC.Name] undefined for:" ++ (showGhc old)+ hsTyDecls _ = []++-- ---------------------------------------------------------------------++instance HsValBinds (GHC.LTyClDecl GHC.Name) where+ hsValBinds _ = error $ "hsValBinds (GHC.LTyClDecl GHC.Name) must pull out tcdMeths"+ replaceValBinds old _new = error $ "replaceValBinds (GHC.LTyClDecl GHC.Name) undefined for:" ++ (showGhc old)+ hsTyDecls _ = []++-- ---------------------------------------------------------------------++instance HsValBinds [GHC.LInstDecl GHC.Name] where+ hsValBinds _ = emptyValBinds+ replaceValBinds old _new = error $ "replaceValBinds [GHC.LInstDecl GHC.Name] undefined for:" ++ (showGhc old)+ hsTyDecls _ = []++-- ---------------------------------------------------------------------++instance HsValBinds (GHC.LInstDecl GHC.Name) where+ hsValBinds _ = emptyValBinds+ replaceValBinds old _new = error $ "replaceValBinds (GHC.LInstDecl GHC.Name) undefined for:" ++ (showGhc old)+ hsTyDecls _ = []++-- ---------------------------------------------------------------------++instance HsValBinds (GHC.LHsType GHC.Name) where+ hsValBinds _ = emptyValBinds+ replaceValBinds old _new = error $ "replaceValBinds (GHC.LHsType GHC.Name) undefined for:" ++ (showGhc old)+ hsTyDecls _ = []++-- ---------------------------------------------------------------------++instance HsValBinds [GHC.LSig GHC.Name] where+ hsValBinds _ = emptyValBinds+ replaceValBinds old _new = error $ "replaceValBinds [GHC.LSig GHC.Name] undefined for:" ++ (showGhc old)+ hsTyDecls _ = []++-- ---------------------------------------------------------------------++instance HsValBinds (GHC.LSig GHC.Name) where+ hsValBinds _ = emptyValBinds+ replaceValBinds old _new = error $ "replaceValBinds (GHC.LSig GHC.Name) undefined for:" ++ (showGhc old)+ hsTyDecls _ = []++-- ---------------------------------------------------------------------++#if __GLASGOW_HASKELL__ > 704+instance HsValBinds [GHC.LFamInstDecl GHC.Name] where+ hsValBinds _ = emptyValBinds+ replaceValBinds old _new = error $ "replaceValBinds [GHC.LFamInstDecl GHC.Name] undefined for:" ++ (showGhc old)+ hsTyDecls _ = []+#endif++-- ---------------------------------------------------------------------++#if __GLASGOW_HASKELL__ > 704+instance HsValBinds (GHC.LFamInstDecl GHC.Name) where+ hsValBinds _ = emptyValBinds+ replaceValBinds old _new = error $ "replaceValBinds (GHC.LFamInstDecl GHC.Name) undefined for:" ++ (showGhc old)+ hsTyDecls _ = []+#endif++-- ---------------------------------------------------------------------++instance HsValBinds (GHC.HsIPBinds GHC.Name) where+ hsValBinds _ = emptyValBinds+ replaceValBinds old _new = error $ "replaceValBinds (GHC.HsIPBinds GHC.Name) undefined for:" ++ (showGhc old)+ hsTyDecls _ = []++-- ---------------------------------------------------------------------+++-- ---------------------------------------------------------------------++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, SYB.Typeable b) => a -> b -> Bool++-- ---------------------------------------------------------------------++instance FindEntity GHC.Name where++ findEntity n t = fromMaybe False res+ where+ res = somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t++ worker (name::GHC.Name)+ | 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 = somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t++ worker (name::GHC.Located GHC.Name)+ | n == name = Just True+ worker _ = Nothing+++-- ---------------------------------------------------------------------++instance FindEntity (GHC.Located (GHC.HsExpr GHC.Name)) where++ findEntity e t = fromMaybe False res+ where+ res = somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t++ worker (expr::GHC.Located (GHC.HsExpr 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 = 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 = somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t++ worker (decl::(GHC.Located (GHC.HsDecl GHC.Name)))+ | sameOccurrence d decl = Just True+ worker _ = Nothing++-- ---------------------------------------------------------------------++{-+-- | 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 -> Bool+findEntity a b = fromMaybe False res+ where+ res = somethingStaged SYB.Parser Nothing worker b++ worker :: (SYB.Typeable b, SYB.Data b) => b -> Maybe Bool+ worker b = if SYB.typeOf a == SYB.typeOf b+ -- then Just (getStartEndLoc b == getStartEndLoc a)+ then Just True -- ++AZ++ test for now+ else Nothing+-}+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 = somethingStaged SYB.Parser Nothing worker b++ worker :: (SYB.Typeable c,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++-- ---------------------------------------------------------------------++-- |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))+ | defines' ns /= [] = [(GHC.L l (GHC.TypeSig (defines' ns) t))]+ inSig _ = []++ defines' (p::[GHC.Located GHC.Name])+ = filter (\(GHC.L _ n) -> n `elem` pns) p++-- ---------------------------------------------------------------------++-- 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+++-- ---------------------------------------------------------------------++-- | 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) _ _ _ _ _))+ = pname == n+defines n (GHC.L _ (GHC.PatBind p _rhs _ty _fvs _))+ = elem n (hsNamess p)+defines _ _= 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 pn $ map (\(GHC.L _ n)->n) names+definesTypeSig _ _ =False+++{-+-- | Return True if the declaration defines the type signature of the specified identifier.+isTypeSigOf :: PNT -> HsDeclP -> Bool+isTypeSigOf pnt (TiDecorate.Dec (HsTypeSig loc is c tp))= elem pnt is+isTypeSigOf _ _ =False+-}+++-- | 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]++-- TODO: what about GHC.AbsBinds?+definedPNs _ = []+++--------------------------------------------------------------------------------++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++instance UsedByRhs GHC.RenamedSource where++ -- Defined like this in the original+ usedByRhs _renamed _pns = False+ -- usedByRhs renamed pns = usedByRhs (hsValBinds renamed) pns -- ++AZ++++instance UsedByRhs (GHC.LHsBinds GHC.Name) where+ usedByRhs binds pns = or $ map (\b -> usedByRhs b pns) $ GHC.bagToList binds++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++instance UsedByRhs (GHC.Match GHC.Name) where+ usedByRhs (GHC.Match _ _ (GHC.GRHSs rhs _)) pns -- = usedByRhs (hsValBinds rhs) pns+ = findPNs pns rhs++instance UsedByRhs [GHC.LHsBind GHC.Name] where+ usedByRhs binds pns = or $ map (\b -> usedByRhs b pns) binds++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++instance UsedByRhs (GHC.LHsBind GHC.Name) where+ usedByRhs (GHC.L _ bind) pns = usedByRhs bind pns++instance UsedByRhs (GHC.LHsExpr GHC.Name) where+ usedByRhs (GHC.L _ e) pns = usedByRhs e pns++instance UsedByRhs (GHC.HsExpr GHC.Name) where+ usedByRhs (GHC.HsLet _lb e) pns = findPNs pns e+ usedByRhs e _pns = error $ "undefined usedByRhs:" ++ (showGhc e)++instance UsedByRhs (GHC.Stmt GHC.Name) where+ usedByRhs (GHC.LetStmt lb) pns = findPNs pns lb+ usedByRhs s _pns = error $ "undefined usedByRhs:" ++ (showGhc s)+++--------------------------------------------------------------------------------++-- |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' SYB.Renamer (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' SYB.Parser (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'::(SYB.Data t, SYB.Data a, Eq a,GHC.Outputable a)+ =>SYB.Stage+ ->SimpPos -- ^ The row and column number+ ->t -- ^ The syntax phrase+ -> Maybe (GHC.Located a) -- ^ The result+locToName' stage (row,col) t =+ if res1 /= Nothing+ then res1+ else res2+ where+ res1 = somethingStaged stage Nothing+ (Nothing `SYB.mkQ` worker+ `SYB.extQ` workerBind+ `SYB.extQ` workerExpr+ `SYB.extQ` workerLIE+ `SYB.extQ` workerHsTyVarBndr+ `SYB.extQ` workerLHsType+ ) t++ res2 = somethingStaged stage Nothing+ (Nothing `SYB.mkQ` workerFunBind) t++ {-+ res = reverse $ everythingStaged SYB.Renamer (++) []+ ([] `SYB.mkQ` workerFunBind `SYB.extQ` worker `SYB.extQ` workerBind `SYB.extQ` workerExpr) t++ res' = case res of+ [] -> Nothing+ xs -> Just (head xs)+ -}+ -- A FunBind has a MatchGroup, which lists all the possible+ -- bindings. Hence+ -- x 0 = 0+ -- x y = 2 * y+ -- Will have a single FunBind, with name x and using the+ -- specific (GHC.L l GHC.Name) of the x on the first line.+ -- Attempting to find the variable x on the second line will+ -- fail, it needs to be deduced from a FunBind having more+ -- than one match. The Located Match includes the original+ -- variable name in the location, but not in the match contents+ workerFunBind ((GHC.FunBind pnt _ (GHC.MatchGroup matches _) _ _ _) :: (GHC.HsBindLR a a))+ | nonEmptyList match = Just pnt+ where+ -- match = error $ "locToName':matches=" ++ (showGhc $ map (\(GHC.L l _) -> l) matches)+ match = filter inScope (tail matches)+ -- match = filter inScope (matches)+ workerFunBind _ = Nothing++ worker (pnt :: (GHC.Located a))+ | inScope pnt = Just pnt+ worker _ = Nothing++ workerBind pnt@(GHC.L l (GHC.VarPat name) :: (GHC.Located (GHC.Pat a)))+ | inScope pnt = Just (GHC.L l name)+ workerBind _ = Nothing++ workerExpr (pnt@(GHC.L l (GHC.HsVar name)) :: (GHC.Located (GHC.HsExpr a)))+ | inScope pnt = Just (GHC.L l name)+ workerExpr _ = Nothing++ workerLIE (pnt@(GHC.L l (GHC.IEVar name)) :: (GHC.LIE a))+ | inScope pnt = Just (GHC.L l name)+ workerLIE _ = Nothing++#if __GLASGOW_HASKELL__ > 704+ workerHsTyVarBndr (pnt@(GHC.L l (GHC.UserTyVar name)):: (GHC.LHsTyVarBndr a))+#else+ workerHsTyVarBndr (pnt@(GHC.L l (GHC.UserTyVar name _typ)):: (GHC.LHsTyVarBndr a))+#endif+ | inScope pnt = Just (GHC.L l name)+ workerHsTyVarBndr _ = Nothing++ workerLHsType (pnt@(GHC.L l (GHC.HsTyVar name)):: (GHC.LHsType a))+ | inScope pnt = Just (GHC.L l name)+ workerLHsType _ = Nothing+++ inScope :: GHC.Located e -> Bool+ inScope (GHC.L l _) =+ case l of+ (GHC.UnhelpfulSpan _) -> False+ (GHC.RealSrcSpan ss) ->+ -- (GHC.srcSpanFile ss == fileName) &&+ (GHC.srcSpanStartLine ss <= row) &&+ (GHC.srcSpanEndLine ss >= row) &&+ (col >= (GHC.srcSpanStartCol ss)) &&+ (col <= (GHC.srcSpanEndCol ss))+++--------------------------------------------------------------------------------++-- |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 _ = []++++--------------------------------------------------------------------------------++-- |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 = somethingStaged SYB.Renamer Nothing+ (Nothing `SYB.mkQ` worker `SYB.extQ` workerBind `SYB.extQ` workerExpr) t++ worker ((GHC.L _ n) :: (GHC.Located GHC.Name))+ | showGhc n == str = Just n+ worker _ = Nothing++ workerBind (GHC.L _ (GHC.VarPat name) :: (GHC.Located (GHC.Pat GHC.Name)))+ | showGhc name == str = Just name+ workerBind _ = Nothing+++ workerExpr ((GHC.L _ (GHC.HsVar name)) :: (GHC.Located (GHC.HsExpr GHC.Name)))+ | showGhc 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.+{-+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+-}++{-+addItemsToImport::( )+ =>ModuleName -- ^ The imported module name.+ ->Maybe PName -- ^ The condition identifier.+ ->Either [String] [EntSpecP] -- ^ The identifiers to add in either String or EntSpecP format.+ ->t -- ^ The given syntax phrase.+ ->m t -- ^ The result.+-}++{-+addItemsToImport::(Term t,MonadState (([PosToken],Bool),t1) m)+ =>ModuleName -- ^ The imported module name.+ ->Maybe PName -- ^ The condition identifier.+ ->Either [String] [EntSpecP] -- ^ The identifiers to add in either String or EntSpecP format.+ ->t -- ^ The given syntax phrase.+ ->m t -- ^ The result.++addItemsToImport serverModName pn (Left []) t = return t+addItemsToImport serverModName pn (Right []) t = return t+addItemsToImport serverModName pn ids t+ =applyTP (full_buTP (idTP `adhocTP` inImport)) t+ where+ inImport (imp@(HsImportDecl loc m@(SN modName _) qual as h):: HsImportDeclP)+ | serverModName == modName && (if isJust pn then findPN (fromJust pn) h else True)+ = case h of+ Nothing -> return imp+ Just (b, ents) -> do let ents'=case ids of+ Left is' -> map (\x-> Var (nameToPNT x)) is'+ Right es -> es+ ((toks,_),others)<-get+ let (_,endPos)=getStartEndLoc toks (glast "addItemsToImport" ents)+ (t,(_,s))=ghead "addItemsToImport" $ getToks (endPos,endPos) toks+ newToken = mkToken t endPos (s++","++showEntities (render.ppi) ents')+ toks'=replaceToks toks endPos endPos [newToken]+ put ((toks',modified),others)+ return (HsImportDecl loc m qual as (Just (b, ents++ents')))+ inImport imp = return imp+-}++-- ---------------------------------------------------------------------++addImportDecl ::+ GHC.RenamedSource+ -> GHC.ModuleName+ -> Maybe GHC.FastString -- ^qualifier+ -> Bool -> Bool -> Bool+ -> Maybe String -- ^alias+ -> Bool+ -> [GHC.Name]+ -> RefactGhc GHC.RenamedSource+addImportDecl (groupedDecls,imp, b, c) modName pkgQual source safe qualify alias hide idNames+ = do+ toks <- fetchToks+ let toks1+ =if length imps' > 0+ then let (_startLoc, endLoc) = getStartEndLoc $ last imps'+ toks1' = getToks ((1,1),endLoc) toks+ in toks1'+ else if not $ isEmptyGroup groupedDecls+ then+ let startLoc = fst $ startEndLocIncComments toks groupedDecls+ (toks1', _toks2') = break (\t ->tokenPos t==startLoc) toks+ in toks1'+ else toks++ -- drawTokenTreeDetailed "before starting"+ logm $ "addImportDecl:toks =" ++ show toks+ logm $ "addImportDecl:toks1=" ++ show toks1++ let lastTok = ghead "addImportDecl" $ dropWhile isWhiteSpace $ reverse toks1+ let startPos = tokenPos lastTok+ let endPos = tokenPosEnd lastTok++ newToks <- liftIO $ basicTokenise (showGhc impDecl)+ logm $ "addImportDecl:newToks=" ++ (show newToks) -- ++AZ+++ void $ putToksAfterPos (startPos,endPos) (PlaceOffset 1 0 1) newToks+ return (groupedDecls, (imp++[(mkNewLSomething impDecl)]), b, c)+ where++ alias' = case alias of+ Just stringName -> Just $ GHC.mkModuleName stringName+ _ -> Nothing++ impDecl = GHC.ImportDecl {+ GHC.ideclName = mkNewLModuleName modName+ , 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, map mkNewEnt idNames)))+ }+ imps' = rmPreludeImports imp++ mkNewLSomething :: a -> GHC.Located a+ mkNewLSomething a = (GHC.L l a) where+ filename = (GHC.mkFastString "f")+ l = GHC.mkSrcSpan (GHC.mkSrcLoc filename 1 1) (GHC.mkSrcLoc filename 1 1)+++ mkNewLModuleName :: GHC.ModuleName -> GHC.Located GHC.ModuleName+ mkNewLModuleName moduName = mkNewLSomething moduName++-- ---------------------------------------------------------------------++isEmptyGroup :: GHC.HsGroup id -> Bool+isEmptyGroup x = (==0) $ sum $+ [valds, tyclds, instds, derivds, fixds, defds, fords, warnds, annds, ruleds, vects, docs]+ where+ valds = size $ GHC.hs_valds x++ size :: GHC.HsValBindsLR idL idR -> Int+ size (GHC.ValBindsIn lhsBinds sigs) = (length sigs) + (length . GHC.bagToList $ lhsBinds)+ size (GHC.ValBindsOut recFlags lsigs) = (length lsigs) + (length recFlags)++ tyclds = length $ GHC.hs_tyclds x++ instds = length $ GHC.hs_instds x++ derivds = length $ GHC.hs_derivds x++ fixds = length $ GHC.hs_fixds x++ defds = length $ GHC.hs_defds x++ fords = length $ GHC.hs_fords x++ warnds = length $ GHC.hs_warnds x++ annds = length $ GHC.hs_annds x++ ruleds = length $ GHC.hs_ruleds x++ vects = length $ GHC.hs_vects x++ docs = length $ GHC.hs_docs x+++-- | Remove ImportDecl from the imports list, commonly returned from a RenamedSource type, so it can+-- be further processed.+--rmPreludeImports :: [GHC.Located (GHC.ImportDecl GHC.Name)] -> [GHC.Located (GHC.ImportDecl GHC.Name)]+rmPreludeImports ::+ [GHC.Located (GHC.ImportDecl GHC.Name)]+ -> [GHC.Located (GHC.ImportDecl GHC.Name)]+rmPreludeImports = filter isPrelude where+ isPrelude = (/="Prelude") . GHC.moduleNameString . GHC.unLoc . GHC.ideclName . GHC.unLoc+++-- ---------------------------------------------------------------------++-- |Make a new set of tokens, originating at (0,0), for a given+-- declaration and optional signature.+-- NOTE: This function returns tokens originating at (0,0), to be+-- stitched in at the right place by TokenUtils+makeNewToks :: (GHC.LHsBind GHC.Name, [GHC.LSig GHC.Name], Maybe [PosToken])+ -> RefactGhc [PosToken]+makeNewToks (decl, maybeSig, declToks) = do+ let+ declStr = case declToks of+ Just ts -> "\n" ++ (unlines $ dropWhile (\l -> l == "") $ lines $ GHC.showRichTokenStream $ reAlignMarked ts)+ Nothing -> "\n"++(prettyprint decl)++"\n\n"+ sigStr = case declToks of+ Just _ts -> ""+ Nothing -> "\n" ++ (intercalate "\n" $ map prettyprint maybeSig)+ -- logm $ "makeNewToks:declStr=[" ++ declStr ++ "]"+ newToks <- liftIO $ tokenise (realSrcLocFromTok mkZeroToken) 0 True (sigStr ++ declStr)+ return newToks++-- ---------------------------------------------------------------------++-- | 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,HsValBinds 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.LHsBind GHC.Name, [GHC.LSig GHC.Name], Maybe [PosToken])+ -- ^ The declaration with optional signatures to be added,+ -- in both AST and Token stream format (optional). If+ -- signature and tokens provided, the tokens should+ -- include the signature too+ -> Bool -- ^ True means the declaration is a+ -- toplevel declaration.+ -> RefactGhc t++addDecl parent pn (decl, msig, declToks) topLevel+ = if isJust pn+ then appendDecl parent (gfromJust "addDecl" pn) (decl, msig, declToks)+ else if topLevel+ then addTopLevelDecl (decl, msig, declToks) parent+ else addLocalDecl parent (decl,msig,declToks)+ where++ -- ^Add a definition to the beginning of the definition declaration+ -- list, but after the data type declarations if there is any. The+ -- definition will be pretty-printed if its token stream is not+ -- provided.+ addTopLevelDecl :: (SYB.Data t, HsValBinds t)+ => (GHC.LHsBind GHC.Name, [GHC.LSig GHC.Name], Maybe [PosToken])+ -> t -> RefactGhc t+ addTopLevelDecl (newDecl, maybeSig, maybeDeclToks) parent'+ = do let binds = hsValBinds parent'+ decls = hsBinds parent'+ (decls1,decls2) = break (\x->isFunOrPatBindR x {- was || isTypeSig x -}) decls++ newToks <- makeNewToks (newDecl,maybeSig,maybeDeclToks)+ logm $ "addTopLevelDecl:newToks=" ++ (show newToks)++ let Just sspan = if (emptyList decls2)+ then getSrcSpan (glast "addTopLevelDecl" decls1)+ else getSrcSpan (ghead "addTopLevelDecl" decls2)++ decl' <- putDeclToksAfterSpan sspan newDecl (PlaceOffset 2 0 2) newToks++ return (replaceValBinds parent' (GHC.ValBindsIn (GHC.listToBag (decls1++[decl']++decls2)) (maybeSig++(getValBindSigs binds))))++ appendDecl :: (SYB.Data t, HsValBinds t)+ => t -- ^Original AST+ -> GHC.Name -- ^Name to add the declaration after+ -> (GHC.LHsBind GHC.Name, [GHC.LSig GHC.Name], Maybe [PosToken]) -- ^declaration and maybe sig/tokens+ -> RefactGhc t -- ^updated AST+ appendDecl parent' pn' (newDecl, maybeSig, declToks')+ = do let binds = hsValBinds parent'+ -- logm $ "appendDecl:declToks=" ++ (show declToks')+ newToks <- makeNewToks (newDecl,maybeSig,declToks')+ -- logm $ "appendDecl:newToks=" ++ (show newToks)++ let Just sspan = getSrcSpan $ ghead "appendDecl" after+ decl' <- putDeclToksAfterSpan sspan newDecl (PlaceOffset 2 0 2) newToks++ let decls1 = before ++ [ghead "appendDecl14" after]+ decls2 = gtail "appendDecl15" after+ {-+ case maybeSig of+ Nothing -> return (replaceBinds parent (decls1++[decl']++decls2))+ Just sig -> return (replaceValBinds parent (GHC.ValBindsIn (GHC.listToBag (decls1++[decl']++decls2)) (sig:(getValBindSigs binds))))+ -}+ return (replaceValBinds parent' (GHC.ValBindsIn (GHC.listToBag (decls1++[decl']++decls2)) (maybeSig++(getValBindSigs binds))))+ where+ decls = hsBinds parent'+ (before,after) = break (defines pn') decls -- Need to handle the case that 'after' is empty?+++ addLocalDecl :: (SYB.Data t, HsValBinds t)+ => t -> (GHC.LHsBind GHC.Name, [GHC.LSig GHC.Name], Maybe [PosToken])+ -> RefactGhc t+ addLocalDecl parent' (newFun, maybeSig, newFunToks)+ =do+ let binds = hsValBinds parent'++ let (startLoc@((_,prevCol)),endLoc)+ = if (emptyList localDecls)+ then getStartEndLoc parent'+ else getStartEndLoc localDecls++ newToks <- liftIO $ basicTokenise newSource++ (newFun',_) <- addLocInfo (newFun, newToks)++ let rowIndent = 1++ if (emptyList localDecls)+ then+ void $ putToksAfterPos (startLoc,endLoc) (PlaceOffset rowIndent 4 2) newToks+ else+ void $ putToksAfterPos (startLoc,endLoc) (PlaceAbsCol (rowIndent+1) prevCol 2) newToks+++ return (replaceValBinds parent' (GHC.ValBindsIn (GHC.listToBag ((hsBinds parent' ++ [newFun']))) (maybeSig++(getValBindSigs binds))))+ where+ localDecls = hsBinds parent'++ -- TODO: where tokens are passed in, first normalise them to+ -- the left column before adding in the where clause part+ newSource = if (emptyList localDecls)+ then "where\n"++ concatMap (\l-> " "++l++"\n") (lines newFun')+ else ("" ++ newFun'++"\n")+ where+ newFun' = unlines $ stripLeadingSpaces $ lines $ sigStr ++ newFunBody+ newFunBody = case newFunToks of+ Just ts -> unlines $ dropWhile (\l -> l == "") $ lines $ GHC.showRichTokenStream $ reAlignMarked ts+ Nothing -> prettyprint newFun++ sigStr = case newFunToks of+ Just _ts -> ""+ Nothing -> if (emptyList maybeSig)+ then ""+ else (intercalate "\n" $ map prettyprint maybeSig) ++ "\n"++-- ---------------------------------------------------------------------++-- |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.RenamedSource -- ^ The current module+ ->[GHC.Name] -- ^ The items to be added+ ->RefactGhc GHC.RenamedSource -- ^ The result (with token stream updated)+addHiding a b c = addItemsToImport' a b c Hide++-- | Creates a new entity for hiding a name in an ImportDecl.+mkNewEnt :: GHC.Name -> GHC.LIE GHC.Name+mkNewEnt pn = (GHC.L l (GHC.IEVar pn))+ where+ filename = (GHC.mkFastString "f")+ l = GHC.mkSrcSpan (GHC.mkSrcLoc filename 1 1) (GHC.mkSrcLoc filename 1 1)++-- | 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.RenamedSource -- ^ The current module+ ->[GHC.Name] -- ^ The items to be added+-- ->Maybe GHC.Name -- ^ The condition identifier.+ ->RefactGhc GHC.RenamedSource -- ^ The result (with token stream updated)+addItemsToImport a b c = addItemsToImport' a b c 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.RenamedSource -- ^ The current module+ ->[GHC.Name] -- ^ 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.RenamedSource -- ^ The result (with token stream updated)+addItemsToImport' serverModName (g,imps,e,d) pns impType = do+ imps' <- mapM inImport imps+ return (g,imps',e,d)+ where+ isHide = case impType of+ Hide -> True+ Import -> False++ inImport :: GHC.LImportDecl GHC.Name -> RefactGhc (GHC.LImportDecl GHC.Name)+ inImport imp@(GHC.L _ (GHC.ImportDecl (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, ents) -> insertEnts imp ents False+ inImport x = return x++ insertEnts ::+ GHC.LImportDecl GHC.Name+ -> [GHC.LIE GHC.Name]+ -> Bool+ -> RefactGhc ( GHC.LImportDecl GHC.Name )+ insertEnts imp ents isNew =+ if isNew && not isHide then return imp+ else do+ toks <- fetchToks+ let (startPos,endPos) = getStartEndLoc imp+ ((GHC.L l t),s) = ghead "addHiding" $ reverse $ getToks (startPos,endPos) toks+ start = getGhcLoc l+ end = getGhcLocEnd l++ beginning =+ if isNew then+ s ++ (if isHide then " hiding " else " ")++"("+ else ","+ ending = if isNew then ")" else s++ newToken=mkToken t start (beginning++showEntities showGhc pns ++ending)+ -- toks'=replaceToks toks start end [newToken]+ -- toks'=replaceTok toks start newToken++ void $ putToksForPos (start,end) [newToken]++ return (replaceHiding imp (Just (isHide, (map mkNewEnt pns)++ents)))+++ replaceHiding (GHC.L l (GHC.ImportDecl mn q src safe isQ isImp as _h)) h1 =+ (GHC.L l (GHC.ImportDecl mn q src safe isQ isImp as h1))++-- ---------------------------------------------------------------------++addParamsToDecls::+ [GHC.LHsBind GHC.Name] -- ^ A declaration list where the function is defined and\/or used.+ ->GHC.Name -- ^ The function name.+ ->[GHC.Name] -- ^ The parameters to be added.+ ->Bool -- ^ Modify the token stream or not.+ ->RefactGhc [GHC.LHsBind GHC.Name] -- ^ The result.++addParamsToDecls decls pn paramPNames modifyToks = do+ logm $ "addParamsToDecls (pn,paramPNames,modifyToks)=" ++ (showGhc (pn,paramPNames,modifyToks))+ -- logm $ "addParamsToDecls: decls=" ++ (SYB.showData SYB.Renamer 0 decls)+ if (paramPNames/=[])+ then mapM addParamToDecl decls+ else return decls+ where+ addParamToDecl :: GHC.LHsBind GHC.Name -> RefactGhc (GHC.LHsBind GHC.Name)+ addParamToDecl (GHC.L l1 (GHC.FunBind (GHC.L l2 pname) i (GHC.MatchGroup matches ptt) co fvs t))+ | pname == pn+ = do matches' <- mapM addParamtoMatch matches+ return (GHC.L l1 (GHC.FunBind (GHC.L l2 pname) i (GHC.MatchGroup matches' ptt) co fvs t))+ where+ -- addParamtoMatch (HsMatch loc fun pats rhs decls)+ addParamtoMatch (GHC.L l (GHC.Match pats mtyp rhs))+ = do rhs' <- addActualParamsToRhs modifyToks pn paramPNames rhs+ let pats' = map GHC.noLoc $ map pNtoPat paramPNames+ _pats'' <- if modifyToks+ then do -- TODO: What happens if pats is []+ -- Will only happen if there is a single match only.+ logm $ "addParamtoMatch:l=" ++ (showGhc l)+ if emptyList pats+ then addFormalParams (Left l2) pats'+ else addFormalParams (Right pats) pats'+ return pats'++ else return pats'+ -- return (HsMatch loc fun (pats'++pats) rhs' decls)+ return (GHC.L l (GHC.Match (pats'++pats) mtyp rhs'))++ -- addParamToDecl (TiDecorate.Dec (HsPatBind loc p rhs ds))+ addParamToDecl (GHC.L l1 (GHC.PatBind pat@(GHC.L _l2 (GHC.VarPat p)) rhs ty fvs t))+ | p == pn+ = do _rhs'<-addActualParamsToRhs modifyToks pn paramPNames rhs+ let pats' = map GHC.noLoc $ map pNtoPat paramPNames+ _pats'' <- if modifyToks then do _ <- addFormalParams (Right [pat]) pats'+ return pats'+ else return pats'+ -- return (TiDecorate.Dec (HsFunBind loc [HsMatch loc (patToPNT p) pats' rhs ds]))+ return (GHC.L l1 (GHC.PatBind pat rhs ty fvs t))+ addParamToDecl x=return x+++-- | Add tokens corresponding to the new parameters to the end of the+-- syntax element provided+addFormalParams+ :: Either GHC.SrcSpan [(GHC.LPat GHC.Name)] -- location: SrcSpan only+ -- if no existing params, else list+ -- of current params+ -> [(GHC.LPat GHC.Name)] -- params to add+ -> RefactGhc ()+addFormalParams place newParams+ = do+ -- logm $ "addFormalParams:(place,newParams):" ++ (SYB.showData SYB.Renamer 0 (place,newParams))+ -- newToks <- liftIO $ basicTokenise (prettyprintPatList prettyprint True newParams)+ let newStr = (prettyprintPatList prettyprint True newParams)++ case place of+ Left l@(GHC.RealSrcSpan ss) -> do+ newToks' <- liftIO $ tokenise (GHC.realSrcSpanStart ss) 0 False newStr+ let newToks = map markToken newToks'+ _ <- putToksAfterSpan l PlaceAdjacent newToks+ return ()+ Left ss -> error $ "addFormalParams: expecting RealSrcSpan, got:" ++ (showGhc ss)+ Right pats -> do+ let l = GHC.combineLocs (ghead "addFormalParams" pats) (glast "addFormalParams" pats)+ -- logm $ "addFormalParams:(l,pats)=" ++ (SYB.showData SYB.Renamer 0 (l,pats))+ toks <- getToksForSpan l++ let oldStr = GHC.showRichTokenStream $ rmOffsetFromToks toks+ combinedToks <- liftIO $ tokenise (realSrcLocFromTok+ $ ghead "addFormalParams" toks)+ 0 False (newStr ++ " " ++ oldStr)++ _ <- putToksForSpan l combinedToks++ return ()++ -- drawTokenTree "after addFormalParams"+ -- drawTokenTreeDetailed "after addFormalParams"++-- ---------------------------------------------------------------------++addActualParamsToRhs :: (SYB.Typeable t, SYB.Data t) =>+ Bool -> GHC.Name -> [GHC.Name] -> t -> RefactGhc t+addActualParamsToRhs modifyToks pn paramPNames rhs = do+ -- logm $ "addActualParamsToRhs:rhs=" ++ (SYB.showData SYB.Renamer 0 $ rhs)++ -- = applyTP (stop_tdTP (failTP `adhocTP` worker))++ r <- applyTP (stop_tdTPGhc (failTP `adhocTP` grhs)) rhs+ -- r <- everywhereMStaged SYB.Renamer (SYB.mkM grhs) rhs+ return r+ where++ -- |Limit the action to actual RHS elements+ grhs :: (GHC.GRHSs GHC.Name) -> RefactGhc (GHC.GRHSs GHC.Name)+ grhs (GHC.GRHSs g lb) = do+ -- logm $ "addActualParamsToRhs.grhs:g=" ++ (SYB.showData SYB.Renamer 0 g)+ g' <- everywhereMStaged SYB.Renamer (SYB.mkM worker) g+ return (GHC.GRHSs g' lb)++ worker :: (GHC.Located (GHC.HsExpr GHC.Name)) -> RefactGhc (GHC.Located (GHC.HsExpr GHC.Name))+ worker oldExp@(GHC.L l2 (GHC.HsVar pname))+ | pname == pn = do+ -- logm $ "addActualParamsToRhs:oldExp=" ++ (SYB.showData SYB.Renamer 0 oldExp)+ let newExp' = foldl addParamToExp oldExp paramPNames+ let newExp = (GHC.L l2 (GHC.HsPar newExp'))+ -- TODO: updateToks must add a space at the end of the+ -- new exp+ if modifyToks then do _ <- updateToks oldExp newExp prettyprint False+ return newExp+ else return newExp+ worker x = return x++ addParamToExp :: (GHC.LHsExpr GHC.Name) -> GHC.Name -> (GHC.LHsExpr GHC.Name)+ addParamToExp expr param = GHC.noLoc (GHC.HsApp expr (GHC.noLoc (GHC.HsVar param)))+++{-+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}))))))))] ++-}+++{-+ addActualParamsToRhs pn paramPNames+ = applyTP (stop_tdTP (failTP `adhocTP` worker))+ where+ worker exp@(TiDecorate.Exp (HsId (HsVar (PNT pname ty loc))))+ | pname==pn+ = do let newExp=TiDecorate.Exp (HsParen (foldl addParamToExp exp (map pNtoExp paramPNames)))+ if modifyToks then do (newExp', _) <- updateToks exp newExp prettyprint+ return newExp'+ else return newExp+ worker x =mzero++ addParamToExp exp param=(TiDecorate.Exp (HsApp exp param))+-}++++-- | Remove those specified items from the entity list in the import declaration.+{-+ rmItemsFromImport::( )+ =>HsModuleP -- ^ The module AST+ ->[PName] -- ^ The items to be removed+ ->m HsModuleP -- ^ The result+-}++{-+rmItemsFromImport::(MonadState (([PosToken],Bool),t1) m)+ =>HsModuleP -- ^ The module AST+ ->[PName] -- ^ The items to be removed+ ->m HsModuleP -- ^ The result+++rmItemsFromImport mod pns+ = applyTP (full_buTP (idTP `adhocTP` inImport)) mod+ where+ inImport (imp@(HsImportDecl loc modName qual as h)::HsImportDeclP)+ | any (flip findEntity imp) pns+ = case h of+ Just (b, ents) ->+ do let matchedEnts=findEnts pns ents+ if matchedEnts==[]+ then return imp+ else if length matchedEnts == length ents+ then do ((toks,_),others)<-get+ let (startPos,endPos)=getStartEndLoc toks ents+ toks'=deleteToks toks startPos endPos+ put ((toks',modified),others)+ return (HsImportDecl loc modName qual as (Just (b,[])))+ else do ((toks,_),others)<-get+ let remainedEnts=concatMap (\pn->filter (not.match pn) ents) pns + toks'=foldl deleteEnt toks $ map (getStartEndLoc toks) matchedEnts+ put ((toks',modified),others)+ return (HsImportDecl loc modName qual as (Just (b, remainedEnts)))+ _ ->return imp+ inImport x = return x++ findEnts pns ents =nub $ concatMap (\pn->filter (match pn) ents) pns++ -- this function does not check this sub entities of the ListSubs. any problems?+ match::PName -> EntSpec PNT ->Bool+ match pn (Var pnt) = pNTtoPN pnt == pn+ match pn (Abs pnt) = pNTtoPN pnt == pn+ match pn (AllSubs pnt) = pNTtoPN pnt == pn+ match pn (ListSubs pnt _) = pNTtoPN pnt == pn+-}+++{-+-- | Remove the sub entities of a type constructor or class from the export list.+rmSubEntsFromExport::(MonadState (([PosToken],Bool),(Int,Int)) m)+ =>PName -- ^ The type constructor or class name+ ->HsModuleP -- ^ The module AST+ ->m HsModuleP -- ^ The result+rmSubEntsFromExport typeCon+ = applyTP (full_buTP (idTP `adhocTP` inEntSpec))+ where+ inEntSpec (ent@(AllSubs pnt)::EntSpec PNT)+ | pNTtoPN pnt == typeCon+ =do (ent', _)<-updateToks ent (Abs pnt) prettyprint+ return ent'+ inEntSpec (ent@(ListSubs pnt _))+ | pNTtoPN pnt == typeCon+ = do (ent', _) <- updateToks ent (Abs pnt) prettyprint+ return ent'+ inEntSpec ent = return ent+-}++---------------------------------------------------------------------------------------+-- | Remove the specified entities from the module's exports. The entities can be specified in either of two formats:+-- i.e. either specify the module names and identifier names to be removed, so just given the exact AST for these entities.+{-rmItemsFromExport::( )+ =>HsModuleP -- ^ The module AST.+ ->Either ([ModuleName],[PName]) [HsExportEntP] -- ^ The entities to remove. + ->m HsModuleP -- ^ The result.+-}+{-+rmItemsFromExport::(MonadState (([PosToken],Bool),t1) m)+ =>HsModuleP -- ^ The module AST.+ ->Either ([ModuleName],[PName]) [HsExportEntP] -- ^ The entities to remove.+ ->m HsModuleP -- ^ The result.++rmItemsFromExport mod@(HsModule loc modName exps imps ds) (Left (modNames, pns))+ =if isNothing exps+ then return mod+ else do let ents =findEnts (modNames, pns) (fromJust exps)+ rmItemsFromExport mod (Right ents)+ where+ findEnts (modNames, pns) ents+ =let ms = concatMap (\m ->filter (\e -> case e of+ ModuleE (SN m' _) -> m==m'+ EntE e' -> False) ents) modNames+ es =concatMap (\pn->filter (\e ->case e of+ ModuleE _ -> False+ EntE e' -> match pn e') ents) pns+ in (ms++es)+ match::PName -> EntSpec PNT ->Bool+ match pn (Var pnt) = pNTtoPN pnt == pn+ match pn (Abs pnt) = pNTtoPN pnt == pn+ match pn (AllSubs pnt) = pNTtoPN pnt == pn+ match pn (ListSubs pnt _) = pNTtoPN pnt == pn++rmItemsFromExport mod@(HsModule loc modName exps@(Just es) imps ds) (Right ents)+ = do exps'<- if ents==[]+ then return exps+ else if length ents == length es+ then do ((toks,_),others)<-get+ let (startPos,endPos) = getStartEndLoc toks ents+ toks'= deleteToks toks startPos endPos+ put ((toks',modified),others)+ return (Just [] ) -- should not remove the empty bracket!!!+ else do ((toks,_),others)<-get+ let toks' = foldl deleteEnt toks $ map (getStartEndLoc toks) ents+ put ((toks',modified),others)+ return (Just (es \\ ents))+ return (HsModule loc modName exps' imps ds)+rmItemsFromExport mod _ = return mod+-}++-- ---------------------------------------------------------------------++-- | Duplicate a function\/pattern binding declaration under a new name+-- right after the original one. Also updates the token stream.+duplicateDecl::(SYB.Data t) =>+ [GHC.LHsBind GHC.Name] -- ^ The declaration list+ ->t -- ^ Any signatures are in here+ ->GHC.Name -- ^ The identifier whose definition is to be duplicated+ ->GHC.Name -- ^ The new name (possibly qualified)+ ->RefactGhc [GHC.LHsBind GHC.Name] -- ^ The result+duplicateDecl decls sigs n newFunName+ = do+ let Just sspan = getSrcSpan funBinding+ toks <- getToksForSpan sspan+ -- lay <- getLayoutForSpan sspan++ newSpan <- case typeSig of+ [] -> return sspan+ _ -> do+ let Just sspanSig = getSrcSpan typeSig+ toksSig <- getToksForSpan sspanSig+ -- laySig <- getLayoutForSpan sspanSig++ let colStart = tokenCol $ ghead "duplicateDecl.sig"+ $ dropWhile isWhiteSpace toksSig++ typeSig' <- putDeclToksAfterSpan sspan (ghead "duplicateDecl" typeSig) (PlaceAbsCol 2 colStart 0) toksSig+ _typeSig'' <- renamePN n newFunName True False typeSig'++ let (GHC.L sspanSig' _) = typeSig'++ return sspanSig'++ let rowOffset = case typeSig of+ [] -> 2+ _ -> 1++ let colStart = tokenCol $ ghead "duplicateDecl.decl"+ $ dropWhile isWhiteSpace toks++ funBinding' <- putDeclToksAfterSpan newSpan (ghead "duplicateDecl" funBinding) (PlaceAbsCol rowOffset colStart 2) toks+ funBinding'' <- renamePN n newFunName True False funBinding'++ -- return (typeSig'++funBinding') -- ++AZ++ TODO: reinstate this+ return [funBinding'']+ where+ declsToDup = definingDeclsNames [n] decls True False -- ++AZ++ should recursive be set true?+ funBinding = filter isFunOrPatBindR declsToDup --get the fun binding.+ typeSig = definingSigsNames [n] sigs++-- ---------------------------------------------------------------------++-- | 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+ -> RefactGhc+ (t,+ GHC.LHsBind GHC.Name,+ Maybe (GHC.LSig GHC.Name)) -- ^ The result and the removed+ -- declaration, with SrcSpans+ -- adjusted to reflect the stashed+ -- tokens and the possibly removed+ -- siganture+rmDecl pn incSig t = do+ logm $ "rmDecl:(pn,incSig)= " ++ (showGhc (pn,incSig)) -- ++AZ+++ -- drawTokenTreeDetailed "rmDecl.entry tree" -- ++AZ++ 'in' present+ setStateStorage StorageNone+ t2 <- everywhereMStaged' SYB.Renamer (SYB.mkM inLet) t -- top down+ -- drawTokenTreeDetailed "rmDecl.entry after inLet" -- ++AZ++ 'in' missing+ -- drawTokenTree "rmDecl.entry after inLet" -- ++AZ++ 'in' missing+ t' <- everywhereMStaged' SYB.Renamer (SYB.mkM inDecls `SYB.extM` inGRHSs) t2 -- top down++ -- applyTP (once_tdTP (failTP `adhocTP` inDecls)) t+ -- t' <- everywhereMStaged SYB.Renamer (SYB.mkM inDecls) t+ (t'',sig') <- if incSig+ then rmTypeSig pn t'+ else return (t', Nothing)+ storage <- getStateStorage+ let decl' = case storage of+ StorageBind bind -> bind+ x -> error $ "rmDecl: unexpected value in StateStorage:" ++ (show x)+ return (t'',decl',sig')+ where+ inGRHSs ((GHC.GRHSs a localDecls)::GHC.GRHSs GHC.Name)+ -- was | not $ emptyList (snd (break (defines pn) decls)) -- /=[]+ | not $ emptyList (snd (break (defines pn) (hsBinds localDecls))) -- /=[]+ = do+ let decls = hsBinds localDecls+ -- logm $ "rmDecl:inGRHSs decls=" ++ (SYB.showData SYB.Renamer 0 $ decls)+ -- logm $ "rmDecl:inGRHSs localDecls=" ++ (SYB.showData SYB.Renamer 0 $ localDecls)+ let (_decls1, decls2) = break (defines pn) decls+ decl = ghead "rmDecl" decls2+ topLevel <- isTopLevelPN pn+ decls' <- case topLevel of+ True -> rmTopLevelDecl decl decls+ False -> rmLocalDecl decl decls+ return (GHC.GRHSs a (replaceBinds localDecls decls'))+ inGRHSs x = return x++ inDecls (decls::[GHC.LHsBind GHC.Name])+ | not $ emptyList (snd (break (defines pn) decls)) -- /=[]+ = do let (_decls1, decls2) = break (defines pn) decls+ decl = ghead "rmDecl" decls2+ -- error $ (render.ppi) t -- ecl ++ (show decl)+ topLevel <- isTopLevelPN pn+ case topLevel of+ True -> rmTopLevelDecl decl decls+ False -> rmLocalDecl decl decls+ inDecls x = return x++ inLet :: GHC.LHsExpr GHC.Name -> RefactGhc (GHC.LHsExpr GHC.Name)+ inLet (GHC.L ss (GHC.HsLet localDecls expr@(GHC.L l _)))+ | not $ emptyList (snd (break (defines pn) (hsBinds localDecls)))+ = do+ -- putSrcSpan ss -- Make sure the tree includes a SrcSpan for+ -- the HsLet, for when it is replaced later++ let decls = hsBinds localDecls+ let (decls1, decls2) = break (defines pn) decls+ decl = ghead "rmDecl" decls2++ -- drawTokenTreeDetailed "rmDecl.inLet tree" -- ++AZ++ present+ toks <- getToksForSpan l+ -- drawTokenTreeDetailed "rmDecl.inLet tree" -- ++AZ++ missing+ -- toks <- getToksForSpanWithIntros l+ removeToksForPos (getStartEndLoc decl)+ -- drawTokenTree "rmDecl.inLet after removeToksForPos"+ decl' <- syncDeclToLatestStash decl+ setStateStorage (StorageBind decl')+ -- drawTokenTree "rmDecl.inLet after syncDeclToLatestStash"+ case length decls of+ 1 -> do -- Removing the last declaration+ -- logm $ "rmDecl.inLet:length decls = 1: expr=" ++ (SYB.showData SYB.Renamer 0 expr)+ -- putToksForSpan ss toks+ (_,expr') <- putDeclToksForSpan ss expr $ dropWhile (\tok -> isEmpty tok || isIn tok) toks+ -- drawTokenTree "rmDecl.inLet after putToksForSpan"+ return expr'+ _ -> do+ logm $ "rmDecl.inLet:length decls /= 1"+ -- drawTokenTreeDetailed "rmDecl.inLet tree"+ let decls2' = gtail "inLet" decls2+ return $ (GHC.L ss (GHC.HsLet (replaceBinds localDecls (decls1 ++ decls2')) expr))++ inLet x = return x+++ rmTopLevelDecl :: GHC.LHsBind GHC.Name -> [GHC.LHsBind GHC.Name]+ -> RefactGhc [GHC.LHsBind GHC.Name]+ rmTopLevelDecl decl decls+ =do+ logm $ "rmTopLevelDecl:" -- ++AZ++++ removeToksForPos (getStartEndLoc decl)+ decl' <- syncDeclToLatestStash decl+ setStateStorage (StorageBind decl')++ let (decls1, decls2) = break (defines pn) decls+ decls2' = gtail "rmTopLevelDecl 1" decls2+ return $ (decls1 ++ decls2')+ -- return (decls \\ [decl])+++ {- The difference between removing a top level declaration and a+ local declaration is: if the local declaration to be removed is+ the only declaration in current declaration list, then the 'where'/+ 'let'/'in' enclosing this declaration should also be removed. Whereas,+ when a only top level decl is removed, the 'where' can not be removed.+ -}++ -- |Remove a location declaration that defines pn.+ rmLocalDecl :: GHC.LHsBind GHC.Name -> [GHC.LHsBind GHC.Name]+ -> RefactGhc [GHC.LHsBind GHC.Name]+ rmLocalDecl decl@(GHC.L sspan _) decls+ = do++ -- TODO: The let/in version is wrapped in a GHC.HsLet expression.+ -- The sspan of HsLet runs from the let keyword to the end of+ -- the in clause.+ -- (GHC.L l (HsLet (HsLocalBinds id) (LHsExpr id))+ -- So we must remove the tokens from the start of l to the+ -- start of the LHsExpr++ logm $ "rmLocalDecl: decls=" ++ (showGhc decls)+ -- drawTokenTreeDetailed $ "Before getToksForSpan :" ++ (show sspan) -- ++AZ+++ prevToks <- getToksBeforeSpan sspan -- Need these before+ -- sspan is deleted+ removeToksForPos (getStartEndLoc decl)+ decl' <- syncDeclToLatestStash decl+ setStateStorage (StorageBind decl')++ case length decls of+ 1 -> do+ -- Get rid of preceding where or let token+ let startPos = getGhcLoc sspan+ --divide the token stream.+ (_toks1,toks2)=break (\t1->tokenPos t1 < startPos) $ reversedToks prevToks+ --get the 'where' or 'let' token+ rvToks1 = dropWhile (not.isWhereOrLet) toks2+ --There must be a 'where' or 'let', so rvToks1 can not be empty.+ whereOrLet = ghead "rmLocalDecl:whereOrLet" rvToks1+ --drop the 'where' 'or 'let' token+ -- rmEndPos = tokenPosEnd $ ghead "rmLocalDecl.2" toks2+ rmEndPos = tokenPosEnd whereOrLet+ rmStartPos = tokenPos whereOrLet++ -- logm $ "rmLocalDecl: where/let tokens:" ++ (show (_toks1,toks2)) -- ++AZ++ + logm $ "rmLocalDecl: where/let tokens are at" ++ (show (rmStartPos,rmEndPos)) -- ++AZ++ + removeToksForPos (rmStartPos,rmEndPos)++ return ()+ _ -> return ()++ let (decls1, decls2) = break (defines pn) decls+ decls2' = gtail "rmLocalDecl 3" 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.Name])+ -- ^ 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.Name))+ -- ^ The result and removed signature, if there+ -- was one+rmTypeSig pn t+ = do+ -- logm $ "rmTypeSig:t=" ++ (SYB.showData SYB.Renamer 0 t)++ setStateStorage StorageNone+ t' <- everywhereMStaged SYB.Renamer (SYB.mkM inSigs) t+ storage <- getStateStorage+ let sig' = case storage of+ StorageSig sig -> Just sig+ StorageNone -> Nothing+ x -> error $ "rmTypeSig: unexpected value in StateStorage:" ++ (show x)+ return (t',sig')+ where+ inSigs (sigs::[GHC.LSig GHC.Name])+ | not $ emptyList (snd (break (definesTypeSig pn) sigs)) -- /=[]+ = do+ let (decls1,decls2)= break (definesTypeSig pn) sigs+ let sig@(GHC.L sspan (GHC.TypeSig names typ)) = ghead "rmTypeSig" decls2+ if length names > 1+ then do+ -- We have the following cases+ -- [pn,x..], [..x,pn,y..], [..x,pn]+ -- We must handle the commas correctly in+ -- all cases+ -- so [pn,x..] : take front comma+ -- [..x,pn,y..] : take either front or back comma,+ -- but only one+ -- [..x,pn] : take back comma+ let newSig=(GHC.L sspan (GHC.TypeSig (filter (\(GHC.L _ x) -> x /= pn) names) typ))++ toks <- getToksForSpan sspan+ logm $ "rmTypeSig: fetched toks:" ++ (show toks) -- ++AZ+++ let pnt = ghead "rmTypeSig" (filter (\(GHC.L _ x) -> x == pn) names)+ (startPos1, endPos1) =+ let (startPos1', endPos1') = getStartEndLoc pnt+ in if gfromJust "rmTypeSig" (elemIndex pnt names) == 0+ then extendForwards toks (startPos1',endPos1') isComma+ else extendBackwards toks (startPos1',endPos1') isComma+ toks' = deleteToks toks startPos1 endPos1+ void $ putToksForSpan sspan toks'++ -- Construct the old signature, by keeping the+ -- signature part but discarding the other names+ let oldSig = (GHC.L sspan (GHC.TypeSig [pnt] typ))+ sig'@(GHC.L sspan' _) <- syncDeclToLatestStash oldSig+ let typeLoc = extendBackwards toks (getStartEndLoc typ) isDoubleColon+ let (_,typTok,_) = splitToks typeLoc toks+ let (_,pntTok,_) = splitToks (getStartEndLoc pnt) toks+ void $ putToksForSpan sspan' (pntTok ++ typTok)+ setStateStorage (StorageSig sig')+++ return (decls1++[newSig]++tail decls2)+ else do+ removeToksForSpan sspan+ sig' <- syncDeclToLatestStash sig+ setStateStorage (StorageSig sig')+ return (decls1++tail decls2)+ inSigs x = return x++{-+ [+ (L {test/testdata/LiftToToplevel/PatBindIn1.hs:15:7-14}+ (TypeSig+ [+ (L {test/testdata/LiftToToplevel/PatBindIn1.hs:15:7} {Name: h})] + (L {test/testdata/LiftToToplevel/PatBindIn1.hs:15:12-14}+ (HsTyVar {Name: GHC.Types.Int})))),+ (L {test/testdata/LiftToToplevel/PatBindIn1.hs:16:7-14}+ (TypeSig+ [+ (L {test/testdata/LiftToToplevel/PatBindIn1.hs:16:7} {Name: t})] + (L {test/testdata/LiftToToplevel/PatBindIn1.hs:16:12-14}+ (HsTyVar {Name: GHC.Types.Int})))),+ (L {test/testdata/LiftToToplevel/PatBindIn1.hs:17:7-22}+ (TypeSig+ [+ (L {test/testdata/LiftToToplevel/PatBindIn1.hs:17:7-9} {Name: tup})] + (L {test/testdata/LiftToToplevel/PatBindIn1.hs:17:14-22}+ (HsTupleTy+ (HsBoxedOrConstraintTuple)+ [+ (L {test/testdata/LiftToToplevel/PatBindIn1.hs:17:15-17}+ (HsTyVar {Name: GHC.Types.Int})),+ (L {test/testdata/LiftToToplevel/PatBindIn1.hs:17:19-21}+ (HsTyVar {Name: GHC.Types.Int}))]))))]+-}++-- ---------------------------------------------------------------------+++-- 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 =+ -- error "undefined rmQualifier"+ everywhereMStaged SYB.Renamer (SYB.mkM rename) t+ where+ rename ((GHC.L l pn)::GHC.Located GHC.Name)+ | elem pn pns+ = do do -- toks <- fetchToks+ -- let toks' = replaceToks toks (row,col) (row,col) [mkToken Varid (row,col) s]+ let (rs,_) = break (=='.') $ reverse $ showGhc pn -- ++TODO: replace this with the appropriate formulation+ s = reverse rs+ {- TODO: reinstate token update if required+ let (row,col) = getGhcLoc l+ let toks' = replaceToks toks (row,col) (row,col) [mkToken (GHC.ITvarid (GHC.mkFastString s)) (row,col) s]+ putToks toks' modified+ -}+ return (GHC.L l (GHC.mkInternalName (GHC.nameUnique pn) (GHC.mkVarOcc s) l))+ rename x = return x++-- ---------------------------------------------------------------------++-- | Replace all occurences of a top level GHC.Name with a qualified version.+qualifyToplevelName :: GHC.Name -> RefactGhc ()+qualifyToplevelName n = do+ renamed <- getRefactRenamed+ -- logm $ "qualifyToplevelName:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed)+ _ <- renamePN n n True True renamed+ return ()++-- ---------------------------------------------------------------------++-- | Rename each occurrences of the identifier in the given syntax+-- phrase with the new name. If the Bool parameter is True, then+-- modify both the AST and the token stream, otherwise only modify the+-- AST.+-- 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 modifying the token stream as well.+ ->Bool -- ^ True means use the qualified form for+ -- the new name.+ ->t -- ^ The syntax phrase+ ->RefactGhc t+renamePN oldPN newName updateTokens useQual t = do+ -- = error $ "renamePN: sspan=" ++ (showGhc sspan) -- ++AZ+++ -- logm $ "renamePN': (oldPN,newName)=" ++ (showGhc (oldPN,newName))+ -- logm $ "renamePN: t=" ++ (SYB.showData SYB.Renamer 0 t)+ -- Note: bottom-up traversal+ let isRenamed = somethingStaged SYB.Renamer Nothing+ (Nothing `SYB.mkQ` isRenamedSource `SYB.extQ` isRenamedGroup) t+++ t' <- if isRenamed == (Just True)+ then+ everywhereMStaged SYB.Renamer+ (SYB.mkM renameRenamedSource+ `SYB.extM` renameGroup+ ) t+ else+ renamePNworker oldPN newName updateTokens useQual t+ -- t'' <- adjustLayoutAfterRename oldPN newName t'+ return t'+ where+ isRenamedSource :: GHC.RenamedSource -> Maybe Bool+ isRenamedSource (_g,_i,_e,_d) = Just True++ isRenamedGroup :: GHC.HsGroup GHC.Name -> Maybe Bool+ isRenamedGroup _g = Just True++ -- ---------------------------------++ renameRenamedSource :: GHC.RenamedSource -> RefactGhc GHC.RenamedSource+ renameRenamedSource (g,i,e,d) = do+ i' <- renamePNworker oldPN newName updateTokens False i+ e' <- renamePNworker oldPN newName updateTokens useQual e+ return (g,i',e',d)++ renameGroup :: (GHC.HsGroup GHC.Name) -> RefactGhc (GHC.HsGroup GHC.Name)+ renameGroup g+ = do+ logm $ "renamePN:renameGroup"+ g' <- renamePNworker oldPN newName updateTokens useQual g+ return g'+ -- renameGroup x = return x++-- ---------------------------------------------------------------------++-- | Rename each occurrences of the identifier in the given syntax+-- phrase with the new name. If the Bool parameter is True, then+-- modify both the AST and the token stream, otherwise only modify the+-- AST.+-- TODO: the syntax phrase is required to be GHC.Located, not sure how+-- to specify this without breaking the everywhereMStaged call+renamePNworker::(SYB.Data t)+ =>GHC.Name -- ^ The identifier to be renamed.+ ->GHC.Name -- ^ The new name, including possible qualifier+ ->Bool -- ^ True means modifying the token stream as well.+ ->Bool -- ^ True means use the qualified form for+ -- the new name.+ ->t -- ^ The syntax phrase+ ->RefactGhc t+renamePNworker oldPN newName updateTokens useQual t = do+ -- logm $ "renamePN: (oldPN,newName)=" ++ (showGhc (oldPN,newName))+ -- Note: bottom-up traversal (no ' at end)+ everywhereMStaged SYB.Renamer (SYB.mkM rename+ -- everywhereMStaged' SYB.Renamer (SYB.mkM rename+ `SYB.extM` renameVar+ `SYB.extM` renameTyVar+ `SYB.extM` renameHsTyVarBndr+ `SYB.extM` renameLIE+ `SYB.extM` renameLPat+ `SYB.extM` renameTypeSig+ `SYB.extM` renameFunBind+ ) t+ where+ rename :: (GHC.Located GHC.Name) -> RefactGhc (GHC.Located GHC.Name)+ rename (GHC.L l n)+ | (GHC.nameUnique n == GHC.nameUnique oldPN)+ = do+ logm $ "renamePNworker:rename at :" ++ (show l) ++ (showSrcSpanF l)+ -- drawTokenTree "before worker" -- ++AZ++ debug+ worker useQual l Nothing+ return (GHC.L l newName)+ rename x = return x++ renameVar :: (GHC.Located (GHC.HsExpr GHC.Name)) -> RefactGhc (GHC.Located (GHC.HsExpr GHC.Name))+ renameVar v@(GHC.L l (GHC.HsVar n))+ | (GHC.nameUnique n == GHC.nameUnique oldPN)+ = do+ logm $ "renamePNworker:renameVar at :" ++ (showGhc l)++ -- Get the original qualification, if any+ rn <- (getParsedForRenamedLocated v :: RefactGhc (GHC.LHsExpr GHC.RdrName))+ let (GHC.L _ (GHC.HsVar mqn)) = rn+ let mrnq = GHC.isQual_maybe mqn+ logm $ "renamePNworker:renameVar mrn,mrnq :" ++ (showGhc (rn,mrnq))++ worker useQual l mrnq+ return (GHC.L l (GHC.HsVar newName))+ renameVar x = return x++ -- HsTyVar {Name: Renaming.D1.Tree}))+ renameTyVar :: (GHC.Located (GHC.HsType GHC.Name)) -> RefactGhc (GHC.Located (GHC.HsType GHC.Name))+ renameTyVar v@(GHC.L l (GHC.HsTyVar n))+ | (GHC.nameUnique n == GHC.nameUnique oldPN)+ = do+ logm $ "renamePNworker:renameTyVar at :" ++ (showGhc l)++ -- Get the original qualification, if any+ rn <- (getParsedForRenamedLocated v :: RefactGhc (GHC.LHsType GHC.RdrName))+ let (GHC.L _ (GHC.HsTyVar mqn)) = rn+ let mrnq = GHC.isQual_maybe mqn+ logm $ "renamePNworker:renameVar mrn,mrnq :" ++ (showGhc (rn,mrnq))++ worker useQual l mrnq+ return (GHC.L l (GHC.HsTyVar newName))+ renameTyVar x = return x+++ renameHsTyVarBndr :: (GHC.LHsTyVarBndr GHC.Name) -> RefactGhc (GHC.LHsTyVarBndr GHC.Name)+#if __GLASGOW_HASKELL__ > 704+ renameHsTyVarBndr v@(GHC.L l (GHC.UserTyVar n))+#else+ renameHsTyVarBndr v@(GHC.L l (GHC.UserTyVar n typ))+#endif+ | (GHC.nameUnique n == GHC.nameUnique oldPN)+ = do+ logm $ "renamePNworker:renameHsTyVarBndr at :" ++ (showGhc l)++ -- Get the original qualification, if any+ rn <- (getParsedForRenamedLocated v :: RefactGhc (GHC.LHsTyVarBndr GHC.RdrName))+#if __GLASGOW_HASKELL__ > 704+ let (GHC.L _ (GHC.UserTyVar mqn)) = rn+#else+ let (GHC.L _ (GHC.UserTyVar mqn _)) = rn+#endif+ let mrnq = GHC.isQual_maybe mqn+ logm $ "renamePNworker:renameVar mrn,mrnq :" ++ (showGhc (rn,mrnq))++ worker useQual l mrnq+#if __GLASGOW_HASKELL__ > 704+ return (GHC.L l (GHC.UserTyVar newName))+#else+ return (GHC.L l (GHC.UserTyVar newName typ))+#endif+ renameHsTyVarBndr x = return x++ renameLIE :: (GHC.LIE GHC.Name) -> RefactGhc (GHC.LIE GHC.Name)+ renameLIE (GHC.L l (GHC.IEVar n))+ | (GHC.nameUnique n == GHC.nameUnique oldPN)+ = do+ logm $ "renamePNworker:renameLIE at :" ++ (showGhc l)+ worker useQual l Nothing+ return (GHC.L l (GHC.IEVar newName))+ renameLIE x = return x++ renameLPat :: (GHC.LPat GHC.Name) -> RefactGhc (GHC.LPat GHC.Name)+ renameLPat v@(GHC.L l (GHC.VarPat n))+ | (GHC.nameUnique n == GHC.nameUnique oldPN)+ = do+ logm $ "renamePNworker:renameLPat at :" ++ (showGhc l)++ -- Get the original qualification, if any+ rn <- (getParsedForRenamedLocated v :: RefactGhc (GHC.LPat GHC.RdrName))+ let (GHC.L _ (GHC.VarPat mqn)) = rn+ let mrnq = GHC.isQual_maybe mqn+ logm $ "renamePNworker:renameVar mrn,mrnq :" ++ (showGhc (rn,mrnq))++ worker False l mrnq+ return (GHC.L l (GHC.VarPat newName))+ renameLPat x = return x++ renameFunBind :: (GHC.LHsBindLR GHC.Name GHC.Name) -> RefactGhc (GHC.LHsBindLR GHC.Name GHC.Name)+ renameFunBind (GHC.L l (GHC.FunBind (GHC.L ln n) fi (GHC.MatchGroup matches typ) co fvs tick))+ | (GHC.nameUnique n == GHC.nameUnique oldPN) || (GHC.nameUnique n == GHC.nameUnique newName)+ = 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) )+ -- logm $ "renamePNWorker.renameFunBind"+ worker False ln Nothing+ -- Now do (b)+ logm $ "renamePNWorker.renameFunBind.renameFunBind:starting matches"+ let w (GHC.L lm _match) = worker False lm' Nothing+ where+ ((GHC.L lm' _),_) = newNameTok False lm oldPN+ mapM_ w $ tail matches+ logm $ "renamePNWorker.renameFunBind.renameFunBind.renameFunBind:matches done"+ return (GHC.L l (GHC.FunBind (GHC.L ln newName) fi (GHC.MatchGroup matches typ) co fvs tick))+ renameFunBind x = return x++ renameTypeSig :: (GHC.LSig GHC.Name) -> RefactGhc (GHC.LSig GHC.Name)+ renameTypeSig (GHC.L l (GHC.TypeSig ns typ))+ = do+ -- logm $ "renamePNWorker:renameTypeSig"+ _ns' <- renamePN oldPN newName updateTokens False ns+ -- Has already been renamed, make sure qualifier is removed+ ns' <- renamePN newName newName updateTokens False ns+ typ' <- renamePN oldPN newName updateTokens False typ+ -- logm $ "renamePNWorker:renameTypeSig done"+ return (GHC.L l (GHC.TypeSig ns' typ'))+ renameTypeSig x = return x++ -- The param l is only useful for the start of the token pos+ worker :: Bool -> GHC.SrcSpan -> Maybe (GHC.ModuleName, GHC.OccName) -> RefactGhc ()+ worker useQual' l mmo+ = do if updateTokens+ then do+ newTok <- case mmo of+ Nothing -> return $ newNameTok useQual' l newName+ Just (modu,_) -> do+ newName' <- mkNewGhcName (Just $ GHC.mkModule GHC.mainPackageId modu) (GHC.occNameString $ GHC.getOccName newName)+ return $ newNameTok True l newName'+ -- replaceToken l (markToken $ newNameTok useQual' l newName)+ replaceToken l (markToken $ newTok)+ return ()+ else return ()++-- ---------------------------------------------------------------------++-- | Create a new name token. If 'useQual' then use the qualified+-- name, if it exists.+-- The end position is not changed, so the eventual realignment can+-- know what the difference in length in the token is+newNameTok :: Bool -> GHC.SrcSpan -> GHC.Name -> PosToken+newNameTok useQual l newName =+ ((GHC.L l' (GHC.ITvarid (GHC.mkFastString newNameStr))),newNameStr)+ where+ newNameStr = if useQual then (showGhc newName)+ else (GHC.occNameString $ GHC.getOccName newName)++ l' = case l of+ GHC.RealSrcSpan ss ->+ let+ ((ForestLine _ _ _ startRow,startCol),_) = srcSpanToForestSpan l++ locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) startRow startCol+ locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) startRow (length newNameStr + startCol)+ in+ GHC.mkSrcSpan locStart locEnd+ _ -> l+++----------------------------------------------------------------------------------------+-- | Check whether the specified identifier is declared in the given syntax phrase t,+-- if so, rename the identifier by creating a new name automatically. If the Bool parameter +-- is True, the token stream will be modified, otherwise only the AST is modified. ++autoRenameLocalVar:: (HsValBinds t)+ =>Bool -- ^ True means modfiying the token stream as well. + ->GHC.Name -- ^ The identifier.+ ->t -- ^ The syntax phrase.+ -> RefactGhc t -- ^ The result.+autoRenameLocalVar modifyToks pn t = do+ logm $ "autoRenameLocalVar: (modifyToks,pn)=" ++ (showGhc (modifyToks,pn))+ -- = everywhereMStaged SYB.Renamer (SYB.mkM renameInMatch)+ if isDeclaredIn pn t+ then do t' <- worker t+ return t'+ else do return t++ where+ worker tt =do (f,d) <- hsFDNamesFromInside tt+ ds <- hsVisibleNames pn (hsValBinds tt)+ let newNameStr=mkNewName (nameToString pn) (nub (f `union` d `union` ds)) 1+ newName <- mkNewGhcName Nothing newNameStr+ if modifyToks+ then renamePN pn newName True False tt+ else renamePN pn newName False False tt++-- ---------------------------------------------------------------------++-- | Show a list of entities, the parameter f is a function that+-- specifies how to format an entity.+showEntities:: (t->String) -> [t] ->String+showEntities _ [] = ""+showEntities f [pn] = f pn+showEntities f (pn:pns) =f pn ++ "," ++ showEntities f pns+++-- ---------------------------------------------------------------------+{-+-- | Return True if the identifier can become qualified.+canBeQualified::(Term t)=>PNT->t->Bool+canBeQualified pnt t+ = isTopLevelPNT pnt && isUsedInRhs pnt t && not (findPntInImp pnt t)+ where+ findPntInImp pnt+ = (fromMaybe False).(applyTU (once_tdTU (failTU `adhocTU` inImp)))+ where+ inImp ((HsImportDecl loc modName qual as h)::HsImportDeclP)+ |findEntity pnt h = Just True+ inImp _ = Nothing+-}+++-- ---------------------------------------------------------------------++isMainModule :: GHC.Module -> Bool+isMainModule modu = GHC.modulePackageId modu == GHC.mainPackageId++-- ---------------------------------------------------------------------++-- | 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 $ somethingStaged SYB.Parser Nothing+ (Nothing `SYB.mkQ` inMatch `SYB.extQ` inDecl) t+ where+ inMatch ((GHC.FunBind name _ (GHC.MatchGroup _matches _) _ _ _) :: GHC.HsBind t)+ | isJust (find (sameOccurrence pnt) [name]) = Just True+ inMatch _ = Nothing++ inDecl ((GHC.TypeSig is _) :: GHC.Sig t)+ |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 _ = []++-- ---------------------------------------------------------------------++-- | 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.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.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++-- ---------------------------------------------------------------------++-- | 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 = 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.Located (GHC.HsExpr GHC.Name) -> GHC.Name+expToName (GHC.L _ (GHC.HsVar pnt)) = pnt+expToName (GHC.L _ (GHC.HsPar e)) = expToName e+expToName _ = defaultName+++nameToString :: GHC.Name -> String+nameToString name = showGhc name++-- | 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 :: GHC.Name -> GHC.Pat GHC.Name
src/Language/Haskell/Refact/Utils/Utils.hs view
@@ -24,27 +24,18 @@ , RefacSource(..) , update- -- , writeRefactoredFiles- -- , Refact -- ^ deprecated , fileNameToModName , fileNameFromModSummary , getModuleName , clientModsAndFiles , serverModsAndFiles- -- , getCurrentModuleGraph- -- , sortCurrentModuleGraph - -- * For testing- -- , initGhcSession- -- , prettyprint- -- , pwd- -- , cd ) where import Control.Monad.State import Data.List import Data.Maybe-import Data.Monoid+-- import Data.Monoid import Language.Haskell.GhcMod import Language.Haskell.Refact.Utils.DualTree import Language.Haskell.Refact.Utils.GhcBugWorkArounds@@ -102,7 +93,7 @@ case mm of [] -> return Nothing _ -> do- let (mfn,ms) = (ghead "getModuleMaybe" mm)+ let (_mfn,ms) = (ghead "getModuleMaybe" mm) -- activateModule (fromJust mfn,ms) return $ Just ms @@ -345,15 +336,7 @@ -- --------------------------------------------------------------------- -{--applyRefacToClientMods refac fileName- = do clients <- clientModsAndFiles =<< fileNameToModName fileName- mapM (applyRefac refac Nothing) (map snd clients)--} --- ----------------------------------------------------------------------- modifiedFiles :: [ApplyRefacResult] -> [String] modifiedFiles refactResult = map (\((s,_),_) -> s) $ filter (\((_,b),_) -> b) refactResult@@ -430,67 +413,9 @@ return newBind | otherwise = return t' -{- instance (SYB.Data t, GHC.OutputableBndr n, SYB.Data n) => Update [GHC.LPat n] t where- update oldPat newPat t- = everywhereMStaged SYB.Parser (SYB.mkM inPat) t- where- inPat (p::[GHC.LPat n])- | and $ zipWith sameOccurrence p oldPat- = do _ <- {- zipUpdateToks -} updateToks oldPat newPat prettyprint- return newPat- | otherwise = return p -} -{--zipUpdateToks f [] [] c = return []-zipUpdateToks f [] _ _ = return []-zipUpdateToks f _ [] _ = return []-zipUpdateToks f (a:as) (b:bs) c = do res <- f a b c- rest <- zipUpdateToks f as bs c- return (res:rest)--}- -- ------------------------------------------------------------------------ TODO: ++AZ++ get rid of the following instances, merge them into a--- single function above-{--instance (SYB.Data t) => Update (GHC.Located HsExpP) t where- update oldExp newExp t- = everywhereMStaged SYB.Parser (SYB.mkM inExp) t- where- inExp (e::GHC.Located HsExpP)- | sameOccurrence e oldExp- = do (newExp', _) <- updateToks oldExp newExp prettyprint- -- error "update: up`dated tokens" -- ++AZ++ debug- return newExp'- | otherwise = return e--} -{- ++AZ++ comment out for now, see what breaks-instance (SYB.Data t) => Update (GHC.Located HsPatP) t where- update oldPat newPat t- = everywhereMStaged SYB.Parser (SYB.mkM inPat) t- where- inPat (p::GHC.Located HsPatP) -- = error "here"- | sameOccurrence p oldPat- = do (newPat', _) <- updateToksList [oldPat] newPat (prettyprintPatList prettyprint False)- return $ head newPat'- | otherwise = return p--instance (SYB.Data t) => Update [GHC.Located HsPatP] t where- update oldPat newPat t- = everywhereMStaged SYB.Parser (SYB.mkM inPat) t- where- inPat (p::[GHC.Located HsPatP])- | and $ zipWith sameOccurrence p oldPat- = do liftIO $ putStrLn (">" ++ SYB.showData SYB.Parser 0 p ++ "<")- (newPat', _) <- (updateToksList oldPat newPat (prettyprintPatList prettyprint False))- liftIO $ putStrLn (">" ++ SYB.showData SYB.Parser 0 newPat' ++ "<") - return newPat'- inPat p = return p---++AZ++ comment out for now ends -}---- ---------------------------------------------------------------------- -- | Write refactored program source to files. writeRefactoredFiles :: VerboseLevel -> [ApplyRefacResult] -> IO ()@@ -601,18 +526,3 @@ show = GHC.moduleNameString -- -----------------------------------------------------------------------{- ++AZ++ what is using this?--- | Get the current module graph, provided we are in a live GHC session-getCurrentModuleGraph :: RefactGhc GHC.ModuleGraph-getCurrentModuleGraph = GHC.getModuleGraph--sortCurrentModuleGraph :: RefactGhc [GHC.SCC GHC.ModSummary]-sortCurrentModuleGraph = do- g <- getCurrentModuleGraph- let scc = GHC.topSortModuleGraph False g Nothing- return scc---++AZ++ -}-
src/MainHaRe.hs view
@@ -11,16 +11,10 @@ import Data.Typeable import Data.Version import Language.Haskell.GhcMod-import Language.Haskell.Refact.Case-import Language.Haskell.Refact.DupDef-import Language.Haskell.Refact.MoveDef-import Language.Haskell.Refact.Renaming-import Language.Haskell.Refact.Utils.Monad-import Language.Haskell.Refact.Utils.TypeSyn+import Language.Haskell.Refact.HaRe import Paths_HaRe import Prelude import System.Console.GetOpt--- import System.Directory import System.Environment (getArgs) import System.IO (hPutStr, hPutStrLn, stdout, stderr, hSetEncoding, utf8) @@ -36,28 +30,14 @@ 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 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 rename" ++ ghcOptHelp ++ "filename newname line col\n" ++ "\t ghc-hare help\n" -{-- ++ "\t ghc-hare list" ++ ghcOptHelp ++ "[-l]\n"- ++ "\t ghc-hare lang [-l]\n"- ++ "\t ghc-hare flag [-l]\n"- ++ "\t ghc-hare browse" ++ ghcOptHelp ++ "[-l] [-o] [-d] <module> [<module> ...]\n"- ++ "\t ghc-hare check" ++ ghcOptHelp ++ "<HaskellFile>\n"- ++ "\t ghc-hare expand" ++ ghcOptHelp ++ "<HaskellFile>\n"- ++ "\t ghc-hare debug" ++ ghcOptHelp ++ "<HaskellFile>\n"- ++ "\t ghc-hare info" ++ ghcOptHelp ++ "<HaskellFile> <module> <expression>\n"- ++ "\t ghc-hare type" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"- ++ "\t ghc-hare lint [-h opt] <HaskellFile>\n"- ++ "\t ghc-hare boot\n"- ++ "\t ghc-hare help\n"--} ---------------------------------------------------------------- argspec :: [OptDescr (RefactSettings -> RefactSettings)]