haskell-tools-refactor (empty) → 0.1.2.0
raw patch · 15 files changed
+1901/−0 lines, 15 filesdep +basedep +containersdep +directorysetup-changed
Dependencies added: base, containers, directory, either, filepath, ghc, ghc-paths, haskell-tools-ast, haskell-tools-ast-fromghc, haskell-tools-ast-gen, haskell-tools-ast-trf, haskell-tools-prettyprint, mtl, references, split, structural-traversal, template-haskell, time, transformers, uniplate
Files
- LICENSE +29/−0
- Language/Haskell/Tools/Refactor.hs +253/−0
- Language/Haskell/Tools/Refactor/ASTDebug.hs +162/−0
- Language/Haskell/Tools/Refactor/ASTDebug/Instances.hs +135/−0
- Language/Haskell/Tools/Refactor/DebugGhcAST.hs +369/−0
- Language/Haskell/Tools/Refactor/ExtractBinding.hs +155/−0
- Language/Haskell/Tools/Refactor/GenerateExports.hs +48/−0
- Language/Haskell/Tools/Refactor/GenerateTypeSignature.hs +136/−0
- Language/Haskell/Tools/Refactor/OrganizeImports.hs +93/−0
- Language/Haskell/Tools/Refactor/RangeDebug.hs +80/−0
- Language/Haskell/Tools/Refactor/RangeDebug/Instances.hs +137/−0
- Language/Haskell/Tools/Refactor/RefactorBase.hs +190/−0
- Language/Haskell/Tools/Refactor/RenameDefinition.hs +64/−0
- Setup.hs +2/−0
- haskell-tools-refactor.cabal +48/−0
+ LICENSE view
@@ -0,0 +1,29 @@+Haskell-Tools is Copyright (c) Boldizsár Németh, 2016, all rights reserved, +and is distributed as free software under the following license. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +- Redistributions of source code must retain the above copyright +notice, this list of conditions, and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright +notice, this list of conditions, and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +- The names of the copyright holders may not be used to endorse or +promote products derived from this software without specific prior +written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Language/Haskell/Tools/Refactor.hs view
@@ -0,0 +1,253 @@+{-# LANGUAGE StandaloneDeriving + , DeriveGeneric + , LambdaCase + , ScopedTypeVariables + , BangPatterns + , MultiWayIf + #-} +module Language.Haskell.Tools.Refactor where + +import Language.Haskell.Tools.AST.FromGHC +import Language.Haskell.Tools.AST as AST +import Language.Haskell.Tools.AnnTrf.RangeToRangeTemplate +import Language.Haskell.Tools.AnnTrf.RangeTemplateToSourceTemplate +import Language.Haskell.Tools.AnnTrf.SourceTemplate +import Language.Haskell.Tools.AnnTrf.RangeTemplate +import Language.Haskell.Tools.AnnTrf.PlaceComments +import Language.Haskell.Tools.PrettyPrint.RoseTree +import Language.Haskell.Tools.PrettyPrint +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) +import Outputable +import BasicTypes +import Bag +import Var +import SrcLoc +import Module +import FastString +import HscTypes +import GHC.Paths ( libdir ) + +import Data.List +import Data.List.Split +import GHC.Generics hiding (moduleName) +import Data.StructuralTraversal +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 +import Control.Reference +import Control.Exception +import System.Directory +import System.IO +import System.FilePath +import Data.Generics.Uniplate.Operations + +import Language.Haskell.Tools.Refactor.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.TH.LanguageExtensions + +import DynFlags +import StringBuffer + +import Debug.Trace + + +type TemplateWithNames = NodeInfo (SemanticInfo GHC.Name) SourceTemplate +type TemplateWithTypes = NodeInfo (SemanticInfo GHC.Id) SourceTemplate + +data RefactorCommand = NoRefactor + | OrganizeImports + | GenerateExports + | GenerateSignature RealSrcSpan + | RenameDefinition RealSrcSpan String + | ExtractBinding RealSrcSpan String + deriving Show + +performCommand :: RefactorCommand -> Ann AST.Module TemplateWithTypes -> Ghc (Either String (Ann AST.Module TemplateWithTypes)) +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") + +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") + + +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) + +astView :: String -> String -> IO String +astView workingDir target = + runGhc (Just libdir) $ + (astDebug <$> (parseTyped =<< loadModule workingDir target)) + +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 + } + target <- guessTarget moduleName Nothing + setTargets [target] + load LoadAllTargets + getModSummary $ mkModuleName moduleName + +parseTyped :: ModSummary -> Ghc (Ann AST.Module TemplateWithTypes) +parseTyped modSum = do + p <- parseModule modSum + tc <- typecheckModule p + let annots = pm_annotations p + srcBuffer = fromJust $ ms_hspp_buf $ pm_mod_summary p + rangeToSource srcBuffer . cutUpRanges . fixRanges . placeComments (getNormalComments $ snd annots) + <$> (addTypeInfos (typecheckedSource tc) + =<< (do parseTrf <- runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModule (pm_parsed_source p) + runTrf (fst annots) (getPragmaComments $ snd annots) + $ trfModuleRename (ms_mod $ modSum) parseTrf + (fromJust $ tm_renamed_source tc) + (pm_parsed_source p))) + +parseRenamed :: ModSummary -> Ghc (Ann AST.Module TemplateWithNames) +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 (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 + + -- 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 (pm_parsed_source p) + liftIO $ putStrLn $ rangeDebug 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 $ rangeDebug transformed + liftIO $ putStrLn "=========== ranges fixed:" + let commented = fixRanges $ placeComments (getNormalComments $ snd annots) transformed + liftIO $ putStrLn $ rangeDebug commented + liftIO $ putStrLn "=========== cut up:" + let cutUp = cutUpRanges commented + liftIO $ putStrLn $ templateDebug cutUp + liftIO $ putStrLn "=========== sourced:" + let sourced = rangeToSource (fromJust $ ms_hspp_buf $ pm_mod_summary p) cutUp + liftIO $ putStrLn $ sourceTemplateDebug 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 $ sourceTemplateDebug correctlyTransformed + liftIO $ putStrLn "=========== transformed & prettyprinted:" + let prettyPrinted = prettyPrint correctlyTransformed + liftIO $ putStrLn prettyPrinted + liftIO $ putStrLn "===========" + Left transformProblem -> do + liftIO $ putStrLn "===========" + liftIO $ putStrLn transformProblem + liftIO $ putStrLn "===========" + +printSemaInfo :: (StructuralTraversable node, Outputable n) => node (NodeInfo (SemanticInfo n) src) -> Ghc (node (NodeInfo (SemanticInfo n) src)) +printSemaInfo = traverseUp (return ()) (return ()) (\n@(NodeInfo s _) -> liftIO (print s) >> return n) + +deriving instance Generic SrcSpan +deriving instance (Generic sema, Generic src) => Generic (NodeInfo sema src) +deriving instance Generic RangeTemplate +deriving instance Generic (SemanticInfo n) +deriving instance Generic SourceTemplate +deriving instance Generic SpanInfo
+ Language/Haskell/Tools/Refactor/ASTDebug.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE TypeOperators + , DefaultSignatures + , StandaloneDeriving + , FlexibleContexts + , FlexibleInstances + , MultiParamTypeClasses + , TypeFamilies + , TemplateHaskell + , OverloadedStrings + , LambdaCase + , ViewPatterns + , ScopedTypeVariables + #-} +-- | 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 a = TreeNode { _nodeLabel :: String + , _nodeSubtree :: TreeDebugNode a + } + | SimpleNode { _nodeLabel :: String + , _nodeValue :: String + } + deriving Show + +data TreeDebugNode a + = TreeDebugNode { _nodeName :: String + , _nodeInfo :: a + , _children :: [DebugNode a] + } + deriving Show + +makeReferences ''DebugNode +makeReferences ''TreeDebugNode + +astDebug :: (InspectableName n, HasRange a, ASTDebug e a, a ~ (NodeInfo (SemanticInfo n) src)) => e a -> String +astDebug ast = toList (astDebugToJson (astDebug' ast)) + +astDebugToJson :: (InspectableName n, HasRange a, a ~ (NodeInfo (SemanticInfo n) src)) => [DebugNode a] -> 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 :: (InspectableName n, HasRange a, a ~ (NodeInfo (SemanticInfo n) src)) => TreeDebugNode a -> Seq Char +astDebugElemJson (TreeDebugNode name info children) + = fromList "{ \"text\" : \"" >< fromList name + >< fromList "\", \"state\" : { \"opened\" : true }, \"a_attr\" : { \"data-range\" : \"" + >< fromList (shortShowSpan (getRange info)) + >< fromList "\", \"data-elems\" : \"" + >< foldl (><) Seq.empty dataElems + >< fromList "\", \"data-sema\" : \"" + >< fromList (showSema (info ^. semanticInfo)) + >< 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 InspectableName n => AssocData (SemanticInfo n) where + assocName NoSemanticInfo = "NoSemanticInfo" + assocName (ScopeInfo {}) = "ScopeInfo" + assocName (NameInfo {}) = "NameInfo" + assocName (ModuleInfo {}) = "ModuleInfo" + assocName (ImportInfo {}) = "ImportInfo" + + toAssoc NoSemanticInfo = [] + toAssoc (ScopeInfo locals) = [ ("namesInScope", inspectScope locals) ] + toAssoc (NameInfo locals defined nameInfo) = [ ("name", inspect nameInfo) + , ("isDefined", show defined) + , ("namesInScope", inspectScope locals) + ] + toAssoc (ModuleInfo mod imps) = [("moduleName", showSDocUnsafe (ppr mod)) + ,("implicitImports", concat (intersperse ", " (map inspect imps)))] + 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 ASTDebug e a where + astDebug' :: e a -> [DebugNode a] + default astDebug' :: (GAstDebug (Rep (e a)) a, Generic (e a)) => e a -> [DebugNode a] + astDebug' = gAstDebug . from + +class GAstDebug f a where + gAstDebug :: f p -> [DebugNode a] + +instance GAstDebug V1 a where + gAstDebug _ = error "GAstDebug V1" + +instance GAstDebug U1 a where + gAstDebug U1 = [] + +instance (GAstDebug f a, GAstDebug g a) => GAstDebug (f :+: g) a where + gAstDebug (L1 x) = gAstDebug x + gAstDebug (R1 x) = gAstDebug x + +instance (GAstDebug f a, GAstDebug g a) => GAstDebug (f :*: g) a where + gAstDebug (x :*: y) + = gAstDebug x ++ gAstDebug y + +instance {-# OVERLAPPING #-} ASTDebug e a => GAstDebug (K1 i (e a)) a where + gAstDebug (K1 x) = astDebug' x + +instance {-# OVERLAPPABLE #-} Show x => GAstDebug (K1 i x) a where + gAstDebug (K1 x) = [SimpleNode "" (show x)] + +instance (GAstDebug f a, Constructor c) => GAstDebug (M1 C c f) a where + gAstDebug c@(M1 x) = [TreeNode "" (TreeDebugNode (conName c) undefined (gAstDebug x))] + +instance (GAstDebug f a, Selector s) => GAstDebug (M1 S s f) a where + gAstDebug s@(M1 x) = traversal&nodeLabel .= selName s $ gAstDebug x + +-- don't have to do anything with datatype metainfo +instance GAstDebug f a => GAstDebug (M1 D t f) a where + gAstDebug (M1 x) = gAstDebug x
+ Language/Haskell/Tools/Refactor/ASTDebug/Instances.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE FlexibleContexts + , FlexibleInstances + , MultiParamTypeClasses + , StandaloneDeriving + , DeriveGeneric + , UndecidableInstances + #-} +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 (ASTDebug e a, Show (e a)) => ASTDebug (Ann e) a where + astDebug' (Ann a e) = traversal&nodeSubtree&nodeInfo .= a $ astDebug' e + +instance (ASTDebug e a, Show (e a)) => ASTDebug (AnnList e) a where + astDebug' (AnnList a ls) = [TreeNode "" (TreeDebugNode "*" a (concatMap astDebug' ls))] + +instance (ASTDebug e a, Show (e a)) => ASTDebug (AnnMaybe e) a where + astDebug' (AnnMaybe a e) = [TreeNode "" (TreeDebugNode "?" a (maybe [] astDebug' e))] + +-- Modules +instance (Generic a, Show a) => ASTDebug Module a +instance (Generic a, Show a) => ASTDebug ModuleHead a +instance (Generic a, Show a) => ASTDebug ExportSpecList a +instance (Generic a, Show a) => ASTDebug ExportSpec a +instance (Generic a, Show a) => ASTDebug IESpec a +instance (Generic a, Show a) => ASTDebug SubSpec a +instance (Generic a, Show a) => ASTDebug ModulePragma a +instance (Generic a, Show a) => ASTDebug FilePragma a +instance (Generic a, Show a) => ASTDebug ImportDecl a +instance (Generic a, Show a) => ASTDebug ImportSpec a +instance (Generic a, Show a) => ASTDebug ImportQualified a +instance (Generic a, Show a) => ASTDebug ImportSource a +instance (Generic a, Show a) => ASTDebug ImportSafe a +instance (Generic a, Show a) => ASTDebug TypeNamespace a +instance (Generic a, Show a) => ASTDebug ImportRenaming a + +-- Declarations +instance (Generic a, Show a) => ASTDebug Decl a +instance (Generic a, Show a) => ASTDebug ClassBody a +instance (Generic a, Show a) => ASTDebug ClassElement a +instance (Generic a, Show a) => ASTDebug DeclHead a +instance (Generic a, Show a) => ASTDebug InstBody a +instance (Generic a, Show a) => ASTDebug InstBodyDecl a +instance (Generic a, Show a) => ASTDebug GadtConDecl a +instance (Generic a, Show a) => ASTDebug GadtConType a +instance (Generic a, Show a) => ASTDebug GadtField a +instance (Generic a, Show a) => ASTDebug FunDeps a +instance (Generic a, Show a) => ASTDebug FunDep a +instance (Generic a, Show a) => ASTDebug ConDecl a +instance (Generic a, Show a) => ASTDebug FieldDecl a +instance (Generic a, Show a) => ASTDebug Deriving a +instance (Generic a, Show a) => ASTDebug InstanceRule a +instance (Generic a, Show a) => ASTDebug InstanceHead a +instance (Generic a, Show a) => ASTDebug TypeEqn a +instance (Generic a, Show a) => ASTDebug KindConstraint a +instance (Generic a, Show a) => ASTDebug TyVar a +instance (Generic a, Show a) => ASTDebug Type a +instance (Generic a, Show a) => ASTDebug Kind a +instance (Generic a, Show a) => ASTDebug Context a +instance (Generic a, Show a) => ASTDebug Assertion a +instance (Generic a, Show a) => ASTDebug Expr a +instance (Generic a, Show a, ASTDebug expr a, Show (expr a), Generic (expr a)) => ASTDebug (Stmt' expr) a +instance (Generic a, Show a) => ASTDebug CompStmt a +instance (Generic a, Show a) => ASTDebug ValueBind a +instance (Generic a, Show a) => ASTDebug Pattern a +instance (Generic a, Show a) => ASTDebug PatternField a +instance (Generic a, Show a) => ASTDebug Splice a +instance (Generic a, Show a) => ASTDebug QQString a +instance (Generic a, Show a) => ASTDebug Match a +instance (Generic a, Show a, ASTDebug expr a, Show (expr a), Generic (expr a)) => ASTDebug (Alt' expr) a +instance (Generic a, Show a) => ASTDebug Rhs a +instance (Generic a, Show a) => ASTDebug GuardedRhs a +instance (Generic a, Show a) => ASTDebug FieldUpdate a +instance (Generic a, Show a) => ASTDebug Bracket a +instance (Generic a, Show a) => ASTDebug TopLevelPragma a +instance (Generic a, Show a) => ASTDebug Rule a +instance (Generic a, Show a) => ASTDebug AnnotationSubject a +instance (Generic a, Show a) => ASTDebug MinimalFormula a +instance (Generic a, Show a) => ASTDebug ExprPragma a +instance (Generic a, Show a) => ASTDebug SourceRange a +instance (Generic a, Show a) => ASTDebug Number a +instance (Generic a, Show a) => ASTDebug QuasiQuote a +instance (Generic a, Show a) => ASTDebug RhsGuard a +instance (Generic a, Show a) => ASTDebug LocalBind a +instance (Generic a, Show a) => ASTDebug LocalBinds a +instance (Generic a, Show a) => ASTDebug FixitySignature a +instance (Generic a, Show a) => ASTDebug TypeSignature a +instance (Generic a, Show a) => ASTDebug ListCompBody a +instance (Generic a, Show a) => ASTDebug TupSecElem a +instance (Generic a, Show a) => ASTDebug TypeFamily a +instance (Generic a, Show a) => ASTDebug TypeFamilySpec a +instance (Generic a, Show a) => ASTDebug InjectivityAnn a +instance (Generic a, Show a, ASTDebug expr a, Show (expr a), Generic (expr a)) => ASTDebug (CaseRhs' expr) a +instance (Generic a, Show a, ASTDebug expr a, Show (expr a), Generic (expr a)) => ASTDebug (GuardedCaseRhs' expr) a +instance (Generic a, Show a) => ASTDebug PatternSynonym a +instance (Generic a, Show a) => ASTDebug PatSynRhs a +instance (Generic a, Show a) => ASTDebug PatSynLhs a +instance (Generic a, Show a) => ASTDebug PatSynWhere a +instance (Generic a, Show a) => ASTDebug PatternTypeSignature a +instance (Generic a, Show a) => ASTDebug Role a +instance (Generic a, Show a) => ASTDebug Cmd a +instance (Generic a, Show a) => ASTDebug LanguageExtension a +instance (Generic a, Show a) => ASTDebug MatchLhs a + +-- Literal +instance (Generic a, Show a) => ASTDebug Literal a +instance (Generic a, Show a, ASTDebug k a, Show (k a), Generic (k a)) => ASTDebug (Promoted k) a + +-- Base +instance (Generic a, Show a) => ASTDebug Operator a +instance (Generic a, Show a) => ASTDebug Name a +instance (Generic a, Show a) => ASTDebug SimpleName a +instance (Generic a, Show a) => ASTDebug UnqualName a +instance (Generic a, Show a) => ASTDebug StringNode a +instance (Generic a, Show a) => ASTDebug DataOrNewtypeKeyword a +instance (Generic a, Show a) => ASTDebug DoKind a +instance (Generic a, Show a) => ASTDebug TypeKeyword a +instance (Generic a, Show a) => ASTDebug OverlapPragma a +instance (Generic a, Show a) => ASTDebug CallConv a +instance (Generic a, Show a) => ASTDebug ArrowAppl a +instance (Generic a, Show a) => ASTDebug Safety a +instance (Generic a, Show a) => ASTDebug ConlikeAnnot a +instance (Generic a, Show a) => ASTDebug Assoc a +instance (Generic a, Show a) => ASTDebug Precedence a +instance (Generic a, Show a) => ASTDebug LineNumber a +instance (Generic a, Show a) => ASTDebug PhaseControl a +instance (Generic a, Show a) => ASTDebug PhaseNumber a +instance (Generic a, Show a) => ASTDebug PhaseInvert a
+ Language/Haskell/Tools/Refactor/DebugGhcAST.hs view
@@ -0,0 +1,369 @@+{-# 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 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/ExtractBinding.hs view
@@ -0,0 +1,155 @@+ +{-# LANGUAGE ViewPatterns + , RankNTypes + , FlexibleContexts + , TypeApplications + #-} +module Language.Haskell.Tools.Refactor.ExtractBinding where + +import qualified GHC +import qualified Var as GHC +import qualified OccName as GHC hiding (varName) +import SrcLoc +import Unique + +import Data.Char +import Data.Maybe +import Data.Generics.Uniplate.Data +import Control.Reference hiding (element) +import Control.Monad.State +import Language.Haskell.Tools.AST +import Language.Haskell.Tools.AnnTrf.SourceTemplate +import Language.Haskell.Tools.AST.Gen +import Language.Haskell.Tools.Refactor.RefactorBase +import Language.Haskell.Tools.AnnTrf.SourceTemplateHelpers + +import Debug.Trace + +type STWithId = STWithNames GHC.Id + +extractBinding' :: RealSrcSpan -> String -> Ann Module STWithId -> RefactoredModule GHC.Id +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 :: Simple Traversal (Ann Module STWithId) (Ann ValueBind STWithId) + -> Simple Traversal (Ann ValueBind STWithId) (Ann Expr STWithId) + -> String -> Ann Module STWithId -> RefactoredModule GHC.Id +extractBinding selectDecl selectExpr name mod + = let conflicting = any @[] (isConflicting name) (mod ^? selectDecl & biplateRef) + exprRange = head (mod ^? selectDecl & selectExpr & annotation & sourceInfo & sourceTemplateRange) + decl = last (mod ^? selectDecl) + declRange = last (mod ^? selectDecl & annotation & sourceInfo & sourceTemplateRange) + in if conflicting + then refactError "The given name causes name conflict." + else do (res, st) <- runStateT (selectDecl&selectExpr !~ extractThatBind name (head $ decl ^? actualContainingExpr exprRange) $ mod) Nothing + case st of Just def -> return $ evalState (selectDecl&element !~ addLocalBinding declRange exprRange def $ res) False + Nothing -> refactError "There is no applicable expression to extract." + +isConflicting :: String -> Ann SimpleName STWithId -> Bool +isConflicting name used + = (used ^? semantics & isDefined) == Just True + && (GHC.occNameString . GHC.getOccName <$> (used ^? semantics & nameInfo)) == Just name + +-- Replaces the selected expression with a call and generates the called binding. +extractThatBind :: String -> Ann Expr STWithId -> Ann Expr STWithId -> StateT (Maybe (Ann ValueBind STWithId)) (Refactor GHC.Id) (Ann Expr STWithId) +extractThatBind name cont e + = do ret <- get + if (isJust ret) then return e + else case (e ^. element) of + Paren {} | hasParameter -> element & exprInner !~ doExtract name cont $ e + | otherwise -> doExtract name cont (fromJust $ e ^? element & exprInner) + Var {} -> lift $ refactError "The selected expression is too simple to be extracted." + el | isParenLikeExpr el && hasParameter -> mkParen <$> doExtract name cont e + el -> doExtract name cont e + where hasParameter = not (null (getExternalBinds cont e)) + +addLocalBinding :: SrcSpan -> SrcSpan -> Ann ValueBind STWithId -> ValueBind STWithId -> State Bool (ValueBind STWithId) +addLocalBinding declRange exprRange local bind + = do done <- get + if not done then do put True + return $ doAddBinding declRange exprRange local bind + else return bind + where + doAddBinding declRng _ local sb@(SimpleBind {}) = valBindLocals .- insertLocalBind declRng local $ sb + doAddBinding declRng (RealSrcSpan rng) local fb@(FunBind {}) + = funBindMatches & annList & filtered (isInside rng) & element & matchBinds .- insertLocalBind declRng local $ fb + +insertLocalBind :: SrcSpan -> Ann ValueBind STWithId -> AnnMaybe LocalBinds STWithId -> AnnMaybe LocalBinds STWithId +insertLocalBind declRng toInsert locals + | isAnnNothing locals + , RealSrcSpan rng <- declRng = -- creates the new where clause indented 2 spaces from the declaration + mkLocalBinds (srcLocCol (realSrcSpanStart rng) + 2) [mkLocalValBind toInsert] + | otherwise = annJust & element & localBinds .- insertWhere (mkLocalValBind toInsert) (const True) isNothing $ locals + +-- | All expressions that are bound stronger than function application. +isParenLikeExpr :: Expr a -> Bool +isParenLikeExpr (If {}) = True +isParenLikeExpr (Paren {}) = True +isParenLikeExpr (List {}) = True +isParenLikeExpr (ParArray {}) = True +isParenLikeExpr (LeftSection {}) = True +isParenLikeExpr (RightSection {}) = True +isParenLikeExpr (RecCon {}) = True +isParenLikeExpr (RecUpdate {}) = True +isParenLikeExpr (Enum {}) = True +isParenLikeExpr (ParArrayEnum {}) = True +isParenLikeExpr (ListComp {}) = True +isParenLikeExpr (ParArrayComp {}) = True +isParenLikeExpr (BracketExpr {}) = True +isParenLikeExpr (Splice {}) = True +isParenLikeExpr (QuasiQuoteExpr {}) = True +isParenLikeExpr _ = False + +doExtract :: String -> Ann Expr STWithId -> Ann Expr STWithId -> StateT (Maybe (Ann ValueBind STWithId)) (Refactor GHC.Id) (Ann Expr STWithId) +doExtract name cont e@((^. element) -> lam@(Lambda {})) + = do let params = getExternalBinds cont e + put (Just (generateBind name (map mkVarPat params ++ (lam ^? exprBindings&annList)) (fromJust $ lam ^? exprInner))) + return (generateCall name params) +doExtract name cont e + = do let params = getExternalBinds cont e + put (Just (generateBind name (map mkVarPat params) e)) + return (generateCall name params) + +-- | Gets the values that have to be passed to the extracted definition +getExternalBinds :: Ann Expr STWithId -> Ann Expr STWithId -> [Ann Name STWithId] +getExternalBinds cont expr = map exprToName $ keepFirsts $ filter isApplicableName (expr ^? uniplateRef) + where isApplicableName name@(fmap GHC.varName . getExprNameInfo -> Just nm) = inScopeForOriginal nm && notInScopeForExtracted nm + isApplicableName _ = False + + getExprNameInfo :: Ann Expr STWithId -> Maybe GHC.Var + getExprNameInfo expr = (listToMaybe $ expr ^? element & (exprName&element&simpleName &+& exprOperator&element&operatorName) + & semantics&nameInfo) + + -- | Creates the parameter value to pass the name (operators are passed in parentheses) + exprToName :: Ann Expr STWithId -> Ann Name STWithId + exprToName e | Just n <- e ^? element & exprName = n + | Just op <- e ^? element & exprOperator & element & operatorName = mkParenName op + + notInScopeForExtracted :: GHC.Name -> Bool + notInScopeForExtracted n = notElem @[] n (cont ^? semantics & scopedLocals & traversal & traversal) + + inScopeForOriginal :: GHC.Name -> Bool + inScopeForOriginal n = elem @[] n (expr ^? semantics & scopedLocals & traversal & traversal) + + keepFirsts (e:rest) = e : keepFirsts (filter (/= e) rest) + keepFirsts [] = [] + +actualContainingExpr :: SrcSpan -> Simple Traversal (Ann ValueBind STWithId) (Ann Expr STWithId) +actualContainingExpr (RealSrcSpan rng) = element & accessRhs & element & accessExpr + where accessRhs :: Simple Traversal (ValueBind STWithId) (Ann Rhs STWithId) + accessRhs = valBindRhs &+& funBindMatches & annList & filtered (isInside rng) & element & matchRhs + accessExpr :: Simple Traversal (Rhs STWithId) (Ann Expr STWithId) + accessExpr = rhsExpr &+& rhsGuards & annList & filtered (isInside rng) & element & guardExpr + +-- | Generates the expression that calls the local binding +generateCall :: String -> [Ann Name STWithId] -> Ann Expr STWithId +generateCall name args = foldl (\e a -> mkApp e (mkVar a)) (mkVar $ mkNormalName $ mkSimpleName name) args + +-- | Generates the local binding for the selected expression +generateBind :: String -> [Ann Pattern STWithId] -> Ann Expr STWithId -> Ann ValueBind STWithId +generateBind name [] e = mkSimpleBind (mkVarPat $ mkNormalName $ mkSimpleName name) (mkUnguardedRhs e) Nothing +generateBind name args e = mkFunctionBind [mkMatch (mkNormalMatchLhs (mkNormalName $ mkSimpleName name) args) (mkUnguardedRhs e) Nothing] + +isValidBindingName :: String -> Bool +isValidBindingName = nameValid Variable
+ Language/Haskell/Tools/Refactor/GenerateExports.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE TupleSections #-} +module Language.Haskell.Tools.Refactor.GenerateExports where + +import Control.Reference hiding (element) + +import qualified GHC + +import Data.Maybe + +import Language.Haskell.Tools.AST +import Language.Haskell.Tools.AnnTrf.SourceTemplate +import Language.Haskell.Tools.AST.Gen +import Language.Haskell.Tools.Refactor.RefactorBase + +-- | Creates an export list that imports standalone top-level definitions with all of their contained definitions +generateExports :: GHC.NamedThing n => Ann Module (STWithNames n) -> RefactoredModule n +generateExports mod = return (element & modHead & annJust & element & mhExports & annMaybe .= Just (createExports (getTopLevels mod)) $ mod) + +-- | Get all the top-level definitions with flags that mark if they can contain other top-level definitions +-- (classes and data declarations). +getTopLevels :: Ann Module (STWithNames n) -> [(n, Bool)] +getTopLevels mod = catMaybes $ map (\d -> fmap (,exportContainOthers d) (getTopLevelDeclName d)) (mod ^? element & modDecl & annList & element) + where exportContainOthers :: Decl (STWithNames n) -> Bool + exportContainOthers (DataDecl {}) = True + exportContainOthers (ClassDecl {}) = True + exportContainOthers _ = False + +-- | Get all the standalone top level definitions (their GHC unique names) in a module. +-- You could also do getting all the names with a biplate reference and select the top-level ones, but this is more efficient. +getTopLevelDeclName :: Decl (NodeInfo (SemanticInfo n) src) -> Maybe n +getTopLevelDeclName (d @ TypeDecl {}) = listToMaybe (d ^? declHead & dhNames) +getTopLevelDeclName (d @ TypeFamilyDecl {}) = listToMaybe (d ^? declTypeFamily & element & tfHead & dhNames) +getTopLevelDeclName (d @ ClosedTypeFamilyDecl {}) = listToMaybe (d ^? declHead & dhNames) +getTopLevelDeclName (d @ DataDecl {}) = listToMaybe (d ^? declHead & dhNames) +getTopLevelDeclName (d @ GDataDecl {}) = listToMaybe (d ^? declHead & dhNames) +getTopLevelDeclName (d @ ClassDecl {}) = listToMaybe (d ^? declHead & dhNames) +getTopLevelDeclName (d @ PatternSynonymDecl {}) + = listToMaybe (d ^? declPatSyn & element & patLhs & element & (patName & element & simpleName &+& patSynOp & element & operatorName) & semantics & nameInfo) +getTopLevelDeclName (d @ ValueBinding {}) = listToMaybe (d ^? declValBind & bindingName) +getTopLevelDeclName (d @ ForeignImport {}) = listToMaybe (d ^? declName & element & simpleName & semantics & nameInfo) +getTopLevelDeclName _ = Nothing + +-- | Create the export for a give name. +createExports :: GHC.NamedThing n => [(n, Bool)] -> Ann ExportSpecList (STWithNames n) +createExports elems = mkExportSpecList $ map (mkExportSpec . createExport) elems + where createExport (n, False) = mkIeSpec (mkUnqualName' (GHC.getName n)) Nothing + createExport (n, True) = mkIeSpec (mkUnqualName' (GHC.getName n)) (Just mkSubAll) +
+ Language/Haskell/Tools/Refactor/GenerateTypeSignature.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE ViewPatterns + , FlexibleContexts + , ScopedTypeVariables + , RankNTypes + #-} +module Language.Haskell.Tools.Refactor.GenerateTypeSignature (generateTypeSignature, generateTypeSignature') where + +import GHC hiding (Module) +import Type as GHC +import TyCon as GHC +import OccName as GHC +import Outputable as GHC +import TysWiredIn as GHC +import Id as GHC + +import Data.List +import Data.Maybe +import Data.Data +import Data.Generics.Uniplate.Data +import Control.Monad +import Control.Monad.State +import Control.Reference hiding (element) +import Language.Haskell.Tools.AnnTrf.SourceTemplate +import Language.Haskell.Tools.AnnTrf.SourceTemplateHelpers +import Language.Haskell.Tools.AST.Gen +import Language.Haskell.Tools.AST as AST +import Language.Haskell.Tools.Refactor.RefactorBase + +type RefactorId = Refactor GHC.Id +type STWithId = STWithNames GHC.Id + +generateTypeSignature' :: RealSrcSpan -> Ann Module STWithId -> RefactoredModule GHC.Id +generateTypeSignature' sp = generateTypeSignature (nodesContaining sp) (nodesContaining sp) (getValBindInList sp) + +-- | Perform the refactoring on either local or top-level definition +generateTypeSignature :: Simple Traversal (Ann Module STWithId) (AnnList Decl STWithId) + -- ^ Access for a top-level definition if it is the selected definition + -> Simple Traversal (Ann Module STWithId) (AnnList LocalBind STWithId) + -- ^ Access for a definition list if it contains the selected definition + -> (forall d . (Show (d (NodeInfo STWithId SourceTemplate)), Data (d STWithId), Typeable d, BindingElem d) + => AnnList d STWithId -> Maybe (Ann ValueBind STWithId)) + -- ^ Selector for either local or top-level declaration in the definition list + -> Ann Module STWithId -> RefactoredModule GHC.Id +generateTypeSignature topLevelRef localRef vbAccess + = flip evalStateT False . + (topLevelRef !~ genTypeSig vbAccess + <=< localRef !~ genTypeSig vbAccess) + +genTypeSig :: (Show (d (NodeInfo (SemanticInfo Id) SourceTemplate)), BindingElem d) => (AnnList d STWithId -> Maybe (Ann ValueBind STWithId)) + -> AnnList d STWithId -> StateT Bool RefactorId (AnnList d STWithId) +genTypeSig vbAccess ls + | Just vb <- vbAccess ls + , not (typeSignatureAlreadyExist ls vb) + = do let id = getBindingName vb + isTheBind (Just ((^.element) -> decl)) + = isBinding decl && (decl ^? bindName) == (vb ^? bindingName :: [GHC.Id]) + isTheBind _ = False + + alreadyGenerated <- get + if alreadyGenerated + then return ls + else do put True + typeSig <- lift $ generateTSFor (getName id) (idType id) + return $ insertWhere (wrapperAnn $ createTypeSig typeSig) (const True) isTheBind ls + | otherwise = return ls + + +generateTSFor :: GHC.Name -> GHC.Type -> RefactorId (Ann TypeSignature STWithId) +generateTSFor n t = mkTypeSignature (mkUnqualName' n) <$> generateTypeFor (-1) (dropForAlls t) + +-- | Generates the source-level type for a GHC internal type +generateTypeFor :: Int -> GHC.Type -> RefactorId (Ann AST.Type STWithId) +generateTypeFor prec t + -- context + | (break (not . isPredTy) -> (preds, other), rt) <- splitFunTys t + , not (null preds) + = do ctx <- case preds of [pred] -> mkContextOne <$> generateAssertionFor pred + _ -> mkContextMulti <$> mapM generateAssertionFor preds + wrapParen 0 <$> (mkTyCtx ctx <$> generateTypeFor 0 (mkFunTys other rt)) + -- function + | Just (at, rt) <- splitFunTy_maybe t + = wrapParen 0 <$> (mkTyFun <$> generateTypeFor 10 at <*> generateTypeFor 0 rt) + -- type operator (we don't know the precedences, so always use parentheses) + | (op, [at,rt]) <- splitAppTys t + , Just tc <- tyConAppTyCon_maybe op + , isSymOcc (getOccName (getName tc)) + = wrapParen 0 <$> (mkTyInfix <$> generateTypeFor 10 at <*> referenceOperator (getTCId tc) <*> generateTypeFor 10 rt) + -- tuple types + | Just (tc, tas) <- splitTyConApp_maybe t + , isTupleTyCon tc + = mkTyTuple <$> mapM (generateTypeFor (-1)) tas + -- string type + | Just (ls, [et]) <- splitTyConApp_maybe t + , Just ch <- tyConAppTyCon_maybe et + , listTyCon == ls + , charTyCon == ch + = return $ mkTyVar (mkNormalName $ mkSimpleName "String") + -- list types + | Just (tc, [et]) <- splitTyConApp_maybe t + , listTyCon == tc + = mkTyList <$> generateTypeFor (-1) et + -- type application + | Just (tf, ta) <- splitAppTy_maybe t + = wrapParen 10 <$> (mkTyApp <$> generateTypeFor 10 tf <*> generateTypeFor 11 ta) + -- type constructor + | Just tc <- tyConAppTyCon_maybe t + = mkTyVar <$> referenceName (getTCId tc) + -- type variable + | Just tv <- getTyVar_maybe t + = mkTyVar <$> referenceName tv + -- forall type + | (tvs@(_:_), t') <- splitForAllTys t + = wrapParen (-1) <$> (mkTyForall (mkTypeVarList (map getName tvs)) <$> generateTypeFor 0 t') + | otherwise = error ("Cannot represent type: " ++ showSDocUnsafe (ppr t)) + where wrapParen :: Int -> Ann AST.Type STWithId -> Ann AST.Type STWithId + wrapParen prec' node = if prec' < prec then mkTyParen node else node + + getTCId :: GHC.TyCon -> GHC.Id + getTCId tc = GHC.mkVanillaGlobal (GHC.tyConName tc) (tyConKind tc) + + generateAssertionFor :: GHC.Type -> RefactorId (Ann AST.Assertion STWithId) + generateAssertionFor t + | Just (tc, types) <- splitTyConApp_maybe t + = mkClassAssert <$> referenceName (getTCId tc) <*> mapM (generateTypeFor 0) types + -- TODO: infix things + +-- | Check whether the definition already has a type signature +typeSignatureAlreadyExist :: forall d . BindingElem d => AnnList d STWithId -> Ann ValueBind STWithId -> Bool +typeSignatureAlreadyExist ls vb = + getBindingName vb `elem` concatMap (^? bindName) (filter isTypeSig $ ls ^? annList&element) + +getBindingName :: Ann ValueBind STWithId -> GHC.Id +getBindingName vb = case nub $ 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/OrganizeImports.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE LambdaCase + , ScopedTypeVariables + #-} +module Language.Haskell.Tools.Refactor.OrganizeImports (organizeImports) where + +import SrcLoc +import Name hiding (Name) +import GHC (Ghc, GhcMonad, lookupGlobalName, TyThing(..), moduleNameString, moduleName) +import qualified GHC +import TyCon +import ConLike +import DataCon +import Outputable (ppr, showSDocUnsafe) + +import Control.Reference hiding (element) +import Control.Monad +import Control.Monad.IO.Class +import Data.Function hiding ((&)) +import Data.String +import Data.Maybe +import Data.Data +import Data.List +import Data.Generics.Uniplate.Data +import Language.Haskell.Tools.AST +import Language.Haskell.Tools.AST.FromGHC +import Language.Haskell.Tools.AnnTrf.SourceTemplate +import Language.Haskell.Tools.AnnTrf.SourceTemplateHelpers +import Language.Haskell.Tools.PrettyPrint +import Language.Haskell.Tools.Refactor.DebugGhcAST +import Language.Haskell.Tools.AST.Gen +import Language.Haskell.Tools.Refactor.RefactorBase +import Debug.Trace + +organizeImports :: forall n . (NamedThing n, Data n) => Ann Module (STWithNames n) -> RefactoredModule n +organizeImports mod + = element&modImports&annListElems !~ narrowImports usedNames . sortImports $ mod + where usedNames = map getName $ catMaybes + $ map (^? (annotation&semanticInfo&nameInfo)) + $ (universeBi (mod ^. element&modHead) ++ universeBi (mod ^. element&modDecl) :: [Ann SimpleName (STWithNames n)]) + +-- | Sorts the imports in alphabetical order +sortImports :: [Ann ImportDecl (STWithNames n)] -> [Ann ImportDecl (STWithNames n)] +sortImports = sortBy (ordByOccurrence `on` (^. element&importModule&element)) + +-- | Modify an import to only import names that are used. +narrowImports :: forall n . NamedThing n => [GHC.Name] -> [Ann ImportDecl (STWithNames n)] -> Refactor n [Ann ImportDecl (STWithNames n)] +narrowImports usedNames imps = foldM (narrowOneImport usedNames) imps imps + where narrowOneImport :: [GHC.Name] -> [Ann ImportDecl (STWithNames n)] -> Ann ImportDecl (STWithNames n) -> Refactor n [Ann ImportDecl (STWithNames n)] + 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 + +narrowImport :: NamedThing n => [GHC.Name] -> [SemanticInfo n] -> Ann ImportDecl (STWithNames n) + -> Refactor n (Maybe (Ann ImportDecl (STWithNames n))) +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 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 + +-- | Narrows the import specification (explicitely imported elements) +narrowImportSpecs :: forall n . NamedThing n => [GHC.Name] -> AnnList IESpec (STWithNames n) -> Refactor n (AnnList IESpec (STWithNames n)) +narrowImportSpecs usedNames + = (annList&element !~ narrowSpecSubspec usedNames) + >=> return . filterList isNeededSpec + where narrowSpecSubspec :: [GHC.Name] -> IESpec (STWithNames n) -> Refactor n (IESpec (STWithNames n)) + narrowSpecSubspec usedNames spec + = do let Just specName = spec ^? ieName&element&simpleName&annotation&semanticInfo&nameInfo + Just tt <- GHC.lookupName (getName specName) + let subspecsInScope = case tt of ATyCon tc | not (isClassTyCon tc) + -> map getName (tyConDataCons tc) `intersect` usedNames + _ -> usedNames + ieSubspec&annJust !- narrowImportSubspecs subspecsInScope $ spec + + isNeededSpec :: Ann IESpec (STWithNames n) -> Bool + isNeededSpec ie = + -- if the name is used, it is needed + fmap getName (ie ^? element&ieName&element&simpleName&annotation&semanticInfo&nameInfo) `elem` map Just usedNames + -- if the name is not used, but some of its constructors are used, it is needed + || ((ie ^? element&ieSubspec&annJust&element&essList&annList) /= []) + || (case ie ^? element&ieSubspec&annJust&element of Just SubSpecAll -> True; _ -> False) + +narrowImportSubspecs :: NamedThing n => [GHC.Name] -> Ann SubSpec (STWithNames n) -> Ann SubSpec (STWithNames n) +narrowImportSubspecs [] (Ann _ SubSpecAll) = mkSubList [] +narrowImportSubspecs _ ss@(Ann _ SubSpecAll) = ss +narrowImportSubspecs usedNames ss@(Ann _ (SubSpecList _)) + = element&essList .- filterList (\n -> fmap getName (n ^? element&simpleName&annotation&semanticInfo&nameInfo) `elem` map Just usedNames) $ ss
+ Language/Haskell/Tools/Refactor/RangeDebug.hs view
@@ -0,0 +1,80 @@+{-# 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 + +rangeDebug :: (a ~ NodeInfo sema SpanInfo, TreeDebug e a) => e a -> String +rangeDebug = treeDebug' (shortShowSpanInfo . (^. sourceInfo)) 0 + +shortShowSpanInfo :: SpanInfo -> String +shortShowSpanInfo (NodeSpan sp) = shortShowSpan sp +shortShowSpanInfo (OptionalPos bef aft loc) = "?" ++ show bef ++ " " ++ show aft ++ " " ++ shortShowLoc loc +shortShowSpanInfo (ListPos bef aft sep _ loc) = "*" ++ show bef ++ " " ++ show sep ++ " " ++ show aft ++ " " ++ shortShowLoc loc + +shortShowSpan :: SrcSpan -> String +shortShowSpan (UnhelpfulSpan _) = "??-??" +shortShowSpan sp@(RealSrcSpan _) + = shortShowLoc (srcSpanStart sp) ++ "-" ++ shortShowLoc (srcSpanEnd sp) + +shortShowLoc :: SrcLoc -> String +shortShowLoc (UnhelpfulLoc _) = "??" +shortShowLoc (RealSrcLoc loc) = show (srcLocLine loc) ++ ":" ++ show (srcLocCol loc) + +templateDebug :: TreeDebug e (NodeInfo sema RangeTemplate) => e (NodeInfo sema RangeTemplate) -> String +templateDebug = treeDebug' (shortShowRangeTemplate . (^. sourceInfo)) 0 + +shortShowRangeTemplate (RangeTemplate _ rngs) = "ˇ" ++ concatMap showRangeTemplateElem rngs ++ "ˇ" + where showRangeTemplateElem (RangeElem sp) = "[" ++ shortShowSpan (RealSrcSpan sp) ++ "]" + showRangeTemplateElem (RangeChildElem) = "." + showRangeTemplateElem r = show r + +sourceTemplateDebug :: TreeDebug e (NodeInfo sema SourceTemplate) => e (NodeInfo sema SourceTemplate) -> String +sourceTemplateDebug = treeDebug' (shortShowSourceTemplate . (^. sourceInfo)) 0 + +shortShowSourceTemplate temp = "ˇ" ++ (concatMap show $ temp ^. sourceTemplateElems) ++ "ˇ" + +class TreeDebug e a where + treeDebug' :: (a -> String) -> Int -> e a -> String + default treeDebug' :: (GTreeDebug (Rep (e a)) a, Generic (e a)) => (a -> String) -> Int -> e a -> String + treeDebug' f i = gTreeDebug f i . from + +class GTreeDebug f a where + gTreeDebug :: (a -> String) -> Int -> f p -> String + +instance GTreeDebug V1 a where + gTreeDebug _ _ _ = error "GTreeDebug V1" + +instance GTreeDebug U1 a where + gTreeDebug _ _ U1 = "" + +instance (GTreeDebug f a, GTreeDebug g a) => GTreeDebug (f :+: g) a where + gTreeDebug f i (L1 x) = gTreeDebug f i x + gTreeDebug f i (R1 x) = gTreeDebug f i x + +instance (GTreeDebug f a, GTreeDebug g a) => GTreeDebug (f :*: g) a where + gTreeDebug f i (x :*: y) + = gTreeDebug f i x ++ gTreeDebug f i y + +instance {-# OVERLAPPING #-} TreeDebug e a => GTreeDebug (K1 i (e a)) a where + gTreeDebug f i (K1 x) = treeDebug' f i x + +instance {-# OVERLAPPABLE #-} GTreeDebug (K1 i c) a where + gTreeDebug f i (K1 x) = "" + +instance GTreeDebug f a => GTreeDebug (M1 i t f) a where + gTreeDebug f i (M1 x) = gTreeDebug f i x
+ Language/Haskell/Tools/Refactor/RangeDebug/Instances.hs view
@@ -0,0 +1,137 @@+{-# 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 Language.Haskell.Tools.AST + +-- Annotations +instance (TreeDebug e a, Show (e a)) => TreeDebug (Ann e) a where + treeDebug' f i (Ann a e) = identLine i ++ f a ++ " " ++ take 40 (show e) ++ "..." ++ treeDebug' f (i+1) e + +identLine :: Int -> String +identLine i = "\n" ++ replicate (i*2) ' ' + +instance (TreeDebug e a, Show (e a)) => TreeDebug (AnnList e) a where + treeDebug' f i (AnnList a ls) = identLine i ++ f a ++ " <*>" ++ concatMap (treeDebug' f (i + 1)) ls + +instance (TreeDebug e a, Show (e a)) => TreeDebug (AnnMaybe e) a where + treeDebug' f i (AnnMaybe a e) = identLine i ++ f a ++ " <?>" ++ maybe "" (\e -> treeDebug' f (i + 1) e) e + +-- Modules +instance (Generic a, Show a) => TreeDebug Module a +instance (Generic a, Show a) => TreeDebug ModuleHead a +instance (Generic a, Show a) => TreeDebug ExportSpecList a +instance (Generic a, Show a) => TreeDebug ExportSpec a +instance (Generic a, Show a) => TreeDebug IESpec a +instance (Generic a, Show a) => TreeDebug SubSpec a +instance (Generic a, Show a) => TreeDebug ModulePragma a +instance (Generic a, Show a) => TreeDebug FilePragma a +instance (Generic a, Show a) => TreeDebug ImportDecl a +instance (Generic a, Show a) => TreeDebug ImportSpec a +instance (Generic a, Show a) => TreeDebug ImportQualified a +instance (Generic a, Show a) => TreeDebug ImportSource a +instance (Generic a, Show a) => TreeDebug ImportSafe a +instance (Generic a, Show a) => TreeDebug TypeNamespace a +instance (Generic a, Show a) => TreeDebug ImportRenaming a + +-- Declarations +instance (Generic a, Show a) => TreeDebug Decl a +instance (Generic a, Show a) => TreeDebug ClassBody a +instance (Generic a, Show a) => TreeDebug ClassElement a +instance (Generic a, Show a) => TreeDebug DeclHead a +instance (Generic a, Show a) => TreeDebug InstBody a +instance (Generic a, Show a) => TreeDebug InstBodyDecl a +instance (Generic a, Show a) => TreeDebug GadtConDecl a +instance (Generic a, Show a) => TreeDebug GadtConType a +instance (Generic a, Show a) => TreeDebug GadtField a +instance (Generic a, Show a) => TreeDebug FunDeps a +instance (Generic a, Show a) => TreeDebug FunDep a +instance (Generic a, Show a) => TreeDebug ConDecl a +instance (Generic a, Show a) => TreeDebug FieldDecl a +instance (Generic a, Show a) => TreeDebug Deriving a +instance (Generic a, Show a) => TreeDebug InstanceRule a +instance (Generic a, Show a) => TreeDebug InstanceHead a +instance (Generic a, Show a) => TreeDebug TypeEqn a +instance (Generic a, Show a) => TreeDebug KindConstraint a +instance (Generic a, Show a) => TreeDebug TyVar a +instance (Generic a, Show a) => TreeDebug Type a +instance (Generic a, Show a) => TreeDebug Kind a +instance (Generic a, Show a) => TreeDebug Context a +instance (Generic a, Show a) => TreeDebug Assertion a +instance (Generic a, Show a) => TreeDebug Expr a +instance (Generic a, Show a, TreeDebug expr a, Show (expr a), Generic (expr a)) => TreeDebug (Stmt' expr) a +instance (Generic a, Show a) => TreeDebug CompStmt a +instance (Generic a, Show a) => TreeDebug ValueBind a +instance (Generic a, Show a) => TreeDebug Pattern a +instance (Generic a, Show a) => TreeDebug PatternField a +instance (Generic a, Show a) => TreeDebug Splice a +instance (Generic a, Show a) => TreeDebug QQString a +instance (Generic a, Show a) => TreeDebug Match a +instance (Generic a, Show a, TreeDebug expr a, Show (expr a), Generic (expr a)) => TreeDebug (Alt' expr) a +instance (Generic a, Show a) => TreeDebug Rhs a +instance (Generic a, Show a) => TreeDebug GuardedRhs a +instance (Generic a, Show a) => TreeDebug FieldUpdate a +instance (Generic a, Show a) => TreeDebug Bracket a +instance (Generic a, Show a) => TreeDebug TopLevelPragma a +instance (Generic a, Show a) => TreeDebug Rule a +instance (Generic a, Show a) => TreeDebug AnnotationSubject a +instance (Generic a, Show a) => TreeDebug MinimalFormula a +instance (Generic a, Show a) => TreeDebug ExprPragma a +instance (Generic a, Show a) => TreeDebug SourceRange a +instance (Generic a, Show a) => TreeDebug Number a +instance (Generic a, Show a) => TreeDebug QuasiQuote a +instance (Generic a, Show a) => TreeDebug RhsGuard a +instance (Generic a, Show a) => TreeDebug LocalBind a +instance (Generic a, Show a) => TreeDebug LocalBinds a +instance (Generic a, Show a) => TreeDebug FixitySignature a +instance (Generic a, Show a) => TreeDebug TypeSignature a +instance (Generic a, Show a) => TreeDebug ListCompBody a +instance (Generic a, Show a) => TreeDebug TupSecElem a +instance (Generic a, Show a) => TreeDebug TypeFamily a +instance (Generic a, Show a) => TreeDebug TypeFamilySpec a +instance (Generic a, Show a) => TreeDebug InjectivityAnn a +instance (Generic a, Show a, TreeDebug expr a, Show (expr a), Generic (expr a)) => TreeDebug (CaseRhs' expr) a +instance (Generic a, Show a, TreeDebug expr a, Show (expr a), Generic (expr a)) => TreeDebug (GuardedCaseRhs' expr) a +instance (Generic a, Show a) => TreeDebug PatternSynonym a +instance (Generic a, Show a) => TreeDebug PatSynRhs a +instance (Generic a, Show a) => TreeDebug PatSynLhs a +instance (Generic a, Show a) => TreeDebug PatSynWhere a +instance (Generic a, Show a) => TreeDebug PatternTypeSignature a +instance (Generic a, Show a) => TreeDebug Role a +instance (Generic a, Show a) => TreeDebug Cmd a +instance (Generic a, Show a) => TreeDebug LanguageExtension a +instance (Generic a, Show a) => TreeDebug MatchLhs a + +-- Literal +instance (Generic a, Show a) => TreeDebug Literal a +instance (Generic a, Show a, TreeDebug k a, Show (k a), Generic (k a)) => TreeDebug (Promoted k) a + +-- Base +instance (Generic a, Show a) => TreeDebug Operator a +instance (Generic a, Show a) => TreeDebug Name a +instance (Generic a, Show a) => TreeDebug SimpleName a +instance (Generic a, Show a) => TreeDebug UnqualName a +instance (Generic a, Show a) => TreeDebug StringNode a +instance (Generic a, Show a) => TreeDebug DataOrNewtypeKeyword a +instance (Generic a, Show a) => TreeDebug DoKind a +instance (Generic a, Show a) => TreeDebug TypeKeyword a +instance (Generic a, Show a) => TreeDebug OverlapPragma a +instance (Generic a, Show a) => TreeDebug CallConv a +instance (Generic a, Show a) => TreeDebug ArrowAppl a +instance (Generic a, Show a) => TreeDebug Safety a +instance (Generic a, Show a) => TreeDebug ConlikeAnnot a +instance (Generic a, Show a) => TreeDebug Assoc a +instance (Generic a, Show a) => TreeDebug Precedence a +instance (Generic a, Show a) => TreeDebug LineNumber a +instance (Generic a, Show a) => TreeDebug PhaseControl a +instance (Generic a, Show a) => TreeDebug PhaseNumber a +instance (Generic a, Show a) => TreeDebug PhaseInvert a
+ Language/Haskell/Tools/Refactor/RefactorBase.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE GeneralizedNewtypeDeriving + , TypeFamilies + , ViewPatterns + , StandaloneDeriving + , LambdaCase + #-} +module Language.Haskell.Tools.Refactor.RefactorBase where + +import Language.Haskell.Tools.AST +import Language.Haskell.Tools.AST.Gen +import Language.Haskell.Tools.AnnTrf.SourceTemplateHelpers +import Language.Haskell.Tools.AnnTrf.SourceTemplate +import GHC (Ghc, GhcMonad(..), TyThing(..), lookupName) +import Exception (ExceptionMonad(..)) +import DynFlags (HasDynFlags(..)) +import qualified Name as GHC +import qualified Module as GHC +import qualified PrelNames as GHC +import qualified TyCon as GHC +import qualified TysWiredIn as GHC +import Control.Reference hiding (element) +import Data.Function (on) +import Data.List +import Data.Maybe +import Data.Char +import Control.Monad.Reader +import Control.Monad.Trans.Except +import Control.Monad.Writer + +-- | The information a refactoring can use +data RefactorCtx a = RefactorCtx { refModuleName :: GHC.Module + , refCtxImports :: [Ann ImportDecl a] + } + +-- | Performs the given refactoring, transforming it into a Ghc action +runRefactor :: (a ~ STWithNames n, TemplateAnnot a) => Ann Module a -> (Ann Module a -> Refactor n (Ann Module a)) -> Ghc (Either String (Ann Module a)) +runRefactor mod trf = let init = RefactorCtx (fromJust $ mod ^? semantics&defModuleName) (mod ^? element&modImports&annList) + in runExceptT $ runReaderT (addGeneratedImports (runWriterT (fromRefactorT $ trf mod))) init + +-- | Adds the imports that bring names into scope that are needed by the refactoring +addGeneratedImports :: (TemplateAnnot a, Monad m) => ReaderT (RefactorCtx a) m (Ann Module a, [GHC.Name]) -> ReaderT (RefactorCtx a) m (Ann Module a) +addGeneratedImports = + fmap (\(m,names) -> element&modImports&annListElems .- (++ addImports names) $ m) + where addImports :: TemplateAnnot a => [GHC.Name] -> [Ann ImportDecl a] + addImports names = map createImport $ groupBy ((==) `on` GHC.nameModule) $ nub $ sort names + + -- TODO: group names like constructors into correct IESpecs + createImport :: TemplateAnnot a => [GHC.Name] -> Ann ImportDecl a + createImport names = mkImportDecl False False False Nothing (mkSimpleName $ GHC.moduleNameString $ GHC.moduleName $ GHC.nameModule $ head names) + Nothing (Just $ mkImportSpecList (map (\n -> mkIeSpec (mkUnqualName' n) Nothing) names)) + +instance (GhcMonad m, Monoid s) => GhcMonad (WriterT s m) where + getSession = lift getSession + setSession env = lift (setSession env) + +instance (ExceptionMonad m, Monoid s) => ExceptionMonad (WriterT s m) where + gcatch w c = WriterT (runWriterT w `gcatch` (runWriterT . c)) + gmask m = WriterT $ gmask (\f -> runWriterT $ m (WriterT . f . runWriterT)) + +instance GhcMonad m => GhcMonad (ReaderT s m) where + getSession = lift getSession + setSession env = lift (setSession env) + +instance ExceptionMonad m => ExceptionMonad (ReaderT s m) where + gcatch r c = ReaderT (\ctx -> runReaderT r ctx `gcatch` (flip runReaderT ctx . c)) + gmask m = ReaderT $ \ctx -> gmask (\f -> runReaderT (m (\a -> ReaderT $ \ctx' -> f (runReaderT a ctx'))) ctx) + +instance GhcMonad m => GhcMonad (ExceptT s m) where + getSession = lift getSession + setSession env = lift (setSession env) + +instance ExceptionMonad m => ExceptionMonad (ExceptT s m) where + gcatch e c = ExceptT (runExceptT e `gcatch` (runExceptT . c)) + gmask m = ExceptT $ gmask (\f -> runExceptT $ m (ExceptT . f . runExceptT)) + + +-- | Input and output information for the refactoring +newtype RefactorT ann m ast = RefactorT { fromRefactorT :: WriterT [GHC.Name] (ReaderT (RefactorCtx ann) m) ast } + deriving (Functor, Applicative, Monad, MonadReader (RefactorCtx ann), MonadWriter [GHC.Name], MonadIO, HasDynFlags, ExceptionMonad, GhcMonad) + +instance MonadTrans (RefactorT ann) where + lift = RefactorT . lift . lift + +refactError :: String -> Refactor n a +refactError = lift . throwE + +-- | The refactoring monad +type Refactor n = RefactorT (STWithNames n) (ExceptT String Ghc) + +type STWithNames n = NodeInfo (SemanticInfo n) SourceTemplate + +type RefactoredModule n = Refactor n (Ann Module (STWithNames n)) + +registeredNamesFromPrelude :: [GHC.Name] +registeredNamesFromPrelude = GHC.basicKnownKeyNames ++ map GHC.tyConName GHC.wiredInTyCons + +otherNamesFromPrelude :: [String] +otherNamesFromPrelude + -- TODO: extend and revise this list + = ["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"] + +qualifiedName :: GHC.Name -> String +qualifiedName name = case GHC.nameModule_maybe name of + Just mod -> GHC.moduleNameString (GHC.moduleName mod) ++ "." ++ GHC.occNameString (GHC.nameOccName name) + Nothing -> GHC.occNameString (GHC.nameOccName name) + +referenceName :: (Eq n, GHC.NamedThing n) => n -> Refactor n (Ann Name (STWithNames n)) +referenceName = referenceName' mkQualName' + +referenceOperator :: (Eq n, GHC.NamedThing n) => n -> Refactor n (Ann Operator (STWithNames n)) +referenceOperator = referenceName' mkQualOp' + +-- | Create a name that references the definition. Generates an import if the definition is not yet imported. +referenceName' :: (Eq n, GHC.NamedThing n) => ([String] -> GHC.Name -> Ann nt (STWithNames n)) -> n -> Refactor n (Ann nt (STWithNames n)) +referenceName' makeName n@(GHC.getName -> name) + | name `elem` registeredNamesFromPrelude || qualifiedName name `elem` otherNamesFromPrelude + = return $ makeName [] name -- imported from prelude + | otherwise + = do RefactorCtx {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 + +-- | Reference the name by the shortest suitable import +referenceBy :: (TemplateAnnot a) => ([String] -> GHC.Name -> Ann nt a) -> GHC.Name -> [Ann ImportDecl a] -> Ann nt a +referenceBy makeName name imps = + let prefixes = map importQualifier imps + in makeName (minimumBy (compare `on` (length . concat)) prefixes) name + where importQualifier :: Ann ImportDecl a -> [String] + importQualifier imp + = if isJust (imp ^? element&importQualified&annJust) + then case imp ^? element&importAs&annJust&element&importRename&element of + Nothing -> nameElements (imp ^. element&importModule&element) -- fully qualified import + Just asName -> nameElements asName -- the name given by as clause + else [] -- unqualified import + +-- | Different classes of definitions that have different kind of names. +data NameClass = Variable -- ^ Normal value definitions: functions, variables + | Ctor -- ^ Data constructors + | ValueOperator -- ^ Functions with operator-like names + | DataCtorOperator -- ^ Constructors with operator-like names + | SynonymOperator -- ^ Type definitions with operator-like names + +-- | Get which category does a given name belong to +classifyName :: GHC.Name -> Refactor n NameClass +classifyName n = lookupName n >>= return . \case + Just (AnId id) | isop -> ValueOperator + Just (AnId id) -> Variable + Just (AConLike id) | isop -> DataCtorOperator + Just (AConLike id) -> Ctor + Just (ATyCon id) | isop -> SynonymOperator + Just (ATyCon id) -> Ctor + Nothing | isop -> ValueOperator + Nothing -> Variable + where isop = GHC.isSymOcc (GHC.getOccName n) + + +-- | Check if a given name is valid for a given kind of definition +nameValid :: NameClass -> String -> Bool +nameValid n "" = False +nameValid n str | str `elem` reservedNames = False + where -- TODO: names reserved by extensions + reservedNames = [ "case", "class", "data", "default", "deriving", "do", "else", "if", "import", "in", "infix" + , "infixl", "infixr", "instance", "let", "module", "newtype", "of", "then", "type", "where", "_" + , "..", ":", "::", "=", "\\", "|", "<-", "->", "@", "~", "=>", "[]" + ] +-- Operators that are data constructors (must start with ':') +nameValid DataCtorOperator (':' : nameRest) + = all isOperatorChar nameRest +-- Type families and synonyms that are operators (can start with ':') +nameValid SynonymOperator (c : nameRest) + = isOperatorChar c && all isOperatorChar nameRest +-- Normal value operators (cannot start with ':') +nameValid ValueOperator (c : nameRest) + = isOperatorChar c && c /= ':' && all isOperatorChar nameRest +-- Data and type constructors (start with uppercase) +nameValid Ctor (c : nameRest) + = isUpper c && isIdStartChar c && all (\c -> isIdStartChar c || isDigit c) nameRest +-- Variables and type variables (start with lowercase) +nameValid Variable (c : nameRest) + = isLower c && isIdStartChar c && all (\c -> isIdStartChar c || isDigit c) nameRest +nameValid _ _ = False + +isIdStartChar c = (isLetter c && isAscii c) || c == '\'' || c == '_' +isOperatorChar c = (isPunctuation c || isSymbol c) && isAscii c
+ Language/Haskell/Tools/Refactor/RenameDefinition.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE ScopedTypeVariables + , LambdaCase + , MultiWayIf + #-} +module Language.Haskell.Tools.Refactor.RenameDefinition (renameDefinition, renameDefinition') where + +import Name hiding (Name) +import GHC (Ghc, TyThing(..), lookupName) +import qualified GHC +import OccName +import SrcLoc + +import Control.Reference hiding (element) +import Control.Monad.State +import Control.Monad.Trans.Except +import Data.Data +import Data.Maybe +import Data.Generics.Uniplate.Data +import Language.Haskell.Tools.AST +import Language.Haskell.Tools.AnnTrf.SourceTemplate +import Language.Haskell.Tools.AST.Gen +import Language.Haskell.Tools.Refactor.RefactorBase + +import Debug.Trace + +renameDefinition' :: forall n . (NamedThing n, Data n) => RealSrcSpan -> String -> Ann Module (STWithNames n) -> RefactoredModule n +renameDefinition' sp str mod + = case (getNodeContaining sp mod :: Maybe (Ann SimpleName (STWithNames n))) >>= (fmap getName . (^? semantics&nameInfo)) of + Just n -> renameDefinition n str mod + Nothing -> refactError "No name is selected" + +renameDefinition :: forall n . (NamedThing n, Data n) => GHC.Name -> String -> Ann Module (STWithNames n) -> RefactoredModule n +renameDefinition toChange newName mod + = do nameCls <- classifyName toChange + (res,defFound) <- runStateT (biplateRef !~ changeName toChange newName $ mod) 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 + where + changeName :: GHC.Name -> String -> Ann SimpleName (STWithNames n) -> StateT Bool (Refactor n) (Ann SimpleName (STWithNames n)) + changeName toChange str elem + = if | fmap getName (elem ^? semantics&nameInfo) == Just toChange + && (elem ^? semantics&isDefined) == Just False + && any ((str ==) . occNameString . getOccName) (maybe [] head (elem ^? semantics & scopedLocals)) + -> lift $ refactError "The definition clashes with an existing one" -- name clash with an external definition + | fmap getName (elem ^? semantics&nameInfo) == Just toChange + -> do modify (|| fromMaybe False (elem ^? semantics&isDefined)) + return $ element & unqualifiedName .= mkNamePart str $ elem + | let namesInScope = fromMaybe [] (elem ^? semantics & scopedLocals) + actualName = maybe toChange getName (elem ^? semantics & nameInfo) + in str == occNameString (getOccName actualName) && sameNamespace toChange actualName + && conflicts toChange actualName namesInScope + -> lift $ refactError "The definition clashes with an existing one" -- local name clash + | otherwise -> return elem + +conflicts :: GHC.Name -> GHC.Name -> [[GHC.Name]] -> Bool +conflicts overwrites overwritten (scopeBlock : scope) + | overwritten `elem` scopeBlock && overwrites `notElem` scopeBlock = False + | overwrites `elem` scopeBlock = True + | otherwise = conflicts overwrites overwritten scope +conflicts _ _ [] = False + +sameNamespace :: GHC.Name -> GHC.Name -> Bool +sameNamespace n1 n2 = occNameSpace (getOccName n1) == occNameSpace (getOccName n2)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ haskell-tools-refactor.cabal view
@@ -0,0 +1,48 @@+name: haskell-tools-refactor +version: 0.1.2.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 +license: BSD3 +license-file: LICENSE +author: Boldizsar Nemeth +maintainer: nboldi@elte.hu +category: Language +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Language.Haskell.Tools.Refactor + , Language.Haskell.Tools.Refactor.GenerateTypeSignature + , Language.Haskell.Tools.Refactor.OrganizeImports + , Language.Haskell.Tools.Refactor.GenerateExports + , Language.Haskell.Tools.Refactor.RenameDefinition + , Language.Haskell.Tools.Refactor.ExtractBinding + , Language.Haskell.Tools.Refactor.RefactorBase + 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 + build-depends: base >=4.9 && <5.0 + , ghc >=8.0 && <8.1 + , mtl >=2.2 && <2.3 + , uniplate >=1.6 && <1.7 + , ghc-paths >=0.1 && <0.2 + , containers >=0.5 && <0.6 + , directory >=1.2 && <1.3 + , transformers >=0.5 && <0.6 + , references >=0.3.2 && <1.0 + , split >=0.2 && <1.0 + , time >=1.5 && <2.0 + , filepath >=1.4 && <2.0 + , either >=4.0 && <5.0 + , haskell-tools-ast >=0.1.2 && <0.2 + , haskell-tools-ast-fromghc >=0.1.2 && <0.2 + , haskell-tools-ast-gen >=0.1.2 && <0.2 + , haskell-tools-ast-trf >=0.1.2 && <0.2 + , haskell-tools-prettyprint >=0.1.2 && <0.2 + , structural-traversal >=0.1 && <0.2 + , template-haskell >=2.0 && <3.0 + default-language: Haskell2010 +