haskell-tools-refactor 0.2.0.0 → 0.3.0.0
raw patch · 25 files changed
+1676/−952 lines, 25 filesdep +haskell-tools-backend-ghcdep +haskell-tools-rewritedep +old-timedep −haskell-tools-ast-fromghcdep −haskell-tools-ast-gendep −haskell-tools-ast-trfdep ~Cabaldep ~HUnitdep ~basePVP ok
version bump matches the API change (PVP)
Dependencies added: haskell-tools-backend-ghc, haskell-tools-rewrite, old-time
Dependencies removed: haskell-tools-ast-fromghc, haskell-tools-ast-gen, haskell-tools-ast-trf
Dependency ranges changed: Cabal, HUnit, base, either, filepath, haskell-tools-ast, haskell-tools-prettyprint, haskell-tools-refactor, polyparse, references, split, template-haskell, time
API changes (from Hackage documentation)
- Language.Haskell.Tools.Refactor: ExtractBinding :: RealSrcSpan -> String -> RefactorCommand
- Language.Haskell.Tools.Refactor: GenerateExports :: RefactorCommand
- Language.Haskell.Tools.Refactor: GenerateSignature :: RealSrcSpan -> RefactorCommand
- Language.Haskell.Tools.Refactor: IsHsBoot :: IsBoot
- Language.Haskell.Tools.Refactor: NoRefactor :: RefactorCommand
- Language.Haskell.Tools.Refactor: NormalHs :: IsBoot
- Language.Haskell.Tools.Refactor: OrganizeImports :: RefactorCommand
- Language.Haskell.Tools.Refactor: RenameDefinition :: RealSrcSpan -> String -> RefactorCommand
- Language.Haskell.Tools.Refactor: analyzeCommand :: String -> String -> [String] -> RefactorCommand
- Language.Haskell.Tools.Refactor: data IsBoot
- Language.Haskell.Tools.Refactor: data RefactorCommand
- Language.Haskell.Tools.Refactor: initGhcFlags :: Ghc ()
- Language.Haskell.Tools.Refactor: instance GHC.Classes.Eq Language.Haskell.Tools.Refactor.IsBoot
- Language.Haskell.Tools.Refactor: instance GHC.Classes.Ord Language.Haskell.Tools.Refactor.IsBoot
- Language.Haskell.Tools.Refactor: instance GHC.Show.Show Language.Haskell.Tools.Refactor.IsBoot
- Language.Haskell.Tools.Refactor: instance GHC.Show.Show Language.Haskell.Tools.Refactor.RefactorCommand
- Language.Haskell.Tools.Refactor: loadModule :: String -> String -> Ghc ModSummary
- Language.Haskell.Tools.Refactor: parseTyped :: ModSummary -> Ghc TypedModule
- Language.Haskell.Tools.Refactor: performCommand :: (HasModuleInfo dom, DomGenerateExports dom, OrganizeImportsDomain dom, DomainRenameDefinition dom, ExtractBindingDomain dom, GenerateSignatureDomain dom) => RefactorCommand -> ModuleDom dom -> [ModuleDom dom] -> Ghc (Either String [RefactorChange dom])
- Language.Haskell.Tools.Refactor: readCommand :: String -> String -> RefactorCommand
- Language.Haskell.Tools.Refactor: readSrcLoc :: String -> String -> RealSrcLoc
- Language.Haskell.Tools.Refactor: readSrcSpan :: String -> String -> RealSrcSpan
- Language.Haskell.Tools.Refactor: toBootFileName :: String -> String -> FilePath
- Language.Haskell.Tools.Refactor: toFileName :: String -> String -> FilePath
- Language.Haskell.Tools.Refactor: tryRefactor :: Refactoring IdDom -> String -> IO ()
- Language.Haskell.Tools.Refactor: type TypedModule = Ann Module IdDom SrcTemplateStage
- Language.Haskell.Tools.Refactor: useDirs :: [FilePath] -> Ghc ()
- Language.Haskell.Tools.Refactor: useFlags :: [String] -> Ghc [String]
- Language.Haskell.Tools.Refactor.DataToNewtype: dataToNewtype :: Domain dom => LocalRefactoring dom
- Language.Haskell.Tools.Refactor.DollarApp: dollarApp :: DollarDomain dom => RealSrcSpan -> LocalRefactoring dom
- Language.Haskell.Tools.Refactor.ExtractBinding: actualContainingExpr :: SourceInfo st => SrcSpan -> Simple Traversal (Ann ValueBind dom st) (Ann Expr dom st)
- Language.Haskell.Tools.Refactor.ExtractBinding: addLocalBinding :: SrcSpan -> SrcSpan -> Ann' ValueBind dom -> ValueBind dom SrcTemplateStage -> State Bool (ValueBind dom SrcTemplateStage)
- Language.Haskell.Tools.Refactor.ExtractBinding: doExtract :: ExtractBindingDomain dom => String -> Ann' Expr dom -> Ann' Expr dom -> StateT (Maybe (Ann' ValueBind dom)) (LocalRefactor dom) (Ann' Expr dom)
- Language.Haskell.Tools.Refactor.ExtractBinding: extractBinding :: forall dom. ExtractBindingDomain dom => Simple Traversal (Ann' Module dom) (Ann' ValueBind dom) -> Simple Traversal (Ann' ValueBind dom) (Ann' Expr dom) -> String -> LocalRefactoring dom
- Language.Haskell.Tools.Refactor.ExtractBinding: extractBinding' :: ExtractBindingDomain dom => RealSrcSpan -> String -> LocalRefactoring dom
- Language.Haskell.Tools.Refactor.ExtractBinding: extractThatBind :: ExtractBindingDomain dom => String -> Ann' Expr dom -> Ann' Expr dom -> StateT (Maybe (Ann' ValueBind dom)) (LocalRefactor dom) (Ann' Expr dom)
- Language.Haskell.Tools.Refactor.ExtractBinding: generateBind :: String -> [Ann' Pattern dom] -> Ann' Expr dom -> Ann' ValueBind dom
- Language.Haskell.Tools.Refactor.ExtractBinding: generateCall :: String -> [Ann' Name dom] -> Ann' Expr dom
- Language.Haskell.Tools.Refactor.ExtractBinding: getExternalBinds :: ExtractBindingDomain dom => Ann' Expr dom -> Ann' Expr dom -> [Ann' Name dom]
- Language.Haskell.Tools.Refactor.ExtractBinding: insertLocalBind :: SrcSpan -> Ann' ValueBind dom -> AnnMaybe' LocalBinds dom -> AnnMaybe' LocalBinds dom
- Language.Haskell.Tools.Refactor.ExtractBinding: isConflicting :: ExtractBindingDomain dom => String -> Ann' QualifiedName dom -> Bool
- Language.Haskell.Tools.Refactor.ExtractBinding: isParenLikeExpr :: Expr dom st -> Bool
- Language.Haskell.Tools.Refactor.ExtractBinding: isValidBindingName :: String -> Bool
- Language.Haskell.Tools.Refactor.ExtractBinding: type Ann' e dom = Ann e dom SrcTemplateStage
- Language.Haskell.Tools.Refactor.ExtractBinding: type AnnMaybe' e dom = AnnMaybe e dom SrcTemplateStage
- Language.Haskell.Tools.Refactor.ExtractBinding: type ExtractBindingDomain dom = (Domain dom, HasNameInfo dom, HasDefiningInfo dom, HasScopeInfo dom)
- Language.Haskell.Tools.Refactor.GenerateExports: createExports :: DomGenerateExports dom => [(Name, Bool)] -> Ann ExportSpecList dom SrcTemplateStage
- Language.Haskell.Tools.Refactor.GenerateExports: generateExports :: DomGenerateExports dom => LocalRefactoring dom
- Language.Haskell.Tools.Refactor.GenerateExports: getTopLevelDeclName :: DomGenerateExports dom => Decl dom SrcTemplateStage -> Maybe Name
- Language.Haskell.Tools.Refactor.GenerateExports: getTopLevels :: DomGenerateExports dom => Ann Module dom SrcTemplateStage -> [(Name, Bool)]
- Language.Haskell.Tools.Refactor.GenerateExports: type DomGenerateExports dom = (Domain dom, HasNameInfo dom)
- Language.Haskell.Tools.Refactor.GenerateTypeSignature: generateTypeSignature :: GenerateSignatureDomain dom => Simple Traversal (Ann' Module dom) (AnnList' Decl dom) -> Simple Traversal (Ann' Module dom) (AnnList' LocalBind dom) -> (forall d. (Show (d dom SrcTemplateStage), Data (d dom SrcTemplateStage), Typeable d, BindingElem d) => AnnList' d dom -> Maybe (Ann' ValueBind dom)) -> LocalRefactoring dom
- Language.Haskell.Tools.Refactor.GenerateTypeSignature: generateTypeSignature' :: GenerateSignatureDomain dom => RealSrcSpan -> LocalRefactoring dom
- Language.Haskell.Tools.Refactor.GenerateTypeSignature: type GenerateSignatureDomain dom = (HasModuleInfo dom, HasIdInfo dom, HasImportInfo dom)
- Language.Haskell.Tools.Refactor.IfToGuards: ifToGuards :: Domain dom => RealSrcSpan -> LocalRefactoring dom
- Language.Haskell.Tools.Refactor.OrganizeImports: organizeImports :: forall dom. OrganizeImportsDomain dom => LocalRefactoring dom
- Language.Haskell.Tools.Refactor.OrganizeImports: type OrganizeImportsDomain dom = (Domain dom, HasNameInfo dom, HasImportInfo dom)
- Language.Haskell.Tools.Refactor.RefactorBase: instance (GHC.Base.Monad m, DynFlags.HasDynFlags m) => DynFlags.HasDynFlags (Language.Haskell.Tools.Refactor.RefactorBase.LocalRefactorT dom m)
- Language.Haskell.Tools.Refactor.RenameDefinition: renameDefinition :: DomainRenameDefinition dom => Name -> [Name] -> String -> Refactoring dom
- Language.Haskell.Tools.Refactor.RenameDefinition: renameDefinition' :: forall dom. DomainRenameDefinition dom => RealSrcSpan -> String -> Refactoring dom
- Language.Haskell.Tools.Refactor.RenameDefinition: type DomainRenameDefinition dom = (HasNameInfo dom, HasScopeInfo dom, HasDefiningInfo dom, HasImplicitFieldsInfo dom, HasModuleInfo dom)
+ Language.Haskell.Tools.Refactor: annJust :: (Functor w, Applicative w, Monad w, Functor r, Applicative r, MonadPlus r, Morph Maybe r) => Reference w r (MU *) (MU *) (AnnMaybeG e d s) (AnnMaybeG e d s) (Ann e d s) (Ann e d s)
+ Language.Haskell.Tools.Refactor: annList :: (RefMonads w r, MonadPlus r, Morph Maybe r, Morph [] r) => Reference w r (MU *) (MU *) (AnnListG e d s) (AnnListG e d s) (Ann e d s) (Ann e d s)
+ Language.Haskell.Tools.Refactor: annListElems :: RefMonads w r => Reference w r (MU *) (MU *) (AnnListG elem0 dom0 stage0) (AnnListG elem0 dom0 stage0) [Ann elem0 dom0 stage0] [Ann elem0 dom0 stage0]
+ Language.Haskell.Tools.Refactor: class (Typeable * d, Data d, (~) * (SemanticInfo' d SameInfoDefaultCls) NoSemanticInfo, Data (SemanticInfo' d SameInfoNameCls), Data (SemanticInfo' d SameInfoExprCls), Data (SemanticInfo' d SameInfoImportCls), Data (SemanticInfo' d SameInfoModuleCls), Data (SemanticInfo' d SameInfoWildcardCls), Show (SemanticInfo' d SameInfoNameCls), Show (SemanticInfo' d SameInfoExprCls), Show (SemanticInfo' d SameInfoImportCls), Show (SemanticInfo' d SameInfoModuleCls), Show (SemanticInfo' d SameInfoWildcardCls)) => Domain d
+ Language.Haskell.Tools.Refactor: class HasRange a
+ Language.Haskell.Tools.Refactor: getRange :: HasRange a => a -> SrcSpan
+ Language.Haskell.Tools.Refactor: isAnnNothing :: AnnMaybeG e d s -> Bool
+ Language.Haskell.Tools.Refactor: setRange :: HasRange a => SrcSpan -> a -> a
+ Language.Haskell.Tools.Refactor.BindingElem: class NamedElement d => BindingElem d
+ Language.Haskell.Tools.Refactor.BindingElem: createBinding :: BindingElem d => ValueBind dom -> Ann d dom SrcTemplateStage
+ Language.Haskell.Tools.Refactor.BindingElem: createTypeSig :: BindingElem d => TypeSignature dom -> Ann d dom SrcTemplateStage
+ Language.Haskell.Tools.Refactor.BindingElem: getValBindInList :: (BindingElem d) => RealSrcSpan -> AnnListG d dom SrcTemplateStage -> Maybe (ValueBind dom)
+ Language.Haskell.Tools.Refactor.BindingElem: instance Language.Haskell.Tools.Refactor.BindingElem.BindingElem Language.Haskell.Tools.AST.Representation.Binds.ULocalBind
+ Language.Haskell.Tools.Refactor.BindingElem: instance Language.Haskell.Tools.Refactor.BindingElem.BindingElem Language.Haskell.Tools.AST.Representation.Decls.UDecl
+ Language.Haskell.Tools.Refactor.BindingElem: isBinding :: BindingElem d => Ann d dom SrcTemplateStage -> Bool
+ Language.Haskell.Tools.Refactor.BindingElem: isTypeSig :: BindingElem d => Ann d dom SrcTemplateStage -> Bool
+ Language.Haskell.Tools.Refactor.BindingElem: sigBind :: BindingElem d => Simple Partial (Ann d dom SrcTemplateStage) (TypeSignature dom)
+ Language.Haskell.Tools.Refactor.BindingElem: valBind :: BindingElem d => Simple Partial (Ann d dom SrcTemplateStage) (ValueBind dom)
+ Language.Haskell.Tools.Refactor.BindingElem: valBindsInList :: BindingElem d => Simple Traversal (AnnListG d dom SrcTemplateStage) (ValueBind dom)
+ Language.Haskell.Tools.Refactor.GetModules: srcDirFromRoot :: FilePath -> String -> FilePath
+ Language.Haskell.Tools.Refactor.ListOperations: filterList :: (Ann e dom SrcTemplateStage -> Bool) -> AnnListG e dom SrcTemplateStage -> AnnListG e dom SrcTemplateStage
+ Language.Haskell.Tools.Refactor.ListOperations: insertIndex :: (Maybe (Ann e dom SrcTemplateStage) -> Bool) -> (Maybe (Ann e dom SrcTemplateStage) -> Bool) -> [Ann e dom SrcTemplateStage] -> Maybe Int
+ Language.Haskell.Tools.Refactor.ListOperations: insertWhere :: Ann e dom SrcTemplateStage -> (Maybe (Ann e dom SrcTemplateStage) -> Bool) -> (Maybe (Ann e dom SrcTemplateStage) -> Bool) -> AnnListG e dom SrcTemplateStage -> AnnListG e dom SrcTemplateStage
+ Language.Haskell.Tools.Refactor.ListOperations: replaceList :: [Ann e dom SrcTemplateStage] -> AnnListG e dom SrcTemplateStage -> AnnListG e dom SrcTemplateStage
+ Language.Haskell.Tools.Refactor.ListOperations: replaceWithJust :: Ann e dom SrcTemplateStage -> AnnMaybe e dom -> AnnMaybe e dom
+ Language.Haskell.Tools.Refactor.Perform: ExtractBinding :: RealSrcSpan -> String -> RefactorCommand
+ Language.Haskell.Tools.Refactor.Perform: GenerateExports :: RefactorCommand
+ Language.Haskell.Tools.Refactor.Perform: GenerateSignature :: RealSrcSpan -> RefactorCommand
+ Language.Haskell.Tools.Refactor.Perform: NoRefactor :: RefactorCommand
+ Language.Haskell.Tools.Refactor.Perform: OrganizeImports :: RefactorCommand
+ Language.Haskell.Tools.Refactor.Perform: RenameDefinition :: RealSrcSpan -> String -> RefactorCommand
+ Language.Haskell.Tools.Refactor.Perform: analyzeCommand :: String -> String -> [String] -> RefactorCommand
+ Language.Haskell.Tools.Refactor.Perform: data RefactorCommand
+ Language.Haskell.Tools.Refactor.Perform: instance GHC.Show.Show Language.Haskell.Tools.Refactor.Perform.RefactorCommand
+ Language.Haskell.Tools.Refactor.Perform: performCommand :: (HasModuleInfo dom, DomGenerateExports dom, OrganizeImportsDomain dom, DomainRenameDefinition dom, ExtractBindingDomain dom, GenerateSignatureDomain dom) => RefactorCommand -> ModuleDom dom -> [ModuleDom dom] -> Ghc (Either String [RefactorChange dom])
+ Language.Haskell.Tools.Refactor.Perform: readCommand :: String -> String -> RefactorCommand
+ Language.Haskell.Tools.Refactor.Predefined.DataToNewtype: dataToNewtype :: Domain dom => LocalRefactoring dom
+ Language.Haskell.Tools.Refactor.Predefined.DollarApp: dollarApp :: DollarDomain dom => RealSrcSpan -> LocalRefactoring dom
+ Language.Haskell.Tools.Refactor.Predefined.DollarApp: type DollarDomain dom = (HasImportInfo dom, HasModuleInfo dom, HasFixityInfo dom, HasNameInfo dom)
+ Language.Haskell.Tools.Refactor.Predefined.ExtractBinding: extractBinding' :: ExtractBindingDomain dom => RealSrcSpan -> String -> LocalRefactoring dom
+ Language.Haskell.Tools.Refactor.Predefined.ExtractBinding: type ExtractBindingDomain dom = (HasNameInfo dom, HasDefiningInfo dom, HasScopeInfo dom)
+ Language.Haskell.Tools.Refactor.Predefined.GenerateExports: generateExports :: DomGenerateExports dom => LocalRefactoring dom
+ Language.Haskell.Tools.Refactor.Predefined.GenerateExports: type DomGenerateExports dom = (Domain dom, HasNameInfo dom)
+ Language.Haskell.Tools.Refactor.Predefined.GenerateTypeSignature: generateTypeSignature :: GenerateSignatureDomain dom => Simple Traversal (Module dom) (DeclList dom) -> Simple Traversal (Module dom) (LocalBindList dom) -> (forall d. (BindingElem d) => AnnList d dom -> Maybe (ValueBind dom)) -> LocalRefactoring dom
+ Language.Haskell.Tools.Refactor.Predefined.GenerateTypeSignature: generateTypeSignature' :: GenerateSignatureDomain dom => RealSrcSpan -> LocalRefactoring dom
+ Language.Haskell.Tools.Refactor.Predefined.GenerateTypeSignature: type GenerateSignatureDomain dom = (HasModuleInfo dom, HasIdInfo dom, HasImportInfo dom)
+ Language.Haskell.Tools.Refactor.Predefined.IfToGuards: ifToGuards :: Domain dom => RealSrcSpan -> LocalRefactoring dom
+ Language.Haskell.Tools.Refactor.Predefined.OrganizeImports: organizeImports :: forall dom. OrganizeImportsDomain dom => LocalRefactoring dom
+ Language.Haskell.Tools.Refactor.Predefined.OrganizeImports: type OrganizeImportsDomain dom = (HasNameInfo dom, HasImportInfo dom)
+ Language.Haskell.Tools.Refactor.Predefined.RenameDefinition: renameDefinition :: DomainRenameDefinition dom => Name -> [Name] -> String -> Refactoring dom
+ Language.Haskell.Tools.Refactor.Predefined.RenameDefinition: renameDefinition' :: forall dom. DomainRenameDefinition dom => RealSrcSpan -> String -> Refactoring dom
+ Language.Haskell.Tools.Refactor.Predefined.RenameDefinition: type DomainRenameDefinition dom = (HasNameInfo dom, HasScopeInfo dom, HasDefiningInfo dom, HasImplicitFieldsInfo dom, HasModuleInfo dom)
+ Language.Haskell.Tools.Refactor.Prepare: IsHsBoot :: IsBoot
+ Language.Haskell.Tools.Refactor.Prepare: NormalHs :: IsBoot
+ Language.Haskell.Tools.Refactor.Prepare: data IsBoot
+ Language.Haskell.Tools.Refactor.Prepare: initGhcFlags :: Ghc ()
+ Language.Haskell.Tools.Refactor.Prepare: instance GHC.Classes.Eq Language.Haskell.Tools.Refactor.Prepare.IsBoot
+ Language.Haskell.Tools.Refactor.Prepare: instance GHC.Classes.Ord Language.Haskell.Tools.Refactor.Prepare.IsBoot
+ Language.Haskell.Tools.Refactor.Prepare: instance GHC.Show.Show Language.Haskell.Tools.Refactor.Prepare.IsBoot
+ Language.Haskell.Tools.Refactor.Prepare: loadModule :: String -> String -> Ghc ModSummary
+ Language.Haskell.Tools.Refactor.Prepare: parseTyped :: ModSummary -> Ghc TypedModule
+ Language.Haskell.Tools.Refactor.Prepare: readSrcLoc :: String -> String -> RealSrcLoc
+ Language.Haskell.Tools.Refactor.Prepare: readSrcSpan :: String -> String -> RealSrcSpan
+ Language.Haskell.Tools.Refactor.Prepare: toBootFileName :: String -> String -> FilePath
+ Language.Haskell.Tools.Refactor.Prepare: toFileName :: String -> String -> FilePath
+ Language.Haskell.Tools.Refactor.Prepare: tryRefactor :: Refactoring IdDom -> String -> IO ()
+ Language.Haskell.Tools.Refactor.Prepare: type TypedModule = Ann UModule IdDom SrcTemplateStage
+ Language.Haskell.Tools.Refactor.Prepare: useDirs :: [FilePath] -> Ghc ()
+ Language.Haskell.Tools.Refactor.Prepare: useFlags :: [String] -> Ghc [String]
+ Language.Haskell.Tools.Refactor.RefactorBase: instance (DynFlags.HasDynFlags m, GHC.Base.Monad m) => DynFlags.HasDynFlags (Language.Haskell.Tools.Refactor.RefactorBase.LocalRefactorT dom m)
- Language.Haskell.Tools.Refactor.GetModules: getModules :: FilePath -> IO [String]
+ Language.Haskell.Tools.Refactor.GetModules: getModules :: FilePath -> IO [([FilePath], [String])]
- Language.Haskell.Tools.Refactor.GetModules: modulesFromCabalFile :: FilePath -> IO [String]
+ Language.Haskell.Tools.Refactor.GetModules: modulesFromCabalFile :: FilePath -> IO [([FilePath], [String])]
- Language.Haskell.Tools.Refactor.RefactorBase: RefactorCtx :: Module -> Ann Module dom SrcTemplateStage -> [Ann ImportDecl dom SrcTemplateStage] -> RefactorCtx dom
+ Language.Haskell.Tools.Refactor.RefactorBase: RefactorCtx :: Module -> Ann UModule dom SrcTemplateStage -> [Ann UImportDecl dom SrcTemplateStage] -> RefactorCtx dom
- Language.Haskell.Tools.Refactor.RefactorBase: [refCtxImports] :: RefactorCtx dom -> [Ann ImportDecl dom SrcTemplateStage]
+ Language.Haskell.Tools.Refactor.RefactorBase: [refCtxImports] :: RefactorCtx dom -> [Ann UImportDecl dom SrcTemplateStage]
- Language.Haskell.Tools.Refactor.RefactorBase: [refCtxRoot] :: RefactorCtx dom -> Ann Module dom SrcTemplateStage
+ Language.Haskell.Tools.Refactor.RefactorBase: [refCtxRoot] :: RefactorCtx dom -> Ann UModule dom SrcTemplateStage
- Language.Haskell.Tools.Refactor.RefactorBase: addGeneratedImports :: [Name] -> Ann Module dom SrcTemplateStage -> Ann Module dom SrcTemplateStage
+ Language.Haskell.Tools.Refactor.RefactorBase: addGeneratedImports :: [Name] -> Ann UModule dom SrcTemplateStage -> Ann UModule dom SrcTemplateStage
- Language.Haskell.Tools.Refactor.RefactorBase: referenceBy :: ([String] -> Name -> Ann nt dom SrcTemplateStage) -> Name -> [Ann ImportDecl dom SrcTemplateStage] -> Ann nt dom SrcTemplateStage
+ Language.Haskell.Tools.Refactor.RefactorBase: referenceBy :: ([String] -> Name -> Ann nt dom SrcTemplateStage) -> Name -> [Ann UImportDecl dom SrcTemplateStage] -> Ann nt dom SrcTemplateStage
- Language.Haskell.Tools.Refactor.RefactorBase: referenceName :: (HasImportInfo dom, HasModuleInfo dom) => Name -> LocalRefactor dom (Ann Name dom SrcTemplateStage)
+ Language.Haskell.Tools.Refactor.RefactorBase: referenceName :: (HasImportInfo dom, HasModuleInfo dom) => Name -> LocalRefactor dom (Ann UName dom SrcTemplateStage)
- Language.Haskell.Tools.Refactor.RefactorBase: referenceOperator :: (HasImportInfo dom, HasModuleInfo dom) => Name -> LocalRefactor dom (Ann Operator dom SrcTemplateStage)
+ Language.Haskell.Tools.Refactor.RefactorBase: referenceOperator :: (HasImportInfo dom, HasModuleInfo dom) => Name -> LocalRefactor dom (Ann UOperator dom SrcTemplateStage)
- Language.Haskell.Tools.Refactor.RefactorBase: type UnnamedModule dom = Ann Module dom SrcTemplateStage
+ Language.Haskell.Tools.Refactor.RefactorBase: type UnnamedModule dom = Ann UModule dom SrcTemplateStage
Files
- Language/Haskell/Tools/Refactor.hs +23/−187
- Language/Haskell/Tools/Refactor/BindingElem.hs +61/−0
- Language/Haskell/Tools/Refactor/DataToNewtype.hs +0/−20
- Language/Haskell/Tools/Refactor/DollarApp.hs +0/−54
- Language/Haskell/Tools/Refactor/ExtractBinding.hs +0/−161
- Language/Haskell/Tools/Refactor/GenerateExports.hs +0/−54
- Language/Haskell/Tools/Refactor/GenerateTypeSignature.hs +0/−140
- Language/Haskell/Tools/Refactor/GetModules.hs +18/−8
- Language/Haskell/Tools/Refactor/IfToGuards.hs +0/−34
- Language/Haskell/Tools/Refactor/ListOperations.hs +57/−0
- Language/Haskell/Tools/Refactor/OrganizeImports.hs +0/−100
- Language/Haskell/Tools/Refactor/Perform.hs +94/−0
- Language/Haskell/Tools/Refactor/Predefined/DataToNewtype.hs +15/−0
- Language/Haskell/Tools/Refactor/Predefined/DollarApp.hs +49/−0
- Language/Haskell/Tools/Refactor/Predefined/ExtractBinding.hs +163/−0
- Language/Haskell/Tools/Refactor/Predefined/GenerateExports.hs +44/−0
- Language/Haskell/Tools/Refactor/Predefined/GenerateTypeSignature.hs +134/−0
- Language/Haskell/Tools/Refactor/Predefined/IfToGuards.hs +33/−0
- Language/Haskell/Tools/Refactor/Predefined/OrganizeImports.hs +97/−0
- Language/Haskell/Tools/Refactor/Predefined/RenameDefinition.hs +121/−0
- Language/Haskell/Tools/Refactor/Prepare.hs +127/−0
- Language/Haskell/Tools/Refactor/RefactorBase.hs +20/−21
- Language/Haskell/Tools/Refactor/RenameDefinition.hs +0/−121
- haskell-tools-refactor.cabal +57/−52
- test/Main.hs +563/−0
Language/Haskell/Tools/Refactor.hs view
@@ -1,191 +1,27 @@-{-# LANGUAGE StandaloneDeriving - , DeriveGeneric - , LambdaCase - , ScopedTypeVariables - , BangPatterns - , MultiWayIf - , FlexibleContexts - , TypeFamilies - , TupleSections - , TemplateHaskell - , ViewPatterns - #-} --- | Defines common utilities for using refactorings. Provides an interface for both demo, command line and integrated tools. -module Language.Haskell.Tools.Refactor where - -import Language.Haskell.Tools.AST.FromGHC -import Language.Haskell.Tools.AST as AST -import Language.Haskell.Tools.AnnTrf.RangeToRangeTemplate -import Language.Haskell.Tools.AnnTrf.RangeTemplateToSourceTemplate -import Language.Haskell.Tools.AnnTrf.SourceTemplate -import Language.Haskell.Tools.AnnTrf.RangeTemplate -import Language.Haskell.Tools.AnnTrf.PlaceComments -import Language.Haskell.Tools.PrettyPrint.RoseTree -import Language.Haskell.Tools.PrettyPrint +-- | 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 + , HasRange(..), annListElems, annList, annJust, isAnnNothing, Domain + ) where -import GHC hiding (loadModule) -import Panic (handleGhcException) -import Outputable -import BasicTypes -import Bag -import Var -import SrcLoc -import Module as GHC -import FastString -import HscTypes -import GHC.Paths ( libdir ) -import CmdLineParser - -import Data.List -import Data.List.Split -import GHC.Generics hiding (moduleName) -import qualified Data.Map as Map -import Data.Maybe -import Data.Typeable -import Data.IORef -import Control.Monad -import Control.Monad.State -import Control.Monad.IO.Class -import Control.Reference -import Control.Exception -import System.Directory -import System.IO -import System.FilePath -import Data.Generics.Uniplate.Operations +-- Important: Haddock doesn't support the rename all exported modules and export them at once hack -import Language.Haskell.Tools.Refactor.OrganizeImports -import Language.Haskell.Tools.Refactor.GenerateTypeSignature -import Language.Haskell.Tools.Refactor.GenerateExports -import Language.Haskell.Tools.Refactor.RenameDefinition -import Language.Haskell.Tools.Refactor.ExtractBinding +import Language.Haskell.Tools.AST.SemaInfoClasses +import Language.Haskell.Tools.AST.Rewrite +import Language.Haskell.Tools.AST.References +import Language.Haskell.Tools.AST.Helpers import Language.Haskell.Tools.Refactor.RefactorBase -import Language.Haskell.Tools.Refactor.GetModules - -import Language.Haskell.TH.LanguageExtensions - -import DynFlags -import StringBuffer - -import Debug.Trace - - --- | Use the given source directories -useDirs :: [FilePath] -> Ghc () -useDirs workingDirs = do - dynflags <- getSessionDynFlags - setSessionDynFlags dynflags { importPaths = importPaths dynflags ++ workingDirs } - return () - --- | Set the given flags for the GHC session -useFlags :: [String] -> Ghc [String] -useFlags args = do - let lArgs = map (L noSrcSpan) args - dynflags <- getSessionDynFlags - let ((leftovers, errors, warnings), newDynFlags) = (runCmdLine $ processArgs flagsAll lArgs) dynflags - setSessionDynFlags newDynFlags - return $ map unLoc leftovers - --- | Initialize GHC flags to default values that support refactoring -initGhcFlags :: Ghc () -initGhcFlags = do - dflags <- getSessionDynFlags - setSessionDynFlags - $ flip gopt_set Opt_KeepRawTokenStream - $ flip gopt_set Opt_NoHsMain - $ dflags { importPaths = [] - , hscTarget = HscAsm -- needed for static pointers - , ghcLink = LinkInMemory - , ghcMode = CompManager - , packageFlags = ExposePackage "template-haskell" (PackageArg "template-haskell") (ModRenaming True []) : packageFlags dflags - } - return () - --- | Translates module name and working directory into the name of the file where the given module should be defined -toFileName :: String -> String -> FilePath -toFileName workingDir mod = normalise $ workingDir </> map (\case '.' -> pathSeparator; c -> c) mod ++ ".hs" - --- | Translates module name and working directory into the name of the file where the boot module should be defined -toBootFileName :: String -> String -> FilePath -toBootFileName workingDir mod = normalise $ workingDir </> map (\case '.' -> pathSeparator; c -> c) mod ++ ".hs-boot" - --- | Load the summary of a module given by the working directory and module name. -loadModule :: String -> String -> Ghc ModSummary -loadModule workingDir moduleName - = do initGhcFlags - useDirs [workingDir] - target <- guessTarget moduleName Nothing - setTargets [target] - load LoadAllTargets - getModSummary $ mkModuleName moduleName - --- | The final version of our AST, with type infromation added -type TypedModule = Ann AST.Module IdDom SrcTemplateStage - --- | Get the typed representation from a type-correct program. -parseTyped :: ModSummary -> Ghc TypedModule -parseTyped modSum = do - p <- parseModule modSum - tc <- typecheckModule p - let annots = pm_annotations p - srcBuffer = fromJust $ ms_hspp_buf $ pm_mod_summary p - rangeToSource srcBuffer . cutUpRanges . fixRanges . placeComments (getNormalComments $ snd annots) - <$> (addTypeInfos (typecheckedSource tc) - =<< (do parseTrf <- runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModule modSum (pm_parsed_source p) - runTrf (fst annots) (getPragmaComments $ snd annots) - $ trfModuleRename modSum parseTrf - (fromJust $ tm_renamed_source tc) - (pm_parsed_source p))) - --- | Executes a given command on the selected module and given other modules -performCommand :: (HasModuleInfo dom, DomGenerateExports dom, OrganizeImportsDomain dom, DomainRenameDefinition dom, ExtractBindingDomain dom, GenerateSignatureDomain dom) - => RefactorCommand -> ModuleDom dom -- ^ The module in which the refactoring is performed - -> [ModuleDom dom] -- ^ Other modules - -> Ghc (Either String [RefactorChange dom]) -performCommand rf mod mods = runRefactor mod mods $ selectCommand rf - where selectCommand NoRefactor = localRefactoring return - selectCommand OrganizeImports = localRefactoring organizeImports - selectCommand GenerateExports = localRefactoring generateExports - selectCommand (GenerateSignature sp) = localRefactoring $ generateTypeSignature' sp - selectCommand (RenameDefinition sp str) = renameDefinition' sp str - selectCommand (ExtractBinding sp str) = localRefactoring $ extractBinding' sp str - --- | A refactoring command -data RefactorCommand = NoRefactor - | OrganizeImports - | GenerateExports - | GenerateSignature RealSrcSpan - | RenameDefinition RealSrcSpan String - | ExtractBinding RealSrcSpan String - deriving Show - -readCommand :: String -> String -> RefactorCommand -readCommand fileName (splitOn " " -> refact:args) = analyzeCommand fileName refact args - -analyzeCommand :: String -> String -> [String] -> RefactorCommand -analyzeCommand _ "" _ = NoRefactor -analyzeCommand _ "CheckSource" _ = NoRefactor -analyzeCommand _ "OrganizeImports" _ = OrganizeImports -analyzeCommand _ "GenerateExports" _ = GenerateExports -analyzeCommand fileName "GenerateSignature" [sp] = GenerateSignature (readSrcSpan fileName sp) -analyzeCommand fileName "RenameDefinition" [sp, newName] = RenameDefinition (readSrcSpan fileName sp) newName -analyzeCommand fileName "ExtractBinding" [sp, newName] = ExtractBinding (readSrcSpan fileName sp) newName - -readSrcSpan :: String -> String -> RealSrcSpan -readSrcSpan fileName s = case splitOn "-" s of - [from,to] -> mkRealSrcSpan (readSrcLoc fileName from) (readSrcLoc fileName to) - -readSrcLoc :: String -> String -> RealSrcLoc -readSrcLoc fileName s = case splitOn ":" s of - [line,col] -> mkRealSrcLoc (mkFastString fileName) (read line) (read col) - -data IsBoot = NormalHs | IsHsBoot deriving (Eq, Ord, Show) +import Language.Haskell.Tools.AST.ElementTypes +import Language.Haskell.Tools.Refactor.Prepare +import Language.Haskell.Tools.Refactor.ListOperations +import Language.Haskell.Tools.Refactor.BindingElem -tryRefactor :: Refactoring IdDom -> String -> IO () -tryRefactor refact moduleName - = runGhc (Just libdir) $ do - initGhcFlags - useDirs ["."] - mod <- loadModule "." moduleName >>= parseTyped - res <- runRefactor (toFileName "." moduleName, mod) [] refact - case res of Right r -> liftIO $ mapM_ (putStrLn . prettyPrint . snd . fromContentChanged) r - Left err -> liftIO $ putStrLn err +import Language.Haskell.Tools.AST.Ann
+ Language/Haskell/Tools/Refactor/BindingElem.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE FlexibleContexts + , TypeFamilies + #-} +-- | Utilities for transformations that work on both top-level and local definitions +module Language.Haskell.Tools.Refactor.BindingElem where + +import Control.Reference +import Language.Haskell.Tools.AST.Rewrite +import Language.Haskell.Tools.AST.ElementTypes +import Language.Haskell.Tools.AST +import SrcLoc + +-- | A type class for handling definitions that can appear as both top-level and local definitions +class NamedElement d => BindingElem d where + + -- | Accesses a type signature definition in a local or top-level definition + sigBind :: Simple Partial (Ann d dom SrcTemplateStage) (TypeSignature dom) + + -- | Accesses a value or function definition in a local or top-level definition + valBind :: Simple Partial (Ann d dom SrcTemplateStage) (ValueBind dom) + + -- | Creates a new definition from a type signature + createTypeSig :: TypeSignature dom -> Ann d dom SrcTemplateStage + + -- | Creates a new definition from a value or function definition + createBinding :: ValueBind dom -> Ann d dom SrcTemplateStage + + -- | Checks if a given definition is a type signature + isTypeSig :: Ann d dom SrcTemplateStage -> Bool + + -- | Checks if a given definition is a function or value binding + isBinding :: Ann d dom SrcTemplateStage -> Bool + +instance BindingElem UDecl where + sigBind = declTypeSig + valBind = declValBind + createTypeSig = mkTypeSigDecl + createBinding = mkValueBinding + isTypeSig TypeSigDecl {} = True + isTypeSig _ = False + isBinding ValueBinding {} = True + isBinding _ = False + +instance BindingElem ULocalBind where + sigBind = localSig + valBind = localVal + createTypeSig = mkLocalTypeSig + createBinding = mkLocalValBind + isTypeSig LocalTypeSig {} = True + isTypeSig _ = False + isBinding LocalValBind {} = True + isBinding _ = False + +getValBindInList :: (BindingElem d) => RealSrcSpan -> AnnListG d dom SrcTemplateStage -> Maybe (ValueBind dom) +getValBindInList sp ls = case ls ^? valBindsInList & filtered (isInside sp) of + [] -> Nothing + [n] -> Just n + _ -> error "getValBindInList: Multiple nodes" + +valBindsInList :: BindingElem d => Simple Traversal (AnnListG d dom SrcTemplateStage) (ValueBind dom) +valBindsInList = annList & valBind
− Language/Haskell/Tools/Refactor/DataToNewtype.hs
@@ -1,20 +0,0 @@-module Language.Haskell.Tools.Refactor.DataToNewtype (dataToNewtype) where - -import Language.Haskell.Tools.AST -import Language.Haskell.Tools.AST.Gen -import Language.Haskell.Tools.Refactor.RefactorBase - -import Language.Haskell.Tools.Refactor (tryRefactor) - -tryItOut moduleName = tryRefactor (localRefactoring $ dataToNewtype) moduleName - -dataToNewtype :: Domain dom => LocalRefactoring dom -dataToNewtype (Ann mi mod@(Module { _modDecl = AnnList li ls })) - = return (Ann mi mod { _modDecl = AnnList li (map changeDeclaration ls) }) - -changeDeclaration :: Ann Decl dom SrcTemplateStage -> Ann Decl dom SrcTemplateStage -changeDeclaration (Ann a dd@(DataDecl {})) - | annLength (_declCons dd) == 1 - && annLength (_conDeclArgs (_element (_annListElems (_declCons dd) !! 0))) == 1 - = Ann a dd{ _declNewtype = mkNewtypeKeyword } -changeDeclaration decl = decl
− Language/Haskell/Tools/Refactor/DollarApp.hs
@@ -1,54 +0,0 @@-{-# LANGUAGE ViewPatterns, FlexibleContexts, ConstraintKinds #-} -module Language.Haskell.Tools.Refactor.DollarApp (dollarApp) where - -import Language.Haskell.Tools.AST -import Language.Haskell.Tools.AST.Gen -import Language.Haskell.Tools.PrettyPrint -import Language.Haskell.Tools.Refactor -import Language.Haskell.Tools.Refactor.RefactorBase - -import SrcLoc (RealSrcSpan, SrcSpan) -import Unique (getUnique) -import Id (idName) -import PrelNames (dollarIdKey) -import PrelInfo (wiredInIds) -import BasicTypes (Fixity(..)) - -import Control.Monad.State -import Control.Reference hiding (element) -import Data.Generics.Uniplate.Data -import Debug.Trace - -tryItOut moduleName sp = tryRefactor (localRefactoring $ dollarApp (readSrcSpan (toFileName "." moduleName) sp)) moduleName - -type RefactMonad dom = StateT [SrcSpan] (LocalRefactor dom) -type DollarDomain dom = (HasImportInfo dom, HasModuleInfo dom, HasFixityInfo dom, HasNameInfo dom) - -dollarApp :: DollarDomain dom => RealSrcSpan -> LocalRefactoring dom -dollarApp sp = flip evalStateT [] . ((nodesContained sp !~ (\e -> get >>= replaceExpr e)) >=> (biplateRef !~ parenExpr)) - -replaceExpr :: DollarDomain dom => Ann Expr dom SrcTemplateStage -> [SrcSpan] -> RefactMonad dom (Ann Expr dom SrcTemplateStage) -replaceExpr expr@(e -> App fun (e -> Paren (e -> InfixApp _ op arg))) replacedRanges - | not (getRange arg `elem` replacedRanges) - , sema <- op ^. element&operatorName&semantics - , semanticsName sema /= Just dollarName - , case semanticsFixity sema of Just (Fixity _ p _) | p > 0 -> False; _ -> True - = return expr -replaceExpr (e -> App fun (e -> Paren arg)) _ = do modify $ (getRange arg :) - mkInfixApp fun <$> lift (referenceOperator dollarName) <*> pure arg -replaceExpr e _ = return e - -parenExpr :: Ann Expr dom SrcTemplateStage -> RefactMonad dom (Ann Expr dom SrcTemplateStage) -parenExpr e = (element&exprLhs !~ parenDollar True) =<< (element&exprRhs !~ parenDollar False $ e) - -parenDollar :: Bool -> Ann Expr dom SrcTemplateStage -> RefactMonad dom (Ann Expr dom SrcTemplateStage) -parenDollar lhs expr@(e -> InfixApp _ _ arg) - = do replacedRanges <- get - if getRange arg `elem` replacedRanges && (lhs || getRange expr `notElem` replacedRanges) - then return $ mkParen expr - else return expr -parenDollar _ e = return e - -e = (^. element) - -[dollarName] = map idName $ filter ((dollarIdKey==) . getUnique) wiredInIds
− Language/Haskell/Tools/Refactor/ExtractBinding.hs
@@ -1,161 +0,0 @@- -{-# LANGUAGE ViewPatterns - , ScopedTypeVariables - , RankNTypes - , FlexibleContexts - , TypeApplications - , ConstraintKinds - , TypeFamilies - #-} -module Language.Haskell.Tools.Refactor.ExtractBinding where - -import qualified GHC -import qualified Var as GHC -import qualified OccName as GHC hiding (varName) -import SrcLoc -import Unique - -import Data.Char -import Data.Maybe -import Data.Generics.Uniplate.Data -import Control.Reference hiding (element) -import Control.Monad.State -import Language.Haskell.Tools.AST -import Language.Haskell.Tools.AnnTrf.SourceTemplate -import Language.Haskell.Tools.AST.Gen -import Language.Haskell.Tools.Refactor.RefactorBase -import Language.Haskell.Tools.AnnTrf.SourceTemplateHelpers - -import Debug.Trace - -type Ann' e dom = Ann e dom SrcTemplateStage -type AnnMaybe' e dom = AnnMaybe e dom SrcTemplateStage - -type ExtractBindingDomain dom = ( Domain dom, HasNameInfo dom, HasDefiningInfo dom, HasScopeInfo dom ) - -extractBinding' :: ExtractBindingDomain dom => RealSrcSpan -> String -> LocalRefactoring dom -extractBinding' sp name mod - = if isValidBindingName name then extractBinding (nodesContaining sp) (nodesContaining sp) name mod - else refactError "The given name is not a valid for the extracted binding" - -extractBinding :: forall dom . ExtractBindingDomain dom => Simple Traversal (Ann' Module dom) (Ann' ValueBind dom) - -> Simple Traversal (Ann' ValueBind dom) (Ann' Expr dom) - -> String -> LocalRefactoring dom -extractBinding selectDecl selectExpr name mod - = let conflicting = any (isConflicting name) (mod ^? selectDecl & biplateRef :: [Ann' QualifiedName dom]) - exprRange = getRange $ head (mod ^? selectDecl & selectExpr & annotation & sourceInfo) - decl = last (mod ^? selectDecl) - declRange = getRange $ last (mod ^? selectDecl & annotation & sourceInfo) - 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&element !~ addLocalBinding declRange exprRange def $ res) False - Nothing -> refactError "There is no applicable expression to extract." - -isConflicting :: ExtractBindingDomain dom => String -> Ann' QualifiedName dom -> Bool -isConflicting name used - = semanticsDefining (used ^. semantics) - && (GHC.occNameString . GHC.getOccName <$> semanticsName (used ^. semantics)) == Just name - --- Replaces the selected expression with a call and generates the called binding. -extractThatBind :: ExtractBindingDomain dom => String -> Ann' Expr dom -> Ann' Expr dom -> StateT (Maybe (Ann' ValueBind dom)) (LocalRefactor dom) (Ann' Expr dom) -extractThatBind name cont e - = do ret <- get - if (isJust ret) then return e - else case (e ^. element) of - Paren {} | hasParameter -> element & exprInner !~ doExtract name cont $ e - | otherwise -> doExtract name cont (fromJust $ e ^? element & exprInner) - Var {} -> lift $ refactError "The selected expression is too simple to be extracted." - el | isParenLikeExpr el && hasParameter -> mkParen <$> doExtract name cont e - el -> doExtract name cont e - where hasParameter = not (null (getExternalBinds cont e)) - -addLocalBinding :: SrcSpan -> SrcSpan -> Ann' ValueBind dom -> ValueBind dom SrcTemplateStage -> State Bool (ValueBind dom SrcTemplateStage) -addLocalBinding declRange exprRange local bind - = do done <- get - if not done then do put True - return $ doAddBinding declRange exprRange local bind - else return bind - where - doAddBinding declRng _ local sb@(SimpleBind {}) = valBindLocals .- insertLocalBind declRng local $ sb - doAddBinding declRng (RealSrcSpan rng) local fb@(FunBind {}) - = funBindMatches & annList & filtered (isInside rng) & element & matchBinds .- insertLocalBind declRng local $ fb - -insertLocalBind :: SrcSpan -> Ann' ValueBind dom -> AnnMaybe' LocalBinds dom -> AnnMaybe' LocalBinds dom -insertLocalBind declRng toInsert locals - | isAnnNothing locals - , RealSrcSpan rng <- declRng = -- creates the new where clause indented 2 spaces from the declaration - mkLocalBinds (srcLocCol (realSrcSpanStart rng) + 2) [mkLocalValBind toInsert] - | otherwise = annJust & element & localBinds .- insertWhere (mkLocalValBind toInsert) (const True) isNothing $ locals - --- | All expressions that are bound stronger than function application. -isParenLikeExpr :: Expr dom st -> Bool -isParenLikeExpr (If {}) = True -isParenLikeExpr (Paren {}) = True -isParenLikeExpr (List {}) = True -isParenLikeExpr (ParArray {}) = True -isParenLikeExpr (LeftSection {}) = True -isParenLikeExpr (RightSection {}) = True -isParenLikeExpr (RecCon {}) = True -isParenLikeExpr (RecUpdate {}) = True -isParenLikeExpr (Enum {}) = True -isParenLikeExpr (ParArrayEnum {}) = True -isParenLikeExpr (ListComp {}) = True -isParenLikeExpr (ParArrayComp {}) = True -isParenLikeExpr (BracketExpr {}) = True -isParenLikeExpr (Splice {}) = True -isParenLikeExpr (QuasiQuoteExpr {}) = True -isParenLikeExpr _ = False - -doExtract :: ExtractBindingDomain dom => String -> Ann' Expr dom -> Ann' Expr dom -> StateT (Maybe (Ann' ValueBind dom)) (LocalRefactor dom) (Ann' Expr dom) -doExtract name cont e@((^. element) -> lam@(Lambda {})) - = do let params = getExternalBinds cont e - put (Just (generateBind name (map mkVarPat params ++ (lam ^? exprBindings&annList)) (fromJust $ lam ^? exprInner))) - return (generateCall name params) -doExtract name cont e - = do let params = getExternalBinds cont e - put (Just (generateBind name (map mkVarPat params) e)) - return (generateCall name params) - --- | Gets the values that have to be passed to the extracted definition -getExternalBinds :: ExtractBindingDomain dom => Ann' Expr dom -> Ann' Expr dom -> [Ann' Name dom] -getExternalBinds cont expr = map exprToName $ keepFirsts $ filter isApplicableName (expr ^? uniplateRef) - where isApplicableName name@(getExprNameInfo -> Just nm) = inScopeForOriginal nm && notInScopeForExtracted nm - isApplicableName _ = False - - getExprNameInfo :: ExtractBindingDomain dom => Ann' Expr dom -> Maybe GHC.Name - getExprNameInfo expr = semanticsName =<< (listToMaybe $ expr ^? element & (exprName&element&simpleName &+& exprOperator&element&operatorName) - & semantics) - - -- | Creates the parameter value to pass the name (operators are passed in parentheses) - exprToName :: Ann' Expr dom -> Ann' Name dom - exprToName e | Just n <- e ^? element & exprName = n - | Just op <- e ^? element & exprOperator & element & operatorName = mkParenName op - - notInScopeForExtracted :: GHC.Name -> Bool - notInScopeForExtracted n = notElem @[] n (semanticsScope (cont ^. semantics) ^? traversal & traversal) - - inScopeForOriginal :: GHC.Name -> Bool - inScopeForOriginal n = elem @[] n (semanticsScope (expr ^. semantics) ^? traversal & traversal) - - keepFirsts (e:rest) = e : keepFirsts (filter (/= e) rest) - keepFirsts [] = [] - -actualContainingExpr :: SourceInfo st => SrcSpan -> Simple Traversal (Ann ValueBind dom st) (Ann Expr dom st) -actualContainingExpr (RealSrcSpan rng) = element & accessRhs & element & accessExpr - where accessRhs :: SourceInfo st => Simple Traversal (ValueBind dom st) (Ann Rhs dom st) - accessRhs = valBindRhs &+& funBindMatches & annList & filtered (isInside rng) & element & matchRhs - accessExpr :: SourceInfo st => Simple Traversal (Rhs dom st) (Ann Expr dom st) - accessExpr = rhsExpr &+& rhsGuards & annList & filtered (isInside rng) & element & guardExpr - --- | Generates the expression that calls the local binding -generateCall :: String -> [Ann' Name dom] -> Ann' Expr dom -generateCall name args = foldl (\e a -> mkApp e (mkVar a)) (mkVar $ mkNormalName $ mkSimpleName name) args - --- | Generates the local binding for the selected expression -generateBind :: String -> [Ann' Pattern dom] -> Ann' Expr dom -> Ann' ValueBind dom -generateBind name [] e = mkSimpleBind (mkVarPat $ mkNormalName $ mkSimpleName name) (mkUnguardedRhs e) Nothing -generateBind name args e = mkFunctionBind [mkMatch (mkNormalMatchLhs (mkNormalName $ mkSimpleName name) args) (mkUnguardedRhs e) Nothing] - -isValidBindingName :: String -> Bool -isValidBindingName = nameValid Variable
− Language/Haskell/Tools/Refactor/GenerateExports.hs
@@ -1,54 +0,0 @@-{-# LANGUAGE TupleSections - , ConstraintKinds - , TypeFamilies - , FlexibleContexts - #-} -module Language.Haskell.Tools.Refactor.GenerateExports where - -import Control.Reference hiding (element) - -import qualified GHC - -import Data.Maybe - -import Language.Haskell.Tools.AST -import Language.Haskell.Tools.AnnTrf.SourceTemplate -import Language.Haskell.Tools.AST.Gen -import Language.Haskell.Tools.Refactor.RefactorBase - -type DomGenerateExports dom = (Domain dom, HasNameInfo dom) - --- | Creates an export list that imports standalone top-level definitions with all of their contained definitions -generateExports :: DomGenerateExports dom => LocalRefactoring dom -generateExports mod = return (element & modHead & annJust & element & mhExports & annMaybe .= Just (createExports (getTopLevels mod)) $ mod) - --- | Get all the top-level definitions with flags that mark if they can contain other top-level definitions --- (classes and data declarations). -getTopLevels :: DomGenerateExports dom => Ann Module dom SrcTemplateStage -> [(GHC.Name, Bool)] -getTopLevels mod = catMaybes $ map (\d -> fmap (,exportContainOthers d) (getTopLevelDeclName d)) (mod ^? element & modDecl & annList & element) - where exportContainOthers :: Decl dom SrcTemplateStage -> Bool - exportContainOthers (DataDecl {}) = True - exportContainOthers (ClassDecl {}) = True - exportContainOthers _ = False - --- | Get all the standalone top level definitions (their GHC unique names) in a module. --- You could also do getting all the names with a biplate reference and select the top-level ones, but this is more efficient. -getTopLevelDeclName :: DomGenerateExports dom => Decl dom SrcTemplateStage -> Maybe GHC.Name -getTopLevelDeclName (d @ TypeDecl {}) = semanticsName =<< listToMaybe (d ^? declHead & dhNames) -getTopLevelDeclName (d @ TypeFamilyDecl {}) = semanticsName =<< listToMaybe (d ^? declTypeFamily & element & tfHead & dhNames) -getTopLevelDeclName (d @ ClosedTypeFamilyDecl {}) = semanticsName =<< listToMaybe (d ^? declHead & dhNames) -getTopLevelDeclName (d @ DataDecl {}) = semanticsName =<< listToMaybe (d ^? declHead & dhNames) -getTopLevelDeclName (d @ GDataDecl {}) = semanticsName =<< listToMaybe (d ^? declHead & dhNames) -getTopLevelDeclName (d @ ClassDecl {}) = semanticsName =<< listToMaybe (d ^? declHead & dhNames) -getTopLevelDeclName (d @ PatternSynonymDecl {}) - = semanticsName =<< listToMaybe (d ^? declPatSyn & element & patLhs & element & (patName & element & simpleName &+& patSynOp & element & operatorName) & semantics) -getTopLevelDeclName (d @ ValueBinding {}) = semanticsName =<< listToMaybe (d ^? declValBind & bindingName) -getTopLevelDeclName (d @ ForeignImport {}) = semanticsName =<< listToMaybe (d ^? declName & element & simpleName & semantics) -getTopLevelDeclName _ = Nothing - --- | Create the export for a give name. -createExports :: DomGenerateExports dom => [(GHC.Name, Bool)] -> Ann ExportSpecList dom SrcTemplateStage -createExports elems = mkExportSpecList $ map (mkExportSpec . createExport) elems - where createExport (n, False) = mkIeSpec (mkUnqualName' (GHC.getName n)) Nothing - createExport (n, True) = mkIeSpec (mkUnqualName' (GHC.getName n)) (Just mkSubAll) -
− Language/Haskell/Tools/Refactor/GenerateTypeSignature.hs
@@ -1,140 +0,0 @@-{-# LANGUAGE ViewPatterns - , FlexibleContexts - , ScopedTypeVariables - , RankNTypes - , TypeApplications - , TypeFamilies - , ConstraintKinds - #-} -module Language.Haskell.Tools.Refactor.GenerateTypeSignature (generateTypeSignature, generateTypeSignature', GenerateSignatureDomain) where - -import GHC hiding (Module) -import Type as GHC -import TyCon as GHC -import OccName as GHC -import Outputable as GHC -import TysWiredIn as GHC -import Id as GHC - -import Data.List -import Data.Maybe -import Data.Data -import Data.Generics.Uniplate.Data -import Control.Monad -import Control.Monad.State -import Control.Reference hiding (element) -import Language.Haskell.Tools.AnnTrf.SourceTemplate -import Language.Haskell.Tools.AnnTrf.SourceTemplateHelpers -import Language.Haskell.Tools.AST.Gen -import Language.Haskell.Tools.AST as AST -import Language.Haskell.Tools.Refactor.RefactorBase - -type Ann' e dom = Ann e dom SrcTemplateStage -type AnnList' e dom = AnnList e dom SrcTemplateStage -type GenerateSignatureDomain dom = ( HasModuleInfo dom, HasIdInfo dom, HasImportInfo dom ) - -generateTypeSignature' :: GenerateSignatureDomain dom => RealSrcSpan -> LocalRefactoring dom -generateTypeSignature' sp = generateTypeSignature (nodesContaining sp) (nodesContaining sp) (getValBindInList sp) - --- | Perform the refactoring on either local or top-level definition -generateTypeSignature :: GenerateSignatureDomain dom => Simple Traversal (Ann' Module dom) (AnnList' Decl dom) - -- ^ Access for a top-level definition if it is the selected definition - -> Simple Traversal (Ann' Module dom) (AnnList' LocalBind dom) - -- ^ Access for a definition list if it contains the selected definition - -> (forall d . (Show (d dom SrcTemplateStage), Data (d dom SrcTemplateStage), Typeable d, BindingElem d) - => AnnList' d dom -> Maybe (Ann' ValueBind dom)) - -- ^ Selector for either local or top-level declaration in the definition list - -> LocalRefactoring dom -generateTypeSignature topLevelRef localRef vbAccess - = flip evalStateT False . - (topLevelRef !~ genTypeSig vbAccess - <=< localRef !~ genTypeSig vbAccess) - -genTypeSig :: (GenerateSignatureDomain dom, BindingElem d) => (AnnList' d dom -> Maybe (Ann' ValueBind dom)) - -> AnnList' d dom -> StateT Bool (LocalRefactor dom) (AnnList' d dom) -genTypeSig vbAccess ls - | Just vb <- vbAccess ls - , not (typeSignatureAlreadyExist ls vb) - = do let id = getBindingName vb - isTheBind (Just ((^.element) -> decl)) - = isBinding decl && map semanticsId (decl ^? bindName) == map semanticsId (vb ^? bindingName) - isTheBind _ = False - - alreadyGenerated <- get - if alreadyGenerated - then return ls - else do put True - typeSig <- lift $ generateTSFor (getName id) (idType id) - return $ insertWhere (wrapperAnn $ createTypeSig typeSig) (const True) isTheBind ls - | otherwise = return ls - - -generateTSFor :: GenerateSignatureDomain dom => GHC.Name -> GHC.Type -> LocalRefactor dom (Ann' TypeSignature dom) -generateTSFor n t = mkTypeSignature (mkUnqualName' n) <$> generateTypeFor (-1) (dropForAlls t) - --- | Generates the source-level type for a GHC internal type -generateTypeFor :: GenerateSignatureDomain dom => Int -> GHC.Type -> LocalRefactor dom (Ann' AST.Type dom) -generateTypeFor prec t - -- context - | (break (not . isPredTy) -> (preds, other), rt) <- splitFunTys t - , not (null preds) - = do ctx <- case preds of [pred] -> mkContextOne <$> generateAssertionFor pred - _ -> mkContextMulti <$> mapM generateAssertionFor preds - wrapParen 0 <$> (mkTyCtx ctx <$> generateTypeFor 0 (mkFunTys other rt)) - -- function - | Just (at, rt) <- splitFunTy_maybe t - = wrapParen 0 <$> (mkTyFun <$> generateTypeFor 10 at <*> generateTypeFor 0 rt) - -- type operator (we don't know the precedences, so always use parentheses) - | (op, [at,rt]) <- splitAppTys t - , Just tc <- tyConAppTyCon_maybe op - , isSymOcc (getOccName (getName tc)) - = wrapParen 0 <$> (mkTyInfix <$> generateTypeFor 10 at <*> referenceOperator (idName $ getTCId tc) <*> generateTypeFor 10 rt) - -- tuple types - | Just (tc, tas) <- splitTyConApp_maybe t - , isTupleTyCon tc - = mkTyTuple <$> mapM (generateTypeFor (-1)) tas - -- string type - | Just (ls, [et]) <- splitTyConApp_maybe t - , Just ch <- tyConAppTyCon_maybe et - , listTyCon == ls - , charTyCon == ch - = return $ mkTyVar (mkNormalName $ mkSimpleName "String") - -- list types - | Just (tc, [et]) <- splitTyConApp_maybe t - , listTyCon == tc - = mkTyList <$> generateTypeFor (-1) et - -- type application - | Just (tf, ta) <- splitAppTy_maybe t - = wrapParen 10 <$> (mkTyApp <$> generateTypeFor 10 tf <*> generateTypeFor 11 ta) - -- type constructor - | Just tc <- tyConAppTyCon_maybe t - = mkTyVar <$> referenceName (idName $ getTCId tc) - -- type variable - | Just tv <- getTyVar_maybe t - = mkTyVar <$> referenceName (idName tv) - -- forall type - | (tvs@(_:_), t') <- splitForAllTys t - = wrapParen (-1) <$> (mkTyForall (map (mkTypeVar' . getName) tvs) <$> generateTypeFor 0 t') - | otherwise = error ("Cannot represent type: " ++ showSDocUnsafe (ppr t)) - where wrapParen :: Int -> Ann' AST.Type dom -> Ann' AST.Type dom - wrapParen prec' node = if prec' < prec then mkTyParen node else node - - getTCId :: GHC.TyCon -> GHC.Id - getTCId tc = GHC.mkVanillaGlobal (GHC.tyConName tc) (tyConKind tc) - - generateAssertionFor :: GenerateSignatureDomain dom => GHC.Type -> LocalRefactor dom (Ann' AST.Assertion dom) - generateAssertionFor t - | Just (tc, types) <- splitTyConApp_maybe t - = mkClassAssert <$> referenceName (idName $ getTCId tc) <*> mapM (generateTypeFor 0) types - -- TODO: infix things - --- | Check whether the definition already has a type signature -typeSignatureAlreadyExist :: (GenerateSignatureDomain dom, BindingElem d) => AnnList' d dom -> Ann' ValueBind dom -> Bool -typeSignatureAlreadyExist ls vb = - getBindingName vb `elem` (map semanticsId $ concatMap (^? bindName) (filter isTypeSig $ ls ^? annList&element)) - -getBindingName :: GenerateSignatureDomain dom => Ann' ValueBind dom -> GHC.Id -getBindingName vb = case nub $ map semanticsId $ vb ^? bindingName of - [n] -> n - [] -> error "Trying to generate a signature for a binding with no name" - _ -> error "Trying to generate a signature for a binding with multiple names"
Language/Haskell/Tools/Refactor/GetModules.hs view
@@ -11,22 +11,27 @@ -- | Get modules of the project with the indicated root directory. -- If there is a cabal file, it uses that, otherwise it just scans the directory recursively for haskell sourcefiles. -getModules :: FilePath -> IO [String] +getModules :: FilePath -> IO [([FilePath], [String])] getModules root = do files <- listDirectory root case find (\p -> takeExtension p == ".cabal") files of Just cabalFile -> modulesFromCabalFile (root </> cabalFile) - Nothing -> modulesFromDirectory root root + Nothing -> do mods <- modulesFromDirectory root root + return [([root], mods)] -modulesFromCabalFile :: FilePath -> IO [String] +modulesFromCabalFile :: FilePath -> IO [([FilePath], [String])] -- now adding all conditional entries, regardless of flags modulesFromCabalFile cabal = getModules . flattenPackageDescription <$> readPackageDescription silent cabal - where getModules pkg = map (concat . intersperse "." . components) - $ maybe [] libModules (library pkg) - ++ concatMap exeModules (executables pkg) - ++ concatMap testModules (testSuites pkg) - ++ concatMap benchmarkModules (benchmarks pkg) + where getModules :: PackageDescription -> [([FilePath], [String])] + getModules pkg = map (\(bi, mods) -> ( map (normalise . (takeDirectory cabal </>)) $ hsSourceDirs bi + , map (concat . intersperse "." . components) mods) ) + $ maybe [] ((:[]) . libRecord) (library pkg) ++ map exeRecord (executables pkg) + ++ map testRecord (testSuites pkg) ++ map benchRecord (benchmarks pkg) + libRecord lib = (libBuildInfo lib, libModules lib) + exeRecord exe = (buildInfo exe, exeModules exe) + testRecord test = (testBuildInfo test, testModules test) + benchRecord bench = (benchmarkBuildInfo bench, benchmarkModules bench) modulesFromDirectory :: FilePath -> FilePath -> IO [String] -- now recognizing only .hs files @@ -38,3 +43,8 @@ else if takeExtension path == ".hs" then return [concat $ intersperse "." $ splitDirectories $ dropExtension $ makeRelative root path] else return [] + +srcDirFromRoot :: FilePath -> String -> FilePath +srcDirFromRoot fileName "" = fileName +srcDirFromRoot fileName moduleName + = srcDirFromRoot (takeDirectory fileName) (dropWhile (/= '.') $ dropWhile (== '.') moduleName)
− Language/Haskell/Tools/Refactor/IfToGuards.hs
@@ -1,34 +0,0 @@-{-# LANGUAGE RankNTypes, FlexibleContexts, ViewPatterns #-} -module Language.Haskell.Tools.Refactor.IfToGuards (ifToGuards) where - -import Language.Haskell.Tools.AST -import Language.Haskell.Tools.AST.Gen -import Language.Haskell.Tools.Refactor.RefactorBase - -import Control.Reference hiding (element) -import SrcLoc -import Data.Generics.Uniplate.Data - -import Language.Haskell.Tools.Refactor - -tryItOut moduleName sp = tryRefactor (localRefactoring $ ifToGuards (readSrcSpan (toFileName "." moduleName) sp)) moduleName - -ifToGuards :: Domain dom => RealSrcSpan -> LocalRefactoring dom -ifToGuards sp = return . (nodesContaining sp .- ifToGuards') - -ifToGuards' :: Ann ValueBind dom SrcTemplateStage -> Ann ValueBind dom SrcTemplateStage -ifToGuards' (e -> SimpleBind (e -> VarPat name) (e -> UnguardedRhs (e -> If pred thenE elseE)) locals) - = mkFunctionBind [mkMatch (mkNormalMatchLhs name []) (createSimpleIfRhss pred thenE elseE) (locals ^. annMaybe) ] -ifToGuards' fbs@(e -> FunBind _) - = element&funBindMatches&annList&element&matchRhs .- trfRhs $ fbs - where trfRhs :: Ann Rhs dom SrcTemplateStage -> Ann Rhs dom SrcTemplateStage - trfRhs (e -> UnguardedRhs (e -> If pred thenE elseE)) = createSimpleIfRhss pred thenE elseE - trfRhs e = e -- don't transform already guarded right-hand sides to avoid multiple evaluation of the same condition - -e = (^. element) - -createSimpleIfRhss :: Ann Expr dom SrcTemplateStage -> Ann Expr dom SrcTemplateStage -> Ann Expr dom SrcTemplateStage -> Ann Rhs dom SrcTemplateStage -createSimpleIfRhss pred thenE elseE = mkGuardedRhss [ mkGuardedRhs [mkGuardCheck pred] thenE - , mkGuardedRhs [mkGuardCheck (mkVar (mkName "otherwise"))] elseE - ] -
+ Language/Haskell/Tools/Refactor/ListOperations.hs view
@@ -0,0 +1,57 @@+module Language.Haskell.Tools.Refactor.ListOperations where + +import SrcLoc +import Data.String +import Data.List +import Control.Reference +import Data.Function (on) +import Language.Haskell.Tools.AST +import Language.Haskell.Tools.AST.Rewrite +import Language.Haskell.Tools.Transform + +filterList :: (Ann e dom SrcTemplateStage -> Bool) -> AnnListG e dom SrcTemplateStage -> AnnListG e dom SrcTemplateStage +-- QUESTION: is it OK? No problem from losing separators? +filterList pred ls = replaceList (filter pred (ls ^. annListElems)) ls + +-- | Replaces the list with a new one with the given elements, keeping the most common separator as the new one. +replaceList :: [Ann e dom SrcTemplateStage] -> AnnListG e dom SrcTemplateStage -> AnnListG e dom SrcTemplateStage +replaceList elems (AnnListG (NodeInfo sema src) _) + = AnnListG (NodeInfo sema (listSep mostCommonSeparator)) elems + where mostCommonSeparator + = case group $ sort (src ^. srcTmpSeparators) of + [] -> src ^. srcTmpDefaultSeparator + nonempty@(_:_) -> head $ maximumBy (compare `on` length) nonempty + +-- | Inserts the element in the places where the two positioning functions (one checks the element before, one the element after) +-- allows the placement. +insertWhere :: Ann e dom SrcTemplateStage -> (Maybe (Ann e dom SrcTemplateStage) -> Bool) + -> (Maybe (Ann e dom SrcTemplateStage) -> Bool) -> AnnListG e dom SrcTemplateStage + -> AnnListG e dom SrcTemplateStage +insertWhere e before after al + = let index = insertIndex before after (al ^? annList) + in case index of + Nothing -> al + Just ind -> annListElems .- insertAt ind e + $ (if isEmptyAnnList then id else annListAnnot&sourceInfo .- addDefaultSeparator ind) + $ al + where addDefaultSeparator i al = srcTmpSeparators .- insertAt i (al ^. srcTmpDefaultSeparator) $ al + insertAt n e ls = let (bef,aft) = splitAt n ls in bef ++ [e] ++ aft + isEmptyAnnList = (null :: [x] -> Bool) $ (al ^? annList) + +-- | Checks where the element will be inserted given the two positioning functions. +insertIndex :: (Maybe (Ann e dom SrcTemplateStage) -> Bool) -> (Maybe (Ann e dom SrcTemplateStage) -> Bool) -> [Ann e dom SrcTemplateStage] -> Maybe Int +insertIndex before after [] + | before Nothing && after Nothing = Just 0 + | otherwise = Nothing +insertIndex before after list@(first:_) + | before Nothing && after (Just first) = Just 0 + | otherwise = (+1) <$> insertIndex' before after list + where insertIndex' before after (curr:rest@(next:_)) + | before (Just curr) && after (Just next) = Just 0 + | otherwise = (+1) <$> insertIndex' before after rest + insertIndex' before after (curr:[]) + | before (Just curr) && after Nothing = Just 0 + | otherwise = Nothing + +replaceWithJust :: Ann e dom SrcTemplateStage -> AnnMaybe e dom -> AnnMaybe e dom +replaceWithJust e (AnnMaybeG temp _) = AnnMaybeG temp (Just e)
− Language/Haskell/Tools/Refactor/OrganizeImports.hs
@@ -1,100 +0,0 @@-{-# LANGUAGE LambdaCase - , ScopedTypeVariables - , FlexibleContexts - , TypeFamilies - , ConstraintKinds - #-} -module Language.Haskell.Tools.Refactor.OrganizeImports (organizeImports, OrganizeImportsDomain) where - -import SrcLoc -import Name hiding (Name) -import GHC (Ghc, GhcMonad, lookupGlobalName, TyThing(..), moduleNameString, moduleName) -import qualified GHC -import TyCon -import ConLike -import DataCon -import Outputable (Outputable(..), ppr, showSDocUnsafe) - -import Control.Reference hiding (element) -import Control.Monad -import Control.Monad.IO.Class -import Data.Function hiding ((&)) -import Data.String -import Data.Maybe -import Data.Data -import Data.List -import Data.Generics.Uniplate.Data -import Language.Haskell.Tools.AST as AST -import Language.Haskell.Tools.AST.FromGHC -import Language.Haskell.Tools.AnnTrf.SourceTemplate -import Language.Haskell.Tools.AnnTrf.SourceTemplateHelpers -import Language.Haskell.Tools.PrettyPrint -import Language.Haskell.Tools.AST.Gen -import Language.Haskell.Tools.Refactor.RefactorBase -import Debug.Trace - -type OrganizeImportsDomain dom = ( Domain dom, HasNameInfo dom, HasImportInfo dom ) - -organizeImports :: forall dom . OrganizeImportsDomain dom => LocalRefactoring dom -organizeImports mod - = element&modImports&annListElems !~ narrowImports usedNames . sortImports $ mod - where usedNames = map getName $ catMaybes - $ map (semanticsName . (^. (annotation&semanticInfo))) - $ (universeBi (mod ^. element&modHead) ++ universeBi (mod ^. element&modDecl) :: [Ann QualifiedName dom SrcTemplateStage]) - --- | Sorts the imports in alphabetical order -sortImports :: [Ann ImportDecl dom SrcTemplateStage] -> [Ann ImportDecl dom SrcTemplateStage] -sortImports = sortBy (compare `on` (^. element&importModule&element&AST.moduleNameString)) - --- | Modify an import to only import names that are used. -narrowImports :: forall dom . OrganizeImportsDomain dom - => [GHC.Name] -> [Ann ImportDecl dom SrcTemplateStage] -> LocalRefactor dom [Ann ImportDecl dom SrcTemplateStage] -narrowImports usedNames imps = foldM (narrowOneImport usedNames) imps imps - where narrowOneImport :: [GHC.Name] -> [Ann ImportDecl dom SrcTemplateStage] -> Ann ImportDecl dom SrcTemplateStage -> LocalRefactor dom [Ann ImportDecl dom SrcTemplateStage] - narrowOneImport names all one = - (\case Just x -> map (\e -> if e == one then x else e) all - Nothing -> delete one all) <$> narrowImport names (map (semanticsImportedModule . (^. semantics)) all) one - -narrowImport :: OrganizeImportsDomain dom - => [GHC.Name] -> [GHC.Module] -> Ann ImportDecl dom SrcTemplateStage - -> LocalRefactor dom (Maybe (Ann ImportDecl dom SrcTemplateStage)) -narrowImport usedNames otherModules imp - | importIsExact (imp ^. element) - = Just <$> (element&importSpec&annJust&element&importSpecList !~ narrowImportSpecs usedNames $ imp) - | otherwise - = if null actuallyImported - then if length (filter (== importedMod) otherModules) > 1 - then pure Nothing - else Just <$> (element&importSpec !- replaceWithJust (mkImportSpecList []) $ imp) - else pure (Just imp) - where actuallyImported = semanticsImported (imp ^. semantics) `intersect` usedNames - importedMod = semanticsImportedModule $ imp ^. semantics - --- | Narrows the import specification (explicitely imported elements) -narrowImportSpecs :: forall dom . OrganizeImportsDomain dom - => [GHC.Name] -> AnnList IESpec dom SrcTemplateStage -> LocalRefactor dom (AnnList IESpec dom SrcTemplateStage) -narrowImportSpecs usedNames - = (annList&element !~ narrowSpecSubspec usedNames) - >=> return . filterList isNeededSpec - where narrowSpecSubspec :: [GHC.Name] -> IESpec dom SrcTemplateStage -> LocalRefactor dom (IESpec dom SrcTemplateStage) - narrowSpecSubspec usedNames spec - = do let Just specName = semanticsName =<< (spec ^? ieName&element&simpleName&annotation&semanticInfo) - Just tt <- GHC.lookupName (getName specName) - let subspecsInScope = case tt of ATyCon tc | not (isClassTyCon tc) - -> map getName (tyConDataCons tc) `intersect` usedNames - _ -> usedNames - ieSubspec&annJust !- narrowImportSubspecs subspecsInScope $ spec - - isNeededSpec :: Ann IESpec dom SrcTemplateStage -> Bool - isNeededSpec ie = - -- if the name is used, it is needed - fmap getName (semanticsName =<< (ie ^? element&ieName&element&simpleName&annotation&semanticInfo)) `elem` map Just usedNames - -- if the name is not used, but some of its constructors are used, it is needed - || ((ie ^? element&ieSubspec&annJust&element&essList&annList) /= []) - || (case ie ^? element&ieSubspec&annJust&element of Just SubSpecAll -> True; _ -> False) - -narrowImportSubspecs :: OrganizeImportsDomain dom => [GHC.Name] -> Ann SubSpec dom SrcTemplateStage -> Ann SubSpec dom SrcTemplateStage -narrowImportSubspecs [] (Ann _ SubSpecAll) = mkSubList [] -narrowImportSubspecs _ ss@(Ann _ SubSpecAll) = ss -narrowImportSubspecs usedNames ss@(Ann _ (SubSpecList _)) - = element&essList .- filterList (\n -> fmap getName (semanticsName =<< (n ^? element&simpleName&annotation&semanticInfo)) `elem` map Just usedNames) $ ss
+ Language/Haskell/Tools/Refactor/Perform.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE StandaloneDeriving + , DeriveGeneric + , LambdaCase + , ScopedTypeVariables + , BangPatterns + , MultiWayIf + , FlexibleContexts + , TypeFamilies + , TupleSections + , TemplateHaskell + , ViewPatterns + #-} +-- | Defines common utilities for using refactorings. Provides an interface for both demo, command line and integrated tools. +module Language.Haskell.Tools.Refactor.Perform where + +import Language.Haskell.Tools.AST.FromGHC +import Language.Haskell.Tools.AST as AST +import Language.Haskell.Tools.Transform +import Language.Haskell.Tools.PrettyPrint + +import Data.List +import Data.List.Split +import GHC.Generics hiding (moduleName) +import qualified Data.Map as Map +import Data.Maybe +import Data.Typeable +import Data.IORef +import Control.Monad +import Control.Monad.State +import Control.Monad.IO.Class +import Control.Reference +import Control.Exception +import System.Directory +import System.IO +import System.FilePath +import Data.Generics.Uniplate.Operations + +import Language.Haskell.Tools.Refactor.Predefined.OrganizeImports +import Language.Haskell.Tools.Refactor.Predefined.GenerateTypeSignature +import Language.Haskell.Tools.Refactor.Predefined.GenerateExports +import Language.Haskell.Tools.Refactor.Predefined.RenameDefinition +import Language.Haskell.Tools.Refactor.Predefined.ExtractBinding +import Language.Haskell.Tools.Refactor.RefactorBase +import Language.Haskell.Tools.Refactor.GetModules +import Language.Haskell.Tools.Refactor.Prepare + +import Language.Haskell.TH.LanguageExtensions +import GHC +import SrcLoc + + +import Debug.Trace + + +-- | Executes a given command on the selected module and given other modules +performCommand :: (HasModuleInfo dom, DomGenerateExports dom, OrganizeImportsDomain dom, DomainRenameDefinition dom, ExtractBindingDomain dom, GenerateSignatureDomain dom) + => RefactorCommand -> ModuleDom dom -- ^ The module in which the refactoring is performed + -> [ModuleDom dom] -- ^ Other modules + -> Ghc (Either String [RefactorChange dom]) +performCommand rf mod mods = runRefactor mod mods $ selectCommand rf + where selectCommand NoRefactor = localRefactoring return + selectCommand OrganizeImports = localRefactoring organizeImports + selectCommand GenerateExports = localRefactoring generateExports + selectCommand (GenerateSignature sp) = localRefactoring $ generateTypeSignature' (correctSp mod sp) + selectCommand (RenameDefinition sp str) = renameDefinition' (correctSp mod sp) str + selectCommand (ExtractBinding sp str) = localRefactoring $ extractBinding' (correctSp mod sp) str + + correctSp mod sp = mkRealSrcSpan (updateSrcFile fileName $ realSrcSpanStart sp) + (updateSrcFile fileName $ realSrcSpanEnd sp) + fileName = case srcSpanStart $ getRange (snd mod) of RealSrcLoc loc -> srcLocFile loc + updateSrcFile fn loc = mkRealSrcLoc fn (srcLocLine loc) (srcLocCol loc) + +-- | A refactoring command +data RefactorCommand = NoRefactor + | OrganizeImports + | GenerateExports + | GenerateSignature RealSrcSpan + | RenameDefinition RealSrcSpan String + | ExtractBinding RealSrcSpan String + deriving Show + +readCommand :: String -> String -> RefactorCommand +readCommand fileName (splitOn " " -> refact:args) = analyzeCommand fileName refact args + +analyzeCommand :: String -> String -> [String] -> RefactorCommand +analyzeCommand _ "" _ = NoRefactor +analyzeCommand _ "CheckSource" _ = NoRefactor +analyzeCommand _ "OrganizeImports" _ = OrganizeImports +analyzeCommand _ "GenerateExports" _ = GenerateExports +analyzeCommand fileName "GenerateSignature" [sp] = GenerateSignature (readSrcSpan fileName sp) +analyzeCommand fileName "RenameDefinition" [sp, newName] = RenameDefinition (readSrcSpan fileName sp) newName +analyzeCommand fileName "ExtractBinding" [sp, newName] = ExtractBinding (readSrcSpan fileName sp) newName +analyzeCommand _ ref _ = error $ "Unknown command: " ++ ref +
+ Language/Haskell/Tools/Refactor/Predefined/DataToNewtype.hs view
@@ -0,0 +1,15 @@+module Language.Haskell.Tools.Refactor.Predefined.DataToNewtype (dataToNewtype) where + +import Control.Reference + +import Language.Haskell.Tools.Refactor + +tryItOut moduleName = tryRefactor (localRefactoring $ dataToNewtype) moduleName + +dataToNewtype :: Domain dom => LocalRefactoring dom +dataToNewtype = return . (modDecl & annList .- changeDeclaration) + +changeDeclaration :: Decl dom -> Decl dom +changeDeclaration dd@(DataDecl DataKeyword ctx declHead (AnnList [ConDecl name (AnnList [arg])]) derivs) + = declNewtype .= mkNewtypeKeyword $ dd +changeDeclaration decl = decl
+ Language/Haskell/Tools/Refactor/Predefined/DollarApp.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE ViewPatterns, FlexibleContexts, ConstraintKinds #-} +module Language.Haskell.Tools.Refactor.Predefined.DollarApp (dollarApp, DollarDomain) where + +import Language.Haskell.Tools.Refactor + +import SrcLoc (RealSrcSpan, SrcSpan) +import Unique (getUnique) +import Id (idName) +import PrelNames (dollarIdKey) +import PrelInfo (wiredInIds) +import BasicTypes (Fixity(..)) + +import Control.Monad.State +import Control.Reference hiding (element) +import Data.Generics.Uniplate.Data +import Debug.Trace + +tryItOut moduleName sp + = tryRefactor (localRefactoring $ dollarApp (readSrcSpan (toFileName "." moduleName) sp)) moduleName + +type DollarMonad dom = StateT [SrcSpan] (LocalRefactor dom) +type DollarDomain dom = (HasImportInfo dom, HasModuleInfo dom, HasFixityInfo dom, HasNameInfo dom) + +dollarApp :: DollarDomain dom => RealSrcSpan -> LocalRefactoring dom +dollarApp sp = flip evalStateT [] . ((nodesContained sp !~ (\e -> get >>= replaceExpr e)) + >=> (biplateRef !~ parenExpr)) + +replaceExpr :: DollarDomain dom => Expr dom -> [SrcSpan] -> DollarMonad dom (Expr dom) +replaceExpr expr@(App fun (Paren (InfixApp _ op arg))) replacedRanges + | not (getRange arg `elem` replacedRanges) + , semanticsName (op ^. operatorName) /= Just dollarName + , case semanticsFixity (op ^. operatorName) of Just (Fixity _ p _) | p > 0 -> False; _ -> True + = return expr +replaceExpr (App fun (Paren arg)) _ = do modify $ (getRange arg :) + mkInfixApp fun <$> lift (referenceOperator dollarName) <*> pure arg +replaceExpr e _ = return e + +parenExpr :: Expr dom -> DollarMonad dom (Expr dom) +parenExpr e = (exprLhs !~ parenDollar True) =<< (exprRhs !~ parenDollar False $ e) + +parenDollar :: Bool -> Expr dom -> DollarMonad dom (Expr dom) +parenDollar lhs expr@(InfixApp _ _ arg) + = do replacedRanges <- get + if getRange arg `elem` replacedRanges && (lhs || getRange expr `notElem` replacedRanges) + then return $ mkParen expr + else return expr +parenDollar _ e = return e + +[dollarName] = map idName $ filter ((dollarIdKey==) . getUnique) wiredInIds
+ Language/Haskell/Tools/Refactor/Predefined/ExtractBinding.hs view
@@ -0,0 +1,163 @@+ +{-# LANGUAGE ViewPatterns + , ScopedTypeVariables + , RankNTypes + , FlexibleContexts + , TypeApplications + , ConstraintKinds + , TypeFamilies + #-} +module Language.Haskell.Tools.Refactor.Predefined.ExtractBinding (extractBinding', ExtractBindingDomain) where + +import qualified GHC +import qualified Var as GHC +import qualified OccName as GHC hiding (varName) +import SrcLoc +import Unique + +import Data.Char +import Data.Maybe +import Data.Generics.Uniplate.Data +import Control.Reference hiding (element) +import Control.Monad.State + +import Language.Haskell.Tools.Refactor + +type ExtractBindingDomain dom = ( HasNameInfo dom, HasDefiningInfo dom, HasScopeInfo dom ) + +extractBinding' :: ExtractBindingDomain dom => RealSrcSpan -> String -> LocalRefactoring dom +extractBinding' sp name mod + = if isValidBindingName name then extractBinding (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) + -> Simple Traversal (ValueBind dom) (Expr dom) + -> String -> LocalRefactoring dom +extractBinding selectDecl selectExpr name mod + = let conflicting = any (isConflicting name) (mod ^? selectDecl & biplateRef :: [QualifiedName dom]) + exprRange = getRange $ head (mod ^? selectDecl & selectExpr) + decl = last (mod ^? selectDecl) + declRange = getRange $ 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 declRange exprRange def $ res) False + Nothing -> 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 +isConflicting name used + = semanticsDefining used + && (GHC.occNameString . GHC.getOccName <$> semanticsName used) == Just name + +-- 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 + if (isJust ret) then return e + else case e of + Paren {} | hasParameter -> exprInner !~ doExtract name cont $ e + | otherwise -> doExtract name cont (fromJust $ e ^? exprInner) + Var {} -> lift $ refactError "The selected expression is too simple to be extracted." + el | isParenLikeExpr el && hasParameter -> mkParen <$> doExtract name cont e + el -> doExtract name cont e + where hasParameter = not (null (getExternalBinds cont e)) + +-- | Adds a local binding to the +addLocalBinding :: SrcSpan -> SrcSpan -> ValueBind dom -> ValueBind dom -> State Bool (ValueBind dom) +-- this uses the state monad to only add the local binding to the first selected element +addLocalBinding declRange exprRange local bind + = do done <- get + if not done then do put True + return $ doAddBinding declRange exprRange local bind + else return bind + where + doAddBinding declRng _ local sb@(SimpleBind {}) = valBindLocals .- insertLocalBind declRng local $ sb + doAddBinding declRng (RealSrcSpan rng) local fb@(FunctionBind {}) + = funBindMatches & annList & filtered (isInside rng) & matchBinds + .- insertLocalBind declRng local $ fb + +-- | Puts a value definition into a list of local binds +insertLocalBind :: SrcSpan -> ValueBind dom -> MaybeLocalBinds dom -> MaybeLocalBinds dom +insertLocalBind declRng toInsert locals + | isAnnNothing locals + , RealSrcSpan rng <- declRng = -- creates the new where clause indented 2 spaces from the declaration + mkLocalBinds (srcLocCol (realSrcSpanStart rng) + 2) [mkLocalValBind toInsert] + | otherwise = annJust & localBinds .- insertWhere (mkLocalValBind toInsert) (const True) isNothing $ locals + +-- | All expressions that are bound stronger than function application. +isParenLikeExpr :: Expr dom -> Bool +isParenLikeExpr (If {}) = True +isParenLikeExpr (Paren {}) = True +isParenLikeExpr (List {}) = True +isParenLikeExpr (ParArray {}) = True +isParenLikeExpr (LeftSection {}) = True +isParenLikeExpr (RightSection {}) = True +isParenLikeExpr (RecCon {}) = True +isParenLikeExpr (RecUpdate {}) = True +isParenLikeExpr (Enum {}) = True +isParenLikeExpr (ParArrayEnum {}) = True +isParenLikeExpr (ListComp {}) = True +isParenLikeExpr (ParArrayComp {}) = True +isParenLikeExpr (BracketExpr {}) = True +isParenLikeExpr (SpliceExpr {}) = True +isParenLikeExpr (QuasiQuoteExpr {}) = True +isParenLikeExpr _ = False + +-- | Replaces the expression with the call and stores the binding of the call in its state +doExtract :: ExtractBindingDomain dom + => String -> Expr dom -> Expr dom -> StateT (Maybe (ValueBind dom)) (LocalRefactor dom) (Expr dom) +doExtract name cont e@(Lambda (AnnList bindings) inner) + = do let params = getExternalBinds cont e + put (Just (generateBind name (map mkVarPat params ++ bindings) inner)) + return (generateCall name params) +doExtract name cont e + = do let params = getExternalBinds cont e + put (Just (generateBind name (map mkVarPat params) e)) + return (generateCall name params) + +-- | Gets the values that have to be passed to the extracted definition +getExternalBinds :: ExtractBindingDomain dom => Expr dom -> Expr dom -> [Name dom] +getExternalBinds cont expr = map exprToName $ keepFirsts $ filter isApplicableName (expr ^? uniplateRef) + where isApplicableName name@(getExprNameInfo -> Just nm) = inScopeForOriginal nm && notInScopeForExtracted nm + isApplicableName _ = False + + getExprNameInfo :: ExtractBindingDomain dom => Expr dom -> Maybe GHC.Name + getExprNameInfo expr = semanticsName =<< (listToMaybe $ expr ^? (exprName&simpleName &+& exprOperator&operatorName)) + + -- | Creates the parameter value to pass the name (operators are passed in parentheses) + exprToName :: Expr dom -> Name dom + exprToName e | Just n <- e ^? exprName = n + | Just op <- e ^? exprOperator & operatorName = mkParenName op + + notInScopeForExtracted :: GHC.Name -> Bool + notInScopeForExtracted n = not $ n `inScope` semanticsScope cont + + inScopeForOriginal :: GHC.Name -> Bool + inScopeForOriginal n = n `inScope` semanticsScope expr + + keepFirsts (e:rest) = e : keepFirsts (filter (/= e) rest) + keepFirsts [] = [] + +actualContainingExpr :: SrcSpan -> Simple Traversal (ValueBind dom) (Expr dom) +actualContainingExpr (RealSrcSpan rng) = accessRhs & accessExpr + where accessRhs :: Simple Traversal (ValueBind dom) (Rhs dom) + accessRhs = valBindRhs &+& funBindMatches & annList & filtered (isInside rng) & matchRhs + accessExpr :: Simple Traversal (Rhs dom) (Expr dom) + accessExpr = rhsExpr &+& rhsGuards & annList & filtered (isInside rng) & guardExpr + +-- | Generates the expression that calls the local binding +generateCall :: String -> [Name dom] -> Expr dom +generateCall name args = foldl (\e a -> mkApp e (mkVar a)) (mkVar $ mkNormalName $ mkSimpleName name) args + +-- | Generates the local binding for the selected expression +generateBind :: String -> [Pattern dom] -> Expr dom -> ValueBind dom +generateBind name [] e = mkSimpleBind (mkVarPat $ mkNormalName $ mkSimpleName name) (mkUnguardedRhs e) Nothing +generateBind name args e = mkFunctionBind [mkMatch (mkMatchLhs (mkNormalName $ mkSimpleName name) args) (mkUnguardedRhs e) Nothing] + +isValidBindingName :: String -> Bool +isValidBindingName = nameValid Variable
+ Language/Haskell/Tools/Refactor/Predefined/GenerateExports.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE TupleSections + , ConstraintKinds + , TypeFamilies + , FlexibleContexts + #-} +module Language.Haskell.Tools.Refactor.Predefined.GenerateExports (generateExports, DomGenerateExports) where + +import Control.Reference hiding (element) + +import qualified GHC + +import Data.Maybe +import Control.Applicative ((<|>)) + +import Language.Haskell.Tools.AST +import Language.Haskell.Tools.Transform +import Language.Haskell.Tools.AST.Rewrite +import Language.Haskell.Tools.AST.ElementTypes +import Language.Haskell.Tools.Refactor.RefactorBase + +type DomGenerateExports dom = (Domain dom, HasNameInfo dom) + +-- | Creates an export list that imports standalone top-level definitions with all of their contained definitions +generateExports :: DomGenerateExports dom => LocalRefactoring dom +generateExports mod = return (modHead & annJust & mhExports & annMaybe + .= Just (createExports (getTopLevels mod)) $ mod) + +-- | Get all the top-level definitions with flags that mark if they can contain other top-level definitions +-- (classes and data declarations). +getTopLevels :: DomGenerateExports dom => Module dom -> [(GHC.Name, Bool)] +getTopLevels mod = catMaybes $ map (\d -> fmap (,exportContainOthers d) + (foldl (<|>) Nothing $ map semanticsName $ d ^? elementName)) + (mod ^? modDecl & annList) + where exportContainOthers :: Decl dom -> Bool + exportContainOthers (DataDecl {}) = True + exportContainOthers (ClassDecl {}) = True + exportContainOthers _ = False + +-- | Create the export for a give name. +createExports :: DomGenerateExports dom => [(GHC.Name, Bool)] -> ExportSpecs dom +createExports elems = mkExportSpecs $ map (mkExportSpec . createExport) elems + where createExport (n, False) = mkIESpec (mkUnqualName' (GHC.getName n)) Nothing + createExport (n, True) = mkIESpec (mkUnqualName' (GHC.getName n)) (Just mkSubAll) +
+ Language/Haskell/Tools/Refactor/Predefined/GenerateTypeSignature.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE ViewPatterns + , FlexibleContexts + , ScopedTypeVariables + , RankNTypes + , TypeApplications + , TypeFamilies + , ConstraintKinds + #-} +module Language.Haskell.Tools.Refactor.Predefined.GenerateTypeSignature (generateTypeSignature, generateTypeSignature', GenerateSignatureDomain) where + +import GHC hiding (Module) +import Type as GHC +import TyCon as GHC +import OccName as GHC +import Outputable as GHC +import TysWiredIn as GHC +import Id as GHC + +import Data.List +import Data.Maybe +import Data.Data +import Data.Generics.Uniplate.Data +import Control.Monad +import Control.Monad.State +import Control.Reference hiding (element) + +import Language.Haskell.Tools.Refactor as AST + +type GenerateSignatureDomain dom = ( HasModuleInfo dom, HasIdInfo dom, HasImportInfo dom ) + +generateTypeSignature' :: GenerateSignatureDomain dom => RealSrcSpan -> LocalRefactoring dom +generateTypeSignature' sp = generateTypeSignature (nodesContaining sp) (nodesContaining sp) (getValBindInList sp) + +-- | Perform the refactoring on either local or top-level definition +generateTypeSignature :: GenerateSignatureDomain dom => Simple Traversal (Module dom) (DeclList dom) + -- ^ Access for a top-level definition if it is the selected definition + -> Simple Traversal (Module dom) (LocalBindList dom) + -- ^ Access for a definition list if it contains the selected definition + -> (forall d . (BindingElem d) => AnnList d dom -> Maybe (ValueBind dom)) + -- ^ Selector for either local or top-level declaration in the definition list + -> LocalRefactoring dom +generateTypeSignature topLevelRef localRef vbAccess + = flip evalStateT False . + (topLevelRef !~ genTypeSig vbAccess + <=< localRef !~ genTypeSig vbAccess) + +genTypeSig :: (GenerateSignatureDomain dom, BindingElem d) => (AnnList d dom -> Maybe (ValueBind dom)) + -> AnnList d dom -> StateT Bool (LocalRefactor dom) (AnnList d dom) +genTypeSig vbAccess ls + | Just vb <- vbAccess ls + , not (typeSignatureAlreadyExist ls vb) + = do let id = getBindingName vb + isTheBind (Just decl) + = isBinding decl && map semanticsId (decl ^? elementName) == map semanticsId (vb ^? bindingName) + isTheBind _ = False + + alreadyGenerated <- get + if alreadyGenerated + then return ls + else do put True + typeSig <- lift $ generateTSFor (getName id) (idType id) + return $ insertWhere (createTypeSig typeSig) (const True) isTheBind ls + | otherwise = return ls + + +generateTSFor :: GenerateSignatureDomain dom => GHC.Name -> GHC.Type -> LocalRefactor dom (TypeSignature dom) +generateTSFor n t = mkTypeSignature (mkUnqualName' n) <$> generateTypeFor (-1) (dropForAlls t) + +-- | Generates the source-level type for a GHC internal type +generateTypeFor :: GenerateSignatureDomain dom => Int -> GHC.Type -> LocalRefactor dom (AST.Type dom) +generateTypeFor prec t + -- context + | (break (not . isPredTy) -> (preds, other), rt) <- splitFunTys t + , not (null preds) + = do ctx <- case preds of [pred] -> mkContextOne <$> generateAssertionFor pred + _ -> mkContextMulti <$> mapM generateAssertionFor preds + wrapParen 0 <$> (mkCtxType ctx <$> generateTypeFor 0 (mkFunTys other rt)) + -- function + | Just (at, rt) <- splitFunTy_maybe t + = wrapParen 0 <$> (mkFunctionType <$> generateTypeFor 10 at <*> generateTypeFor 0 rt) + -- type operator (we don't know the precedences, so always use parentheses) + | (op, [at,rt]) <- splitAppTys t + , Just tc <- tyConAppTyCon_maybe op + , isSymOcc (getOccName (getName tc)) + = wrapParen 0 <$> (mkInfixTypeApp <$> generateTypeFor 10 at <*> referenceOperator (idName $ getTCId tc) <*> generateTypeFor 10 rt) + -- tuple types + | Just (tc, tas) <- splitTyConApp_maybe t + , isTupleTyCon tc + = mkTupleType <$> mapM (generateTypeFor (-1)) tas + -- string type + | Just (ls, [et]) <- splitTyConApp_maybe t + , Just ch <- tyConAppTyCon_maybe et + , listTyCon == ls + , charTyCon == ch + = return $ mkVarType (mkNormalName $ mkSimpleName "String") + -- list types + | Just (tc, [et]) <- splitTyConApp_maybe t + , listTyCon == tc + = mkListType <$> generateTypeFor (-1) et + -- type application + | Just (tf, ta) <- splitAppTy_maybe t + = wrapParen 10 <$> (mkTypeApp <$> generateTypeFor 10 tf <*> generateTypeFor 11 ta) + -- type constructor + | Just tc <- tyConAppTyCon_maybe t + = mkVarType <$> referenceName (idName $ getTCId tc) + -- type variable + | Just tv <- getTyVar_maybe t + = mkVarType <$> referenceName (idName tv) + -- forall type + | (tvs@(_:_), t') <- splitForAllTys t + = wrapParen (-1) <$> (mkForallType (map (mkTypeVar' . getName) tvs) <$> generateTypeFor 0 t') + | otherwise = error ("Cannot represent type: " ++ showSDocUnsafe (ppr t)) + where wrapParen :: Int -> AST.Type dom -> AST.Type dom + wrapParen prec' node = if prec' < prec then mkParenType node else node + + getTCId :: GHC.TyCon -> GHC.Id + getTCId tc = GHC.mkVanillaGlobal (GHC.tyConName tc) (tyConKind tc) + + generateAssertionFor :: GenerateSignatureDomain dom => GHC.Type -> LocalRefactor dom (Assertion dom) + generateAssertionFor t + | Just (tc, types) <- splitTyConApp_maybe t + = mkClassAssert <$> referenceName (idName $ getTCId tc) <*> mapM (generateTypeFor 0) types + -- TODO: infix things + +-- | Check whether the definition already has a type signature +typeSignatureAlreadyExist :: (GenerateSignatureDomain dom, BindingElem d) => AnnList d dom -> ValueBind dom -> Bool +typeSignatureAlreadyExist ls vb = + getBindingName vb `elem` (map semanticsId $ concatMap (^? elementName) (filter isTypeSig $ ls ^? annList)) + +getBindingName :: GenerateSignatureDomain dom => ValueBind dom -> GHC.Id +getBindingName vb = case nub $ map semanticsId $ vb ^? bindingName of + [n] -> n + [] -> error "Trying to generate a signature for a binding with no name" + _ -> error "Trying to generate a signature for a binding with multiple names"
+ Language/Haskell/Tools/Refactor/Predefined/IfToGuards.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE RankNTypes, FlexibleContexts, ViewPatterns #-} +module Language.Haskell.Tools.Refactor.Predefined.IfToGuards (ifToGuards) where + +import Language.Haskell.Tools.AST +import Language.Haskell.Tools.AST.Rewrite +import Language.Haskell.Tools.Refactor.RefactorBase + +import Control.Reference hiding (element) +import SrcLoc +import Data.Generics.Uniplate.Data + +import Language.Haskell.Tools.AST.ElementTypes +import Language.Haskell.Tools.Refactor + +tryItOut moduleName sp = tryRefactor (localRefactoring $ ifToGuards (readSrcSpan (toFileName "." moduleName) sp)) moduleName + +ifToGuards :: Domain dom => RealSrcSpan -> LocalRefactoring dom +ifToGuards sp = return . (nodesContaining sp .- ifToGuards') + +ifToGuards' :: ValueBind dom -> ValueBind dom +ifToGuards' (SimpleBind (VarPat name) (UnguardedRhs (If pred thenE elseE)) locals) + = mkFunctionBind [mkMatch (mkMatchLhs name []) (createSimpleIfRhss pred thenE elseE) (locals ^. annMaybe) ] +ifToGuards' fbs@(FunctionBind {}) + = funBindMatches&annList&matchRhs .- trfRhs $ fbs + where trfRhs :: Rhs dom -> Rhs dom + trfRhs (UnguardedRhs (If pred thenE elseE)) = createSimpleIfRhss pred thenE elseE + trfRhs e = e -- don't transform already guarded right-hand sides to avoid multiple evaluation of the same condition + +createSimpleIfRhss :: Expr dom -> Expr dom -> Expr dom -> Rhs dom +createSimpleIfRhss pred thenE elseE = mkGuardedRhss [ mkGuardedRhs [mkGuardCheck pred] thenE + , mkGuardedRhs [mkGuardCheck (mkVar (mkName "otherwise"))] elseE + ] +
+ Language/Haskell/Tools/Refactor/Predefined/OrganizeImports.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE LambdaCase + , ScopedTypeVariables + , FlexibleContexts + , TypeFamilies + , ConstraintKinds + #-} +module Language.Haskell.Tools.Refactor.Predefined.OrganizeImports (organizeImports, OrganizeImportsDomain) where + +import SrcLoc +import Name hiding (Name) +import GHC (Ghc, GhcMonad, lookupGlobalName, TyThing(..), moduleNameString, moduleName) +import qualified GHC +import TyCon +import ConLike +import DataCon +import Outputable (Outputable(..), ppr, showSDocUnsafe) + +import Control.Reference hiding (element) +import Control.Monad +import Control.Monad.IO.Class +import Data.Function hiding ((&)) +import Data.String +import Data.Maybe +import Data.Data +import Data.List +import Data.Generics.Uniplate.Data + +import Language.Haskell.Tools.Refactor as AST + +type OrganizeImportsDomain dom = ( HasNameInfo dom, HasImportInfo dom ) + +organizeImports :: forall dom . OrganizeImportsDomain dom => LocalRefactoring dom +organizeImports mod + = modImports&annListElems !~ narrowImports usedNames . sortImports $ mod + where usedNames = map getName $ catMaybes $ map semanticsName + -- obviously we don't want the names in the imports to be considered, but both from + -- the declarations (used), both from the module head (re-exported) will count as usage + $ (universeBi (mod ^. modHead) ++ universeBi (mod ^. modDecl) :: [QualifiedName dom]) + +-- | Sorts the imports in alphabetical order +sortImports :: [ImportDecl dom] -> [ImportDecl dom] +sortImports = sortBy (compare `on` (^. importModule&AST.moduleNameString)) + +-- | Modify an import to only import names that are used. +narrowImports :: forall dom . OrganizeImportsDomain dom + => [GHC.Name] -> [ImportDecl dom] -> LocalRefactor dom [ImportDecl dom] +narrowImports usedNames imps = foldM (narrowOneImport usedNames) imps imps + where narrowOneImport :: [GHC.Name] -> [ImportDecl dom] -> ImportDecl dom -> LocalRefactor dom [ImportDecl dom] + narrowOneImport names all one = + (\case Just x -> map (\e -> if e == one then x else e) all + Nothing -> delete one all) <$> narrowImport names (map semanticsImportedModule all) one + +-- | Reduces the number of definitions used from an import +narrowImport :: OrganizeImportsDomain dom + => [GHC.Name] -> [GHC.Module] -> ImportDecl dom + -> LocalRefactor dom (Maybe (ImportDecl dom)) +narrowImport usedNames otherModules imp + | importIsExact imp + = Just <$> (importSpec&annJust&importSpecList !~ narrowImportSpecs usedNames $ imp) + | otherwise + = if null actuallyImported + then if length (filter (== importedMod) otherModules) > 1 + then pure Nothing + else Just <$> (importSpec !- replaceWithJust (mkImportSpecList []) $ imp) + else pure (Just imp) + where actuallyImported = semanticsImported imp `intersect` usedNames + importedMod = semanticsImportedModule imp + +-- | 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) + >=> return . filterList isNeededSpec + where narrowSpecSubspec :: [GHC.Name] -> IESpec dom -> LocalRefactor dom (IESpec dom) + narrowSpecSubspec usedNames spec + = do let Just specName = semanticsName =<< (spec ^? ieName&simpleName) + Just tt <- GHC.lookupName (getName specName) + let subspecsInScope = case tt of ATyCon tc | not (isClassTyCon tc) + -> map getName (tyConDataCons tc) `intersect` usedNames + _ -> usedNames + ieSubspec&annJust !- narrowImportSubspecs subspecsInScope $ spec + + isNeededSpec :: IESpec dom -> Bool + isNeededSpec ie = + -- if the name is used, it is needed + fmap getName (semanticsName =<< (ie ^? ieName&simpleName)) `elem` map Just usedNames + -- if the name is not used, but some of its constructors are used, it is needed + || ((ie ^? ieSubspec&annJust&essList&annList) /= []) + || (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
+ Language/Haskell/Tools/Refactor/Predefined/RenameDefinition.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE ScopedTypeVariables + , LambdaCase + , MultiWayIf + , TypeApplications + , ConstraintKinds + , TypeFamilies + , FlexibleContexts + , ViewPatterns + #-} +module Language.Haskell.Tools.Refactor.Predefined.RenameDefinition (renameDefinition, renameDefinition', DomainRenameDefinition) where + +import Name hiding (Name) +import GHC (Ghc, TyThing(..), lookupName) +import qualified GHC +import OccName +import SrcLoc +import Outputable +import Unique + +import Control.Reference as Ref +import Control.Monad.State +import Control.Monad.Trans.Except +import Data.Data +import Data.List.Split +import Data.List +import Data.Maybe +import Data.Generics.Uniplate.Data +import Language.Haskell.Tools.AST +import Language.Haskell.Tools.Transform +import Language.Haskell.Tools.AST.Rewrite +import Language.Haskell.Tools.AST.ElementTypes +import Language.Haskell.Tools.Refactor.RefactorBase + +import Debug.Trace + +type DomainRenameDefinition dom = ( HasNameInfo dom, HasScopeInfo dom, HasDefiningInfo dom + , HasImplicitFieldsInfo dom, HasModuleInfo dom ) + +renameDefinition' :: forall dom . DomainRenameDefinition dom => RealSrcSpan -> String -> Refactoring dom +renameDefinition' sp str mod mods + = case (getNodeContaining sp (snd mod) :: Maybe (QualifiedName dom)) >>= (fmap getName . semanticsName) of + Just name -> do let sameNames = bindsWithSameName name (snd mod ^? biplateRef) + renameDefinition name sameNames str mod mods + where bindsWithSameName :: GHC.Name -> [FieldWildcard dom] -> [GHC.Name] + bindsWithSameName name wcs = catMaybes $ map ((lookup name) . semanticsImplicitFlds) wcs + Nothing -> case getNodeContaining sp (snd mod) of + Just modName -> renameModule (modName ^. moduleNameString) str mod mods + Nothing -> refactError "No name is selected" + +renameModule :: forall dom . DomainRenameDefinition dom => String -> String -> Refactoring dom +renameModule from to m mods + | any (nameConflict to) (map snd $ m:mods) = refactError "UName conflict when renaming module" + | not (validModuleName to) = refactError "The given name is not a valid module name" + | otherwise = fmap (\ls -> ModuleRemoved from : map (\(ContentChanged (mod,res)) -> ContentChanged (if mod == from then to else mod, res)) ls) + $ localRefactoring (replaceModuleNames >=> alterNormalNames) m mods + where replaceModuleNames :: LocalRefactoring dom + replaceModuleNames = biplateRef @_ @(ModuleName dom) & filtered (\e -> (e ^. moduleNameString) == from) != mkModuleName to + + alterNormalNames :: LocalRefactoring dom + alterNormalNames mod = if from `elem` moduleQualifiers mod + then biplateRef @_ @(QualifiedName dom) & filtered (\e -> concat (intersperse "." (e ^? qualifiers&annList&simpleNameStr)) == from) + !- (\e -> mkQualifiedName (splitOn "." to) (e ^. unqualifiedName&simpleNameStr)) $ mod + else return mod + + moduleQualifiers :: Module dom -> [String] + moduleQualifiers mod = mod ^? modImports & annList & filtered (\m -> isAnnNothing (m ^. importAs)) + & importModule & moduleNameString + + nameConflict :: String -> Module dom -> Bool + nameConflict to mod + = let modName = mod ^? modHead&annJust&mhName&moduleNameString + imports = mod ^? modImports&annList + importNames = map (\imp -> fromMaybe (imp ^. importModule) (imp ^? importAs&annJust&importRename) ^. moduleNameString) imports + in modName == Just to || to `elem` importNames + +renameDefinition :: DomainRenameDefinition dom => GHC.Name -> [GHC.Name] -> String -> Refactoring dom +renameDefinition toChangeOrig toChangeWith newName mod mods + = do nameCls <- classifyName toChangeOrig + (changedModules,defFound) <- runStateT (catMaybes <$> mapM (renameInAModule toChangeOrig toChangeWith newName) (mod:mods)) False + if | not (nameValid nameCls newName) -> refactError "The new name is not valid" + | not defFound -> refactError "The definition to rename was not found" + | otherwise -> return $ map ContentChanged changedModules + where + renameInAModule :: DomainRenameDefinition dom => GHC.Name -> [GHC.Name] -> String -> ModuleDom dom -> StateT Bool Refactor (Maybe (ModuleDom dom)) + renameInAModule toChangeOrig toChangeWith newName (name, mod) + = mapStateT (localRefactoringRes (\f (a,s) -> (fmap (\(n,r) -> (n, f r)) a,s)) mod) $ + do (res, isChanged) <- runStateT (biplateRef !~ changeName toChangeOrig toChangeWith newName $ mod) False + if isChanged then return $ Just (name, res) + else return Nothing + + changeName :: DomainRenameDefinition dom => GHC.Name -> [GHC.Name] -> String -> QualifiedName dom + -> StateT Bool (StateT Bool (LocalRefactor dom)) (QualifiedName dom) + changeName toChangeOrig toChangeWith str name + | maybe False (`elem` toChange) actualName + && semanticsDefining name == False + && any @[] ((str ==) . occNameString . getOccName) (semanticsScope name ^? Ref.element 0 & traversal & filtered (sameNamespace toChangeOrig)) + = refactError $ "The definition clashes with an existing one at: " ++ shortShowSpan (getRange name) -- name clash with an external definition + | maybe False (`elem` toChange) actualName + = do put True -- state that something is changed in the local state + when (actualName == Just toChangeOrig) + $ lift $ modify (|| semanticsDefining name) -- state that the definition is renamed in the global state + return $ unqualifiedName .= mkNamePart str $ name -- found the changed name (or a name that have to be changed too) + | let namesInScope = semanticsScope name + in case semanticsName name of + Just (getName -> exprName) -> str == occNameString (getOccName exprName) && sameNamespace toChangeOrig exprName + && conflicts toChangeOrig exprName namesInScope + Nothing -> False -- ambiguous names + = refactError $ "The definition clashes with an existing one: " ++ shortShowSpan (getRange name) -- local name clash + | otherwise = return name -- not the changed name, leave as before + where toChange = toChangeOrig : toChangeWith + actualName = fmap getName (semanticsName name) + +conflicts :: GHC.Name -> GHC.Name -> [[GHC.Name]] -> Bool +conflicts overwrites overwritten (scopeBlock : scope) + | overwritten `elem` scopeBlock && overwrites `notElem` scopeBlock = False + | overwrites `elem` scopeBlock = True + | otherwise = conflicts overwrites overwritten scope +conflicts _ _ [] = False + +sameNamespace :: GHC.Name -> GHC.Name -> Bool +sameNamespace n1 n2 = occNameSpace (getOccName n1) == occNameSpace (getOccName n2)
+ Language/Haskell/Tools/Refactor/Prepare.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE StandaloneDeriving + , DeriveGeneric + , LambdaCase + , ScopedTypeVariables + , BangPatterns + , MultiWayIf + , FlexibleContexts + , TypeFamilies + , TupleSections + , TemplateHaskell + , ViewPatterns + #-} +-- | Defines utility methods that prepare Haskell modules for refactoring +module Language.Haskell.Tools.Refactor.Prepare where + +import GHC hiding (loadModule) +import Panic (handleGhcException) +import Outputable +import BasicTypes +import Bag +import Var +import SrcLoc +import Module as GHC +import FastString +import HscTypes +import GHC.Paths ( libdir ) +import CmdLineParser +import DynFlags +import StringBuffer + +import Control.Monad.IO.Class +import System.FilePath +import Data.Maybe +import Data.List.Split + +import Language.Haskell.Tools.AST as AST +import Language.Haskell.Tools.AST.FromGHC +import Language.Haskell.Tools.PrettyPrint +import Language.Haskell.Tools.Transform +import Language.Haskell.Tools.Refactor.RefactorBase + +tryRefactor :: Refactoring IdDom -> String -> IO () +tryRefactor refact moduleName + = runGhc (Just libdir) $ do + initGhcFlags + useDirs ["."] + mod <- loadModule "." moduleName >>= parseTyped + res <- runRefactor (toFileName "." moduleName, mod) [] refact + case res of Right r -> liftIO $ mapM_ (putStrLn . prettyPrint . snd . fromContentChanged) r + Left err -> liftIO $ putStrLn err + +-- | Set the given flags for the GHC session +useFlags :: [String] -> Ghc [String] +useFlags args = do + let lArgs = map (L noSrcSpan) args + dynflags <- getSessionDynFlags + let ((leftovers, errors, warnings), newDynFlags) = (runCmdLine $ processArgs flagsAll lArgs) dynflags + setSessionDynFlags newDynFlags + return $ map unLoc leftovers + +-- | Initialize GHC flags to default values that support refactoring +initGhcFlags :: Ghc () +initGhcFlags = do + dflags <- getSessionDynFlags + setSessionDynFlags + $ flip gopt_set Opt_KeepRawTokenStream + $ flip gopt_set Opt_NoHsMain + $ dflags { importPaths = [] + , hscTarget = HscAsm -- needed for static pointers + , ghcLink = LinkInMemory + , ghcMode = CompManager + , packageFlags = ExposePackage "template-haskell" (PackageArg "template-haskell") (ModRenaming True []) : packageFlags dflags + } + return () + +-- | Use the given source directories +useDirs :: [FilePath] -> Ghc () +useDirs workingDirs = do + dynflags <- getSessionDynFlags + setSessionDynFlags dynflags { importPaths = importPaths dynflags ++ workingDirs } + return () + +-- | Translates module name and working directory into the name of the file where the given module should be defined +toFileName :: String -> String -> FilePath +toFileName workingDir mod = normalise $ workingDir </> map (\case '.' -> pathSeparator; c -> c) mod ++ ".hs" + +-- | Translates module name and working directory into the name of the file where the boot module should be defined +toBootFileName :: String -> String -> FilePath +toBootFileName workingDir mod = normalise $ workingDir </> map (\case '.' -> pathSeparator; c -> c) mod ++ ".hs-boot" + +-- | Load the summary of a module given by the working directory and module name. +loadModule :: String -> String -> Ghc ModSummary +loadModule workingDir moduleName + = do initGhcFlags + useDirs [workingDir] + target <- guessTarget moduleName Nothing + setTargets [target] + load LoadAllTargets + getModSummary $ mkModuleName moduleName + +-- | The final version of our AST, with type infromation added +type TypedModule = Ann AST.UModule IdDom SrcTemplateStage + +-- | Get the typed representation from a type-correct program. +parseTyped :: ModSummary -> Ghc TypedModule +parseTyped modSum = do + p <- parseModule modSum + tc <- typecheckModule p + let annots = pm_annotations p + srcBuffer = fromJust $ ms_hspp_buf $ pm_mod_summary p + prepareAST srcBuffer . placeComments (getNormalComments $ snd annots) + <$> (addTypeInfos (typecheckedSource tc) + =<< (do parseTrf <- runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModule modSum (pm_parsed_source p) + runTrf (fst annots) (getPragmaComments $ snd annots) + $ trfModuleRename modSum parseTrf + (fromJust $ tm_renamed_source tc) + (pm_parsed_source p))) + +data IsBoot = NormalHs | IsHsBoot deriving (Eq, Ord, Show) + +readSrcSpan :: String -> String -> RealSrcSpan +readSrcSpan fileName s = case splitOn "-" s of + [from,to] -> mkRealSrcSpan (readSrcLoc fileName from) (readSrcLoc fileName to) + +readSrcLoc :: String -> String -> RealSrcLoc +readSrcLoc fileName s = case splitOn ":" s of + [line,col] -> mkRealSrcLoc (mkFastString fileName) (read line) (read col)
Language/Haskell/Tools/Refactor/RefactorBase.hs view
@@ -11,9 +11,8 @@ module Language.Haskell.Tools.Refactor.RefactorBase where import Language.Haskell.Tools.AST as AST -import Language.Haskell.Tools.AST.Gen -import Language.Haskell.Tools.AnnTrf.SourceTemplateHelpers -import Language.Haskell.Tools.AnnTrf.SourceTemplate +import Language.Haskell.Tools.AST.Rewrite +import Language.Haskell.Tools.Transform import GHC (Ghc, GhcMonad(..), TyThing(..), lookupName) import Exception (ExceptionMonad(..)) import DynFlags (HasDynFlags(..)) @@ -33,7 +32,7 @@ import Control.Monad.Writer import Control.Monad.State -type UnnamedModule dom = Ann AST.Module dom SrcTemplateStage +type UnnamedModule dom = Ann AST.UModule dom SrcTemplateStage -- | The name of the module and the AST type ModuleDom dom = (String, UnnamedModule dom) @@ -64,20 +63,20 @@ -> LocalRefactor dom a -> Refactor a localRefactoringRes access mod trf - = let init = RefactorCtx (semanticsModule $ mod ^. semantics) mod (mod ^? element&modImports&annList) + = let init = RefactorCtx (semanticsModule $ mod ^. semantics) mod (mod ^? modImports&annList) in flip runReaderT init $ do (mod, newNames) <- runWriterT (fromRefactorT trf) return $ access (addGeneratedImports newNames) mod -- | Adds the imports that bring names into scope that are needed by the refactoring -addGeneratedImports :: [GHC.Name] -> Ann Module dom SrcTemplateStage -> Ann Module dom SrcTemplateStage -addGeneratedImports names m = element&modImports&annListElems .- (++ addImports names) $ m - where addImports :: [GHC.Name] -> [Ann ImportDecl dom SrcTemplateStage] +addGeneratedImports :: [GHC.Name] -> Ann UModule dom SrcTemplateStage -> Ann UModule dom SrcTemplateStage +addGeneratedImports names m = modImports&annListElems .- (++ addImports names) $ m + where addImports :: [GHC.Name] -> [Ann UImportDecl dom SrcTemplateStage] addImports names = map createImport $ groupBy ((==) `on` GHC.nameModule) $ nub $ sort names -- TODO: group names like constructors into correct IESpecs - createImport :: [GHC.Name] -> Ann ImportDecl dom SrcTemplateStage + createImport :: [GHC.Name] -> Ann UImportDecl dom SrcTemplateStage 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)) + Nothing (Just $ mkImportSpecList (map (\n -> mkIESpec (mkUnqualName' n) Nothing) names)) instance (GhcMonad m, Monoid s) => GhcMonad (WriterT s m) where getSession = lift getSession @@ -110,8 +109,8 @@ -- | The information a refactoring can use data RefactorCtx dom = RefactorCtx { refModuleName :: GHC.Module - , refCtxRoot :: Ann Module dom SrcTemplateStage - , refCtxImports :: [Ann ImportDecl dom SrcTemplateStage] + , refCtxRoot :: Ann UModule dom SrcTemplateStage + , refCtxImports :: [Ann UImportDecl dom SrcTemplateStage] } instance MonadTrans (LocalRefactorT dom) where @@ -155,10 +154,10 @@ Just mod -> GHC.moduleNameString (GHC.moduleName mod) ++ "." ++ GHC.occNameString (GHC.nameOccName name) Nothing -> GHC.occNameString (GHC.nameOccName name) -referenceName :: (HasImportInfo dom, HasModuleInfo dom) => GHC.Name -> LocalRefactor dom (Ann Name dom SrcTemplateStage) +referenceName :: (HasImportInfo dom, HasModuleInfo dom) => GHC.Name -> LocalRefactor dom (Ann UName dom SrcTemplateStage) referenceName = referenceName' mkQualName' -referenceOperator :: (HasImportInfo dom, HasModuleInfo dom) => GHC.Name -> LocalRefactor dom (Ann Operator dom SrcTemplateStage) +referenceOperator :: (HasImportInfo dom, HasModuleInfo dom) => GHC.Name -> LocalRefactor dom (Ann UOperator dom SrcTemplateStage) referenceOperator = referenceName' mkQualOp' -- | Create a name that references the definition. Generates an import if the definition is not yet imported. @@ -180,15 +179,15 @@ -- use it according to the best available import -- | Reference the name by the shortest suitable import -referenceBy :: ([String] -> GHC.Name -> Ann nt dom SrcTemplateStage) -> GHC.Name -> [Ann ImportDecl dom SrcTemplateStage] -> Ann nt dom SrcTemplateStage +referenceBy :: ([String] -> GHC.Name -> Ann nt dom SrcTemplateStage) -> GHC.Name -> [Ann UImportDecl dom SrcTemplateStage] -> Ann nt dom SrcTemplateStage referenceBy makeName name imps = let prefixes = map importQualifier imps in makeName (minimumBy (compare `on` (length . concat)) prefixes) name - where importQualifier :: Ann ImportDecl dom SrcTemplateStage -> [String] + where importQualifier :: Ann UImportDecl dom SrcTemplateStage -> [String] importQualifier imp - = if isJust (imp ^? element&importQualified&annJust) - then case imp ^? element&importAs&annJust&element&importRename&element of - Nothing -> splitOn "." (imp ^. element&importModule&element&moduleNameString) -- fully qualified import + = if isJust (imp ^? importQualified&annJust) + then case imp ^? importAs&annJust&importRename of + Nothing -> splitOn "." (imp ^. importModule&moduleNameString) -- fully qualified import Just asName -> splitOn "." (asName ^. moduleNameString) -- the name given by as clause else [] -- unqualified import @@ -197,7 +196,7 @@ | Ctor -- ^ Data constructors | ValueOperator -- ^ Functions with operator-like names | DataCtorOperator -- ^ Constructors with operator-like names - | SynonymOperator -- ^ Type definitions with operator-like names + | SynonymOperator -- ^ UType definitions with operator-like names -- | Get which category does a given name belong to classifyName :: RefactorMonad m => GHC.Name -> m NameClass @@ -228,7 +227,7 @@ -- Operators that are data constructors (must start with ':') nameValid DataCtorOperator (':' : nameRest) = all isOperatorChar nameRest --- Type families and synonyms that are operators (can start with ':') +-- UType families and synonyms that are operators (can start with ':') nameValid SynonymOperator (c : nameRest) = isOperatorChar c && all isOperatorChar nameRest -- Normal value operators (cannot start with ':')
− Language/Haskell/Tools/Refactor/RenameDefinition.hs
@@ -1,121 +0,0 @@-{-# LANGUAGE ScopedTypeVariables - , LambdaCase - , MultiWayIf - , TypeApplications - , ConstraintKinds - , TypeFamilies - , FlexibleContexts - , ViewPatterns - #-} -module Language.Haskell.Tools.Refactor.RenameDefinition (renameDefinition, renameDefinition', DomainRenameDefinition) where - -import Name hiding (Name) -import GHC (Ghc, TyThing(..), lookupName) -import qualified GHC -import OccName -import SrcLoc -import Outputable -import Unique - -import Control.Reference hiding (element) -import qualified Control.Reference as Ref -import Control.Monad.State -import Control.Monad.Trans.Except -import Data.Data -import Data.List.Split -import Data.List -import Data.Maybe -import Data.Generics.Uniplate.Data -import Language.Haskell.Tools.AST -import Language.Haskell.Tools.AnnTrf.SourceTemplate -import Language.Haskell.Tools.AST.Gen -import Language.Haskell.Tools.Refactor.RefactorBase - -import Debug.Trace - -type DomainRenameDefinition dom = ( HasNameInfo dom, HasScopeInfo dom, HasDefiningInfo dom - , HasImplicitFieldsInfo dom, HasModuleInfo dom ) - -renameDefinition' :: forall dom . DomainRenameDefinition dom => RealSrcSpan -> String -> Refactoring dom -renameDefinition' sp str mod mods - = case (getNodeContaining sp (snd mod) :: Maybe (Ann QualifiedName dom SrcTemplateStage)) >>= (fmap getName . (semanticsName =<<) . (^? semantics)) of - Just name -> do let sameNames = bindsWithSameName name (snd mod ^? biplateRef) - renameDefinition name sameNames str mod mods - where bindsWithSameName :: GHC.Name -> [Ann FieldWildcard dom SrcTemplateStage] -> [GHC.Name] - bindsWithSameName name wcs = catMaybes $ map ((lookup name) . semanticsImplicitFlds . (^. semantics)) wcs - Nothing -> case getNodeContaining sp (snd mod) of - Just modName -> renameModule (modName ^. element&moduleNameString) str mod mods - Nothing -> refactError "No name is selected" - -renameModule :: forall dom . DomainRenameDefinition dom => String -> String -> Refactoring dom -renameModule from to m mods - | any (nameConflict to) (map snd $ m:mods) = refactError "Name conflict when renaming module" - | not (validModuleName to) = refactError "The given name is not a valid module name" - | otherwise = fmap (\ls -> ModuleRemoved from : map (\(ContentChanged (mod,res)) -> ContentChanged (if mod == from then to else mod, res)) ls) - $ localRefactoring (replaceModuleNames >=> alterNormalNames) m mods - where replaceModuleNames :: LocalRefactoring dom - replaceModuleNames = biplateRef @_ @(Ann ModuleName dom SrcTemplateStage) & filtered (\e -> (e ^. element&moduleNameString) == from) != mkModuleName to - - alterNormalNames :: LocalRefactoring dom - alterNormalNames mod = if from `elem` moduleQualifiers mod - then biplateRef @_ @(Ann QualifiedName dom SrcTemplateStage) & filtered (\e -> concat (intersperse "." (e ^? element&qualifiers&annList&element&simpleNameStr)) == from) - !- (\e -> mkQualifiedName (splitOn "." to) (e ^. element&unqualifiedName&element&simpleNameStr)) $ mod - else return mod - - moduleQualifiers :: Ann Module dom SrcTemplateStage -> [String] - moduleQualifiers mod = mod ^? element & modImports & annList & element & filtered (\m -> isAnnNothing (m ^. importAs)) - & importModule & element & moduleNameString - - nameConflict :: String -> Ann Module dom SrcTemplateStage -> Bool - nameConflict to mod - = let modName = mod ^? element&modHead&annJust&element&mhName&element&moduleNameString - imports = mod ^? element&modImports&annList&element - importNames = map (\imp -> fromMaybe (imp ^. importModule) (imp ^? importAs&annJust&element&importRename) ^. element&moduleNameString) imports - in modName == Just to || to `elem` importNames - -renameDefinition :: DomainRenameDefinition dom => GHC.Name -> [GHC.Name] -> String -> Refactoring dom -renameDefinition toChangeOrig toChangeWith newName mod mods - = do nameCls <- classifyName toChangeOrig - (changedModules,defFound) <- runStateT (catMaybes <$> mapM (renameInAModule toChangeOrig toChangeWith newName) (mod:mods)) False - if | not (nameValid nameCls newName) -> refactError "The new name is not valid" - | not defFound -> refactError "The definition to rename was not found" - | otherwise -> return $ map ContentChanged changedModules - where - renameInAModule :: DomainRenameDefinition dom => GHC.Name -> [GHC.Name] -> String -> ModuleDom dom -> StateT Bool Refactor (Maybe (ModuleDom dom)) - renameInAModule toChangeOrig toChangeWith newName (name, mod) - = mapStateT (localRefactoringRes (\f (a,s) -> (fmap (\(n,r) -> (n, f r)) a,s)) mod) $ - do (res, isChanged) <- runStateT (biplateRef !~ changeName toChangeOrig toChangeWith newName $ mod) False - if isChanged then return $ Just (name, res) - else return Nothing - - changeName :: DomainRenameDefinition dom => GHC.Name -> [GHC.Name] -> String -> Ann QualifiedName dom SrcTemplateStage - -> StateT Bool (StateT Bool (LocalRefactor dom)) (Ann QualifiedName dom SrcTemplateStage) - changeName toChangeOrig toChangeWith str name - | maybe False (`elem` toChange) actualName - && semanticsDefining (name ^. semantics) == False - && any @[] ((str ==) . occNameString . getOccName) (semanticsScope (name ^. semantics) ^? Ref.element 0 & traversal & filtered (sameNamespace toChangeOrig)) - = refactError $ "The definition clashes with an existing one at: " ++ shortShowSpan (getRange name) -- name clash with an external definition - | maybe False (`elem` toChange) actualName - = do put True -- state that something is changed in the local state - when (actualName == Just toChangeOrig) - $ lift $ modify (|| semanticsDefining (name ^. semantics)) -- state that the definition is renamed in the global state - return $ element & unqualifiedName .= mkNamePart str $ name -- found the changed name (or a name that have to be changed too) - | let namesInScope = semanticsScope (name ^. semantics) - in case semanticsName (name ^. semantics) of - Just (getName -> exprName) -> str == occNameString (getOccName exprName) && sameNamespace toChangeOrig exprName - && conflicts toChangeOrig exprName namesInScope - Nothing -> False -- ambiguous names - = refactError $ "The definition clashes with an existing one: " ++ shortShowSpan (getRange name) -- local name clash - | otherwise = return name -- not the changed name, leave as before - where toChange = toChangeOrig : toChangeWith - actualName = fmap getName (semanticsName (name ^. semantics)) - -conflicts :: GHC.Name -> GHC.Name -> [[GHC.Name]] -> Bool -conflicts overwrites overwritten (scopeBlock : scope) - | overwritten `elem` scopeBlock && overwrites `notElem` scopeBlock = False - | overwrites `elem` scopeBlock = True - | otherwise = conflicts overwrites overwritten scope -conflicts _ _ [] = False - -sameNamespace :: GHC.Name -> GHC.Name -> Bool -sameNamespace n1 n2 = occNameSpace (getOccName n1) == occNameSpace (getOccName n2)
haskell-tools-refactor.cabal view
@@ -1,5 +1,5 @@ name: haskell-tools-refactor -version: 0.2.0.0 +version: 0.3.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 @@ -13,62 +13,67 @@ library exposed-modules: Language.Haskell.Tools.Refactor - , Language.Haskell.Tools.Refactor.GenerateTypeSignature - , Language.Haskell.Tools.Refactor.OrganizeImports - , Language.Haskell.Tools.Refactor.GenerateExports - , Language.Haskell.Tools.Refactor.RenameDefinition - , Language.Haskell.Tools.Refactor.ExtractBinding - , Language.Haskell.Tools.Refactor.RefactorBase - , Language.Haskell.Tools.Refactor.DataToNewtype - , Language.Haskell.Tools.Refactor.IfToGuards - , Language.Haskell.Tools.Refactor.DollarApp + , Language.Haskell.Tools.Refactor.BindingElem , Language.Haskell.Tools.Refactor.GetModules - build-depends: base >=4.9 && <5.0 - , ghc >=8.0 && <8.1 - , mtl >=2.2 && <2.3 - , uniplate >=1.6 && <1.7 - , ghc-paths >=0.1 && <0.2 - , containers >=0.5 && <0.6 - , directory >=1.2 && <1.3 - , transformers >=0.5 && <0.6 - , references >=0.3.2 && <1.0 - , split >=0.2 && <1.0 - , filepath >=1.4 && <2.0 - , haskell-tools-ast >=0.2 && <0.3 - , haskell-tools-ast-fromghc >=0.2 && <0.3 - , haskell-tools-ast-gen >=0.2 && <0.3 - , haskell-tools-ast-trf >=0.2 && <0.3 - , haskell-tools-prettyprint >=0.2 && <0.3 - , template-haskell >=2.0 && <3.0 - , Cabal >=1.24 && <2.0 + , Language.Haskell.Tools.Refactor.RefactorBase + , Language.Haskell.Tools.Refactor.Prepare + , Language.Haskell.Tools.Refactor.Perform + , Language.Haskell.Tools.Refactor.ListOperations + + , Language.Haskell.Tools.Refactor.Predefined.GenerateTypeSignature + , Language.Haskell.Tools.Refactor.Predefined.OrganizeImports + , Language.Haskell.Tools.Refactor.Predefined.GenerateExports + , Language.Haskell.Tools.Refactor.Predefined.RenameDefinition + , Language.Haskell.Tools.Refactor.Predefined.ExtractBinding + , Language.Haskell.Tools.Refactor.Predefined.DataToNewtype + , Language.Haskell.Tools.Refactor.Predefined.IfToGuards + , Language.Haskell.Tools.Refactor.Predefined.DollarApp + + build-depends: base >= 4.9 && < 4.10 + , mtl >= 2.2 && < 2.3 + , uniplate >= 1.6 && < 1.7 + , ghc-paths >= 0.1 && < 0.2 + , containers >= 0.5 && < 0.6 + , directory >= 1.2 && < 1.3 + , transformers >= 0.5 && < 0.6 + , references >= 0.3 && < 0.4 + , split >= 0.2 && < 0.3 + , filepath >= 1.4 && < 1.5 + , template-haskell >= 2.11 && < 2.12 + , ghc >= 8.0 && < 8.1 + , Cabal >= 1.24 && < 1.25 + , haskell-tools-ast >= 0.3 && < 0.4 + , haskell-tools-backend-ghc >= 0.3 && < 0.4 + , haskell-tools-rewrite >= 0.3 && < 0.4 + , haskell-tools-prettyprint >= 0.3 && < 0.4 default-language: Haskell2010 test-suite haskell-tools-test type: exitcode-stdio-1.0 ghc-options: -with-rtsopts=-M2g - hs-source-dirs: ../../test + hs-source-dirs: test main-is: Main.hs - build-depends: base >=4.9 && <5.0 - , HUnit >=1.3 && <2.0 - , ghc >=8.0 && <8.1 - , ghc-paths >=0.1 && <0.2 - , transformers >=0.5 && <0.6 - , either >=4.0 && <5.0 - , filepath >=1.4 && <2.0 - , haskell-tools-ast >=0.2 && <0.3 - , haskell-tools-ast-fromghc >=0.2 && <0.3 - , haskell-tools-ast-gen >=0.2 && <0.3 - , haskell-tools-ast-trf >=0.2 && <0.3 - , haskell-tools-prettyprint >=0.2 && <0.3 - , haskell-tools-refactor >=0.2 && <0.3 - , mtl >=2.2 && <2.3 - , uniplate >=1.6 && <1.7 - , containers >=0.5 && <0.6 - , directory >=1.2 && <1.3 - , references >=0.3.2 && <1.0 - , split >=0.2 && <1.0 - , time >=1.5 && <2.0 - , template-haskell >=2.0 && <3.0 - , Cabal >=1.24 && <2.0 - , polyparse >=1.12 && <2.0 + build-depends: base >= 4.9 && < 4.10 + , HUnit >= 1.3 && < 1.4 + , transformers >= 0.5 && < 0.6 + , either >= 4.4 && < 4.5 + , filepath >= 1.4 && < 1.5 + , mtl >= 2.2 && < 2.3 + , uniplate >= 1.6 && < 1.7 + , containers >= 0.5 && < 0.6 + , directory >= 1.2 && < 1.3 + , references >= 0.3 && < 0.4 + , split >= 0.2 && < 0.3 + , time >= 1.6 && < 1.7 + , old-time >= 1.1 && < 1.2 + , polyparse >= 1.12 && < 1.13 + , template-haskell >= 2.11 && < 2.12 + , ghc >= 8.0 && < 8.1 + , ghc-paths >= 0.1 && < 0.2 + , Cabal >= 1.24 && < 1.25 + , haskell-tools-ast >= 0.3 && < 0.4 + , haskell-tools-backend-ghc >= 0.3 && < 0.4 + , haskell-tools-rewrite >= 0.3 && < 0.4 + , haskell-tools-prettyprint >= 0.3 && < 0.4 + , haskell-tools-refactor >= 0.3 && < 0.4 default-language: Haskell2010
+ test/Main.hs view
@@ -0,0 +1,563 @@+{-# LANGUAGE LambdaCase + , ViewPatterns + , TypeFamilies + #-} +module Main where + +import GHC hiding (loadModule, ParsedModule) +import DynFlags +import GHC.Paths ( libdir ) +import Module as GHC + +import Control.Monad.IO.Class +import Control.Monad +import Data.Maybe +import Data.List +import Data.Either.Combinators +import Test.HUnit hiding (test) +import System.IO +import System.Exit +import System.FilePath + +import Language.Haskell.Tools.AST as AST +import Language.Haskell.Tools.AST.Rewrite as G +import Language.Haskell.Tools.AST.FromGHC +import Language.Haskell.Tools.Transform +import Language.Haskell.Tools.PrettyPrint +import Language.Haskell.Tools.Refactor.Perform +import Language.Haskell.Tools.Refactor.Prepare +import Language.Haskell.Tools.Refactor.GetModules +import Language.Haskell.Tools.Refactor.Predefined.OrganizeImports +import Language.Haskell.Tools.Refactor.Predefined.GenerateTypeSignature +import Language.Haskell.Tools.Refactor.Predefined.GenerateExports +import Language.Haskell.Tools.Refactor.Predefined.RenameDefinition +import Language.Haskell.Tools.Refactor.Predefined.ExtractBinding +import Language.Haskell.Tools.Refactor.RefactorBase + +import Language.Haskell.Tools.Refactor.Predefined.DataToNewtype +import Language.Haskell.Tools.Refactor.Predefined.IfToGuards +import Language.Haskell.Tools.Refactor.Predefined.DollarApp + +main :: IO () +main = run nightlyTests + +run :: [Test] -> IO () +run tests = do results <- runTestTT $ TestList tests + if errors results + failures results > 0 + then exitFailure + else exitSuccess + +nightlyTests :: [Test] +nightlyTests = unitTests + ++ map makeCpphsTest cppHsTests + ++ map makeInstanceControlTest instanceControlTests + +unitTests :: [Test] +unitTests = genTests ++ functionalTests + +functionalTests :: [Test] +functionalTests = map makeReprintTest checkTestCases + ++ map makeOrganizeImportsTest organizeImportTests + ++ map makeGenerateSignatureTest generateSignatureTests + ++ map makeGenerateExportsTest generateExportsTests + ++ map makeRenameDefinitionTest renameDefinitionTests + ++ map makeWrongRenameDefinitionTest wrongRenameDefinitionTests + ++ map makeExtractBindingTest extractBindingTests + ++ map makeWrongExtractBindingTest wrongExtractBindingTests + ++ map makeMultiModuleTest multiModuleTests + ++ map makeMiscRefactorTest miscRefactorTests + where checkTestCases = languageTests + ++ organizeImportTests + ++ map fst generateSignatureTests + ++ generateExportsTests + ++ map (\(mod,_,_) -> mod) renameDefinitionTests + ++ map (\(mod,_,_) -> mod) wrongRenameDefinitionTests + ++ map (\(mod,_,_) -> mod) extractBindingTests + ++ map (\(mod,_,_) -> mod) wrongExtractBindingTests + +rootDir = ".." </> ".." </> "examples" + +languageTests = + [ "Decl.AmbiguousFields" + , "Decl.AnnPragma" + , "Decl.ClosedTypeFamily" + , "Decl.CtorOp" + , "Decl.DataFamily" + , "Decl.DataType" + , "Decl.DataTypeDerivings" + , "Decl.FunBind" + , "Decl.FunctionalDeps" + , "Decl.FunGuards" + , "Decl.GADT" + , "Decl.InjectiveTypeFamily" + , "Decl.InlinePragma" + , "Decl.InstanceOverlaps" + , "Decl.InstanceSpec" + , "Decl.LocalBindings" + , "Decl.LocalFixity" + , "Decl.MultipleFixity" + , "Decl.MultipleSigs" + , "Decl.OperatorBind" + , "Decl.OperatorDecl" + , "Decl.ParamDataType" + , "Decl.PatternBind" + , "Decl.PatternSynonym" + , "Decl.RecordPatternSynonyms" + , "Decl.RecordType" + , "Decl.RewriteRule" + , "Decl.SpecializePragma" + , "Decl.StandaloneDeriving" + , "Decl.TypeClass" + , "Decl.TypeClassMinimal" + , "Decl.TypeFamily" + , "Decl.TypeFamilyKindSig" + , "Decl.TypeInstance" + , "Decl.TypeRole" + , "Decl.TypeSynonym" + , "Decl.ValBind" + , "Expr.ArrowNotation" + , "Expr.Case" + , "Expr.DoNotation" + , "Expr.GeneralizedListComp" + , "Expr.EmptyCase" + , "Expr.If" + , "Expr.ImplicitParams" + , "Expr.LambdaCase" + , "Expr.ListComp" + , "Expr.MultiwayIf" + , "Expr.Negate" + , "Expr.Operator" + , "Expr.ParenName" + , "Expr.ParListComp" + , "Expr.RecordPuns" + , "Expr.RecordWildcards" + , "Expr.RecursiveDo" + , "Expr.Sections" + , "Expr.StaticPtr" + , "Expr.TupleSections" + , "Module.Simple" + , "Module.GhcOptionsPragma" + , "Module.Export" + , "Module.NamespaceExport" + , "Module.Import" + , "Pattern.Backtick" + , "Pattern.Constructor" + , "Pattern.ImplicitParams" + , "Pattern.Infix" + , "Pattern.NPlusK" + , "Pattern.Record" + , "Type.Bang" + , "Type.Builtin" + , "Type.Ctx" + , "Type.ExplicitTypeApplication" + , "Type.Forall" + , "Type.Primitives" + , "Type.TypeOperators" + , "Type.Unpack" + , "Type.Wildcard" + , "TH.Brackets" + , "TH.QuasiQuote.Define" + , "TH.QuasiQuote.Use" + , "TH.Splice.Define" + , "TH.Splice.Use" + , "Refactor.CommentHandling.CommentTypes" + , "Refactor.CommentHandling.BlockComments" + , "Refactor.CommentHandling.Crosslinking" + , "Refactor.CommentHandling.FunctionArgs" + ] + +cppHsTests = + [ "Language.Preprocessor.Cpphs" + , "Language.Preprocessor.Unlit" + , "Language.Preprocessor.Cpphs.CppIfdef" + , "Language.Preprocessor.Cpphs.HashDefine" + , "Language.Preprocessor.Cpphs.MacroPass" + , "Language.Preprocessor.Cpphs.Options" + , "Language.Preprocessor.Cpphs.Position" + , "Language.Preprocessor.Cpphs.ReadFirst" + , "Language.Preprocessor.Cpphs.RunCpphs" + , "Language.Preprocessor.Cpphs.SymTab" + , "Language.Preprocessor.Cpphs.Tokenise" + ] + +instanceControlTests = + [ "Control.Instances.Test" + , "Control.Instances.Morph" + , "Control.Instances.ShortestPath" + , "Control.Instances.TypeLevelPrelude" + ] + +organizeImportTests = + [ "Refactor.OrganizeImports.Narrow" + , "Refactor.OrganizeImports.Reorder" + , "Refactor.OrganizeImports.Unused" + , "Refactor.OrganizeImports.Ctor" + , "Refactor.OrganizeImports.Class" + , "Refactor.OrganizeImports.Operator" + , "Refactor.OrganizeImports.SameName" + , "Refactor.OrganizeImports.Removed" + ] + +generateSignatureTests = + [ ("Refactor.GenerateTypeSignature.Simple", "3:1-3:10") + , ("Refactor.GenerateTypeSignature.Function", "3:1-3:15") + , ("Refactor.GenerateTypeSignature.HigherOrder", "3:1-3:14") + , ("Refactor.GenerateTypeSignature.Polymorph", "3:1-3:10") + , ("Refactor.GenerateTypeSignature.PolymorphSub", "5:3-5:4") + , ("Refactor.GenerateTypeSignature.PolymorphSubMulti", "5:3-5:4") + , ("Refactor.GenerateTypeSignature.Placement", "4:1-4:10") + , ("Refactor.GenerateTypeSignature.Tuple", "3:1-3:18") + , ("Refactor.GenerateTypeSignature.Complex", "3:1-3:21") + , ("Refactor.GenerateTypeSignature.Local", "4:3-4:12") + , ("Refactor.GenerateTypeSignature.Let", "3:9-3:18") + , ("Refactor.GenerateTypeSignature.TypeDefinedInModule", "3:1-3:1") + , ("Refactor.GenerateTypeSignature.BringToScope.AlreadyQualImport", "6:1-6:2") + ] + +generateExportsTests = + [ "Refactor.GenerateExports.Normal" + , "Refactor.GenerateExports.Operators" + ] + +renameDefinitionTests = + [ ("Refactor.RenameDefinition.AmbiguousFields", "4:14-4:15", "xx") + , ("Refactor.RenameDefinition.RecordField", "3:22-3:23", "xCoord") + , ("Refactor.RenameDefinition.Constructor", "3:14-3:19", "Point2D") + , ("Refactor.RenameDefinition.Type", "5:16-5:16", "Point2D") + , ("Refactor.RenameDefinition.Function", "3:1-3:2", "q") + , ("Refactor.RenameDefinition.QualName", "3:1-3:2", "q") + , ("Refactor.RenameDefinition.BacktickName", "3:1-3:2", "g") + , ("Refactor.RenameDefinition.ParenName", "4:3-4:5", "<->") + , ("Refactor.RenameDefinition.RecordWildcards", "4:32-4:33", "yy") + , ("Refactor.RenameDefinition.RecordPatternSynonyms", "4:16-4:17", "xx") + , ("Refactor.RenameDefinition.ClassMember", "7:3-7:4", "q") + , ("Refactor.RenameDefinition.LocalFunction", "4:5-4:6", "g") + , ("Refactor.RenameDefinition.LayoutAware", "3:1-3:2", "main") + , ("Refactor.RenameDefinition.Arg", "4:3-4:4", "y") + , ("Refactor.RenameDefinition.FunTypeVar", "3:6-3:7", "x") + , ("Refactor.RenameDefinition.FunTypeVarLocal", "5:10-5:11", "b") + , ("Refactor.RenameDefinition.ClassTypeVar", "3:9-3:10", "f") + , ("Refactor.RenameDefinition.TypeOperators", "4:13-4:15", "x1") + , ("Refactor.RenameDefinition.NoPrelude", "4:1-4:2", "map") + , ("Refactor.RenameDefinition.UnusedDef", "3:1-3:2", "map") + , ("Refactor.RenameDefinition.ImplicitParams", "8:17-8:20", "compare") + , ("Refactor.RenameDefinition.SameCtorAndType", "3:6-3:13", "P2D") + , ("Refactor.RenameDefinition.RoleAnnotation", "4:11-4:12", "AA") + , ("Refactor.RenameDefinition.TypeBracket", "6:6-6:7", "B") + , ("Refactor.RenameDefinition.ValBracket", "8:11-8:12", "B") + ] + +wrongRenameDefinitionTests = + [ ("Refactor.RenameDefinition.LibraryFunction", "4:5-4:7", "identity") + , ("Refactor.RenameDefinition.NameClash", "5:9-5:10", "h") + , ("Refactor.RenameDefinition.NameClash", "3:1-3:2", "map") + , ("Refactor.RenameDefinition.WrongName", "4:1-4:2", "F") + , ("Refactor.RenameDefinition.WrongName", "4:1-4:2", "++") + , ("Refactor.RenameDefinition.WrongName", "7:6-7:7", "x") + , ("Refactor.RenameDefinition.WrongName", "7:6-7:7", ":+:") + , ("Refactor.RenameDefinition.WrongName", "7:10-7:11", "x") + , ("Refactor.RenameDefinition.WrongName", "9:6-9:7", "A") + , ("Refactor.RenameDefinition.WrongName", "9:19-9:19", ".+++.") + , ("Refactor.RenameDefinition.WrongName", "11:3-11:3", ":+++:") + , ("Refactor.RenameDefinition.IllegalQualRename", "4:30-4:34", "Bl") + ] + +extractBindingTests = + [ ("Refactor.ExtractBinding.Simple", "3:19-3:27", "exaggerate") + , ("Refactor.ExtractBinding.Parentheses", "3:23-3:62", "sqDistance") + , ("Refactor.ExtractBinding.AddToExisting", "3:10-3:12", "b") + , ("Refactor.ExtractBinding.LocalDefinition", "4:13-4:16", "y") + , ("Refactor.ExtractBinding.ClassInstance", "6:30-6:35", "g") + , ("Refactor.ExtractBinding.ListComprehension", "5:25-5:39", "notDivisible") + , ("Refactor.ExtractBinding.Records", "5:5-5:39", "plus") + , ("Refactor.ExtractBinding.RecordWildcards", "6:5-6:27", "plus") + ] + +wrongExtractBindingTests = + [ ("Refactor.ExtractBinding.TooSimple", "3:19-3:20", "x") + , ("Refactor.ExtractBinding.NameConflict", "3:19-3:27", "stms") + ] + +multiModuleTests = + [ ("RenameDefinition 5:5-5:6 bb", "A", "Refactor" </> "RenameDefinition" </> "MultiModule", []) + , ("RenameDefinition 1:8-1:9 C", "B", "Refactor" </> "RenameDefinition" </> "RenameModule", ["B"]) + , ("RenameDefinition 3:8-3:9 C", "A", "Refactor" </> "RenameDefinition" </> "RenameModule", ["B"]) + , ("RenameDefinition 6:1-6:9 hello", "Use", "Refactor" </> "RenameDefinition" </> "SpliceDecls", []) + , ("RenameDefinition 5:1-5:5 exprSplice", "Define", "Refactor" </> "RenameDefinition" </> "SpliceExpr", []) + , ("RenameDefinition 6:1-6:4 spliceTyp", "Define", "Refactor" </> "RenameDefinition" </> "SpliceType", []) + ] + +miscRefactorTests = + [ ("Refactor.DataToNewtype.Cases", \_ _ -> dataToNewtype) + , ("Refactor.IfToGuards.Simple", \wd mod -> ifToGuards (readSrcSpan (toFileName wd mod) "3:11-3:33")) + , ("Refactor.DollarApp.FirstSingle", \wd mod -> dollarApp (readSrcSpan (toFileName wd mod) "5:5-5:12")) + , ("Refactor.DollarApp.FirstMulti", \wd mod -> dollarApp (readSrcSpan (toFileName wd mod) "5:5-5:16")) + , ("Refactor.DollarApp.InfixOperator", \wd mod -> dollarApp (readSrcSpan (toFileName wd mod) "5:5-5:16")) + , ("Refactor.DollarApp.AnotherOperator", \wd mod -> dollarApp (readSrcSpan (toFileName wd mod) "5:5-5:15")) + , ("Refactor.DollarApp.ImportDollar", \wd mod -> dollarApp (readSrcSpan (toFileName wd mod) "6:5-6:12")) + ] + +makeMultiModuleTest :: (String, String, String, [String]) -> Test +makeMultiModuleTest (refact, mod, root, removed) + = TestLabel (root ++ ":" ++ mod) $ TestCase + $ do res <- performRefactors refact (rootDir </> root) [] mod + case res of Right result -> checkResults result removed + Left err -> assertFailure $ "The transformation failed : " ++ err + where checkResults :: [(String, Maybe String)] -> [String] -> IO () + checkResults ((name, Just mod):rest) removed = + do expected <- loadExpected False ((rootDir </> root) ++ "_res") name + assertEqual "The transformed result is not what is expected" (standardizeLineEndings expected) + (standardizeLineEndings mod) + checkResults rest removed + checkResults ((name, Nothing) : rest) removed = checkResults rest (delete name removed) + checkResults [] [] = return () + checkResults [] removed = assertFailure $ "Modules has not been marked as removed: " ++ concat (intersperse ", " removed) + +createTest :: String -> [String] -> String -> Test +createTest refactoring args mod + = TestLabel mod $ TestCase $ checkCorrectlyTransformed (refactoring ++ (concatMap (" "++) args)) rootDir mod + +createFailTest :: String -> [String] -> String -> Test +createFailTest refactoring args mod + = TestLabel mod $ TestCase $ checkTransformFails (refactoring ++ (concatMap (" "++) args)) rootDir mod + +makeOrganizeImportsTest :: String -> Test +makeOrganizeImportsTest = createTest "OrganizeImports" [] + +makeGenerateSignatureTest :: (String, String) -> Test +makeGenerateSignatureTest (mod, rng) = createTest "GenerateSignature" [rng] mod + +makeGenerateExportsTest :: String -> Test +makeGenerateExportsTest mod = createTest "GenerateExports" [] mod + +makeRenameDefinitionTest :: (String, String, String) -> Test +makeRenameDefinitionTest (mod, rng, newName) = createTest "RenameDefinition" [rng, newName] mod + +makeWrongRenameDefinitionTest :: (String, String, String) -> Test +makeWrongRenameDefinitionTest (mod, rng, newName) = createFailTest "RenameDefinition" [rng, newName] mod + +makeExtractBindingTest :: (String, String, String) -> Test +makeExtractBindingTest (mod, rng, newName) = createTest "ExtractBinding" [rng, newName] mod + +makeWrongExtractBindingTest :: (String, String, String) -> Test +makeWrongExtractBindingTest (mod, rng, newName) = createFailTest "ExtractBinding" [rng, newName] mod + +checkCorrectlyTransformed :: String -> String -> String -> IO () +checkCorrectlyTransformed command workingDir moduleName + = do expected <- loadExpected True workingDir moduleName + res <- performRefactor command workingDir [] moduleName + assertEqual "The transformed result is not what is expected" (Right (standardizeLineEndings expected)) + (mapRight standardizeLineEndings res) +makeMiscRefactorTest :: (String, FilePath -> String -> LocalRefactoring IdDom) -> Test +makeMiscRefactorTest (moduleName, refact) + = TestLabel moduleName $ TestCase $ + do expected <- loadExpected True rootDir moduleName + res <- testRefactor (localRefactoring (refact rootDir moduleName)) moduleName + assertEqual "The transformed result is not what is expected" (Right (standardizeLineEndings expected)) + (mapRight standardizeLineEndings res) + +testRefactor :: Refactoring IdDom -> String -> IO (Either String String) +testRefactor refact moduleName + = runGhc (Just libdir) $ do + initGhcFlags + useDirs [rootDir] + mod <- loadModule rootDir moduleName >>= parseTyped + res <- runRefactor (toFileName rootDir moduleName, mod) [] refact + case res of Right r -> return $ Right $ prettyPrint $ snd $ fromContentChanged $ head r + Left err -> return $ Left err + +checkTransformFails :: String -> String -> String -> IO () +checkTransformFails command workingDir moduleName + = do res <- performRefactor command workingDir [] moduleName + assertBool "The transform should fail for the given input" (isLeft res) + +loadExpected :: Bool -> String -> String -> IO String +loadExpected resSuffix workingDir moduleName = + do -- need to use binary or line endings will be translated + expectedHandle <- openBinaryFile (workingDir </> map (\case '.' -> pathSeparator; c -> c) moduleName ++ (if resSuffix then "_res" else "") ++ ".hs") ReadMode + hGetContents expectedHandle + +standardizeLineEndings = filter (/= '\r') + +makeReprintTest :: String -> Test +makeReprintTest mod = TestLabel mod $ TestCase (checkCorrectlyPrinted rootDir mod) + +makeCpphsTest :: String -> Test +makeCpphsTest mod = TestLabel mod $ TestCase (checkCorrectlyPrinted (rootDir </> "CppHs") mod) + +makeInstanceControlTest :: String -> Test +makeInstanceControlTest mod = TestLabel mod $ TestCase (checkCorrectlyPrinted (rootDir </> "InstanceControl") mod) + +checkCorrectlyPrinted :: String -> String -> IO () +checkCorrectlyPrinted workingDir moduleName + = do -- need to use binary or line endings will be translated + expectedHandle <- openBinaryFile (workingDir </> map (\case '.' -> pathSeparator; c -> c) moduleName ++ ".hs") ReadMode + expected <- hGetContents expectedHandle + (actual, actual', actual'') <- runGhc (Just libdir) $ do + parsed <- loadModule workingDir moduleName + actual <- prettyPrint <$> parseAST parsed + actual' <- prettyPrint <$> parseRenamed parsed + actual'' <- prettyPrint <$> parseTyped parsed + return (actual, actual', actual'') + assertEqual "The original and the transformed source differ" expected actual + assertEqual "The original and the transformed source differ" expected actual' + assertEqual "The original and the transformed source differ" expected actual'' + + +performRefactors :: String -> String -> [String] -> String -> IO (Either String [(String, Maybe String)]) +performRefactors command workingDir flags target = do + mods <- getModules workingDir + runGhc (Just libdir) $ do + initGhcFlags + useFlags flags + useDirs (concatMap fst mods) + setTargets (map (\mod -> (Target (TargetModule (GHC.mkModuleName mod)) True Nothing)) (concatMap snd mods)) + load LoadAllTargets + allMods <- getModuleGraph + selectedMod <- getModSummary (GHC.mkModuleName target) + let otherModules = filter (not . (\ms -> ms_mod ms == ms_mod selectedMod && ms_hsc_src ms == ms_hsc_src selectedMod)) allMods + targetMod <- parseTyped selectedMod + otherMods <- mapM parseTyped otherModules + res <- performCommand (readCommand (toFileName workingDir target) command) + (target, targetMod) (zip (map (GHC.moduleNameString . moduleName . ms_mod) otherModules) otherMods) + return $ (\case Right r -> Right $ (map (\case ContentChanged (n,m) -> (n, Just $ prettyPrint m) + ModuleRemoved m -> (m, Nothing) + )) r + Left l -> Left l) + $ res + +type ParsedModule = Ann AST.UModule (Dom RdrName) SrcTemplateStage + +parseAST :: ModSummary -> Ghc ParsedModule +parseAST modSum = do + p <- parseModule modSum + let annots = pm_annotations p + srcBuffer = fromJust $ ms_hspp_buf $ pm_mod_summary p + prepareAST srcBuffer . placeComments (snd annots) + <$> (runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModule modSum $ pm_parsed_source p) + +type RenamedModule = Ann AST.UModule (Dom GHC.Name) SrcTemplateStage + +parseRenamed :: ModSummary -> Ghc RenamedModule +parseRenamed modSum = do + p <- parseModule modSum + tc <- typecheckModule p + let annots = pm_annotations p + srcBuffer = fromJust $ ms_hspp_buf $ pm_mod_summary p + prepareAST srcBuffer . placeComments (getNormalComments $ snd annots) + <$> (do parseTrf <- runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModule modSum (pm_parsed_source p) + runTrf (fst annots) (getPragmaComments $ snd annots) + $ trfModuleRename modSum parseTrf + (fromJust $ tm_renamed_source tc) + (pm_parsed_source p)) + +performRefactor :: String -> FilePath -> [String] -> String -> IO (Either String String) +performRefactor command workingDir flags target = + runGhc (Just libdir) $ do + initGhcFlags + useFlags flags + useDirs [workingDir] + ((\case Right r -> Right (newContent r); Left l -> Left l) <$> (refact =<< parseTyped =<< loadModule workingDir target)) + where refact m = performCommand (readCommand (toFileName workingDir target) command) (target,m) [] + newContent (ContentChanged (_, newContent) : ress) = prettyPrint newContent + newContent (_ : ress) = newContent ress + +-- tests for ast-gen + +genTests :: [Test] +genTests = testBase ++ map makeGenTest testExprs ++ map makeGenTest testPatterns ++ map makeGenTest testType + ++ map makeGenTest testBinds ++ map makeGenTest testDecls ++ map makeGenTest testModules + +makeGenTest :: SourceInfoTraversal elem => (String, Ann elem dom SrcTemplateStage) -> Test +makeGenTest (expected, ast) = TestLabel expected $ TestCase $ assertEqual "The generated AST is not what is expected" expected (prettyPrint ast) + +testBase + = [ makeGenTest ("A.b", mkNormalName $ mkQualifiedName ["A"] "b") + , makeGenTest ("A.+", mkQualOp ["A"] "+") + , makeGenTest ("`mod`", mkBacktickOp [] "mod") + , makeGenTest ("(+)", mkParenName $ mkSimpleName "+") + ] + +testExprs + = [ ("a + 3", mkInfixApp (mkVar (mkName "a")) (mkUnqualOp "+") (mkLit $ mkIntLit 3)) + , ("(\"xx\"++)", mkLeftSection (mkLit (mkStringLit "xx")) (mkUnqualOp "++")) + , ("(1, [2, 3])", mkTuple [ mkLit (mkIntLit 1), mkList [ mkLit (mkIntLit 2), mkLit (mkIntLit 3) ] ]) + , ("P { x = 1 }", mkRecCon (mkName "P") [ mkFieldUpdate (mkName "x") (mkLit $ mkIntLit 1) ]) + , ("if f a then x else y", mkIf (mkApp (mkVar $ mkName "f") (mkVar $ mkName "a")) (mkVar $ mkName "x") (mkVar $ mkName "y")) + , ("let nat = [0..] in !z", mkLet [mkLocalValBind $ mkSimpleBind' (mkName "nat") (mkEnum (mkLit (mkIntLit 0)) Nothing Nothing)] + (mkPrefixApp (mkUnqualOp "!") (mkVar $ mkName "z")) ) + , ( "case x of Just y -> y\n" + ++ " Nothing -> 0", mkCase (mkVar (mkName "x")) [ mkAlt (mkAppPat (mkName "Just") [mkVarPat (mkName "y")]) (mkCaseRhs $ mkVar (mkName "y")) Nothing + , mkAlt (mkVarPat $ mkName "Nothing") (mkCaseRhs $ mkLit $ mkIntLit 0) Nothing + ]) + , ( "if | x > y -> x\n" + ++ " | otherwise -> y", mkMultiIf [ mkGuardedCaseRhs [mkGuardCheck $ mkInfixApp (mkVar (mkName "x")) (mkUnqualOp ">") (mkVar (mkName "y"))] (mkVar (mkName "x")) + , mkGuardedCaseRhs [mkGuardCheck $ mkVar (mkName "otherwise")] (mkVar (mkName "y")) + ]) + , ( "do x <- a\n" + ++ " return x", mkDoBlock [ G.mkBindStmt (mkVarPat (mkName "x")) (mkVar (mkName "a")) + , mkExprStmt (mkApp (mkVar $ mkName "return") (mkVar $ mkName "x")) + ]) + ] + +testPatterns + = [ ("~[0, a]", mkIrrefutablePat $ mkListPat [ mkLitPat (mkIntLit 0), mkVarPat (mkName "a") ]) + , ("p@Point{ x = 1 }", mkAsPat (mkName "p") $ mkRecPat (mkName "Point") [ mkPatternField (mkName "x") (mkLitPat (mkIntLit 1)) ]) + , ("!(_, f -> 3)", mkBangPat $ mkTuplePat [mkWildPat, mkViewPat (mkVar $ mkName "f") (mkLitPat (mkIntLit 3))]) + ] + +testType + = [ ("forall x . Eq x => x -> ()", mkForallType [mkTypeVar (mkName "x")] + $ mkCtxType (mkContextOne (mkClassAssert (mkName "Eq") [mkVarType (mkName "x")])) + $ mkFunctionType (mkVarType (mkName "x")) (mkVarType (mkName "()"))) + , ("(A :+: B) (x, x)", mkTypeApp (mkParenType $ mkInfixTypeApp (mkVarType (mkName "A")) (mkUnqualOp ":+:") (mkVarType (mkName "B"))) + (mkTupleType [ mkVarType (mkName "x"), mkVarType (mkName "x") ])) + ] + +testBinds + = [( "x = (a, b) where a = 3\n" + ++ " b = 4", mkSimpleBind (mkVarPat (mkName "x")) (mkUnguardedRhs (mkTuple [(mkVar (mkName "a")), (mkVar (mkName "b"))])) + (Just $ mkLocalBinds' [ mkLocalValBind $ mkSimpleBind' (mkName "a") (mkLit $ mkIntLit 3) + , mkLocalValBind $ mkSimpleBind' (mkName "b") (mkLit $ mkIntLit 4) + ]) ) + ,( "f i 0 = i\n" + ++ "f i x = x", mkFunctionBind' (mkName "f") [ ([mkVarPat $ mkName "i", mkLitPat $ mkIntLit 0], mkVar $ mkName "i") + , ([mkVarPat $ mkName "i", mkVarPat $ mkName "x"], mkVar $ mkName "x") + ]) + ] + +testDecls + = [ ("id :: a -> a", mkTypeSigDecl $ mkTypeSignature (mkName "id") (mkFunctionType (mkVarType (mkName "a")) (mkVarType (mkName "a")))) + , ("id x = x", mkValueBinding $ mkFunctionBind' (mkName "id") [([mkVarPat $ mkName "x"], mkVar $ mkName "x")]) + , ("data A a = A a deriving Show", mkDataDecl mkDataKeyword Nothing (mkDeclHeadApp (mkNameDeclHead (mkName "A")) (mkTypeVar (mkName "a"))) + [mkConDecl (mkName "A") [mkVarType (mkName "a")]] (Just $ mkDeriving [mkInstanceHead (mkName "Show")])) + , ("data A = A { x :: Int }", mkDataDecl mkDataKeyword Nothing (mkNameDeclHead (mkName "A")) + [mkRecordConDecl (mkName "A") [mkFieldDecl [mkName "x"] (mkVarType (mkName "Int"))]] Nothing) + , ( "class A t => C t where f :: t\n" + ++ " type T t :: *" + , mkClassDecl (Just $ mkContextOne (mkClassAssert (mkName "A") [mkVarType (mkName "t")])) + (mkDeclHeadApp (mkNameDeclHead (mkName "C")) (mkTypeVar (mkName "t"))) [] + (Just $ mkClassBody [ mkClassElemSig $ mkTypeSignature (mkName "f") (mkVarType (mkName "t")) + , mkClassElemTypeFam (mkDeclHeadApp (mkNameDeclHead (mkName "T")) (mkTypeVar (mkName "t"))) + (Just $ mkTypeFamilyKindSpec $ mkKindConstraint $ mkKindStar) + ]) + ) + , ("instance C Int where f = 0", mkInstanceDecl Nothing (mkInstanceRule Nothing $ mkAppInstanceHead (mkInstanceHead $ mkName "C") (mkVarType (mkName "Int"))) + (Just $ mkInstanceBody [mkInstanceBind $ mkSimpleBind' (mkName "f") (mkLit $ mkIntLit 0)])) + , ("infixl 6 +", mkFixityDecl $ mkInfixL 6 (mkUnqualOp "+")) + ] + +testModules + = [ ("", G.mkModule [] Nothing [] []) + , ("module Test(x, A(a), B(..)) where", G.mkModule [] (Just $ mkModuleHead (G.mkModuleName "Test") (Just $ mkExportSpecs [ + mkExportSpec $ mkIESpec (mkName "x") Nothing + , mkExportSpec $ mkIESpec (mkName "A") (Just $ mkSubList [mkName "a"]) + , mkExportSpec $ mkIESpec (mkName "B") (Just mkSubAll) + ]) Nothing) [] []) + , ("\nimport qualified A\n" + ++ "import B as BB(x)\n" + ++ "import B hiding (x)", G.mkModule [] Nothing [ mkImportDecl False True False Nothing (G.mkModuleName "A") Nothing Nothing + , mkImportDecl False False False Nothing (G.mkModuleName "B") (Just $ G.mkModuleName "BB") (Just $ mkImportSpecList [mkIESpec (mkName "x") Nothing]) + , mkImportDecl False False False Nothing (G.mkModuleName "B") Nothing (Just $ mkImportHidingList [mkIESpec (mkName "x") Nothing]) + ] []) + ]