haskell-tools-refactor 0.1.3.0 → 0.2.0.0
raw patch · 18 files changed
+494/−1212 lines, 18 filesdep +Cabaldep +HUnitdep +haskell-tools-refactordep ~haskell-tools-astdep ~haskell-tools-ast-fromghcdep ~haskell-tools-ast-gensetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies added: Cabal, HUnit, haskell-tools-refactor, polyparse
Dependency ranges changed: haskell-tools-ast, haskell-tools-ast-fromghc, haskell-tools-ast-gen, haskell-tools-ast-trf, haskell-tools-prettyprint
API changes (from Hackage documentation)
- Language.Haskell.Tools.Refactor: astView :: String -> String -> IO String
- Language.Haskell.Tools.Refactor: demoRefactor :: String -> String -> String -> IO ()
- Language.Haskell.Tools.Refactor: instance (GHC.Generics.Generic sema, GHC.Generics.Generic src) => GHC.Generics.Generic (Language.Haskell.Tools.AST.SemaInfoTypes.NodeInfo sema src)
- Language.Haskell.Tools.Refactor: instance GHC.Generics.Generic SrcLoc.SrcSpan
- Language.Haskell.Tools.Refactor: onlineASTView :: FilePath -> String -> IO (Either String String)
- Language.Haskell.Tools.Refactor: onlineRefactor :: String -> FilePath -> String -> IO (Either String String)
- Language.Haskell.Tools.Refactor: parseRenamed :: ModSummary -> Ghc (Ann Module (Dom Name) SrcTemplateStage)
- Language.Haskell.Tools.Refactor: performRefactor :: String -> String -> String -> IO (Either String String)
- Language.Haskell.Tools.Refactor.RefactorBase: RefactorT :: WriterT [Name] (ReaderT (RefactorCtx dom) m) a -> RefactorT dom m a
- Language.Haskell.Tools.Refactor.RefactorBase: instance (GHC.Base.Monad m, DynFlags.HasDynFlags m) => DynFlags.HasDynFlags (Language.Haskell.Tools.Refactor.RefactorBase.RefactorT dom m)
- Language.Haskell.Tools.Refactor.RefactorBase: instance Control.Monad.IO.Class.MonadIO m => Control.Monad.IO.Class.MonadIO (Language.Haskell.Tools.Refactor.RefactorBase.RefactorT dom m)
- Language.Haskell.Tools.Refactor.RefactorBase: instance Control.Monad.Trans.Class.MonadTrans (Language.Haskell.Tools.Refactor.RefactorBase.RefactorT dom)
- Language.Haskell.Tools.Refactor.RefactorBase: instance Exception.ExceptionMonad m => Exception.ExceptionMonad (Language.Haskell.Tools.Refactor.RefactorBase.RefactorT dom m)
- Language.Haskell.Tools.Refactor.RefactorBase: instance GHC.Base.Applicative m => GHC.Base.Applicative (Language.Haskell.Tools.Refactor.RefactorBase.RefactorT dom m)
- Language.Haskell.Tools.Refactor.RefactorBase: instance GHC.Base.Functor m => GHC.Base.Functor (Language.Haskell.Tools.Refactor.RefactorBase.RefactorT dom m)
- Language.Haskell.Tools.Refactor.RefactorBase: instance GHC.Base.Monad m => Control.Monad.Reader.Class.MonadReader (Language.Haskell.Tools.Refactor.RefactorBase.RefactorCtx dom) (Language.Haskell.Tools.Refactor.RefactorBase.RefactorT dom m)
- Language.Haskell.Tools.Refactor.RefactorBase: instance GHC.Base.Monad m => Control.Monad.Writer.Class.MonadWriter [Name.Name] (Language.Haskell.Tools.Refactor.RefactorBase.RefactorT dom m)
- Language.Haskell.Tools.Refactor.RefactorBase: instance GHC.Base.Monad m => GHC.Base.Monad (Language.Haskell.Tools.Refactor.RefactorBase.RefactorT dom m)
- Language.Haskell.Tools.Refactor.RefactorBase: instance GhcMonad.GhcMonad m => GhcMonad.GhcMonad (Language.Haskell.Tools.Refactor.RefactorBase.RefactorT dom m)
- Language.Haskell.Tools.Refactor.RefactorBase: newtype RefactorT dom m a
- Language.Haskell.Tools.Refactor.RefactorBase: type RefactoredModule dom = Refactor dom (Ann Module dom SrcTemplateStage)
+ Language.Haskell.Tools.Refactor: IsHsBoot :: IsBoot
+ Language.Haskell.Tools.Refactor: NormalHs :: IsBoot
+ Language.Haskell.Tools.Refactor: analyzeCommand :: String -> String -> [String] -> RefactorCommand
+ Language.Haskell.Tools.Refactor: data IsBoot
+ 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: 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.GetModules: getModules :: FilePath -> IO [String]
+ Language.Haskell.Tools.Refactor.GetModules: modulesFromCabalFile :: FilePath -> IO [String]
+ Language.Haskell.Tools.Refactor.GetModules: modulesFromDirectory :: FilePath -> FilePath -> IO [String]
+ Language.Haskell.Tools.Refactor.IfToGuards: ifToGuards :: Domain dom => RealSrcSpan -> LocalRefactoring dom
+ Language.Haskell.Tools.Refactor.RefactorBase: ContentChanged :: (ModuleDom dom) -> RefactorChange dom
+ Language.Haskell.Tools.Refactor.RefactorBase: LocalRefactorT :: WriterT [Name] (ReaderT (RefactorCtx dom) m) a -> LocalRefactorT dom m a
+ Language.Haskell.Tools.Refactor.RefactorBase: ModuleRemoved :: String -> RefactorChange dom
+ Language.Haskell.Tools.Refactor.RefactorBase: [fromContentChanged] :: RefactorChange dom -> (ModuleDom dom)
+ Language.Haskell.Tools.Refactor.RefactorBase: [refCtxRoot] :: RefactorCtx dom -> Ann Module dom SrcTemplateStage
+ Language.Haskell.Tools.Refactor.RefactorBase: [removedModuleName] :: RefactorChange dom -> String
+ Language.Haskell.Tools.Refactor.RefactorBase: class Monad m => RefactorMonad m
+ Language.Haskell.Tools.Refactor.RefactorBase: data RefactorChange 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.RefactorBase: instance Control.Monad.IO.Class.MonadIO m => Control.Monad.IO.Class.MonadIO (Language.Haskell.Tools.Refactor.RefactorBase.LocalRefactorT dom m)
+ Language.Haskell.Tools.Refactor.RefactorBase: instance Control.Monad.Trans.Class.MonadTrans (Language.Haskell.Tools.Refactor.RefactorBase.LocalRefactorT dom)
+ Language.Haskell.Tools.Refactor.RefactorBase: instance Exception.ExceptionMonad m => Exception.ExceptionMonad (Language.Haskell.Tools.Refactor.RefactorBase.LocalRefactorT dom m)
+ Language.Haskell.Tools.Refactor.RefactorBase: instance GHC.Base.Applicative m => GHC.Base.Applicative (Language.Haskell.Tools.Refactor.RefactorBase.LocalRefactorT dom m)
+ Language.Haskell.Tools.Refactor.RefactorBase: instance GHC.Base.Functor m => GHC.Base.Functor (Language.Haskell.Tools.Refactor.RefactorBase.LocalRefactorT dom m)
+ Language.Haskell.Tools.Refactor.RefactorBase: instance GHC.Base.Monad m => Control.Monad.Reader.Class.MonadReader (Language.Haskell.Tools.Refactor.RefactorBase.RefactorCtx dom) (Language.Haskell.Tools.Refactor.RefactorBase.LocalRefactorT dom m)
+ Language.Haskell.Tools.Refactor.RefactorBase: instance GHC.Base.Monad m => Control.Monad.Writer.Class.MonadWriter [Name.Name] (Language.Haskell.Tools.Refactor.RefactorBase.LocalRefactorT dom m)
+ Language.Haskell.Tools.Refactor.RefactorBase: instance GHC.Base.Monad m => GHC.Base.Monad (Language.Haskell.Tools.Refactor.RefactorBase.LocalRefactorT dom m)
+ Language.Haskell.Tools.Refactor.RefactorBase: instance GhcMonad.GhcMonad m => GhcMonad.GhcMonad (Language.Haskell.Tools.Refactor.RefactorBase.LocalRefactorT dom m)
+ Language.Haskell.Tools.Refactor.RefactorBase: instance Language.Haskell.Tools.Refactor.RefactorBase.RefactorMonad (Language.Haskell.Tools.Refactor.RefactorBase.LocalRefactor dom)
+ Language.Haskell.Tools.Refactor.RefactorBase: instance Language.Haskell.Tools.Refactor.RefactorBase.RefactorMonad Language.Haskell.Tools.Refactor.RefactorBase.Refactor
+ Language.Haskell.Tools.Refactor.RefactorBase: instance Language.Haskell.Tools.Refactor.RefactorBase.RefactorMonad m => Language.Haskell.Tools.Refactor.RefactorBase.RefactorMonad (Control.Monad.Trans.State.Lazy.StateT s m)
+ Language.Haskell.Tools.Refactor.RefactorBase: liftGhc :: RefactorMonad m => Ghc a -> m a
+ Language.Haskell.Tools.Refactor.RefactorBase: localRefactoring :: HasModuleInfo dom => LocalRefactoring dom -> Refactoring dom
+ Language.Haskell.Tools.Refactor.RefactorBase: localRefactoringRes :: HasModuleInfo dom => ((UnnamedModule dom -> UnnamedModule dom) -> a -> a) -> UnnamedModule dom -> LocalRefactor dom a -> Refactor a
+ Language.Haskell.Tools.Refactor.RefactorBase: newtype LocalRefactorT dom m a
+ Language.Haskell.Tools.Refactor.RefactorBase: type LocalRefactor dom = LocalRefactorT dom Refactor
+ Language.Haskell.Tools.Refactor.RefactorBase: type LocalRefactoring dom = UnnamedModule dom -> LocalRefactor dom (UnnamedModule dom)
+ Language.Haskell.Tools.Refactor.RefactorBase: type ModuleDom dom = (String, UnnamedModule dom)
+ Language.Haskell.Tools.Refactor.RefactorBase: type Refactoring dom = ModuleDom dom -> [ModuleDom dom] -> Refactor [RefactorChange dom]
+ Language.Haskell.Tools.Refactor.RefactorBase: type UnnamedModule dom = Ann Module dom SrcTemplateStage
+ Language.Haskell.Tools.Refactor.RefactorBase: validModuleName :: String -> Bool
- Language.Haskell.Tools.Refactor: parseTyped :: ModSummary -> Ghc (Ann Module IdDom SrcTemplateStage)
+ Language.Haskell.Tools.Refactor: parseTyped :: ModSummary -> Ghc TypedModule
- Language.Haskell.Tools.Refactor: performCommand :: (SemanticInfo' dom SameInfoModuleCls ~ ModuleInfo n, DomGenerateExports dom, OrganizeImportsDomain dom n, DomainRenameDefinition dom, ExtractBindingDomain dom, GenerateSignatureDomain dom) => RefactorCommand -> Ann Module dom SrcTemplateStage -> Ghc (Either String (Ann Module dom SrcTemplateStage))
+ 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.ExtractBinding: doExtract :: ExtractBindingDomain dom => String -> Ann' Expr dom -> Ann' Expr dom -> StateT (Maybe (Ann' ValueBind dom)) (Refactor dom) (Ann' Expr dom)
+ 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 -> Ann' Module dom -> RefactoredModule 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 -> Ann' Module dom -> RefactoredModule 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)) (Refactor dom) (Ann' Expr 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: isConflicting :: ExtractBindingDomain dom => String -> Ann' SimpleName dom -> Bool
+ Language.Haskell.Tools.Refactor.ExtractBinding: isConflicting :: ExtractBindingDomain dom => String -> Ann' QualifiedName dom -> Bool
- Language.Haskell.Tools.Refactor.ExtractBinding: type ExtractBindingDomain dom = (Domain dom, HasNameInfo (SemanticInfo' dom SameInfoNameCls), HasDefiningInfo (SemanticInfo' dom SameInfoNameCls), HasScopeInfo (SemanticInfo' dom SameInfoExprCls))
+ Language.Haskell.Tools.Refactor.ExtractBinding: type ExtractBindingDomain dom = (Domain dom, HasNameInfo dom, HasDefiningInfo dom, HasScopeInfo dom)
- Language.Haskell.Tools.Refactor.GenerateExports: generateExports :: DomGenerateExports dom => Ann Module dom SrcTemplateStage -> RefactoredModule dom
+ Language.Haskell.Tools.Refactor.GenerateExports: generateExports :: DomGenerateExports dom => LocalRefactoring dom
- Language.Haskell.Tools.Refactor.GenerateExports: type DomGenerateExports dom = (Domain dom, HasNameInfo (SemanticInfo' dom SameInfoNameCls))
+ 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)) -> Ann' Module dom -> RefactoredModule 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 -> Ann' Module dom -> RefactoredModule dom
+ Language.Haskell.Tools.Refactor.GenerateTypeSignature: generateTypeSignature' :: GenerateSignatureDomain dom => RealSrcSpan -> LocalRefactoring dom
- Language.Haskell.Tools.Refactor.GenerateTypeSignature: type GenerateSignatureDomain dom = (Domain dom, HasIdInfo (SemanticInfo' dom SameInfoNameCls), Eq (SemanticInfo' dom SameInfoNameCls), SemanticInfo' dom SameInfoImportCls ~ ImportInfo Id)
+ Language.Haskell.Tools.Refactor.GenerateTypeSignature: type GenerateSignatureDomain dom = (HasModuleInfo dom, HasIdInfo dom, HasImportInfo dom)
- Language.Haskell.Tools.Refactor.OrganizeImports: organizeImports :: forall n dom. OrganizeImportsDomain dom n => Ann Module dom SrcTemplateStage -> RefactoredModule dom
+ Language.Haskell.Tools.Refactor.OrganizeImports: organizeImports :: forall dom. OrganizeImportsDomain dom => LocalRefactoring dom
- Language.Haskell.Tools.Refactor.OrganizeImports: type OrganizeImportsDomain dom n = (Domain dom, HasNameInfo (SemanticInfo' dom SameInfoNameCls), SemanticInfo' dom SameInfoImportCls ~ ImportInfo n, NamedThing n)
+ Language.Haskell.Tools.Refactor.OrganizeImports: type OrganizeImportsDomain dom = (Domain dom, HasNameInfo dom, HasImportInfo dom)
- Language.Haskell.Tools.Refactor.RefactorBase: RefactorCtx :: Module -> [Ann ImportDecl dom SrcTemplateStage] -> RefactorCtx dom
+ Language.Haskell.Tools.Refactor.RefactorBase: RefactorCtx :: Module -> Ann Module dom SrcTemplateStage -> [Ann ImportDecl dom SrcTemplateStage] -> RefactorCtx dom
- Language.Haskell.Tools.Refactor.RefactorBase: [fromRefactorT] :: RefactorT dom m a -> WriterT [Name] (ReaderT (RefactorCtx dom) m) a
+ Language.Haskell.Tools.Refactor.RefactorBase: [fromRefactorT] :: LocalRefactorT dom m a -> WriterT [Name] (ReaderT (RefactorCtx dom) m) a
- Language.Haskell.Tools.Refactor.RefactorBase: addGeneratedImports :: (Monad m) => ReaderT (RefactorCtx dom) m (Ann Module dom SrcTemplateStage, [Name]) -> ReaderT (RefactorCtx dom) m (Ann Module dom SrcTemplateStage)
+ Language.Haskell.Tools.Refactor.RefactorBase: addGeneratedImports :: [Name] -> Ann Module dom SrcTemplateStage -> Ann Module dom SrcTemplateStage
- Language.Haskell.Tools.Refactor.RefactorBase: classifyName :: Name -> Refactor dom NameClass
+ Language.Haskell.Tools.Refactor.RefactorBase: classifyName :: RefactorMonad m => Name -> m NameClass
- Language.Haskell.Tools.Refactor.RefactorBase: refactError :: String -> Refactor n a
+ Language.Haskell.Tools.Refactor.RefactorBase: refactError :: RefactorMonad m => String -> m a
- Language.Haskell.Tools.Refactor.RefactorBase: referenceName :: (SemanticInfo' dom SameInfoImportCls ~ ImportInfo n, Eq n, NamedThing n) => n -> Refactor dom (Ann Name 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' :: (SemanticInfo' dom SameInfoImportCls ~ ImportInfo n, Eq n, NamedThing n) => ([String] -> Name -> Ann nt dom SrcTemplateStage) -> n -> Refactor dom (Ann nt dom SrcTemplateStage)
+ Language.Haskell.Tools.Refactor.RefactorBase: referenceName' :: (HasImportInfo dom, HasModuleInfo dom) => ([String] -> Name -> Ann nt dom SrcTemplateStage) -> Name -> LocalRefactor dom (Ann nt dom SrcTemplateStage)
- Language.Haskell.Tools.Refactor.RefactorBase: referenceOperator :: (SemanticInfo' dom SameInfoImportCls ~ ImportInfo n, Eq n, NamedThing n) => n -> Refactor dom (Ann Operator dom SrcTemplateStage)
+ Language.Haskell.Tools.Refactor.RefactorBase: referenceOperator :: (HasImportInfo dom, HasModuleInfo dom) => Name -> LocalRefactor dom (Ann Operator dom SrcTemplateStage)
- Language.Haskell.Tools.Refactor.RefactorBase: runRefactor :: (SemanticInfo' dom SameInfoModuleCls ~ ModuleInfo n) => Ann Module dom SrcTemplateStage -> (Ann Module dom SrcTemplateStage -> RefactoredModule dom) -> Ghc (Either String (Ann Module dom SrcTemplateStage))
+ Language.Haskell.Tools.Refactor.RefactorBase: runRefactor :: (HasModuleInfo dom) => ModuleDom dom -> [ModuleDom dom] -> Refactoring dom -> Ghc (Either String [RefactorChange dom])
- Language.Haskell.Tools.Refactor.RefactorBase: type Refactor dom = RefactorT dom (ExceptT String Ghc)
+ Language.Haskell.Tools.Refactor.RefactorBase: type Refactor = ExceptT String Ghc
- Language.Haskell.Tools.Refactor.RenameDefinition: renameDefinition :: DomainRenameDefinition dom => Name -> String -> Ann Module dom SrcTemplateStage -> RefactoredModule dom
+ 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 -> Ann Module dom SrcTemplateStage -> RefactoredModule dom
+ Language.Haskell.Tools.Refactor.RenameDefinition: renameDefinition' :: forall dom. DomainRenameDefinition dom => RealSrcSpan -> String -> Refactoring dom
- Language.Haskell.Tools.Refactor.RenameDefinition: type DomainRenameDefinition dom = (Domain dom, HasNameInfo (SemanticInfo' dom SameInfoNameCls), Data (SemanticInfo' dom SameInfoNameCls), HasScopeInfo (SemanticInfo' dom SameInfoNameCls), HasDefiningInfo (SemanticInfo' dom SameInfoNameCls))
+ Language.Haskell.Tools.Refactor.RenameDefinition: type DomainRenameDefinition dom = (HasNameInfo dom, HasScopeInfo dom, HasDefiningInfo dom, HasImplicitFieldsInfo dom, HasModuleInfo dom)
Files
- Language/Haskell/Tools/Refactor.hs +102/−157
- Language/Haskell/Tools/Refactor/ASTDebug.hs +0/−223
- Language/Haskell/Tools/Refactor/ASTDebug/Instances.hs +0/−150
- Language/Haskell/Tools/Refactor/DataToNewtype.hs +20/−0
- Language/Haskell/Tools/Refactor/DebugGhcAST.hs +0/−368
- Language/Haskell/Tools/Refactor/DollarApp.hs +54/−0
- Language/Haskell/Tools/Refactor/ExtractBinding.hs +7/−8
- Language/Haskell/Tools/Refactor/GenerateExports.hs +2/−2
- Language/Haskell/Tools/Refactor/GenerateTypeSignature.hs +14/−15
- Language/Haskell/Tools/Refactor/GetModules.hs +40/−0
- Language/Haskell/Tools/Refactor/IfToGuards.hs +34/−0
- Language/Haskell/Tools/Refactor/OrganizeImports.hs +17/−19
- Language/Haskell/Tools/Refactor/RangeDebug.hs +0/−53
- Language/Haskell/Tools/Refactor/RangeDebug/Instances.hs +0/−139
- Language/Haskell/Tools/Refactor/RefactorBase.hs +88/−35
- Language/Haskell/Tools/Refactor/RenameDefinition.hs +74/−28
- Setup.hs +1/−1
- haskell-tools-refactor.cabal +41/−14
Language/Haskell/Tools/Refactor.hs view
@@ -6,7 +6,11 @@ , 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 @@ -18,10 +22,6 @@ import Language.Haskell.Tools.AnnTrf.PlaceComments import Language.Haskell.Tools.PrettyPrint.RoseTree import Language.Haskell.Tools.PrettyPrint -import Language.Haskell.Tools.Refactor.RangeDebug -import Language.Haskell.Tools.Refactor.RangeDebug.Instances -import Language.Haskell.Tools.Refactor.ASTDebug -import Language.Haskell.Tools.Refactor.ASTDebug.Instances import GHC hiding (loadModule) import Panic (handleGhcException) @@ -30,10 +30,11 @@ import Bag import Var import SrcLoc -import Module +import Module as GHC import FastString import HscTypes import GHC.Paths ( libdir ) +import CmdLineParser import Data.List import Data.List.Split @@ -41,9 +42,7 @@ import qualified Data.Map as Map import Data.Maybe import Data.Typeable -import Data.Time.Clock import Data.IORef -import Data.Either.Combinators import Control.Monad import Control.Monad.State import Control.Monad.IO.Class @@ -54,13 +53,13 @@ import System.FilePath import Data.Generics.Uniplate.Operations -import Language.Haskell.Tools.Refactor.DebugGhcAST 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.Refactor.RefactorBase +import Language.Haskell.Tools.Refactor.GetModules import Language.Haskell.TH.LanguageExtensions @@ -68,103 +67,62 @@ import StringBuffer import Debug.Trace - -data RefactorCommand = NoRefactor - | OrganizeImports - | GenerateExports - | GenerateSignature RealSrcSpan - | RenameDefinition RealSrcSpan String - | ExtractBinding RealSrcSpan String - deriving Show -performCommand :: (SemanticInfo' dom SameInfoModuleCls ~ AST.ModuleInfo n, DomGenerateExports dom, OrganizeImportsDomain dom n, DomainRenameDefinition dom, ExtractBindingDomain dom, GenerateSignatureDomain dom) - => RefactorCommand -> Ann AST.Module dom SrcTemplateStage -> Ghc (Either String (Ann AST.Module dom SrcTemplateStage)) -performCommand rf mod = runRefactor mod $ selectCommand rf - where selectCommand NoRefactor = return - selectCommand OrganizeImports = organizeImports - selectCommand GenerateExports = generateExports - selectCommand (GenerateSignature sp) = generateTypeSignature' sp - selectCommand (RenameDefinition sp str) = renameDefinition' sp str - selectCommand (ExtractBinding sp str) = extractBinding' sp str -readCommand :: String -> String -> RefactorCommand -readCommand fileName s = case splitOn " " s of - [""] -> NoRefactor - ("CheckSource":_) -> NoRefactor - ("OrganizeImports":_) -> OrganizeImports - ("GenerateExports":_) -> GenerateExports - ["GenerateSignature", sp] -> GenerateSignature (readSrcSpan fileName sp) - ["RenameDefinition", sp, name] -> RenameDefinition (readSrcSpan fileName sp) name - ["ExtractBinding", sp, name] -> ExtractBinding (readSrcSpan fileName sp) name - -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) - -onlineRefactor :: String -> FilePath -> String -> IO (Either String String) -onlineRefactor command workingDir moduleStr - = do withBinaryFile fileName WriteMode (`hPutStr` moduleStr) - modOpts <- runGhc (Just libdir) $ ms_hspp_opts <$> loadModule workingDir moduleName - if | xopt Cpp modOpts -> return (Left "The use of C preprocessor is not supported, please turn off Cpp extension") - | xopt TemplateHaskell modOpts -> return (Left "The use of Template Haskell is not supported yet, please turn off TemplateHaskell extension") - | xopt EmptyCase modOpts -> return (Left "The ranges in the AST are not correct for empty cases, therefore the EmptyCase extension is disabled") - | xopt ImplicitParams modOpts -> return (Left "Implicit parameters are erased early on by the compiler, we cannot support them") - | otherwise -> do - res <- performRefactor command workingDir moduleName - removeFile fileName - return res - where moduleName = "Test" - fileName = workingDir </> (moduleName ++ ".hs") +-- | Use the given source directories +useDirs :: [FilePath] -> Ghc () +useDirs workingDirs = do + dynflags <- getSessionDynFlags + setSessionDynFlags dynflags { importPaths = importPaths dynflags ++ workingDirs } + return () -onlineASTView :: FilePath -> String -> IO (Either String String) -onlineASTView workingDir moduleStr - = do withBinaryFile fileName WriteMode (`hPutStr` moduleStr) - modOpts <- runGhc (Just libdir) $ ms_hspp_opts <$> loadModule workingDir moduleName - if | xopt Cpp modOpts -> return (Left "The use of C preprocessor is not supported, please turn off Cpp extension") - | xopt TemplateHaskell modOpts -> return (Left "The use of Template Haskell is not supported yet, please turn off TemplateHaskell extension") - | xopt EmptyCase modOpts -> return (Left "The ranges in the AST are not correct for empty cases, therefore the EmptyCase extension is disabled") - | xopt ImplicitParams modOpts -> return (Left "Implicit parameters are erased early on by the compiler, we cannot support them") - | otherwise -> do - res <- astView workingDir moduleName - removeFile fileName - return (Right res) - where moduleName = "Test" - fileName = workingDir </> (moduleName ++ ".hs") +-- | 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 () -performRefactor :: String -> String -> String -> IO (Either String String) -performRefactor command workingDir target = - runGhc (Just libdir) $ - (mapRight prettyPrint <$> (refact =<< parseTyped =<< loadModule workingDir target)) - where refact = performCommand (readCommand (workingDir </> (map (\case '.' -> '\\'; c -> c) target ++ ".hs")) command) +-- | 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" -astView :: String -> String -> IO String -astView workingDir target = - runGhc (Just libdir) $ - (astDebug <$> (parseTyped =<< loadModule workingDir target)) +-- | 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 dflags <- getSessionDynFlags - -- don't generate any code - setSessionDynFlags - $ flip gopt_set Opt_KeepRawTokenStream - $ flip gopt_set Opt_NoHsMain - $ dflags { importPaths = [workingDir] - , hscTarget = HscInterpreted - , ghcLink = LinkInMemory - , ghcMode = CompManager - } + = do initGhcFlags + useDirs [workingDir] target <- guessTarget moduleName Nothing setTargets [target] load LoadAllTargets getModSummary $ mkModuleName moduleName -parseTyped :: ModSummary -> Ghc (Ann AST.Module IdDom SrcTemplateStage) +-- | 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 @@ -172,75 +130,62 @@ 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 (ms_mod modSum) (pm_parsed_source p) + =<< (do parseTrf <- runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModule modSum (pm_parsed_source p) runTrf (fst annots) (getPragmaComments $ snd annots) - $ trfModuleRename (ms_mod $ modSum) parseTrf + $ trfModuleRename modSum parseTrf (fromJust $ tm_renamed_source tc) (pm_parsed_source p))) -parseRenamed :: ModSummary -> Ghc (Ann AST.Module (Dom GHC.Name) SrcTemplateStage) -parseRenamed 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) - <$> (do parseTrf <- runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModule (ms_mod modSum) (pm_parsed_source p) - runTrf (fst annots) (getPragmaComments $ snd annots) - $ trfModuleRename (ms_mod $ modSum) parseTrf - (fromJust $ tm_renamed_source tc) - (pm_parsed_source p)) - --- | Should be only used for testing -demoRefactor :: String -> String -> String -> IO () -demoRefactor command workingDir moduleName = - runGhc (Just libdir) $ do - modSum <- loadModule workingDir moduleName - p <- parseModule modSum - t <- typecheckModule p - - let r = tm_renamed_source t - let annots = pm_annotations $ tm_parsed_module t +-- | 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 - -- liftIO $ putStrLn $ show annots - liftIO $ putStrLn $ show (pm_parsed_source p) - liftIO $ putStrLn "===========" - liftIO $ putStrLn $ show (fromJust $ tm_renamed_source t) - --liftIO $ putStrLn $ show (typecheckedSource t) - liftIO $ putStrLn "=========== parsed:" - --transformed <- runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModule (pm_parsed_source p) - parseTrf <- runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModule (ms_mod modSum) (pm_parsed_source p) - liftIO $ putStrLn $ srcInfoDebug parseTrf - liftIO $ putStrLn "=========== typed:" - transformed <- addTypeInfos (typecheckedSource t) =<< (runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModuleRename (ms_mod $ modSum) parseTrf (fromJust $ tm_renamed_source t) (pm_parsed_source p)) - liftIO $ putStrLn $ srcInfoDebug transformed - liftIO $ putStrLn "=========== ranges fixed:" - let commented = fixRanges $ placeComments (getNormalComments $ snd annots) transformed - liftIO $ putStrLn $ srcInfoDebug commented - liftIO $ putStrLn "=========== cut up:" - let cutUp = cutUpRanges commented - liftIO $ putStrLn $ srcInfoDebug cutUp - liftIO $ putStrLn $ show $ getLocIndices cutUp - liftIO $ putStrLn $ show $ mapLocIndices (fromJust $ ms_hspp_buf $ pm_mod_summary p) (getLocIndices cutUp) - liftIO $ putStrLn "=========== sourced:" - let sourced = rangeToSource (fromJust $ ms_hspp_buf $ pm_mod_summary p) cutUp - liftIO $ putStrLn $ srcInfoDebug sourced - liftIO $ putStrLn "=========== pretty printed:" - let prettyPrinted = prettyPrint sourced - liftIO $ putStrLn prettyPrinted - transformed <- performCommand (readCommand (fromJust $ ml_hs_file $ ms_location modSum) command) sourced - case transformed of - Right correctlyTransformed -> do - liftIO $ putStrLn "=========== transformed AST:" - liftIO $ putStrLn $ srcInfoDebug correctlyTransformed - liftIO $ putStrLn "=========== transformed & prettyprinted:" - let prettyPrinted = prettyPrint correctlyTransformed - liftIO $ putStrLn prettyPrinted - liftIO $ putStrLn "===========" - Left transformProblem -> do - liftIO $ putStrLn "===========" - liftIO $ putStrLn transformProblem - liftIO $ putStrLn "===========" +-- | 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) -deriving instance Generic SrcSpan -deriving instance (Generic sema, Generic src) => Generic (NodeInfo sema src) +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) + +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
− Language/Haskell/Tools/Refactor/ASTDebug.hs
@@ -1,223 +0,0 @@-{-# LANGUAGE TypeOperators - , DefaultSignatures - , StandaloneDeriving - , FlexibleContexts - , FlexibleInstances - , MultiParamTypeClasses - , TypeFamilies - , TemplateHaskell - , OverloadedStrings - , ConstraintKinds - , LambdaCase - , ViewPatterns - , ScopedTypeVariables - , UndecidableInstances - #-} --- | A module for displaying the AST in a tree view. -module Language.Haskell.Tools.Refactor.ASTDebug where - -import GHC.Generics -import Control.Reference -import Control.Applicative -import Data.Sequence as Seq -import Data.Foldable -import Data.Maybe -import Data.List as List -import SrcLoc -import Outputable - -import DynFlags as GHC -import Name as GHC -import Id as GHC -import RdrName as GHC -import Unique as GHC - -import Language.Haskell.Tools.AST -import Language.Haskell.Tools.AST.FromGHC -import Language.Haskell.Tools.AnnTrf.RangeToRangeTemplate -import Language.Haskell.Tools.AnnTrf.RangeTemplate -import Language.Haskell.Tools.AnnTrf.SourceTemplate -import Language.Haskell.Tools.Refactor.RangeDebug - - -data DebugNode dom = TreeNode { _nodeLabel :: String - , _nodeSubtree :: TreeDebugNode dom - } - | SimpleNode { _nodeLabel :: String - , _nodeValue :: String - } - -deriving instance Domain dom => Show (DebugNode dom) - -data TreeDebugNode dom - = TreeDebugNode { _nodeName :: String - , _nodeInfo :: SemanticInfoType dom - , _children :: [DebugNode dom] - } - -deriving instance Domain dom => Show (TreeDebugNode dom) - -data SemanticInfoType dom - = DefaultInfoType { semaInfoTypeRng :: SrcSpan - } - | NameInfoType { semaInfoTypeName :: SemanticInfo' dom SameInfoNameCls - , semaInfoTypeRng :: SrcSpan - } - | ExprInfoType { semaInfoTypeExpr :: SemanticInfo' dom SameInfoExprCls - , semaInfoTypeRng :: SrcSpan - } - | ImportInfoType { semaInfoTypeImport :: SemanticInfo' dom SameInfoImportCls - , semaInfoTypeRng :: SrcSpan - } - | ModuleInfoType { semaInfoTypeModule :: SemanticInfo' dom SameInfoModuleCls - , semaInfoTypeRng :: SrcSpan - } - -deriving instance Domain dom => Show (SemanticInfoType dom) - -makeReferences ''DebugNode -makeReferences ''TreeDebugNode - -type AssocSema dom = ( AssocData (SemanticInfo' dom SameInfoModuleCls), AssocData (SemanticInfo' dom SameInfoImportCls) - , AssocData (SemanticInfo' dom SameInfoNameCls), AssocData (SemanticInfo' dom SameInfoExprCls) ) - -astDebug :: (ASTDebug e dom st, AssocSema dom) => e dom st -> String -astDebug ast = toList (astDebugToJson (astDebug' ast)) - -astDebugToJson :: AssocSema dom => [DebugNode dom] -> Seq Char -astDebugToJson nodes = fromList "[ " >< childrenJson >< fromList " ]" - where treeNodes = List.filter (\case TreeNode {} -> True; _ -> False) nodes - childrenJson = case map debugTreeNode treeNodes of - first:rest -> first >< foldl (><) Seq.empty (fmap (fromList ", " ><) (fromList rest)) - [] -> Seq.empty - debugTreeNode (TreeNode "" s) = astDebugElemJson s - debugTreeNode (TreeNode (dropWhile (=='_') -> l) s) = astDebugElemJson (nodeName .- (("<span class='astlab'>" ++ l ++ "</span>: ") ++) $ s) - -astDebugElemJson :: AssocSema dom => TreeDebugNode dom -> Seq Char -astDebugElemJson (TreeDebugNode name info children) - = fromList "{ \"text\" : \"" >< fromList name - >< fromList "\", \"state\" : { \"opened\" : true }, \"a_attr\" : { \"data-range\" : \"" - >< fromList (shortShowSpan (semaInfoTypeRng info)) - >< fromList "\", \"data-elems\" : \"" - >< foldl (><) Seq.empty dataElems - >< fromList "\", \"data-sema\" : \"" - >< fromList (showSema info) - >< fromList "\" }, \"children\" : " - >< astDebugToJson children >< fromList " }" - where dataElems = catMaybes (map (\case SimpleNode l v -> Just (fromList (formatScalarElem l v)); _ -> Nothing) children) - formatScalarElem l v = "<div class='scalarelem'><span class='astlab'>" ++ l ++ "</span>: " ++ tail (init (show v)) ++ "</div>" - showSema info = "<div class='semaname'>" ++ assocName info ++ "</div>" - ++ concatMap (\(l,i) -> "<div class='scalarelem'><span class='astlab'>" ++ l ++ "</span>: " ++ i ++ "</div>") (toAssoc info) - -class AssocData a where - assocName :: a -> String - toAssoc :: a -> [(String, String)] - -instance AssocSema dom => AssocData (SemanticInfoType dom) where - assocName s@(DefaultInfoType {}) = "NoSemanticInfo" - assocName s@(NameInfoType {}) = assocName (semaInfoTypeName s) - assocName s@(ExprInfoType {}) = assocName (semaInfoTypeExpr s) - assocName s@(ImportInfoType {}) = assocName (semaInfoTypeImport s) - assocName s@(ModuleInfoType {}) = assocName (semaInfoTypeModule s) - - toAssoc s@(DefaultInfoType {}) = [] - toAssoc s@(NameInfoType {}) = toAssoc (semaInfoTypeName s) - toAssoc s@(ExprInfoType {}) = toAssoc (semaInfoTypeExpr s) - toAssoc s@(ImportInfoType {}) = toAssoc (semaInfoTypeImport s) - toAssoc s@(ModuleInfoType {}) = toAssoc (semaInfoTypeModule s) - - -instance AssocData ScopeInfo where - assocName (ScopeInfo {}) = "ScopeInfo" - toAssoc (ScopeInfo locals) = [ ("namesInScope", inspectScope locals) ] - -instance InspectableName n => AssocData (NameInfo n) where - assocName (NameInfo {}) = "NameInfo" - assocName (AmbiguousNameInfo {}) = "AmbiguousNameInfo" - assocName (ImplicitNameInfo {}) = "ImplicitNameInfo" - - toAssoc (NameInfo locals defined nameInfo) = [ ("name", inspect nameInfo) - , ("isDefined", show defined) - , ("namesInScope", inspectScope locals) - ] - toAssoc (AmbiguousNameInfo locals defined name _) = [ ("name", inspect name) - , ("isDefined", show defined) - , ("namesInScope", inspectScope locals) - ] - toAssoc (ImplicitNameInfo locals defined name) = [ ("name", name) - , ("isDefined", show defined) - , ("namesInScope", inspectScope locals) - ] -instance AssocData CNameInfo where - assocName (CNameInfo {}) = "CNameInfo" - toAssoc (CNameInfo locals defined nameInfo) = [ ("name", inspect nameInfo) - , ("isDefined", show defined) - , ("namesInScope", inspectScope locals) - ] - -instance InspectableName n => AssocData (ModuleInfo n) where - assocName (ModuleInfo {}) = "ModuleInfo" - toAssoc (ModuleInfo mod imps) = [ ("moduleName", showSDocUnsafe (ppr mod)) - , ("implicitImports", concat (intersperse ", " (map inspect imps))) - ] - -instance InspectableName n => AssocData (ImportInfo n) where - assocName (ImportInfo {}) = "ImportInfo" - toAssoc (ImportInfo mod avail imported) = [ ("moduleName", showSDocUnsafe (ppr mod)) - , ("availableNames", concat (intersperse ", " (map inspect avail))) - , ("importedNames", concat (intersperse ", " (map inspect imported))) - ] - -inspectScope :: InspectableName n => [[n]] -> String -inspectScope = concat . intersperse " | " . map (concat . intersperse ", " . map inspect) - -class InspectableName n where - inspect :: n -> String - -instance InspectableName GHC.Name where - inspect name = showSDocUnsafe (ppr name) ++ "[" ++ show (getUnique name) ++ "]" - -instance InspectableName GHC.RdrName where - inspect name = showSDocUnsafe (ppr name) - -instance InspectableName GHC.Id where - inspect name = showSDocUnsafe (ppr name) ++ "[" ++ show (getUnique name) ++ "] :: " ++ showSDocOneLine unsafeGlobalDynFlags (ppr (idType name)) - -class (Domain dom, SourceInfo st) - => ASTDebug e dom st where - astDebug' :: e dom st -> [DebugNode dom] - default astDebug' :: (GAstDebug (Rep (e dom st)) dom, Generic (e dom st)) => e dom st -> [DebugNode dom] - astDebug' = gAstDebug . from - -class GAstDebug f dom where - gAstDebug :: f p -> [DebugNode dom] - -instance GAstDebug V1 dom where - gAstDebug _ = error "GAstDebug V1" - -instance GAstDebug U1 dom where - gAstDebug U1 = [] - -instance (GAstDebug f dom, GAstDebug g dom) => GAstDebug (f :+: g) dom where - gAstDebug (L1 x) = gAstDebug x - gAstDebug (R1 x) = gAstDebug x - -instance (GAstDebug f dom, GAstDebug g dom) => GAstDebug (f :*: g) dom where - gAstDebug (x :*: y) - = gAstDebug x ++ gAstDebug y - -instance {-# OVERLAPPING #-} ASTDebug e dom st => GAstDebug (K1 i (e dom st)) dom where - gAstDebug (K1 x) = astDebug' x - -instance {-# OVERLAPPABLE #-} Show x => GAstDebug (K1 i x) dom where - gAstDebug (K1 x) = [SimpleNode "" (show x)] - -instance (GAstDebug f dom, Constructor c) => GAstDebug (M1 C c f) dom where - gAstDebug c@(M1 x) = [TreeNode "" (TreeDebugNode (conName c) undefined (gAstDebug x))] - -instance (GAstDebug f dom, Selector s) => GAstDebug (M1 S s f) dom where - gAstDebug s@(M1 x) = traversal&nodeLabel .= selName s $ gAstDebug x - --- don't have to do anything with datatype metainfo -instance GAstDebug f dom => GAstDebug (M1 D t f) dom where - gAstDebug (M1 x) = gAstDebug x
− Language/Haskell/Tools/Refactor/ASTDebug/Instances.hs
@@ -1,150 +0,0 @@-{-# LANGUAGE FlexibleContexts - , FlexibleInstances - , MultiParamTypeClasses - , StandaloneDeriving - , DeriveGeneric - , UndecidableInstances - , TypeFamilies - #-} -module Language.Haskell.Tools.Refactor.ASTDebug.Instances where - -import Language.Haskell.Tools.Refactor.ASTDebug - -import GHC.Generics -import Control.Reference - -import Language.Haskell.Tools.AST - --- Annotations -instance {-# OVERLAPPING #-} (ASTDebug SimpleName dom st) => ASTDebug (Ann SimpleName) dom st where - astDebug' (Ann a e) = traversal&nodeSubtree&nodeInfo .= (NameInfoType (a ^. semanticInfo) (getRange (a ^. sourceInfo))) $ astDebug' e - -instance {-# OVERLAPPING #-} (ASTDebug Expr dom st) => ASTDebug (Ann Expr) dom st where - astDebug' (Ann a e) = traversal&nodeSubtree&nodeInfo .= (ExprInfoType (a ^. semanticInfo) (getRange (a ^. sourceInfo))) $ astDebug' e - -instance {-# OVERLAPPING #-} (ASTDebug ImportDecl dom st) => ASTDebug (Ann ImportDecl) dom st where - astDebug' (Ann a e) = traversal&nodeSubtree&nodeInfo .= (ImportInfoType (a ^. semanticInfo) (getRange (a ^. sourceInfo))) $ astDebug' e - -instance {-# OVERLAPPING #-} (ASTDebug Module dom st) => ASTDebug (Ann Module) dom st where - astDebug' (Ann a e) = traversal&nodeSubtree&nodeInfo .= (ModuleInfoType (a ^. semanticInfo) (getRange (a ^. sourceInfo))) $ astDebug' e - -instance {-# OVERLAPPABLE #-} (ASTDebug e dom st) => ASTDebug (Ann e) dom st where - astDebug' (Ann a e) = traversal&nodeSubtree&nodeInfo .= DefaultInfoType (getRange (a ^. sourceInfo)) $ astDebug' e - -instance (ASTDebug e dom st) => ASTDebug (AnnList e) dom st where - astDebug' (AnnList a ls) = [TreeNode "" (TreeDebugNode "*" (DefaultInfoType (getRange (a ^. sourceInfo))) (concatMap astDebug' ls))] - -instance (ASTDebug e dom st) => ASTDebug (AnnMaybe e) dom st where - astDebug' (AnnMaybe a e) = [TreeNode "" (TreeDebugNode "?" (DefaultInfoType (getRange (a ^. sourceInfo))) (maybe [] astDebug' e))] - --- Modules -instance (Domain dom, SourceInfo st) => ASTDebug Module dom st -instance (Domain dom, SourceInfo st) => ASTDebug ModuleHead dom st -instance (Domain dom, SourceInfo st) => ASTDebug ExportSpecList dom st -instance (Domain dom, SourceInfo st) => ASTDebug ExportSpec dom st -instance (Domain dom, SourceInfo st) => ASTDebug IESpec dom st -instance (Domain dom, SourceInfo st) => ASTDebug SubSpec dom st -instance (Domain dom, SourceInfo st) => ASTDebug ModulePragma dom st -instance (Domain dom, SourceInfo st) => ASTDebug FilePragma dom st -instance (Domain dom, SourceInfo st) => ASTDebug ImportDecl dom st -instance (Domain dom, SourceInfo st) => ASTDebug ImportSpec dom st -instance (Domain dom, SourceInfo st) => ASTDebug ImportQualified dom st -instance (Domain dom, SourceInfo st) => ASTDebug ImportSource dom st -instance (Domain dom, SourceInfo st) => ASTDebug ImportSafe dom st -instance (Domain dom, SourceInfo st) => ASTDebug TypeNamespace dom st -instance (Domain dom, SourceInfo st) => ASTDebug ImportRenaming dom st - --- Declarations -instance (Domain dom, SourceInfo st) => ASTDebug Decl dom st -instance (Domain dom, SourceInfo st) => ASTDebug ClassBody dom st -instance (Domain dom, SourceInfo st) => ASTDebug ClassElement dom st -instance (Domain dom, SourceInfo st) => ASTDebug DeclHead dom st -instance (Domain dom, SourceInfo st) => ASTDebug InstBody dom st -instance (Domain dom, SourceInfo st) => ASTDebug InstBodyDecl dom st -instance (Domain dom, SourceInfo st) => ASTDebug GadtConDecl dom st -instance (Domain dom, SourceInfo st) => ASTDebug GadtConType dom st -instance (Domain dom, SourceInfo st) => ASTDebug GadtField dom st -instance (Domain dom, SourceInfo st) => ASTDebug FunDeps dom st -instance (Domain dom, SourceInfo st) => ASTDebug FunDep dom st -instance (Domain dom, SourceInfo st) => ASTDebug ConDecl dom st -instance (Domain dom, SourceInfo st) => ASTDebug FieldDecl dom st -instance (Domain dom, SourceInfo st) => ASTDebug Deriving dom st -instance (Domain dom, SourceInfo st) => ASTDebug InstanceRule dom st -instance (Domain dom, SourceInfo st) => ASTDebug InstanceHead dom st -instance (Domain dom, SourceInfo st) => ASTDebug TypeEqn dom st -instance (Domain dom, SourceInfo st) => ASTDebug KindConstraint dom st -instance (Domain dom, SourceInfo st) => ASTDebug TyVar dom st -instance (Domain dom, SourceInfo st) => ASTDebug Type dom st -instance (Domain dom, SourceInfo st) => ASTDebug Kind dom st -instance (Domain dom, SourceInfo st) => ASTDebug Context dom st -instance (Domain dom, SourceInfo st) => ASTDebug Assertion dom st -instance (Domain dom, SourceInfo st) => ASTDebug Expr dom st -instance (Domain dom, SourceInfo st) => ASTDebug (Stmt' Expr) dom st -instance (Domain dom, SourceInfo st) => ASTDebug (Stmt' Cmd) dom st -instance (Domain dom, SourceInfo st) => ASTDebug CompStmt dom st -instance (Domain dom, SourceInfo st) => ASTDebug ValueBind dom st -instance (Domain dom, SourceInfo st) => ASTDebug Pattern dom st -instance (Domain dom, SourceInfo st) => ASTDebug PatternField dom st -instance (Domain dom, SourceInfo st) => ASTDebug Splice dom st -instance (Domain dom, SourceInfo st) => ASTDebug QQString dom st -instance (Domain dom, SourceInfo st) => ASTDebug Match dom st -instance (Domain dom, SourceInfo st, ASTDebug expr dom st, Generic (expr dom st)) => ASTDebug (Alt' expr) dom st -instance (Domain dom, SourceInfo st) => ASTDebug Rhs dom st -instance (Domain dom, SourceInfo st) => ASTDebug GuardedRhs dom st -instance (Domain dom, SourceInfo st) => ASTDebug FieldUpdate dom st -instance (Domain dom, SourceInfo st) => ASTDebug Bracket dom st -instance (Domain dom, SourceInfo st) => ASTDebug TopLevelPragma dom st -instance (Domain dom, SourceInfo st) => ASTDebug Rule dom st -instance (Domain dom, SourceInfo st) => ASTDebug AnnotationSubject dom st -instance (Domain dom, SourceInfo st) => ASTDebug MinimalFormula dom st -instance (Domain dom, SourceInfo st) => ASTDebug ExprPragma dom st -instance (Domain dom, SourceInfo st) => ASTDebug SourceRange dom st -instance (Domain dom, SourceInfo st) => ASTDebug Number dom st -instance (Domain dom, SourceInfo st) => ASTDebug QuasiQuote dom st -instance (Domain dom, SourceInfo st) => ASTDebug RhsGuard dom st -instance (Domain dom, SourceInfo st) => ASTDebug LocalBind dom st -instance (Domain dom, SourceInfo st) => ASTDebug LocalBinds dom st -instance (Domain dom, SourceInfo st) => ASTDebug FixitySignature dom st -instance (Domain dom, SourceInfo st) => ASTDebug TypeSignature dom st -instance (Domain dom, SourceInfo st) => ASTDebug ListCompBody dom st -instance (Domain dom, SourceInfo st) => ASTDebug TupSecElem dom st -instance (Domain dom, SourceInfo st) => ASTDebug TypeFamily dom st -instance (Domain dom, SourceInfo st) => ASTDebug TypeFamilySpec dom st -instance (Domain dom, SourceInfo st) => ASTDebug InjectivityAnn dom st -instance (Domain dom, SourceInfo st, ASTDebug expr dom st, Generic (expr dom st)) => ASTDebug (CaseRhs' expr) dom st -instance (Domain dom, SourceInfo st, ASTDebug expr dom st, Generic (expr dom st)) => ASTDebug (GuardedCaseRhs' expr) dom st -instance (Domain dom, SourceInfo st) => ASTDebug PatternSynonym dom st -instance (Domain dom, SourceInfo st) => ASTDebug PatSynRhs dom st -instance (Domain dom, SourceInfo st) => ASTDebug PatSynLhs dom st -instance (Domain dom, SourceInfo st) => ASTDebug PatSynWhere dom st -instance (Domain dom, SourceInfo st) => ASTDebug PatternTypeSignature dom st -instance (Domain dom, SourceInfo st) => ASTDebug Role dom st -instance (Domain dom, SourceInfo st) => ASTDebug Cmd dom st -instance (Domain dom, SourceInfo st) => ASTDebug LanguageExtension dom st -instance (Domain dom, SourceInfo st) => ASTDebug MatchLhs dom st - --- Literal -instance (Domain dom, SourceInfo st) => ASTDebug Literal dom st -instance (Domain dom, SourceInfo st, ASTDebug k dom st, Generic (k dom st)) => ASTDebug (Promoted k) dom st - --- Base -instance (Domain dom, SourceInfo st) => ASTDebug Operator dom st -instance (Domain dom, SourceInfo st) => ASTDebug Name dom st -instance (Domain dom, SourceInfo st) => ASTDebug SimpleName dom st -instance (Domain dom, SourceInfo st) => ASTDebug ModuleName dom st -instance (Domain dom, SourceInfo st) => ASTDebug UnqualName dom st -instance (Domain dom, SourceInfo st) => ASTDebug StringNode dom st -instance (Domain dom, SourceInfo st) => ASTDebug DataOrNewtypeKeyword dom st -instance (Domain dom, SourceInfo st) => ASTDebug DoKind dom st -instance (Domain dom, SourceInfo st) => ASTDebug TypeKeyword dom st -instance (Domain dom, SourceInfo st) => ASTDebug OverlapPragma dom st -instance (Domain dom, SourceInfo st) => ASTDebug CallConv dom st -instance (Domain dom, SourceInfo st) => ASTDebug ArrowAppl dom st -instance (Domain dom, SourceInfo st) => ASTDebug Safety dom st -instance (Domain dom, SourceInfo st) => ASTDebug ConlikeAnnot dom st -instance (Domain dom, SourceInfo st) => ASTDebug Assoc dom st -instance (Domain dom, SourceInfo st) => ASTDebug Precedence dom st -instance (Domain dom, SourceInfo st) => ASTDebug LineNumber dom st -instance (Domain dom, SourceInfo st) => ASTDebug PhaseControl dom st -instance (Domain dom, SourceInfo st) => ASTDebug PhaseNumber dom st -instance (Domain dom, SourceInfo st) => ASTDebug PhaseInvert dom st
+ Language/Haskell/Tools/Refactor/DataToNewtype.hs view
@@ -0,0 +1,20 @@+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/DebugGhcAST.hs
@@ -1,368 +0,0 @@-{-# LANGUAGE StandaloneDeriving - , TypeSynonymInstances - , FlexibleInstances - #-} --- | A module for showing GHC's syntax tree representation. -module Language.Haskell.Tools.Refactor.DebugGhcAST where - -import Language.Haskell.Tools.Refactor.RangeDebug -import Language.Haskell.Tools.AST.FromGHC.GHCUtils -import Language.Haskell.Tools.AST (shortShowSpan) - -import GHC -import HsSyn -import HsDecls -import Module -import Coercion -import SrcLoc -import RdrName -import BasicTypes -import Outputable -import TyCon -import PlaceHolder -import ForeignCall -import Var -import ConLike -import PatSyn -import TcEvidence -import Bag -import BooleanFormula -import FieldLabel -import CoreSyn -import UniqFM -import OccName - -instance Show a => Show (Located a) where - show (L l a) = "L(" ++ shortShowSpan l ++ ") (" ++ show a ++ ")" - -deriving instance Show (ABExport RdrName) -deriving instance Show (AmbiguousFieldOcc RdrName) -deriving instance Show (AnnDecl RdrName) -deriving instance Show (AnnProvenance RdrName) -deriving instance Show (ApplicativeArg RdrName RdrName) -deriving instance Show (ArithSeqInfo RdrName) -deriving instance Show (BooleanFormula (Located RdrName)) -deriving instance Show (ClsInstDecl RdrName) -deriving instance Show (ConDecl RdrName) -deriving instance Show (ConDeclField RdrName) -deriving instance Show (DataFamInstDecl RdrName) -deriving instance Show (DefaultDecl RdrName) -deriving instance Show (DerivDecl RdrName) -deriving instance Show (FamilyDecl RdrName) -deriving instance Show (FamilyInfo RdrName) -deriving instance Show (FamilyResultSig RdrName) -deriving instance Show (FieldLbl RdrName) -deriving instance Show (FieldOcc RdrName) -deriving instance Show (FixitySig RdrName) -deriving instance Show (ForeignDecl RdrName) -deriving instance Show a => Show (GRHS RdrName a) -deriving instance Show a => Show (GRHSs RdrName a) -deriving instance Show (InjectivityAnn RdrName) -deriving instance Show (HsAppType RdrName) -deriving instance Show (HsBindLR RdrName RdrName) -deriving instance Show (HsBracket RdrName) -deriving instance Show (HsCmd RdrName) -deriving instance Show (HsCmdTop RdrName) -deriving instance Show (HsConDeclDetails RdrName) -deriving instance Show (HsConPatDetails RdrName) -deriving instance Show (HsDataDefn RdrName) -deriving instance Show (HsDecl RdrName) -deriving instance Show (HsExpr RdrName) -deriving instance Show (HsGroup RdrName) -deriving instance Show (HsLocalBindsLR RdrName RdrName) -deriving instance Show (HsMatchContext RdrName) -deriving instance Show (HsModule RdrName) -deriving instance Show (HsOverLit RdrName) -deriving instance Show (HsPatSynDetails (Located RdrName)) -deriving instance Show (HsPatSynDir RdrName) -deriving instance Show (HsRecFields RdrName (LPat RdrName)) -deriving instance Show (HsRecordBinds RdrName) -deriving instance Show (HsSplice RdrName) -deriving instance Show (HsStmtContext RdrName) -deriving instance Show (HsTupArg RdrName) -deriving instance Show (HsTyVarBndr RdrName) -deriving instance Show (HsType RdrName) -deriving instance Show (HsValBindsLR RdrName RdrName) -deriving instance Show (HsWildCardInfo RdrName) -deriving instance Show (IE RdrName) -deriving instance Show (ImportDecl RdrName) -deriving instance Show (InstDecl RdrName) -deriving instance Show (LHsQTyVars RdrName) -deriving instance Show a => Show (Match RdrName a) -deriving instance Show (MatchFixity RdrName) -deriving instance Show a => Show (MatchGroup RdrName a) -deriving instance Show (ParStmtBlock RdrName RdrName) -deriving instance Show (Pat RdrName) -deriving instance Show (PatSynBind RdrName RdrName) -deriving instance Show (RecordPatSynField (Located RdrName)) -deriving instance Show (RoleAnnotDecl RdrName) -deriving instance Show (RuleBndr RdrName) -deriving instance Show (RuleDecl RdrName) -deriving instance Show (RuleDecls RdrName) -deriving instance Show (Sig RdrName) -deriving instance Show (SpliceDecl RdrName) -deriving instance Show (SyntaxExpr RdrName) -deriving instance Show a => Show (StmtLR RdrName RdrName a) -deriving instance Show (TyClDecl RdrName) -deriving instance Show (TyClGroup RdrName) -deriving instance Show a => Show (TyFamEqn RdrName a) -deriving instance Show (TyFamInstDecl RdrName) -deriving instance Show (VectDecl RdrName) -deriving instance Show (WarnDecl RdrName) -deriving instance Show (WarnDecls RdrName) - - -deriving instance Show (ABExport Name) -deriving instance Show (AmbiguousFieldOcc Name) -deriving instance Show (AnnDecl Name) -deriving instance Show (AnnProvenance Name) -deriving instance Show (ApplicativeArg Name Name) -deriving instance Show (ArithSeqInfo Name) -deriving instance Show (BooleanFormula (Located Name)) -deriving instance Show (ClsInstDecl Name) -deriving instance Show (ConDecl Name) -deriving instance Show (ConDeclField Name) -deriving instance Show (DataFamInstDecl Name) -deriving instance Show (DefaultDecl Name) -deriving instance Show (DerivDecl Name) -deriving instance Show (FamilyDecl Name) -deriving instance Show (FamilyInfo Name) -deriving instance Show (FamilyResultSig Name) -deriving instance Show (FieldLbl Name) -deriving instance Show (FieldOcc Name) -deriving instance Show (FixitySig Name) -deriving instance Show (ForeignDecl Name) -deriving instance Show a => Show (GRHS Name a) -deriving instance Show a => Show (GRHSs Name a) -deriving instance Show (InjectivityAnn Name) -deriving instance Show (HsAppType Name) -deriving instance Show (HsBindLR Name Name) -deriving instance Show (HsBracket Name) -deriving instance Show (HsCmd Name) -deriving instance Show (HsCmdTop Name) -deriving instance Show (HsConDeclDetails Name) -deriving instance Show (HsConPatDetails Name) -deriving instance Show (HsDataDefn Name) -deriving instance Show (HsDecl Name) -deriving instance Show (HsExpr Name) -deriving instance Show (HsGroup Name) -deriving instance Show (HsLocalBindsLR Name Name) -deriving instance Show (HsMatchContext Name) -deriving instance Show (HsModule Name) -deriving instance Show (HsOverLit Name) -deriving instance Show (HsPatSynDetails (Located Name)) -deriving instance Show (HsPatSynDir Name) -deriving instance Show (HsRecFields Name (LPat Name)) -deriving instance Show (HsRecordBinds Name) -deriving instance Show (HsSplice Name) -deriving instance Show (HsStmtContext Name) -deriving instance Show (HsTupArg Name) -deriving instance Show (HsTyVarBndr Name) -deriving instance Show (HsType Name) -deriving instance Show (HsValBindsLR Name Name) -deriving instance Show (HsWildCardInfo Name) -deriving instance Show (IE Name) -deriving instance Show (ImportDecl Name) -deriving instance Show (InstDecl Name) -deriving instance Show (LHsQTyVars Name) -deriving instance Show a => Show (Match Name a) -deriving instance Show (MatchFixity Name) -deriving instance Show a => Show (MatchGroup Name a) -deriving instance Show (ParStmtBlock Name Name) -deriving instance Show (Pat Name) -deriving instance Show (PatSynBind Name Name) -deriving instance Show (RecordPatSynField (Located Name)) -deriving instance Show (RoleAnnotDecl Name) -deriving instance Show (RuleBndr Name) -deriving instance Show (RuleDecl Name) -deriving instance Show (RuleDecls Name) -deriving instance Show (Sig Name) -deriving instance Show (SpliceDecl Name) -deriving instance Show (SyntaxExpr Name) -deriving instance Show a => Show (StmtLR Name Name a) -deriving instance Show (TyClDecl Name) -deriving instance Show (TyClGroup Name) -deriving instance Show a => Show (TyFamEqn Name a) -deriving instance Show (TyFamInstDecl Name) -deriving instance Show (VectDecl Name) -deriving instance Show (WarnDecl Name) -deriving instance Show (WarnDecls Name) - - -deriving instance Show (ABExport Id) -deriving instance Show (AmbiguousFieldOcc Id) -deriving instance Show (AnnDecl Id) -deriving instance Show (AnnProvenance Id) -deriving instance Show (ApplicativeArg Id Id) -deriving instance Show (ArithSeqInfo Id) -deriving instance Show (BooleanFormula (Located Id)) -deriving instance Show (ClsInstDecl Id) -deriving instance Show (ConDecl Id) -deriving instance Show (ConDeclField Id) -deriving instance Show (DataFamInstDecl Id) -deriving instance Show (DefaultDecl Id) -deriving instance Show (DerivDecl Id) -deriving instance Show (FamilyDecl Id) -deriving instance Show (FamilyInfo Id) -deriving instance Show (FamilyResultSig Id) -deriving instance Show (FieldLbl Id) -deriving instance Show (FieldOcc Id) -deriving instance Show (FixitySig Id) -deriving instance Show (ForeignDecl Id) -deriving instance Show a => Show (GRHS Id a) -deriving instance Show a => Show (GRHSs Id a) -deriving instance Show (InjectivityAnn Id) -deriving instance Show (HsAppType Id) -deriving instance Show (HsBindLR Id Id) -deriving instance Show (HsBracket Id) -deriving instance Show (HsCmd Id) -deriving instance Show (HsCmdTop Id) -deriving instance Show (HsConDeclDetails Id) -deriving instance Show (HsConPatDetails Id) -deriving instance Show (HsDataDefn Id) -deriving instance Show (HsDecl Id) -deriving instance Show (HsExpr Id) -deriving instance Show (HsGroup Id) -deriving instance Show (HsLocalBindsLR Id Id) -deriving instance Show (HsMatchContext Id) -deriving instance Show (HsModule Id) -deriving instance Show (HsOverLit Id) -deriving instance Show (HsPatSynDetails (Located Id)) -deriving instance Show (HsPatSynDir Id) -deriving instance Show (HsRecFields Id (LPat Id)) -deriving instance Show (HsRecordBinds Id) -deriving instance Show (HsSplice Id) -deriving instance Show (HsStmtContext Id) -deriving instance Show (HsTupArg Id) -deriving instance Show (HsTyVarBndr Id) -deriving instance Show (HsType Id) -deriving instance Show (HsValBindsLR Id Id) -deriving instance Show (HsWildCardInfo Id) -deriving instance Show (IE Id) -deriving instance Show (ImportDecl Id) -deriving instance Show (InstDecl Id) -deriving instance Show (LHsQTyVars Id) -deriving instance Show a => Show (Match Id a) -deriving instance Show (MatchFixity Id) -deriving instance Show a => Show (MatchGroup Id a) -deriving instance Show (ParStmtBlock Id Id) -deriving instance Show (Pat Id) -deriving instance Show (PatSynBind Id Id) -deriving instance Show (RecordPatSynField (Located Id)) -deriving instance Show (RoleAnnotDecl Id) -deriving instance Show (RuleBndr Id) -deriving instance Show (RuleDecl Id) -deriving instance Show (RuleDecls Id) -deriving instance Show (Sig Id) -deriving instance Show (SpliceDecl Id) -deriving instance Show (SyntaxExpr Id) -deriving instance Show a => Show (StmtLR Id Id a) -deriving instance Show (TyClDecl Id) -deriving instance Show (TyClGroup Id) -deriving instance Show a => Show (TyFamEqn Id a) -deriving instance Show (TyFamInstDecl Id) -deriving instance Show (VectDecl Id) -deriving instance Show (WarnDecl Id) -deriving instance Show (WarnDecls Id) - -deriving instance Show Activation -deriving instance Show HsArrAppType -deriving instance Show Boxity -deriving instance Show CType -deriving instance Show CImportSpec -deriving instance Show CExportSpec -deriving instance Show CCallConv -deriving instance Show CCallTarget -deriving instance Show ConLike -deriving instance Show DocDecl -deriving instance Show Fixity -deriving instance Show FixityDirection -deriving instance Show ForeignImport -deriving instance Show ForeignExport -deriving instance Show Header -deriving instance Show HsIPName -deriving instance Show HsLit -deriving instance Show HsTupleSort -deriving instance Show HsSrcBang -deriving instance Show InlinePragma -deriving instance Show NewOrData -deriving instance Show Origin -deriving instance Show OverLitVal -deriving instance Show OverlapMode -deriving instance Show PlaceHolder -deriving instance Show Role -deriving instance Show RecFlag -deriving instance Show SpliceExplicitFlag -deriving instance Show TcSpecPrag -deriving instance Show TcSpecPrags -deriving instance Show TransForm -deriving instance Show WarningTxt -deriving instance Show PendingRnSplice -deriving instance Show PendingTcSplice - -instance Show UnboundVar where - show (OutOfScope n _) = "OutOfScope " ++ show n - show (TrueExprHole n) = "TrueExprHole " ++ show n - - - -instance Show ModuleName where - show = showSDocUnsafe . ppr -instance Show TyCon where - show = showSDocUnsafe . ppr -instance Show ClsInst where - show = showSDocUnsafe . ppr -instance Show Type where - show = showSDocUnsafe . ppr -instance Show OccName where - show = showSDocUnsafe . ppr --- instance Show RdrName where - -- show = showSDocUnsafe . ppr - -deriving instance Show RdrName -deriving instance Show Module -deriving instance Show StringLiteral -deriving instance Show UntypedSpliceFlavour -deriving instance Show SrcUnpackedness -deriving instance Show SrcStrictness -deriving instance Show IEWildcard - -deriving instance Show t => Show (HsImplicitBndrs RdrName t) -deriving instance Show t => Show (HsImplicitBndrs Name t) -deriving instance Show t => Show (HsImplicitBndrs Id t) -deriving instance Show t => Show (HsWildCardBndrs RdrName t) -deriving instance Show t => Show (HsWildCardBndrs Name t) -deriving instance Show t => Show (HsWildCardBndrs Id t) -deriving instance (Show a, Show b) => Show (HsRecField' a b) - - -instance Show UnitId where - show = showSDocUnsafe . ppr -instance Show Name where - show = showSDocUnsafe . ppr -instance Show HsTyLit where - show = showSDocUnsafe . ppr -instance Show Var where - show = showSDocUnsafe . ppr -instance Show DataCon where - show = showSDocUnsafe . ppr -instance Show PatSyn where - show = showSDocUnsafe . ppr -instance Show TcEvBinds where - show = showSDocUnsafe . ppr -instance Show HsWrapper where - show = showSDocUnsafe . ppr -instance Show Class where - show = showSDocUnsafe . ppr -instance Show TcCoercion where - show = showSDocUnsafe . ppr -instance Outputable a => Show (UniqFM a) where - show = showSDocUnsafe . ppr -instance Outputable a => Show (Tickish a) where - show = showSDocUnsafe . ppr -instance OutputableBndr a => Show (HsIPBinds a) where - show = showSDocUnsafe . ppr - -instance Show a => Show (Bag a) where - show = show . bagToList -
+ Language/Haskell/Tools/Refactor/DollarApp.hs view
@@ -0,0 +1,54 @@+{-# 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 view
@@ -31,19 +31,18 @@ type Ann' e dom = Ann e dom SrcTemplateStage type AnnMaybe' e dom = AnnMaybe e dom SrcTemplateStage -type ExtractBindingDomain dom = ( Domain dom, HasNameInfo (SemanticInfo' dom SameInfoNameCls), HasDefiningInfo (SemanticInfo' dom SameInfoNameCls) - , HasScopeInfo (SemanticInfo' dom SameInfoExprCls) ) +type ExtractBindingDomain dom = ( Domain dom, HasNameInfo dom, HasDefiningInfo dom, HasScopeInfo dom ) -extractBinding' :: ExtractBindingDomain dom => RealSrcSpan -> String -> Ann' Module dom -> RefactoredModule 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 -> Ann' Module dom -> RefactoredModule dom + -> String -> LocalRefactoring dom extractBinding selectDecl selectExpr name mod - = let conflicting = any (isConflicting name) (mod ^? selectDecl & biplateRef :: [Ann' SimpleName dom]) + = 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) @@ -53,13 +52,13 @@ 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' SimpleName dom -> Bool +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)) (Refactor dom) (Ann' Expr dom) +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 @@ -108,7 +107,7 @@ isParenLikeExpr (QuasiQuoteExpr {}) = True isParenLikeExpr _ = False -doExtract :: ExtractBindingDomain dom => String -> Ann' Expr dom -> Ann' Expr dom -> StateT (Maybe (Ann' ValueBind dom)) (Refactor dom) (Ann' Expr dom) +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)))
Language/Haskell/Tools/Refactor/GenerateExports.hs view
@@ -16,10 +16,10 @@ import Language.Haskell.Tools.AST.Gen import Language.Haskell.Tools.Refactor.RefactorBase -type DomGenerateExports dom = (Domain dom, HasNameInfo (SemanticInfo' dom SameInfoNameCls)) +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 => Ann Module dom SrcTemplateStage -> RefactoredModule dom +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
Language/Haskell/Tools/Refactor/GenerateTypeSignature.hs view
@@ -31,10 +31,9 @@ type Ann' e dom = Ann e dom SrcTemplateStage type AnnList' e dom = AnnList e dom SrcTemplateStage -type GenerateSignatureDomain dom = ( Domain dom, HasIdInfo (SemanticInfo' dom SameInfoNameCls), Eq (SemanticInfo' dom SameInfoNameCls) - , SemanticInfo' dom SameInfoImportCls ~ ImportInfo Id ) +type GenerateSignatureDomain dom = ( HasModuleInfo dom, HasIdInfo dom, HasImportInfo dom ) -generateTypeSignature' :: GenerateSignatureDomain dom => RealSrcSpan -> Ann' Module dom -> RefactoredModule 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 @@ -45,14 +44,14 @@ -> (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 - -> Ann' Module dom -> RefactoredModule dom + -> 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 (Refactor dom) (AnnList' d dom) + -> AnnList' d dom -> StateT Bool (LocalRefactor dom) (AnnList' d dom) genTypeSig vbAccess ls | Just vb <- vbAccess ls , not (typeSignatureAlreadyExist ls vb) @@ -70,11 +69,11 @@ | otherwise = return ls -generateTSFor :: GenerateSignatureDomain dom => GHC.Name -> GHC.Type -> Refactor dom (Ann' TypeSignature dom) +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 -> Refactor dom (Ann' AST.Type dom) +generateTypeFor :: GenerateSignatureDomain dom => Int -> GHC.Type -> LocalRefactor dom (Ann' AST.Type dom) generateTypeFor prec t -- context | (break (not . isPredTy) -> (preds, other), rt) <- splitFunTys t @@ -89,7 +88,7 @@ | (op, [at,rt]) <- splitAppTys t , Just tc <- tyConAppTyCon_maybe op , isSymOcc (getOccName (getName tc)) - = wrapParen 0 <$> (mkTyInfix <$> generateTypeFor 10 at <*> referenceOperator (getTCId tc) <*> generateTypeFor 10 rt) + = wrapParen 0 <$> (mkTyInfix <$> generateTypeFor 10 at <*> referenceOperator (idName $ getTCId tc) <*> generateTypeFor 10 rt) -- tuple types | Just (tc, tas) <- splitTyConApp_maybe t , isTupleTyCon tc @@ -109,13 +108,13 @@ = wrapParen 10 <$> (mkTyApp <$> generateTypeFor 10 tf <*> generateTypeFor 11 ta) -- type constructor | Just tc <- tyConAppTyCon_maybe t - = mkTyVar <$> referenceName (getTCId tc) + = mkTyVar <$> referenceName (idName $ getTCId tc) -- type variable | Just tv <- getTyVar_maybe t - = mkTyVar <$> referenceName tv + = mkTyVar <$> referenceName (idName tv) -- forall type | (tvs@(_:_), t') <- splitForAllTys t - = wrapParen (-1) <$> (mkTyForall (mkTypeVarList (map getName tvs)) <$> generateTypeFor 0 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 @@ -123,19 +122,19 @@ getTCId :: GHC.TyCon -> GHC.Id getTCId tc = GHC.mkVanillaGlobal (GHC.tyConName tc) (tyConKind tc) - generateAssertionFor :: GenerateSignatureDomain dom => GHC.Type -> Refactor dom (Ann' AST.Assertion dom) + generateAssertionFor :: GenerateSignatureDomain dom => GHC.Type -> LocalRefactor dom (Ann' AST.Assertion dom) generateAssertionFor t | Just (tc, types) <- splitTyConApp_maybe t - = mkClassAssert <$> referenceName (getTCId tc) <*> mapM (generateTypeFor 0) types + = 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` catMaybes (map semanticsId $ concatMap (^? bindName) (filter isTypeSig $ ls ^? annList&element)) + getBindingName vb `elem` (map semanticsId $ concatMap (^? bindName) (filter isTypeSig $ ls ^? annList&element)) getBindingName :: GenerateSignatureDomain dom => Ann' ValueBind dom -> GHC.Id -getBindingName vb = case catMaybes $ map semanticsId $ nub $ vb ^? bindingName of +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
@@ -0,0 +1,40 @@+module Language.Haskell.Tools.Refactor.GetModules where + +import Data.List (intersperse, find) +import Distribution.Verbosity (silent) +import Distribution.ModuleName (components) +import Distribution.PackageDescription +import Distribution.PackageDescription.Configuration +import Distribution.PackageDescription.Parse +import System.FilePath.Posix +import System.Directory + +-- | 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 root + = do files <- listDirectory root + case find (\p -> takeExtension p == ".cabal") files of + Just cabalFile -> modulesFromCabalFile (root </> cabalFile) + Nothing -> modulesFromDirectory root root + + +modulesFromCabalFile :: FilePath -> IO [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) + +modulesFromDirectory :: FilePath -> FilePath -> IO [String] +-- now recognizing only .hs files +modulesFromDirectory root searchRoot = concat <$> (mapM goOn =<< listDirectory searchRoot) + where goOn fp = let path = searchRoot </> fp + in do isDir <- doesDirectoryExist path + if isDir + then modulesFromDirectory root path + else if takeExtension path == ".hs" + then return [concat $ intersperse "." $ splitDirectories $ dropExtension $ makeRelative root path] + else return []
+ Language/Haskell/Tools/Refactor/IfToGuards.hs view
@@ -0,0 +1,34 @@+{-# 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/OrganizeImports.hs view
@@ -29,56 +29,54 @@ import Language.Haskell.Tools.AnnTrf.SourceTemplate import Language.Haskell.Tools.AnnTrf.SourceTemplateHelpers import Language.Haskell.Tools.PrettyPrint -import Language.Haskell.Tools.Refactor.DebugGhcAST import Language.Haskell.Tools.AST.Gen import Language.Haskell.Tools.Refactor.RefactorBase import Debug.Trace -type OrganizeImportsDomain dom n = (Domain dom, HasNameInfo (SemanticInfo' dom SameInfoNameCls), SemanticInfo' dom SameInfoImportCls ~ ImportInfo n, NamedThing n) +type OrganizeImportsDomain dom = ( Domain dom, HasNameInfo dom, HasImportInfo dom ) -organizeImports :: forall n dom . OrganizeImportsDomain dom n - => Ann Module dom SrcTemplateStage -> RefactoredModule 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 SimpleName dom SrcTemplateStage]) + $ (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 n dom . OrganizeImportsDomain dom n - => [GHC.Name] -> [Ann ImportDecl dom SrcTemplateStage] -> Refactor dom [Ann ImportDecl dom SrcTemplateStage] +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 -> Refactor dom [Ann ImportDecl dom SrcTemplateStage] + 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 (^. semantics) all) one + Nothing -> delete one all) <$> narrowImport names (map (semanticsImportedModule . (^. semantics)) all) one -narrowImport :: OrganizeImportsDomain dom n - => [GHC.Name] -> [ImportInfo n] -> Ann ImportDecl dom SrcTemplateStage - -> Refactor dom (Maybe (Ann ImportDecl dom SrcTemplateStage)) +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 (otherModules ^? traversal&importedModule&filtered (== importedMod) :: [GHC.Module]) > 1 + then if length (filter (== importedMod) otherModules) > 1 then pure Nothing else Just <$> (element&importSpec !- replaceWithJust (mkImportSpecList []) $ imp) else pure (Just imp) - where actuallyImported = map getName (fromJust (imp ^? annotation&semanticInfo&importedNames)) `intersect` usedNames - Just importedMod = imp ^? annotation&semanticInfo&importedModule + where actuallyImported = semanticsImported (imp ^. semantics) `intersect` usedNames + importedMod = semanticsImportedModule $ imp ^. semantics -- | Narrows the import specification (explicitely imported elements) -narrowImportSpecs :: forall dom n . OrganizeImportsDomain dom n - => [GHC.Name] -> AnnList IESpec dom SrcTemplateStage -> Refactor dom (AnnList IESpec dom SrcTemplateStage) +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 -> Refactor dom (IESpec dom SrcTemplateStage) + 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) @@ -95,7 +93,7 @@ || ((ie ^? element&ieSubspec&annJust&element&essList&annList) /= []) || (case ie ^? element&ieSubspec&annJust&element of Just SubSpecAll -> True; _ -> False) -narrowImportSubspecs :: OrganizeImportsDomain dom n => [GHC.Name] -> Ann SubSpec dom SrcTemplateStage -> Ann SubSpec dom SrcTemplateStage +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 _))
− Language/Haskell/Tools/Refactor/RangeDebug.hs
@@ -1,53 +0,0 @@-{-# LANGUAGE TypeOperators - , DefaultSignatures - , StandaloneDeriving - , FlexibleContexts - , FlexibleInstances - , MultiParamTypeClasses - , TypeFamilies - #-} --- | A module for displaying debug info about the source annotations of the syntax tree in different phases. -module Language.Haskell.Tools.Refactor.RangeDebug where - -import GHC.Generics -import Control.Reference -import SrcLoc -import Language.Haskell.Tools.AST -import Language.Haskell.Tools.AST.FromGHC -import Language.Haskell.Tools.AnnTrf.RangeToRangeTemplate -import Language.Haskell.Tools.AnnTrf.RangeTemplate -import Language.Haskell.Tools.AnnTrf.SourceTemplate - -srcInfoDebug :: TreeDebug e dom st => e dom st -> String -srcInfoDebug = treeDebug' 0 - -class (SourceInfo st, Domain dom, Show (e dom st)) - => TreeDebug e dom st where - treeDebug' :: Int -> e dom st -> String - default treeDebug' :: (GTreeDebug (Rep (e dom st)), Generic (e dom st), Domain dom) => Int -> e dom st -> String - treeDebug' i = gTreeDebug i . from - -class GTreeDebug f where - gTreeDebug :: Int -> f p -> String - -instance GTreeDebug V1 where - gTreeDebug _ = error "GTreeDebug V1" - -instance GTreeDebug U1 where - gTreeDebug _ U1 = "" - -instance (GTreeDebug f, GTreeDebug g) => GTreeDebug (f :+: g) where - gTreeDebug i (L1 x) = gTreeDebug i x - gTreeDebug i (R1 x) = gTreeDebug i x - -instance (GTreeDebug f, GTreeDebug g) => GTreeDebug (f :*: g) where - gTreeDebug i (x :*: y) = gTreeDebug i x ++ gTreeDebug i y - -instance {-# OVERLAPPING #-} TreeDebug e dom st => GTreeDebug (K1 i (e dom st)) where - gTreeDebug i (K1 x) = treeDebug' i x - -instance {-# OVERLAPPABLE #-} GTreeDebug (K1 i c) where - gTreeDebug i (K1 x) = "" - -instance GTreeDebug f => GTreeDebug (M1 i t f) where - gTreeDebug i (M1 x) = gTreeDebug i x
− Language/Haskell/Tools/Refactor/RangeDebug/Instances.hs
@@ -1,139 +0,0 @@-{-# LANGUAGE FlexibleContexts - , FlexibleInstances - , MultiParamTypeClasses - , StandaloneDeriving - , DeriveGeneric - , UndecidableInstances - #-} -module Language.Haskell.Tools.Refactor.RangeDebug.Instances where - -import Language.Haskell.Tools.Refactor.RangeDebug - -import GHC.Generics -import Control.Reference - -import Language.Haskell.Tools.AST - --- Annotations -instance TreeDebug e dom st => TreeDebug (Ann e) dom st where - treeDebug' i (Ann a e) = identLine i ++ show (a ^. sourceInfo) ++ " " ++ take 40 (show e) ++ "..." ++ treeDebug' (i+1) e - -identLine :: Int -> String -identLine i = "\n" ++ replicate (i*2) ' ' - -instance TreeDebug e dom st => TreeDebug (AnnList e) dom st where - treeDebug' i (AnnList a ls) = identLine i ++ show (a ^. sourceInfo) ++ " <*>" ++ concatMap (treeDebug' (i + 1)) ls - -instance TreeDebug e dom st => TreeDebug (AnnMaybe e) dom st where - treeDebug' i (AnnMaybe a e) = identLine i ++ show (a ^. sourceInfo) ++ " <?>" ++ maybe "" (\e -> treeDebug' (i + 1) e) e - --- Modules -instance (SourceInfo st, Domain dom) => TreeDebug Module dom st -instance (SourceInfo st, Domain dom) => TreeDebug ModuleHead dom st -instance (SourceInfo st, Domain dom) => TreeDebug ExportSpecList dom st -instance (SourceInfo st, Domain dom) => TreeDebug ExportSpec dom st -instance (SourceInfo st, Domain dom) => TreeDebug IESpec dom st -instance (SourceInfo st, Domain dom) => TreeDebug SubSpec dom st -instance (SourceInfo st, Domain dom) => TreeDebug ModulePragma dom st -instance (SourceInfo st, Domain dom) => TreeDebug FilePragma dom st -instance (SourceInfo st, Domain dom) => TreeDebug ImportDecl dom st -instance (SourceInfo st, Domain dom) => TreeDebug ImportSpec dom st -instance (SourceInfo st, Domain dom) => TreeDebug ImportQualified dom st -instance (SourceInfo st, Domain dom) => TreeDebug ImportSource dom st -instance (SourceInfo st, Domain dom) => TreeDebug ImportSafe dom st -instance (SourceInfo st, Domain dom) => TreeDebug TypeNamespace dom st -instance (SourceInfo st, Domain dom) => TreeDebug ImportRenaming dom st - --- Declarations -instance (SourceInfo st, Domain dom) => TreeDebug Decl dom st -instance (SourceInfo st, Domain dom) => TreeDebug ClassBody dom st -instance (SourceInfo st, Domain dom) => TreeDebug ClassElement dom st -instance (SourceInfo st, Domain dom) => TreeDebug DeclHead dom st -instance (SourceInfo st, Domain dom) => TreeDebug InstBody dom st -instance (SourceInfo st, Domain dom) => TreeDebug InstBodyDecl dom st -instance (SourceInfo st, Domain dom) => TreeDebug GadtConDecl dom st -instance (SourceInfo st, Domain dom) => TreeDebug GadtConType dom st -instance (SourceInfo st, Domain dom) => TreeDebug GadtField dom st -instance (SourceInfo st, Domain dom) => TreeDebug FunDeps dom st -instance (SourceInfo st, Domain dom) => TreeDebug FunDep dom st -instance (SourceInfo st, Domain dom) => TreeDebug ConDecl dom st -instance (SourceInfo st, Domain dom) => TreeDebug FieldDecl dom st -instance (SourceInfo st, Domain dom) => TreeDebug Deriving dom st -instance (SourceInfo st, Domain dom) => TreeDebug InstanceRule dom st -instance (SourceInfo st, Domain dom) => TreeDebug InstanceHead dom st -instance (SourceInfo st, Domain dom) => TreeDebug TypeEqn dom st -instance (SourceInfo st, Domain dom) => TreeDebug KindConstraint dom st -instance (SourceInfo st, Domain dom) => TreeDebug TyVar dom st -instance (SourceInfo st, Domain dom) => TreeDebug Type dom st -instance (SourceInfo st, Domain dom) => TreeDebug Kind dom st -instance (SourceInfo st, Domain dom) => TreeDebug Context dom st -instance (SourceInfo st, Domain dom) => TreeDebug Assertion dom st -instance (SourceInfo st, Domain dom) => TreeDebug Expr dom st -instance (SourceInfo st, Domain dom, TreeDebug expr dom st, Generic (expr dom st)) => TreeDebug (Stmt' expr) dom st -instance (SourceInfo st, Domain dom) => TreeDebug CompStmt dom st -instance (SourceInfo st, Domain dom) => TreeDebug ValueBind dom st -instance (SourceInfo st, Domain dom) => TreeDebug Pattern dom st -instance (SourceInfo st, Domain dom) => TreeDebug PatternField dom st -instance (SourceInfo st, Domain dom) => TreeDebug Splice dom st -instance (SourceInfo st, Domain dom) => TreeDebug QQString dom st -instance (SourceInfo st, Domain dom) => TreeDebug Match dom st -instance (SourceInfo st, Domain dom, TreeDebug expr dom st, Generic (expr dom st)) => TreeDebug (Alt' expr) dom st -instance (SourceInfo st, Domain dom) => TreeDebug Rhs dom st -instance (SourceInfo st, Domain dom) => TreeDebug GuardedRhs dom st -instance (SourceInfo st, Domain dom) => TreeDebug FieldUpdate dom st -instance (SourceInfo st, Domain dom) => TreeDebug Bracket dom st -instance (SourceInfo st, Domain dom) => TreeDebug TopLevelPragma dom st -instance (SourceInfo st, Domain dom) => TreeDebug Rule dom st -instance (SourceInfo st, Domain dom) => TreeDebug AnnotationSubject dom st -instance (SourceInfo st, Domain dom) => TreeDebug MinimalFormula dom st -instance (SourceInfo st, Domain dom) => TreeDebug ExprPragma dom st -instance (SourceInfo st, Domain dom) => TreeDebug SourceRange dom st -instance (SourceInfo st, Domain dom) => TreeDebug Number dom st -instance (SourceInfo st, Domain dom) => TreeDebug QuasiQuote dom st -instance (SourceInfo st, Domain dom) => TreeDebug RhsGuard dom st -instance (SourceInfo st, Domain dom) => TreeDebug LocalBind dom st -instance (SourceInfo st, Domain dom) => TreeDebug LocalBinds dom st -instance (SourceInfo st, Domain dom) => TreeDebug FixitySignature dom st -instance (SourceInfo st, Domain dom) => TreeDebug TypeSignature dom st -instance (SourceInfo st, Domain dom) => TreeDebug ListCompBody dom st -instance (SourceInfo st, Domain dom) => TreeDebug TupSecElem dom st -instance (SourceInfo st, Domain dom) => TreeDebug TypeFamily dom st -instance (SourceInfo st, Domain dom) => TreeDebug TypeFamilySpec dom st -instance (SourceInfo st, Domain dom) => TreeDebug InjectivityAnn dom st -instance (SourceInfo st, Domain dom, TreeDebug expr dom st, Generic (expr dom st)) => TreeDebug (CaseRhs' expr) dom st -instance (SourceInfo st, Domain dom, TreeDebug expr dom st, Generic (expr dom st)) => TreeDebug (GuardedCaseRhs' expr) dom st -instance (SourceInfo st, Domain dom) => TreeDebug PatternSynonym dom st -instance (SourceInfo st, Domain dom) => TreeDebug PatSynRhs dom st -instance (SourceInfo st, Domain dom) => TreeDebug PatSynLhs dom st -instance (SourceInfo st, Domain dom) => TreeDebug PatSynWhere dom st -instance (SourceInfo st, Domain dom) => TreeDebug PatternTypeSignature dom st -instance (SourceInfo st, Domain dom) => TreeDebug Role dom st -instance (SourceInfo st, Domain dom) => TreeDebug Cmd dom st -instance (SourceInfo st, Domain dom) => TreeDebug LanguageExtension dom st -instance (SourceInfo st, Domain dom) => TreeDebug MatchLhs dom st - --- Literal -instance (SourceInfo st, Domain dom) => TreeDebug Literal dom st -instance (SourceInfo st, Domain dom, TreeDebug k dom st, Generic (k dom st)) => TreeDebug (Promoted k) dom st - --- Base -instance (SourceInfo st, Domain dom) => TreeDebug Operator dom st -instance (SourceInfo st, Domain dom) => TreeDebug Name dom st -instance (SourceInfo st, Domain dom) => TreeDebug SimpleName dom st -instance (SourceInfo st, Domain dom) => TreeDebug ModuleName dom st -instance (SourceInfo st, Domain dom) => TreeDebug UnqualName dom st -instance (SourceInfo st, Domain dom) => TreeDebug StringNode dom st -instance (SourceInfo st, Domain dom) => TreeDebug DataOrNewtypeKeyword dom st -instance (SourceInfo st, Domain dom) => TreeDebug DoKind dom st -instance (SourceInfo st, Domain dom) => TreeDebug TypeKeyword dom st -instance (SourceInfo st, Domain dom) => TreeDebug OverlapPragma dom st -instance (SourceInfo st, Domain dom) => TreeDebug CallConv dom st -instance (SourceInfo st, Domain dom) => TreeDebug ArrowAppl dom st -instance (SourceInfo st, Domain dom) => TreeDebug Safety dom st -instance (SourceInfo st, Domain dom) => TreeDebug ConlikeAnnot dom st -instance (SourceInfo st, Domain dom) => TreeDebug Assoc dom st -instance (SourceInfo st, Domain dom) => TreeDebug Precedence dom st -instance (SourceInfo st, Domain dom) => TreeDebug LineNumber dom st -instance (SourceInfo st, Domain dom) => TreeDebug PhaseControl dom st -instance (SourceInfo st, Domain dom) => TreeDebug PhaseNumber dom st -instance (SourceInfo st, Domain dom) => TreeDebug PhaseInvert dom st
Language/Haskell/Tools/Refactor/RefactorBase.hs view
@@ -3,10 +3,14 @@ , ViewPatterns , StandaloneDeriving , LambdaCase + , FlexibleInstances + , FlexibleContexts + , TypeSynonymInstances + , MultiWayIf #-} module Language.Haskell.Tools.Refactor.RefactorBase where -import Language.Haskell.Tools.AST +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 @@ -27,22 +31,46 @@ import Control.Monad.Reader import Control.Monad.Trans.Except import Control.Monad.Writer +import Control.Monad.State --- | The information a refactoring can use -data RefactorCtx dom = RefactorCtx { refModuleName :: GHC.Module - , refCtxImports :: [Ann ImportDecl dom SrcTemplateStage] - } +type UnnamedModule dom = Ann AST.Module dom SrcTemplateStage +-- | The name of the module and the AST +type ModuleDom dom = (String, UnnamedModule dom) + +-- | A refactoring that only affects one module +type LocalRefactoring dom = UnnamedModule dom -> LocalRefactor dom (UnnamedModule dom) + +-- | The type of a refactoring +type Refactoring dom = ModuleDom dom -> [ModuleDom dom] -> Refactor [RefactorChange dom] + +-- | Change in the project, modification or removal of a module. +data RefactorChange dom = ContentChanged { fromContentChanged :: (ModuleDom dom) } + | ModuleRemoved { removedModuleName :: String } + -- | Performs the given refactoring, transforming it into a Ghc action -runRefactor :: (SemanticInfo' dom SameInfoModuleCls ~ ModuleInfo n) - => Ann Module dom SrcTemplateStage -> (Ann Module dom SrcTemplateStage -> RefactoredModule dom) -> Ghc (Either String (Ann Module dom SrcTemplateStage)) -runRefactor mod trf = let init = RefactorCtx (fromJust $ mod ^? semantics&defModuleName) (mod ^? element&modImports&annList) - in runExceptT $ runReaderT (addGeneratedImports (runWriterT (fromRefactorT $ trf mod))) init +runRefactor :: (HasModuleInfo dom) => ModuleDom dom -> [ModuleDom dom] -> Refactoring dom -> Ghc (Either String [RefactorChange dom]) +runRefactor mod mods trf = runExceptT $ trf mod mods +-- | Wraps a refactoring that only affects one module. Performs the per-module finishing touches. +localRefactoring :: HasModuleInfo dom => LocalRefactoring dom -> Refactoring dom +localRefactoring ref (name, mod) _ + = (\m -> [ContentChanged (name, m)]) <$> localRefactoringRes id mod (ref mod) + +-- | Transform the result of the local refactoring +localRefactoringRes :: HasModuleInfo dom + => ((UnnamedModule dom -> UnnamedModule dom) -> a -> a) + -> UnnamedModule dom + -> LocalRefactor dom a + -> Refactor a +localRefactoringRes access mod trf + = let init = RefactorCtx (semanticsModule $ mod ^. semantics) mod (mod ^? element&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 :: (Monad m) => ReaderT (RefactorCtx dom) m (Ann Module dom SrcTemplateStage, [GHC.Name]) -> ReaderT (RefactorCtx dom) m (Ann Module dom SrcTemplateStage) -addGeneratedImports = - fmap (\(m,names) -> element&modImports&annListElems .- (++ addImports names) $ m) +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] addImports names = map createImport $ groupBy ((==) `on` GHC.nameModule) $ nub $ sort names @@ -77,26 +105,48 @@ -- | Input and output information for the refactoring -newtype RefactorT dom m a = RefactorT { fromRefactorT :: WriterT [GHC.Name] (ReaderT (RefactorCtx dom) m) a } +newtype LocalRefactorT dom m a = LocalRefactorT { fromRefactorT :: WriterT [GHC.Name] (ReaderT (RefactorCtx dom) m) a } deriving (Functor, Applicative, Monad, MonadReader (RefactorCtx dom), MonadWriter [GHC.Name], MonadIO, HasDynFlags, ExceptionMonad, GhcMonad) -instance MonadTrans (RefactorT dom) where - lift = RefactorT . lift . lift +-- | The information a refactoring can use +data RefactorCtx dom = RefactorCtx { refModuleName :: GHC.Module + , refCtxRoot :: Ann Module dom SrcTemplateStage + , refCtxImports :: [Ann ImportDecl dom SrcTemplateStage] + } -refactError :: String -> Refactor n a -refactError = lift . throwE +instance MonadTrans (LocalRefactorT dom) where + lift = LocalRefactorT . lift . lift --- | The refactoring monad -type Refactor dom = RefactorT dom (ExceptT String Ghc) +-- | A monad that can be used to refactor +class Monad m => RefactorMonad m where + refactError :: String -> m a + liftGhc :: Ghc a -> m a -type RefactoredModule dom = Refactor dom (Ann Module dom SrcTemplateStage) +instance RefactorMonad Refactor where + refactError = throwE + liftGhc = lift +instance RefactorMonad (LocalRefactor dom) where + refactError = lift . refactError + liftGhc = lift . liftGhc + +instance RefactorMonad m => RefactorMonad (StateT s m) where + refactError = lift . refactError + liftGhc = lift . liftGhc + +-- | The refactoring monad for a given module +type LocalRefactor dom = LocalRefactorT dom Refactor + +-- | The refactoring monad for the whole project +type Refactor = ExceptT String Ghc + registeredNamesFromPrelude :: [GHC.Name] registeredNamesFromPrelude = GHC.basicKnownKeyNames ++ map GHC.tyConName GHC.wiredInTyCons otherNamesFromPrelude :: [String] otherNamesFromPrelude -- TODO: extend and revise this list + -- TODO: prelude names are simply existing names?? No need to check?? = ["GHC.Base.Maybe", "GHC.Base.Just", "GHC.Base.Nothing", "GHC.Base.maybe", "GHC.Base.either", "GHC.Base.not" , "Data.Tuple.curry", "Data.Tuple.uncurry", "GHC.Base.compare", "GHC.Base.max", "GHC.Base.min", "GHC.Base.id"] @@ -105,29 +155,29 @@ Just mod -> GHC.moduleNameString (GHC.moduleName mod) ++ "." ++ GHC.occNameString (GHC.nameOccName name) Nothing -> GHC.occNameString (GHC.nameOccName name) -referenceName :: (SemanticInfo' dom SameInfoImportCls ~ ImportInfo n, Eq n, GHC.NamedThing n) - => n -> Refactor dom (Ann Name dom SrcTemplateStage) +referenceName :: (HasImportInfo dom, HasModuleInfo dom) => GHC.Name -> LocalRefactor dom (Ann Name dom SrcTemplateStage) referenceName = referenceName' mkQualName' -referenceOperator :: (SemanticInfo' dom SameInfoImportCls ~ ImportInfo n, Eq n, GHC.NamedThing n) - => n -> Refactor dom (Ann Operator dom SrcTemplateStage) +referenceOperator :: (HasImportInfo dom, HasModuleInfo dom) => GHC.Name -> LocalRefactor dom (Ann Operator dom SrcTemplateStage) referenceOperator = referenceName' mkQualOp' -- | Create a name that references the definition. Generates an import if the definition is not yet imported. -referenceName' :: (SemanticInfo' dom SameInfoImportCls ~ ImportInfo n, Eq n, GHC.NamedThing n) - => ([String] -> GHC.Name -> Ann nt dom SrcTemplateStage) -> n -> Refactor dom (Ann nt dom SrcTemplateStage) -referenceName' makeName n@(GHC.getName -> name) +referenceName' :: (HasImportInfo dom, HasModuleInfo dom) + => ([String] -> GHC.Name -> Ann nt dom SrcTemplateStage) -> GHC.Name -> LocalRefactor dom (Ann nt dom SrcTemplateStage) +referenceName' makeName name | name `elem` registeredNamesFromPrelude || qualifiedName name `elem` otherNamesFromPrelude = return $ makeName [] name -- imported from prelude | otherwise - = do RefactorCtx {refCtxImports = imports, refModuleName = thisModule} <- ask + = do RefactorCtx {refCtxRoot = mod, refCtxImports = imports, refModuleName = thisModule} <- ask if maybe True (thisModule ==) (GHC.nameModule_maybe name) then return $ makeName [] name -- in the same module, use simple name - else let possibleImports = filter ((n `elem`) . (\imp -> fromJust $ imp ^? semantics&importedNames)) imports - in if null possibleImports - then do tell [name] - return $ makeName [] name - else return $ referenceBy makeName name possibleImports -- use it according to the best available import + else let possibleImports = filter ((name `elem`) . (\imp -> semanticsImported $ imp ^. semantics)) imports + fromPrelude = name `elem` semanticsImplicitImports (mod ^. semantics) + in if | fromPrelude -> return $ makeName [] name + | null possibleImports -> do tell [name] + return $ makeName [] name + | otherwise -> return $ referenceBy makeName name possibleImports + -- 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 @@ -150,8 +200,8 @@ | SynonymOperator -- ^ Type definitions with operator-like names -- | Get which category does a given name belong to -classifyName :: GHC.Name -> Refactor dom NameClass -classifyName n = lookupName n >>= return . \case +classifyName :: RefactorMonad m => GHC.Name -> m NameClass +classifyName n = liftGhc (lookupName n) >>= return . \case Just (AnId id) | isop -> ValueOperator Just (AnId id) -> Variable Just (AConLike id) | isop -> DataCtorOperator @@ -162,6 +212,9 @@ Nothing -> Variable where isop = GHC.isSymOcc (GHC.getOccName n) +-- | Checks if a given name is a valid module name +validModuleName :: String -> Bool +validModuleName s = all (nameValid Ctor) (splitOn "." s) -- | Check if a given name is valid for a given kind of definition nameValid :: NameClass -> String -> Bool
Language/Haskell/Tools/Refactor/RenameDefinition.hs view
@@ -15,12 +15,15 @@ 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 @@ -30,39 +33,82 @@ import Debug.Trace -type DomainRenameDefinition dom = ( Domain dom, HasNameInfo (SemanticInfo' dom SameInfoNameCls), Data (SemanticInfo' dom SameInfoNameCls) - , HasScopeInfo (SemanticInfo' dom SameInfoNameCls), HasDefiningInfo (SemanticInfo' dom SameInfoNameCls) ) +type DomainRenameDefinition dom = ( HasNameInfo dom, HasScopeInfo dom, HasDefiningInfo dom + , HasImplicitFieldsInfo dom, HasModuleInfo dom ) -renameDefinition' :: forall dom . DomainRenameDefinition dom => RealSrcSpan -> String -> Ann Module dom SrcTemplateStage -> RefactoredModule dom -renameDefinition' sp str mod - = case (getNodeContaining sp mod :: Maybe (Ann SimpleName dom SrcTemplateStage)) >>= (fmap getName . (semanticsName =<<) . (^? semantics)) of - Just n -> renameDefinition n str mod - Nothing -> refactError "No name is selected" +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" -renameDefinition :: DomainRenameDefinition dom => GHC.Name -> String -> Ann Module dom SrcTemplateStage -> RefactoredModule dom -renameDefinition toChange newName mod - = do nameCls <- classifyName toChange - (res,defFound) <- runStateT (biplateRef !~ changeName toChange newName $ mod) False +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 res + | otherwise -> return $ map ContentChanged changedModules where - changeName :: DomainRenameDefinition dom => GHC.Name -> String -> Ann SimpleName dom SrcTemplateStage -> StateT Bool (Refactor dom) (Ann SimpleName dom SrcTemplateStage) - changeName toChange str elem - = if | fmap getName (semanticsName (elem ^. semantics)) == Just toChange - && semanticsDefining (elem ^. semantics) == False - && any @[] ((str ==) . occNameString . getOccName) (semanticsScope (elem ^. semantics) ^? Ref.element 0 & traversal) - -> lift $ refactError "The definition clashes with an existing one" -- name clash with an external definition - | fmap getName (semanticsName (elem ^. semantics)) == Just toChange - -> do modify (|| semanticsDefining (elem ^. semantics)) - return $ element & unqualifiedName .= mkNamePart str $ elem - | let namesInScope = semanticsScope (elem ^. semantics) - in case semanticsName (elem ^. semantics) of - Just (getName -> exprName) -> str == occNameString (getOccName exprName) && sameNamespace toChange exprName - && conflicts toChange exprName namesInScope - Nothing -> False -- ambiguous names - -> lift $ refactError "The definition clashes with an existing one" -- local name clash - | otherwise -> return elem + 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)
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple+import Distribution.Simple main = defaultMain
haskell-tools-refactor.cabal view
@@ -1,5 +1,5 @@ name: haskell-tools-refactor -version: 0.1.3.0 +version: 0.2.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 @@ -19,11 +19,10 @@ , Language.Haskell.Tools.Refactor.RenameDefinition , Language.Haskell.Tools.Refactor.ExtractBinding , Language.Haskell.Tools.Refactor.RefactorBase - other-modules: Language.Haskell.Tools.Refactor.RangeDebug - , Language.Haskell.Tools.Refactor.RangeDebug.Instances - , Language.Haskell.Tools.Refactor.ASTDebug - , Language.Haskell.Tools.Refactor.ASTDebug.Instances - , Language.Haskell.Tools.Refactor.DebugGhcAST + , Language.Haskell.Tools.Refactor.DataToNewtype + , Language.Haskell.Tools.Refactor.IfToGuards + , Language.Haskell.Tools.Refactor.DollarApp + , Language.Haskell.Tools.Refactor.GetModules build-depends: base >=4.9 && <5.0 , ghc >=8.0 && <8.1 , mtl >=2.2 && <2.3 @@ -34,14 +33,42 @@ , transformers >=0.5 && <0.6 , references >=0.3.2 && <1.0 , split >=0.2 && <1.0 - , time >=1.5 && <2.0 , filepath >=1.4 && <2.0 - , either >=4.0 && <5.0 - , haskell-tools-ast >=0.1.3 && <0.2 - , haskell-tools-ast-fromghc >=0.1.3 && <0.2 - , haskell-tools-ast-gen >=0.1.3 && <0.2 - , haskell-tools-ast-trf >=0.1.3 && <0.2 - , haskell-tools-prettyprint >=0.1.3 && <0.2 + , 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 default-language: Haskell2010 - + +test-suite haskell-tools-test + type: exitcode-stdio-1.0 + ghc-options: -with-rtsopts=-M2g + 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 + default-language: Haskell2010