haskell-tools-refactor 0.4.1.3 → 0.5.0.0
raw patch · 69 files changed
+645/−127 lines, 69 filesdep +old-timedep +polyparsedep ~haskell-tools-astdep ~haskell-tools-backend-ghcdep ~haskell-tools-prettyprintPVP ok
version bump matches the API change (PVP)
Dependencies added: old-time, polyparse
Dependency ranges changed: haskell-tools-ast, haskell-tools-backend-ghc, haskell-tools-prettyprint, haskell-tools-refactor, haskell-tools-rewrite
API changes (from Hackage documentation)
- Language.Haskell.Tools.Refactor.ListOperations: replaceWithJust :: Ann e dom SrcTemplateStage -> AnnMaybe e dom -> AnnMaybe e dom
+ Language.Haskell.Tools.Refactor: data Ann (elem :: * -> * -> *) dom stage :: (* -> * -> *) -> * -> * -> *
+ Language.Haskell.Tools.Refactor.Helpers: normalizeElements :: [Ann e dom SrcTemplateStage] -> [Ann e dom SrcTemplateStage]
+ Language.Haskell.Tools.Refactor.Helpers: removeEmptyBnds :: Simple Traversal (Module dom) (ValueBind dom) -> Simple Traversal (Module dom) (Expr dom) -> Module dom -> Module dom
+ Language.Haskell.Tools.Refactor.Helpers: replaceWithJust :: Ann e dom SrcTemplateStage -> AnnMaybe e dom -> AnnMaybe e dom
+ Language.Haskell.Tools.Refactor.Helpers: replaceWithNothing :: AnnMaybe e dom -> AnnMaybe e dom
+ Language.Haskell.Tools.Refactor.Perform: FloatOut :: RealSrcSpan -> RefactorCommand
+ Language.Haskell.Tools.Refactor.Predefined.FloatOut: Extracted :: [LocalBind dom] -> FloatState dom
+ Language.Haskell.Tools.Refactor.Predefined.FloatOut: Inserted :: FloatState dom
+ Language.Haskell.Tools.Refactor.Predefined.FloatOut: NotEncountered :: FloatState dom
+ Language.Haskell.Tools.Refactor.Predefined.FloatOut: checkConflict :: forall dom. FloatOutDefinition dom => LocalBind dom -> ([String], [String])
+ Language.Haskell.Tools.Refactor.Predefined.FloatOut: data FloatState dom
+ Language.Haskell.Tools.Refactor.Predefined.FloatOut: extractAndInsert :: FloatOutDefinition dom => RealSrcSpan -> LocalBindList dom -> StateT (FloatState dom) (LocalRefactor dom) (LocalBindList dom)
+ Language.Haskell.Tools.Refactor.Predefined.FloatOut: floatOut :: FloatOutDefinition dom => RealSrcSpan -> LocalRefactoring dom
+ Language.Haskell.Tools.Refactor.Predefined.FloatOut: type FloatOutDefinition dom = (HasNameInfo dom, HasScopeInfo dom)
+ Language.Haskell.Tools.Refactor.Prepare: reloadPkgDb :: Ghc ()
+ Language.Haskell.Tools.Refactor.RefactorBase: IllegalExtensions :: [String] -> RefactorException
+ Language.Haskell.Tools.Refactor.RefactorBase: SourceCodeProblem :: ErrorMessages -> RefactorException
+ Language.Haskell.Tools.Refactor.RefactorBase: UnknownException :: String -> RefactorException
+ Language.Haskell.Tools.Refactor.RefactorBase: data RefactorException
+ Language.Haskell.Tools.Refactor.RefactorBase: instance GHC.Exception.Exception Language.Haskell.Tools.Refactor.RefactorBase.RefactorException
+ Language.Haskell.Tools.Refactor.RefactorBase: instance GHC.Show.Show ErrUtils.ErrorMessages
+ Language.Haskell.Tools.Refactor.RefactorBase: instance GHC.Show.Show Language.Haskell.Tools.Refactor.RefactorBase.RefactorException
- Language.Haskell.Tools.Refactor.Session: handleErrors :: ExceptionMonad m => m a -> m (Either String a)
+ Language.Haskell.Tools.Refactor.Session: handleErrors :: ExceptionMonad m => m a -> m (Either RefactorException a)
- Language.Haskell.Tools.Refactor.Session: loadPackagesFrom :: IsRefactSessionState st => (ModSummary -> IO a) -> [FilePath] -> StateT st Ghc (Either String ([a], [String]))
+ Language.Haskell.Tools.Refactor.Session: loadPackagesFrom :: IsRefactSessionState st => (ModSummary -> IO a) -> [FilePath] -> StateT st Ghc (Either RefactorException ([a], [String]))
- Language.Haskell.Tools.Refactor.Session: reloadChangedModules :: IsRefactSessionState st => (ModSummary -> IO a) -> (ModSummary -> Bool) -> StateT st Ghc (Either String [a])
+ Language.Haskell.Tools.Refactor.Session: reloadChangedModules :: IsRefactSessionState st => (ModSummary -> IO a) -> (ModSummary -> Bool) -> StateT st Ghc (Either RefactorException [a])
Files
- Language/Haskell/Tools/Refactor.hs +20/−18
- Language/Haskell/Tools/Refactor/BindingElem.hs +1/−1
- Language/Haskell/Tools/Refactor/GetModules.hs +34/−19
- Language/Haskell/Tools/Refactor/Helpers.hs +47/−0
- Language/Haskell/Tools/Refactor/ListOperations.hs +4/−5
- Language/Haskell/Tools/Refactor/Perform.hs +6/−0
- Language/Haskell/Tools/Refactor/Predefined/ExtractBinding.hs +66/−13
- Language/Haskell/Tools/Refactor/Predefined/FloatOut.hs +76/−0
- Language/Haskell/Tools/Refactor/Predefined/GenerateExports.hs +2/−1
- Language/Haskell/Tools/Refactor/Predefined/IfToGuards.hs +1/−1
- Language/Haskell/Tools/Refactor/Predefined/InlineBinding.hs +14/−8
- Language/Haskell/Tools/Refactor/Predefined/OrganizeImports.hs +30/−26
- Language/Haskell/Tools/Refactor/Predefined/RenameDefinition.hs +2/−2
- Language/Haskell/Tools/Refactor/Prepare.hs +23/−4
- Language/Haskell/Tools/Refactor/RefactorBase.hs +26/−0
- Language/Haskell/Tools/Refactor/Session.hs +20/−9
- examples/Module/Import.hs +1/−1
- examples/Refactor/ExtractBinding/AssocOp.hs +3/−0
- examples/Refactor/ExtractBinding/AssocOpMiddle.hs +3/−0
- examples/Refactor/ExtractBinding/AssocOpMiddle_res.hs +4/−0
- examples/Refactor/ExtractBinding/AssocOpRightAssoc.hs +3/−0
- examples/Refactor/ExtractBinding/AssocOpRightAssoc_res.hs +4/−0
- examples/Refactor/ExtractBinding/AssocOp_res.hs +4/−0
- examples/Refactor/ExtractBinding/LeftSection.hs +3/−0
- examples/Refactor/ExtractBinding/LeftSection_res.hs +4/−0
- examples/Refactor/ExtractBinding/RightSection.hs +3/−0
- examples/Refactor/ExtractBinding/RightSection_res.hs +4/−0
- examples/Refactor/ExtractBinding/SectionInfix.hs +3/−0
- examples/Refactor/ExtractBinding/SectionInfix_res.hs +4/−0
- examples/Refactor/ExtractBinding/SectionWithLocals.hs +6/−0
- examples/Refactor/ExtractBinding/SectionWithLocals_res.hs +7/−0
- examples/Refactor/FloatOut/FloatLocals.hs +5/−0
- examples/Refactor/FloatOut/FloatLocals_res.hs +5/−0
- examples/Refactor/FloatOut/ImplicitLocal.hs +5/−0
- examples/Refactor/FloatOut/ImplicitParam.hs +4/−0
- examples/Refactor/FloatOut/MoveFixity.hs +5/−0
- examples/Refactor/FloatOut/MoveFixity_res.hs +5/−0
- examples/Refactor/FloatOut/MoveSignature.hs +5/−0
- examples/Refactor/FloatOut/MoveSignature_res.hs +5/−0
- examples/Refactor/FloatOut/NameCollosion.hs +6/−0
- examples/Refactor/FloatOut/NameCollosionWithImport.hs +4/−0
- examples/Refactor/FloatOut/NameCollosionWithLocal.hs +6/−0
- examples/Refactor/FloatOut/NoCollosion.hs +7/−0
- examples/Refactor/FloatOut/NoCollosion_res.hs +7/−0
- examples/Refactor/FloatOut/SharedSignature.hs +6/−0
- examples/Refactor/FloatOut/ToTopLevel.hs +4/−0
- examples/Refactor/FloatOut/ToTopLevel_res.hs +4/−0
- examples/Refactor/GenerateTypeSignature/HigherOrder_res.hs +1/−1
- examples/Refactor/GenerateTypeSignature/PolymorphSubMulti_res.hs +1/−1
- examples/Refactor/GenerateTypeSignature/Tuple_res.hs +1/−1
- examples/Refactor/InlineBinding/LetBind.hs +3/−0
- examples/Refactor/InlineBinding/LetBind_res.hs +3/−0
- examples/Refactor/InlineBinding/LetGuard.hs +5/−0
- examples/Refactor/InlineBinding/LetGuard_res.hs +4/−0
- examples/Refactor/InlineBinding/LetStmt.hs +4/−0
- examples/Refactor/InlineBinding/LetStmt_res.hs +3/−0
- examples/Refactor/InlineBinding/LocalNested_res.hs +1/−2
- examples/Refactor/InlineBinding/Local_res.hs +1/−2
- examples/Refactor/OrganizeImports/NarrowSpec.hs +5/−0
- examples/Refactor/OrganizeImports/NarrowSpec_res.hs +5/−0
- examples/Refactor/OrganizeImports/NarrowType.hs +8/−0
- examples/Refactor/OrganizeImports/NarrowType_res.hs +8/−0
- examples/Refactor/OrganizeImports/StandaloneDeriving.hs +6/−0
- examples/Refactor/OrganizeImports/StandaloneDeriving_res.hs +6/−0
- examples/Refactor/OrganizeImports/TemplateHaskell.hs +5/−0
- examples/Refactor/OrganizeImports/TemplateHaskell_res.hs +5/−0
- examples/Type/TypeOperators.hs +4/−1
- haskell-tools-refactor.cabal +16/−10
- test/Main.hs +39/−1
Language/Haskell/Tools/Refactor.hs view
@@ -1,22 +1,23 @@ -- | Defines the API for refactorings module Language.Haskell.Tools.Refactor - ( module Language.Haskell.Tools.AST.SemaInfoClasses - , module Language.Haskell.Tools.AST.Rewrite - , module Language.Haskell.Tools.AST.References - , module Language.Haskell.Tools.AST.Helpers - , module Language.Haskell.Tools.Refactor.RefactorBase - , module Language.Haskell.Tools.AST.ElementTypes - , module Language.Haskell.Tools.Refactor.Prepare - , module Language.Haskell.Tools.Refactor.ListOperations - , module Language.Haskell.Tools.Refactor.BindingElem - , module Language.Haskell.Tools.IndentationUtils - , HasSourceInfo(..), HasRange(..), annListElems, annListAnnot, annList, annJust, annMaybe, isAnnNothing, Domain - , shortShowSpan, SrcTemplateStage, SourceInfoTraversal(..) - -- elements of source templates - , sourceTemplateNodeRange, sourceTemplateNodeElems - , sourceTemplateListRange, srcTmpListBefore, srcTmpListAfter, srcTmpDefaultSeparator, srcTmpIndented, srcTmpSeparators - , sourceTemplateOptRange, srcTmpOptBefore, srcTmpOptAfter - ) where + ( module Language.Haskell.Tools.AST.SemaInfoClasses + , module Language.Haskell.Tools.AST.Rewrite + , module Language.Haskell.Tools.AST.References + , module Language.Haskell.Tools.AST.Helpers + , module Language.Haskell.Tools.Refactor.RefactorBase + , module Language.Haskell.Tools.Refactor.Helpers + , module Language.Haskell.Tools.AST.ElementTypes + , module Language.Haskell.Tools.Refactor.Prepare + , module Language.Haskell.Tools.Refactor.ListOperations + , module Language.Haskell.Tools.Refactor.BindingElem + , module Language.Haskell.Tools.IndentationUtils + , Ann, HasSourceInfo(..), HasRange(..), annListElems, annListAnnot, annList, annJust, annMaybe, isAnnNothing, Domain + , shortShowSpan, SrcTemplateStage, SourceInfoTraversal(..) + -- elements of source templates + , sourceTemplateNodeRange, sourceTemplateNodeElems + , sourceTemplateListRange, srcTmpListBefore, srcTmpListAfter, srcTmpDefaultSeparator, srcTmpIndented, srcTmpSeparators + , sourceTemplateOptRange, srcTmpOptBefore, srcTmpOptAfter + ) where -- Important: Haddock doesn't support the rename all exported modules and export them at once hack @@ -27,9 +28,10 @@ import Language.Haskell.Tools.AST.SemaInfoClasses import Language.Haskell.Tools.IndentationUtils import Language.Haskell.Tools.Refactor.BindingElem +import Language.Haskell.Tools.Refactor.Helpers import Language.Haskell.Tools.Refactor.ListOperations import Language.Haskell.Tools.Refactor.Prepare import Language.Haskell.Tools.Refactor.RefactorBase import Language.Haskell.Tools.Transform -import Language.Haskell.Tools.AST.Ann+import Language.Haskell.Tools.AST.Ann
Language/Haskell/Tools/Refactor/BindingElem.hs view
@@ -7,7 +7,7 @@ import Control.Reference import Language.Haskell.Tools.AST import Language.Haskell.Tools.AST.Rewrite -import SrcLoc (RealSrcSpan(..)) +import SrcLoc (RealSrcSpan) -- | A type class for handling definitions that can appear as both top-level and local definitions class NamedElement d => BindingElem d where
Language/Haskell/Tools/Refactor/GetModules.hs view
@@ -4,6 +4,7 @@ , TemplateHaskell , FlexibleContexts #-} +-- | Representation and operations for module collections (libraries, executables, ...) in the framework. module Language.Haskell.Tools.Refactor.GetModules where import Control.Reference @@ -11,12 +12,14 @@ import Data.List (intersperse, find, sortBy) import qualified Data.Map as Map import Data.Maybe +import Distribution.Compiler import Distribution.ModuleName (components) import Distribution.ModuleName import Distribution.Package (Dependency(..), PackageName(..), pkgName) import Distribution.PackageDescription import Distribution.PackageDescription.Configuration import Distribution.PackageDescription.Parse +import Distribution.System import Distribution.Verbosity (silent) import Language.Haskell.Extension import System.Directory @@ -49,6 +52,7 @@ show (ModuleCollection id root srcDirs mods _ deps) = "ModuleCollection (" ++ show id ++ ") " ++ root ++ " " ++ show srcDirs ++ " (" ++ show mods ++ ") " ++ show deps +-- | The state of a module. data ModuleRecord = ModuleNotLoaded { _recModuleWillNeedCode :: Bool } | ModuleParsed { _parsedRecModule :: UnnamedModule (Dom RdrName) @@ -64,7 +68,7 @@ , _modRecMS :: ModSummary } --- | This data structure identifies a module collection +-- | This data structure identifies a module collection. data ModuleCollectionId = DirectoryMC FilePath | LibraryMC String | ExecutableMC String String @@ -93,7 +97,7 @@ show (ModuleNotLoaded code) = "ModuleNotLoaded " ++ show code show mr = GHC.moduleNameString $ GHC.moduleName $ GHC.ms_mod $ fromJust $ mr ^? modRecMS - +-- | Find the module collection where the given module is. lookupModuleColl :: String -> [ModuleCollection] -> Maybe (ModuleCollection) lookupModuleColl moduleName = find (any ((moduleName ==) . (^. sfkModuleName)) . Map.keys . (^. mcModules)) @@ -149,6 +153,7 @@ Nothing -> do mods <- modulesFromDirectory root root return [ModuleCollection (DirectoryMC root) root [root] (Map.fromList $ map ((, ModuleNotLoaded False) . SourceFileKey NormalHs) mods) return []] +-- | Load the module giving a directory. All modules loaded from the folder and subfolders. modulesFromDirectory :: FilePath -> FilePath -> IO [String] -- now recognizing only .hs files modulesFromDirectory root searchRoot = concat <$> (mapM goOn =<< listDirectory searchRoot) @@ -165,24 +170,32 @@ srcDirFromRoot fileName moduleName = srcDirFromRoot (takeDirectory fileName) (dropWhile (/= '.') $ dropWhile (== '.') moduleName) +-- | Load the module using a cabal file. The modules described in the cabal file will be loaded. +-- The flags and extensions set in the cabal file will be used by default. modulesFromCabalFile :: FilePath -> FilePath -> IO [ModuleCollection] -- now adding all conditional entries, regardless of flags -modulesFromCabalFile root cabal = getModules . flattenPackageDescription <$> readPackageDescription silent (root </> cabal) - where getModules pkg = maybe [] ((:[]) . toModuleCollection pkg) (library pkg) - ++ map (toModuleCollection pkg) (executables pkg) - ++ map (toModuleCollection pkg) (testSuites pkg) - ++ map (toModuleCollection pkg) (benchmarks pkg) +modulesFromCabalFile root cabal = getModules . setupFlags <$> readPackageDescription silent (root </> cabal) + where getModules pkg = maybe [] (maybe [] (:[]) . toModuleCollection pkg) (library pkg) + ++ catMaybes (map (toModuleCollection pkg) (executables pkg)) + ++ catMaybes (map (toModuleCollection pkg) (testSuites pkg)) + ++ catMaybes (map (toModuleCollection pkg) (benchmarks pkg)) - toModuleCollection :: ToModuleCollection tmc => PackageDescription -> tmc -> ModuleCollection - toModuleCollection pkg tmc = let bi = getBuildInfo tmc - in ModuleCollection (mkModuleCollKey (pkgName $ package pkg) tmc) - root - (map (normalise . (root </>)) $ hsSourceDirs bi) - (Map.fromList $ map ((, ModuleNotLoaded False) . SourceFileKey NormalHs . moduleName) (getModuleNames tmc)) - (flagsFromBuildInfo bi) - (map (\(Dependency pkgName _) -> LibraryMC (unPackageName pkgName)) (targetBuildDepends bi)) + toModuleCollection :: ToModuleCollection tmc => PackageDescription -> tmc -> Maybe ModuleCollection + toModuleCollection pkg tmc + = let bi = getBuildInfo tmc + in if buildable bi + then Just $ ModuleCollection (mkModuleCollKey (pkgName $ package pkg) tmc) + root + (map (normalise . (root </>)) $ hsSourceDirs bi) + (Map.fromList $ map ((, ModuleNotLoaded False) . SourceFileKey NormalHs . moduleName) (getModuleNames tmc)) + (flagsFromBuildInfo bi) + (map (\(Dependency pkgName _) -> LibraryMC (unPackageName pkgName)) (targetBuildDepends bi)) + else Nothing moduleName = concat . intersperse "." . components + setupFlags = either (\deps -> error $ "Missing dependencies: " ++ show deps) fst + . finalizePackageDescription [] (const True) buildPlatform + (unknownCompilerInfo buildCompilerId NoAbiTag) [] class ToModuleCollection t where mkModuleCollKey :: PackageName -> t -> ModuleCollectionId @@ -197,7 +210,8 @@ instance ToModuleCollection Executable where mkModuleCollKey pn exe = ExecutableMC (unPackageName pn) (exeName exe) getBuildInfo = buildInfo - getModuleNames = exeModules + getModuleNames e = {- fromString (toModuleName $ modulePath e) : -} exeModules e + where toModuleName = map (\case c | c `elem` pathSeparators -> '.'; c -> c) . dropExtension instance ToModuleCollection TestSuite where mkModuleCollKey pn test = TestSuiteMC (unPackageName pn) (testName test) @@ -231,13 +245,14 @@ flagsFromBuildInfo :: BuildInfo -> DynFlags -> IO DynFlags -- the import pathes are already set globally -flagsFromBuildInfo BuildInfo{ defaultExtensions, options } df +flagsFromBuildInfo bi@BuildInfo{ options } df = do (df,_,_) <- parseDynamicFlags df (map (L noSrcSpan) $ concatMap snd options) return $ foldl (.) id (map (\case EnableExtension ext -> translateExtension ext _ -> id - ) defaultExtensions) + ) (usedExtensions bi)) $ df - where translateExtension OverlappingInstances = flip xopt_set GHC.OverlappingInstances + where -- | Map the cabal extensions to the ones that GHC recognizes + translateExtension OverlappingInstances = flip xopt_set GHC.OverlappingInstances translateExtension UndecidableInstances = flip xopt_set GHC.UndecidableInstances translateExtension IncoherentInstances = flip xopt_set GHC.IncoherentInstances translateExtension DoRec = flip xopt_set GHC.RecursiveDo
+ Language/Haskell/Tools/Refactor/Helpers.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE LambdaCase + , RankNTypes + , FlexibleContexts + #-} +-- | Helper functions for defining refactorings. +module Language.Haskell.Tools.Refactor.Helpers where + +import Control.Reference +import Data.Function (on) +import Data.List (sortBy, nubBy) + +import Language.Haskell.Tools.AST as AST +import Language.Haskell.Tools.AST.Rewrite as AST +import Language.Haskell.Tools.Refactor.ListOperations (filterList) + +import SrcLoc (srcSpanStart) + +replaceWithJust :: Ann e dom SrcTemplateStage -> AnnMaybe e dom -> AnnMaybe e dom +replaceWithJust e = annMaybe .= Just e + +replaceWithNothing :: AnnMaybe e dom -> AnnMaybe e dom +replaceWithNothing = annMaybe .= Nothing + +-- | Remove the container (where or let) when the last binding is removed. +removeEmptyBnds :: Simple Traversal (Module dom) (ValueBind dom) + -> Simple Traversal (Module dom) (Expr dom) + -> AST.Module dom -> AST.Module dom +removeEmptyBnds binds exprs = (binds .- removeEmptyBindsAndGuards) . (exprs .- removeEmptyLetsAndStmts) + where removeEmptyBindsAndGuards sb@(SimpleBind _ _ _) + = (valBindLocals .- removeIfEmpty) . (valBindRhs .- removeEmptyGuards) $ sb + removeEmptyBindsAndGuards fb@(FunctionBind _) + = (funBindMatches & annList & matchBinds .- removeIfEmpty) . (funBindMatches & annList & matchRhs .- removeEmptyGuards) $ fb + + removeEmptyGuards rhs = rhsGuards & annList & guardStmts .- filterList (\case GuardLet (AnnList []) -> False; _ -> True) $ rhs + + removeIfEmpty mb@(AnnJust (LocalBinds (AnnList []))) = annMaybe .= Nothing $ mb + removeIfEmpty mb = mb + + removeEmptyLetsAndStmts (Let (AnnList []) e) = e + removeEmptyLetsAndStmts e = exprStmts .- removeEmptyStmts $ e + + removeEmptyStmts ls = (annList & cmdStmtBinds .- removeEmptyStmts) + . filterList (\case LetStmt (AnnList []) -> False; _ -> True) $ ls + +-- | Puts the elements in the orginal order and remove duplicates (elements with the same source range) +normalizeElements :: [Ann e dom SrcTemplateStage] -> [Ann e dom SrcTemplateStage] +normalizeElements elems = nubBy ((==) `on` getRange) $ sortBy (compare `on` srcSpanStart . getRange) elems
Language/Haskell/Tools/Refactor/ListOperations.hs view
@@ -6,7 +6,7 @@ import Control.Reference import Language.Haskell.Tools.AST -import Language.Haskell.Tools.AST.Rewrite (AnnMaybe(..), AnnList(..)) +import Language.Haskell.Tools.AST.Rewrite (AnnList) import Language.Haskell.Tools.Transform (srcTmpDefaultSeparator, srcTmpSeparators) -- | Filters the elements of the list. By default it removes the separator before the element. @@ -64,13 +64,12 @@ | before Nothing && after Nothing = Just 0 | otherwise = Nothing +-- | Gets the elements and separators from a list. The first separator is zipped to the second element. +-- To the first element, the "" string is zipped. zipWithSeparators :: AnnList e dom -> [(String, Ann e dom SrcTemplateStage)] zipWithSeparators (AnnListG (NodeInfo _ src) elems) | [] <- src ^. srcTmpSeparators - = map (src ^. srcTmpDefaultSeparator ,) elems + = zip ("" : repeat (src ^. srcTmpDefaultSeparator)) elems | otherwise = zip ("" : seps ++ repeat (last seps)) elems where seps = src ^. srcTmpSeparators - -replaceWithJust :: Ann e dom SrcTemplateStage -> AnnMaybe e dom -> AnnMaybe e dom -replaceWithJust e (AnnMaybeG temp _) = AnnMaybeG temp (Just e)
Language/Haskell/Tools/Refactor/Perform.hs view
@@ -17,6 +17,7 @@ import Language.Haskell.Tools.AST as AST import Language.Haskell.Tools.Refactor.Predefined.ExtractBinding +import Language.Haskell.Tools.Refactor.Predefined.FloatOut import Language.Haskell.Tools.Refactor.Predefined.GenerateExports import Language.Haskell.Tools.Refactor.Predefined.GenerateTypeSignature import Language.Haskell.Tools.Refactor.Predefined.InlineBinding @@ -41,6 +42,7 @@ selectCommand (RenameDefinition sp str) = renameDefinition' (correctRefactorSpan (snd mod) sp) str selectCommand (ExtractBinding sp str) = localRefactoring $ extractBinding' (correctRefactorSpan (snd mod) sp) str selectCommand (InlineBinding sp) = inlineBinding (correctRefactorSpan (snd mod) sp) + selectCommand (FloatOut sp) = localRefactoring $ floatOut (correctRefactorSpan (snd mod) sp) -- | A refactoring command data RefactorCommand = NoRefactor @@ -51,12 +53,15 @@ | RenameDefinition RealSrcSpan String | ExtractBinding RealSrcSpan String | InlineBinding RealSrcSpan + | FloatOut RealSrcSpan deriving Show +-- | Recognize a command from its textual representation readCommand :: String -> RefactorCommand readCommand (splitOn " " -> refact:args) = analyzeCommand refact args readCommand _ = error "panic: splitOn resulted empty" +-- | Check the parts and return the command analyzeCommand :: String -> [String] -> RefactorCommand analyzeCommand "" _ = NoRefactor analyzeCommand "CheckSource" _ = NoRefactor @@ -67,5 +72,6 @@ analyzeCommand "RenameDefinition" [sp, newName] = RenameDefinition (readSrcSpan sp) newName analyzeCommand "ExtractBinding" [sp, newName] = ExtractBinding (readSrcSpan sp) newName analyzeCommand "InlineBinding" [sp] = InlineBinding (readSrcSpan sp) +analyzeCommand "FloatOut" [sp] = FloatOut (readSrcSpan sp) analyzeCommand ref _ = error $ "Unknown command: " ++ ref
Language/Haskell/Tools/Refactor/Predefined/ExtractBinding.hs view
@@ -10,16 +10,23 @@ module Language.Haskell.Tools.Refactor.Predefined.ExtractBinding (extractBinding', ExtractBindingDomain, tryItOut) where import qualified GHC +import Name (nameModule_maybe) import qualified OccName as GHC (occNameString) -import SrcLoc (SrcSpan(..), RealSrcSpan(..)) +import OccName (HasOccName(..)) +import PrelNames +import RdrName (isOrig_maybe) +import SrcLoc import Control.Monad.State import Control.Reference import Data.Generics.Uniplate.Data () +import Data.List (find) import Data.Maybe import Language.Haskell.Tools.Refactor +-- | We need name information to identify bindings, and scope information to check which +-- entities must be directly passed as parameters. type ExtractBindingDomain dom = ( HasNameInfo dom, HasDefiningInfo dom, HasScopeInfo dom ) tryItOut :: String -> String -> String -> IO () @@ -27,24 +34,27 @@ extractBinding' :: ExtractBindingDomain dom => RealSrcSpan -> String -> LocalRefactoring dom extractBinding' sp name mod - = if isValidBindingName name then extractBinding (nodesContaining sp) (nodesContaining sp) name mod + = if isValidBindingName name then extractBinding sp (nodesContaining sp) (nodesContaining sp) name mod else refactError "The given name is not a valid for the extracted binding" -- | Safely performs the transformation to introduce the local binding and replace the expression with the call. -- Checks if the introduction of the name causes a name conflict. extractBinding :: forall dom . ExtractBindingDomain dom - => Simple Traversal (Module dom) (ValueBind dom) + => RealSrcSpan -> Simple Traversal (Module dom) (ValueBind dom) -> Simple Traversal (ValueBind dom) (Expr dom) -> String -> LocalRefactoring dom -extractBinding selectDecl selectExpr name mod +extractBinding sp selectDecl selectExpr name mod = let conflicting = any (isConflicting name) (mod ^? selectDecl & biplateRef :: [QualifiedName dom]) - exprRange = getRange $ head (mod ^? selectDecl & selectExpr) + exprRanges = map getRange (mod ^? selectDecl & selectExpr) decl = last (mod ^? selectDecl) - in if conflicting - then refactError "The given name causes name conflict." - else do (res, st) <- runStateT (selectDecl&selectExpr !~ extractThatBind name (head $ decl ^? actualContainingExpr exprRange) $ mod) Nothing - case st of Just def -> return $ evalState (selectDecl !~ addLocalBinding exprRange def $ res) False - Nothing -> refactError "There is no applicable expression to extract." + in case exprRanges of + exprRange:_ -> + if conflicting + then refactError "The given name causes name conflict." + else do (res, st) <- runStateT (selectDecl&selectExpr !~ extractThatBind sp name (head $ decl ^? actualContainingExpr exprRange) $ mod) Nothing + case st of Just def -> return $ evalState (selectDecl !~ addLocalBinding exprRange def $ res) False + Nothing -> refactError "There is no applicable expression to extract." + [] -> refactError "There is no applicable expression to extract." -- | Decides if a new name defined to be the given string will conflict with the given AST element isConflicting :: ExtractBindingDomain dom => String -> QualifiedName dom -> Bool @@ -54,17 +64,60 @@ -- Replaces the selected expression with a call and generates the called binding. extractThatBind :: ExtractBindingDomain dom - => String -> Expr dom -> Expr dom -> StateT (Maybe (ValueBind dom)) (LocalRefactor dom) (Expr dom) -extractThatBind name cont e - = do ret <- get + => RealSrcSpan -> String -> Expr dom -> Expr dom -> StateT (Maybe (ValueBind dom)) (LocalRefactor dom) (Expr dom) +extractThatBind sp name cont e + = do ret <- get -- being in a state monad to only apply the if (isJust ret) then return e else case e of + -- only the expression inside the parameters should be extracted Paren {} | hasParameter -> exprInner !~ doExtract name cont $ e | otherwise -> doExtract name cont (fromJust $ e ^? exprInner) + -- a single variable cannot be extracted (would lead to precedence problems) Var {} -> lift $ refactError "The selected expression is too simple to be extracted." + -- extract operator sections + InfixApp lhs op rhs + | (lhs `outside` sp) && (sp `encloses` op) && (sp `encloses` rhs) + -> do let params = getExternalBinds cont rhs ++ opName op + put (Just (generateBind name (map mkVarPat params) (mkRightSection op (parenIfInfix rhs)))) + return (mkApp (generateCall name params) (parenIfInfix lhs)) + | (sp `encloses` lhs) && (sp `encloses` op) && (rhs `outside` sp) + -> do let params = getExternalBinds cont lhs ++ opName op + put (Just (generateBind name (map mkVarPat params) (mkLeftSection (parenIfInfix lhs) op))) + return (mkApp (generateCall name params) (parenIfInfix rhs)) + where parenIfInfix e@(InfixApp {}) = mkParen e + parenIfInfix e = e + -- extract parts of known associative infix operators + InfixApp (InfixApp lhs lop mid) rop rhs -- correction for left-associative operators + | (Just lName, Just rName) <- (semanticsName (lop ^. operatorName), semanticsName (rop ^. operatorName)) + , (lop `outside` sp) && (sp `encloses` mid) && (sp `encloses` rhs) + && lName == rName && isKnownCommutativeOp lName + -> do let params = getExternalBinds cont mid ++ opName rop ++ getExternalBinds cont rhs + put (Just (generateBind name (map mkVarPat params) (mkInfixApp mid rop rhs))) + return (mkInfixApp lhs lop (generateCall name params)) + InfixApp lhs lop (InfixApp mid rop rhs) -- correction for right-associative operators + | (Just lName, Just rName) <- (semanticsName (lop ^. operatorName), semanticsName (rop ^. operatorName)) + , (sp `encloses` lhs) && (sp `encloses` mid) && (rop `outside` sp) + && lName == rName && isKnownCommutativeOp lName + -> do let params = getExternalBinds cont lhs ++ opName lop ++ getExternalBinds cont mid + put (Just (generateBind name (map mkVarPat params) (mkInfixApp lhs lop mid))) + return (mkInfixApp (generateCall name params) rop rhs) + -- normal case el | isParenLikeExpr el && hasParameter -> mkParen <$> doExtract name cont e | otherwise -> doExtract name cont e where hasParameter = not (null (getExternalBinds cont e)) + -- True if the elem is completely inside the given source range + sp `encloses` elem = case getRange elem of RealSrcSpan enc -> sp `containsSpan` enc + _ -> False + -- True if the elem is completely outside the given range (no overlapping) + elem `outside` sp = case getRange elem of RealSrcSpan out -> realSrcSpanStart sp > realSrcSpanEnd out + || realSrcSpanEnd sp < realSrcSpanStart out + _ -> False + opName op = case semanticsName (op ^. operatorName) of + Nothing -> [] + Just n -> [mkUnqualName' n | not $ n `inScope` semanticsScope cont] + isKnownCommutativeOp :: GHC.Name -> Bool + isKnownCommutativeOp n = isJust $ find (maybe False (\(mn, occ) -> (nameModule_maybe n) == Just mn && occName n == occ) . isOrig_maybe) ops + where ops = [plus_RDR, times_RDR, append_RDR, and_RDR, {- or_RDR, -} compose_RDR] -- somehow or is missing... WHY? -- | Adds a local binding to the where clause of the enclosing binding addLocalBinding :: SrcSpan -> ValueBind dom -> ValueBind dom -> State Bool (ValueBind dom)
+ Language/Haskell/Tools/Refactor/Predefined/FloatOut.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE LambdaCase + , ConstraintKinds + , FlexibleContexts + , ViewPatterns + , TypeApplications + , ScopedTypeVariables + #-} +module Language.Haskell.Tools.Refactor.Predefined.FloatOut where + +import Control.Monad.State +import Control.Reference +import Data.List +import Data.Maybe (Maybe(..), catMaybes) + +import Language.Haskell.Tools.Refactor + +import Name as GHC (Name, NamedThing(..), occNameString) +import OccName (occNameString) +import SrcLoc (RealSrcSpan) + +type FloatOutDefinition dom = (HasNameInfo dom, HasScopeInfo dom) + +floatOut :: FloatOutDefinition dom => RealSrcSpan -> LocalRefactoring dom +floatOut sp mod + = do (mod', st) <- runStateT (nodesContaining sp !~ extractAndInsert sp $ mod) NotEncountered + case st of NotEncountered -> refactError "No definition is selected." + Extracted bnds -> -- insert it to the global definition list + return $ modDecl & annListElems .- (++ map toTopLevel bnds) $ removeEmpties mod' + Inserted -> -- already inserted to a local scope + return (removeEmpties mod') + where toTopLevel :: LocalBind dom -> Decl dom + toTopLevel (LocalValBind vb) = mkValueBinding vb + toTopLevel (LocalTypeSig sg) = mkTypeSigDecl sg + toTopLevel (LocalFixity fx) = mkFixityDecl fx + + removeEmpties = removeEmptyBnds (nodesContaining sp) (nodesContaining sp) + +data FloatState dom = NotEncountered | Extracted [LocalBind dom] | Inserted + +extractAndInsert :: FloatOutDefinition dom => RealSrcSpan -> LocalBindList dom -> StateT (FloatState dom) (LocalRefactor dom) (LocalBindList dom) +extractAndInsert sp locs + | hasSharedSig = refactError "Cannot float out a definition, since it has a signature shared with other bindings that stay in the scope." + | not (null nameConflicts) = refactError $ "Cannot float out a definition, since it would cause a name conflicts in the target scope: " + ++ concat (intersperse ", " nameConflicts) + | not (null implicitConflicts) = refactError $ "Cannot float out a definition, since it uses the implicit parameters: " + ++ concat (intersperse ", " implicitConflicts) + | otherwise = get >>= \case NotEncountered -> put (Extracted floated) >> return filteredLocs + Extracted binds -> put Inserted >> (return $ annListElems .- (++ binds) $ locs) + Inserted -> return locs + where selected = locs ^? annList & filtered (isInside sp) + floated = normalizeElements $ selected ++ (locs ^? annList & filtered (nameIsSelected . (^? elementName))) + where nameIsSelected [n] = n `elem` concatMap (^? elementName) selected + nameIsSelected _ = False + + filteredLocs = filterList (\e -> not (getRange e `elem` floatedElemRanges)) locs + where floatedElemRanges = map getRange floated + hasSharedSig = any (\e -> not $ null ((filteredLocs ^? annList & elementName) `intersect` (e ^? elementName))) selected + conflicts = map checkConflict selected + + nameConflicts = concat $ map fst conflicts + implicitConflicts = concat $ map snd conflicts + +checkConflict :: forall dom . FloatOutDefinition dom => LocalBind dom -> ([String], [String]) +checkConflict bnd = (concatMap @[] getConflict bndNames, implicits) + where bndNames = bnd ^? elementName + getConflict bndName = filter ((== nameStr) . Just) $ map (occNameString . getOccName) outerScope + where outerScope = concat $ take 1 $ drop 2 $ semanticsScope bndName + nameStr = fmap (occNameString . getOccName) $ semanticsName bndName + implicits = map (occNameString . getOccName) + (concatMap getPossibleImplicits bndNames `intersect` getQNames (bnd ^? biplateRef)) + + getQNames :: [QualifiedName dom] -> [GHC.Name] + getQNames = catMaybes . map semanticsName + + getPossibleImplicits :: QualifiedName dom -> [GHC.Name] + getPossibleImplicits qn = concat (take 2 $ semanticsScope qn) \\ catMaybes (map semanticsName bndNames)
Language/Haskell/Tools/Refactor/Predefined/GenerateExports.hs view
@@ -8,11 +8,12 @@ import Control.Reference ((^?), (.=), (&)) import Language.Haskell.Tools.Refactor -import qualified GHC (NamedThing(..), Name(..)) +import qualified GHC (NamedThing(..), Name) import Control.Applicative ((<|>)) import Data.Maybe (Maybe(..), catMaybes) +-- | We need name information to generate exports type DomGenerateExports dom = (Domain dom, HasNameInfo dom) -- | Creates an export list that imports standalone top-level definitions with all of their contained definitions
Language/Haskell/Tools/Refactor/Predefined/IfToGuards.hs view
@@ -4,7 +4,7 @@ import Control.Reference ((^.), (.-), (&)) import Data.Generics.Uniplate.Data () import Language.Haskell.Tools.Refactor -import SrcLoc (RealSrcSpan(..)) +import SrcLoc (RealSrcSpan) tryItOut :: String -> String -> IO () tryItOut = tryRefactor (localRefactoring . ifToGuards)
Language/Haskell/Tools/Refactor/Predefined/InlineBinding.hs view
@@ -19,8 +19,8 @@ import Data.List (nub) import Data.Maybe (Maybe(..), catMaybes) -import Name as GHC (NamedThing(..), Name(..), occNameString) -import SrcLoc as GHC (SrcSpan(..), RealSrcSpan(..), containsSpan) +import Name as GHC (NamedThing(..), Name, occNameString) +import SrcLoc as GHC (SrcSpan(..), RealSrcSpan, containsSpan) import Language.Haskell.Tools.Refactor as AST @@ -35,6 +35,8 @@ topLevel = nodesContaining span local :: Simple Traversal (Module dom) (LocalBindList dom) local = nodesContaining span + exprs :: Simple Traversal (Module dom) (Expr dom) + exprs = nodesContaining span elemAccess :: (BindingElem d) => AnnList d dom -> Maybe (ValueBind dom) elemAccess = getValBindInList span removed = catMaybes $ map elemAccess (mod ^? topLevel) ++ map elemAccess (mod ^? local) @@ -47,21 +49,22 @@ | _:_ <- mod ^? modHead & annJust & mhExports & annJust & biplateRef & filtered (\n -> semanticsName (n :: QualifiedName dom) == Just removedBindingName) -> refactError "Cannot inline the definition, it is present in the export list." - | otherwise -> localRefactoring (inlineBinding' topLevel local removedBinding removedBindingName) namedMod mods + | otherwise -> localRefactoring (inlineBinding' topLevel local exprs removedBinding removedBindingName) namedMod mods -- | Performs the inline binding on a single module. inlineBinding' :: InlineBindingDomain dom => Simple Traversal (Module dom) (DeclList dom) -> Simple Traversal (Module dom) (LocalBindList dom) + -> Simple Traversal (Module dom) (Expr dom) -> ValueBind dom -> GHC.Name -> LocalRefactoring dom -inlineBinding' topLevelRef localRef removedBinding removedBindingName mod +inlineBinding' topLevelRef localRef exprRef removedBinding removedBindingName mod = do replacement <- createReplacement removedBinding let RealSrcSpan bindingSpan = getRange removedBinding (mod', used) <- runStateT (descendBiM (replaceInvocations bindingSpan removedBindingName replacement) mod) False if not used then refactError "The selected definition is not used, it can be safely deleted." - else return $ removeBindingAndSig topLevelRef localRef removedBindingName mod' + else return $ removeBindingAndSig topLevelRef localRef exprRef removedBindingName mod' -- | True if the given module contains the name of the inlined definition. containInlined :: forall dom . InlineBindingDomain dom => GHC.Name -> ModuleDom dom -> Bool @@ -72,10 +75,12 @@ removeBindingAndSig :: InlineBindingDomain dom => Simple Traversal (Module dom) (DeclList dom) -> Simple Traversal (Module dom) (LocalBindList dom) + -> Simple Traversal (Module dom) (Expr dom) -> GHC.Name -> AST.Module dom -> AST.Module dom -removeBindingAndSig topLevelRef localRef name - = (topLevelRef .- removeBindingAndSig' name) . (localRef .- removeBindingAndSig' name) +removeBindingAndSig topLevelRef localRef exprRef name + = removeEmptyBnds (topLevelRef & annList & declValBind &+& localRef & annList & localVal) exprRef + . (topLevelRef .- removeBindingAndSig' name) . (localRef .- removeBindingAndSig' name) removeBindingAndSig' :: (InlineBindingDomain dom, BindingElem d) => GHC.Name -> AnnList d dom -> AnnList d dom removeBindingAndSig' name = (annList .- removeNameFromSigBind) . filterList notThatBindOrSig @@ -131,7 +136,8 @@ in joinApps (parenIfNeeded (createLambda matchedPats (wrapLocals locals (replaceExprs argReplacement expr)))) appliedArgs where getArgsOf (MatchLhs _ (AnnList args)) = args getArgsOf (InfixLhs lhs _ rhs (AnnList more)) = lhs:rhs:more -createReplacement (FunctionBind matches) +createReplacement (FunctionBind matches) + -- function bind has at least one match = return $ \sc args -> let numArgs = getArgNum (head (matches ^? annList & matchLhs)) - length args newArgs = take numArgs $ map mkName $ filter notInScope $ map (("x" ++ ) . show @Int) [1..] notInScope str = not $ any (any ((== str) . occNameString . getOccName)) sc
Language/Haskell/Tools/Refactor/Predefined/OrganizeImports.hs view
@@ -16,7 +16,7 @@ import Id import IdInfo (RecSelParent(..)) import InstEnv (ClsInst(..)) -import Language.Haskell.TH.LanguageExtensions (Extension(..)) +import Language.Haskell.TH.LanguageExtensions as GHC (Extension(..)) import Name (NamedThing(..)) import TyCon (tyConFieldLabels, tyConDataCons, isClassTyCon) @@ -40,12 +40,13 @@ organizeImports :: forall dom . OrganizeImportsDomain dom => LocalRefactoring dom organizeImports mod = do ms <- lift $ GHC.getModSummary (GHC.moduleName $ semanticsModule mod) - let th = xopt TemplateHaskell $ GHC.ms_hspp_opts ms - if th + let noNarrowingImports = xopt TemplateHaskell (GHC.ms_hspp_opts ms) + noNarrowingSubspecs = xopt GHC.StandaloneDeriving (GHC.ms_hspp_opts ms) + if noNarrowingImports then -- don't change the imports for template haskell modules -- (we don't know what definitions the generated code will use) return $ modImports .- sortImports $ mod - else modImports !~ narrowImports exportedModules usedNames prelInstances prelFamInsts . sortImports $ mod + else modImports !~ narrowImports noNarrowingSubspecs exportedModules usedNames prelInstances prelFamInsts . sortImports $ mod where prelInstances = semanticsPrelOrphanInsts mod prelFamInsts = semanticsPrelFamInsts mod usedNames = map getName $ catMaybes $ map semanticsName @@ -78,39 +79,45 @@ -- | Modify an import to only import names that are used. narrowImports :: forall dom . OrganizeImportsDomain dom - => [String] -> [GHC.Name] -> [ClsInst] -> [FamInst] -> ImportDeclList dom -> LocalRefactor dom (ImportDeclList dom) -narrowImports exportedModules usedNames prelInsts prelFamInsts imps - = annListElems & traversal !~ narrowImport exportedModules usedNames + => Bool -> [String] -> [GHC.Name] -> [ClsInst] -> [FamInst] -> ImportDeclList dom -> LocalRefactor dom (ImportDeclList dom) +narrowImports noNarrowSubspecs exportedModules usedNames prelInsts prelFamInsts imps + = annListElems & traversal !~ narrowImport noNarrowSubspecs exportedModules usedNames $ filterListIndexed (\i _ -> neededImps !! i) imps where neededImps = neededImports exportedModules usedNames prelInsts prelFamInsts (imps ^. annListElems) -- | Reduces the number of definitions used from an import narrowImport :: OrganizeImportsDomain dom - => [String] -> [GHC.Name] -> ImportDecl dom -> LocalRefactor dom (ImportDecl dom) -narrowImport exportedModules usedNames imp + => Bool -> [String] -> [GHC.Name] -> ImportDecl dom -> LocalRefactor dom (ImportDecl dom) +narrowImport noNarrowSubspecs exportedModules usedNames imp | (imp ^. importModule & moduleNameString) `elem` exportedModules || maybe False (`elem` exportedModules) (imp ^? importAs & annJust & importRename & moduleNameString) = return imp -- dont change an import if it is exported as-is (module export) | importIsExact imp - = importSpec&annJust&importSpecList !~ narrowImportSpecs usedNames $ imp + = importSpec&annJust&importSpecList !~ narrowImportSpecs noNarrowSubspecs usedNames $ imp | otherwise = do namedThings <- mapM lookupName actuallyImported let -- to explicitely import pattern synonyms we need to enable an extension, and the user might not expect this hasPatSyn = any (\case Just (AConLike (PatSynCon _)) -> True; _ -> False) namedThings - groups = groupThings (semanticsImported imp) (catMaybes namedThings) + groups = groupThings noNarrowSubspecs (semanticsImported imp) (catMaybes namedThings) return $ if not hasPatSyn && length groups < 4 then importSpec .- replaceWithJust (createImportSpec groups) $ imp else imp where actuallyImported = semanticsImported imp `intersect` usedNames -groupThings :: [GHC.Name] -> [TyThing] -> [(GHC.Name, Bool)] -groupThings importable = nub . sort . map createImportFromTyThing +-- | Group things as importable definitions. The second member of the pair will be true, when there is a sub-name +-- that should be imported apart from the name of the importable definition. +groupThings :: Bool -> [GHC.Name] -> [TyThing] -> [(GHC.Name, Bool)] +groupThings noNarrowSubspecs importable + = map last . groupBy ((==) `on` fst) . sort . map createImportFromTyThing where createImportFromTyThing :: TyThing -> (GHC.Name, Bool) createImportFromTyThing tt | Just td <- getTopDef tt = if (td `elem` importable) then (td, True) else (getName tt, False) - | otherwise = (getName tt, False) + createImportFromTyThing tt@(ATyCon {}) = (getName tt, noNarrowSubspecs) + createImportFromTyThing tt = (getName tt, False) +-- | Gets the importable definition for a (looked up) name. For example a class function is only importable +-- in a class, so it gets the name of the class. getTopDef :: TyThing -> Maybe GHC.Name getTopDef (AnId id) | isRecordSelector id = Just $ case recordSelectorTyCon id of RecSelData tc -> getName tc @@ -119,7 +126,7 @@ <|> fmap getName (isClassOpId_maybe id) getTopDef (AConLike (RealDataCon dc)) = Just (getName $ dataConTyCon dc) getTopDef (AConLike (PatSynCon _)) = error "getTopDef: should not be called with pattern synonyms" -getTopDef tc@(ATyCon _) = Just (getName tc) +getTopDef (ATyCon _) = Nothing createImportSpec :: [(GHC.Name, Bool)] -> ImportSpec dom createImportSpec elems = mkImportSpecList $ map createIESpec elems @@ -147,9 +154,9 @@ -- | Narrows the import specification (explicitely imported elements) narrowImportSpecs :: forall dom . OrganizeImportsDomain dom - => [GHC.Name] -> IESpecList dom -> LocalRefactor dom (IESpecList dom) -narrowImportSpecs usedNames - = (annList !~ narrowSpecSubspec usedNames) + => Bool -> [GHC.Name] -> IESpecList dom -> LocalRefactor dom (IESpecList dom) +narrowImportSpecs noNarrowSubspecs usedNames + = (if noNarrowSubspecs then return else (annList !~ narrowSpecSubspec usedNames)) >=> return . filterList isNeededSpec where narrowSpecSubspec :: [GHC.Name] -> IESpec dom -> LocalRefactor dom (IESpec dom) narrowSpecSubspec usedNames spec @@ -158,7 +165,7 @@ let subspecsInScope = case tt of ATyCon tc | not (isClassTyCon tc) -> (map getName (tyConDataCons tc) ++ map flSelector (tyConFieldLabels tc)) `intersect` usedNames _ -> usedNames - ieSubspec&annJust !- narrowImportSubspecs subspecsInScope $ spec + ieSubspec !- narrowImportSubspecs subspecsInScope $ spec isNeededSpec :: IESpec dom -> Bool isNeededSpec ie = @@ -169,10 +176,7 @@ || (case ie ^? ieSubspec&annJust of Just SubAll -> True; _ -> False) -- | Reduces the number of definitions imported from a sub-specifier. -narrowImportSubspecs :: OrganizeImportsDomain dom => [GHC.Name] -> SubSpec dom -> SubSpec dom -narrowImportSubspecs [] SubAll = mkSubList [] -narrowImportSubspecs _ ss@SubAll = ss -narrowImportSubspecs usedNames ss@(SubList {}) - = essList .- filterList (\n -> fmap getName (semanticsName =<< (n ^? simpleName)) `elem` map Just usedNames) $ ss - - +narrowImportSubspecs :: OrganizeImportsDomain dom => [GHC.Name] -> MaybeSubSpec dom -> MaybeSubSpec dom +narrowImportSubspecs [] = replaceWithNothing +narrowImportSubspecs usedNames + = annJust & essList .- filterList (\n -> fmap getName (semanticsName =<< (n ^? simpleName)) `elem` map Just usedNames)
Language/Haskell/Tools/Refactor/Predefined/RenameDefinition.hs view
@@ -9,9 +9,9 @@ #-} module Language.Haskell.Tools.Refactor.Predefined.RenameDefinition (renameDefinition, renameDefinition', DomainRenameDefinition) where -import qualified GHC (RealSrcSpan(..), NamedThing(..), Name(..)) +import qualified GHC (RealSrcSpan, NamedThing(..), Name) import Name (OccName(..), NamedThing(..), occNameString) -import SrcLoc (RealSrcSpan(..)) +import SrcLoc (RealSrcSpan) import Control.Monad.State import Control.Reference as Ref
Language/Haskell/Tools/Refactor/Prepare.hs view
@@ -19,12 +19,15 @@ import GHC hiding (loadModule) import qualified GHC (loadModule) import GHC.Paths ( libdir ) +import Packages import SrcLoc +import Control.Exception import Control.Monad import Control.Monad.IO.Class +import Control.Monad.Trans import Data.IntSet (member) -import Data.List ((\\)) +import Data.List ((\\), intersperse, isSuffixOf) import Data.List.Split import Data.Maybe import Language.Haskell.TH.LanguageExtensions @@ -37,6 +40,7 @@ import Language.Haskell.Tools.Refactor.RefactorBase import Language.Haskell.Tools.Transform +-- | A quick function to try the refactorings tryRefactor :: (RealSrcSpan -> Refactoring IdDom) -> String -> String -> IO () tryRefactor refact moduleName span = runGhc (Just libdir) $ do @@ -64,8 +68,14 @@ -- TODO: print errors and warnings? let ((leftovers, _, _), newDynFlags) = (runCmdLine $ processArgs flagsAll lArgs) dynflags void $ setSessionDynFlags newDynFlags + when (any ("-package-db" `isSuffixOf`) args) reloadPkgDb return $ map unLoc leftovers +-- | Reloads the package database based on the session flags +reloadPkgDb :: Ghc () +reloadPkgDb = void $ setSessionDynFlags . fst =<< liftIO . initPackages . (\df -> df { pkgDatabase = Nothing }) + =<< getSessionDynFlags + -- | Initialize GHC flags to default values that support refactoring initGhcFlags :: Ghc () initGhcFlags = initGhcFlags' False @@ -73,6 +83,7 @@ initGhcFlagsForTest :: Ghc () initGhcFlagsForTest = initGhcFlags' True +-- | Sets up basic flags and settings for GHC initGhcFlags' :: Bool -> Ghc () initGhcFlags' needsCodeGen = do dflags <- getSessionDynFlags @@ -86,12 +97,13 @@ , packageFlags = ExposePackage "template-haskell" (PackageArg "template-haskell") (ModRenaming True []) : packageFlags dflags } --- | Use the given source directories +-- | Use the given source directories when searching for imported modules useDirs :: [FilePath] -> Ghc () useDirs workingDirs = do dynflags <- getSessionDynFlags void $ setSessionDynFlags dynflags { importPaths = importPaths dynflags ++ workingDirs } +-- | Don't use the given source directories when searching for imported modules deregisterDirs :: [FilePath] -> Ghc () deregisterDirs workingDirs = do dynflags <- getSessionDynFlags @@ -105,6 +117,7 @@ toBootFileName :: FilePath -> String -> FilePath toBootFileName workingDir mod = normalise $ workingDir </> map (\case '.' -> pathSeparator; c -> c) mod ++ ".hs-boot" +-- | Get the source directory where the module is located. getSourceDir :: ModSummary -> IO FilePath getSourceDir ms = do filePath <- canonicalizePath $ getModSumOrig ms @@ -113,6 +126,7 @@ let srcDirParts = reverse $ drop (length modNameParts) $ reverse filePathParts return $ joinPath srcDirParts +-- | Gets the path to the source file of the module. getModSumOrig :: ModSummary -> FilePath getModSumOrig = normalise . fromMaybe (error "getModSumOrig: The given module doesn't have haskell source file.") . ml_hs_file . ms_location @@ -132,9 +146,12 @@ -- | Get the typed representation from a type-correct program. parseTyped :: ModSummary -> Ghc TypedModule parseTyped modSum = withAlteredDynFlags (return . normalizeFlags) $ do - let compExts = extensionFlags $ ms_hspp_opts modSum - hasStaticFlags = fromEnum StaticPointers `member` compExts + let hasStaticFlags = StaticPointers `xopt` ms_hspp_opts modSum + hasCppExtension = Cpp `xopt` ms_hspp_opts modSum + hasUnicodeExtension = UnicodeSyntax `xopt` ms_hspp_opts modSum ms = if hasStaticFlags then forceAsmGen (modSumNormalizeFlags modSum) else (modSumNormalizeFlags modSum) + when (hasCppExtension || hasUnicodeExtension) + $ throw (IllegalExtensions (["CPP" | hasCppExtension] ++ ["UnicodeSyntax" | hasUnicodeExtension])) p <- parseModule ms tc <- typecheckModule p void $ GHC.loadModule tc -- when used with loadModule, the module will be loaded twice @@ -177,11 +194,13 @@ normalizeFlags :: DynFlags -> DynFlags normalizeFlags = updOptLevel 0 +-- | Read a source range from our textual format: @line:col-line:col@ or @line:col@ readSrcSpan :: String -> RealSrcSpan readSrcSpan s = case splitOn "-" s of [one] -> mkRealSrcSpan (readSrcLoc one) (readSrcLoc one) [from,to] -> mkRealSrcSpan (readSrcLoc from) (readSrcLoc to) +-- | Read a source location from our format: @line:col@ readSrcLoc :: String -> RealSrcLoc readSrcLoc s = case splitOn ":" s of [line,col] -> mkRealSrcLoc (mkFastString "file-name-should-be-fixed") (read line) (read col)
Language/Haskell/Tools/Refactor/RefactorBase.hs view
@@ -9,20 +9,25 @@ , MultiWayIf , TemplateHaskell #-} +-- | Basic utilities and types for defining refactorings. module Language.Haskell.Tools.Refactor.RefactorBase where import Language.Haskell.Tools.AST as AST import Language.Haskell.Tools.AST.Rewrite +import Bag as GHC import DynFlags (HasDynFlags(..)) +import ErrUtils as GHC import Exception (ExceptionMonad(..)) import GHC (Ghc, GhcMonad(..), TyThing(..), lookupName) import qualified Module as GHC import qualified Name as GHC +import Outputable import qualified PrelNames as GHC import qualified TyCon as GHC import qualified TysWiredIn as GHC +import Control.Exception import Control.Monad.Reader import Control.Monad.State import Control.Monad.Trans.Except @@ -33,7 +38,9 @@ import Data.List import Data.List.Split import Data.Maybe +import Data.Typeable +-- | A type for the input and result of refactoring a module type UnnamedModule dom = Ann AST.UModule dom SrcTemplateStage -- | The name of the module and the AST @@ -62,6 +69,22 @@ , sameLocation :: SourceFileKey } +-- | Exceptions that can occur while loading modules or during internal operations (not during performing the refactor). +data RefactorException = IllegalExtensions [String] + | SourceCodeProblem ErrorMessages + | UnknownException String + deriving (Show, Typeable) + +instance Show ErrorMessages where + show = show . bagToList + +instance Exception RefactorException where + displayException (SourceCodeProblem prob) + = "Source code problem: " ++ showSDocUnsafe (vcat (pprErrMsgBagWithLoc prob)) + displayException (IllegalExtensions exts) + = "The following extensions are not allowed: " ++ (concat $ intersperse ", " exts) ++ "." + displayException (UnknownException ex) = "An unexpected problem appeared: " ++ ex ++ "." + instance Show (RefactorChange dom) where show (ContentChanged (n, _)) = "ContentChanged (" ++ show n ++ ")" show (ModuleRemoved n) = "ModuleRemoved " ++ n @@ -95,8 +118,11 @@ -- TODO: group names like constructors into correct IESpecs createImport :: [GHC.Name] -> Ann UImportDecl dom SrcTemplateStage + -- works on groupby result, so list is nonempty createImport names = mkImportDecl False False False Nothing (mkModuleName $ GHC.moduleNameString $ GHC.moduleName $ GHC.nameModule $ head names) Nothing (Just $ mkImportSpecList (map (\n -> mkIESpec (mkUnqualName' n) Nothing) names)) + +-- some instances missing from GHC instance (GhcMonad m, Monoid s) => GhcMonad (WriterT s m) where getSession = lift getSession
Language/Haskell/Tools/Refactor/Session.hs view
@@ -1,8 +1,10 @@ {-# LANGUAGE TemplateHaskell , TupleSections #-} +-- | Common operations for managing refactoring sessions, for example loading packages, re-loading modules. module Language.Haskell.Tools.Refactor.Session where +import Control.Exception import Control.Monad.State import Control.Reference import qualified Data.List as List @@ -25,12 +27,16 @@ import Language.Haskell.Tools.Refactor.Prepare import Language.Haskell.Tools.Refactor.RefactorBase +import Debug.Trace + +-- | The state common for refactoring tools, carrying the state of modules. data RefactorSessionState = RefactorSessionState { __refSessMCs :: [ModuleCollection] } makeReferences ''RefactorSessionState +-- | A common class for the state of refactoring tools class IsRefactSessionState st where refSessMCs :: Simple Lens st [ModuleCollection] initSession :: st @@ -39,9 +45,9 @@ refSessMCs = _refSessMCs initSession = RefactorSessionState [] - -loadPackagesFrom :: IsRefactSessionState st => (ModSummary -> IO a) -> [FilePath] -> StateT st Ghc (Either String ([a], [String])) -loadPackagesFrom report packages = +-- | Load packages from the given directories. Loads modules, performs the given callback action, warns for duplicate modules. +loadPackagesFrom :: IsRefactSessionState st => (ModSummary -> IO a) -> [FilePath] -> StateT st Ghc (Either RefactorException ([a], [String])) +loadPackagesFrom report packages = do modColls <- liftIO $ getAllModules packages modify $ refSessMCs .- (++ modColls) allModColls <- gets (^. refSessMCs) @@ -67,9 +73,10 @@ needsCodeGen <- gets (needsGeneratedCode (keyFromMS ms) . (^. refSessMCs)) reloadModule report (if needsCodeGen then forceCodeGen ms else ms) -handleErrors :: ExceptionMonad m => m a -> m (Either String a) -handleErrors action = handleSourceError (return . Left . errorsText) (Right <$> action) - where errorsText = concat . List.intersperse "\n\n" . map showSDocUnsafe . pprErrMsgBagWithLoc . srcErrorMessages +-- | Handle GHC exceptions and RefactorException. +handleErrors :: ExceptionMonad m => m a -> m (Either RefactorException a) +handleErrors action = handleSourceError (return . Left . SourceCodeProblem . srcErrorMessages) (Right <$> action) + `gcatch` (return . Left) keyFromMS :: ModSummary -> SourceFileKey keyFromMS ms = SourceFileKey (case ms_hsc_src ms of HsSrcFile -> NormalHs; _ -> IsHsBoot) (modSumName ms) @@ -93,7 +100,8 @@ case sfs of sf:_ -> getMods (Just sf) [] -> getMods Nothing -reloadChangedModules :: IsRefactSessionState st => (ModSummary -> IO a) -> (ModSummary -> Bool) -> StateT st Ghc (Either String [a]) +-- | Reload the modules that have been changed (given by predicate). Pefrom the callback. +reloadChangedModules :: IsRefactSessionState st => (ModSummary -> IO a) -> (ModSummary -> Bool) -> StateT st Ghc (Either RefactorException [a]) reloadChangedModules report isChanged = handleErrors $ do reachable <- getReachableModules isChanged void $ checkEvaluatedMods report reachable @@ -111,11 +119,12 @@ sortedMods = reverse $ topologicalSortG allModsGraph return $ filter ((`elem` recompMods) . ms_mod) $ map getModFromNode sortedMods +-- | Reload a given module. Perform a callback. reloadModule :: IsRefactSessionState st => (ModSummary -> IO a) -> ModSummary -> StateT st Ghc a reloadModule report ms = do let modName = modSumName ms mcs <- gets (^. refSessMCs) - let Just mc = lookupModuleColl modName mcs + let mc = fromMaybe (error $ "reloadModule: The following module is not found: " ++ modName) $ lookupModuleColl modName mcs codeGen = hasGeneratedCode (keyFromMS ms) mcs let dfs = ms_hspp_opts ms dfs' <- liftIO $ compileInContext mc mcs dfs @@ -142,10 +151,12 @@ else return Nothing else return Nothing +-- | Re-load the module with code generation enabled. Must be used when the module had already been loaded, +-- but code generation were not enabled by then. codeGenForModule :: (ModSummary -> IO a) -> [ModuleCollection] -> ModSummary -> Ghc a codeGenForModule report mcs ms = let modName = modSumName ms - Just mc = lookupModuleColl modName mcs + mc = fromMaybe (error $ "codeGenForModule: The following module is not found: " ++ modName) $ lookupModuleColl modName mcs in -- TODO: don't recompile, only load? do withAlteredDynFlags (liftIO . compileInContext mc mcs) $ void $ parseTyped (forceCodeGen ms)
examples/Module/Import.hs view
@@ -8,4 +8,4 @@ import Data.List as List import Data.List(map,(++)) import Data.Function hiding ((&)) -import Control.Monad.Writer hiding (Alt) +import Control.Monad.Writer hiding (Alt, Writer())
+ examples/Refactor/ExtractBinding/AssocOp.hs view
@@ -0,0 +1,3 @@+module Refactor.ExtractBinding.AssocOp where + +a = 1 + 2 + 3
+ examples/Refactor/ExtractBinding/AssocOpMiddle.hs view
@@ -0,0 +1,3 @@+module Refactor.ExtractBinding.AssocOpMiddle where + +a = 1 * 2 * 3 * 4
+ examples/Refactor/ExtractBinding/AssocOpMiddle_res.hs view
@@ -0,0 +1,4 @@+module Refactor.ExtractBinding.AssocOpMiddle where + +a = 1 * b * 4 + where b = 2 * 3
+ examples/Refactor/ExtractBinding/AssocOpRightAssoc.hs view
@@ -0,0 +1,3 @@+module Refactor.ExtractBinding.AssocOpRightAssoc where + +f = id . id . id
+ examples/Refactor/ExtractBinding/AssocOpRightAssoc_res.hs view
@@ -0,0 +1,4 @@+module Refactor.ExtractBinding.AssocOpRightAssoc where + +f = g . id + where g = id . id
+ examples/Refactor/ExtractBinding/AssocOp_res.hs view
@@ -0,0 +1,4 @@+module Refactor.ExtractBinding.AssocOp where + +a = 1 + b + where b = 2 + 3
+ examples/Refactor/ExtractBinding/LeftSection.hs view
@@ -0,0 +1,3 @@+module Refactor.ExtractBinding.LeftSection where + +a = 1 + 2
+ examples/Refactor/ExtractBinding/LeftSection_res.hs view
@@ -0,0 +1,4 @@+module Refactor.ExtractBinding.LeftSection where + +a = f 2 + where f = (1 +)
+ examples/Refactor/ExtractBinding/RightSection.hs view
@@ -0,0 +1,3 @@+module Refactor.ExtractBinding.RightSection where + +a = 1 + 2
+ examples/Refactor/ExtractBinding/RightSection_res.hs view
@@ -0,0 +1,4 @@+module Refactor.ExtractBinding.RightSection where + +a = f 1 + where f = (+ 2)
+ examples/Refactor/ExtractBinding/SectionInfix.hs view
@@ -0,0 +1,3 @@+module Refactor.ExtractBinding.SectionInfix where + +a = 1 + 2 + 3
+ examples/Refactor/ExtractBinding/SectionInfix_res.hs view
@@ -0,0 +1,4 @@+module Refactor.ExtractBinding.SectionInfix where + +a = f 3 + where f = ((1 + 2) +)
+ examples/Refactor/ExtractBinding/SectionWithLocals.hs view
@@ -0,0 +1,6 @@+module Refactor.ExtractBinding.SectionWithLocals where + +a x = let y = 2 + z = 3 + (<->) = (-) + in x <-> (y + z)
+ examples/Refactor/ExtractBinding/SectionWithLocals_res.hs view
@@ -0,0 +1,7 @@+module Refactor.ExtractBinding.SectionWithLocals where + +a x = let y = 2 + z = 3 + (<->) = (-) + in f y z (<->) x + where f y z (<->) = (<-> (y + z))
+ examples/Refactor/FloatOut/FloatLocals.hs view
@@ -0,0 +1,5 @@+module Refactor.FloatOut.FloatLocals where + +f = g + where g = h + where h = id
+ examples/Refactor/FloatOut/FloatLocals_res.hs view
@@ -0,0 +1,5 @@+module Refactor.FloatOut.FloatLocals where + +f = g + where g = h + h = id
+ examples/Refactor/FloatOut/ImplicitLocal.hs view
@@ -0,0 +1,5 @@+module Refactor.FloatOut.ImplicitLocal where + +f = g + where g = h + h = ()
+ examples/Refactor/FloatOut/ImplicitParam.hs view
@@ -0,0 +1,4 @@+module Refactor.FloatOut.ImplicitParam where + +f a = g + where g = a
+ examples/Refactor/FloatOut/MoveFixity.hs view
@@ -0,0 +1,5 @@+module Refactor.FloatOut.MoveFixity where + +f = 3 <+> 4 + where infixl 6 <+> + a <+> b = a + b
+ examples/Refactor/FloatOut/MoveFixity_res.hs view
@@ -0,0 +1,5 @@+module Refactor.FloatOut.MoveFixity where + +f = 3 <+> 4 +infixl 6 <+> +a <+> b = a + b
+ examples/Refactor/FloatOut/MoveSignature.hs view
@@ -0,0 +1,5 @@+module Refactor.FloatOut.MoveSignature where + +f = g + where g :: a -> a + g = id
+ examples/Refactor/FloatOut/MoveSignature_res.hs view
@@ -0,0 +1,5 @@+module Refactor.FloatOut.MoveSignature where + +f = g +g :: a -> a +g = id
+ examples/Refactor/FloatOut/NameCollosion.hs view
@@ -0,0 +1,6 @@+module Refactor.FloatOut.NameCollosion where + +f = g + where g = id + +g = ()
+ examples/Refactor/FloatOut/NameCollosionWithImport.hs view
@@ -0,0 +1,4 @@+module Refactor.FloatOut.NameCollosionWithImport where + +f = id + where id = ()
+ examples/Refactor/FloatOut/NameCollosionWithLocal.hs view
@@ -0,0 +1,6 @@+module Refactor.FloatOut.NameCollosionWithLocal where + +f = g + where g = h + where h = id + h = ()
+ examples/Refactor/FloatOut/NoCollosion.hs view
@@ -0,0 +1,7 @@+module Refactor.FloatOut.NoCollosion where + +f = g + where g = h + where h = id + +h = ()
+ examples/Refactor/FloatOut/NoCollosion_res.hs view
@@ -0,0 +1,7 @@+module Refactor.FloatOut.NoCollosion where + +f = g + where g = h + h = id + +h = ()
@@ -0,0 +1,6 @@+module Refactor.FloatOut.SharedSignature where + +f = g + where g, h :: a -> a + g = id + h = id
+ examples/Refactor/FloatOut/ToTopLevel.hs view
@@ -0,0 +1,4 @@+module Refactor.FloatOut.ToTopLevel where + +f = g + where g = id
+ examples/Refactor/FloatOut/ToTopLevel_res.hs view
@@ -0,0 +1,4 @@+module Refactor.FloatOut.ToTopLevel where + +f = g +g = id
examples/Refactor/GenerateTypeSignature/HigherOrder_res.hs view
@@ -1,4 +1,4 @@ module Refactor.GenerateTypeSignature.HigherOrder where -app :: (t -> t1) -> t -> t1 +app :: (t1 -> t) -> t1 -> t app f x = f x
examples/Refactor/GenerateTypeSignature/PolymorphSubMulti_res.hs view
@@ -2,5 +2,5 @@ f :: (Num a, Ord a) => a -> a f a = g a where - g :: (Ord t, Num t) => t -> t + g :: (Num t, Ord t) => t -> t g a = if a > 0 then a + 1 else a
examples/Refactor/GenerateTypeSignature/Tuple_res.hs view
@@ -1,4 +1,4 @@ module Refactor.GenerateTypeSignature.Tuple where -tuple :: t -> t1 -> (t, t1) +tuple :: t1 -> t -> (t1, t) tuple x y = (x,y)
+ examples/Refactor/InlineBinding/LetBind.hs view
@@ -0,0 +1,3 @@+module Refactor.InlineBinding.LetBind where + +a = let x = () in x
+ examples/Refactor/InlineBinding/LetBind_res.hs view
@@ -0,0 +1,3 @@+module Refactor.InlineBinding.LetBind where + +a = ()
+ examples/Refactor/InlineBinding/LetGuard.hs view
@@ -0,0 +1,5 @@+module Refactor.InlineBinding.LetGuard where + +a | let x = 3 + , x == 3 + = ()
+ examples/Refactor/InlineBinding/LetGuard_res.hs view
@@ -0,0 +1,4 @@+module Refactor.InlineBinding.LetGuard where + +a | 3 == 3 + = ()
+ examples/Refactor/InlineBinding/LetStmt.hs view
@@ -0,0 +1,4 @@+module Refactor.InlineBinding.LetStmt where + +a = do let x = () + putStrLn (show x)
+ examples/Refactor/InlineBinding/LetStmt_res.hs view
@@ -0,0 +1,3 @@+module Refactor.InlineBinding.LetStmt where + +a = do putStrLn (show ())
examples/Refactor/InlineBinding/LocalNested_res.hs view
@@ -1,5 +1,4 @@ module Refactor.InlineBinding.LocalNested where a = b - where b = () - where + where b = ()
examples/Refactor/InlineBinding/Local_res.hs view
@@ -1,4 +1,3 @@ module Refactor.InlineBinding.Local where -b = () - where +b = ()
+ examples/Refactor/OrganizeImports/NarrowSpec.hs view
@@ -0,0 +1,5 @@+module Refactor.OrganizeImports.NarrowSpec where + +import Control.Monad.State (State(..)) + +type St = State ()
+ examples/Refactor/OrganizeImports/NarrowSpec_res.hs view
@@ -0,0 +1,5 @@+module Refactor.OrganizeImports.NarrowSpec where + +import Control.Monad.State (State) + +type St = State ()
+ examples/Refactor/OrganizeImports/NarrowType.hs view
@@ -0,0 +1,8 @@+module Refactor.OrganizeImports.NarrowType where + +import Control.Monad.State + +type St = State () +type StT = StateT () IO + +f = runStateT
+ examples/Refactor/OrganizeImports/NarrowType_res.hs view
@@ -0,0 +1,8 @@+module Refactor.OrganizeImports.NarrowType where + +import Control.Monad.State (StateT(..), State) + +type St = State () +type StT = StateT () IO + +f = runStateT
+ examples/Refactor/OrganizeImports/StandaloneDeriving.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE StandaloneDeriving #-} +module Refactor.OrganizeImports.StandaloneDeriving where + +import Control.Monad.State (State(..), StateT) + +type St = State ()
+ examples/Refactor/OrganizeImports/StandaloneDeriving_res.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE StandaloneDeriving #-} +module Refactor.OrganizeImports.StandaloneDeriving where + +import Control.Monad.State (State(..)) + +type St = State ()
+ examples/Refactor/OrganizeImports/TemplateHaskell.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE TemplateHaskell #-} +module Refactor.OrganizeImports.TemplateHaskell where + +import Control.Monad.Writer +import Control.Monad.State (State(..))
+ examples/Refactor/OrganizeImports/TemplateHaskell_res.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE TemplateHaskell #-} +module Refactor.OrganizeImports.TemplateHaskell where + +import Control.Monad.State (State(..)) +import Control.Monad.Writer
examples/Type/TypeOperators.hs view
@@ -4,4 +4,7 @@ infixr 6 :+: data a :+: r = a :+: r -type X = Int :+: Char :+: String+type X = Int :+: Char :+: String + +type (:&:) = (,) +infixr :&:
haskell-tools-refactor.cabal view
@@ -1,5 +1,5 @@ name: haskell-tools-refactor -version: 0.4.1.3 +version: 0.5.0.0 synopsis: Refactoring Tool for Haskell description: Contains a set of refactorings based on the Haskell-Tools framework to easily transform a Haskell program. For the descriptions of the implemented refactorings, see the homepage. homepage: https://github.com/haskell-tools/haskell-tools @@ -43,6 +43,7 @@ , examples/Refactor/RenameDefinition/SpliceExpr_res/*.hs , examples/Refactor/RenameDefinition/SpliceType/*.hs , examples/Refactor/RenameDefinition/SpliceType_res/*.hs + , examples/Refactor/FloatOut/*.hs , examples/TH/*.hs , examples/TH/QuasiQuote/*.hs , examples/TH/Splice/*.hs @@ -58,6 +59,7 @@ , Language.Haskell.Tools.Refactor.Perform , Language.Haskell.Tools.Refactor.ListOperations , Language.Haskell.Tools.Refactor.Session + , Language.Haskell.Tools.Refactor.Helpers , Language.Haskell.Tools.Refactor.Predefined.GenerateTypeSignature , Language.Haskell.Tools.Refactor.Predefined.OrganizeImports @@ -68,6 +70,7 @@ , Language.Haskell.Tools.Refactor.Predefined.IfToGuards , Language.Haskell.Tools.Refactor.Predefined.DollarApp , Language.Haskell.Tools.Refactor.Predefined.InlineBinding + , Language.Haskell.Tools.Refactor.Predefined.FloatOut build-depends: base >= 4.9 && < 4.10 , mtl >= 2.2 && < 2.3 @@ -82,10 +85,10 @@ , template-haskell >= 2.11 && < 2.12 , ghc >= 8.0 && < 8.1 , Cabal >= 1.24 && < 1.25 - , haskell-tools-ast >= 0.4 && < 0.5 - , haskell-tools-backend-ghc >= 0.4 && < 0.5 - , haskell-tools-rewrite >= 0.4 && < 0.5 - , haskell-tools-prettyprint >= 0.4 && < 0.5 + , haskell-tools-ast >= 0.5 && < 0.6 + , haskell-tools-backend-ghc >= 0.5 && < 0.6 + , haskell-tools-rewrite >= 0.5 && < 0.6 + , haskell-tools-prettyprint >= 0.5 && < 0.6 default-language: Haskell2010 test-suite haskell-tools-test @@ -110,9 +113,12 @@ , ghc >= 8.0 && < 8.1 , ghc-paths >= 0.1 && < 0.2 , Cabal >= 1.24 && < 1.25 - , haskell-tools-ast >= 0.4 && < 0.5 - , haskell-tools-backend-ghc >= 0.4 && < 0.5 - , haskell-tools-rewrite >= 0.4 && < 0.5 - , haskell-tools-prettyprint >= 0.4 && < 0.5 - , haskell-tools-refactor >= 0.4 && < 0.5 + , haskell-tools-ast >= 0.5 && < 0.6 + , haskell-tools-backend-ghc >= 0.5 && < 0.6 + , haskell-tools-rewrite >= 0.5 && < 0.6 + , haskell-tools-prettyprint >= 0.5 && < 0.6 + , haskell-tools-refactor >= 0.5 && < 0.6 + -- libraries used by the examples + , old-time >= 1.1 && < 1.2 + , polyparse >= 1.12 && < 1.13 default-language: Haskell2010
test/Main.hs view
@@ -69,6 +69,8 @@ ++ map makeWrongExtractBindingTest wrongExtractBindingTests ++ map makeInlineBindingTest inlineBindingTests ++ map makeWrongInlineBindingTest wrongInlineBindingTests + ++ map makeFloatOutTest floatOutTests + ++ map makeWrongFloatOutTest wrongFloatOutTests ++ map (makeMultiModuleTest checkMultiResults) multiModuleTests ++ map (makeMultiModuleTest checkMultiFail) wrongMultiModuleTests ++ map makeMiscRefactorTest miscRefactorTests @@ -222,6 +224,10 @@ , "Refactor.OrganizeImports.InstanceCarry.ImportOrphan" , "Refactor.OrganizeImports.InstanceCarry.ImportNonOrphan" , "Refactor.OrganizeImports.NarrowQual" + , "Refactor.OrganizeImports.NarrowSpec" + , "Refactor.OrganizeImports.StandaloneDeriving" + , "Refactor.OrganizeImports.TemplateHaskell" + , "Refactor.OrganizeImports.NarrowType" ] generateSignatureTests = @@ -314,6 +320,13 @@ , ("Refactor.ExtractBinding.IndentationMultiLine", "3:12-3:18", "extracted") , ("Refactor.ExtractBinding.IndentationOperator", "3:13-3:20", "extracted") , ("Refactor.ExtractBinding.ExtractedFormatting", "4:5-5:7", "extracted") + , ("Refactor.ExtractBinding.LeftSection", "3:5-3:8", "f") + , ("Refactor.ExtractBinding.RightSection", "3:7-3:10", "f") + , ("Refactor.ExtractBinding.SectionWithLocals", "6:13-6:24", "f") + , ("Refactor.ExtractBinding.SectionInfix", "3:5-3:12", "f") + , ("Refactor.ExtractBinding.AssocOp", "3:9-3:14", "b") + , ("Refactor.ExtractBinding.AssocOpRightAssoc", "3:5-3:12", "g") + , ("Refactor.ExtractBinding.AssocOpMiddle", "3:9-3:14", "b") ] wrongExtractBindingTests = @@ -336,6 +349,9 @@ , ("Refactor.InlineBinding.MultiMatchGuarded", "4:1-4:2") , ("Refactor.InlineBinding.RemoveSignatures", "5:1-5:2") , ("Refactor.InlineBinding.FilterSignatures", "5:1-5:2") + , ("Refactor.InlineBinding.LetBind", "3:9-3:10") + , ("Refactor.InlineBinding.LetStmt", "3:12-3:13") + , ("Refactor.InlineBinding.LetGuard", "3:9-3:10") ] wrongInlineBindingTests = @@ -344,7 +360,23 @@ , ("Refactor.InlineBinding.NotOccurring", "3:1") ] +floatOutTests = + [ ("Refactor.FloatOut.ToTopLevel", "4:10") + , ("Refactor.FloatOut.FloatLocals", "5:18") + , ("Refactor.FloatOut.MoveSignature", "5:10") + , ("Refactor.FloatOut.MoveFixity", "5:11-5:14") + , ("Refactor.FloatOut.NoCollosion", "5:18") + ] +wrongFloatOutTests = + [ ("Refactor.FloatOut.NameCollosion", "4:10") + , ("Refactor.FloatOut.NameCollosionWithImport", "4:11") + , ("Refactor.FloatOut.NameCollosionWithLocal", "5:18") + , ("Refactor.FloatOut.SharedSignature", "5:10") + , ("Refactor.FloatOut.ImplicitLocal", "4:10") + , ("Refactor.FloatOut.ImplicitParam", "4:10") + ] + multiModuleTests = [ ("RenameDefinition 5:5-5:6 bb", "A", "Refactor" </> "RenameDefinition" </> "MultiModule", []) , ("RenameDefinition 1:8-1:9 C", "B", "Refactor" </> "RenameDefinition" </> "RenameModule", ["B"]) @@ -428,7 +460,13 @@ makeWrongInlineBindingTest :: (String, String) -> TestTree makeWrongInlineBindingTest (mod, rng) = createFailTest "InlineBinding" [rng] mod - + +makeFloatOutTest :: (String, String) -> TestTree +makeFloatOutTest (mod, rng) = createTest "FloatOut" [rng] mod + +makeWrongFloatOutTest :: (String, String) -> TestTree +makeWrongFloatOutTest (mod, rng) = createFailTest "FloatOut" [rng] mod + checkCorrectlyTransformed :: String -> String -> String -> IO () checkCorrectlyTransformed command workingDir moduleName = do expected <- loadExpected True workingDir moduleName