diff --git a/Language/Haskell/Tools/Refactor/GetModules.hs b/Language/Haskell/Tools/Refactor/GetModules.hs --- a/Language/Haskell/Tools/Refactor/GetModules.hs +++ b/Language/Haskell/Tools/Refactor/GetModules.hs @@ -3,13 +3,16 @@ , LambdaCase , TemplateHaskell , FlexibleContexts + , TypeApplications + , RankNTypes #-} -- | Representation and operations for module collections (libraries, executables, ...) in the framework. module Language.Haskell.Tools.Refactor.GetModules where +import Control.Monad import Control.Reference import Data.Function (on) -import Data.List (intersperse, find, sortBy) +import Data.List import qualified Data.Map as Map import Data.Maybe import Distribution.Compiler @@ -21,11 +24,11 @@ import Distribution.PackageDescription.Parse import Distribution.System import Distribution.Verbosity (silent) -import Language.Haskell.Extension +import Language.Haskell.Extension as Cabal import System.Directory import System.FilePath.Posix -import DynFlags (DynFlags, xopt_set, xopt_unset) +import DynFlags import qualified DynFlags as GHC import GHC hiding (ModuleName) import qualified Language.Haskell.TH.LanguageExtensions as GHC @@ -35,6 +38,8 @@ import Language.Haskell.Tools.AST (Dom, IdDom) import Language.Haskell.Tools.Refactor.RefactorBase +import Debug.Trace + -- | The modules of a library, executable, test or benchmark. A package contains one or more module collection. data ModuleCollection = ModuleCollection { _mcId :: ModuleCollectionId @@ -42,6 +47,7 @@ , _mcSourceDirs :: [FilePath] , _mcModules :: Map.Map SourceFileKey ModuleRecord , _mcFlagSetup :: DynFlags -> IO DynFlags -- ^ Sets up the ghc environment for compiling the modules of this collection + , _mcLoadFlagSetup :: DynFlags -> IO DynFlags -- ^ Sets up the ghc environment for dependency analysis , _mcDependencies :: [ModuleCollectionId] } @@ -49,19 +55,22 @@ (==) = (==) `on` _mcId instance Show ModuleCollection where - show (ModuleCollection id root srcDirs mods _ deps) + show (ModuleCollection id root srcDirs mods _ _ deps) = "ModuleCollection (" ++ show id ++ ") " ++ root ++ " " ++ show srcDirs ++ " (" ++ show mods ++ ") " ++ show deps +containingMC :: FilePath -> Simple Traversal [ModuleCollection] ModuleCollection +containingMC fp = traversal & filtered (\mc -> _mcRoot mc `isPrefixOf` fp) + -- | The state of a module. -data ModuleRecord +data ModuleRecord = ModuleNotLoaded { _recModuleWillNeedCode :: Bool } | ModuleParsed { _parsedRecModule :: UnnamedModule (Dom RdrName) , _modRecMS :: ModSummary } | ModuleRenamed { _renamedRecModule :: UnnamedModule (Dom Name) - , _modRecMS :: ModSummary + , _modRecMS :: ModSummary } - | ModuleTypeChecked { _typedRecModule :: UnnamedModule IdDom + | ModuleTypeChecked { _typedRecModule :: UnnamedModule IdDom , _modRecMS :: ModSummary } | ModuleCodeGenerated { _typedRecModule :: UnnamedModule IdDom @@ -108,11 +117,11 @@ removeModule moduleName = map (mcModules .- Map.filterWithKey (\k _ -> moduleName /= (k ^. sfkModuleName))) hasGeneratedCode :: SourceFileKey -> [ModuleCollection] -> Bool -hasGeneratedCode key = maybe False (\case (_, ModuleCodeGenerated {}) -> True; _ -> False) +hasGeneratedCode key = maybe False (\case (_, ModuleCodeGenerated {}) -> True; _ -> False) . find ((key ==) . fst) . concatMap (Map.assocs . (^. mcModules)) needsGeneratedCode :: SourceFileKey -> [ModuleCollection] -> Bool -needsGeneratedCode key = maybe False (\case (_, ModuleCodeGenerated {}) -> True; (_, ModuleNotLoaded True) -> True; _ -> False) +needsGeneratedCode key = maybe False (\case (_, ModuleCodeGenerated {}) -> True; (_, ModuleNotLoaded True) -> True; _ -> False) . find ((key ==) . fst) . concatMap (Map.assocs . (^. mcModules)) codeGeneratedFor :: SourceFileKey -> [ModuleCollection] -> [ModuleCollection] @@ -121,7 +130,7 @@ r -> r) key) isAlreadyLoaded :: SourceFileKey -> [ModuleCollection] -> Bool -isAlreadyLoaded key = maybe False (\case (_, ModuleNotLoaded {}) -> False; _ -> True) +isAlreadyLoaded key = maybe False (\case (_, ModuleNotLoaded {}) -> False; _ -> True) . find ((key ==) . fst) . concatMap (Map.assocs . (^. mcModules)) -- | Gets all ModuleCollections from a list of source directories. It also orders the source directories that are package roots so that @@ -151,23 +160,23 @@ case find (\p -> takeExtension p == ".cabal") files of Just cabalFile -> modulesFromCabalFile root cabalFile Nothing -> do mods <- modulesFromDirectory root root - return [ModuleCollection (DirectoryMC root) root [root] (Map.fromList $ map ((, ModuleNotLoaded False) . SourceFileKey NormalHs) mods) return []] + return [ModuleCollection (DirectoryMC root) root [root] (Map.fromList $ map ((, ModuleNotLoaded False) . SourceFileKey NormalHs) mods) return return []] -- | Load the module giving a directory. All modules loaded from the folder and subfolders. modulesFromDirectory :: FilePath -> FilePath -> IO [String] -- now recognizing only .hs files modulesFromDirectory root searchRoot = concat <$> (mapM goOn =<< listDirectory searchRoot) - where goOn fp = let path = searchRoot fp - in do isDir <- doesDirectoryExist path + 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] + then modulesFromDirectory root path + else if takeExtension path == ".hs" + then return [concat $ intersperse "." $ splitDirectories $ dropExtension $ makeRelative root path] else return [] - + srcDirFromRoot :: FilePath -> String -> FilePath -srcDirFromRoot fileName "" = fileName -srcDirFromRoot fileName moduleName +srcDirFromRoot fileName "" = fileName +srcDirFromRoot fileName moduleName = srcDirFromRoot (takeDirectory fileName) (dropWhile (/= '.') $ dropWhile (== '.') moduleName) -- | Load the module using a cabal file. The modules described in the cabal file will be loaded. @@ -175,29 +184,30 @@ modulesFromCabalFile :: FilePath -> FilePath -> IO [ModuleCollection] -- now adding all conditional entries, regardless of flags modulesFromCabalFile root cabal = getModules . setupFlags <$> readPackageDescription silent (root cabal) - where getModules pkg = maybe [] (maybe [] (:[]) . toModuleCollection pkg) (library pkg) - ++ catMaybes (map (toModuleCollection pkg) (executables pkg)) - ++ catMaybes (map (toModuleCollection pkg) (testSuites pkg)) + where getModules pkg = maybe [] (maybe [] (:[]) . toModuleCollection pkg) (library pkg) + ++ catMaybes (map (toModuleCollection pkg) (executables pkg)) + ++ catMaybes (map (toModuleCollection pkg) (testSuites pkg)) ++ catMaybes (map (toModuleCollection pkg) (benchmarks pkg)) - + toModuleCollection :: ToModuleCollection tmc => PackageDescription -> tmc -> Maybe ModuleCollection - toModuleCollection pkg tmc - = let bi = getBuildInfo tmc + toModuleCollection pkg tmc + = let bi = getBuildInfo tmc in if buildable bi - then Just $ ModuleCollection (mkModuleCollKey (pkgName $ package pkg) tmc) + then Just $ ModuleCollection (mkModuleCollKey (pkgName $ package pkg) tmc) root - (map (normalise . (root )) $ hsSourceDirs bi) - (Map.fromList $ map ((, ModuleNotLoaded False) . SourceFileKey NormalHs . moduleName) (getModuleNames tmc)) + (map (normalise . (root )) $ hsSourceDirs bi) + (Map.fromList $ map ((, ModuleNotLoaded False) . SourceFileKey NormalHs . moduleName) (getModuleNames tmc)) (flagsFromBuildInfo bi) - (map (\(Dependency pkgName _) -> LibraryMC (unPackageName pkgName)) (targetBuildDepends bi)) + (loadFlagsFromBuildInfo bi) + (map (\(Dependency pkgName _) -> LibraryMC (unPackageName pkgName)) (targetBuildDepends bi)) else Nothing moduleName = concat . intersperse "." . components - setupFlags = either (\deps -> error $ "Missing dependencies: " ++ show deps) fst - . finalizePackageDescription [] (const True) buildPlatform + setupFlags = either (\deps -> error $ "Missing dependencies: " ++ show deps) fst + . finalizePackageDescription [] (const True) buildPlatform (unknownCompilerInfo buildCompilerId NoAbiTag) [] -class ToModuleCollection t where +class ToModuleCollection t where mkModuleCollKey :: PackageName -> t -> ModuleCollectionId getBuildInfo :: t -> BuildInfo getModuleNames :: t -> [ModuleName] @@ -223,153 +233,249 @@ getBuildInfo = benchmarkBuildInfo getModuleNames = benchmarkModules +isDirectoryMC :: ModuleCollection -> Bool +isDirectoryMC mc = case mc ^. mcId of DirectoryMC{} -> True; _ -> False compileInContext :: ModuleCollection -> [ModuleCollection] -> DynFlags -> IO DynFlags -compileInContext mc mcs dfs - = (\dfs' -> applyDependencies mcs (mc ^. mcDependencies) dfs') +compileInContext mc mcs dfs + = (\dfs' -> applyDependencies mcs (mc ^. mcDependencies) (selectEnabled dfs')) <$> (mc ^. mcFlagSetup $ dfs) + where selectEnabled = if isDirectoryMC mc then id else onlyUseEnabled applyDependencies :: [ModuleCollection] -> [ModuleCollectionId] -> DynFlags -> DynFlags -applyDependencies mcs ids dfs = dfs { GHC.packageFlags = catMaybes $ map (dependencyToPkgFlag mcs) ids } +applyDependencies mcs ids dfs + = dfs { GHC.packageFlags = GHC.packageFlags dfs ++ (catMaybes $ map (dependencyToPkgFlag mcs) ids) } +onlyUseEnabled :: DynFlags -> DynFlags +onlyUseEnabled = GHC.setGeneralFlag' GHC.Opt_HideAllPackages + dependencyToPkgFlag :: [ModuleCollection] -> ModuleCollectionId -> Maybe (GHC.PackageFlag) -dependencyToPkgFlag mcs lib@(LibraryMC pkgName) - = if isNothing $ find (\mc -> (mc ^. mcId) == lib) mcs +dependencyToPkgFlag mcs lib@(LibraryMC pkgName) + = if isNothing $ find (\mc -> (mc ^. mcId) == lib) mcs then Just $ GHC.ExposePackage pkgName (GHC.PackageArg pkgName) (GHC.ModRenaming True []) else Nothing dependencyToPkgFlag _ _ = Nothing -enableAllPackages :: [ModuleCollection] -> DynFlags -> DynFlags -enableAllPackages mcs dfs = applyDependencies mcs allDeps dfs +setupLoadFlags :: [ModuleCollection] -> DynFlags -> IO DynFlags +setupLoadFlags mcs dfs = applyDependencies mcs allDeps . selectEnabled <$> useSavedFlags dfs where allDeps = mcs ^? traversal & mcDependencies & traversal + selectEnabled = if any (\(mc,rest) -> isDirectoryMC mc && isIndependentMc mc rest) (breaks mcs) then id else onlyUseEnabled + useSavedFlags = foldl @[] (>=>) return (mcs ^? traversal & mcLoadFlagSetup) + isIndependentMc mc rest = not $ any (`isPrefixOf` (mc ^. mcRoot)) (map (^. mcRoot) rest) +breaks :: [a] -> [(a,[a])] +breaks [] = [] +breaks (e:rest) = (e,rest) : map (\(x,ls) -> (x,e:ls)) (breaks rest) + +loadFlagsFromBuildInfo :: BuildInfo -> DynFlags -> IO DynFlags +loadFlagsFromBuildInfo bi@BuildInfo{ cppOptions } df + = do (df',unused,warnings) <- parseDynamicFlags df (map (L noSrcSpan) $ cppOptions) + mapM_ putStrLn (map unLoc warnings ++ map (("Flag is not used: " ++) . unLoc) unused) + return (setupLoadExtensions df') + where setupLoadExtensions = foldl (.) id (map setExtensionFlag' $ catMaybes $ map translateExtension loadExtensions) + loadExtensions = [PatternSynonyms | patternSynonymsNeeded] ++ [ExplicitNamespaces | explicitNamespacesNeeded] + ++ [PackageImports | packageImportsNeeded] ++ [CPP | cppNeeded] ++ [MagicHash | magicHashNeeded] + explicitNamespacesNeeded = not $ null $ map EnableExtension [ExplicitNamespaces, TypeFamilies, TypeOperators] `intersect` usedExtensions bi + patternSynonymsNeeded = EnableExtension PatternSynonyms `elem` usedExtensions bi + packageImportsNeeded = EnableExtension PackageImports `elem` usedExtensions bi + cppNeeded = EnableExtension CPP `elem` usedExtensions bi + magicHashNeeded = EnableExtension MagicHash `elem` usedExtensions bi + flagsFromBuildInfo :: BuildInfo -> DynFlags -> IO DynFlags -- the import pathes are already set globally flagsFromBuildInfo bi@BuildInfo{ options } df - = do (df,_,_) <- parseDynamicFlags df (map (L noSrcSpan) $ concatMap snd options) - return $ foldl (.) id (map (\case EnableExtension ext -> translateExtension ext - _ -> id - ) (usedExtensions bi)) - $ df - where -- | Map the cabal extensions to the ones that GHC recognizes - translateExtension OverlappingInstances = flip xopt_set GHC.OverlappingInstances - translateExtension UndecidableInstances = flip xopt_set GHC.UndecidableInstances - translateExtension IncoherentInstances = flip xopt_set GHC.IncoherentInstances - translateExtension DoRec = flip xopt_set GHC.RecursiveDo - translateExtension RecursiveDo = flip xopt_set GHC.RecursiveDo - translateExtension ParallelListComp = flip xopt_set GHC.ParallelListComp - translateExtension MultiParamTypeClasses = flip xopt_set GHC.MultiParamTypeClasses - translateExtension MonomorphismRestriction = flip xopt_set GHC.MonomorphismRestriction - translateExtension FunctionalDependencies = flip xopt_set GHC.FunctionalDependencies - translateExtension RankNTypes = flip xopt_set GHC.RankNTypes - translateExtension ExistentialQuantification = flip xopt_set GHC.ExistentialQuantification - translateExtension ScopedTypeVariables = flip xopt_set GHC.ScopedTypeVariables - translateExtension PatternSignatures = flip xopt_set GHC.PatternSynonyms - translateExtension ImplicitParams = flip xopt_set GHC.ImplicitParams - translateExtension FlexibleContexts = flip xopt_set GHC.FlexibleContexts - translateExtension FlexibleInstances = flip xopt_set GHC.FlexibleInstances - translateExtension EmptyDataDecls = flip xopt_set GHC.EmptyDataDecls - translateExtension CPP = flip xopt_set GHC.Cpp - translateExtension KindSignatures = flip xopt_set GHC.KindSignatures - translateExtension BangPatterns = flip xopt_set GHC.BangPatterns - translateExtension TypeSynonymInstances = flip xopt_set GHC.TypeSynonymInstances - translateExtension TemplateHaskell = flip xopt_set GHC.TemplateHaskell - translateExtension ForeignFunctionInterface = flip xopt_set GHC.ForeignFunctionInterface - translateExtension Arrows = flip xopt_set GHC.Arrows - translateExtension ImplicitPrelude = flip xopt_set GHC.ImplicitPrelude - translateExtension NamedFieldPuns = flip xopt_set GHC.RecordPuns - translateExtension PatternGuards = flip xopt_set GHC.PatternGuards - translateExtension GeneralizedNewtypeDeriving = flip xopt_set GHC.GeneralizedNewtypeDeriving - translateExtension RestrictedTypeSynonyms = flip xopt_unset GHC.LiberalTypeSynonyms - translateExtension MagicHash = flip xopt_set GHC.MagicHash - translateExtension TypeFamilies = flip xopt_set GHC.TypeFamilies - translateExtension StandaloneDeriving = flip xopt_set GHC.StandaloneDeriving - translateExtension UnicodeSyntax = flip xopt_set GHC.UnicodeSyntax - translateExtension UnliftedFFITypes = flip xopt_set GHC.UnliftedFFITypes - translateExtension InterruptibleFFI = flip xopt_set GHC.InterruptibleFFI - translateExtension CApiFFI = flip xopt_set GHC.CApiFFI - translateExtension LiberalTypeSynonyms = flip xopt_set GHC.LiberalTypeSynonyms - translateExtension TypeOperators = flip xopt_set GHC.TypeOperators - translateExtension RecordWildCards = flip xopt_set GHC.RecordWildCards - translateExtension RecordPuns = flip xopt_set GHC.RecordPuns - translateExtension DisambiguateRecordFields = flip xopt_set GHC.DisambiguateRecordFields - translateExtension TraditionalRecordSyntax = flip xopt_set GHC.TraditionalRecordSyntax - translateExtension OverloadedStrings = flip xopt_set GHC.OverloadedStrings - translateExtension GADTs = flip xopt_set GHC.GADTs - translateExtension GADTSyntax = flip xopt_set GHC.GADTSyntax - translateExtension MonoPatBinds = flip xopt_set GHC.MonoPatBinds - translateExtension RelaxedPolyRec = flip xopt_set GHC.RelaxedPolyRec - translateExtension ExtendedDefaultRules = flip xopt_set GHC.ExtendedDefaultRules - translateExtension UnboxedTuples = flip xopt_set GHC.UnboxedTuples - translateExtension DeriveDataTypeable = flip xopt_set GHC.DeriveDataTypeable - translateExtension DeriveGeneric = flip xopt_set GHC.DeriveGeneric - translateExtension DefaultSignatures = flip xopt_set GHC.DefaultSignatures - translateExtension InstanceSigs = flip xopt_set GHC.InstanceSigs - translateExtension ConstrainedClassMethods = flip xopt_set GHC.ConstrainedClassMethods - translateExtension PackageImports = flip xopt_set GHC.PackageImports - translateExtension ImpredicativeTypes = flip xopt_set GHC.ImpredicativeTypes - translateExtension PostfixOperators = flip xopt_set GHC.PostfixOperators - translateExtension QuasiQuotes = flip xopt_set GHC.QuasiQuotes - translateExtension TransformListComp = flip xopt_set GHC.TransformListComp - translateExtension MonadComprehensions = flip xopt_set GHC.MonadComprehensions - translateExtension ViewPatterns = flip xopt_set GHC.ViewPatterns - translateExtension TupleSections = flip xopt_set GHC.TupleSections - translateExtension GHCForeignImportPrim = flip xopt_set GHC.GHCForeignImportPrim - translateExtension NPlusKPatterns = flip xopt_set GHC.NPlusKPatterns - translateExtension DoAndIfThenElse = flip xopt_set GHC.DoAndIfThenElse - translateExtension MultiWayIf = flip xopt_set GHC.MultiWayIf - translateExtension LambdaCase = flip xopt_set GHC.LambdaCase - translateExtension RebindableSyntax = flip xopt_set GHC.RebindableSyntax - translateExtension ExplicitForAll = flip xopt_set GHC.ExplicitForAll - translateExtension DatatypeContexts = flip xopt_set GHC.DatatypeContexts - translateExtension MonoLocalBinds = flip xopt_set GHC.MonoLocalBinds - translateExtension DeriveFunctor = flip xopt_set GHC.DeriveFunctor - translateExtension DeriveTraversable = flip xopt_set GHC.DeriveTraversable - translateExtension DeriveFoldable = flip xopt_set GHC.DeriveFoldable - translateExtension NondecreasingIndentation = flip xopt_set GHC.NondecreasingIndentation - translateExtension ConstraintKinds = flip xopt_set GHC.ConstraintKinds - translateExtension PolyKinds = flip xopt_set GHC.PolyKinds - translateExtension DataKinds = flip xopt_set GHC.DataKinds - translateExtension ParallelArrays = flip xopt_set GHC.ParallelArrays - translateExtension RoleAnnotations = flip xopt_set GHC.RoleAnnotations - translateExtension OverloadedLists = flip xopt_set GHC.OverloadedLists - translateExtension EmptyCase = flip xopt_set GHC.EmptyCase - translateExtension AutoDeriveTypeable = flip xopt_set GHC.AutoDeriveTypeable - translateExtension NegativeLiterals = flip xopt_set GHC.NegativeLiterals - translateExtension BinaryLiterals = flip xopt_set GHC.BinaryLiterals - translateExtension NumDecimals = flip xopt_set GHC.NumDecimals - translateExtension NullaryTypeClasses = flip xopt_set GHC.NullaryTypeClasses - translateExtension ExplicitNamespaces = flip xopt_set GHC.ExplicitNamespaces - translateExtension AllowAmbiguousTypes = flip xopt_set GHC.AllowAmbiguousTypes - translateExtension JavaScriptFFI = flip xopt_set GHC.JavaScriptFFI - translateExtension PatternSynonyms = flip xopt_set GHC.PatternSynonyms - translateExtension PartialTypeSignatures = flip xopt_set GHC.PartialTypeSignatures - translateExtension NamedWildCards = flip xopt_set GHC.NamedWildCards - translateExtension DeriveAnyClass = flip xopt_set GHC.DeriveAnyClass - translateExtension DeriveLift = flip xopt_set GHC.DeriveLift - translateExtension StaticPointers = flip xopt_set GHC.StaticPointers - translateExtension StrictData = flip xopt_set GHC.StrictData - translateExtension Strict = flip xopt_set GHC.Strict - translateExtension ApplicativeDo = flip xopt_set GHC.ApplicativeDo - translateExtension DuplicateRecordFields = flip xopt_set GHC.DuplicateRecordFields - translateExtension TypeApplications = flip xopt_set GHC.TypeApplications - translateExtension TypeInType = flip xopt_set GHC.TypeInType - translateExtension UndecidableSuperClasses = flip xopt_set GHC.UndecidableSuperClasses - translateExtension MonadFailDesugaring = flip xopt_set GHC.MonadFailDesugaring - translateExtension TemplateHaskellQuotes = flip xopt_set GHC.TemplateHaskellQuotes - translateExtension OverloadedLabels = flip xopt_set GHC.OverloadedLabels + = do (df',unused,warnings) <- parseDynamicFlags df (map (L noSrcSpan) $ concatMap snd options) + mapM_ putStrLn (map unLoc warnings ++ map (("Flag is not used: " ++) . unLoc) unused) + return $ (flip lang_set (toGhcLang =<< defaultLanguage bi)) + $ foldl (.) id (map (\case EnableExtension ext -> setEnabled True ext + DisableExtension ext -> setEnabled False ext + ) (usedExtensions bi)) + $ foldr (.) id (map (setEnabled True) (languageDefault (defaultLanguage bi))) + $ df' + where toGhcLang Cabal.Haskell98 = Just GHC.Haskell98 + toGhcLang Cabal.Haskell2010 = Just GHC.Haskell2010 + toGhcLang _ = Nothing - translateExtension Safe = \df -> df { GHC.safeHaskell = GHC.Sf_Safe } - translateExtension SafeImports = \df -> df { GHC.safeHaskell = GHC.Sf_Safe } - translateExtension Trustworthy = \df -> df { GHC.safeHaskell = GHC.Sf_Trustworthy } - translateExtension Unsafe = \df -> df { GHC.safeHaskell = GHC.Sf_Unsafe } + -- We don't put the default settings (ImplicitPrelude, MonomorphismRestriction) here + -- because that overrides the opposite extensions (NoImplicitPrelude, NoMonomorphismRestriction) + -- enabled in modules. + languageDefault (Just Cabal.Haskell2010) + = [ DatatypeContexts, DoAndIfThenElse, EmptyDataDecls, ForeignFunctionInterface + , PatternGuards, RelaxedPolyRec, TraditionalRecordSyntax ] + -- Haskell 98 is the default + languageDefault _ + = [ DatatypeContexts, NondecreasingIndentation, NPlusKPatterns, TraditionalRecordSyntax ] - -- Couldn't find the equivalent of these extensions - translateExtension Rank2Types = id - translateExtension PolymorphicComponents = id - translateExtension Generics = id - translateExtension ExtensibleRecords = id - translateExtension NewQualifiedOperators = id - translateExtension XmlSyntax = id - translateExtension HereDocuments = id - translateExtension RegularPatterns = id + setEnabled enable ext + = case translateExtension ext of + Just e -> (if enable then setExtensionFlag' else unSetExtensionFlag') e + Nothing -> id + +-- * Not imported from DynFlags.hs, so I copied it here +setExtensionFlag', unSetExtensionFlag' :: GHC.Extension -> DynFlags -> DynFlags +setExtensionFlag' f dflags = foldr ($) (xopt_set dflags f) deps + where + deps = [ if turn_on then setExtensionFlag' d + else unSetExtensionFlag' d + | (f', turn_on, d) <- impliedXFlags, f' == f ] +unSetExtensionFlag' f dflags = xopt_unset dflags f + +turnOn = True +turnOff = False + +impliedXFlags :: [(GHC.Extension, Bool, GHC.Extension)] +impliedXFlags + = [ (GHC.RankNTypes, turnOn, GHC.ExplicitForAll) + , (GHC.ScopedTypeVariables, turnOn, GHC.ExplicitForAll) + , (GHC.LiberalTypeSynonyms, turnOn, GHC.ExplicitForAll) + , (GHC.ExistentialQuantification, turnOn, GHC.ExplicitForAll) + , (GHC.FlexibleInstances, turnOn, GHC.TypeSynonymInstances) + , (GHC.FunctionalDependencies, turnOn, GHC.MultiParamTypeClasses) + , (GHC.MultiParamTypeClasses, turnOn, GHC.ConstrainedClassMethods) + , (GHC.TypeFamilyDependencies, turnOn, GHC.TypeFamilies) + , (GHC.RebindableSyntax, turnOff, GHC.ImplicitPrelude) + , (GHC.GADTs, turnOn, GHC.GADTSyntax) + , (GHC.GADTs, turnOn, GHC.MonoLocalBinds) + , (GHC.TypeFamilies, turnOn, GHC.MonoLocalBinds) + , (GHC.TypeFamilies, turnOn, GHC.KindSignatures) + , (GHC.PolyKinds, turnOn, GHC.KindSignatures) + , (GHC.TypeInType, turnOn, GHC.DataKinds) + , (GHC.TypeInType, turnOn, GHC.PolyKinds) + , (GHC.TypeInType, turnOn, GHC.KindSignatures) + , (GHC.AutoDeriveTypeable, turnOn, GHC.DeriveDataTypeable) + , (GHC.TypeFamilies, turnOn, GHC.ExplicitNamespaces) + , (GHC.TypeOperators, turnOn, GHC.ExplicitNamespaces) + , (GHC.ImpredicativeTypes, turnOn, GHC.RankNTypes) + , (GHC.RecordWildCards, turnOn, GHC.DisambiguateRecordFields) + , (GHC.ParallelArrays, turnOn, GHC.ParallelListComp) + , (GHC.JavaScriptFFI, turnOn, GHC.InterruptibleFFI) + , (GHC.DeriveTraversable, turnOn, GHC.DeriveFunctor) + , (GHC.DeriveTraversable, turnOn, GHC.DeriveFoldable) + , (GHC.DuplicateRecordFields, turnOn, GHC.DisambiguateRecordFields) + , (GHC.TemplateHaskell, turnOn, GHC.TemplateHaskellQuotes) + , (GHC.Strict, turnOn, GHC.StrictData) + ] + +-- * Mapping of Cabal haskell extensions to their GHC counterpart + +-- | Map the cabal extensions to the ones that GHC recognizes +translateExtension AllowAmbiguousTypes = Just GHC.AllowAmbiguousTypes +translateExtension ApplicativeDo = Just GHC.ApplicativeDo +translateExtension Arrows = Just GHC.Arrows +translateExtension AutoDeriveTypeable = Just GHC.AutoDeriveTypeable +translateExtension BangPatterns = Just GHC.BangPatterns +translateExtension BinaryLiterals = Just GHC.BinaryLiterals +translateExtension CApiFFI = Just GHC.CApiFFI +translateExtension ConstrainedClassMethods = Just GHC.ConstrainedClassMethods +translateExtension ConstraintKinds = Just GHC.ConstraintKinds +translateExtension CPP = Just GHC.Cpp +translateExtension DataKinds = Just GHC.DataKinds +translateExtension DatatypeContexts = Just GHC.DatatypeContexts +translateExtension DefaultSignatures = Just GHC.DefaultSignatures +translateExtension DeriveAnyClass = Just GHC.DeriveAnyClass +translateExtension DeriveDataTypeable = Just GHC.DeriveDataTypeable +translateExtension DeriveFoldable = Just GHC.DeriveFoldable +translateExtension DeriveFunctor = Just GHC.DeriveFunctor +translateExtension DeriveGeneric = Just GHC.DeriveGeneric +translateExtension DeriveLift = Just GHC.DeriveLift +translateExtension DeriveTraversable = Just GHC.DeriveTraversable +translateExtension DisambiguateRecordFields = Just GHC.DisambiguateRecordFields +translateExtension DoAndIfThenElse = Just GHC.DoAndIfThenElse +translateExtension DoRec = Just GHC.RecursiveDo +translateExtension DuplicateRecordFields = Just GHC.DuplicateRecordFields +translateExtension EmptyCase = Just GHC.EmptyCase +translateExtension EmptyDataDecls = Just GHC.EmptyDataDecls +translateExtension ExistentialQuantification = Just GHC.ExistentialQuantification +translateExtension ExplicitForAll = Just GHC.ExplicitForAll +translateExtension ExplicitNamespaces = Just GHC.ExplicitNamespaces +translateExtension ExtendedDefaultRules = Just GHC.ExtendedDefaultRules +translateExtension FlexibleContexts = Just GHC.FlexibleContexts +translateExtension FlexibleInstances = Just GHC.FlexibleInstances +translateExtension ForeignFunctionInterface = Just GHC.ForeignFunctionInterface +translateExtension FunctionalDependencies = Just GHC.FunctionalDependencies +translateExtension GADTs = Just GHC.GADTs +translateExtension GADTSyntax = Just GHC.GADTSyntax +translateExtension GeneralizedNewtypeDeriving = Just GHC.GeneralizedNewtypeDeriving +translateExtension GHCForeignImportPrim = Just GHC.GHCForeignImportPrim +translateExtension ImplicitParams = Just GHC.ImplicitParams +translateExtension ImplicitPrelude = Just GHC.ImplicitPrelude +translateExtension ImpredicativeTypes = Just GHC.ImpredicativeTypes +translateExtension IncoherentInstances = Just GHC.IncoherentInstances +translateExtension InstanceSigs = Just GHC.InstanceSigs +translateExtension InterruptibleFFI = Just GHC.InterruptibleFFI +translateExtension JavaScriptFFI = Just GHC.JavaScriptFFI +translateExtension KindSignatures = Just GHC.KindSignatures +translateExtension LambdaCase = Just GHC.LambdaCase +translateExtension LiberalTypeSynonyms = Just GHC.LiberalTypeSynonyms +translateExtension MagicHash = Just GHC.MagicHash +translateExtension MonadComprehensions = Just GHC.MonadComprehensions +translateExtension MonadFailDesugaring = Just GHC.MonadFailDesugaring +translateExtension MonoLocalBinds = Just GHC.MonoLocalBinds +translateExtension MonomorphismRestriction = Just GHC.MonomorphismRestriction +translateExtension MonoPatBinds = Just GHC.MonoPatBinds +translateExtension MultiParamTypeClasses = Just GHC.MultiParamTypeClasses +translateExtension MultiWayIf = Just GHC.MultiWayIf +translateExtension NamedFieldPuns = Just GHC.RecordPuns +translateExtension NamedWildCards = Just GHC.NamedWildCards +translateExtension NegativeLiterals = Just GHC.NegativeLiterals +translateExtension NondecreasingIndentation = Just GHC.NondecreasingIndentation +translateExtension NPlusKPatterns = Just GHC.NPlusKPatterns +translateExtension NullaryTypeClasses = Just GHC.NullaryTypeClasses +translateExtension NumDecimals = Just GHC.NumDecimals +translateExtension OverlappingInstances = Just GHC.OverlappingInstances +translateExtension OverloadedLabels = Just GHC.OverloadedLabels +translateExtension OverloadedLists = Just GHC.OverloadedLists +translateExtension OverloadedStrings = Just GHC.OverloadedStrings +translateExtension PackageImports = Just GHC.PackageImports +translateExtension ParallelArrays = Just GHC.ParallelArrays +translateExtension ParallelListComp = Just GHC.ParallelListComp +translateExtension PartialTypeSignatures = Just GHC.PartialTypeSignatures +translateExtension PatternGuards = Just GHC.PatternGuards +translateExtension PatternSignatures = Just GHC.PatternSynonyms +translateExtension PatternSynonyms = Just GHC.PatternSynonyms +translateExtension PolyKinds = Just GHC.PolyKinds +translateExtension PostfixOperators = Just GHC.PostfixOperators +translateExtension QuasiQuotes = Just GHC.QuasiQuotes +translateExtension RankNTypes = Just GHC.RankNTypes +translateExtension RebindableSyntax = Just GHC.RebindableSyntax +translateExtension RecordPuns = Just GHC.RecordPuns +translateExtension RecordWildCards = Just GHC.RecordWildCards +translateExtension RecursiveDo = Just GHC.RecursiveDo +translateExtension RelaxedPolyRec = Just GHC.RelaxedPolyRec +translateExtension RestrictedTypeSynonyms = Nothing -- flip xopt_unset GHC.LiberalTypeSynonyms +translateExtension RoleAnnotations = Just GHC.RoleAnnotations +translateExtension ScopedTypeVariables = Just GHC.ScopedTypeVariables +translateExtension StandaloneDeriving = Just GHC.StandaloneDeriving +translateExtension StaticPointers = Just GHC.StaticPointers +translateExtension Strict = Just GHC.Strict +translateExtension StrictData = Just GHC.StrictData +translateExtension TemplateHaskell = Just GHC.TemplateHaskell +translateExtension TemplateHaskellQuotes = Just GHC.TemplateHaskellQuotes +translateExtension TraditionalRecordSyntax = Just GHC.TraditionalRecordSyntax +translateExtension TransformListComp = Just GHC.TransformListComp +translateExtension TupleSections = Just GHC.TupleSections +translateExtension TypeApplications = Just GHC.TypeApplications +translateExtension TypeFamilies = Just GHC.TypeFamilies +translateExtension TypeInType = Just GHC.TypeInType +translateExtension TypeOperators = Just GHC.TypeOperators +translateExtension TypeSynonymInstances = Just GHC.TypeSynonymInstances +translateExtension UnboxedTuples = Just GHC.UnboxedTuples +translateExtension UndecidableInstances = Just GHC.UndecidableInstances +translateExtension UndecidableSuperClasses = Just GHC.UndecidableSuperClasses +translateExtension UnicodeSyntax = Just GHC.UnicodeSyntax +translateExtension UnliftedFFITypes = Just GHC.UnliftedFFITypes +translateExtension ViewPatterns = Just GHC.ViewPatterns + +translateExtension Safe = Nothing -- \df -> df { GHC.safeHaskell = GHC.Sf_Safe } +translateExtension SafeImports = Nothing -- \df -> df { GHC.safeHaskell = GHC.Sf_Safe } +translateExtension Trustworthy = Nothing -- \df -> df { GHC.safeHaskell = GHC.Sf_Trustworthy } +translateExtension Unsafe = Nothing -- \df -> df { GHC.safeHaskell = GHC.Sf_Unsafe } + +translateExtension Rank2Types = Just GHC.RankNTypes +translateExtension PolymorphicComponents = Just GHC.RankNTypes +translateExtension Generics = Nothing -- it does nothing, deprecated extension +translateExtension NewQualifiedOperators = Nothing -- it does nothing, deprecated extension +translateExtension ExtensibleRecords = Nothing -- not in GHC +translateExtension XmlSyntax = Nothing -- not in GHC +translateExtension HereDocuments = Nothing -- not in GHC +translateExtension RegularPatterns = Nothing -- not in GHC diff --git a/Language/Haskell/Tools/Refactor/ListOperations.hs b/Language/Haskell/Tools/Refactor/ListOperations.hs --- a/Language/Haskell/Tools/Refactor/ListOperations.hs +++ b/Language/Haskell/Tools/Refactor/ListOperations.hs @@ -1,13 +1,14 @@ {-# LANGUAGE TupleSections #-} --- | Defines operation on AST lists. +-- | Defines operation on AST lists. -- AST lists carry source information so simple list modification is not enough. module Language.Haskell.Tools.Refactor.ListOperations where import Control.Reference +import Data.List (findIndices) import Language.Haskell.Tools.AST import Language.Haskell.Tools.AST.Rewrite (AnnList) -import Language.Haskell.Tools.Transform (srcTmpDefaultSeparator, srcTmpSeparators) +import Language.Haskell.Tools.Transform (srcTmpDefaultSeparator, srcTmpSeparators, srcTmpIndented) -- | Filters the elements of the list. By default it removes the separator before the element. -- Of course, if the first element is removed, the following separator is removed as well. @@ -16,33 +17,35 @@ filterListIndexed :: (Int -> Ann e dom SrcTemplateStage -> Bool) -> AnnList e dom -> AnnList e dom filterListIndexed pred (AnnListG (NodeInfo sema src) elems) - = let (filteredElems, separators) = filterElems 0 elems (src ^. srcTmpSeparators) - in AnnListG (NodeInfo sema (srcTmpSeparators .= separators $ src)) filteredElems - where filterElems i (elem:ls) (sep:seps) - | pred i elem = let (elems',seps') = filterElems' (i+1) ls (sep:seps) in (elem:elems', seps') - | otherwise = filterElems (i+1) ls seps - filterElems i elems [] = (filter (pred i) elems, []) - filterElems _ [] seps = ([], seps) - - filterElems' i (elem:ls) (sep:seps) - | pred i elem = let (elems',seps') = filterElems' (i+1) ls seps in (elem:elems', sep:seps') - | otherwise = filterElems' (i+1) ls seps - filterElems' i elems [] = (filter (pred i) elems, []) - filterElems' _ [] seps = ([], seps) - + = AnnListG (NodeInfo sema (srcTmpIndented .- fmap filterIndents $ srcTmpSeparators .- filterSeparators $ src)) filteredElems + where elementsKept = findIndices (uncurry pred) (zip [0..] elems) + filteredElems = sublist elementsKept elems + filterIndents = sublist elementsKept + filterSeparators = take (length elementsKept - 1) . sublist elementsKept + +-- | Selects the given indices from a list +sublist :: [Int] -> [a] -> [a] +sublist = sublist' 0 + where sublist' i [] _ = [] + sublist' i _ [] = [] + sublist' i (ind:more) (e:rest) + | i == ind = e : sublist' (i+1) more rest + | otherwise = sublist' (i+1) (ind:more) rest + -- | Inserts the element in the places where the two positioning functions (one checks the element before, one the element after) --- allows the placement. -insertWhere :: Ann e dom SrcTemplateStage -> (Maybe (Ann e dom SrcTemplateStage) -> Bool) - -> (Maybe (Ann e dom SrcTemplateStage) -> Bool) -> AnnList e dom +-- allows the placement. +insertWhere :: Bool -> Ann e dom SrcTemplateStage -> (Maybe (Ann e dom SrcTemplateStage) -> Bool) + -> (Maybe (Ann e dom SrcTemplateStage) -> Bool) -> AnnList e dom -> AnnList e dom -insertWhere e before after al +insertWhere indented e before after al = let index = insertIndex before after (al ^? annList) - in case index of + in case index of Nothing -> al - Just ind -> annListElems .- insertAt ind e - $ (if isEmptyAnnList then id else annListAnnot&sourceInfo .- addDefaultSeparator ind) - $ al - where addDefaultSeparator i al = srcTmpSeparators .- insertAt i (al ^. srcTmpDefaultSeparator) $ al + Just ind -> annListElems .- insertAt ind e + $ (if isEmptyAnnList then id else annListAnnot&sourceInfo .- setIndented ind . addDefaultSeparator ind) + $ al + where setIndented i = srcTmpIndented .- fmap (insertAt i indented) + addDefaultSeparator i al = srcTmpSeparators .- insertAt i (al ^. srcTmpDefaultSeparator) $ al insertAt n e ls = let (bef,aft) = splitAt n ls in bef ++ [e] ++ aft isEmptyAnnList = (null :: [x] -> Bool) $ (al ^? annList) @@ -53,23 +56,23 @@ | otherwise = Nothing insertIndex before after list@(first:_) | before Nothing && after (Just first) = Just 0 - | otherwise = (+1) <$> insertIndex' before after list - where insertIndex' before after (curr:rest@(next:_)) + | otherwise = (+1) <$> insertIndex' before after list + where insertIndex' before after (curr:rest@(next:_)) | before (Just curr) && after (Just next) = Just 0 | otherwise = (+1) <$> insertIndex' before after rest - insertIndex' before after (curr:[]) + insertIndex' before after (curr:[]) | before (Just curr) && after Nothing = Just 0 | otherwise = Nothing - insertIndex' before after [] + insertIndex' before after [] | before Nothing && after Nothing = Just 0 | otherwise = Nothing -- | Gets the elements and separators from a list. The first separator is zipped to the second element. -- To the first element, the "" string is zipped. zipWithSeparators :: AnnList e dom -> [(String, Ann e dom SrcTemplateStage)] -zipWithSeparators (AnnListG (NodeInfo _ src) elems) - | [] <- src ^. srcTmpSeparators +zipWithSeparators (AnnListG (NodeInfo _ src) elems) + | [] <- src ^. srcTmpSeparators = zip ("" : repeat (src ^. srcTmpDefaultSeparator)) elems - | otherwise + | otherwise = zip ("" : seps ++ repeat (last seps)) elems where seps = src ^. srcTmpSeparators diff --git a/Language/Haskell/Tools/Refactor/Perform.hs b/Language/Haskell/Tools/Refactor/Perform.hs --- a/Language/Haskell/Tools/Refactor/Perform.hs +++ b/Language/Haskell/Tools/Refactor/Perform.hs @@ -29,15 +29,15 @@ import GHC -- | 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) +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 ProjectOrganizeImports = projectOrganizeImports - selectCommand GenerateExports = localRefactoring generateExports + selectCommand ProjectOrganizeImports = projectOrganizeImports + selectCommand GenerateExports = localRefactoring generateExports selectCommand (GenerateSignature sp) = localRefactoring $ generateTypeSignature' (correctRefactorSpan (snd mod) sp) selectCommand (RenameDefinition sp str) = renameDefinition' (correctRefactorSpan (snd mod) sp) str selectCommand (ExtractBinding sp str) = localRefactoring $ extractBinding' (correctRefactorSpan (snd mod) sp) str @@ -45,7 +45,7 @@ selectCommand (FloatOut sp) = localRefactoring $ floatOut (correctRefactorSpan (snd mod) sp) -- | A refactoring command -data RefactorCommand = NoRefactor +data RefactorCommand = NoRefactor | OrganizeImports | ProjectOrganizeImports | GenerateExports @@ -57,21 +57,31 @@ deriving Show -- | Recognize a command from its textual representation -readCommand :: String -> RefactorCommand +readCommand :: String -> Either String RefactorCommand readCommand (splitOn " " -> refact:args) = analyzeCommand refact args readCommand _ = error "panic: splitOn resulted empty" -- | Check the parts and return the command -analyzeCommand :: String -> [String] -> RefactorCommand -analyzeCommand "" _ = NoRefactor -analyzeCommand "CheckSource" _ = NoRefactor -analyzeCommand "OrganizeImports" _ = OrganizeImports -analyzeCommand "ProjectOrganizeImports" _ = ProjectOrganizeImports -analyzeCommand "GenerateExports" _ = GenerateExports -analyzeCommand "GenerateSignature" [sp] = GenerateSignature (readSrcSpan sp) -analyzeCommand "RenameDefinition" [sp, newName] = RenameDefinition (readSrcSpan sp) newName -analyzeCommand "ExtractBinding" [sp, newName] = ExtractBinding (readSrcSpan sp) newName -analyzeCommand "InlineBinding" [sp] = InlineBinding (readSrcSpan sp) -analyzeCommand "FloatOut" [sp] = FloatOut (readSrcSpan sp) -analyzeCommand ref _ = error $ "Unknown command: " ++ ref +analyzeCommand :: String -> [String] -> Either String RefactorCommand +analyzeCommand "" _ = Right NoRefactor +analyzeCommand "CheckSource" _ = Right NoRefactor +analyzeCommand "OrganizeImports" _ = Right OrganizeImports +analyzeCommand "ProjectOrganizeImports" _ = Right ProjectOrganizeImports +analyzeCommand "GenerateExports" _ = Right GenerateExports +analyzeCommand "GenerateSignature" [sp] = Right $ GenerateSignature (readSrcSpan sp) +analyzeCommand "GenerateSignature" _ = Left $ "GenerateSignature needs one argument: the source range of the definition" +analyzeCommand "RenameDefinition" [sp, newName] = Right $ RenameDefinition (readSrcSpan sp) newName +analyzeCommand "RenameDefinition" _ = Left $ "RenameDefinition needs two arguments: the source range of the name and the new name" +analyzeCommand "ExtractBinding" [sp, newName] = Right $ ExtractBinding (readSrcSpan sp) newName +analyzeCommand "ExtractBinding" _ = Left $ "RenameDefinition needs two arguments: the source range of the expression and the new name" +analyzeCommand "InlineBinding" [sp] = Right $ InlineBinding (readSrcSpan sp) +analyzeCommand "InlineBinding" _ = Left $ "InlineBinding needs one argument: the source range of the definition" +analyzeCommand "FloatOut" [sp] = Right $ FloatOut (readSrcSpan sp) +analyzeCommand "FloatOut" _ = Left $ "FloatOut needs one argument: the source range of the definition" +analyzeCommand ref _ = Left $ "Unknown command: " ++ ref +refactorCommands :: [String] +refactorCommands + = [ "CheckSource", "OrganizeImports", "ProjectOrganizeImports", "GenerateExports" + , "GenerateSignature", "RenameDefinition", "ExtractBinding", "InlineBinding" + , "FloatOut" ] diff --git a/Language/Haskell/Tools/Refactor/Predefined/DollarApp1.hs b/Language/Haskell/Tools/Refactor/Predefined/DollarApp1.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Predefined/DollarApp1.hs @@ -0,0 +1,16 @@ +module Language.Haskell.Tools.Refactor.Predefined.DollarApp1 where + +import Language.Haskell.Tools.Refactor + +import Control.Reference +import SrcLoc (RealSrcSpan) + +tryItOut :: String -> String -> IO () +tryItOut = tryRefactor (localRefactoring . dollarApp) + +dollarApp :: Domain dom => RealSrcSpan -> LocalRefactoring dom +dollarApp sp = return . (nodesContained sp .- replaceExpr) + +replaceExpr :: Expr dom -> Expr dom +replaceExpr (App fun (Paren arg)) = mkInfixApp fun (mkUnqualOp "$") arg +replaceExpr e = e diff --git a/Language/Haskell/Tools/Refactor/Predefined/DollarApp2.hs b/Language/Haskell/Tools/Refactor/Predefined/DollarApp2.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Predefined/DollarApp2.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE FlexibleContexts #-} +module Language.Haskell.Tools.Refactor.Predefined.DollarApp2 where + +import Language.Haskell.Tools.Refactor + +import Control.Reference +import SrcLoc (RealSrcSpan) +import Unique (getUnique) +import Id (idName) +import PrelNames (dollarIdKey) +import PrelInfo (wiredInIds) + +tryItOut :: String -> String -> IO () +tryItOut = tryRefactor (localRefactoring . dollarApp) + +dollarApp :: (HasImportInfo dom, HasModuleInfo dom) => RealSrcSpan -> LocalRefactoring dom +dollarApp sp = nodesContained sp !~ replaceExpr + +replaceExpr :: (HasImportInfo dom, HasModuleInfo dom) => Expr dom -> LocalRefactor dom (Expr dom) +replaceExpr (App fun (Paren arg)) = mkInfixApp fun <$> referenceOperator dollarName <*> pure arg +replaceExpr e = pure e + +[dollarName] = map idName $ filter ((dollarIdKey==) . getUnique) wiredInIds diff --git a/Language/Haskell/Tools/Refactor/Predefined/DollarApp3.hs b/Language/Haskell/Tools/Refactor/Predefined/DollarApp3.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Predefined/DollarApp3.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE ViewPatterns, FlexibleContexts, ConstraintKinds #-} +module Language.Haskell.Tools.Refactor.Predefined.DollarApp3 where + +import Language.Haskell.Tools.Refactor + +import BasicTypes (Fixity(..)) +import Id (idName) +import qualified Name as GHC (Name) +import PrelInfo (wiredInIds) +import PrelNames (dollarIdKey) +import SrcLoc (RealSrcSpan, SrcSpan) +import Unique (getUnique) + +import Control.Monad.State +import Control.Reference ((^.), (!~), biplateRef) + +tryItOut :: String -> String -> IO () +tryItOut = tryRefactor (localRefactoring . dollarApp) + +type DollarMonad dom = StateT [SrcSpan] (LocalRefactor dom) +type DollarDomain dom = (HasImportInfo dom, HasModuleInfo dom, HasFixityInfo dom, HasNameInfo dom) + +dollarApp :: DollarDomain dom => RealSrcSpan -> LocalRefactoring dom +dollarApp sp = flip evalStateT [] . ((nodesContained sp !~ (\e -> get >>= replaceExpr e)) + >=> (biplateRef !~ parenExpr)) + +replaceExpr :: DollarDomain dom => Expr dom -> [SrcSpan] -> DollarMonad dom (Expr dom) +replaceExpr (App fun (Paren arg)) _ = do modify $ (getRange arg :) + mkInfixApp fun <$> lift (referenceOperator dollarName) <*> pure arg +replaceExpr e _ = return e + +parenExpr :: Expr dom -> DollarMonad dom (Expr dom) +parenExpr e = (exprLhs !~ parenDollar True) =<< (exprRhs !~ parenDollar False $ e) + +parenDollar :: Bool -> Expr dom -> DollarMonad dom (Expr dom) +parenDollar lhs expr@(InfixApp _ _ arg) + = do replacedRanges <- get + if getRange arg `elem` replacedRanges && (lhs || getRange expr `notElem` replacedRanges) + then return $ mkParen expr + else return expr +parenDollar _ e = return e + +dollarName :: GHC.Name +[dollarName] = map idName $ filter ((dollarIdKey==) . getUnique) wiredInIds diff --git a/Language/Haskell/Tools/Refactor/Predefined/ExtractBinding.hs b/Language/Haskell/Tools/Refactor/Predefined/ExtractBinding.hs --- a/Language/Haskell/Tools/Refactor/Predefined/ExtractBinding.hs +++ b/Language/Haskell/Tools/Refactor/Predefined/ExtractBinding.hs @@ -6,6 +6,7 @@ , TypeApplications , ConstraintKinds , TypeFamilies + , MultiWayIf #-} module Language.Haskell.Tools.Refactor.Predefined.ExtractBinding (extractBinding', ExtractBindingDomain, tryItOut) where @@ -20,7 +21,7 @@ import Control.Monad.State import Control.Reference import Data.Generics.Uniplate.Data () -import Data.List (find) +import Data.List (find, intersperse) import Data.Maybe import Language.Haskell.Tools.Refactor @@ -34,27 +35,35 @@ extractBinding' :: ExtractBindingDomain dom => RealSrcSpan -> String -> LocalRefactoring dom extractBinding' sp name mod - = if isValidBindingName name then extractBinding sp (nodesContaining sp) (nodesContaining sp) name mod - else refactError "The given name is not a valid for the extracted binding" + = if isNothing (isValidBindingName name) + then extractBinding sp (nodesContaining sp) (nodesContaining sp) name mod + else refactError $ "The given name is not a valid for the extracted binding: " ++ fromJust (isValidBindingName name) -- | Safely performs the transformation to introduce the local binding and replace the expression with the call. -- Checks if the introduction of the name causes a name conflict. -extractBinding :: forall dom . ExtractBindingDomain dom +extractBinding :: forall dom . ExtractBindingDomain dom => RealSrcSpan -> Simple Traversal (Module dom) (ValueBind dom) -> Simple Traversal (ValueBind dom) (Expr dom) -> String -> LocalRefactoring dom extractBinding sp selectDecl selectExpr name mod - = let conflicting = any (isConflicting name) (mod ^? selectDecl & biplateRef :: [QualifiedName dom]) + = let conflicting = filter (isConflicting name) ((take 1 $ reverse $ mod ^? selectDecl) ^? biplateRef :: [QualifiedName dom]) exprRanges = map getRange (mod ^? selectDecl & selectExpr) decl = last (mod ^? selectDecl) - in case exprRanges of - exprRange:_ -> - if conflicting - then refactError "The given name causes name conflict." - else do (res, st) <- runStateT (selectDecl&selectExpr !~ extractThatBind sp name (head $ decl ^? actualContainingExpr exprRange) $ mod) Nothing - case st of Just def -> return $ evalState (selectDecl !~ addLocalBinding exprRange def $ res) False - Nothing -> refactError "There is no applicable expression to extract." + declPats = decl ^? valBindPat &+& funBindMatches & annList & matchLhs + & (matchLhsArgs & annList &+& matchLhsLhs &+& matchLhsRhs &+& matchLhsArgs & annList) + in case exprRanges of + exprRange:_ -> + if | not (null conflicting) + -> refactError $ "The given name causes name conflict with the definition(s) at: " ++ concat (intersperse "," (map (shortShowSpan . getRange) conflicting)) + | any (`containsRange` exprRange) $ map getRange declPats + -> refactError "Extract binding cannot be applied to view pattern expressions." + | otherwise + -> do (res, st) <- runStateT (selectDecl&selectExpr !~ extractThatBind sp name (head $ decl ^? actualContainingExpr exprRange) $ mod) Nothing + case st of Just def -> return $ evalState (selectDecl !~ addLocalBinding exprRange def $ res) False + Nothing -> refactError "There is no applicable expression to extract." [] -> refactError "There is no applicable expression to extract." + where RealSrcSpan sp1 `containsRange` RealSrcSpan sp2 = sp1 `containsSpan` sp2 + _ `containsRange` _ = False -- | Decides if a new name defined to be the given string will conflict with the given AST element isConflicting :: ExtractBindingDomain dom => String -> QualifiedName dom -> Bool @@ -63,11 +72,11 @@ && (GHC.occNameString . GHC.getOccName <$> semanticsName used) == Just name -- Replaces the selected expression with a call and generates the called binding. -extractThatBind :: ExtractBindingDomain dom +extractThatBind :: ExtractBindingDomain dom => RealSrcSpan -> String -> Expr dom -> Expr dom -> StateT (Maybe (ValueBind dom)) (LocalRefactor dom) (Expr dom) -extractThatBind sp name cont e - = do ret <- get -- being in a state monad to only apply the - if (isJust ret) then return e +extractThatBind sp name cont e + = do ret <- get -- being in a state monad to only apply the + if (isJust ret) then return e else case e of -- only the expression inside the parameters should be extracted Paren {} | hasParameter -> exprInner !~ doExtract name cont $ e @@ -93,14 +102,14 @@ && lName == rName && isKnownCommutativeOp lName -> do let params = getExternalBinds cont mid ++ opName rop ++ getExternalBinds cont rhs put (Just (generateBind name (map mkVarPat params) (mkInfixApp mid rop rhs))) - return (mkInfixApp lhs lop (generateCall name params)) + return (mkInfixApp lhs lop (generateCall name params)) InfixApp lhs lop (InfixApp mid rop rhs) -- correction for right-associative operators | (Just lName, Just rName) <- (semanticsName (lop ^. operatorName), semanticsName (rop ^. operatorName)) , (sp `encloses` lhs) && (sp `encloses` mid) && (rop `outside` sp) && lName == rName && isKnownCommutativeOp lName -> do let params = getExternalBinds cont lhs ++ opName lop ++ getExternalBinds cont mid put (Just (generateBind name (map mkVarPat params) (mkInfixApp lhs lop mid))) - return (mkInfixApp (generateCall name params) rop rhs) + return (mkInfixApp (generateCall name params) rop rhs) -- normal case el | isParenLikeExpr el && hasParameter -> mkParen <$> doExtract name cont e | otherwise -> doExtract name cont e @@ -109,28 +118,28 @@ sp `encloses` elem = case getRange elem of RealSrcSpan enc -> sp `containsSpan` enc _ -> False -- True if the elem is completely outside the given range (no overlapping) - elem `outside` sp = case getRange elem of RealSrcSpan out -> realSrcSpanStart sp > realSrcSpanEnd out + elem `outside` sp = case getRange elem of RealSrcSpan out -> realSrcSpanStart sp > realSrcSpanEnd out || realSrcSpanEnd sp < realSrcSpanStart out _ -> False - opName op = case semanticsName (op ^. operatorName) of + opName op = case semanticsName (op ^. operatorName) of Nothing -> [] Just n -> [mkUnqualName' n | not $ n `inScope` semanticsScope cont] isKnownCommutativeOp :: GHC.Name -> Bool - isKnownCommutativeOp n = isJust $ find (maybe False (\(mn, occ) -> (nameModule_maybe n) == Just mn && occName n == occ) . isOrig_maybe) ops + isKnownCommutativeOp n = isJust $ find (maybe False (\(mn, occ) -> (nameModule_maybe n) == Just mn && occName n == occ) . isOrig_maybe) ops where ops = [plus_RDR, times_RDR, append_RDR, and_RDR, {- or_RDR, -} compose_RDR] -- somehow or is missing... WHY? -- | Adds a local binding to the where clause of the enclosing binding addLocalBinding :: SrcSpan -> ValueBind dom -> ValueBind dom -> State Bool (ValueBind dom) -- this uses the state monad to only add the local binding to the first selected element -addLocalBinding exprRange local bind +addLocalBinding exprRange local bind = do done <- get if not done then do put True return $ indentBody $ doAddBinding exprRange local bind - else return bind + else return bind where doAddBinding _ local sb@(SimpleBind {}) = valBindLocals .- insertLocalBind local $ sb - doAddBinding (RealSrcSpan rng) local fb@(FunctionBind {}) - = funBindMatches & annList & filtered (isInside rng) & matchBinds + doAddBinding (RealSrcSpan rng) local fb@(FunctionBind {}) + = funBindMatches & annList & filtered (isInside rng) & matchBinds .- insertLocalBind local $ fb doAddBinding _ _ _ = error "doAddBinding: invalid expression range" @@ -141,9 +150,9 @@ -- | Puts a value definition into a list of local binds insertLocalBind :: ValueBind dom -> MaybeLocalBinds dom -> MaybeLocalBinds dom -insertLocalBind toInsert locals +insertLocalBind toInsert locals | isAnnNothing locals = mkLocalBinds [mkLocalValBind toInsert] - | otherwise = annJust & localBinds .- insertWhere (mkLocalValBind toInsert) (const True) isNothing $ locals + | otherwise = annJust & localBinds .- insertWhere True (mkLocalValBind toInsert) (const True) isNothing $ locals -- | All expressions that are bound stronger than function application. isParenLikeExpr :: Expr dom -> Bool @@ -165,13 +174,13 @@ isParenLikeExpr _ = False -- | Replaces the expression with the call and stores the binding of the call in its state -doExtract :: ExtractBindingDomain dom +doExtract :: ExtractBindingDomain dom => String -> Expr dom -> Expr dom -> StateT (Maybe (ValueBind dom)) (LocalRefactor dom) (Expr dom) doExtract name cont e@(Lambda (AnnList bindings) inner) = do let params = getExternalBinds cont e put (Just (generateBind name (map mkVarPat params ++ bindings) inner)) return (generateCall name params) -doExtract name cont e +doExtract name cont e = do let params = getExternalBinds cont e put (Just (generateBind name (map mkVarPat params) e)) return (generateCall name params) @@ -189,8 +198,8 @@ exprToName :: Expr dom -> Name dom exprToName e | Just n <- e ^? exprName = n | Just op <- e ^? exprOperator & operatorName = mkParenName op - | otherwise = error "exprToName: name not found" - + | otherwise = error "exprToName: name not found" + notInScopeForExtracted :: GHC.Name -> Bool notInScopeForExtracted n = not $ n `inScope` semanticsScope cont @@ -217,5 +226,5 @@ generateBind name [] e = mkSimpleBind (mkVarPat $ mkNormalName $ mkSimpleName name) (mkUnguardedRhs e) Nothing generateBind name args e = mkFunctionBind [mkMatch (mkMatchLhs (mkNormalName $ mkSimpleName name) args) (mkUnguardedRhs e) Nothing] -isValidBindingName :: String -> Bool +isValidBindingName :: String -> Maybe String isValidBindingName = nameValid Variable diff --git a/Language/Haskell/Tools/Refactor/Predefined/FloatOut.hs b/Language/Haskell/Tools/Refactor/Predefined/FloatOut.hs --- a/Language/Haskell/Tools/Refactor/Predefined/FloatOut.hs +++ b/Language/Haskell/Tools/Refactor/Predefined/FloatOut.hs @@ -21,9 +21,9 @@ type FloatOutDefinition dom = (HasNameInfo dom, HasScopeInfo dom) floatOut :: FloatOutDefinition dom => RealSrcSpan -> LocalRefactoring dom -floatOut sp mod +floatOut sp mod = do (mod', st) <- runStateT (nodesContaining sp !~ extractAndInsert sp $ mod) NotEncountered - case st of NotEncountered -> refactError "No definition is selected." + case st of NotEncountered -> refactError "No definition is selected. The selection range must be inside the definition." Extracted bnds -> -- insert it to the global definition list return $ modDecl & annListElems .- (++ map toTopLevel bnds) $ removeEmpties mod' Inserted -> -- already inserted to a local scope @@ -38,9 +38,9 @@ data FloatState dom = NotEncountered | Extracted [LocalBind dom] | Inserted extractAndInsert :: FloatOutDefinition dom => RealSrcSpan -> LocalBindList dom -> StateT (FloatState dom) (LocalRefactor dom) (LocalBindList dom) -extractAndInsert sp locs +extractAndInsert sp locs | hasSharedSig = refactError "Cannot float out a definition, since it has a signature shared with other bindings that stay in the scope." - | not (null nameConflicts) = refactError $ "Cannot float out a definition, since it would cause a name conflicts in the target scope: " + | not (null nameConflicts) = refactError $ "Cannot float out a definition, since it would cause a name conflicts in the target scope: " ++ concat (intersperse ", " nameConflicts) | not (null implicitConflicts) = refactError $ "Cannot float out a definition, since it uses the implicit parameters: " ++ concat (intersperse ", " implicitConflicts) @@ -49,7 +49,7 @@ Inserted -> return locs where selected = locs ^? annList & filtered (isInside sp) floated = normalizeElements $ selected ++ (locs ^? annList & filtered (nameIsSelected . (^? elementName))) - where nameIsSelected [n] = n `elem` concatMap (^? elementName) selected + where nameIsSelected [n] = n `elem` concatMap (^? elementName) selected nameIsSelected _ = False filteredLocs = filterList (\e -> not (getRange e `elem` floatedElemRanges)) locs @@ -64,13 +64,13 @@ checkConflict bnd = (concatMap @[] getConflict bndNames, implicits) where bndNames = bnd ^? elementName getConflict bndName = filter ((== nameStr) . Just) $ map (occNameString . getOccName) outerScope - where outerScope = concat $ take 1 $ drop 2 $ semanticsScope bndName + where outerScope = concat $ take 1 $ drop 2 $ semanticsScope bndName nameStr = fmap (occNameString . getOccName) $ semanticsName bndName - implicits = map (occNameString . getOccName) + implicits = map (occNameString . getOccName) (concatMap getPossibleImplicits bndNames `intersect` getQNames (bnd ^? biplateRef)) - + getQNames :: [QualifiedName dom] -> [GHC.Name] getQNames = catMaybes . map semanticsName getPossibleImplicits :: QualifiedName dom -> [GHC.Name] - getPossibleImplicits qn = concat (take 2 $ semanticsScope qn) \\ catMaybes (map semanticsName bndNames) + getPossibleImplicits qn = concat (take 2 $ semanticsScope qn) \\ catMaybes (map semanticsName bndNames) diff --git a/Language/Haskell/Tools/Refactor/Predefined/GenerateTypeSignature.hs b/Language/Haskell/Tools/Refactor/Predefined/GenerateTypeSignature.hs --- a/Language/Haskell/Tools/Refactor/Predefined/GenerateTypeSignature.hs +++ b/Language/Haskell/Tools/Refactor/Predefined/GenerateTypeSignature.hs @@ -1,13 +1,13 @@ {-# LANGUAGE ViewPatterns , FlexibleContexts , ScopedTypeVariables - , RankNTypes + , RankNTypes , TypeApplications , TypeFamilies , ConstraintKinds , TupleSections #-} -module Language.Haskell.Tools.Refactor.Predefined.GenerateTypeSignature +module Language.Haskell.Tools.Refactor.Predefined.GenerateTypeSignature (generateTypeSignature, generateTypeSignature', GenerateSignatureDomain, tryItOut) where import GHC hiding (Module) @@ -27,49 +27,49 @@ import Language.Haskell.Tools.Refactor as AST -type GenerateSignatureDomain dom = ( HasModuleInfo dom, HasIdInfo dom, HasImportInfo dom, HasScopeInfo dom ) +type GenerateSignatureDomain dom = ( HasModuleInfo dom, HasIdInfo dom, HasImportInfo dom, HasScopeInfo dom ) tryItOut :: String -> String -> IO () tryItOut = tryRefactor (localRefactoring . generateTypeSignature') generateTypeSignature' :: GenerateSignatureDomain dom => RealSrcSpan -> LocalRefactoring dom -generateTypeSignature' sp = generateTypeSignature (nodesContaining sp) (nodesContaining sp) (getValBindInList sp) +generateTypeSignature' sp = generateTypeSignature (nodesContaining sp) (nodesContaining sp) (getValBindInList sp) -- | Perform the refactoring on either local or top-level definition -generateTypeSignature :: GenerateSignatureDomain dom => Simple Traversal (Module dom) (DeclList dom) +generateTypeSignature :: GenerateSignatureDomain dom => Simple Traversal (Module dom) (DeclList dom) -- ^ Access for a top-level definition if it is the selected definition - -> Simple Traversal (Module dom) (LocalBindList dom) + -> Simple Traversal (Module dom) (LocalBindList dom) -- ^ Access for a definition list if it contains the selected definition - -> (forall d . (BindingElem d) => AnnList d dom -> Maybe (ValueBind dom)) + -> (forall d . (BindingElem d) => AnnList d dom -> Maybe (ValueBind dom)) -- ^ Selector for either local or top-level declaration in the definition list -> LocalRefactoring dom generateTypeSignature topLevelRef localRef vbAccess mod = let typeSigs = universeBi mod bindings = universeBi mod findTypeSigFor id = find (\ts -> any (id ==) $ map semanticsId (ts ^? tsName & annList & simpleName)) - bindsWithSigs = catMaybes $ concatMap (\b -> map (\n -> let id = semanticsId n in fmap (id,,b) (findTypeSigFor id typeSigs)) (b ^? bindingName)) bindings + bindsWithSigs = catMaybes $ concatMap (\b -> map (\n -> let id = semanticsId n in fmap (id,,b) (findTypeSigFor id typeSigs)) (b ^? bindingName)) bindings scopedSigs = hasScopedTypeSignatures mod in flip evalStateT False . (topLevelRef !~ genTypeSig scopedSigs bindsWithSigs vbAccess <=< localRef !~ genTypeSig scopedSigs bindsWithSigs vbAccess) $ mod - + hasScopedTypeSignatures :: Module dom -> Bool hasScopedTypeSignatures mod = "ScopedTypeVariables" `elem` (mod ^? filePragmas & annList & lpPragmas & annList & langExt :: [String]) -genTypeSig :: forall dom d . (GenerateSignatureDomain dom, BindingElem d) => Bool -> [(GHC.Var, TypeSignature dom, ValueBind dom)] -> (AnnList d dom -> Maybe (ValueBind dom)) +genTypeSig :: forall dom d . (GenerateSignatureDomain dom, BindingElem d) => Bool -> [(GHC.Var, TypeSignature dom, ValueBind dom)] -> (AnnList d dom -> Maybe (ValueBind dom)) -> AnnList d dom -> StateT Bool (LocalRefactor dom) (AnnList d dom) -genTypeSig scopedSigs sigBinds vbAccess ls - | Just vb <- vbAccess ls +genTypeSig scopedSigs sigBinds vbAccess ls + | Just vb <- vbAccess ls , not (typeSignatureAlreadyExist ls vb) - = if isSimpleBinding vb - then + = if isSimpleBinding vb + then do let id = getBindingName vb - isTheBind (Just decl) + isTheBind (Just decl) = isBinding decl && map semanticsId (decl ^? elementName) == map semanticsId (vb ^? bindingName) isTheBind _ = False - + alreadyGenerated <- get - if alreadyGenerated + if alreadyGenerated then return ls else do put True -- checking for possible situations when we cannot generate signature because of @@ -77,12 +77,12 @@ let dangerousTypeVars = dangerousTVs scopedSigs sigBinds myTvs = concatMap @[] (getExternalTVs . idType . semanticsId) (vb ^? bindingName) if not $ null @[] $ myTvs `intersect` dangerousTypeVars - then refactError $ "Could not generate type signature: the type variable(s) " - ++ concat (intersperse ", " $ map (showSDocUnsafe . ppr) (myTvs `intersect` dangerousTypeVars)) + then refactError $ "Could not generate type signature: the type variable(s) " + ++ concat (intersperse ", " $ map (showSDocUnsafe . ppr) (myTvs `intersect` dangerousTypeVars)) ++ " cannot be captured. (Use ScopedTypeVariables and forall-ed type signatures)" - else do + else do typeSig <- lift $ generateTSFor (getName id) (idType id) - return $ insertWhere (createTypeSig typeSig) (const True) isTheBind ls + return $ insertWhere True (createTypeSig typeSig) (const True) isTheBind ls else refactError "Signature can only be generated for simple value bindings." | otherwise = return ls where isSimpleBinding vb = case vb of SimpleBind (AST.VarPat {}) _ _ -> True @@ -97,13 +97,13 @@ generateTSFor n t = mkTypeSignature (mkUnqualName' n) <$> generateTypeFor (-1) (dropForAlls t) -- | Generates the source-level type for a GHC internal type -generateTypeFor :: GenerateSignatureDomain dom => Int -> GHC.Type -> LocalRefactor dom (AST.Type dom) -generateTypeFor prec t +generateTypeFor :: GenerateSignatureDomain dom => Int -> GHC.Type -> LocalRefactor dom (AST.Type dom) +generateTypeFor prec t -- context | (break (not . isPredTy) -> (preds, other), rt) <- splitFunTys t , not (null preds) - = do ctx <- case preds of [pred] -> mkContextOne <$> generateAssertionFor pred - _ -> mkContextMulti <$> mapM generateAssertionFor preds + = do ctx <- case preds of [pred] -> mkContext <$> generateAssertionFor pred + _ -> mkContext <$> (mkTupleAssertion <$> mapM generateAssertionFor preds) wrapParen 0 <$> (mkCtxType ctx <$> generateTypeFor 0 (mkFunTys other rt)) -- function | Just (at, rt) <- splitFunTy_maybe t @@ -147,19 +147,18 @@ getTCId tc = GHC.mkVanillaGlobal (GHC.tyConName tc) (tyConKind tc) generateAssertionFor :: GenerateSignatureDomain dom => GHC.Type -> LocalRefactor dom (Assertion dom) - generateAssertionFor t + generateAssertionFor t | Just (tc, types) <- splitTyConApp_maybe t = mkClassAssert <$> referenceName (idName $ getTCId tc) <*> mapM (generateTypeFor 0) types | otherwise = error "generateAssertionFor: type not supported yet." - -- TODO: infix things - + -- | Check whether the definition already has a type signature typeSignatureAlreadyExist :: (GenerateSignatureDomain dom, BindingElem d) => AnnList d dom -> ValueBind dom -> Bool -typeSignatureAlreadyExist ls vb = +typeSignatureAlreadyExist ls vb = getBindingName vb `elem` (map semanticsId $ concatMap (^? elementName) (filter isTypeSig $ ls ^? annList)) - + getBindingName :: GenerateSignatureDomain dom => ValueBind dom -> GHC.Id -getBindingName vb = case nub $ map semanticsId $ vb ^? bindingName of +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" @@ -174,4 +173,4 @@ | otherwise = [] isForalledTS :: TypeSignature dom -> Bool -isForalledTS ts = not $ null @[] $ ts ^? tsType & typeBounded & annList +isForalledTS ts = not $ null @[] $ ts ^? tsType & typeBounded & annList diff --git a/Language/Haskell/Tools/Refactor/Predefined/HelloRefactor.hs b/Language/Haskell/Tools/Refactor/Predefined/HelloRefactor.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Predefined/HelloRefactor.hs @@ -0,0 +1,17 @@ +module Language.Haskell.Tools.Refactor.Predefined.HelloRefactor where + +import Language.Haskell.Tools.PrettyPrint (prettyPrint) +import Language.Haskell.Tools.Refactor + +import Control.Reference +import Debug.Trace (trace) +import SrcLoc (RealSrcSpan) + +tryItOut :: String -> String -> IO () +tryItOut = tryRefactor (localRefactoring . helloRefactor) + +helloRefactor :: Domain dom => RealSrcSpan -> LocalRefactoring dom +helloRefactor sp = return . (nodesContained sp .- helloExpr) + +helloExpr :: Expr dom -> Expr dom +helloExpr e = trace ("\n### Hello: " ++ prettyPrint e) $ e diff --git a/Language/Haskell/Tools/Refactor/Predefined/OrganizeImports.hs b/Language/Haskell/Tools/Refactor/Predefined/OrganizeImports.hs --- a/Language/Haskell/Tools/Refactor/Predefined/OrganizeImports.hs +++ b/Language/Haskell/Tools/Refactor/Predefined/OrganizeImports.hs @@ -1,14 +1,15 @@ -{-# LANGUAGE LambdaCase +{-# LANGUAGE LambdaCase , ScopedTypeVariables , FlexibleContexts , TypeFamilies , ConstraintKinds , TupleSections + , TypeApplications #-} module Language.Haskell.Tools.Refactor.Predefined.OrganizeImports (organizeImports, OrganizeImportsDomain, projectOrganizeImports) where import ConLike (ConLike(..)) -import DataCon (FieldLbl(..), dataConTyCon) +import DataCon (dataConTyCon) import DynFlags (xopt) import FamInstEnv (FamInst(..)) import GHC (TyThing(..), lookupName) @@ -18,11 +19,12 @@ import InstEnv (ClsInst(..)) import Language.Haskell.TH.LanguageExtensions as GHC (Extension(..)) import Name (NamedThing(..)) -import TyCon (tyConFieldLabels, tyConDataCons, isClassTyCon) +import OccName (HasOccName(..), isSymOcc) +import qualified PrelNames as GHC (fromStringName) +import TyCon (TyCon(..), tyConFamInst_maybe) import Control.Applicative ((<$>), Alternative(..)) import Control.Monad -import Control.Monad.Trans (MonadTrans(..)) import Control.Reference hiding (element) import Data.Function hiding ((&)) import Data.Generics.Uniplate.Data (universeBi) @@ -39,23 +41,49 @@ organizeImports :: forall dom . OrganizeImportsDomain dom => LocalRefactoring dom organizeImports mod - = do ms <- lift $ GHC.getModSummary (GHC.moduleName $ semanticsModule mod) - let noNarrowingImports = xopt TemplateHaskell (GHC.ms_hspp_opts ms) - noNarrowingSubspecs = xopt GHC.StandaloneDeriving (GHC.ms_hspp_opts ms) - if noNarrowingImports - then -- don't change the imports for template haskell modules - -- (we don't know what definitions the generated code will use) - return $ modImports .- sortImports $ mod - else modImports !~ narrowImports noNarrowingSubspecs exportedModules usedNames prelInstances prelFamInsts . sortImports $ mod + = do usedTyThings <- catMaybes <$> mapM lookupName usedNames + let dfs = semanticsDynFlags mod + noNarrowingImports + = xopt TemplateHaskell dfs -- no narrowing if TH is present (we don't know what will be used) + || xopt QuasiQuotes dfs -- no narrowing if TH quotes are present (we don't know what will be used) + || (xopt FlexibleInstances dfs && noNarrowingSubspecs) -- arbitrary ctors might be needed when using imported data families + noNarrowingSubspecs + = -- both standalone deriving and FFI marshalling can cause constructors to be used in the generated code + xopt GHC.StandaloneDeriving dfs || hasMarshalling + -- while pattern synonyms are not handled correctly, we disable subspec narrowing to be safe + || patternSynonymAreUsed usedTyThings + if noNarrowingImports + then -- we don't know what definitions the generated code will use + return $ modImports .- sortImports $ mod + else modImports !~ narrowImports noNarrowingSubspecs exportedModules (addFromString dfs usedNames) exportedNames prelInstances prelFamInsts . sortImports $ mod where prelInstances = semanticsPrelOrphanInsts mod prelFamInsts = semanticsPrelFamInsts mod + addFromString dfs = if xopt OverloadedStrings dfs then (GHC.fromStringName :) else id usedNames = map getName $ catMaybes $ map semanticsName -- obviously we don't want the names in the imports to be considered, but both from -- the declarations (used), both from the module head (re-exported) will count as usage $ (universeBi (mod ^. modHead) ++ universeBi (mod ^. modDecl) :: [QualifiedName dom]) - exportedModules = mod ^? modHead & annJust & mhExports & annJust - & espExports & annList & exportModuleName & moduleNameString - + -- Prelude is not actually exported, but we don't want to remove it if it is explicitly there + -- otherwise, we might add new imported elements that cause conflicts. + exportedModules = "Prelude" : (mod ^? modHead & annJust & mhExports & annJust + & espExports & annList & exportModuleName & moduleNameString) + + -- Exported definitions must be kept imported + exports = mod ^? modHead & annJust & mhExports & annJust & espExports & annList & exportDecl + exportedNames = catMaybes $ map getExported exports + getExported e = fmap (,hasChild) name + where name = semanticsName (e ^. ieName & simpleName) + hasChild = (case e ^? ieSubspec & annJust of Just SubAll -> True; _ -> False) + || not (null @[] (e ^? ieSubspec & annJust & essList & annList)) + + -- Checks if the module uses foreign import/export that requires marshalling. In this case no + -- subspecifiers could be narrowed because constructors might be needed. + hasMarshalling = not $ null @[] (mod ^? modDecl & annList & declForeignType) + + -- Can this name be part of the source code? + -- isSourceName n = ':' `notElem` occNameString (occName n) + patternSynonymAreUsed tts = any (\case AConLike (PatSynCon _) -> True; _ -> False) tts + -- | Sorts the imports in alphabetical order sortImports :: forall dom . ImportDeclList dom -> ImportDeclList dom sortImports ls = srcInfo & srcTmpSeparators .= filter (not . null) (concatMap (\(sep,elems) -> sep : map fst elems) reordered) @@ -65,10 +93,10 @@ reordered = map (_2 .- sortBy (compare `on` (^. _2 & importModule & AST.moduleNameString))) parts parts = map (_2 .- reverse) $ reverse $ breakApart [] imports - + breakApart :: [(String, [(String, ImportDecl dom)])] -> [(String, ImportDecl dom)] -> [(String, [(String, ImportDecl dom)])] breakApart res [] = res - breakApart res ((sep, e) : rest) | length (filter ('\n' ==) sep) > 1 + breakApart res ((sep, e) : rest) | length (filter ('\n' ==) sep) > 1 = breakApart ((sep, [("",e)]) : res) rest breakApart ((lastSep, lastRes) : res) (elem : rest) = breakApart ((lastSep, elem : lastRes) : res) rest @@ -78,53 +106,65 @@ imports = zipWithSeparators ls -- | Modify an import to only import names that are used. -narrowImports :: forall dom . OrganizeImportsDomain dom - => Bool -> [String] -> [GHC.Name] -> [ClsInst] -> [FamInst] -> ImportDeclList dom -> LocalRefactor dom (ImportDeclList dom) -narrowImports noNarrowSubspecs exportedModules usedNames prelInsts prelFamInsts imps - = annListElems & traversal !~ narrowImport noNarrowSubspecs exportedModules usedNames - $ filterListIndexed (\i _ -> neededImps !! i) imps - where neededImps = neededImports exportedModules usedNames prelInsts prelFamInsts (imps ^. annListElems) +narrowImports :: forall dom . OrganizeImportsDomain dom + => Bool -> [String] -> [GHC.Name] -> [(GHC.Name, Bool)] -> [ClsInst] -> [FamInst] -> ImportDeclList dom -> LocalRefactor dom (ImportDeclList dom) +narrowImports noNarrowSubspecs exportedModules usedNames exportedNames prelInsts prelFamInsts imps + = annListElems & traversal !~ narrowImport noNarrowSubspecs exportedModules usedNames exportedNames + $ filterListIndexed (\i _ -> impsNeeded !! i) imps + where impsNeeded = neededImports exportedModules (usedNames ++ map fst exportedNames) prelInsts prelFamInsts (imps ^. annListElems) -- | Reduces the number of definitions used from an import narrowImport :: OrganizeImportsDomain dom - => Bool -> [String] -> [GHC.Name] -> ImportDecl dom -> LocalRefactor dom (ImportDecl dom) -narrowImport noNarrowSubspecs exportedModules usedNames imp + => Bool -> [String] -> [GHC.Name] -> [(GHC.Name, Bool)] -> ImportDecl dom -> LocalRefactor dom (ImportDecl dom) +narrowImport noNarrowSubspecs exportedModules usedNames exportedNames imp | (imp ^. importModule & moduleNameString) `elem` exportedModules || maybe False (`elem` exportedModules) (imp ^? importAs & annJust & importRename & moduleNameString) = return imp -- dont change an import if it is exported as-is (module export) | importIsExact imp - = importSpec&annJust&importSpecList !~ narrowImportSpecs noNarrowSubspecs usedNames $ imp + = importSpec&annJust&importSpecList !~ narrowImportSpecs noNarrowSubspecs usedNames exportedNames $ imp + | importIsHiding imp + = return imp -- a hiding import is not changed, because the wildcard importing of class and datatype + -- members could bring into scope the exact definition that was hidden | otherwise = do namedThings <- mapM lookupName actuallyImported - let -- to explicitely import pattern synonyms we need to enable an extension, and the user might not expect this - hasPatSyn = any (\case Just (AConLike (PatSynCon _)) -> True; _ -> False) namedThings - groups = groupThings noNarrowSubspecs (semanticsImported imp) (catMaybes namedThings) - return $ if not hasPatSyn && length groups < 4 + let -- to explicitly import pattern synonyms or type operators we need to enable an extension, and the user might not expect this + hasRiskyDef = any isRiskyDef namedThings + groups = groupThings noNarrowSubspecs (semanticsImported imp) + (filter ((`elem` semanticsImported imp) . fst) exportedNames) (catMaybes namedThings) + return $ if not hasRiskyDef && length groups < 4 then importSpec .- replaceWithJust (createImportSpec groups) $ imp - else imp + else imp where actuallyImported = semanticsImported imp `intersect` usedNames + isRiskyDef (Just (AConLike (PatSynCon _))) = True + isRiskyDef (Just (ATyCon tc)) = isSymOcc (occName (tyConName tc)) + isRiskyDef _ = False -- | Group things as importable definitions. The second member of the pair will be true, when there is a sub-name -- that should be imported apart from the name of the importable definition. -groupThings :: Bool -> [GHC.Name] -> [TyThing] -> [(GHC.Name, Bool)] -groupThings noNarrowSubspecs importable - = map last . groupBy ((==) `on` fst) . sort . map createImportFromTyThing +groupThings :: Bool -> [GHC.Name] -> [(GHC.Name, Bool)] -> [TyThing] -> [(GHC.Name, Bool)] +groupThings noNarrowSubspecs importable exported + = map last . groupBy ((==) `on` fst) . sort . (exported ++) . map createImportFromTyThing where createImportFromTyThing :: TyThing -> (GHC.Name, Bool) - createImportFromTyThing tt | Just td <- getTopDef tt - = if (td `elem` importable) then (td, True) - else (getName tt, False) + createImportFromTyThing tt | Just (td, isDataType) <- getTopDef tt + = if (td `elem` importable || isDataType) then (td, True) + else (getName tt, False) createImportFromTyThing tt@(ATyCon {}) = (getName tt, noNarrowSubspecs) createImportFromTyThing tt = (getName tt, False) --- | Gets the importable definition for a (looked up) name. For example a class function is only importable --- in a class, so it gets the name of the class. -getTopDef :: TyThing -> Maybe GHC.Name +-- | Gets the importable definition for a (looked up) name. The bool flag tells if it is from +-- a data type. +getTopDef :: TyThing -> Maybe (GHC.Name, Bool) getTopDef (AnId id) | isRecordSelector id - = Just $ case recordSelectorTyCon id of RecSelData tc -> getName tc - RecSelPatSyn ps -> getName ps -getTopDef (AnId id) = fmap (getName . dataConTyCon) (isDataConWorkId_maybe id <|> isDataConId_maybe id) - <|> fmap getName (isClassOpId_maybe id) -getTopDef (AConLike (RealDataCon dc)) = Just (getName $ dataConTyCon dc) + = case recordSelectorTyCon id of RecSelData tc -> Just (getName tc, True) + RecSelPatSyn ps -> Just (getName ps, False) +getTopDef (AnId id) + | Just n <- fmap (getName . dataConTyCon) (isDataConWorkId_maybe id <|> isDataConId_maybe id) + = Just (n, True) +getTopDef (AnId id) = fmap ((,False) . getName) (isClassOpId_maybe id) +getTopDef (AConLike (RealDataCon dc)) + = case tyConFamInst_maybe (dataConTyCon dc) of + Just (dataFam, _) -> Just (getName dataFam, True) + _ -> Just (getName $ dataConTyCon dc, True) getTopDef (AConLike (PatSynCon _)) = error "getTopDef: should not be called with pattern synonyms" getTopDef (ATyCon _) = Nothing @@ -139,44 +179,40 @@ neededImports exportedModules usedNames prelInsts prelFamInsts imps = neededImports' usedNames [] imps where neededImports' _ _ [] = [] -- keep the import if any definition is needed from it - neededImports' usedNames kept (imp : rest) - | not (null actuallyImported) + neededImports' usedNames kept (imp : rest) + | not (null actuallyImported) || (imp ^. importModule & moduleNameString) `elem` exportedModules || maybe False (`elem` exportedModules) (imp ^? importAs & annJust & importRename & moduleNameString) = True : neededImports' usedNames (imp : kept) rest where actuallyImported = semanticsImported imp `intersect` usedNames - neededImports' usedNames kept (imp : rest) + neededImports' usedNames kept (imp : rest) = needed : neededImports' usedNames (if needed then imp : kept else kept) rest where needed = any (`notElem` otherClsInstances) (map is_dfun $ semanticsOrphanInsts imp) || any (`notElem` otherFamInstances) (map fi_axiom $ semanticsFamInsts imp) otherClsInstances = map is_dfun (concatMap semanticsOrphanInsts kept ++ prelInsts) otherFamInstances = map fi_axiom (concatMap semanticsFamInsts kept ++ prelFamInsts) --- | Narrows the import specification (explicitely imported elements) +-- | Narrows the import specification (explicitly imported elements) narrowImportSpecs :: forall dom . OrganizeImportsDomain dom - => Bool -> [GHC.Name] -> IESpecList dom -> LocalRefactor dom (IESpecList dom) -narrowImportSpecs noNarrowSubspecs usedNames - = (if noNarrowSubspecs then return else (annList !~ narrowSpecSubspec usedNames)) + => Bool -> [GHC.Name] -> [(GHC.Name, Bool)] -> IESpecList dom -> LocalRefactor dom (IESpecList dom) +narrowImportSpecs noNarrowSubspecs usedNames exportedNames + = (if noNarrowSubspecs then return else return . (annList .- narrowImportSubspecs neededNames exportedNames)) >=> return . filterList isNeededSpec - where narrowSpecSubspec :: [GHC.Name] -> IESpec dom -> LocalRefactor dom (IESpec dom) - narrowSpecSubspec usedNames spec - = do let Just specName = semanticsName =<< (spec ^? ieName&simpleName) - Just tt <- GHC.lookupName (getName specName) - let subspecsInScope = case tt of ATyCon tc | not (isClassTyCon tc) - -> (map getName (tyConDataCons tc) ++ map flSelector (tyConFieldLabels tc)) `intersect` usedNames - _ -> usedNames - ieSubspec !- narrowImportSubspecs subspecsInScope $ spec - + where neededNames = usedNames ++ map fst exportedNames + isNeededSpec :: IESpec dom -> Bool - isNeededSpec ie = - -- if the name is used, it is needed - fmap getName (semanticsName =<< (ie ^? ieName&simpleName)) `elem` map Just usedNames + isNeededSpec ie = + (semanticsName (ie ^. ieName&simpleName)) `elem` map Just neededNames -- if the name is not used, but some of its constructors are used, it is needed || ((ie ^? ieSubspec&annJust&essList&annList) /= []) - || (case ie ^? ieSubspec&annJust of Just SubAll -> True; _ -> False) + -- its a bit hard to decide if there is an element inside (for example bundled pattern synonyms) + || (case ie ^? ieSubspec&annJust of Just SubAll -> True; _ -> False) -- | Reduces the number of definitions imported from a sub-specifier. -narrowImportSubspecs :: OrganizeImportsDomain dom => [GHC.Name] -> MaybeSubSpec dom -> MaybeSubSpec dom -narrowImportSubspecs [] = replaceWithNothing -narrowImportSubspecs usedNames - = annJust & essList .- filterList (\n -> fmap getName (semanticsName =<< (n ^? simpleName)) `elem` map Just usedNames) +narrowImportSubspecs :: OrganizeImportsDomain dom => [GHC.Name] -> [(GHC.Name, Bool)] -> IESpec dom -> IESpec dom +narrowImportSubspecs neededNames exportedNames ss | noNarrowingForThis = ss + | otherwise + = ieSubspec & annJust & essList .- filterList (\n -> (semanticsName (n ^. simpleName)) `elem` map Just neededNames) $ ss + where noNarrowingForThis = case semanticsName (ss ^. ieName&simpleName) of + Just name -> lookup name exportedNames == Just True + _ -> False diff --git a/Language/Haskell/Tools/Refactor/Predefined/RenameDefinition.hs b/Language/Haskell/Tools/Refactor/Predefined/RenameDefinition.hs --- a/Language/Haskell/Tools/Refactor/Predefined/RenameDefinition.hs +++ b/Language/Haskell/Tools/Refactor/Predefined/RenameDefinition.hs @@ -6,6 +6,7 @@ , TypeFamilies , FlexibleContexts , ViewPatterns + , TupleSections #-} module Language.Haskell.Tools.Refactor.Predefined.RenameDefinition (renameDefinition, renameDefinition', DomainRenameDefinition) where @@ -27,8 +28,8 @@ renameDefinition' :: forall dom . DomainRenameDefinition dom => RealSrcSpan -> String -> Refactoring dom renameDefinition' sp str mod mods - = case (getNodeContaining sp (snd mod) :: Maybe (QualifiedName dom)) >>= (fmap getName . semanticsName) of - Just name -> do let sameNames = bindsWithSameName name (snd mod ^? biplateRef) + = case (getNodeContaining sp (snd mod) :: Maybe (QualifiedName dom)) >>= (fmap getName . semanticsName) of + Just name -> do let sameNames = bindsWithSameName name (snd mod ^? biplateRef) renameDefinition name sameNames str mod mods where bindsWithSameName :: GHC.Name -> [FieldWildcard dom] -> [GHC.Name] bindsWithSameName name wcs = catMaybes $ map ((lookup name) . semanticsImplicitFlds) wcs @@ -37,33 +38,33 @@ Nothing -> refactError "No name is selected" renameModule :: forall dom . DomainRenameDefinition dom => String -> String -> Refactoring dom -renameModule from to m mods - | any (nameConflict to) (map snd $ m:mods) = refactError "Name conflict when renaming module" - | not (validModuleName to) = refactError "The given name is not a valid module name" - | otherwise = -- here it is important that the delete is the last, because rename +renameModule from to m mods + | any (nameConflict to) (map snd $ m:mods) = refactError "Name conflict when renaming module" + | isJust (validModuleName to) = refactError $ "The given name is not a valid module name: " ++ fromJust (validModuleName to) + | otherwise = -- here it is important that the delete is the last, because rename -- can still use the info about the deleted module fmap (\ls -> map (alterChange from to) ls ++ [ModuleRemoved from]) - $ localRefactoring (replaceModuleNames >=> alterNormalNames) m mods - where alterChange from to (ContentChanged (mod,res)) - | (mod ^. sfkModuleName) == from + $ mapM (\(name,mod) -> ContentChanged . (name,) <$> localRefactoringRes id mod (replaceModuleNames =<< alterNormalNames mod)) (m:mods) + where alterChange from to (ContentChanged (mod,res)) + | (mod ^. sfkModuleName) == from = ModuleCreated to res (SourceFileKey NormalHs from) - alterChange _ _ c = c + alterChange _ _ c = c replaceModuleNames :: LocalRefactoring dom replaceModuleNames = biplateRef @_ @(ModuleName dom) & filtered (\e -> (e ^. moduleNameString) == from) != mkModuleName to alterNormalNames :: LocalRefactoring dom - alterNormalNames mod = if from `elem` moduleQualifiers mod + alterNormalNames mod = if from `elem` moduleQualifiers mod then biplateRef @_ @(QualifiedName dom) & filtered (\e -> concat (intersperse "." (e ^? qualifiers&annList&simpleNameStr)) == from) !- (\e -> mkQualifiedName (splitOn "." to) (e ^. unqualifiedName&simpleNameStr)) $ mod else return mod moduleQualifiers :: Module dom -> [String] - moduleQualifiers mod = mod ^? modImports & annList & filtered (\m -> isAnnNothing (m ^. importAs)) + moduleQualifiers mod = mod ^? modImports & annList & filtered (\m -> isAnnNothing (m ^. importAs)) & importModule & moduleNameString nameConflict :: String -> Module dom -> Bool - nameConflict to mod + nameConflict to mod = let modName = mod ^? modHead&annJust&mhName&moduleNameString imports = mod ^? modImports&annList importNames = map (\imp -> fromMaybe (imp ^. importModule) (imp ^? importAs&annJust&importRename) ^. moduleNameString) imports @@ -73,10 +74,10 @@ 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" + if | isJust (nameValid nameCls newName) -> refactError $ "The new name is not valid: " ++ fromJust (nameValid nameCls newName) + | not defFound -> refactError "The definition to rename was not found. Maybe it is in another package." | otherwise -> return $ map ContentChanged changedModules - where + where renameInAModule :: DomainRenameDefinition dom => GHC.Name -> [GHC.Name] -> String -> ModuleDom dom -> StateT Bool Refactor (Maybe (ModuleDom dom)) renameInAModule toChangeOrig toChangeWith newName (name, mod) = mapStateT (localRefactoringRes (\f (a,s) -> (fmap (\(n,r) -> (n, f r)) a,s)) mod) $ @@ -84,7 +85,7 @@ if isChanged then return $ Just (name, res) else return Nothing - changeName :: DomainRenameDefinition dom => GHC.Name -> [GHC.Name] -> String -> QualifiedName dom + changeName :: DomainRenameDefinition dom => GHC.Name -> [GHC.Name] -> String -> QualifiedName dom -> StateT Bool (StateT Bool (LocalRefactor dom)) (QualifiedName dom) changeName toChangeOrig toChangeWith str name | maybe False (`elem` toChange) actualName @@ -93,11 +94,11 @@ = 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) + when (actualName == Just toChangeOrig) $ lift $ modify (|| semanticsDefining name) -- state that the definition is renamed in the global state return $ unqualifiedName .= mkNamePart str $ name -- found the changed name (or a name that have to be changed too) | let namesInScope = semanticsScope name - in case semanticsName name of + in case semanticsName name of Just (getName -> exprName) -> str == occNameString (getOccName exprName) && sameNamespace toChangeOrig exprName && conflicts toChangeOrig exprName namesInScope Nothing -> False -- ambiguous names @@ -107,7 +108,7 @@ actualName = fmap getName (semanticsName name) conflicts :: GHC.Name -> GHC.Name -> [[GHC.Name]] -> Bool -conflicts overwrites overwritten (scopeBlock : scope) +conflicts overwrites overwritten (scopeBlock : scope) | overwritten `elem` scopeBlock && overwrites `notElem` scopeBlock = False | overwrites `elem` scopeBlock = True | otherwise = conflicts overwrites overwritten scope diff --git a/Language/Haskell/Tools/Refactor/Prepare.hs b/Language/Haskell/Tools/Refactor/Prepare.hs --- a/Language/Haskell/Tools/Refactor/Prepare.hs +++ b/Language/Haskell/Tools/Refactor/Prepare.hs @@ -21,6 +21,7 @@ import GHC.Paths ( libdir ) import Packages import SrcLoc +import StringBuffer import Control.Exception import Control.Monad @@ -40,6 +41,7 @@ import Language.Haskell.Tools.Refactor.RefactorBase import Language.Haskell.Tools.Transform + -- | A quick function to try the refactorings tryRefactor :: (RealSrcSpan -> Refactoring IdDom) -> String -> String -> IO () tryRefactor refact moduleName span @@ -47,22 +49,22 @@ initGhcFlags useDirs ["."] mod <- loadModule "." moduleName >>= parseTyped - res <- runRefactor (SourceFileKey NormalHs moduleName, mod) [] - $ refact $ correctRefactorSpan mod $ readSrcSpan span + res <- runRefactor (SourceFileKey NormalHs moduleName, mod) [] + $ refact $ correctRefactorSpan mod $ readSrcSpan span case res of Right r -> liftIO $ mapM_ (putStrLn . prettyPrint . snd . fromContentChanged) r Left err -> liftIO $ putStrLn err -- | Adjust the source range to be applied to the refactored module correctRefactorSpan :: UnnamedModule dom -> RealSrcSpan -> RealSrcSpan -correctRefactorSpan mod sp = mkRealSrcSpan (updateSrcFile fileName $ realSrcSpanStart sp) +correctRefactorSpan mod sp = mkRealSrcSpan (updateSrcFile fileName $ realSrcSpanStart sp) (updateSrcFile fileName $ realSrcSpanEnd sp) - where fileName = case srcSpanStart $ getRange mod of RealSrcLoc loc -> srcLocFile loc + where fileName = case srcSpanStart $ getRange mod of RealSrcLoc loc -> srcLocFile loc _ -> error "correctRefactorSpan: no real span" - updateSrcFile fn loc = mkRealSrcLoc fn (srcLocLine loc) (srcLocCol loc) + updateSrcFile fn loc = mkRealSrcLoc fn (srcLocLine loc) (srcLocCol loc) -- | Set the given flags for the GHC session useFlags :: [String] -> Ghc [String] -useFlags args = do +useFlags args = do let lArgs = map (L noSrcSpan) args dynflags <- getSessionDynFlags -- TODO: print errors and warnings? @@ -73,8 +75,8 @@ -- | Reloads the package database based on the session flags reloadPkgDb :: Ghc () -reloadPkgDb = void $ setSessionDynFlags . fst =<< liftIO . initPackages . (\df -> df { pkgDatabase = Nothing }) - =<< getSessionDynFlags +reloadPkgDb = void $ setSessionDynFlags . fst =<< liftIO . initPackages . (\df -> df { pkgDatabase = Nothing }) + =<< getSessionDynFlags -- | Initialize GHC flags to default values that support refactoring initGhcFlags :: Ghc () @@ -87,13 +89,13 @@ initGhcFlags' :: Bool -> Ghc () initGhcFlags' needsCodeGen = do dflags <- getSessionDynFlags - void $ setSessionDynFlags + void $ setSessionDynFlags $ flip gopt_set Opt_KeepRawTokenStream $ flip gopt_set Opt_NoHsMain $ dflags { importPaths = [] , hscTarget = if needsCodeGen then HscInterpreted else HscNothing , ghcLink = if needsCodeGen then LinkInMemory else NoLink - , ghcMode = CompManager + , ghcMode = CompManager , packageFlags = ExposePackage "template-haskell" (PackageArg "template-haskell") (ModRenaming True []) : packageFlags dflags } @@ -108,7 +110,7 @@ deregisterDirs workingDirs = do dynflags <- getSessionDynFlags void $ setSessionDynFlags dynflags { importPaths = importPaths dynflags \\ workingDirs } - + -- | Translates module name and working directory into the name of the file where the given module should be defined toFileName :: FilePath -> String -> FilePath toFileName workingDir mod = normalise $ workingDir map (\case '.' -> pathSeparator; c -> c) mod ++ ".hs" @@ -119,9 +121,9 @@ -- | Get the source directory where the module is located. getSourceDir :: ModSummary -> IO FilePath -getSourceDir ms +getSourceDir ms = do filePath <- canonicalizePath $ getModSumOrig ms - let modNameParts = splitOn "." $ GHC.moduleNameString (moduleName (ms_mod ms)) + let modNameParts = splitOn "." $ GHC.moduleNameString (moduleName (ms_mod ms)) filePathParts = splitPath filePath let srcDirParts = reverse $ drop (length modNameParts) $ reverse filePathParts return $ joinPath srcDirParts @@ -130,16 +132,20 @@ getModSumOrig :: ModSummary -> FilePath getModSumOrig = normalise . fromMaybe (error "getModSumOrig: The given module doesn't have haskell source file.") . ml_hs_file . ms_location +-- | Gets the module name +getModSumName :: ModSummary -> String +getModSumName = GHC.moduleNameString . moduleName . ms_mod + -- | Load the summary of a module given by the working directory and module name. loadModule :: String -> String -> Ghc ModSummary -loadModule workingDir moduleName +loadModule workingDir moduleName = do initGhcFlagsForTest useDirs [workingDir] target <- guessTarget moduleName Nothing setTargets [target] void $ load (LoadUpTo $ mkModuleName moduleName) getModSummary $ mkModuleName moduleName - + -- | The final version of our AST, with type infromation added type TypedModule = Ann AST.UModule IdDom SrcTemplateStage @@ -148,21 +154,20 @@ parseTyped modSum = withAlteredDynFlags (return . normalizeFlags) $ do let hasStaticFlags = StaticPointers `xopt` ms_hspp_opts modSum hasCppExtension = Cpp `xopt` ms_hspp_opts modSum - hasUnicodeExtension = UnicodeSyntax `xopt` ms_hspp_opts modSum ms = if hasStaticFlags then forceAsmGen (modSumNormalizeFlags modSum) else (modSumNormalizeFlags modSum) - when (hasCppExtension || hasUnicodeExtension) - $ throw (IllegalExtensions (["CPP" | hasCppExtension] ++ ["UnicodeSyntax" | hasUnicodeExtension])) p <- parseModule ms tc <- typecheckModule p void $ GHC.loadModule tc -- when used with loadModule, the module will be loaded twice let annots = pm_annotations p - srcBuffer = fromJust $ ms_hspp_buf $ pm_mod_summary p - prepareAST srcBuffer . placeComments (getNormalComments $ snd annots) - <$> (addTypeInfos (typecheckedSource tc) + srcBuffer <- if hasCppExtension + then liftIO $ hGetStringBuffer (getModSumOrig ms) + else return (fromJust $ ms_hspp_buf $ pm_mod_summary p) + (if hasCppExtension then prepareASTCpp else prepareAST) srcBuffer . placeComments (fst annots) (getNormalComments $ snd annots) + <$> (addTypeInfos (typecheckedSource tc) =<< (do parseTrf <- runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModule ms (pm_parsed_source p) runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModuleRename ms parseTrf - (fromJust $ tm_renamed_source tc) + (fromJust $ tm_renamed_source tc) (pm_parsed_source p))) -- | Modifies the dynamic flags for performing a ghc task @@ -199,9 +204,9 @@ readSrcSpan s = case splitOn "-" s of [one] -> mkRealSrcSpan (readSrcLoc one) (readSrcLoc one) [from,to] -> mkRealSrcSpan (readSrcLoc from) (readSrcLoc to) - + -- | Read a source location from our format: @line:col@ readSrcLoc :: String -> RealSrcLoc readSrcLoc s = case splitOn ":" s of [line,col] -> mkRealSrcLoc (mkFastString "file-name-should-be-fixed") (read line) (read col) - _ -> error "readSrcLoc: panic: splitOn gives empty list" + _ -> error "readSrcLoc: panic: splitOn gives empty list" diff --git a/Language/Haskell/Tools/Refactor/RefactorBase.hs b/Language/Haskell/Tools/Refactor/RefactorBase.hs --- a/Language/Haskell/Tools/Refactor/RefactorBase.hs +++ b/Language/Haskell/Tools/Refactor/RefactorBase.hs @@ -72,6 +72,7 @@ -- | Exceptions that can occur while loading modules or during internal operations (not during performing the refactor). data RefactorException = IllegalExtensions [String] | SourceCodeProblem ErrorMessages + | ModuleNotInPackage String | UnknownException String deriving (Show, Typeable) @@ -81,8 +82,9 @@ instance Exception RefactorException where displayException (SourceCodeProblem prob) = "Source code problem: " ++ showSDocUnsafe (vcat (pprErrMsgBagWithLoc prob)) - displayException (IllegalExtensions exts) + displayException (IllegalExtensions exts) = "The following extensions are not allowed: " ++ (concat $ intersperse ", " exts) ++ "." + displayException (ModuleNotInPackage modName) = "The module is not in the package: " ++ modName displayException (UnknownException ex) = "An unexpected problem appeared: " ++ ex ++ "." instance Show (RefactorChange dom) where @@ -96,13 +98,13 @@ -- | 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) _ +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 + => ((UnnamedModule dom -> UnnamedModule dom) -> a -> a) + -> UnnamedModule dom -> LocalRefactor dom a -> Refactor a localRefactoringRes access mod trf @@ -158,8 +160,8 @@ 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 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) @@ -167,7 +169,7 @@ -- | The information a refactoring can use data RefactorCtx dom = RefactorCtx { refModuleName :: GHC.Module , refCtxRoot :: Ann UModule dom SrcTemplateStage - , refCtxImports :: [Ann UImportDecl dom SrcTemplateStage] + , refCtxImports :: [Ann UImportDecl dom SrcTemplateStage] } instance MonadTrans (LocalRefactorT dom) where @@ -200,14 +202,14 @@ registeredNamesFromPrelude = GHC.basicKnownKeyNames ++ map GHC.tyConName GHC.wiredInTyCons otherNamesFromPrelude :: [String] -otherNamesFromPrelude +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"] qualifiedName :: GHC.Name -> String -qualifiedName name = case GHC.nameModule_maybe name of +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) @@ -218,46 +220,46 @@ referenceOperator = referenceName' mkQualOp' -- | Create a name that references the definition. Generates an import if the definition is not yet imported. -referenceName' :: (HasImportInfo dom, HasModuleInfo dom) +referenceName' :: (HasImportInfo dom, HasModuleInfo dom) => ([String] -> GHC.Name -> Ann nt dom SrcTemplateStage) -> GHC.Name -> LocalRefactor dom (Ann nt dom SrcTemplateStage) -referenceName' makeName name +referenceName' makeName name | name `elem` registeredNamesFromPrelude || qualifiedName name `elem` otherNamesFromPrelude = return $ makeName [] name -- imported from prelude - | otherwise + | otherwise = do RefactorCtx {refCtxRoot = mod, refCtxImports = imports, refModuleName = thisModule} <- ask - if maybe True (thisModule ==) (GHC.nameModule_maybe name) + if maybe True (thisModule ==) (GHC.nameModule_maybe name) then return $ makeName [] name -- in the same module, use simple name 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 + | 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 UImportDecl dom SrcTemplateStage] -> Ann nt dom SrcTemplateStage -referenceBy makeName name imps = +referenceBy makeName name imps = let prefixes = map importQualifier imps in makeName (minimumBy (compare `on` (length . concat)) prefixes) name where importQualifier :: Ann UImportDecl dom SrcTemplateStage -> [String] - importQualifier imp - = if isJust (imp ^? importQualified&annJust) - then case imp ^? importAs&annJust&importRename of + importQualifier imp + = if isJust (imp ^? importQualified&annJust) + then case imp ^? importAs&annJust&importRename of Nothing -> splitOn "." (imp ^. importModule&moduleNameString) -- fully qualified import Just asName -> splitOn "." (asName ^. moduleNameString) -- the name given by as clause else [] -- unqualified import -- | Different classes of definitions that have different kind of names. data NameClass = Variable -- ^ Normal value definitions: functions, variables - | Ctor -- ^ Data constructors + | Ctor -- ^ Data constructors | ValueOperator -- ^ Functions with operator-like names | DataCtorOperator -- ^ Constructors with operator-like names | SynonymOperator -- ^ UType definitions with operator-like names -- | Get which category does a given name belong to classifyName :: RefactorMonad m => GHC.Name -> m NameClass -classifyName n = liftGhc (lookupName n) >>= return . \case +classifyName n = liftGhc (lookupName n) >>= return . \case Just (AnId {}) | isop -> ValueOperator Just (AnId {}) -> Variable Just (AConLike {}) | isop -> DataCtorOperator @@ -267,37 +269,36 @@ Just (ACoAxiom {}) -> error "classifyName: ACoAxiom" Nothing | isop -> ValueOperator Nothing -> Variable - where isop = GHC.isSymOcc (GHC.getOccName n) + 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) +validModuleName :: String -> Maybe String +validModuleName s = foldl mappend mempty $ map (nameValid Ctor) (splitOn "." s) -- | Check if a given name is valid for a given kind of definition -nameValid :: NameClass -> String -> Bool -nameValid _ "" = False -nameValid _ str | str `elem` reservedNames = False +nameValid :: NameClass -> String -> Maybe String +nameValid _ "" = Just "An empty name is not valid" +nameValid _ str | str `elem` reservedNames = Just $ "'" ++ str ++ "' is a reserved name" 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 --- UType families and synonyms that are operators (can start with ':') -nameValid SynonymOperator (c : nameRest) - = isOperatorChar c && all isOperatorChar nameRest +nameValid DataCtorOperator (':' : nameRest) | all isOperatorChar nameRest = Nothing +nameValid DataCtorOperator _ = Just "A constructor operator must start with ':' and only contain operator characters." +-- Type families and synonyms that are operators (can start with ':') +nameValid SynonymOperator name | all isOperatorChar name = Nothing +nameValid SynonymOperator _ = Just "An operator must only contain operator characters." -- Normal value operators (cannot start with ':') -nameValid ValueOperator (c : nameRest) - = isOperatorChar c && c /= ':' && all isOperatorChar nameRest +nameValid ValueOperator (c : nameRest) | isOperatorChar c && c /= ':' && all isOperatorChar nameRest = Nothing +nameValid ValueOperator _ = Just "An operator that is a value must only contain operator characters and cannot start with ':'" -- Data and type constructors (start with uppercase) -nameValid Ctor (c : nameRest) - = isUpper c && isIdStartChar c && all (\c -> isIdStartChar c || isDigit c) nameRest +nameValid Ctor (c : nameRest) | isUpper c && isIdStartChar c && all (\c -> isIdStartChar c || isDigit c) nameRest = Nothing +nameValid Ctor _ = Just "A constructor or module name must start with an uppercase letter, and only contain letters, digits, apostrhophe or underscore" -- Variables and type variables (start with lowercase) -nameValid Variable (c : nameRest) - = isLower c && isIdStartChar c && all (\c -> isIdStartChar c || isDigit c) nameRest -nameValid _ _ = False +nameValid Variable (c : nameRest) | isLower c && isIdStartChar c && all (\c -> isIdStartChar c || isDigit c) nameRest = Nothing +nameValid Variable _ = Just "The name of a value must start with lowercase, and only contain letters, digits, apostrhophe or underscore" isIdStartChar :: Char -> Bool isIdStartChar c = (isLetter c && isAscii c) || c == '\'' || c == '_' @@ -305,4 +306,4 @@ isOperatorChar :: Char -> Bool isOperatorChar c = (isPunctuation c || isSymbol c) && isAscii c -makeReferences ''SourceFileKey +makeReferences ''SourceFileKey diff --git a/Language/Haskell/Tools/Refactor/Session.hs b/Language/Haskell/Tools/Refactor/Session.hs --- a/Language/Haskell/Tools/Refactor/Session.hs +++ b/Language/Haskell/Tools/Refactor/Session.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell +{-# LANGUAGE TemplateHaskell , TupleSections #-} -- | Common operations for managing refactoring sessions, for example loading packages, re-loading modules. @@ -46,17 +46,20 @@ initSession = RefactorSessionState [] -- | Load packages from the given directories. Loads modules, performs the given callback action, warns for duplicate modules. -loadPackagesFrom :: IsRefactSessionState st => (ModSummary -> IO a) -> [FilePath] -> StateT st Ghc (Either RefactorException ([a], [String])) -loadPackagesFrom report packages = +loadPackagesFrom :: IsRefactSessionState st => (ModSummary -> IO a) -> ([ModSummary] -> IO ()) -> (st -> FilePath -> IO [FilePath]) -> [FilePath] -> StateT st Ghc (Either RefactorException ([a], [String])) +loadPackagesFrom report loadCallback additionalSrcDirs packages = do modColls <- liftIO $ getAllModules packages modify $ refSessMCs .- (++ modColls) allModColls <- gets (^. refSessMCs) - lift $ useDirs (modColls ^? traversal & mcSourceDirs & traversal) + st <- get + moreSrcDirs <- liftIO $ mapM (additionalSrcDirs st) packages + lift $ useDirs ((modColls ^? traversal & mcSourceDirs & traversal) ++ concat moreSrcDirs) let (ignored, modNames) = extractDuplicates $ map (^. sfkModuleName) $ concat $ map Map.keys $ modColls ^? traversal & mcModules alreadyExistingMods = concatMap (map (^. sfkModuleName) . Map.keys . (^. mcModules)) (allModColls List.\\ modColls) lift $ mapM_ addTarget $ map (\mod -> (Target (TargetModule (GHC.mkModuleName mod)) True Nothing)) modNames - handleErrors $ withAlteredDynFlags (return . enableAllPackages allModColls) $ do + handleErrors $ withAlteredDynFlags (liftIO . setupLoadFlags allModColls) $ do modsForColls <- lift $ depanal [] True + liftIO $ loadCallback modsForColls let modsToParse = flattenSCCs $ topSortModuleGraph False modsForColls Nothing actuallyCompiled = filter (not . (`elem` alreadyExistingMods) . modSumName) modsToParse void $ checkEvaluatedMods report modsToParse @@ -64,7 +67,7 @@ return (mods, ignored) where extractDuplicates :: Eq a => [a] -> ([a],[a]) - extractDuplicates (a:rest) + extractDuplicates (a:rest) = case extractDuplicates rest of (repl, orig) -> if a `elem` orig then (a:repl, orig) else (repl, a:orig) extractDuplicates [] = ([],[]) @@ -75,24 +78,24 @@ -- | Handle GHC exceptions and RefactorException. handleErrors :: ExceptionMonad m => m a -> m (Either RefactorException a) -handleErrors action = handleSourceError (return . Left . SourceCodeProblem . srcErrorMessages) (Right <$> action) +handleErrors action = handleSourceError (return . Left . SourceCodeProblem . srcErrorMessages) (Right <$> action) `gcatch` (return . Left) keyFromMS :: ModSummary -> SourceFileKey keyFromMS ms = SourceFileKey (case ms_hsc_src ms of HsSrcFile -> NormalHs; _ -> IsHsBoot) (modSumName ms) -getMods :: (Monad m, IsRefactSessionState st) +getMods :: (Monad m, IsRefactSessionState st) => Maybe SourceFileKey -> StateT st m ( Maybe (SourceFileKey, UnnamedModule IdDom) , [(SourceFileKey, UnnamedModule IdDom)] ) -getMods actMod +getMods actMod = do mcs <- gets (^. refSessMCs) return $ ( (_2 !~ (^? typedRecModule)) =<< flip lookupModInSCs mcs =<< actMod , filter ((actMod /=) . Just . fst) $ concatMap (catMaybes . map (_2 !~ (^? typedRecModule)) . Map.assocs . (^. mcModules)) mcs ) -getFileMods :: (GhcMonad m, IsRefactSessionState st) +getFileMods :: (GhcMonad m, IsRefactSessionState st) => FilePath -> StateT st m ( Maybe (SourceFileKey, UnnamedModule IdDom) , [(SourceFileKey, UnnamedModule IdDom)] ) -getFileMods fname +getFileMods fname = do mcs <- gets (^. refSessMCs) let mods = map (\(k,m) -> (fromJust $ m ^? modRecMS, k)) (concatMap Map.assocs $ (mcs ^? traversal & mcModules :: [Map.Map SourceFileKey ModuleRecord])) @@ -101,17 +104,18 @@ [] -> getMods Nothing -- | Reload the modules that have been changed (given by predicate). Pefrom the callback. -reloadChangedModules :: IsRefactSessionState st => (ModSummary -> IO a) -> (ModSummary -> Bool) -> StateT st Ghc (Either RefactorException [a]) -reloadChangedModules report isChanged = handleErrors $ do - reachable <- getReachableModules isChanged +reloadChangedModules :: IsRefactSessionState st => (ModSummary -> IO a) -> ([ModSummary] -> IO ()) -> (ModSummary -> Bool) -> StateT st Ghc (Either RefactorException [a]) +reloadChangedModules report loadCallback isChanged = handleErrors $ do + reachable <- getReachableModules loadCallback isChanged void $ checkEvaluatedMods report reachable mapM (reloadModule report) reachable -getReachableModules :: IsRefactSessionState st => (ModSummary -> Bool) -> StateT st Ghc [ModSummary] -getReachableModules selected = do +getReachableModules :: IsRefactSessionState st => ([ModSummary] -> IO ()) -> (ModSummary -> Bool) -> StateT st Ghc [ModSummary] +getReachableModules loadCallback selected = do allModColls <- gets (^. refSessMCs) - withAlteredDynFlags (return . enableAllPackages allModColls) $ do + withAlteredDynFlags (liftIO . setupLoadFlags allModColls) $ do allMods <- lift $ depanal [] True + liftIO $ loadCallback (filter selected allMods) let (allModsGraph, lookup) = moduleGraphNodes False allMods changedMods = catMaybes $ map (\ms -> lookup (ms_hsc_src ms) (moduleName $ ms_mod ms)) $ filter selected allMods @@ -121,19 +125,21 @@ -- | Reload a given module. Perform a callback. reloadModule :: IsRefactSessionState st => (ModSummary -> IO a) -> ModSummary -> StateT st Ghc a -reloadModule report ms = do - let modName = modSumName ms +reloadModule report ms = do mcs <- gets (^. refSessMCs) - let mc = fromMaybe (error $ "reloadModule: The following module is not found: " ++ modName) $ lookupModuleColl modName mcs + let modName = modSumName ms codeGen = hasGeneratedCode (keyFromMS ms) mcs - let dfs = ms_hspp_opts ms - dfs' <- liftIO $ compileInContext mc mcs dfs - let ms' = ms { ms_hspp_opts = dfs' } - newm <- lift $ withAlteredDynFlags (liftIO . compileInContext mc mcs) $ - parseTyped (if codeGen then forceCodeGen ms' else ms') - modify $ refSessMCs & traversal & filtered (\mc' -> (mc' ^. mcRoot) == (mc ^. mcRoot)) & mcModules - .- Map.insert (keyFromMS ms) ((if codeGen then ModuleCodeGenerated else ModuleTypeChecked) newm ms) - liftIO $ report ms + case lookupModuleColl modName mcs of + Just mc -> do + let dfs = ms_hspp_opts ms + dfs' <- liftIO $ compileInContext mc mcs dfs + let ms' = ms { ms_hspp_opts = dfs' } + newm <- lift $ withAlteredDynFlags (liftIO . compileInContext mc mcs) $ + parseTyped (if codeGen then forceCodeGen ms' else ms') + modify $ refSessMCs & traversal & filtered (\mc' -> (mc' ^. mcRoot) == (mc ^. mcRoot)) & mcModules + .- Map.insert (keyFromMS ms) ((if codeGen then ModuleCodeGenerated else ModuleTypeChecked) newm ms) + liftIO $ report ms + Nothing -> liftIO $ throwIO $ ModuleNotInPackage modName checkEvaluatedMods :: IsRefactSessionState st => (ModSummary -> IO a) -> [ModSummary] -> StateT st Ghc [a] checkEvaluatedMods report mods = do @@ -141,11 +147,11 @@ mcs <- gets (^. refSessMCs) res <- forM modsNeedCode $ \ms -> reloadIfNeeded ms mcs return $ catMaybes res - where reloadIfNeeded ms mcs + where reloadIfNeeded ms mcs = let key = keyFromMS ms in if not (hasGeneratedCode key mcs) then do modify $ refSessMCs .- codeGeneratedFor key - if (isAlreadyLoaded key mcs) then + if (isAlreadyLoaded key mcs) then -- The module is already loaded but code is not generated. Need to reload. Just <$> lift (codeGenForModule report (codeGeneratedFor key mcs) ms) else return Nothing @@ -154,13 +160,13 @@ -- | Re-load the module with code generation enabled. Must be used when the module had already been loaded, -- but code generation were not enabled by then. codeGenForModule :: (ModSummary -> IO a) -> [ModuleCollection] -> ModSummary -> Ghc a -codeGenForModule report mcs ms +codeGenForModule report mcs ms = let modName = modSumName ms mc = fromMaybe (error $ "codeGenForModule: The following module is not found: " ++ modName) $ lookupModuleColl modName mcs in -- TODO: don't recompile, only load? do withAlteredDynFlags (liftIO . compileInContext mc mcs) $ void $ parseTyped (forceCodeGen ms) - liftIO $ report ms + liftIO $ report ms -- | Check which modules can be reached from the module, if it uses template haskell. getEvaluatedMods :: [ModSummary] -> Ghc [GHC.ModSummary] diff --git a/examples/CPP/ConditionalCode.hs b/examples/CPP/ConditionalCode.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/ConditionalCode.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE CPP #-} +module CPP.ConditionalCode where + +#if __GLASGOW_HASKELL__ >= 800 +version = "GHC 8" +#else +version = "not GHC 8" +#endif diff --git a/examples/CPP/ConditionalImport.hs b/examples/CPP/ConditionalImport.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/ConditionalImport.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} +module CPP.ConditionalImport where + +import Data.List +#ifndef USE_DATA_LIST +import Control.Monad +#endif +import Data.List + +a = Nothing >> Nothing diff --git a/examples/CPP/ConditionalImport_res.hs b/examples/CPP/ConditionalImport_res.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/ConditionalImport_res.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE CPP #-} +module CPP.ConditionalImport where + +#ifndef USE_DATA_LIST +import Control.Monad (Monad(..)) +#endif + +a = Nothing >> Nothing diff --git a/examples/CPP/JustEnabled.hs b/examples/CPP/JustEnabled.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/JustEnabled.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE CPP #-} +module CPP.JustEnabled where diff --git a/examples/Decl/ClassInfix.hs b/examples/Decl/ClassInfix.hs new file mode 100644 --- /dev/null +++ b/examples/Decl/ClassInfix.hs @@ -0,0 +1,10 @@ +module Decl.ClassInfix where + +import Control.Applicative + +class Applicative f => MonoidApplicative f where + infixl 4 +<*> + (+<*>) :: f (a -> a) -> f a -> f a + + infixl 5 >< + (><) :: Monoid a => f a -> f a -> f a diff --git a/examples/Decl/ClosedTypeFamily.hs b/examples/Decl/ClosedTypeFamily.hs --- a/examples/Decl/ClosedTypeFamily.hs +++ b/examples/Decl/ClosedTypeFamily.hs @@ -4,4 +4,6 @@ type family F a where F Int = Bool F Bool = Char - F a = Bool + F a = Bool + +type family ClosedEmpty t where diff --git a/examples/Decl/DefaultDecl.hs b/examples/Decl/DefaultDecl.hs new file mode 100644 --- /dev/null +++ b/examples/Decl/DefaultDecl.hs @@ -0,0 +1,3 @@ +module Decl.DefaultDecl where + +default () diff --git a/examples/Decl/FunFixity.hs b/examples/Decl/FunFixity.hs new file mode 100644 --- /dev/null +++ b/examples/Decl/FunFixity.hs @@ -0,0 +1,5 @@ +module Decl.FunFixity where + +infixl `snoc` +snoc :: [a] -> a -> [a] +snoc xs x = xs ++ [x] diff --git a/examples/Decl/GADT.hs b/examples/Decl/GADT.hs --- a/examples/Decl/GADT.hs +++ b/examples/Decl/GADT.hs @@ -1,5 +1,9 @@ -{-# LANGUAGE GADTs, KindSignatures #-} +{-# LANGUAGE GADTs, KindSignatures, DeriveDataTypeable #-} module Decl.GADT where -data G2 a :: * where - G2A :: { g2a :: a, g2b :: Int } -> G2 a +import Data.Typeable + +data DMap k f where + Tip :: DMap k f + Bin :: !Int -> !(k v) -> f v -> !(DMap k f) -> !(DMap k f) -> DMap k f + deriving Typeable diff --git a/examples/Decl/GadtConWithCtx.hs b/examples/Decl/GadtConWithCtx.hs new file mode 100644 --- /dev/null +++ b/examples/Decl/GadtConWithCtx.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE GADTs #-} +module Decl.GadtConWithCtx where + +data Concurrently m a where + Concurrently :: Monad m => { runConcurrently :: m a } -> Concurrently m a diff --git a/examples/Decl/InfixAssertion.hs b/examples/Decl/InfixAssertion.hs new file mode 100644 --- /dev/null +++ b/examples/Decl/InfixAssertion.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DataKinds, TypeOperators, KindSignatures, TypeFamilies #-} +module Decl.InfixAssertion where + +import GHC.TypeLits + +data Proxy (n :: Nat) = Proxy + +divSNat :: (1 <= b) => Proxy b -> Proxy b +divSNat n = n diff --git a/examples/Decl/InfixInstances.hs b/examples/Decl/InfixInstances.hs new file mode 100644 --- /dev/null +++ b/examples/Decl/InfixInstances.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeOperators, TypeFamilies #-} +module Decl.InfixInstances where + +data Zipper h i a = Zipper +data (:@) a i +infixl 8 :> +type family (:>) h p +type instance h :> (a :@ i) = Zipper h i a diff --git a/examples/Decl/InfixPatSyn.hs b/examples/Decl/InfixPatSyn.hs new file mode 100644 --- /dev/null +++ b/examples/Decl/InfixPatSyn.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +module Decl.InfixPatSyn where + +pattern x :. xs <- (uncons -> Just (x,xs)) where + x:.xs = cons x xs +infixr 5 :. + +cons x xs = x:xs +uncons (x:xs) = Just (x,xs) +uncons [] = Nothing diff --git a/examples/Decl/MixedInstance.hs b/examples/Decl/MixedInstance.hs new file mode 100644 --- /dev/null +++ b/examples/Decl/MixedInstance.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-} +module Decl.MixedInstance where + +data Canvas = Canvas +data V2 = V2 + +class Backend c v e where + data Options c v e :: * + +instance Backend Canvas V2 Double where + data Options Canvas V2 Double = CanvasOptions diff --git a/examples/Decl/PatternSynonym.hs b/examples/Decl/PatternSynonym.hs --- a/examples/Decl/PatternSynonym.hs +++ b/examples/Decl/PatternSynonym.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} module Decl.PatternSynonym where data Type = App String [Type] @@ -13,11 +13,16 @@ where Maybe (App "()" []) = App "Bool" [] Maybe t = App "Maybe" [t] +pattern (:<) :: [a] -> a -> [a] +pattern (:<) xs x <- ((\ys -> (init ys,last ys)) -> (xs,x)) + where + (:<) xs x = xs ++ [x] + ------ this is not supported yet -- class ListLike a where --- pattern Head :: e -> a e +-- pattern Head :: e -> a e0 -- pattern Tail :: a e -> a e -- instance ListLike [] where -- pattern Head h = h:_ --- pattern Tail t = _:t +-- pattern Tail t = _:t diff --git a/examples/Expr/EmptyLet.hs b/examples/Expr/EmptyLet.hs new file mode 100644 --- /dev/null +++ b/examples/Expr/EmptyLet.hs @@ -0,0 +1,6 @@ +module Expr.EmptyLet where + +a = let in () + +m = do let + putStrLn "hello" diff --git a/examples/Expr/FunSection.hs b/examples/Expr/FunSection.hs new file mode 100644 --- /dev/null +++ b/examples/Expr/FunSection.hs @@ -0,0 +1,6 @@ +module Expr.FunSection where + +data Rule = Rule { + rulePath :: String -> Bool } + +f r = filter (`rulePath` r) diff --git a/examples/Expr/PatternAndDo.hs b/examples/Expr/PatternAndDo.hs new file mode 100644 --- /dev/null +++ b/examples/Expr/PatternAndDo.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE RecordWildCards #-} +module Expr.PatternAndDo where + +import Control.Monad +import Control.Monad.Identity + +data A = A { x :: Int } + +a = forM_ [] $ \A {..} -> do + Identity "Hello" diff --git a/examples/Expr/SccPragma.hs b/examples/Expr/SccPragma.hs new file mode 100644 --- /dev/null +++ b/examples/Expr/SccPragma.hs @@ -0,0 +1,4 @@ +module Expr.SccPragma where + +f x = {-# SCC "drawComponent" #-} + case x of () -> () diff --git a/examples/Expr/SemicolonDo.hs b/examples/Expr/SemicolonDo.hs new file mode 100644 --- /dev/null +++ b/examples/Expr/SemicolonDo.hs @@ -0,0 +1,7 @@ +module Expr.SemicolonDo where + +import Control.Monad.Identity + +a = do { n <- Identity () + ; return () + } diff --git a/examples/Expr/TupleSections.hs b/examples/Expr/TupleSections.hs --- a/examples/Expr/TupleSections.hs +++ b/examples/Expr/TupleSections.hs @@ -2,4 +2,6 @@ module Expr.TupleSections where f1 = (1,,) -f2 = (,1) +f2 = (,1) + +x = (,("x", [])) diff --git a/examples/Module/ImportOp.hs b/examples/Module/ImportOp.hs new file mode 100644 --- /dev/null +++ b/examples/Module/ImportOp.hs @@ -0,0 +1,3 @@ +module Module.ImportOp where + +import Module.Imported ((:-)(..)) diff --git a/examples/Module/Imported.hs b/examples/Module/Imported.hs new file mode 100644 --- /dev/null +++ b/examples/Module/Imported.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeOperators #-} +module Module.Imported where + +infixr 8 :- +-- | A stack datatype. Just a better looking tuple. +data a :- b = a :- b deriving (Eq, Show) diff --git a/examples/Module/LangPragmas.hs b/examples/Module/LangPragmas.hs new file mode 100644 --- /dev/null +++ b/examples/Module/LangPragmas.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE LambdaCase #-} +{-#LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase#-} +module Module.LangPragmas where diff --git a/examples/Pattern/NestedWildcard.hs b/examples/Pattern/NestedWildcard.hs new file mode 100644 --- /dev/null +++ b/examples/Pattern/NestedWildcard.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE NamedFieldPuns, RecordWildCards #-} +module Pattern.NestedWildcard where + +data A = A { b :: B, ai :: Int } +data B = B { bi :: Int } + +h A { b = B {..}, .. } = bi + ai diff --git a/examples/Pattern/OperatorPattern.hs b/examples/Pattern/OperatorPattern.hs new file mode 100644 --- /dev/null +++ b/examples/Pattern/OperatorPattern.hs @@ -0,0 +1,3 @@ +module Pattern.OperatorPattern where + +child r (_:ps) = r ps diff --git a/examples/Refactor/ExtractBinding/SiblingDefs.hs b/examples/Refactor/ExtractBinding/SiblingDefs.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/SiblingDefs.hs @@ -0,0 +1,7 @@ +module Refactor.ExtractBinding.SiblingDefs where + +f = 1 + where + g = a + where a = 1 + h = 2 diff --git a/examples/Refactor/ExtractBinding/SiblingDefs_res.hs b/examples/Refactor/ExtractBinding/SiblingDefs_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/SiblingDefs_res.hs @@ -0,0 +1,8 @@ +module Refactor.ExtractBinding.SiblingDefs where + +f = 1 + where + g = a + where a = 1 + h = a + where a = 2 diff --git a/examples/Refactor/ExtractBinding/ViewPattern.hs b/examples/Refactor/ExtractBinding/ViewPattern.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/ViewPattern.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE ViewPatterns #-} +module Refactor.ExtractBinding.ViewPattern where + +f (id . id -> x) = x diff --git a/examples/Refactor/GenerateTypeSignature/PolymorphSubMulti.hs b/examples/Refactor/GenerateTypeSignature/PolymorphSubMulti.hs --- a/examples/Refactor/GenerateTypeSignature/PolymorphSubMulti.hs +++ b/examples/Refactor/GenerateTypeSignature/PolymorphSubMulti.hs @@ -2,4 +2,4 @@ f :: (Num a, Ord a) => a -> a f a = g a where - g a = if a > 0 then a + 1 else a + g a = if a > 0 then a + 1 else a diff --git a/examples/Refactor/GenerateTypeSignature/PolymorphSubMulti_res.hs b/examples/Refactor/GenerateTypeSignature/PolymorphSubMulti_res.hs --- a/examples/Refactor/GenerateTypeSignature/PolymorphSubMulti_res.hs +++ b/examples/Refactor/GenerateTypeSignature/PolymorphSubMulti_res.hs @@ -3,4 +3,4 @@ f :: (Num a, Ord a) => a -> a f a = g a where g :: (Num t, Ord t) => t -> t - g a = if a > 0 then a + 1 else a + g a = if a > 0 then a + 1 else a diff --git a/examples/Refactor/OrganizeImports/Fields.hs b/examples/Refactor/OrganizeImports/Fields.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/Fields.hs @@ -0,0 +1,6 @@ +module Refactor.OrganizeImports.Fields where + +import Control.Monad.Trans (MonadTrans(..)) +import Control.Monad.State (Monad(..), StateT(runStateT)) + +x = runStateT (lift putStrLn >> return ()) () diff --git a/examples/Refactor/OrganizeImports/Fields_res.hs b/examples/Refactor/OrganizeImports/Fields_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/Fields_res.hs @@ -0,0 +1,6 @@ +module Refactor.OrganizeImports.Fields where + +import Control.Monad.State (Monad(..), StateT(runStateT)) +import Control.Monad.Trans (MonadTrans(..)) + +x = runStateT (lift putStrLn >> return ()) () diff --git a/examples/Refactor/OrganizeImports/KeepCtorOfMarshalled.hs b/examples/Refactor/OrganizeImports/KeepCtorOfMarshalled.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/KeepCtorOfMarshalled.hs @@ -0,0 +1,5 @@ +module Refactor.OrganizeImports.KeepCtorOfMarshalled where + +import Foreign.C.String + +foreign import ccall unsafe "abc" abc :: CString -> IO () diff --git a/examples/Refactor/OrganizeImports/KeepCtorOfMarshalled_res.hs b/examples/Refactor/OrganizeImports/KeepCtorOfMarshalled_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/KeepCtorOfMarshalled_res.hs @@ -0,0 +1,5 @@ +module Refactor.OrganizeImports.KeepCtorOfMarshalled where + +import Foreign.C.String (CString(..)) + +foreign import ccall unsafe "abc" abc :: CString -> IO () diff --git a/examples/Refactor/OrganizeImports/KeepHiding.hs b/examples/Refactor/OrganizeImports/KeepHiding.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/KeepHiding.hs @@ -0,0 +1,6 @@ +module Refactor.OrganizeImports.KeepHiding where + +import Data.Map hiding (map) + +m :: Map Int String +m = empty diff --git a/examples/Refactor/OrganizeImports/KeepHiding_res.hs b/examples/Refactor/OrganizeImports/KeepHiding_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/KeepHiding_res.hs @@ -0,0 +1,6 @@ +module Refactor.OrganizeImports.KeepHiding where + +import Data.Map hiding (map) + +m :: Map Int String +m = empty diff --git a/examples/Refactor/OrganizeImports/KeepPrelude.hs b/examples/Refactor/OrganizeImports/KeepPrelude.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/KeepPrelude.hs @@ -0,0 +1,3 @@ +module Refactor.OrganizeImports.KeepPrelude where + +import Prelude () diff --git a/examples/Refactor/OrganizeImports/KeepPrelude_res.hs b/examples/Refactor/OrganizeImports/KeepPrelude_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/KeepPrelude_res.hs @@ -0,0 +1,3 @@ +module Refactor.OrganizeImports.KeepPrelude where + +import Prelude () diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/ConSourceHiddenType.hs b/examples/Refactor/OrganizeImports/MakeExplicit/ConSourceHiddenType.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/MakeExplicit/ConSourceHiddenType.hs @@ -0,0 +1,3 @@ +module Refactor.OrganizeImports.MakeExplicit.ConSourceHiddenType (A(B)) where + +import Refactor.OrganizeImports.MakeExplicit.Source diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/ImportCon.hs b/examples/Refactor/OrganizeImports/MakeExplicit/ImportCon.hs --- a/examples/Refactor/OrganizeImports/MakeExplicit/ImportCon.hs +++ b/examples/Refactor/OrganizeImports/MakeExplicit/ImportCon.hs @@ -1,6 +1,5 @@ module Refactor.OrganizeImports.MakeExplicit.ImportCon where -import Refactor.OrganizeImports.MakeExplicit.Source +import Refactor.OrganizeImports.MakeExplicit.ConSourceHiddenType x = B - diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/ImportCon_res.hs b/examples/Refactor/OrganizeImports/MakeExplicit/ImportCon_res.hs --- a/examples/Refactor/OrganizeImports/MakeExplicit/ImportCon_res.hs +++ b/examples/Refactor/OrganizeImports/MakeExplicit/ImportCon_res.hs @@ -1,6 +1,5 @@ module Refactor.OrganizeImports.MakeExplicit.ImportCon where -import Refactor.OrganizeImports.MakeExplicit.Source (A(..)) +import Refactor.OrganizeImports.MakeExplicit.ConSourceHiddenType (A(..)) x = B - diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/Renamed.hs b/examples/Refactor/OrganizeImports/MakeExplicit/Renamed.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/MakeExplicit/Renamed.hs @@ -0,0 +1,5 @@ +module Refactor.OrganizeImports.MakeExplicit.Renamed where + +import Refactor.OrganizeImports.MakeExplicit.Source as Src + +x = B diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/Renamed_res.hs b/examples/Refactor/OrganizeImports/MakeExplicit/Renamed_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/MakeExplicit/Renamed_res.hs @@ -0,0 +1,5 @@ +module Refactor.OrganizeImports.MakeExplicit.Renamed where + +import Refactor.OrganizeImports.MakeExplicit.Source as Src (A(..)) + +x = B diff --git a/examples/Refactor/OrganizeImports/NarrowSpec_res.hs b/examples/Refactor/OrganizeImports/NarrowSpec_res.hs --- a/examples/Refactor/OrganizeImports/NarrowSpec_res.hs +++ b/examples/Refactor/OrganizeImports/NarrowSpec_res.hs @@ -1,5 +1,5 @@ module Refactor.OrganizeImports.NarrowSpec where -import Control.Monad.State (State) +import Control.Monad.State (State(..)) type St = State () diff --git a/examples/Refactor/RenameDefinition/FunnyDo.hs b/examples/Refactor/RenameDefinition/FunnyDo.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/FunnyDo.hs @@ -0,0 +1,5 @@ +module Refactor.RenameDefinition.FunnyDo where + +a = do return (); return () + Just 3; return () + Nothing diff --git a/examples/Refactor/RenameDefinition/FunnyDo_res.hs b/examples/Refactor/RenameDefinition/FunnyDo_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/FunnyDo_res.hs @@ -0,0 +1,5 @@ +module Refactor.RenameDefinition.FunnyDo where + +aaa = do return (); return () + Just 3; return () + Nothing diff --git a/examples/TH/Splice/UseQual.hs b/examples/TH/Splice/UseQual.hs new file mode 100644 --- /dev/null +++ b/examples/TH/Splice/UseQual.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module TH.Splice.UseQual where + +import qualified TH.Splice.Define as Def + +$(Def.def "x") diff --git a/examples/TH/Splice/UseQualMulti.hs b/examples/TH/Splice/UseQualMulti.hs new file mode 100644 --- /dev/null +++ b/examples/TH/Splice/UseQualMulti.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +module TH.Splice.UseQualMulti where + +import qualified TH.Splice.Define as Def +import qualified TH.Splice.Define as Def2 + +$(Def.def "x") +$(Def2.def "y") diff --git a/examples/Type/TupleAssert.hs b/examples/Type/TupleAssert.hs new file mode 100644 --- /dev/null +++ b/examples/Type/TupleAssert.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ConstraintKinds #-} +module Type.TupleAssert where + +f :: (Ord a, (Show a, Eq a)) => a -> String +f = show diff --git a/haskell-tools-refactor.cabal b/haskell-tools-refactor.cabal --- a/haskell-tools-refactor.cabal +++ b/haskell-tools-refactor.cabal @@ -1,5 +1,5 @@ name: haskell-tools-refactor -version: 0.5.0.0 +version: 0.6.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 @@ -11,7 +11,8 @@ build-type: Simple cabal-version: >=1.10 -extra-source-files: examples/CppHs/Language/Preprocessor/*.hs +extra-source-files: examples/CPP/*.hs + , examples/CppHs/Language/Preprocessor/*.hs , examples/CppHs/Language/Preprocessor/Cpphs/*.hs , examples/CppHs/Language/Preprocessor/Cpphs/*.hs , examples/Decl/*.hs @@ -50,7 +51,7 @@ , examples/Type/*.hs library - ghc-options: -O2 + ghc-options: -O2 exposed-modules: Language.Haskell.Tools.Refactor , Language.Haskell.Tools.Refactor.BindingElem , Language.Haskell.Tools.Refactor.GetModules @@ -71,7 +72,11 @@ , Language.Haskell.Tools.Refactor.Predefined.DollarApp , Language.Haskell.Tools.Refactor.Predefined.InlineBinding , Language.Haskell.Tools.Refactor.Predefined.FloatOut - + , Language.Haskell.Tools.Refactor.Predefined.HelloRefactor + , Language.Haskell.Tools.Refactor.Predefined.DollarApp1 + , Language.Haskell.Tools.Refactor.Predefined.DollarApp2 + , Language.Haskell.Tools.Refactor.Predefined.DollarApp3 + build-depends: base >= 4.9 && < 4.10 , mtl >= 2.2 && < 2.3 , uniplate >= 1.6 && < 1.7 @@ -85,15 +90,15 @@ , template-haskell >= 2.11 && < 2.12 , ghc >= 8.0 && < 8.1 , Cabal >= 1.24 && < 1.25 - , haskell-tools-ast >= 0.5 && < 0.6 - , haskell-tools-backend-ghc >= 0.5 && < 0.6 - , haskell-tools-rewrite >= 0.5 && < 0.6 - , haskell-tools-prettyprint >= 0.5 && < 0.6 + , haskell-tools-ast >= 0.6 && < 0.7 + , haskell-tools-backend-ghc >= 0.6 && < 0.7 + , haskell-tools-rewrite >= 0.6 && < 0.7 + , haskell-tools-prettyprint >= 0.6 && < 0.7 default-language: Haskell2010 - + test-suite haskell-tools-test type: exitcode-stdio-1.0 - ghc-options: -with-rtsopts=-M2g -O2 + ghc-options: -with-rtsopts=-M2g hs-source-dirs: test main-is: Main.hs build-depends: base >= 4.9 && < 4.10 @@ -113,11 +118,11 @@ , ghc >= 8.0 && < 8.1 , ghc-paths >= 0.1 && < 0.2 , Cabal >= 1.24 && < 1.25 - , haskell-tools-ast >= 0.5 && < 0.6 - , haskell-tools-backend-ghc >= 0.5 && < 0.6 - , haskell-tools-rewrite >= 0.5 && < 0.6 - , haskell-tools-prettyprint >= 0.5 && < 0.6 - , haskell-tools-refactor >= 0.5 && < 0.6 + , haskell-tools-ast >= 0.6 && < 0.7 + , haskell-tools-backend-ghc >= 0.6 && < 0.7 + , haskell-tools-rewrite >= 0.6 && < 0.7 + , haskell-tools-prettyprint >= 0.6 && < 0.7 + , haskell-tools-refactor >= 0.6 && < 0.7 -- libraries used by the examples , old-time >= 1.1 && < 1.2 , polyparse >= 1.12 && < 1.13 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -11,6 +11,7 @@ import DynFlags import GHC.Paths ( libdir ) import Module as GHC +import StringBuffer import Control.Reference import Control.Monad.IO.Class @@ -49,16 +50,16 @@ main = defaultMain nightlyTests nightlyTests :: TestTree -nightlyTests - = testGroup "all tests" [ testGroup "functional tests" functionalTests +nightlyTests + = testGroup "all tests" [ testGroup "functional tests" functionalTests , testGroup "CppHs tests" $ map makeCpphsTest cppHsTests , testGroup "instance-control tests" $ map makeInstanceControlTest instanceControlTests ] functionalTests :: [TestTree] -functionalTests +functionalTests = [ testGroup "reprint tests" (map makeReprintTest checkTestCases) - , testGroup "refactor tests" + , testGroup "refactor tests" $ map makeOrganizeImportsTest organizeImportTests ++ map makeGenerateSignatureTest generateSignatureTests ++ map makeWrongGenerateSigTest wrongGenerateSigTests @@ -75,9 +76,9 @@ ++ map (makeMultiModuleTest checkMultiFail) wrongMultiModuleTests ++ map makeMiscRefactorTest miscRefactorTests ] - where checkTestCases = languageTests - ++ organizeImportTests - ++ map fst generateSignatureTests + where checkTestCases = languageTests + ++ organizeImportTests + ++ map fst generateSignatureTests ++ generateExportsTests ++ map (\(mod,_,_) -> mod) renameDefinitionTests ++ map (\(mod,_,_) -> mod) wrongRenameDefinitionTests @@ -86,19 +87,27 @@ ++ map (\(mod,_) -> mod) inlineBindingTests rootDir = "examples" - + languageTests = - [ "Decl.AmbiguousFields" + [ "CPP.JustEnabled" + , "CPP.ConditionalCode" + , "Decl.AmbiguousFields" , "Decl.AnnPragma" + , "Decl.ClassInfix" , "Decl.ClosedTypeFamily" , "Decl.CtorOp" , "Decl.DataFamily" , "Decl.DataType" , "Decl.DataTypeDerivings" + , "Decl.DefaultDecl" , "Decl.FunBind" , "Decl.FunctionalDeps" , "Decl.FunGuards" , "Decl.GADT" + , "Decl.GadtConWithCtx" + , "Decl.InfixAssertion" + , "Decl.InfixInstances" + , "Decl.InfixPatSyn" , "Decl.InjectiveTypeFamily" , "Decl.InlinePragma" , "Decl.InstanceOverlaps" @@ -131,6 +140,7 @@ , "Expr.DoNotation" , "Expr.GeneralizedListComp" , "Expr.EmptyCase" + , "Expr.FunSection" , "Expr.If" , "Expr.ImplicitParams" , "Expr.LambdaCase" @@ -140,10 +150,12 @@ , "Expr.Operator" , "Expr.ParenName" , "Expr.ParListComp" + , "Expr.PatternAndDo" , "Expr.RecordPuns" , "Expr.RecordWildcards" , "Expr.RecursiveDo" , "Expr.Sections" + , "Expr.SemicolonDo" , "Expr.StaticPtr" , "Expr.TupleSections" , "Module.Simple" @@ -151,12 +163,16 @@ , "Module.Export" , "Module.NamespaceExport" , "Module.Import" + , "Module.ImportOp" + , "Module.LangPragmas" , "Module.PatternImport" , "Pattern.Backtick" , "Pattern.Constructor" , "Pattern.ImplicitParams" , "Pattern.Infix" + , "Pattern.NestedWildcard" , "Pattern.NPlusK" + , "Pattern.OperatorPattern" , "Pattern.Record" , "Type.Bang" , "Type.Builtin" @@ -164,6 +180,7 @@ , "Type.ExplicitTypeApplication" , "Type.Forall" , "Type.Primitives" + , "Type.TupleAssert" , "Type.TypeOperators" , "Type.Unpack" , "Type.Wildcard" @@ -172,13 +189,15 @@ , "TH.QuasiQuote.Use" , "TH.Splice.Define" , "TH.Splice.Use" + , "TH.Splice.UseQual" + , "TH.Splice.UseQualMulti" , "Refactor.CommentHandling.CommentTypes" , "Refactor.CommentHandling.BlockComments" , "Refactor.CommentHandling.Crosslinking" , "Refactor.CommentHandling.FunctionArgs" ] -cppHsTests = +cppHsTests = [ "Language.Preprocessor.Cpphs" , "Language.Preprocessor.Unlit" , "Language.Preprocessor.Cpphs.CppIfdef" @@ -192,23 +211,27 @@ , "Language.Preprocessor.Cpphs.Tokenise" ] -instanceControlTests = +instanceControlTests = [ "Control.Instances.Test" , "Control.Instances.Morph" , "Control.Instances.ShortestPath" , "Control.Instances.TypeLevelPrelude" ] - -organizeImportTests = + +organizeImportTests = [ "Refactor.OrganizeImports.Narrow" , "Refactor.OrganizeImports.Reorder" , "Refactor.OrganizeImports.Ctor" , "Refactor.OrganizeImports.Class" + , "Refactor.OrganizeImports.Fields" , "Refactor.OrganizeImports.Operator" , "Refactor.OrganizeImports.SameName" , "Refactor.OrganizeImports.Removed" , "Refactor.OrganizeImports.ReorderGroups" , "Refactor.OrganizeImports.ReorderComment" + , "Refactor.OrganizeImports.KeepCtorOfMarshalled" + , "Refactor.OrganizeImports.KeepHiding" + , "Refactor.OrganizeImports.KeepPrelude" , "Refactor.OrganizeImports.KeepReexported" , "Refactor.OrganizeImports.KeepRenamedReexported" , "Refactor.OrganizeImports.MakeExplicit.ImportOne" @@ -221,6 +244,7 @@ , "Refactor.OrganizeImports.MakeExplicit.ImportFour" , "Refactor.OrganizeImports.MakeExplicit.ImportFunHiddenClass" , "Refactor.OrganizeImports.MakeExplicit.ImportFunOutOfClass" + , "Refactor.OrganizeImports.MakeExplicit.Renamed" , "Refactor.OrganizeImports.InstanceCarry.ImportOrphan" , "Refactor.OrganizeImports.InstanceCarry.ImportNonOrphan" , "Refactor.OrganizeImports.NarrowQual" @@ -228,9 +252,10 @@ , "Refactor.OrganizeImports.StandaloneDeriving" , "Refactor.OrganizeImports.TemplateHaskell" , "Refactor.OrganizeImports.NarrowType" + , "CPP.ConditionalImport" ] - -generateSignatureTests = + +generateSignatureTests = [ ("Refactor.GenerateTypeSignature.Simple", "3:1-3:10") , ("Refactor.GenerateTypeSignature.Function", "3:1-3:15") , ("Refactor.GenerateTypeSignature.HigherOrder", "3:1-3:14") @@ -248,7 +273,7 @@ , ("Refactor.GenerateTypeSignature.CanCaptureVariableHasOtherDef", "8:10-8:10") ] -wrongGenerateSigTests = +wrongGenerateSigTests = [ ("Refactor.GenerateTypeSignature.CannotCaptureVariable", "7:10-7:10") , ("Refactor.GenerateTypeSignature.CannotCaptureVariableNoExt", "8:10-8:10") , ("Refactor.GenerateTypeSignature.ComplexLhs", "3:1") @@ -257,7 +282,7 @@ , ("Refactor.GenerateTypeSignature.ComplexLhs", "6:1") ] -generateExportsTests = +generateExportsTests = [ "Refactor.GenerateExports.Normal" , "Refactor.GenerateExports.Operators" ] @@ -289,6 +314,7 @@ , ("Refactor.RenameDefinition.RoleAnnotation", "4:11-4:12", "AA") , ("Refactor.RenameDefinition.TypeBracket", "6:6-6:7", "B") , ("Refactor.RenameDefinition.ValBracket", "8:11-8:12", "B") + , ("Refactor.RenameDefinition.FunnyDo", "3:1-3:2", "aaa") ] wrongRenameDefinitionTests = @@ -327,11 +353,13 @@ , ("Refactor.ExtractBinding.AssocOp", "3:9-3:14", "b") , ("Refactor.ExtractBinding.AssocOpRightAssoc", "3:5-3:12", "g") , ("Refactor.ExtractBinding.AssocOpMiddle", "3:9-3:14", "b") + , ("Refactor.ExtractBinding.SiblingDefs", "7:9-7:10", "a") ] -wrongExtractBindingTests = +wrongExtractBindingTests = [ ("Refactor.ExtractBinding.TooSimple", "3:19-3:20", "x") , ("Refactor.ExtractBinding.NameConflict", "3:19-3:27", "stms") + , ("Refactor.ExtractBinding.ViewPattern", "4:4-4:11", "idid") ] inlineBindingTests = @@ -354,7 +382,7 @@ , ("Refactor.InlineBinding.LetGuard", "3:9-3:10") ] -wrongInlineBindingTests = +wrongInlineBindingTests = [ ("Refactor.InlineBinding.Recursive", "4:1-4:2") , ("Refactor.InlineBinding.InExportList", "4:1-4:2") , ("Refactor.InlineBinding.NotOccurring", "3:1") @@ -400,23 +428,23 @@ , ("Refactor.DollarApp.ImportDollar", \m -> dollarApp (correctRefactorSpan m $ readSrcSpan "6:5-6:12")) ] -makeMultiModuleTest :: ((String, String, String, [String]) -> Either String [(String, Maybe String)] -> IO ()) +makeMultiModuleTest :: ((String, String, String, [String]) -> Either String [(String, Maybe String)] -> IO ()) -> (String, String, String, [String]) -> TestTree makeMultiModuleTest checker test@(refact, mod, root, removed) - = testCase (root ++ ":" ++ mod) + = testCase (root ++ ":" ++ mod) $ do res <- performRefactors refact (rootDir root) [] mod checker test res - + checkMultiResults :: (String, String, String, [String]) -> Either String [(String, Maybe String)] -> IO () checkMultiResults _ (Left err) = assertFailure $ "The transformation failed : " ++ err -checkMultiResults test@(_,_,root,removed) (Right ((name, Just mod):rest)) = +checkMultiResults test@(_,_,root,removed) (Right ((name, Just mod):rest)) = do expected <- loadExpected False ((rootDir root) ++ "_res") name assertEqual "The transformed result is not what is expected" (standardizeLineEndings expected) (standardizeLineEndings mod) checkMultiResults test (Right rest) checkMultiResults (r,m,root,removed) (Right ((name, Nothing) : rest)) = checkMultiResults (r,m,root,delete name removed) (Right rest) checkMultiResults (_,_,_,[]) (Right []) = return () -checkMultiResults (_,_,_,removed) (Right []) +checkMultiResults (_,_,_,removed) (Right []) = assertFailure $ "Modules has not been marked as removed: " ++ concat (intersperse ", " removed) checkMultiFail :: (String, String, String, [String]) -> Either String [(String, Maybe String)] -> IO () @@ -454,40 +482,40 @@ makeWrongExtractBindingTest :: (String, String, String) -> TestTree makeWrongExtractBindingTest (mod, rng, newName) = createFailTest "ExtractBinding" [rng, newName] mod - + makeInlineBindingTest :: (String, String) -> TestTree makeInlineBindingTest (mod, rng) = createTest "InlineBinding" [rng] mod - + makeWrongInlineBindingTest :: (String, String) -> TestTree makeWrongInlineBindingTest (mod, rng) = createFailTest "InlineBinding" [rng] mod - + makeFloatOutTest :: (String, String) -> TestTree makeFloatOutTest (mod, rng) = createTest "FloatOut" [rng] mod - + makeWrongFloatOutTest :: (String, String) -> TestTree makeWrongFloatOutTest (mod, rng) = createFailTest "FloatOut" [rng] mod - + checkCorrectlyTransformed :: String -> String -> String -> IO () checkCorrectlyTransformed command workingDir moduleName = do expected <- loadExpected True workingDir moduleName res <- performRefactor command workingDir [] moduleName - assertEqual "The transformed result is not what is expected" (Right (standardizeLineEndings expected)) + assertEqual "The transformed result is not what is expected" (Right (standardizeLineEndings expected)) (mapRight standardizeLineEndings res) makeMiscRefactorTest :: (String, UnnamedModule IdDom -> LocalRefactoring IdDom) -> TestTree makeMiscRefactorTest (moduleName, refact) = testCase moduleName $ do expected <- loadExpected True rootDir moduleName res <- testRefactor refact moduleName - assertEqual "The transformed result is not what is expected" (Right (standardizeLineEndings expected)) + assertEqual "The transformed result is not what is expected" (Right (standardizeLineEndings expected)) (mapRight standardizeLineEndings res) - + testRefactor :: (UnnamedModule IdDom -> LocalRefactoring IdDom) -> String -> IO (Either String String) -testRefactor refact moduleName +testRefactor refact moduleName = runGhc (Just libdir) $ do initGhcFlags useDirs [rootDir] mod <- loadModule rootDir moduleName >>= parseTyped - res <- runRefactor (SourceFileKey NormalHs moduleName, mod) [] (localRefactoring $ refact mod) + res <- runRefactor (SourceFileKey NormalHs moduleName, mod) [] (localRefactoring $ refact mod) case res of Right r -> return $ Right $ prettyPrint $ snd $ fromContentChanged $ head r Left err -> return $ Left err @@ -495,26 +523,26 @@ checkTransformFails command workingDir moduleName = do res <- performRefactor command workingDir [] moduleName assertBool "The transform should fail for the given input" (isLeft res) - + loadExpected :: Bool -> String -> String -> IO String -loadExpected resSuffix workingDir moduleName = +loadExpected resSuffix workingDir moduleName = do -- need to use binary or line endings will be translated expectedHandle <- openBinaryFile (workingDir map (\case '.' -> pathSeparator; c -> c) moduleName ++ (if resSuffix then "_res" else "") ++ ".hs") ReadMode hGetContents expectedHandle standardizeLineEndings = filter (/= '\r') - -makeReprintTest :: String -> TestTree + +makeReprintTest :: String -> TestTree makeReprintTest mod = testCase mod (checkCorrectlyPrinted rootDir mod) -makeCpphsTest :: String -> TestTree +makeCpphsTest :: String -> TestTree makeCpphsTest mod = testCase mod (checkCorrectlyPrinted (rootDir "CppHs") mod) -makeInstanceControlTest :: String -> TestTree +makeInstanceControlTest :: String -> TestTree makeInstanceControlTest mod = testCase mod (checkCorrectlyPrinted (rootDir "InstanceControl") mod) checkCorrectlyPrinted :: String -> String -> IO () -checkCorrectlyPrinted workingDir moduleName +checkCorrectlyPrinted workingDir moduleName = do -- need to use binary or line endings will be translated expectedHandle <- openBinaryFile (workingDir map (\case '.' -> pathSeparator; c -> c) moduleName ++ ".hs") ReadMode expected <- hGetContents expectedHandle @@ -524,12 +552,12 @@ actual' <- prettyPrint <$> parseRenamed parsed actual'' <- prettyPrint <$> parseTyped parsed return (actual, actual', actual'') - assertEqual "The original and the transformed source differ" expected actual - assertEqual "The original and the transformed source differ" expected actual' - assertEqual "The original and the transformed source differ" expected actual'' + assertEqual "Parsed: The original and the transformed source differ" expected actual + assertEqual "Renamed: The original and the transformed source differ" expected actual' + assertEqual "Typechecked: The original and the transformed source differ" expected actual'' performRefactors :: String -> String -> [String] -> String -> IO (Either String [(String, Maybe String)]) -performRefactors command workingDir flags target = do +performRefactors command workingDir flags target = do mods <- getAllModules [workingDir] runGhc (Just libdir) $ do initGhcFlagsForTest @@ -539,55 +567,57 @@ load LoadAllTargets allMods <- getModuleGraph selectedMod <- getModSummary (GHC.mkModuleName target) - let otherModules = filter (not . (\ms -> ms_mod ms == ms_mod selectedMod && ms_hsc_src ms == ms_hsc_src selectedMod)) allMods + let otherModules = filter (not . (\ms -> ms_mod ms == ms_mod selectedMod && ms_hsc_src ms == ms_hsc_src selectedMod)) allMods targetMod <- parseTyped selectedMod otherMods <- mapM parseTyped otherModules - res <- performCommand (readCommand command) + res <- performCommand (either error id $ readCommand command) (SourceFileKey NormalHs target, targetMod) (zip (map keyFromMS otherModules) otherMods) return $ (\case Right r -> Right $ (map (\case ContentChanged (n,m) -> (n ^. sfkModuleName, Just $ prettyPrint m) ModuleCreated n m _ -> (n, Just $ prettyPrint m) ModuleRemoved m -> (m, Nothing) )) r - Left l -> Left l) + Left l -> Left l) $ res type ParsedModule = Ann AST.UModule (Dom RdrName) SrcTemplateStage parseAST :: ModSummary -> Ghc ParsedModule parseAST modSum = do - let compExts = extensionFlags $ ms_hspp_opts modSum - hasStaticFlags = fromEnum StaticPointers `member` compExts + let hasStaticFlags = StaticPointers `xopt` ms_hspp_opts modSum + hasCppExtension = Cpp `xopt` ms_hspp_opts modSum ms = if hasStaticFlags then forceAsmGen modSum else modSum p <- parseModule ms + sourceOrigin <- if hasCppExtension then liftIO $ hGetStringBuffer (getModSumOrig ms) + else return (fromJust $ ms_hspp_buf $ pm_mod_summary p) let annots = pm_annotations p - srcBuffer = fromJust $ ms_hspp_buf $ pm_mod_summary p - prepareAST srcBuffer . placeComments (snd annots) - <$> (runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModule ms $ pm_parsed_source p) + (if hasCppExtension then prepareASTCpp else prepareAST) sourceOrigin . placeComments (fst annots) (getNormalComments $ snd annots) + <$> (runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModule ms $ pm_parsed_source p) type RenamedModule = Ann AST.UModule (Dom GHC.Name) SrcTemplateStage parseRenamed :: ModSummary -> Ghc RenamedModule parseRenamed modSum = do - let compExts = extensionFlags $ ms_hspp_opts modSum - hasStaticFlags = fromEnum StaticPointers `member` compExts + let hasStaticFlags = StaticPointers `xopt` ms_hspp_opts modSum + hasCppExtension = Cpp `xopt` ms_hspp_opts modSum ms = if hasStaticFlags then forceAsmGen modSum else modSum p <- parseModule ms + sourceOrigin <- if hasCppExtension then liftIO $ hGetStringBuffer (getModSumOrig ms) + else return (fromJust $ ms_hspp_buf $ pm_mod_summary p) tc <- typecheckModule p let annots = pm_annotations p - srcBuffer = fromJust $ ms_hspp_buf $ pm_mod_summary p - prepareAST srcBuffer . placeComments (getNormalComments $ snd annots) + (if hasCppExtension then prepareASTCpp else prepareAST) sourceOrigin . placeComments (fst annots) (getNormalComments $ snd annots) <$> (do parseTrf <- runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModule ms (pm_parsed_source p) runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModuleRename ms parseTrf - (fromJust $ tm_renamed_source tc) + (fromJust $ tm_renamed_source tc) (pm_parsed_source p)) performRefactor :: String -> FilePath -> [String] -> String -> IO (Either String String) -performRefactor command workingDir flags target = +performRefactor command workingDir flags target = runGhc (Just libdir) $ do useFlags flags ((\case Right r -> Right (newContent r); Left l -> Left l) <$> (refact =<< parseTyped =<< loadModule workingDir target)) - where refact m = performCommand (readCommand command) (SourceFileKey NormalHs target,m) [] + where refact m = performCommand (either error id $ readCommand command) (SourceFileKey NormalHs target,m) [] newContent (ContentChanged (_, newContent) : ress) = prettyPrint newContent newContent ((ModuleCreated _ newContent _) : ress) = prettyPrint newContent newContent (_ : ress) = newContent ress