haskell-tools-daemon 0.8.1.0 → 1.0.0.0
raw patch · 57 files changed
+3072/−638 lines, 57 filesdep +Cabaldep +Globdep +deepseqdep −haskell-tools-astdep ~basedep ~ghcdep ~haskell-tools-prettyprint
Dependencies added: Cabal, Glob, deepseq, fswatch, haskell-tools-builtin-refactorings, optparse-applicative, pretty, template-haskell
Dependencies removed: haskell-tools-ast
Dependency ranges changed: base, ghc, haskell-tools-prettyprint, haskell-tools-refactor, process
Files
- Language/Haskell/Tools/Daemon.hs +95/−0
- Language/Haskell/Tools/Daemon/ErrorHandling.hs +82/−0
- Language/Haskell/Tools/Daemon/GetModules.hs +265/−0
- Language/Haskell/Tools/Daemon/MapExtensions.hs +18/−0
- Language/Haskell/Tools/Daemon/Mode.hs +59/−0
- Language/Haskell/Tools/Daemon/ModuleGraph.hs +91/−0
- Language/Haskell/Tools/Daemon/Options.hs +85/−0
- Language/Haskell/Tools/Daemon/PackageDB.hs +117/−0
- Language/Haskell/Tools/Daemon/Protocol.hs +115/−0
- Language/Haskell/Tools/Daemon/Representation.hs +80/−0
- Language/Haskell/Tools/Daemon/Session.hs +305/−0
- Language/Haskell/Tools/Daemon/State.hs +48/−0
- Language/Haskell/Tools/Daemon/Update.hs +380/−0
- Language/Haskell/Tools/Daemon/Utils.hs +84/−0
- Language/Haskell/Tools/Daemon/Watch.hs +77/−0
- Language/Haskell/Tools/Refactor/Daemon.hs +0/−350
- Language/Haskell/Tools/Refactor/Daemon/PackageDB.hs +0/−73
- Language/Haskell/Tools/Refactor/Daemon/State.hs +0/−22
- examples/Project/code-gen/A.hs +6/−0
- examples/Project/code-gen/B.hs +3/−0
- examples/Project/code-gen/some-test-package.cabal +18/−0
- examples/Project/exposed-mod-as-main/A.hs +4/−0
- examples/Project/exposed-mod-as-main/some-test-package.cabal +24/−0
- examples/Project/has-ghc/A.hs +5/−0
- examples/Project/has-ghc/some-test-package.cabal +18/−0
- examples/Project/incomplete-cabal/A.hs +3/−0
- examples/Project/incomplete-cabal/B.hs +3/−0
- examples/Project/incomplete-cabal/some-test-package.cabal +18/−0
- examples/Project/load-error-multi/A.hs +3/−0
- examples/Project/load-error-multi/B.hs +5/−0
- examples/Project/load-error-multi/C.hs +5/−0
- examples/Project/load-error-multi/D.hs +5/−0
- examples/Project/multi-packages-same-module/package1/A.hs +0/−3
- examples/Project/multi-packages-same-module/package1/package1.cabal +0/−18
- examples/Project/multi-packages-same-module/package2/A.hs +0/−1
- examples/Project/multi-packages-same-module/package2/package2.cabal +0/−18
- examples/Project/paths-codegen/A.hs +7/−0
- examples/Project/paths-codegen/dist/build/autogen/Paths_some_test_package.hs +50/−0
- examples/Project/paths-codegen/dist/build/autogen/cabal_macros.h +154/−0
- examples/Project/paths-codegen/some-test-package.cabal +18/−0
- examples/Project/paths-module/A.hs +5/−0
- examples/Project/paths-module/dist/build/autogen/Paths_some_test_package.hs +50/−0
- examples/Project/paths-module/dist/build/autogen/cabal_macros.h +154/−0
- examples/Project/paths-module/some-test-package.cabal +18/−0
- examples/Project/same-module-in-two-mod-coll/A.hs +3/−0
- examples/Project/same-module-in-two-mod-coll/Main.hs +5/−0
- examples/Project/same-module-in-two-mod-coll/some-test-package.cabal +24/−0
- examples/Project/th-imports-normal/A.hs +3/−0
- examples/Project/th-imports-normal/B.hs +6/−0
- examples/Project/th-imports-normal/C.hs +8/−0
- examples/Project/th-typecheck/A.hs +4/−0
- examples/Project/two-modules/A.hs +3/−0
- examples/Project/two-modules/B.hs +3/−0
- examples/Project/two-modules/some-test-package.cabal +18/−0
- exe/Main.hs +7/−2
- haskell-tools-daemon.cabal +66/−20
- test/Main.hs +445/−131
+ Language/Haskell/Tools/Daemon.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE FlexibleContexts, MultiWayIf, OverloadedStrings, RecordWildCards, ScopedTypeVariables, TypeApplications, TypeFamilies #-} +-- | The central module for the background process of Haskell-tools. Starts the daemon process and +-- updates it for each client request in a loop. After this releases the resources and terminates. +module Language.Haskell.Tools.Daemon where + +import Control.Concurrent.MVar +import Control.Exception (catches) +import Control.Monad +import Control.Monad.State.Strict +import Control.Reference hiding (modifyMVarMasked_) +import Data.Tuple (swap) +import Data.Version (showVersion) +import Network.Socket hiding (send, sendTo, recv, recvFrom, KeepAlive) +import System.IO + +import GhcMonad (Session(..), reflectGhc) + +import Language.Haskell.Tools.Daemon.ErrorHandling (userExceptionHandlers, exceptionHandlers) +import Language.Haskell.Tools.Daemon.Mode (WorkingMode(..), socketMode) +import Language.Haskell.Tools.Daemon.Options as Options (SharedDaemonOptions(..), DaemonOptions(..)) +import Language.Haskell.Tools.Daemon.Protocol (ResponseMsg(..), ClientMessage(..)) +import Language.Haskell.Tools.Daemon.State (DaemonSessionState(..), initSession, exiting) +import Language.Haskell.Tools.Daemon.Update (updateClient, initGhcSession) +import Language.Haskell.Tools.Daemon.Watch (createWatchProcess', stopWatch) +import Language.Haskell.Tools.Refactor (IdDom, RefactoringChoice) +import Paths_haskell_tools_daemon (version) + +-- | Starts the daemon process. This will not return until the daemon stops. You can use this entry +-- point when the other endpoint of the client connection is not needed, for example, when you use +-- socket connection to connect to the daemon process. +runDaemon' :: [RefactoringChoice IdDom] -> DaemonOptions -> IO () +runDaemon' refactorings args = do store <- newEmptyMVar + runDaemon refactorings socketMode store args + +-- | Starts the daemon process. This will not return until the daemon stops. +-- The daemon process is parameterized by the refactorings you can use in it. This entry point gives +-- back the other endpoint of the connection so it can be used to run the daemon in the same process. +runDaemon :: [RefactoringChoice IdDom] -> WorkingMode a -> MVar a -> DaemonOptions -> IO () +runDaemon _ _ _ DaemonOptions{..} | daemonVersion + = putStrLn $ showVersion version +runDaemon refactorings mode connStore config@DaemonOptions{..} = withSocketsDo $ + do when (not silentMode) $ putStrLn $ "Starting Haskell Tools daemon" + hSetBuffering stdout LineBuffering + hSetBuffering stderr LineBuffering + conn <- daemonConnect mode portNumber + putMVar connStore conn + when (not silentMode) $ putStrLn $ "Connection established" + ghcSess <- initGhcSession (generateCode sharedOptions) + state <- newMVar initSession + -- set the ghc flags given by command line + case Options.ghcFlags sharedOptions of + Just flags -> void $ respondTo config refactorings ghcSess state (daemonSend mode conn) (SetGHCFlags flags) + Nothing -> return () + case projectType sharedOptions of + Just t -> void $ respondTo config refactorings ghcSess state (daemonSend mode conn) (SetPackageDB t) + Nothing -> return () + -- set up the file watch + (wp,th) <- if noWatch sharedOptions + then return (Nothing, []) + else createWatchProcess' + (watchExe sharedOptions) ghcSess state (daemonSend mode conn) + modifyMVarMasked_ state ( \s -> return s { _watchProc = wp, _watchThreads = th }) + -- start the server loop + serverLoop refactorings mode conn config ghcSess state + -- free allocated resources + case wp of Just watchProcess -> stopWatch watchProcess th + Nothing -> return () + daemonDisconnect mode conn + +-- | Starts the server loop, receiving requests from the client and updated the server state +-- according to these. +serverLoop :: [RefactoringChoice IdDom] -> WorkingMode a -> a -> DaemonOptions -> Session + -> MVar DaemonSessionState -> IO () +serverLoop refactorings mode conn options ghcSess state = + do msgs <- daemonReceive mode conn + continue <- mapM respondToMsg msgs + sessionData <- readMVar state + when (not (sessionData ^. exiting) && all (== True) continue) + $ serverLoop refactorings mode conn options ghcSess state + `catches` exceptionHandlers (serverLoop refactorings mode conn options ghcSess state) + (daemonSend mode conn . ErrorMessage) + where respondToMsg (Right req) + = do when (not (silentMode options)) $ putStrLn $ "Message received: " ++ show req + respondTo options refactorings ghcSess state (daemonSend mode conn) req + `catches` userExceptionHandlers + (\s -> daemonSend mode conn (ErrorMessage s) >> return True) + (\err hint -> daemonSend mode conn (CompilationProblem err hint) >> return True) + respondToMsg (Left msg) = do daemonSend mode conn $ ErrorMessage $ "MALFORMED MESSAGE: " ++ msg + return True + +-- | Responds to a client request by modifying the daemon and GHC state accordingly. +respondTo :: DaemonOptions -> [RefactoringChoice IdDom] -> Session -> MVar DaemonSessionState + -> (ResponseMsg -> IO ()) -> ClientMessage -> IO Bool +respondTo options refactorings ghcSess state next req + = modifyMVar state (\st -> swap <$> reflectGhc (runStateT (updateClient options refactorings next req) st) ghcSess)
+ Language/Haskell/Tools/Daemon/ErrorHandling.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE LambdaCase, ScopedTypeVariables #-} +-- | Handlers for common errors in Haskell-tools daemon. +module Language.Haskell.Tools.Daemon.ErrorHandling where + +import Bag (bagToList) +import Control.Exception +import Control.Monad (Monad(..), when) +import Data.List +import Data.Maybe (Maybe(..), catMaybes) +import Data.Tuple (snd) +import ErrUtils (ErrMsg(..)) +import HscTypes (SourceError, srcErrorMessages) +import SrcLoc (SrcSpan(..), isGoodSrcSpan) +import System.IO (IO, hPutStrLn, stderr) + +import Language.Haskell.Tools.Daemon.GetModules (UnsupportedPackage(..)) +import Language.Haskell.Tools.Refactor + +-- Handlers for exceptions specific to our application. +userExceptionHandlers :: (String -> IO a) -> ([(SrcSpan, String)] -> [String] -> IO a) -> [Handler a] +userExceptionHandlers sendError sendCompProblems = + [ Handler (\(UnsupportedPackage e) -> sendError ("There are unsupported elements in your package: " ++ e ++ " please correct them before loading them into Haskell-tools.")) + , Handler (\(UnsupportedExtension e) -> sendError ("The extension you use is not supported: " ++ e ++ ". Please check your source and cabal files for the use of that language extension.")) + , Handler (\(SpliceInsertionProblem rng e) -> sendError ("A problem occurred:" ++ e ++ "\nWhile type-checking the Template Haskell splice at: " ++ shortShowSpanWithFile rng ++ ". Some complex splices cannot be type checked for reasons currently unknown. Please simplify the splice. We are working on this problem.")) + , Handler (\case (BreakUpProblem outer rng _) -> sendError ("The program element at " ++ (if isGoodSrcSpan rng then shortShowSpanWithFile rng else shortShowSpanWithFile (RealSrcSpan outer)) ++ " could not be prepared for refactoring. The most likely reason is preprocessor usage. Only conditional compilation is supported, includes and preprocessor macros are not. If there is no preprocessor usage at the given location, there might be a weirdly placed comment causing a problem.")) + , Handler (\(TransformationProblem msg) -> sendError ("A problem occurred while preparing the program for refactoring: " ++ msg)) + , Handler (\(PrettyPrintProblem msg) -> sendError ("A problem occurred while pretty printing the result of the refactoring: " ++ msg)) + , Handler (\case (ConvertionProblem rng msg) -> sendError ("An unexpected problem occurred while converting the representation of the program element at " ++ shortShowSpanWithFile rng ++ ": " ++ msg) + (UnrootedConvertionProblem msg) -> sendError ("An unexpected problem occurred while converting between different program representations: " ++ msg)) + , Handler (uncurry sendCompProblems . getProblems) + ] + +-- | Handlers for generic exceptions: 'IOException', 'AsyncException', 'SomeException'. +exceptionHandlers :: IO () -> (String -> IO ()) -> [Handler ()] +exceptionHandlers cont sendError = + [ Handler (\(err :: IOException) -> hPutStrLn stderr $ "IO Exception caught: " ++ show err) + , Handler (\(e :: AsyncException) -> hPutStrLn stderr $ "Asynch exception caught: " ++ show e) + , Handler (\(ex :: SomeException) -> handleException ex cont) + ] + where handleException ex cont + = case handleGHCException (show ex) of + Nothing -> do hPutStrLn stderr $ "Unexpected error: " ++ show (ex :: SomeException) + sendError $ "Internal error: " ++ show ex + Just (msg, doContinue) -> sendError msg >> when doContinue cont + +getProblems :: SourceError -> ([(SrcSpan, String)], [String]) +getProblems errs = let msgs = map (\err -> (errMsgSpan err, show err)) + $ bagToList $ srcErrorMessages errs + hints = nub $ sort $ catMaybes $ map (handleSourceProblem . snd) msgs + in (msgs, hints) + +-- | Hint text and continuation suggestion for different kinds of errors based on pattern matching on error text. +handleGHCException :: String -> Maybe (String, Bool) +handleGHCException msg | "failed" `isInfixOf` msg && "C pre-processor" `isInfixOf` msg + = Just ("Failed to load the package. The cause of that is a failure of the pre-processor. " + ++ " Only conditional compilation is supported, includes and preprocessor macros are not: " ++ msg, False) +handleGHCException msg | "failed" `isInfixOf` msg && "Literate pre-processor" `isInfixOf` msg + = Just ("Haskell-tools does not handle Literate Haskell yet." + ++ " If you get this error after refactoring, you should undo the refactoring. The error message: " ++ msg, True) +handleGHCException msg | "cannot satisfy" `isInfixOf` msg + = Just ("While trying to collect the modules of the project we found the a package is not in the" + ++ " used package database. Check that you actually compiled this package with all of its components (tests, benchmarks). " + ++ "If so, make sure that it is installed with the same tools that the project is " + ++ "configured for (cabal/stack/cabal sandbox). The error message: " ++ msg, True) +handleGHCException _ = Nothing + +-- | Hint text and continuation suggestion for different kinds of source problems based on pattern matching on error text. +handleSourceProblem :: String -> Maybe String +handleSourceProblem msg | "is a package module" `isInfixOf` msg + = Just $ "A module is not found, check that the current working directory is the root of the module hierarchy. " + ++ " Also check that none of the modules are generated by parser generators or hsc files." +handleSourceProblem msg | "Failed to load interface" `isInfixOf` msg + = Just $ "Some of the required (external) modules cannot be loaded, because they are not found. Make sure that the project is " + ++ " already built, and that it is built using the same package database as it is used for refactoring." +handleSourceProblem msg | "Ambiguous interface" `isInfixOf` msg + = Just $ "Some of the required (external) modules cannot be loaded, because they are ambiguous. " + ++ "Since there is no separation between packages and package components, make sure that you do not depend " + ++ "on packages that contain modules with the same qualified name." +handleSourceProblem _ + = Just $ "While loading we found a compilation error in the source code. If it compiles normally " + ++ "using cabal or stack the problem might result from modules with same name, or " + ++ "generated files that are not up-to-date."
+ Language/Haskell/Tools/Daemon/GetModules.hs view
@@ -0,0 +1,265 @@+{-# LANGUAGE BangPatterns, FlexibleContexts, LambdaCase, RankNTypes, NamedFieldPuns, TupleSections, TypeApplications #-} +-- | Collecting modules contained in a module collection (library, executable, testsuite or +-- benchmark). Gets names, source file locations, compilation and load flags for these modules. +module Language.Haskell.Tools.Daemon.GetModules where + +import Control.Exception (Exception, throw) +import Control.Reference ((^.)) +import Data.Char (isUpper) +import Data.Function (on) +import Data.List +import qualified Data.Map as Map (fromList) +import Data.Maybe (Maybe(..), maybe, catMaybes) +import Distribution.Compiler (AbiTag(..), unknownCompilerInfo, buildCompilerId) +import Distribution.ModuleName (fromString, ModuleName, components) +import Distribution.Package (Dependency(..), PackageName(..), pkgName, unPackageName) +import Distribution.PackageDescription +import Distribution.PackageDescription.Configuration (finalizePD) +import Distribution.PackageDescription.Parse (readGenericPackageDescription) +import Distribution.System (buildPlatform) +import Distribution.Types.ComponentRequestedSpec (ComponentRequestedSpec(..)) +import Distribution.Types.UnqualComponentName (unUnqualComponentName) +import Distribution.Verbosity (silent) +import Language.Haskell.Extension as Cabal (Language(..), KnownExtension(..), Extension(..)) +import System.Directory (listDirectory, doesDirectoryExist) +import System.FilePath + +import DynFlags +import qualified DynFlags as GHC +import GHC hiding (ModuleName) + +import Language.Haskell.Tools.Daemon.MapExtensions (translateExtension, setExtensionFlag', unSetExtensionFlag') +import Language.Haskell.Tools.Daemon.Representation + +-- | Gets all ModuleCollections from a list of source directories. It also orders the source directories that are package roots so that +-- they can be loaded in the order they are defined (no backward imports). This matters in those cases because for them there can be +-- special compilation flags. +getAllModules :: [FilePath] -> IO [ModuleCollection ModuleNameStr] +getAllModules pathes = orderMCs . concat <$> mapM getModules (map normalise pathes) + +-- | Sorts model collection in an order to remove all backward references. +-- Works because module collections defined by directories cannot be recursive. +orderMCs :: [ModuleCollection k] -> [ModuleCollection k] +orderMCs = sortBy compareMCs + where compareMCs :: ModuleCollection k -> ModuleCollection k -> Ordering + compareMCs mc _ | DirectoryMC _ <- (mc ^. mcId) = GT + compareMCs _ mc | DirectoryMC _ <- (mc ^. mcId) = LT + compareMCs mc1 mc2 | (mc2 ^. mcId) `elem` (mc1 ^. mcDependencies) = GT + compareMCs mc1 mc2 | (mc1 ^. mcId) `elem` (mc2 ^. mcDependencies) = LT + compareMCs _ _ = EQ + + +-- | Get modules of the project with the indicated root directory. +-- If there is a cabal file, it uses that, otherwise it just scans the directory recursively for haskell sourcefiles. +-- Only returns the non-boot haskell modules, the boot modules will be found during loading. +getModules :: FilePath -> IO [ModuleCollection ModuleNameStr] +getModules root + = do files <- listDirectory root + case find (\p -> takeExtension p == ".cabal") files of + Just cabalFile -> modulesFromCabalFile root cabalFile + Nothing -> do mods <- modulesFromDirectory root root + return [ModuleCollection (DirectoryMC root) False root [root] [] (modKeys mods) return return []] + where modKeys mods = Map.fromList $ map (, ModuleNotLoaded NoCodeGen True) mods + +-- | 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 + if isDir + 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 (takeDirectory fileName) (dropWhile (/= '.') $ dropWhile (== '.') moduleName) + +-- | Load the module using a cabal file. The modules described in the cabal file will be loaded. +-- The flags and extensions set in the cabal file will be used by default. +modulesFromCabalFile :: FilePath -> FilePath -> IO [ModuleCollection ModuleNameStr] +-- now adding all conditional entries, regardless of flags +modulesFromCabalFile root cabal = (getModules . setupFlags <$> readGenericPackageDescription silent (root </> cabal)) + where getModules pkg = maybe [] (maybe [] (:[]) . toModuleCollection pkg) (library pkg) + ++ catMaybes (map (toModuleCollection pkg) (executables pkg)) + ++ catMaybes (map (toModuleCollection pkg) (testSuites pkg)) + ++ catMaybes (map (toModuleCollection pkg) (benchmarks pkg)) + + toModuleCollection :: ToModuleCollection tmc => PackageDescription -> tmc -> Maybe (ModuleCollection ModuleNameStr) + toModuleCollection PackageDescription{ buildType = Just Custom } _ + = throw $ UnsupportedPackage "'build-type: custom' setting in cabal file" + toModuleCollection pkg tmc + = let bi = getBuildInfo tmc + packageName = pkgName $ package pkg + in if buildable bi + then Just $ ModuleCollection (mkModuleCollKey packageName tmc) False + root + (map (normalise . (root </>)) $ hsSourceDirs bi) + (map (\(mn, fs) -> (moduleName mn, fs)) $ getModuleSourceFiles tmc) + (Map.fromList $ map modRecord $ getModuleNames tmc) + (flagsFromBuildInfo bi) + (loadFlagsFromBuildInfo bi) + (map (\(Dependency pkgName _) -> LibraryMC (unPackageName pkgName)) (targetBuildDepends bi)) + else Nothing + where modRecord mn = ( moduleName mn, ModuleNotLoaded NoCodeGen (needsToCompile tmc mn) ) + moduleName = concat . intersperse "." . components + setupFlags = either (\deps -> error $ "Missing dependencies: " ++ show deps) fst + . finalizePD [] (ComponentRequestedSpec True True) (const True) buildPlatform + (unknownCompilerInfo buildCompilerId NoAbiTag) [] + +data UnsupportedPackage = UnsupportedPackage String + deriving Show + +instance Exception UnsupportedPackage + +-- | Extract module-related information from different kind of package components (library, +-- executable, test-suite or benchmark). +class ToModuleCollection t where + -- | Creates a key for registering this package component. + mkModuleCollKey :: PackageName -> t -> ModuleCollectionId + -- | Gets the build info field from a package component. + getBuildInfo :: t -> BuildInfo + -- | Get the names of all the modules used by this package component. + getModuleNames :: t -> [ModuleName] + -- | Gets if some of the modules are defined is source files that are not in the expected + -- location or named as expected. + getModuleSourceFiles :: t -> [(ModuleName, FilePath)] + getModuleSourceFiles _ = [] + -- | Checks if a module is exposed by the package component, so it is necessary to compile. + -- Some of the components may have modules that are only conditionally imported by other modules. + needsToCompile :: t -> ModuleName -> Bool + -- | Gets the Main module in the case of executables, benchmarks and test suites. + getMain :: t -> String + getMain l = getMain' (getBuildInfo l) + +instance ToModuleCollection Library where + mkModuleCollKey pn _ = LibraryMC (unPackageName pn) + getBuildInfo = libBuildInfo + getModuleNames = explicitLibModules + needsToCompile l m = m `elem` exposedModules l + +instance ToModuleCollection Executable where + mkModuleCollKey pn exe = ExecutableMC (unPackageName pn) (unUnqualComponentName $ exeName exe) + getBuildInfo = buildInfo + getModuleNames exe = fromString (getMain exe) : exeModules exe + needsToCompile exe mn = components mn == [getMain exe] + getModuleSourceFiles exe = [(fromString (getMain exe), modulePath exe)] + +instance ToModuleCollection TestSuite where + mkModuleCollKey pn test = TestSuiteMC (unPackageName pn) (unUnqualComponentName $ testName test) + getBuildInfo = testBuildInfo + getModuleNames exe = fromString (getMain exe) : testModules exe + needsToCompile exe mn = components mn == [getMain exe] + getModuleSourceFiles exe + = case testInterface exe of + TestSuiteExeV10 _ fp -> [(fromString (getMain exe), fp)] + _ -> [] + getMain t = case testInterface t of + TestSuiteLibV09 _ mod -> intercalate "." $ components mod + _ -> getMain' (getBuildInfo t) + +instance ToModuleCollection Benchmark where + mkModuleCollKey pn test = BenchmarkMC (unPackageName pn) (unUnqualComponentName $ benchmarkName test) + getBuildInfo = benchmarkBuildInfo + getModuleNames exe = fromString (getMain exe) : benchmarkModules exe + needsToCompile exe mn = components mn == [getMain exe] + getModuleSourceFiles exe + = case benchmarkInterface exe of + BenchmarkExeV10 _ fp -> [(fromString (getMain exe), fp)] + _ -> [] + +-- | A default method of getting the main module using the ghc-options field, checking for the +-- option -main-is. +getMain' :: BuildInfo -> String +getMain' bi + = case ls of _:e:_ -> intercalate "." $ filter (isUpper . head) $ groupBy ((==) `on` (== '.')) e + _ -> "Main" + where ls = dropWhile (/= "-main-is") (concatMap snd (options bi)) + +-- | Checks if the module collection created from a folder without .cabal file. +isDirectoryMC :: ModuleCollectionId -> Bool +isDirectoryMC DirectoryMC{} = True +isDirectoryMC _ = False + +-- | Modify the dynamic flags to match the dependencies requested in the .cabal file. +applyDependencies :: [ModuleCollectionId] -> [ModuleCollectionId] -> DynFlags -> DynFlags +applyDependencies mcs deps dfs + = dfs { GHC.packageFlags = GHC.packageFlags dfs ++ (catMaybes $ map (dependencyToPkgFlag mcs) deps) } + +-- | Only use the dependencies that are explicitely enabled. (As cabal does opposed to as ghc does.) +onlyUseEnabled :: DynFlags -> DynFlags +onlyUseEnabled = GHC.setGeneralFlag' GHC.Opt_HideAllPackages + +-- | Transform dependencies of a module collection into the package flags of the GHC API +dependencyToPkgFlag :: [ModuleCollectionId] -> ModuleCollectionId -> Maybe (GHC.PackageFlag) +dependencyToPkgFlag mcs lib@(LibraryMC pkgName) + = if lib `notElem` mcs + then Just $ GHC.ExposePackage pkgName (GHC.PackageArg pkgName) (GHC.ModRenaming True []) + else Nothing +dependencyToPkgFlag _ _ = Nothing + +-- | Sets the configuration for loading all the modules from the whole project. Combines the +-- configuration of all package fragments. This solution is not perfect (it would be better to load +-- all package fragments separately), but it is how it works. See 'loadFlagsFromBuildInfo'. +setupLoadFlags :: [ModuleCollectionId] -> [FilePath] + -> [ModuleCollectionId] -> (DynFlags -> IO DynFlags) -> DynFlags -> IO DynFlags +-- need to be strict here, otherwise the previous modules cannot be garbage collected +setupLoadFlags !ids !roots !allDeps !flags dfs = applyDependencies ids allDeps . selectEnabled <$> flags dfs + where selectEnabled = if any (\((mcId,mcRoot),rest) -> isDirectoryMC mcId && isIndependentMc mcRoot rest) (breaks (zip ids roots)) + then id + else onlyUseEnabled + where breaks :: [a] -> [(a,[a])] + breaks [] = [] + breaks (e:rest) = (e,rest) : map (\(x,ls) -> (x,e:ls)) (breaks rest) + isIndependentMc root rest = not $ any (`isPrefixOf` root) (map snd rest) + +-- | Collects the compilation options and enabled extensions from Cabal's build info representation. +-- This setup will be used when loading all packages in the project. See 'setupLoadFlags'. +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 + +-- | Collects the compilation options and enabled extensions from Cabal's build info representation +-- for a single module. See 'compileInContext'. +flagsFromBuildInfo :: BuildInfo -> DynFlags -> IO DynFlags +-- the import pathes are already set globally +flagsFromBuildInfo bi@BuildInfo{ options } df + = 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 + + -- 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 ] + + setEnabled enable ext + = case translateExtension ext of + Just e -> (if enable then setExtensionFlag' else unSetExtensionFlag') e + Nothing -> id
+ Language/Haskell/Tools/Daemon/MapExtensions.hs view
@@ -0,0 +1,18 @@+-- | Mapping between Cabal's and GHC's representation of language extensions. +module Language.Haskell.Tools.Daemon.MapExtensions + ( module Language.Haskell.Tools.Daemon.MapExtensions + , module Language.Haskell.Tools.Refactor.Utils.Extensions + ) where + +import DynFlags (DynFlags, xopt_unset, xopt_set) +import Language.Haskell.TH.LanguageExtensions as GHC (Extension) +import Language.Haskell.Tools.Refactor.Utils.Extensions + +-- * 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
+ Language/Haskell/Tools/Daemon/Mode.hs view
@@ -0,0 +1,59 @@+-- | Defines different working modes for the daemon. It can work by using a socket connection +-- or channels to communicate with the client. When the daemon is used by CLI, it uses channel if +-- it communicates with an editor plugin it uses the socket connection. +module Language.Haskell.Tools.Daemon.Mode where + +import Control.Concurrent.Chan +import qualified Data.Aeson as A () +import Data.Aeson hiding ((.=)) +import Data.ByteString.Lazy.Char8 (ByteString) +import Data.ByteString.Lazy.Char8 (unpack) +import qualified Data.ByteString.Lazy.Char8 as BS +import Data.Maybe (Maybe(..), catMaybes) +import Network.Socket hiding (send, sendTo, recv, recvFrom, KeepAlive) +import Network.Socket.ByteString.Lazy (sendAll, recv) + +import Language.Haskell.Tools.Daemon.Protocol (ResponseMsg, ClientMessage) + +-- | An abstraction over the connection to the client. +data WorkingMode a = WorkingMode { daemonConnect :: Int -> IO a -- TODO: could we generalize this Int parameter nicely? + , daemonDisconnect :: a -> IO () + , daemonSend :: a -> ResponseMsg -> IO () + , daemonReceive :: a -> IO [Either String ClientMessage] + } + +-- | Connect to the client running in a separate process using socket connection +socketMode :: WorkingMode (Socket,Socket) +socketMode = WorkingMode sockConn sockDisconnect sockSend sockReceive + where + sockConn portNumber = do + sock <- socket AF_INET Stream 0 + setSocketOption sock ReuseAddr 1 + bind sock (SockAddrInet (read $ show portNumber) iNADDR_ANY) + listen sock 1 + (conn, _) <- accept sock + return (sock,conn) + sockDisconnect (sock,conn) = close conn >> close sock + sockSend (_,conn) = sendAll conn . (`BS.snoc` '\n') . encode + sockReceive (_,conn) = do + msg <- recv conn 2048 + if not $ BS.null msg -- null on TCP means closed connection + then do -- when (not isSilent) $ putStrLn $ "message received: " ++ show (unpack msg) + let msgs = BS.split '\n' msg + in return $ catMaybes $ map decodeMsg msgs + else return [] + where decodeMsg :: ByteString -> Maybe (Either String ClientMessage) + decodeMsg mess + | BS.null mess = Nothing + | otherwise = case decode mess of + Nothing -> Just $ Left $ "MALFORMED MESSAGE: " ++ unpack mess + Just req -> Just $ Right req + +-- | Connect to the client running in the same process using a channel +channelMode :: WorkingMode (Chan ResponseMsg, Chan ClientMessage) +channelMode = WorkingMode chanConn chanDisconnect chanSend chanReceive + where + chanConn _ = (,) <$> newChan <*> newChan + chanDisconnect _ = return () + chanSend (send,_) resp = writeChan send resp + chanReceive (_,recv) = (:[]) . Right <$> readChan recv
+ Language/Haskell/Tools/Daemon/ModuleGraph.hs view
@@ -0,0 +1,91 @@+-- | Creating a dependency graph of the modules loaded into a session. +-- Code copied from GHC because it is not public in GhcMake module +module Language.Haskell.Tools.Daemon.ModuleGraph + (moduleGraphNodes, getModFromNode, dependentModules, supportingModules) where + +import Control.Monad (Monad(..), Functor(..), filterM) +import qualified Data.Map as Map (fromList, Map, lookup) +import Data.Maybe (Maybe(..), mapMaybe, catMaybes) + +import Digraph as GHC +import FastString as GHC (FastString, fsLit) +import GHC +import HscTypes as GHC + +type NodeKey = (ModuleName, HscSource) +type NodeMap a = Map.Map NodeKey a +type SummaryNode = (ModSummary, Int, [Int]) + +getModFromNode :: SummaryNode -> ModSummary +getModFromNode (ms, _, _) = ms + +-- Creates the dependency graph of modules currently loaded. Used for checking which modules need +-- to be reloaded after a recompilation. +moduleGraphNodes :: Bool -> [ModSummary] + -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode) +moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVerticesOrd nodes, lookup_node) + where + numbered_summaries = zip summaries [1..] + + lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode + lookup_node hs_src mod = Map.lookup (mod, hs_src) node_map + + lookup_key :: HscSource -> ModuleName -> Maybe Int + lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod) + + node_map :: NodeMap SummaryNode + node_map = Map.fromList [ ((moduleName (ms_mod s), (ms_hsc_src s)), node) + | node@(s, _, _) <- nodes ] + + nodes :: [SummaryNode] + nodes = [ (s, key, out_keys) + | (s, key) <- numbered_summaries + , not (isBootSummary s && drop_hs_boot_nodes) + , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++ + out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++ + (-- see [boot-edges] below + if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile + then [] + else case lookup_key HsBootFile (ms_mod_name s) of + Nothing -> [] + Just k -> [k]) ] + + hs_boot_key | drop_hs_boot_nodes = HsSrcFile + | otherwise = HsBootFile + + out_edge_keys :: HscSource -> [ModuleName] -> [Int] + out_edge_keys hi_boot ms = mapMaybe (lookup_key hi_boot) ms + +summaryNodeKey :: SummaryNode -> Int +summaryNodeKey (_, k, _) = k + +ms_home_imps :: ModSummary -> [Located ModuleName] +ms_home_imps = home_imps . ms_imps + +ms_home_srcimps :: ModSummary -> [Located ModuleName] +ms_home_srcimps = home_imps . ms_srcimps + +home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName] +home_imps imps = [ lmodname | (mb_pkg, lmodname) <- imps, + isLocal mb_pkg ] + where isLocal Nothing = True + isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special + isLocal _ = False + +supportingModules :: (ModSummary -> Ghc Bool) -> Ghc [ModSummary] +supportingModules = reachedModules False + +dependentModules :: (ModSummary -> Ghc Bool) -> Ghc [ModSummary] +dependentModules = reachedModules True + +reachedModules :: Bool -> (ModSummary -> Ghc Bool) -> Ghc [ModSummary] +reachedModules dependent pred = do + let op = if dependent then transposeG else id + allMods <- getModuleGraph + selected <- filterM pred allMods + let (allModsGraph, lookup) = moduleGraphNodes False allMods + selectedMods = catMaybes $ map (\ms -> lookup (ms_hsc_src ms) (moduleName $ ms_mod ms)) selected + recompMods = map (moduleName . ms_mod . getModFromNode) $ reachablesG (op allModsGraph) selectedMods -- TODO: compare on file name + sortedMods = map getModFromNode $ reverse $ topologicalSortG allModsGraph + sortedSelectedMods = filter ((`elem` recompMods) . moduleName . ms_mod) sortedMods -- TODO: compare on file name + return sortedSelectedMods
+ Language/Haskell/Tools/Daemon/Options.hs view
@@ -0,0 +1,85 @@+module Language.Haskell.Tools.Daemon.Options + (DaemonOptions(..), parseDaemonCLI, SharedDaemonOptions(..), sharedOptionsParser) where + +import Control.Monad.Reader (MonadReader(..)) +import Data.List.Split (splitOn) +import Data.Semigroup ((<>)) +import Language.Haskell.Tools.Daemon.PackageDB (PackageDB(..)) +import Options.Applicative +import Options.Applicative.Types (ReadM(..), Parser, readerAsk) + +-- | Command line options for the daemon process. +data DaemonOptions = DaemonOptions { daemonVersion :: Bool + , portNumber :: Int + , silentMode :: Bool + , sharedOptions :: SharedDaemonOptions + } deriving Show + +-- | Command line options shared by CLI and daemon. +data SharedDaemonOptions = SharedDaemonOptions { noWatch :: Bool + , watchExe :: Maybe FilePath + , generateCode :: Bool + , disableHistory :: Bool + , ghcFlags :: Maybe [String] + , projectType :: Maybe PackageDB + } deriving Show + +parseDaemonCLI = execParser daemonCLI + +daemonCLI = info (daemonOptionsParser <**> helper) + (fullDesc + <> progDesc "Start the Haskell-tools daemon process" + <> header "ht-daemon: a background process for Haskell development tools.") + +daemonOptionsParser :: Parser DaemonOptions +daemonOptionsParser = DaemonOptions <$> version <*> port <*> silent <*> sharedOptionsParser + where version = switch (long "version" + <> short 'v' + <> help "Show the version of this software") + port = option auto + (long "port" + <> short 'p' + <> value 4123 + <> showDefault + <> help "Set the number of port where the daemon will wait for clients." + <> metavar "PORT_NUMBER") + silent = switch (long "silent" + <> short 's' + <> help "Set to disable messages from daemon.") + +sharedOptionsParser :: Parser SharedDaemonOptions +sharedOptionsParser = SharedDaemonOptions <$> noWatch <*> watch <*> generateCode <*> noHistory <*> ghcFlags <*> pkgDBFlags + where noWatch = switch (long "no-watch" + <> help "Disables file system watching.") + watch = optional . strOption + $ long "watch-exe" + <> short 'w' + <> help "The file path of the watch executable that is used to monitor file system changes." + <> metavar "WATH_PATH" + generateCode = switch (long "generate-code" + <> help "Always generate code for the modules of the loaded project.") + noHistory = switch (long "no-history" + <> help "Disables saving the performed refactorings.") + ghcFlags + = optional $ option ghcFlagsParser + (long "ghc-options" + <> short 'g' + <> metavar "GHC_OPTIONS" + <> help "Flags passed to GHC when loading the packages, separated by spaces.") + where ghcFlagsParser :: ReadM [String] + ghcFlagsParser + = ReadM $ do str <- ask + let str' = case str of '=':'"':rest -> init rest + '=':rest -> rest + '"':rest -> init rest + other -> other + return ( splitOn " " str') + pkgDBFlags = optional $ option typeParser + (long "project-type" + <> metavar "PROJECT_TYPE" + <> help "Set the project type (cabal, cabal-sandbox, stack, or explicit package database pathes separated by commas).") + where typeParser = do str <- readerAsk + case str of "cabal" -> return DefaultDB + "cabal-sandbox" -> return CabalSandboxDB + "stack" -> return StackDB + pathes -> return $ ExplicitDB (splitOn "," pathes)
+ Language/Haskell/Tools/Daemon/PackageDB.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE DeriveGeneric, MultiWayIf, ScopedTypeVariables #-} +-- | Setting the package database to use when compiling modules. The daemon must have one single +-- package database that cannot be changed after a package is loaded using that package database. +-- Available package databases are the cabal global, the cabal sandbox, the stack or one that had +-- been explicitely set by a file path. +module Language.Haskell.Tools.Daemon.PackageDB (PackageDB(..), decidePkgDB, packageDBLoc, detectAutogen) where + +import Control.Applicative (Alternative(..)) +import Control.Exception (SomeException, try) +import Control.Monad +import Data.Aeson (FromJSON(..)) +import Data.Char (isSpace) +import Data.List +import Data.Maybe +import GHC.Generics (Generic(..)) +import System.Directory +import System.Exit (ExitCode(..)) +import System.FilePath (FilePath, (</>)) +import System.Process (shell, readCreateProcessWithExitCode) + +-- | Possible package database configurations. +data PackageDB = DefaultDB -- ^ Use the global cabal package database (like when using ghc). + | CabalSandboxDB -- ^ Use the sandboxed cabal package database. + | StackDB -- ^ Use the stack package databases (local and snapshot). + | ExplicitDB { packageDBPath :: [FilePath] } -- ^ Set the package database explicitely. + deriving (Eq, Show, Generic) + +instance FromJSON PackageDB + +-- | Decide which type of project we are dealing with based on the package folders. +-- Should only be invoked if the user did not select the project-type. +decidePkgDB :: [FilePath] -> IO (Maybe PackageDB) +decidePkgDB [] = return Nothing +decidePkgDB (firstRoot:packageRoots) = do + fstRes <- decidePkgDB' firstRoot + res <- mapM decidePkgDB' packageRoots + if any (fstRes /=) res || (fstRes == CabalSandboxDB && not (null res)) + then return Nothing + else return (Just fstRes) + +decidePkgDB' :: FilePath -> IO PackageDB +decidePkgDB' root = do isSandbox <- checkSandbox + if isSandbox then return CabalSandboxDB + else do isStack <- checkStack + if isStack then return StackDB + else return DefaultDB + where + checkStack = + withCurrentDirectory root $ (fmap $ either (\(_ :: SomeException) -> False) id) $ try $ do + projRoot <- runCommandExpectOK "stack path --allow-different-user --project-root" + absPath <- canonicalizePath root + -- we only accept stack projects where the packages are (direct or indirect) subdirectories of the project root + return $ maybe False (`isPrefixOf` absPath) projRoot + checkSandbox = do + hasConfigFile <- doesFileExist (root </> "cabal.config") + hasSandboxFile <- doesFileExist (root </> "cabal.sandbox.config") + return $ hasConfigFile || hasSandboxFile + +-- | Finds the location of the package database based on the configuration. +packageDBLoc :: PackageDB -> FilePath -> IO [FilePath] +packageDBLoc DefaultDB _ = do + dbs <- runCommandExpectOK "ghc-pkg list base" + return $ maybe [] (filter (\l -> not (null l) && not (" " `isPrefixOf` l)) . lines) dbs +packageDBLoc CabalSandboxDB path = do + hasConfigFile <- doesFileExist (path </> "cabal.config") + config <- if hasConfigFile then readFile (path </> "cabal.config") + else readFile (path </> "cabal.sandbox.config") + return $ map (drop (length "package-db: ")) $ filter ("package-db: " `isPrefixOf`) $ lines config +packageDBLoc StackDB path = withCurrentDirectory path $ do + -- TODO: group the 3 calls into one for speed, split the output + globalDB <- runCommandExpectOK "stack path --allow-different-user --global-pkg-db" + snapshotDB <- runCommandExpectOK "stack path --allow-different-user --snapshot-pkg-db" + localDB <- runCommandExpectOK "stack path --allow-different-user --local-pkg-db" + return $ maybeToList localDB ++ maybeToList snapshotDB ++ maybeToList globalDB +packageDBLoc (ExplicitDB dirs) _ = return dirs + +-- | Gets the (probable) location of autogen folder depending on which type of +-- build we are using. +detectAutogen :: FilePath -> PackageDB -> IO (Maybe FilePath) +detectAutogen root DefaultDB = ifExists (root </> "dist" </> "build" </> "autogen") +detectAutogen root (ExplicitDB _) = ifExists (root </> "dist" </> "build" </> "autogen") +detectAutogen root CabalSandboxDB = ifExists (root </> "dist" </> "build" </> "autogen") +detectAutogen root StackDB = (fmap $ either (\(_ :: SomeException) -> Nothing) id) $ try $ do + dir <- withCurrentDirectory root $ do + distDir <- runCommandExpectOK "stack path --allow-different-user --dist-dir" + return $ trim (fromMaybe "" distDir) + genExists <- doesDirectoryExist (root </> dir </> "build" </> "autogen") + buildExists <- doesDirectoryExist (root </> dir </> "build") + if | genExists -> return $ Just (root </> dir </> "build" </> "autogen") + | buildExists -> do -- for some packages, the autogen folder is inside a folder named after the package + cont <- filterM doesDirectoryExist . map ((root </> dir </> "build") </>) + =<< listDirectory (root </> dir </> "build") + existing <- mapM ifExists (map (</> "autogen") cont) + return $ choose existing + | otherwise -> return Nothing + +-- | Run a command and return its result if successful display an error message otherwise. +runCommandExpectOK :: String -> IO (Maybe String) +runCommandExpectOK cmd = do + (exitCode, res, errs) <- readCreateProcessWithExitCode (shell cmd) "" + case exitCode of ExitSuccess -> return (Just $ trim res) + ExitFailure code -> do putStrLn ("The command '" ++ cmd ++ "' exited with " + ++ show code ++ ":\n" ++ errs) + return Nothing + +trim :: String -> String +trim = f . f + where f = reverse . dropWhile isSpace + +-- take the first nonempty +choose :: (Eq (f a), Alternative f) => [f a] -> f a +choose = fromMaybe empty . find (/= empty) + +ifExists :: FilePath -> IO (Maybe FilePath) +ifExists fp = do exists <- doesDirectoryExist fp + if exists then return (Just fp) + else return Nothing
+ Language/Haskell/Tools/Daemon/Protocol.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings #-} +-- | This module declares the messages that can be sent from the client to the +-- daemon engine and from the engine to the client. +module Language.Haskell.Tools.Daemon.Protocol where + +import Control.DeepSeq (NFData) +import qualified Data.Aeson as A ((.=)) +import Data.Aeson hiding ((.=)) +import GHC.Generics (Generic) + +import FastString (unpackFS) +import SrcLoc + +import Language.Haskell.Tools.Daemon.PackageDB (PackageDB) + +-- | The messages expected from the client. +data ClientMessage + = KeepAlive -- ^ A simple ping message to check that the server is running. + | Reset -- ^ A message that instructs the server to reset its internal state and re-load loaded packages. + | Handshake { clientVersion :: [Int] } + -- ^ Tells the client version and asks the servers version. + | SetPackageDB { pkgDB :: PackageDB } + -- ^ Sets the package database for the engine to use. + | AddPackages { addedPathes :: [FilePath] } + -- ^ Registers packages to the engine. They will be subject to subsequent + -- refactorings. Will cause the packages to be loaded, resulting in + -- LoadingModules, LoadedModule or CompilationProblem responses. + | RemovePackages { removedPathes :: [FilePath] } + -- ^ Deregisters the given packages from the engine. They will not be + -- subjects of further refactorings. + | SetWorkingDir { newWorkingDir :: FilePath } + -- ^ Sets the working directory for the compilation. Important when + -- compiling code that loads resources based on relative pathes. + | SetGHCFlags { ghcFlags :: [String] } + -- ^ Sets the compilation flags. The unused flags are returned via the + -- UnusedFlags response. + | PerformRefactoring { refactoring :: String + , modulePath :: FilePath + , editorSelection :: String + , details :: [String] -- ^ Additional details for the refactoring like the + -- names of generated definitions. + , shutdownAfter :: Bool -- ^ Stop the daemon after performing the refactoring. + , diffMode :: Bool -- ^ Don't change the files, send back the result as + -- a unified diff. + } + -- ^ Orders the engine to perform the refactoring on the module given + -- with the selection and details. Successful refactorings will cause re-loading of modules. + -- If 'shutdownAfter' or 'diffMode' is not set, after the refactoring, + -- modules are re-loaded, LoadingModules, LoadedModule responses are sent. + | UndoLast + -- ^ Asks the daemon to undo the last refactoring. + | Disconnect + -- ^ Stops the engine. It replies with Disconnected. + | ReLoad { addedModules :: [FilePath] + , changedModules :: [FilePath] + , removedModules :: [FilePath] + } + -- ^ Instructs the engine to re-load a changed module. + -- LoadingModules, LoadedModule responses may be sent. + | Stop -- TODO: remove + -- ^ Stops the server. OBSOLATE + deriving (Show, Generic) + +instance FromJSON ClientMessage + +-- | The possible responses that the server can give. +data ResponseMsg + = KeepAliveResponse -- ^ A response to KeepAlive + | HandshakeResponse { serverVersion :: [Int] } + -- ^ Tells the version of the server. + | ErrorMessage { errorMsg :: String } + -- ^ An error message marking internal problems or user mistakes. + -- TODO: separate internal problems and user mistakes. + | CompilationProblem { errorMarkers :: [(SrcSpan, String)] + , errorHints :: [String] + } + -- ^ A response that tells there are errors in the source code given. + | DiffInfo { diffInfo :: String } + -- ^ Information about changes that would be caused by the refactoring. + | LoadingModules { modulesToLoad :: [FilePath] } + -- ^ The traversal of the project is done, now the engine is loading the + -- given modules. + | LoadedModule { loadedModulePath :: FilePath + , loadedModuleName :: String + } + -- ^ The engine has loaded the given module. + | UnusedFlags { unusedFlags :: [String] } + -- ^ Returns the flags that are not used by the engine. + | Disconnected + -- ^ The engine has closed the connection. + deriving (Show, Generic) + +instance ToJSON ResponseMsg + +instance ToJSON SrcSpan where + toJSON (RealSrcSpan sp) = object [ "file" A..= unpackFS (srcSpanFile sp) + , "startRow" A..= srcLocLine (realSrcSpanStart sp) + , "startCol" A..= srcLocCol (realSrcSpanStart sp) + , "endRow" A..= srcLocLine (realSrcSpanEnd sp) + , "endCol" A..= srcLocCol (realSrcSpanEnd sp) + ] + toJSON _ = Null + +data UndoRefactor = RemoveAdded { undoRemovePath :: FilePath } + | RestoreRemoved { undoRestorePath :: FilePath + , undoRestoreContents :: String + } + | UndoChanges { undoChangedPath :: FilePath + , undoDiff :: FileDiff + } + deriving (Show, Generic, NFData) + +instance ToJSON UndoRefactor + +type FileDiff = [(Int, Int, String)]
+ Language/Haskell/Tools/Daemon/Representation.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE FlexibleContexts, RecordWildCards, TemplateHaskell #-} +-- | Representation of the modules and packages in the daemon session. +module Language.Haskell.Tools.Daemon.Representation where + +import Control.Reference +import Data.Function (on) +import Data.Map.Strict as Map +import Data.Maybe + +import DynFlags +import GHC + +import Language.Haskell.Tools.Refactor + +-- | The modules of a library, executable, test or benchmark. A package contains one or more module collection. +data ModuleCollection k + = ModuleCollection { _mcId :: ModuleCollectionId + , _mcLoadDone :: Bool + , _mcRoot :: FilePath + , _mcSourceDirs :: [FilePath] + , _mcModuleFiles :: [(ModuleNameStr, FilePath)] + , _mcModules :: (Map.Map k 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] + } + +modCollToSfk :: ModuleCollection ModuleNameStr -> ModuleCollection SourceFileKey +modCollToSfk ModuleCollection{..} = ModuleCollection{ _mcModules = Map.mapKeys (SourceFileKey "") _mcModules, ..} + +-- | The state of a module. +data ModuleRecord + = ModuleNotLoaded { _modRecCodeGen :: CodeGenPolicy + , _recModuleExposed :: Bool + } + | ModuleParsed { _parsedRecModule :: UnnamedModule (Dom RdrName) + , _modRecMS :: ModSummary + } + | ModuleRenamed { _renamedRecModule :: UnnamedModule (Dom GHC.Name) + , _modRecMS :: ModSummary + } + | ModuleTypeChecked { _typedRecModule :: UnnamedModule IdDom + , _modRecMS :: ModSummary + , _modRecCodeGen :: CodeGenPolicy + } + +isLoaded :: ModuleRecord -> Bool +isLoaded ModuleTypeChecked{} = True +isLoaded _ = False + +data CodeGenPolicy = NoCodeGen | InterpretedCode | GeneratedCode + deriving (Eq, Ord, Show) + +-- | An alias for module names +type ModuleNameStr = String + +-- | This data structure identifies a module collection. +data ModuleCollectionId = DirectoryMC FilePath + | LibraryMC String + | ExecutableMC String String + | TestSuiteMC String String + | BenchmarkMC String String + deriving (Eq, Ord, Show) + +instance Eq (ModuleCollection k) where + (==) = (==) `on` _mcId + +instance Show k => Show (ModuleCollection k) where + show (ModuleCollection id loaded root srcDirs mapping mods _ _ deps) + = "ModuleCollection (" ++ show id ++ ") " ++ show loaded ++ " " ++ root ++ " " ++ show srcDirs ++ " " ++ show mapping + ++ " (" ++ show mods ++ ") " ++ show deps + +makeReferences ''ModuleCollection +makeReferences ''ModuleRecord + +instance Show ModuleRecord where + show (ModuleNotLoaded code exposed) = "ModuleNotLoaded " ++ show code ++ " " ++ show exposed + show mr@(ModuleParsed {}) = "ModuleParsed (" ++ (GHC.moduleNameString $ GHC.moduleName $ GHC.ms_mod $ fromJust $ mr ^? modRecMS) ++ ")" + show mr@(ModuleRenamed {}) = "ModuleRenamed (" ++ (GHC.moduleNameString $ GHC.moduleName $ GHC.ms_mod $ fromJust $ mr ^? modRecMS) ++ ")" + show mr@(ModuleTypeChecked {}) = "ModuleTypeChecked (" ++ (GHC.moduleNameString $ GHC.moduleName $ GHC.ms_mod $ fromJust $ mr ^? modRecMS) ++ ")"
+ Language/Haskell/Tools/Daemon/Session.hs view
@@ -0,0 +1,305 @@+{-# LANGUAGE FlexibleContexts, MultiWayIf, TypeApplications #-} +-- | Common operations for managing Daemon-tools sessions, for example loading whole packages or +-- re-loading modules when they are changed. Maintains the state of the compilation with loaded +-- modules. Contains checks for compiling the modules to code when Template Haskell is used. +module Language.Haskell.Tools.Daemon.Session where + +import Control.Monad.State.Strict +import Control.Reference +import Data.Function (on) +import Data.IORef (writeIORef, readIORef) +import qualified Data.List as List +import Data.List.Split (splitOn) +import qualified Data.Map as Map +import Data.Maybe +import System.Directory (doesFileExist) +import System.FilePath + +import Digraph as GHC (flattenSCCs) +import DynFlags (DynFlags(..), xopt) +import Exception (gtry) +import GHC +import GHCi (purgeLookupSymbolCache) +import GhcMonad (modifySession) +import HscTypes +import Language.Haskell.TH.LanguageExtensions as Exts (Extension(..)) +import Linker (unload) +import Module +import NameCache (NameCache(..)) +import Packages (initPackages) + +import Language.Haskell.Tools.Daemon.GetModules (getAllModules, setupLoadFlags) +import Language.Haskell.Tools.Daemon.ModuleGraph (supportingModules, dependentModules) +import Language.Haskell.Tools.Daemon.Representation +import Language.Haskell.Tools.Daemon.State +import Language.Haskell.Tools.Daemon.Utils +import Language.Haskell.Tools.Refactor hiding (ModuleName) + +type DaemonSession a = StateT DaemonSessionState Ghc a + +-- | Load packages from the given directories. Loads modules, performs the given callback action, warns for duplicate modules. +loadPackagesFrom :: (ModSummary -> IO ()) + -> ([ModSummary] -> IO ()) + -> (DaemonSessionState -> FilePath -> IO [FilePath]) + -> [FilePath] + -> DaemonSession [SourceError] +loadPackagesFrom report loadCallback additionalSrcDirs packages = + do -- collecting modules to load + modColls <- liftIO $ getAllModules packages + st <- get + moreSrcDirs <- liftIO $ mapM (additionalSrcDirs st) packages + lift $ useDirs ((modColls ^? traversal & mcSourceDirs & traversal) ++ concat moreSrcDirs) + mcs' <- liftIO (traversal !~ locateModules $ modColls) + modify' (refSessMCs .- (++ mcs')) + mcs <- gets (^. refSessMCs) + let alreadyLoadedFiles + = concatMap (map (^. sfkFileName) . Map.keys . Map.filter (isJust . (^? typedRecModule)) . (^. mcModules)) + (filter (\mc -> (mc ^. mcRoot) `notElem` packages) mcs) + currentTargets <- map targetId <$> (lift getTargets) + lift $ mapM_ (\t -> when (targetId t `notElem` currentTargets) (addTarget t)) + (map makeTarget $ List.nubBy ((==) `on` (^. sfkFileName)) + $ List.sort $ concatMap getExposedModules mcs') + loadRes <- gtry (loadModules mcs alreadyLoadedFiles) + case loadRes of + Right mods -> do + modify (refSessMCs & traversal & filtered (\mc -> (mc ^. mcId) `elem` map (^. mcId) modColls) & mcLoadDone .= True) + compileModules report mods + Left err -> return [err] + + where getExposedModules :: ModuleCollection k -> [k] + getExposedModules + = Map.keys . Map.filter (\v -> fromMaybe True (v ^? recModuleExposed)) . (^. mcModules) + + locateModules :: ModuleCollection ModuleNameStr -> IO (ModuleCollection SourceFileKey) + locateModules mc + = mcModules !~ ((Map.fromList <$>) + . mapM (locateModule (mc ^. mcSourceDirs) (mc ^. mcModuleFiles)) + . Map.assocs) $ mc + + locateModule :: [FilePath] -> [(ModuleNameStr, FilePath)] + -> (ModuleNameStr, ModuleRecord) -> IO (SourceFileKey,ModuleRecord) + locateModule srcDirs modMaps (modName, record) + = do candidate <- createTargetCandidate srcDirs modMaps modName + return (SourceFileKey (either (const "") id candidate) modName, record) + + -- | Creates a possible target from a module name. If possible, finds the + -- corresponding source file to distinguish between modules of the same name. + createTargetCandidate :: [FilePath] -> [(ModuleNameStr, FilePath)] -> ModuleNameStr + -> IO (Either ModuleName FilePath) + createTargetCandidate srcFolders mapping modName + = wrapEither <$> filterM doesFileExist + (map (</> toFileName modName) srcFolders) + where toFileName modName + = case lookup modName mapping of + Just fileName -> fileName + Nothing -> List.intercalate [pathSeparator] (splitOn "." modName) <.> "hs" + wrapEither [] = Left (GHC.mkModuleName modName) + wrapEither (fn:_) = Right fn + + makeTarget (SourceFileKey "" modName) = Target (TargetModule (GHC.mkModuleName modName)) True Nothing + makeTarget (SourceFileKey filePath _) = Target (TargetFile filePath Nothing) True Nothing + + loadModules mcs alreadyLoaded = do + mods <- withLoadFlagsForModules mcs $ do + loadVisiblePackages -- need to update package state when setting the list of visible packages + modsForColls <- lift $ depanal [] True + let modsToParse = flattenSCCs $ topSortModuleGraph False modsForColls Nothing + actuallyCompiled = filter (\ms -> getModSumOrig ms `notElem` alreadyLoaded) modsToParse + modify' (refSessMCs .- foldl (.) id (map (insertIfMissing . keyFromMS) actuallyCompiled)) + return actuallyCompiled + liftIO $ loadCallback mods + return mods + + compileModules report mods = do + checkEvaluatedMods mods + compileWhileOk mods + where compileWhileOk [] = return [] + compileWhileOk (mod:mods) + = do res <- gtry (reloadModule report mod) + case res of + Left err -> do dependents <- lift $ dependentModules (return . (ms_mod mod ==) . ms_mod) + (err :) <$> compileWhileOk (filter ((`notElem` map ms_mod dependents) . ms_mod) mods) + Right _ -> compileWhileOk mods + + +-- | Loads the packages that are declared visible (by .cabal file). +loadVisiblePackages :: DaemonSession () +loadVisiblePackages = do + dfs <- getSessionDynFlags + (dfs', _) <- liftIO $ initPackages dfs + setSessionDynFlags dfs' -- set the package flags (only for this load session) + modify' (pkgDbFlags .= \dfs -> dfs { pkgDatabase = pkgDatabase dfs' + , pkgState = pkgState dfs' + }) -- save the package database + +-- | Get the module that is selected for refactoring and all the other modules. +getFileMods :: String -> DaemonSession ( Maybe (SourceFileKey, UnnamedModule IdDom) + , [(SourceFileKey, UnnamedModule IdDom)] ) +getFileMods fnameOrModule = do + modMaps <- gets (^? refSessMCs & traversal & mcModules) + let modules = mapMaybe (\(k,m) -> (\ms tc -> (ms, (k,tc))) <$> (m ^? modRecMS) <*> (m ^? typedRecModule)) -- not type checkable modules are ignored + $ concatMap @[] Map.assocs modMaps + (modSel, modOthers) = List.partition (\(ms,_) -> getModSumName ms == fnameOrModule + && (case ms_hsc_src ms of HsSrcFile -> True; _ -> False)) + modules + maxSufLength = maximum $ map sufLength modules + (fnSel, fnOthers) = if null modules || maxSufLength == 0 + then ([], modules) + else List.partition ((== maxSufLength) . sufLength) modules + sufLength = length . commonSuffix (splitPath fnameOrModule) . splitPath . getModSumOrig . fst + commonSuffix l1 l2 = takeWhile (uncurry (==)) $ zip (reverse l1) (reverse l2) + backup = case fnSel of + [] -> return (Nothing, map snd fnOthers) + [(_,m)] -> return (Just m, map snd fnOthers) + _:_ -> error "getFileMods: multiple modules selected" + case modSel of + [] -> backup + [(_,m)] -> return (Just m, map snd modOthers) + _:_ -> backup + +-- | Reload the modules that have been changed (given by predicate). Pefrom the callback. +reloadChangedModules :: (ModSummary -> IO a) -> ([ModSummary] -> IO ()) -> (ModSummary -> Bool) + -> DaemonSession [a] +reloadChangedModules report loadCallback isChanged = do + reachable <- getReachableModules loadCallback isChanged + checkEvaluatedMods reachable + -- remove module from session before reloading it, resolves space leak + clearModules reachable + mapM (reloadModule report) reachable + +-- | Clears the given modules from the GHC state to enable re-loading them +-- From the Haskell-tools state we only clear them individually, when their module collection is determined. +clearModules :: [ModSummary] -> DaemonSession () +clearModules [] = return () +clearModules mods = do + let reachableMods = map ms_mod_name mods + notReloaded = (`notElem` reachableMods) . GHC.moduleName . mi_module . hm_iface + env <- getSession + let hptStay = filterHpt notReloaded (hsc_HPT env) + -- clear the symbol cache for iserv + liftIO $ purgeLookupSymbolCache env + -- clear the global linker state + liftIO $ unload env (mapMaybe hm_linkable (eltsHpt hptStay)) + -- clear name cache + nameCache <- liftIO $ readIORef $ hsc_NC env + let nameCache' = nameCache { nsNames = delModuleEnvList (nsNames nameCache) (map ms_mod mods) } + liftIO $ writeIORef (hsc_NC env) nameCache' + -- clear home package table and module graph + lift $ modifySession (\s -> s { hsc_HPT = hptStay + , hsc_mod_graph = filter ((`notElem` reachableMods) . ms_mod_name) (hsc_mod_graph s) + }) + +-- | Get all modules that can be accessed from a given set of modules. Can be used to select which +-- modules need to be reloaded after a change. +getReachableModules :: ([ModSummary] -> IO ()) -> (ModSummary -> Bool) -> DaemonSession [ModSummary] +getReachableModules loadCallback selected = do + mcs <- gets (^. refSessMCs) + withLoadFlagsForModules mcs $ do + lift $ depanal [] True + sortedRecompMods <- lift $ dependentModules (return . selected) + liftIO $ loadCallback sortedRecompMods + return sortedRecompMods + +-- | Reload a given module. Perform a callback. +reloadModule :: (ModSummary -> IO a) -> ModSummary -> DaemonSession a +reloadModule report ms = do + mcs <- gets (^. refSessMCs) + ghcfl <- gets (^. ghcFlagsSet) + let codeGen = needsGeneratedCode (keyFromMS ms) mcs + mc = decideMC ms mcs + newm <- withFlagsForModule mc $ lift $ do + dfs <- liftIO $ fmap ghcfl $ mc ^. mcFlagSetup $ ms_hspp_opts ms + let ms' = ms { ms_hspp_opts = dfs } + -- some flags are cached in mod summary, so we need to override + parseTyped (case codeGen of NoCodeGen -> ms' + InterpretedCode -> forceCodeGen ms' + GeneratedCode -> forceAsmGen ms') + -- replace the module in the program database + modify' $ refSessMCs & traversal & filtered (\c -> (c ^. mcId) == (mc ^. mcId)) & mcModules + .- Map.insert (keyFromMS ms) (ModuleTypeChecked newm ms codeGen) + . removeModuleMS ms + liftIO $ report ms + +-- | Select which module collection we think the module is in +decideMC :: ModSummary -> [ModuleCollection SourceFileKey] -> ModuleCollection SourceFileKey +decideMC ms mcs = + case lookupModuleCollection ms mcs of + Just mc -> mc + Nothing -> case filter (\mc -> (mc ^. mcRoot) `List.isPrefixOf` fileName) mcs of + mc:_ -> mc + _ -> case mcs of mc:_ -> mc + [] -> error "reloadModule: module collections empty" + where fileName = getModSumOrig ms + +-- | Prepares the DynFlags for the compilation of a module +withFlagsForModule :: ModuleCollection SourceFileKey -> DaemonSession a -> DaemonSession a +withFlagsForModule mc action = do + ghcfl <- gets (^. ghcFlagsSet) + dbFlags <- gets (^. pkgDbFlags) + -- IMPORTANT: make sure that the module collection is not passed into the flags, they + -- might not be evaluated and then the reference could prevent garbage collection + -- of entire ASTs + withAlteredDynFlags (liftIO . fmap (dbFlags . ghcfl) . ((mc ^. mcFlagSetup) <=< (mc ^. mcLoadFlagSetup))) action + +-- | Prepares the DynFlags for travesing the module graph +withLoadFlagsForModules :: [ModuleCollection SourceFileKey] -> DaemonSession a -> DaemonSession a +-- IMPORTANT: make sure that a module collection is not passed into the flags, they +-- might not be evaluated and then the reference could prevent garbage collection +-- of entire ASTs +withLoadFlagsForModules mcs action = do + ghcfl <- gets (^. ghcFlagsSet) + dbFlags <- gets (^. pkgDbFlags) + withAlteredDynFlags (liftIO . fmap (dbFlags . ghcfl) + . setupLoadFlags (mcs ^? traversal & mcId) (mcs ^? traversal & mcRoot) + (mcs ^? traversal & mcDependencies & traversal) + (foldl @[] (>=>) return (mcs ^? traversal & mcLoadFlagSetup))) action + +-- | Finds out if a newly added module forces us to generate code for another one. +-- If the other is already loaded it will be reloaded. +checkEvaluatedMods :: [ModSummary] -> DaemonSession () +checkEvaluatedMods changed = do + mcs <- gets (^. refSessMCs) + -- IMPORTANT: make sure that the module collection is not passed into the flags, they + -- might not be evaluated and then the reference could prevent garbage collection + -- of entire ASTs + let lookupFlags ms = maybe return (^. mcFlagSetup) mc $ ms_hspp_opts ms + where mc = lookupModuleCollection ms mcs + (modsNeedCode, modsNeedAsm) <- lift (getEvaluatedMods changed lookupFlags) + -- specify the need of code generation for later loading + forM_ modsNeedCode (\ms -> modify $ refSessMCs .- codeGeneratedFor (keyFromMS ms) InterpretedCode) + forM_ modsNeedAsm (\ms -> modify $ refSessMCs .- codeGeneratedFor (keyFromMS ms) GeneratedCode) + let interpreted = filter (\ms -> isAlreadyLoaded (keyFromMS ms) InterpretedCode mcs) + modsNeedCode + codeGenerated = filter (\ms -> isAlreadyLoaded (keyFromMS ms) GeneratedCode mcs) modsNeedAsm + clearModules (interpreted ++ codeGenerated) + -- reload modules that have already been loaded + forM_ interpreted (codeGenForModule mcs InterpretedCode) + forM_ codeGenerated (codeGenForModule mcs GeneratedCode) + +-- | 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 :: [ModuleCollection SourceFileKey] -> CodeGenPolicy -> ModSummary -> DaemonSession () +codeGenForModule mcs codeGen ms +-- we don't need to update anything, just re-compile (we don't store the typed AST) and generate the code + = withFlagsForModule mc $ lift $ void $ parseTyped (case codeGen of InterpretedCode -> forceCodeGen ms + GeneratedCode -> forceAsmGen ms + _ -> ms) + where mc = fromMaybe (error $ "codeGenForModule: The following module is not found: " ++ getModSumName ms) + $ lookupModuleCollection ms mcs + +-- | Check which modules can be reached from the module, if it uses template haskell. +-- A definition that needs code generation can be inside a module that does not uses the +-- TemplateHaskell extension. +getEvaluatedMods :: [ModSummary] -> (ModSummary -> IO DynFlags) -> Ghc ([ModSummary],[ModSummary]) +-- We cannot really get the modules that need to be linked, because we cannot rename splice content if the +-- module is not type checked and that is impossible if the splice cannot be evaluated. +getEvaluatedMods changed additionalFlags + = do let changedModulePathes = map getModSumOrig changed + -- some flags are stored only in the module collection and are not recorded in the summary + eval <- supportingModules (\ms -> (\flags -> getModSumOrig ms `elem` changedModulePathes && TemplateHaskell `xopt` flags) + <$> liftIO (additionalFlags ms)) + asm <- supportingModules (\ms -> (\flags -> getModSumOrig ms `elem` changedModulePathes + && (StaticPointers `xopt` flags || UnboxedTuples `xopt` flags || UnboxedSums `xopt` flags)) + <$> liftIO (additionalFlags ms)) + let asmOrigs = map getModSumOrig asm + return (filter (\ms -> getModSumOrig ms `notElem` asmOrigs) eval, asm)
+ Language/Haskell/Tools/Daemon/State.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE NamedFieldPuns, RecordWildCards, TemplateHaskell #-} +module Language.Haskell.Tools.Daemon.State where + +import Control.Concurrent +import Control.Reference +import Data.Set +import GHC +import System.FSWatch.Repr + +import Language.Haskell.Tools.Daemon.PackageDB +import Language.Haskell.Tools.Daemon.Protocol +import Language.Haskell.Tools.Daemon.Representation +import Language.Haskell.Tools.Refactor + +-- | The actual state of the daemon process. Contains loaded modules and user settings. +-- The GHC state is handled separately. +data DaemonSessionState + = DaemonSessionState { _refSessMCs :: [ModuleCollection SourceFileKey] + -- ^ The package components loaded into the session. + , _packageDB :: Maybe (PackageDB, Bool) + -- ^ The package database that is selected and a flag to decide if it is forced. + , _ghcFlagsSet :: DynFlags -> DynFlags + -- ^ GHC flags for compiling modules. Overrides settings in cabal files. + , _pkgDbFlags :: DynFlags -> DynFlags + , _packageDBLocs :: [FilePath] + -- ^ The pathes where the package databases are located. + , _exiting :: Bool + -- ^ True if in the process of shutting down the session. + , _undoStack :: [[UndoRefactor]] + -- ^ True if in the process of shutting down the session. + , _watchProc :: Maybe WatchProcess + -- ^ Information about the file system watch process. + , _watchThreads :: [ThreadId] + -- ^ Extra threads started for handling the + -- information from the watch process. + , _touchedFiles :: Set FilePath + -- ^ Marks files as being modified by this process + -- Changes detected on marked files will not invalidate refactoring history. + } + +-- | An initial state of a daemon session. +initSession :: DaemonSessionState +initSession = DaemonSessionState [] Nothing id id [] False [] Nothing [] empty + +resetSession :: DaemonSessionState -> DaemonSessionState +resetSession DaemonSessionState{..} = initSession { _packageDB, _ghcFlagsSet } + +makeReferences ''DaemonSessionState
+ Language/Haskell/Tools/Daemon/Update.hs view
@@ -0,0 +1,380 @@+{-# LANGUAGE FlexibleContexts, LambdaCase, MultiWayIf, RecordWildCards, TupleSections, TypeApplications, TypeFamilies #-} +-- | Resolves how the daemon should react to individual requests from the client. +module Language.Haskell.Tools.Daemon.Update (updateClient, updateForFileChanges, initGhcSession) where + +import Control.DeepSeq (force) +import Control.Exception (evaluate) +import Control.Monad +import Control.Monad.State.Strict +import Control.Reference hiding (modifyMVarMasked_) +import Data.Algorithm.Diff (Diff(..), getGroupedDiff) +import Data.Algorithm.DiffContext (prettyContextDiff, getContextDiff) +import qualified Data.ByteString.Char8 as StrictBS (unpack, readFile) +import Data.Either (Either(..), either, rights) +import Data.IORef (readIORef, newIORef) +import Data.List as List hiding (insert) +import qualified Data.Map as Map (insert, keys, filter) +import Data.Maybe +import qualified Data.Set as Set (fromList, isSubsetOf, (\\)) +import Data.Version (Version(..)) +import System.Directory +import System.FSWatch.Slave (watch) +import System.FilePath (FilePath, takeDirectory, takeExtension) +import System.IO +import System.IO.Strict as StrictIO (hGetContents) +import Text.PrettyPrint as PP (text, render) + +import DynFlags (DynFlags(..), PkgConfRef(..), PackageDBFlag(..)) +import GHC hiding (loadModule) +import GHC.Paths ( libdir ) +import GhcMonad (GhcMonad(..), Session(..), modifySession) +import HscTypes (hsc_mod_graph) +import Language.Haskell.Tools.Daemon.ErrorHandling (getProblems) +import Language.Haskell.Tools.Daemon.Options (SharedDaemonOptions(..), DaemonOptions(..)) +import Language.Haskell.Tools.Daemon.PackageDB (decidePkgDB, packageDBLoc, detectAutogen) +import Language.Haskell.Tools.Daemon.Protocol +import Language.Haskell.Tools.Daemon.Representation as HT +import Language.Haskell.Tools.Daemon.Session +import Language.Haskell.Tools.Daemon.State +import Language.Haskell.Tools.Daemon.Utils +import Language.Haskell.Tools.PrettyPrint (prettyPrint) +import Language.Haskell.Tools.Refactor +import Linker (unload) +import Packages (initPackages) +import Paths_haskell_tools_daemon (version) + +-- | Context for responding to a user request. +data UpdateCtx = UpdateCtx { options :: DaemonOptions + , refactorings :: [RefactoringChoice IdDom] + , response :: ResponseMsg -> IO () + } + +-- | This function does the real job of acting upon client messages in a stateful environment of a +-- client. +updateClient :: DaemonOptions -> [RefactoringChoice IdDom] -> (ResponseMsg -> IO ()) -> ClientMessage + -> DaemonSession Bool +updateClient options refactors resp = updateClient' (UpdateCtx options refactors resp) + +updateClient' :: UpdateCtx -> ClientMessage -> DaemonSession Bool +-- resets the internal state of Haskell-tools (but keeps options) +updateClient' UpdateCtx{..} Reset + = do roots <- gets (^? refSessMCs & traversal & mcRoot) + modify' $ resetSession + Session sess <- liftIO $ initGhcSession (generateCode (sharedOptions options)) + env <- liftIO $ readIORef sess + liftIO $ unload env [] -- clear (unload everything) the global state of the linker + lift $ setSession env + addPackages response roots + return True + +updateClient' UpdateCtx{..} (Handshake _) + = do liftIO (response $ HandshakeResponse $ versionBranch version) + return True + +updateClient' UpdateCtx{..} KeepAlive + = do liftIO (response KeepAliveResponse) + return True + +updateClient' UpdateCtx{..} Disconnect + = do liftIO (response Disconnected) + return False + +updateClient' UpdateCtx{..} (SetPackageDB pkgDB) + = do mcs <- gets (^. refSessMCs) + if null mcs + then modify' (packageDB .= Just (pkgDB, True)) + else liftIO $ response $ ErrorMessage "The package database is already in use and cannot be changed." + return True + +updateClient' UpdateCtx{..} (AddPackages packagePathes) + = do addPackages response packagePathes + return True + +updateClient' _ (SetWorkingDir fp) + = do liftIO (setCurrentDirectory fp) + return True + +updateClient' UpdateCtx{..} (SetGHCFlags flags) + = do (unused, change) <- lift (useFlags flags) + when (not $ null unused) $ liftIO $ response $ UnusedFlags unused + modify' $ ghcFlagsSet .= change + return True + +updateClient' UpdateCtx{..} (RemovePackages packagePathes) = do + mcs <- gets (^. refSessMCs) + let existingFiles = concatMap @[] (map (^. sfkFileName) . Map.keys) (mcs ^? traversal & filtered isRemoved & mcModules) + lift $ forM_ existingFiles (\fs -> removeTarget (TargetFile fs Nothing)) + lift $ deregisterDirs (mcs ^? traversal & filtered isRemoved & mcSourceDirs & traversal) + modify' $ refSessMCs .- filter (not . isRemoved) + modifySession (\s -> s { hsc_mod_graph = filter ((`notElem` existingFiles) . getModSumOrig) (hsc_mod_graph s) }) + mcs <- gets (^. refSessMCs) + when (null mcs) $ modify' (packageDB .= Nothing) + return True + where isRemoved mc = (mc ^. mcRoot) `elem` packagePathes + +updateClient' UpdateCtx{..} UndoLast | disableHistory $ sharedOptions options + = do liftIO $ response $ ErrorMessage "Recording history has been disabled from command line." + return True +updateClient' UpdateCtx{..} UndoLast = + do undos <- gets (^. undoStack) + case undos of + [] -> do liftIO $ response $ ErrorMessage "There is nothing to undo. Please note that the refactoring history is cleared after manual changes in the refactored files." + return True + lastUndo:_ -> do + modify (undoStack .- tail) + liftIO $ mapM_ performUndo lastUndo + reloadModules response (getUndoAdded lastUndo) + (getUndoChanged lastUndo) + (getUndoRemoved lastUndo) -- reload the reverted files + return True + +updateClient' UpdateCtx{..} (ReLoad added changed removed) + = do updateForFileChanges response added changed removed + return True + +updateClient' _ Stop + = do modify (exiting .= True) + return False + +-- TODO: perform refactorings without selected modules +updateClient' UpdateCtx{..} (PerformRefactoring refact modPath selection args shutdown diffMode) + = do (selectedMod, otherMods) <- getFileMods modPath + performRefactoring (refact:selection:args) + (maybe (Left modPath) Right selectedMod) otherMods + when shutdown $ liftIO $ response Disconnected + return (not shutdown) + where performRefactoring cmd actualMod otherMods = do + res <- lift $ performCommand refactorings cmd actualMod otherMods + case res of + Left err -> liftIO $ response $ ErrorMessage err + Right diff -> do changedMods <- applyChanges diff + if not diffMode + then when (not (disableHistory $ sharedOptions options)) $ updateHistory changedMods + else liftIO $ response $ DiffInfo (concatMap (either snd (^. _4)) changedMods) + isWatching <- gets (isJust . (^. watchProc)) + if not isWatching && not shutdown && not diffMode + -- if watch is on, then it will automatically + -- reload changed files, otherwise we do it manually + then void $ reloadChanges (map ((^. sfkFileName) . (^. _1)) (rights changedMods)) + else modify (touchedFiles .= Set.fromList (map ((^. sfkFileName) . (^. _1)) (rights changedMods))) + + applyChanges changes = do + forM changes $ \case + ModuleCreated n m otherM -> do + mcs <- gets (^. refSessMCs) + Just (_, otherMR) <- gets (lookupModInSCs otherM . (^. refSessMCs)) + let Just otherMS = otherMR ^? modRecMS + Just mc = lookupModuleColl (otherM ^. sfkModuleName) mcs + otherSrcDir <- liftIO $ getSourceDir otherMS + let loc = toFileName otherSrcDir n + let newCont = prettyPrint m + when (not diffMode) $ do + modify' $ refSessMCs & traversal & filtered (\mc' -> (mc' ^. mcId) == (mc ^. mcId)) & mcModules + .- Map.insert (SourceFileKey loc n) (ModuleNotLoaded NoCodeGen False) + liftIO $ withBinaryFile loc WriteMode $ \handle -> do + hSetEncoding handle utf8 + hPutStr handle newCont + hFlush handle + lift $ addTarget (Target (TargetFile loc Nothing) True Nothing) + return $ Right (SourceFileKey loc n, loc, RemoveAdded loc, createUnifiedDiff loc "" newCont) + ContentChanged (n,m) -> do + let newCont = prettyPrint m + file = n ^. sfkFileName + origCont <- liftIO $ withBinaryFile file ReadMode $ \handle -> do + hSetEncoding handle utf8 + StrictIO.hGetContents handle + let undo = createUndo 0 $ getGroupedDiff origCont newCont + let unifiedDiff = createUnifiedDiff file origCont newCont + when (not diffMode) $ do + liftIO $ withBinaryFile file WriteMode $ \handle -> do + hSetEncoding handle utf8 + hPutStr handle newCont + hFlush handle + return $ Right (n, file, UndoChanges file undo, unifiedDiff) + ModuleRemoved mod -> do + Just (sfk,_) <- gets (lookupModuleInSCs mod . (^. refSessMCs)) + let file = sfk ^. sfkFileName + origCont <- liftIO (StrictBS.unpack <$> StrictBS.readFile file) + when (not diffMode) $ do + lift $ removeTarget (TargetFile file Nothing) + modify' $ (refSessMCs .- removeModule mod) + liftIO $ removeFile file + return $ Left (RestoreRemoved file origCont, createUnifiedDiff file origCont "") + + reloadChanges changedMods + = reloadChangedModules (\ms -> response (LoadedModule (getModSumOrig ms) (getModSumName ms))) + (\mss -> response (LoadingModules (map getModSumOrig mss))) + (\ms -> getModSumOrig ms `elem` changedMods) + + updateHistory :: [Either (UndoRefactor, b) (SourceFileKey, FilePath, UndoRefactor, String)] -> DaemonSession () + updateHistory changedMods + = do modify (undoStack .- (map (either fst (^. _3)) changedMods :)) + -- force the evaluation of the undo stack to prevent older versions of + -- modules seeming to be used when they could be garbage collected + us <- gets (^. undoStack) + liftIO $ evaluate $ force us + return () + +addPackages :: (ResponseMsg -> IO ()) -> [FilePath] -> DaemonSession () +addPackages _ [] = return () +addPackages resp packagePathes = do + roots <- liftIO $ mapM canonicalizePath packagePathes + nonExisting <- filterM ((return . not) <=< liftIO . doesDirectoryExist) roots + DaemonSessionState {..} <- get + if (not (null nonExisting)) + then liftIO $ resp $ ErrorMessage $ "The following packages are not found: " ++ concat (intersperse ", " nonExisting) + else do + forM_ roots watchNew -- put a file system watch on each package + -- clear existing removed packages + existingMCs <- gets (^. refSessMCs) + let existing = (existingMCs ^? traversal & filtered (isTheAdded roots) & mcModules & traversal & modRecMS) + existingModNames = map ms_mod existing + needToReload <- (filter (\ms -> not $ ms_mod ms `elem` existingModNames)) + <$> getReachableModules (\_ -> return ()) (\ms -> ms_mod ms `elem` existingModNames) + modify' $ refSessMCs .- filter (not . isTheAdded roots) -- remove the added package from the database + forM_ existing $ \ms -> removeTarget (TargetFile (getModSumOrig ms) Nothing) + modifySession (\s -> s { hsc_mod_graph = filter (not . (`elem` existingModNames) . ms_mod) (hsc_mod_graph s) }) + -- load new modules + pkgDBok <- initializePackageDBIfNeeded roots + if pkgDBok then do + errs <- loadPackagesFrom + (\ms -> resp (LoadedModule (getModSumOrig ms) (getModSumName ms))) + (resp . LoadingModules . map getModSumOrig) + (\st fp -> maybe (return []) (fmap maybeToList . detectAutogen fp . fst) (st ^. packageDB)) roots + mapM_ (liftIO . resp . uncurry CompilationProblem . getProblems) errs -- handle source errors here to prevent rollback on the tool state + when (null errs) + $ mapM_ (reloadModule (\_ -> return ())) needToReload -- don't report consequent reloads (not expected) + + else liftIO $ resp $ ErrorMessage $ "Attempted to load two packages with different package DB. " + ++ "Stack, cabal-sandbox and normal packages cannot be combined" + where isTheAdded roots mc = (mc ^. mcRoot) `elem` roots + initializePackageDBIfNeeded roots = do + db <- dbSetup roots + case db of + Nothing -> return False + Just (pkgDB, _) -> do + locs <- liftIO $ packageDBLoc pkgDB (head roots) + usePackageDB locs + modify' (packageDBLocs .= locs) + return True + dbSetup roots = do + pkgDB <- gets (^. packageDB) + case pkgDB of Nothing -> do db <- liftIO $ decidePkgDB roots + modify (packageDB .= fmap (, False) db) + return (fmap (, False) db) + Just (_, True) -> return pkgDB + Just (db, False) -> do newDB <- liftIO $ decidePkgDB roots + if newDB == Just db then return pkgDB + else return Nothing + +-- | Updates the state of the tool after some files have been changed (possibly by another application) +updateForFileChanges :: (ResponseMsg -> IO ()) -> [FilePath] -> [FilePath] -> [FilePath] -> DaemonSession () +updateForFileChanges resp added changed removed = do + -- clear undo stack if the changes are from another application + refactoredFiles <- gets (^. touchedFiles) + let changeSet = Set.fromList (added ++ changed ++ removed) + when (not $ changeSet `Set.isSubsetOf` refactoredFiles) + $ modify (undoStack .= []) -- clear the undo stack, if this changeset is not a result of a refactoring + -- check for module collections that failed to load + mcs <- gets (^. refSessMCs) + let packagesNotLoaded = filter (not . (^. mcLoadDone)) mcs + tryLoadAgain = filter (\r -> List.any (r `isPrefixOf`) (added ++ changed ++ removed)) $ map (^. mcRoot) packagesNotLoaded + -- check for changes in .cabal files + modify (touchedFiles .- (Set.\\ changeSet)) + let changedPackages = map takeDirectory + $ filter (\fp -> takeExtension fp == ".cabal") + $ added ++ changed ++ removed + reloadedPackages = tryLoadAgain ++ changedPackages + packageNotReloaded fp = not $ any (`isPrefixOf` fp) reloadedPackages + addPackages resp reloadedPackages -- reload packages if needed + -- reload the rest of the modules + reloadModules resp (filter packageNotReloaded added) (filter packageNotReloaded changed) + (filter packageNotReloaded removed) + +-- | Reloads changed modules to have an up-to-date version loaded +reloadModules :: (ResponseMsg -> IO ()) -> [FilePath] -> [FilePath] -> [FilePath] -> DaemonSession () +reloadModules _ [] [] [] = return () +reloadModules resp added changed removed = do + lift $ forM_ removed (\src -> removeTarget (TargetFile src Nothing)) + -- remove targets deleted + modify' $ refSessMCs & traversal & mcModules + .- Map.filter (\m -> maybe True ((`notElem` removed) . getModSumOrig) (m ^? modRecMS)) + modifySession (\s -> s { hsc_mod_graph = filter (\mod -> getModSumOrig mod `notElem` removed) (hsc_mod_graph s) }) + -- reload changed modules + -- TODO: filter those that are in reloaded packages + reloadChangedModules (\ms -> resp (LoadedModule (getModSumOrig ms) (getModSumName ms))) + (\mss -> resp (LoadingModules (map getModSumOrig mss))) + (\ms -> getModSumOrig ms `elem` changed) + mcs <- gets (^. refSessMCs) + let mcsToReload = filter (\mc -> any ((mc ^. mcRoot) `isPrefixOf`) added && isNothing (moduleCollectionPkgId (mc ^. mcId))) mcs + addPackages resp (map (^. mcRoot) mcsToReload) -- reload packages containing added modules + +-- | Creates a compressed set of changes in one file +createUndo :: Eq a => Int -> [Diff [a]] -> [(Int, Int, [a])] +createUndo i (Both str _ : rest) = createUndo (i + length str) rest +createUndo i (First rem : Second add : rest) + = (i, i + length add, rem) : createUndo (i + length add) rest +createUndo i (First rem : rest) = (i, i, rem) : createUndo i rest +createUndo i (Second add : rest) + = (i, i + length add, []) : createUndo (i + length add) rest +createUndo _ [] = [] + +-- | Creates a unified-style diff of two texts. Only used when the user wants to know what would change. +createUnifiedDiff :: FilePath -> String -> String -> String +createUnifiedDiff name left right + = render $ prettyContextDiff (PP.text name) (PP.text name) PP.text $ getContextDiff 3 (lines left) (lines right) + +-- | Undo a refactoring change using the information that was saved earlier. +performUndo :: UndoRefactor -> IO () +performUndo (RemoveAdded fp) = removeFile fp +performUndo (RestoreRemoved fp cont) + = liftIO $ withBinaryFile fp WriteMode $ \handle -> do + hSetEncoding handle utf8 + hPutStr handle cont +performUndo (UndoChanges fp changes) = do + cont <- liftIO $ withBinaryFile fp ReadMode $ \handle -> do + hSetEncoding handle utf8 + StrictIO.hGetContents handle + liftIO $ withBinaryFile fp WriteMode $ \handle -> do + hSetEncoding handle utf8 + hPutStr handle (performUndoChanges 0 changes cont) + +-- | Undo the changes in one file using the information that was saved earlier. See 'createUndo'. +performUndoChanges :: Int -> FileDiff -> String -> String +performUndoChanges i ((start,end,replace):rest) str | i == start + = replace ++ performUndoChanges end rest (drop (end-start) str) +performUndoChanges i diffs (c:str) = c : performUndoChanges (i+1) diffs str +performUndoChanges _ _ [] = [] + +-- | Get the files added by a refactoring. +getUndoAdded :: [UndoRefactor] -> [FilePath] +getUndoAdded = catMaybes . map (\case RestoreRemoved fp _ -> Just fp + _ -> Nothing) + +-- | Get the files changed by a refactoring. +getUndoChanged :: [UndoRefactor] -> [FilePath] +getUndoChanged = catMaybes . map (\case UndoChanges fp _ -> Just fp + _ -> Nothing) + +-- | Get the files removed by a refactoring. +getUndoRemoved :: [UndoRefactor] -> [FilePath] +getUndoRemoved = catMaybes . map (\case RemoveAdded fp -> Just fp + _ -> Nothing) + +initGhcSession :: Bool -> IO Session +initGhcSession genCode = Session <$> (newIORef =<< runGhc (Just libdir) (initGhcFlags' genCode >> getSession)) + +usePackageDB :: GhcMonad m => [FilePath] -> m () +usePackageDB [] = return () +usePackageDB pkgDbLocs + = do dfs <- getSessionDynFlags + dfs' <- liftIO $ fmap fst $ initPackages + $ dfs { packageDBFlags = map (PackageDB . PkgConfFile) pkgDbLocs ++ packageDBFlags dfs + , pkgDatabase = Nothing + } + void $ setSessionDynFlags dfs' + +watchNew :: FilePath -> DaemonSession () +watchNew fp = do + wt <- gets (^. watchProc) + maybe (return ()) (\w -> watch w fp) wt
+ Language/Haskell/Tools/Daemon/Utils.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE FlexibleContexts, RankNTypes #-} +-- | Utility operations for the reprsentation of module collections. +module Language.Haskell.Tools.Daemon.Utils where + +import Control.Applicative (Alternative(..)) +import Control.Reference +import Data.List +import qualified Data.Map as Map +import Data.Maybe +import GHC (ModSummary(..)) + +import Language.Haskell.Tools.Daemon.Representation +import Language.Haskell.Tools.Refactor + +-- | Get the name of a module collection from its Id. +moduleCollectionPkgId :: ModuleCollectionId -> Maybe String +moduleCollectionPkgId (DirectoryMC _) = Nothing +moduleCollectionPkgId (LibraryMC id) = Just id +moduleCollectionPkgId (ExecutableMC id _) = Just id +moduleCollectionPkgId (TestSuiteMC id _) = Just id +moduleCollectionPkgId (BenchmarkMC id _) = Just id + +-- TODO: check that these are all needed and they are used right. + +-- | Find the module collection where the given module is contained. Based on module name. +lookupModuleColl :: String -> [ModuleCollection SourceFileKey] -> Maybe (ModuleCollection SourceFileKey) +lookupModuleColl moduleName = find (any ((moduleName ==) . (^. sfkModuleName)) . Map.keys . (^. mcModules)) + +-- | Find the module collection where the given module is contained. Based on source file name. +lookupSourceFileColl :: FilePath -> [ModuleCollection SourceFileKey] -> Maybe (ModuleCollection SourceFileKey) +lookupSourceFileColl fp = find (any ((fp ==) . (^. sfkFileName)) . Map.keys . (^. mcModules)) + +-- | Find the module collection where the given module is contained. Based on source file name and module name. +lookupModuleCollection :: ModSummary -> [ModuleCollection SourceFileKey] -> Maybe (ModuleCollection SourceFileKey) +lookupModuleCollection ms mcs = lookupSourceFileColl (getModSumOrig ms) mcs <|> lookupModuleColl (getModSumName ms) mcs + +-- | Find the module with the given name. Based on module name. +lookupModuleInSCs :: String -> [ModuleCollection SourceFileKey] -> Maybe (SourceFileKey, ModuleRecord) +lookupModuleInSCs moduleName = find ((moduleName ==) . (^. sfkModuleName) . fst) . concatMap (Map.assocs . (^. mcModules)) + +-- | Find the module with the given name. Based on source file name. +lookupModInSCs :: SourceFileKey -> [ModuleCollection SourceFileKey] -> Maybe (SourceFileKey, ModuleRecord) +lookupModInSCs key = find (((key ^. sfkFileName) ==) . (^. sfkFileName) . fst) . concatMap (Map.assocs . (^. mcModules)) + +-- | Get the module with the given name and source file key. +lookupSFKInSCs :: SourceFileKey -> [ModuleCollection SourceFileKey] -> Maybe ModuleRecord +lookupSFKInSCs key = listToMaybe . catMaybes . map (Map.lookup key . (^. mcModules)) + +-- | Remove a module with the given name. Based on module name. +removeModule :: String -> [ModuleCollection SourceFileKey] -> [ModuleCollection SourceFileKey] +removeModule moduleName = map (mcModules .- Map.filterWithKey (\k _ -> moduleName /= (k ^. sfkModuleName))) + +-- | Remove a module with the given name from a module collection. Based on module name and file path. +removeModuleMS :: ModSummary -> Map.Map SourceFileKey ModuleRecord -> Map.Map SourceFileKey ModuleRecord +removeModuleMS ms = Map.filterWithKey (\k _ -> stay k) + where stay k = getModSumName ms /= (k ^. sfkModuleName) || (fn /= getModSumOrig ms && fn /= "") + where fn = k ^. sfkFileName + +-- | Check if the given module needs code generation. Finds the module if no source file name is +-- present and module names check or if both module names and source file names check. +needsGeneratedCode :: SourceFileKey -> [ModuleCollection SourceFileKey] -> CodeGenPolicy +needsGeneratedCode key mcs = fromMaybe NoCodeGen + $ (^? modRecCodeGen) + =<< (lookupSFKInSCs key mcs <|> lookupSFKInSCs (sfkFileName .= "" $ key) mcs) + +-- | Marks the given module for code generation. Finds the module if no source file name is +-- present and module names check or if both module names and source file names check. +-- Idempotent operation. +codeGeneratedFor :: SourceFileKey -> CodeGenPolicy -> [ModuleCollection SourceFileKey] -> [ModuleCollection SourceFileKey] +codeGeneratedFor key codeGen = map (mcModules .- Map.adjust (modRecCodeGen .= codeGen) (sfkFileName .= "" $ key) + . Map.adjust (modRecCodeGen .= codeGen) key) + +-- | Check if the given module has been already loaded. Based on both module name and source +-- file name. +isAlreadyLoaded :: SourceFileKey -> CodeGenPolicy -> [ModuleCollection SourceFileKey] -> Bool +isAlreadyLoaded key codeGen = maybe False (\(_, mc) -> isLoaded mc && (mc ^? modRecCodeGen) < Just codeGen) + . find ((key ==) . fst) . concatMap (Map.assocs . (^. mcModules)) + +-- | Insert a module with a source file key to our database if it wasn't there already +insertIfMissing :: SourceFileKey -> [ModuleCollection SourceFileKey] -> [ModuleCollection SourceFileKey] +insertIfMissing sfk mods + = case lookupSFKInSCs sfk mods of + Just _ -> mods + Nothing -> element 0 & mcModules .- Map.insert sfk (ModuleNotLoaded NoCodeGen False) $ mods
+ Language/Haskell/Tools/Daemon/Watch.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-} +-- | Controls the file system watching in the daemon. The file system watching must run in a +-- separate process to prevent blocking because of file operations interfering with watch. +module Language.Haskell.Tools.Daemon.Watch where + +import Control.Concurrent +import Control.Exception (catches) +import Control.Monad +import Control.Monad.State.Strict +import qualified Data.Aeson as A () +import Data.Maybe (Maybe(..), catMaybes, isNothing) +import Data.Tuple (swap) +import GhcMonad (Session(..), reflectGhc) +import System.Environment (getExecutablePath) +import System.FSWatch.Repr (WatchProcess(..), PE(..)) +import System.FSWatch.Slave (waitNotifies, createWatchProcess) +import System.FilePath +import System.IO (IO, FilePath) + +import Language.Haskell.Tools.Daemon.ErrorHandling (userExceptionHandlers, exceptionHandlers) +import Language.Haskell.Tools.Daemon.Protocol (ResponseMsg(..)) +import Language.Haskell.Tools.Daemon.State (DaemonSessionState) +import Language.Haskell.Tools.Daemon.Update (updateForFileChanges) + +-- | Starts the watch process and a thread that receives notifications from it. The notification +-- thread will invoke updates on the daemon state to re-load files. +createWatchProcess' :: Maybe FilePath -> Session -> MVar DaemonSessionState -> (ResponseMsg -> IO ()) + -> IO (Maybe WatchProcess, [ThreadId]) +createWatchProcess' watchExePath ghcSess daemonSess upClient = do + exePath <- case watchExePath of Just exe -> return exe + Nothing -> guessExePath + process <- createWatchProcess exePath 500 + initProcess process + where + initProcess process = do + reloaderThread <- forkIO $ forever $ void $ do + changes <- waitForChanges process + putStrLn $ "changes: " ++ show changes + let changedFiles = catMaybes $ map getModifiedFile changes + addedFiles = catMaybes $ map getAddedFile changes + removedFiles = catMaybes $ map getRemovedFile changes + reloadAction = updateForFileChanges upClient addedFiles changedFiles removedFiles + handlers = userExceptionHandlers + (upClient . ErrorMessage) + (\err hint -> upClient (CompilationProblem err hint)) + ++ exceptionHandlers (return ()) (upClient . ErrorMessage) + when (length changedFiles + length addedFiles + length removedFiles > 0) + (void (modifyMVar daemonSess (\st -> swap <$> reflectGhc (runStateT reloadAction st) ghcSess)) + `catches` handlers) + return $ (Just process, [reloaderThread]) + + waitForChanges process = do + changes <- waitNotifies process + refactoring <- isNothing <$> tryReadMVar daemonSess + -- if a refactoring is in progress, we should wait for all the changes to appear + if refactoring then (changes ++) <$> waitForChanges process + else return changes + + getModifiedFile (Mod file) | takeExtension file `elem` sourceExtensions = Just file + getModifiedFile _ = Nothing + + getAddedFile (Add file) | takeExtension file `elem` sourceExtensions = Just file + getAddedFile _ = Nothing + + getRemovedFile (Rem file) | takeExtension file `elem` sourceExtensions = Just file + getRemovedFile _ = Nothing + + sourceExtensions = [ ".hs", ".hs-boot", ".cabal" ] + + guessExePath = do exePath <- getExecutablePath + return $ takeDirectory exePath </> "hfswatch" + +-- | Stops the watch process and all threads associated with it. +stopWatch :: WatchProcess -> [ThreadId] -> IO () +stopWatch WatchProcess{..} threads + = do forM threads killThread + wShutdown
− Language/Haskell/Tools/Refactor/Daemon.hs
@@ -1,350 +0,0 @@-{-# LANGUAGE ScopedTypeVariables - , OverloadedStrings - , DeriveGeneric - , LambdaCase - , TemplateHaskell - , FlexibleContexts - , MultiWayIf - , TypeApplications - #-} -module Language.Haskell.Tools.Refactor.Daemon where - -import Control.Applicative ((<|>)) -import Control.Concurrent.MVar -import Control.Exception -import Control.Monad -import Control.Monad.State.Strict -import Control.Reference -import qualified Data.Aeson as A ((.=)) -import Data.Aeson hiding ((.=)) -import Data.Algorithm.Diff -import qualified Data.ByteString.Char8 as StrictBS -import Data.ByteString.Lazy.Char8 (ByteString) -import Data.ByteString.Lazy.Char8 (unpack) -import qualified Data.ByteString.Lazy.Char8 as BS -import Data.Either -import Data.IORef -import Data.List hiding (insert) -import qualified Data.Map as Map -import Data.Maybe -import Data.Tuple -import GHC.Generics -import Network.Socket hiding (send, sendTo, recv, recvFrom, KeepAlive) -import Network.Socket.ByteString.Lazy -import System.Directory -import System.Environment -import System.IO -import System.IO.Strict as StrictIO (hGetContents) -import Data.Version - -import Bag -import DynFlags -import ErrUtils -import FastString (unpackFS) -import GHC hiding (loadModule) -import GHC.Paths ( libdir ) -import GhcMonad (GhcMonad(..), Session(..), reflectGhc, modifySession) -import HscTypes (hsc_mod_graph) -import Packages -import SrcLoc - -import Language.Haskell.Tools.AST -import Language.Haskell.Tools.PrettyPrint -import Language.Haskell.Tools.Refactor.Daemon.PackageDB -import Language.Haskell.Tools.Refactor.Daemon.State -import Language.Haskell.Tools.Refactor.GetModules -import Language.Haskell.Tools.Refactor.Perform -import Language.Haskell.Tools.Refactor.Prepare -import Language.Haskell.Tools.Refactor.RefactorBase -import Language.Haskell.Tools.Refactor.Session -import Paths_haskell_tools_daemon - -runDaemonCLI :: IO () -runDaemonCLI = getArgs >>= runDaemon - -runDaemon :: [String] -> IO () -runDaemon args = withSocketsDo $ - do let finalArgs = args ++ drop (length args) defaultArgs - isSilent = read (finalArgs !! 1) - hSetBuffering stdout LineBuffering - hSetBuffering stderr LineBuffering - when (not isSilent) $ putStrLn $ "Starting Haskell Tools daemon" - sock <- socket AF_INET Stream 0 - setSocketOption sock ReuseAddr 1 - when (not isSilent) $ putStrLn $ "Listening on port " ++ finalArgs !! 0 - bind sock (SockAddrInet (read (finalArgs !! 0)) iNADDR_ANY) - listen sock 4 - clientLoop isSilent sock - -defaultArgs :: [String] -defaultArgs = ["4123", "True"] - -clientLoop :: Bool -> Socket -> IO () -clientLoop isSilent sock - = do when (not isSilent) $ putStrLn $ "Starting client loop" - (conn,_) <- accept sock - ghcSess <- initGhcSession - state <- newMVar initSession - serverLoop isSilent ghcSess state conn - sessionData <- readMVar state - when (not (sessionData ^. exiting)) - $ clientLoop isSilent sock - -serverLoop :: Bool -> Session -> MVar DaemonSessionState -> Socket -> IO () -serverLoop isSilent ghcSess state sock = - do msg <- recv sock 2048 - when (not $ BS.null msg) $ do -- null on TCP means closed connection - when (not isSilent) $ putStrLn $ "message received: " ++ show (unpack msg) - let msgs = BS.split '\n' msg - continue <- forM msgs $ \msg -> respondTo ghcSess state (sendAll sock . (`BS.snoc` '\n')) msg - sessionData <- readMVar state - when (not (sessionData ^. exiting) && all (== True) continue) - $ serverLoop isSilent ghcSess state sock - `catch` interrupted - where interrupted = \ex -> do - let err = show (ex :: IOException) - when (not isSilent) $ do - putStrLn "Closing down socket" - hPutStrLn stderr $ "Some exception caught: " ++ err - -respondTo :: Session -> MVar DaemonSessionState -> (ByteString -> IO ()) -> ByteString -> IO Bool -respondTo ghcSess state next mess - | BS.null mess = return True - | otherwise - = case decode mess of - Nothing -> do next $ encode $ ErrorMessage $ "MALFORMED MESSAGE: " ++ unpack mess - return True - Just req -> modifyMVar state (\st -> swap <$> reflectGhc (runStateT (updateClient (next . encode) req) st) ghcSess) - --- | This function does the real job of acting upon client messages in a stateful environment of a client -updateClient :: (ResponseMsg -> IO ()) -> ClientMessage -> StateT DaemonSessionState Ghc Bool -updateClient resp (Handshake _) = liftIO (resp $ HandshakeResponse $ versionBranch version) >> return True -updateClient resp KeepAlive = liftIO (resp KeepAliveResponse) >> return True -updateClient resp Disconnect = liftIO (resp Disconnected) >> return False -updateClient _ (SetPackageDB pkgDB) = modify (packageDB .= pkgDB) >> return True -updateClient resp (AddPackages packagePathes) = do - addPackages resp packagePathes - return True -updateClient _ (RemovePackages packagePathes) = do - mcs <- gets (^. refSessMCs) - let existingFiles = concatMap @[] (map (^. sfkFileName) . Map.keys) (mcs ^? traversal & filtered isRemoved & mcModules) - lift $ forM_ existingFiles (\fs -> removeTarget (TargetFile fs Nothing)) - lift $ deregisterDirs (mcs ^? traversal & filtered isRemoved & mcSourceDirs & traversal) - modify $ refSessMCs .- filter (not . isRemoved) - modifySession (\s -> s { hsc_mod_graph = filter ((`notElem` existingFiles) . getModSumOrig) (hsc_mod_graph s) }) - mcs <- gets (^. refSessMCs) - when (null mcs) $ modify (packageDBSet .= False) - return True - where isRemoved mc = (mc ^. mcRoot) `elem` packagePathes - -updateClient resp (ReLoad added changed removed) = - -- TODO: check for changed cabal files and reload their packages - do mcs <- gets (^. refSessMCs) - lift $ forM_ removed (\src -> removeTarget (TargetFile src Nothing)) - -- remove targets deleted - modify $ refSessMCs & traversal & mcModules - .- Map.filter (\m -> maybe True ((`notElem` removed) . getModSumOrig) (m ^? modRecMS)) - modifySession (\s -> s { hsc_mod_graph = filter (\mod -> getModSumOrig mod `notElem` removed) (hsc_mod_graph s) }) - -- reload changed modules - -- TODO: filter those that are in reloaded packages - reloadRes <- reloadChangedModules (\ms -> resp (LoadedModules [(getModSumOrig ms, getModSumName ms)])) - (\mss -> resp (LoadingModules (map getModSumOrig mss))) - (\ms -> getModSumOrig ms `elem` changed) - mcs <- gets (^. refSessMCs) - let mcsToReload = filter (\mc -> any ((mc ^. mcRoot) `isPrefixOf`) added && isNothing (moduleCollectionPkgId (mc ^. mcId))) mcs - addPackages resp (map (^. mcRoot) mcsToReload) -- reload packages containing added modules - liftIO $ case reloadRes of Left errs -> resp (either ErrorMessage CompilationProblem (getProblems errs)) - Right _ -> return () - return True - -updateClient _ Stop = modify (exiting .= True) >> return False - -updateClient resp (PerformRefactoring refact modPath selection args) = do - (selectedMod, otherMods) <- getFileMods modPath - case selectedMod of - Just actualMod -> do - case analyzeCommand refact (selection:args) of - Right cmd -> do res <- lift $ performCommand cmd actualMod otherMods - case res of - Left err -> liftIO $ resp $ ErrorMessage err - Right diff -> do changedMods <- applyChanges diff - liftIO $ resp $ ModulesChanged (map (either id (\(_,_,ch) -> ch)) changedMods) - void $ reloadChanges (map ((^. sfkModuleName) . (\(key,_,_) -> key)) (rights changedMods)) - Left err -> liftIO $ resp $ ErrorMessage err - Nothing -> liftIO $ resp $ ErrorMessage $ "The following file is not loaded to Haskell-tools: " - ++ modPath ++ ". Please add the containing package." - return True - - where applyChanges changes = do - forM changes $ \case - ModuleCreated n m otherM -> do - mcs <- gets (^. refSessMCs) - Just (_, otherMR) <- gets (lookupModInSCs otherM . (^. refSessMCs)) - - let Just otherMS = otherMR ^? modRecMS - Just mc = lookupModuleColl (otherM ^. sfkModuleName) mcs - otherSrcDir <- liftIO $ getSourceDir otherMS - let loc = toFileName otherSrcDir n - modify $ refSessMCs & traversal & filtered (\mc' -> (mc' ^. mcId) == (mc ^. mcId)) & mcModules - .- Map.insert (SourceFileKey loc n) (ModuleNotLoaded False False) - liftIO $ withBinaryFile loc WriteMode $ \handle -> do - hSetEncoding handle utf8 - hPutStr handle (prettyPrint m) - lift $ addTarget (Target (TargetFile loc Nothing) True Nothing) - return $ Right (SourceFileKey loc n, loc, RemoveAdded loc) - ContentChanged (n,m) -> do - let newCont = prettyPrint m - file = n ^. sfkFileName - origCont <- liftIO $ withBinaryFile file ReadMode $ \handle -> do - hSetEncoding handle utf8 - StrictIO.hGetContents handle - let undo = createUndo 0 $ getGroupedDiff origCont newCont - origCont <- liftIO $ withBinaryFile file WriteMode $ \handle -> do - hSetEncoding handle utf8 - hPutStr handle newCont - return $ Right (n, file, UndoChanges file undo) - ModuleRemoved mod -> do - Just (_,m) <- gets (lookupModuleInSCs mod . (^. refSessMCs)) - let modName = GHC.moduleName $ fromJust $ fmap semanticsModule (m ^? typedRecModule) <|> fmap semanticsModule (m ^? renamedRecModule) - ms <- getModSummary modName - let file = getModSumOrig ms - origCont <- liftIO (StrictBS.unpack <$> StrictBS.readFile file) - lift $ removeTarget (TargetFile file Nothing) - modify $ (refSessMCs .- removeModule mod) - liftIO $ removeFile file - return $ Left $ RestoreRemoved file origCont - - reloadChanges changedMods - = do reloadRes <- reloadChangedModules (\ms -> resp (LoadedModules [(getModSumOrig ms, getModSumName ms)])) - (\mss -> resp (LoadingModules (map getModSumOrig mss))) - (\ms -> modSumName ms `elem` changedMods) - liftIO $ case reloadRes of Left errs -> resp (either ErrorMessage (ErrorMessage . ("The result of the refactoring contains errors: " ++) . show) (getProblems errs)) - Right _ -> return () - -addPackages :: (ResponseMsg -> IO ()) -> [FilePath] -> StateT DaemonSessionState Ghc () -addPackages resp [] = return () -addPackages resp packagePathes = do - nonExisting <- filterM ((return . not) <=< liftIO . doesDirectoryExist) packagePathes - if (not (null nonExisting)) - then liftIO $ resp $ ErrorMessage $ "The following packages are not found: " ++ concat (intersperse ", " nonExisting) - else do - -- clear existing removed packages - existingMCs <- gets (^. refSessMCs) - let existing = (existingMCs ^? traversal & filtered isTheAdded & mcModules & traversal & modRecMS) - existingModNames = map ms_mod existing - needToReload <- handleErrors $ (filter (\ms -> not $ ms_mod ms `elem` existingModNames)) - <$> getReachableModules (\_ -> return ()) (\ms -> ms_mod ms `elem` existingModNames) - modify $ refSessMCs .- filter (not . isTheAdded) -- remove the added package from the database - forM_ existing $ \ms -> removeTarget (TargetFile (getModSumOrig ms) Nothing) - modifySession (\s -> s { hsc_mod_graph = filter (not . (`elem` existingModNames) . ms_mod) (hsc_mod_graph s) }) - -- load new modules - pkgDBok <- initializePackageDBIfNeeded - if pkgDBok then do - res <- loadPackagesFrom (\ms -> resp (LoadedModules [(getModSumOrig ms, getModSumName ms)]) >> return (getModSumOrig ms)) - (resp . LoadingModules . map getModSumOrig) (\st fp -> maybeToList <$> detectAutogen fp (st ^. packageDB)) packagePathes - case res of - Right modules -> do - mapM_ (reloadModule (\_ -> return ())) (either (const []) id needToReload) -- don't report consequent reloads (not expected) - Left err -> liftIO $ resp $ either ErrorMessage CompilationProblem (getProblems err) - else liftIO $ resp $ ErrorMessage $ "Attempted to load two packages with different package DB. " - ++ "Stack, cabal-sandbox and normal packages cannot be combined" - where isTheAdded mc = (mc ^. mcRoot) `elem` packagePathes - initializePackageDBIfNeeded = do - pkgDBAlreadySet <- gets (^. packageDBSet) - pkgDB <- gets (^. packageDB) - locs <- liftIO $ mapM (packageDBLoc pkgDB) packagePathes - case locs of - firstLoc:rest -> - if | not (all (== firstLoc) rest) - -> return False - | pkgDBAlreadySet -> do - pkgDBLocs <- gets (^. packageDBLocs) - return (pkgDBLocs == firstLoc) - | otherwise -> do - usePackageDB firstLoc - modify ((packageDBSet .= True) . (packageDBLocs .= firstLoc)) - return True - [] -> return True - - -data UndoRefactor = RemoveAdded { undoRemovePath :: FilePath } - | RestoreRemoved { undoRestorePath :: FilePath - , undoRestoreContents :: String - } - | UndoChanges { undoChangedPath :: FilePath - , undoDiff :: FileDiff - } - deriving (Show, Generic) - -instance ToJSON UndoRefactor - -type FileDiff = [(Int, Int, String)] - -createUndo :: Eq a => Int -> [Diff [a]] -> [(Int, Int, [a])] -createUndo i (Both str _ : rest) = createUndo (i + length str) rest -createUndo i (First rem : Second add : rest) - = (i, i + length add, rem) : createUndo (i + length add) rest -createUndo i (First rem : rest) = (i, i, rem) : createUndo i rest -createUndo i (Second add : rest) - = (i, i + length add, []) : createUndo (i + length add) rest -createUndo _ [] = [] - -initGhcSession :: IO Session -initGhcSession = Session <$> (newIORef =<< runGhc (Just libdir) (initGhcFlags >> getSession)) - -usePackageDB :: GhcMonad m => [FilePath] -> m () -usePackageDB [] = return () -usePackageDB pkgDbLocs - = do dfs <- getSessionDynFlags - dfs' <- liftIO $ fmap fst $ initPackages - $ dfs { extraPkgConfs = (map PkgConfFile pkgDbLocs ++) . extraPkgConfs dfs - , pkgDatabase = Nothing - } - void $ setSessionDynFlags dfs' - -getProblems :: RefactorException -> Either String [(SrcSpan, String)] -getProblems (SourceCodeProblem errs) = Right $ map (\err -> (errMsgSpan err, show err)) $ bagToList errs -getProblems other = Left $ displayException other - -data ClientMessage - = KeepAlive - | Handshake { clientVersion :: [Int] } - | SetPackageDB { pkgDB :: PackageDB } - | AddPackages { addedPathes :: [FilePath] } - | RemovePackages { removedPathes :: [FilePath] } - | PerformRefactoring { refactoring :: String - , modulePath :: FilePath - , editorSelection :: String - , details :: [String] - } - | Stop - | Disconnect - | ReLoad { addedModules :: [FilePath] - , changedModules :: [FilePath] - , removedModules :: [FilePath] - } - deriving (Show, Generic) - -instance FromJSON ClientMessage - -data ResponseMsg - = KeepAliveResponse - | HandshakeResponse { serverVersion :: [Int] } - | ErrorMessage { errorMsg :: String } - | CompilationProblem { errorMarkers :: [(SrcSpan, String)] } - | ModulesChanged { undoChanges :: [UndoRefactor] } - | LoadedModules { loadedModules :: [(FilePath, String)] } - | LoadingModules { modulesToLoad :: [FilePath] } - | Disconnected - deriving (Show, Generic) - -instance ToJSON ResponseMsg - -instance ToJSON SrcSpan where - toJSON (RealSrcSpan sp) = object [ "file" A..= unpackFS (srcSpanFile sp) - , "startRow" A..= srcLocLine (realSrcSpanStart sp) - , "startCol" A..= srcLocCol (realSrcSpanStart sp) - , "endRow" A..= srcLocLine (realSrcSpanEnd sp) - , "endCol" A..= srcLocCol (realSrcSpanEnd sp) - ] - toJSON _ = Null
− Language/Haskell/Tools/Refactor/Daemon/PackageDB.hs
@@ -1,73 +0,0 @@-{-# LANGUAGE DeriveGeneric #-} -module Language.Haskell.Tools.Refactor.Daemon.PackageDB where - -import Control.Applicative (Applicative(..), (<$>), Alternative(..)) -import Control.Monad -import Data.Aeson (FromJSON(..)) -import Data.Char (isSpace) -import Data.List -import GHC.Generics (Generic(..)) -import System.Directory -import System.FilePath (FilePath, (</>)) -import System.Process (readProcessWithExitCode) - -data PackageDB = AutoDB - | DefaultDB - | CabalSandboxDB - | StackDB - | ExplicitDB { packageDBPath :: FilePath } - deriving (Show, Generic) - -instance FromJSON PackageDB - -packageDBLoc :: PackageDB -> FilePath -> IO [FilePath] -packageDBLoc AutoDB path = (++) <$> packageDBLoc StackDB path <*> packageDBLoc CabalSandboxDB path -packageDBLoc DefaultDB _ = return [] -packageDBLoc CabalSandboxDB path = do - hasConfigFile <- doesFileExist (path </> "cabal.config") - hasSandboxFile <- doesFileExist (path </> "cabal.sandbox.config") - config <- if hasConfigFile then readFile (path </> "cabal.config") - else if hasSandboxFile then readFile (path </> "cabal.sandbox.config") - else return "" - return $ map (drop (length "package-db: ")) $ filter ("package-db: " `isPrefixOf`) $ lines config -packageDBLoc StackDB path = withCurrentDirectory path $ do - (_, snapshotDB, snapshotDBErrs) <- readProcessWithExitCode "stack" ["path", "--allow-different-user", "--snapshot-pkg-db"] "" - (_, localDB, localDBErrs) <- readProcessWithExitCode "stack" ["path", "--allow-different-user", "--local-pkg-db"] "" - return $ [trim localDB | null localDBErrs] ++ [trim snapshotDB | null snapshotDBErrs] -packageDBLoc (ExplicitDB dir) path = do - hasDir <- doesDirectoryExist (path </> dir) - if hasDir then return [path </> dir] - else return [] - --- | Gets the (probable) location of autogen folder depending on which type of --- build we are using. -detectAutogen :: FilePath -> PackageDB -> IO (Maybe FilePath) -detectAutogen root AutoDB = do - defDB <- detectAutogen root DefaultDB - sandboxDB <- detectAutogen root CabalSandboxDB - stackDB <- detectAutogen root StackDB - return $ choose [ defDB, sandboxDB, stackDB ] -detectAutogen root DefaultDB = ifExists (root </> "dist" </> "build" </> "autogen") -detectAutogen root (ExplicitDB _) = ifExists (root </> "dist" </> "build" </> "autogen") -detectAutogen root CabalSandboxDB = ifExists (root </> "dist" </> "build" </> "autogen") -detectAutogen root StackDB = do - distExists <- doesDirectoryExist (root </> ".stack-work" </> "dist") - existing <- if distExists then (do - contents <- listDirectory (root </> ".stack-work" </> "dist") - let dirs = map ((root </> ".stack-work" </> "dist") </>) contents - subDirs <- mapM (\d -> map (d </>) <$> listDirectory d) dirs - mapM (ifExists . (</> "build" </> "autogen")) (dirs ++ concat subDirs)) else return [] - return (choose existing) - - -trim :: String -> String -trim = f . f - where f = reverse . dropWhile isSpace - -choose :: Alternative f => [f a] -> f a -choose = foldl (<|>) empty - -ifExists :: FilePath -> IO (Maybe FilePath) -ifExists fp = do exists <- doesDirectoryExist fp - if exists then return (Just fp) - else return Nothing
− Language/Haskell/Tools/Refactor/Daemon/State.hs
@@ -1,22 +0,0 @@-{-# LANGUAGE TemplateHaskell #-} -module Language.Haskell.Tools.Refactor.Daemon.State where - -import Control.Reference - -import Language.Haskell.Tools.Refactor.Daemon.PackageDB -import Language.Haskell.Tools.Refactor.RefactorBase -import Language.Haskell.Tools.Refactor.Session - -data DaemonSessionState - = DaemonSessionState { _refactorSession :: RefactorSessionState - , _packageDB :: PackageDB - , _packageDBSet :: Bool - , _packageDBLocs :: [FilePath] - , _exiting :: Bool - } - -makeReferences ''DaemonSessionState - -instance IsRefactSessionState DaemonSessionState where - refSessMCs = refactorSession & refSessMCs - initSession = DaemonSessionState initSession AutoDB False [] False
+ examples/Project/code-gen/A.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE UnboxedTuples #-} +module A where + +import B + +a = () where x = (# b, 0 #)
+ examples/Project/code-gen/B.hs view
@@ -0,0 +1,3 @@+module B where + +b = ()
+ examples/Project/code-gen/some-test-package.cabal view
@@ -0,0 +1,18 @@+name: some-test-package +version: 1.2.3.4 +synopsis: A package just for testing Haskell-tools support. Don't install it. +description: + +homepage: https://github.com/nboldi/haskell-tools +license: BSD3 +license-file: LICENSE +author: Boldizsar Nemeth +maintainer: nboldi@elte.hu +category: Language +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: A, B + build-depends: base + default-language: Haskell2010
+ examples/Project/exposed-mod-as-main/A.hs view
@@ -0,0 +1,4 @@+module A where + +main :: IO () +main = return ()
+ examples/Project/exposed-mod-as-main/some-test-package.cabal view
@@ -0,0 +1,24 @@+name: some-test-package +version: 1.2.3.4 +synopsis: A package just for testing Haskell-tools support. Don't install it. +description: + +homepage: https://github.com/nboldi/haskell-tools +license: BSD3 +license-file: LICENSE +author: Boldizsar Nemeth +maintainer: nboldi@elte.hu +category: Language +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: A + build-depends: base + default-language: Haskell2010 + +executable some-executable + build-depends: base + ghc-options: -main-is=A + main-is: A.hs + default-language: Haskell2010
+ examples/Project/has-ghc/A.hs view
@@ -0,0 +1,5 @@+module A where + +import SrcLoc + +x = ()
+ examples/Project/has-ghc/some-test-package.cabal view
@@ -0,0 +1,18 @@+name: some-test-package +version: 1.2.3.4 +synopsis: A package just for testing Haskell-tools support. Don't install it. +description: + +homepage: https://github.com/nboldi/haskell-tools +license: BSD3 +license-file: LICENSE +author: Boldizsar Nemeth +maintainer: nboldi@elte.hu +category: Language +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: A + build-depends: base, ghc + default-language: Haskell2010
+ examples/Project/incomplete-cabal/A.hs view
@@ -0,0 +1,3 @@+module A where + +x = ()
+ examples/Project/incomplete-cabal/B.hs view
@@ -0,0 +1,3 @@+module B where + +y = ()
+ examples/Project/incomplete-cabal/some-test-package.cabal view
@@ -0,0 +1,18 @@+name: some-test-package +version: 1.2.3.4 +synopsis: A package just for testing Haskell-tools support. Don't install it. +description: + +homepage: https://github.com/nboldi/haskell-tools +license: BSD3 +license-file: LICENSE +author: Boldizsar Nemeth +maintainer: nboldi@elte.hu +category: Language +build-type: Simple +cabal-version: >=1.10 + +library + build-depends: base + default-language: Haskell2010 + exposed-modules: A
+ examples/Project/load-error-multi/A.hs view
@@ -0,0 +1,3 @@+module A where + +a = ()
+ examples/Project/load-error-multi/B.hs view
@@ -0,0 +1,5 @@+module B where + +import No.Such.Module + +b = a
+ examples/Project/load-error-multi/C.hs view
@@ -0,0 +1,5 @@+module C where + +import B + +c = b
+ examples/Project/load-error-multi/D.hs view
@@ -0,0 +1,5 @@+module D where + +import A + +d = a
− examples/Project/multi-packages-same-module/package1/A.hs
@@ -1,3 +0,0 @@-module A where - -x = ()
− examples/Project/multi-packages-same-module/package1/package1.cabal
@@ -1,18 +0,0 @@-name: package1 -version: 1.2.3.4 -synopsis: A package just for testing Haskell-tools support. Don't install it. -description: - -homepage: https://github.com/nboldi/haskell-tools -license: BSD3 -license-file: LICENSE -author: Boldizsar Nemeth -maintainer: nboldi@elte.hu -category: Language -build-type: Simple -cabal-version: >=1.10 - -library - exposed-modules: A - build-depends: base - default-language: Haskell2010
− examples/Project/multi-packages-same-module/package2/A.hs
@@ -1,1 +0,0 @@-module A where
− examples/Project/multi-packages-same-module/package2/package2.cabal
@@ -1,18 +0,0 @@-name: package2 -version: 1.2.3.4 -synopsis: A package just for testing Haskell-tools support. Don't install it. -description: - -homepage: https://github.com/nboldi/haskell-tools -license: BSD3 -license-file: LICENSE -author: Boldizsar Nemeth -maintainer: nboldi@elte.hu -category: Language -build-type: Simple -cabal-version: >=1.10 - -library - exposed-modules: A - build-depends: base - default-language: Haskell2010
+ examples/Project/paths-codegen/A.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TemplateHaskell #-} +module A where + +import Paths_some_test_package +import Language.Haskell.TH + +$(runIO (print version) >> return [])
+ examples/Project/paths-codegen/dist/build/autogen/Paths_some_test_package.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} +{-# OPTIONS_GHC -fno-warn-implicit-prelude #-} +module Paths_some_test_package ( + version, + getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, + getDataFileName, getSysconfDir + ) where + +import qualified Control.Exception as Exception +import Data.Version (Version(..)) +import System.Environment (getEnv) +import Prelude + +#if defined(VERSION_base) + +#if MIN_VERSION_base(4,0,0) +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#else +catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a +#endif + +#else +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#endif +catchIO = Exception.catch + +version :: Version +version = Version [1,2,3,4] [] +bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath + +bindir = "C:\\Users\\nboldi\\AppData\\Roaming\\cabal\\bin" +libdir = "C:\\Users\\nboldi\\AppData\\Roaming\\cabal\\x86_64-windows-ghc-8.0.2\\some-test-package-1.2.3.4-6S3unDRx74P1jz6fzwqDpM" +dynlibdir = "C:\\Users\\nboldi\\AppData\\Roaming\\cabal\\x86_64-windows-ghc-8.0.2" +datadir = "C:\\Users\\nboldi\\AppData\\Roaming\\cabal\\x86_64-windows-ghc-8.0.2\\some-test-package-1.2.3.4" +libexecdir = "C:\\Users\\nboldi\\AppData\\Roaming\\cabal\\some-test-package-1.2.3.4-6S3unDRx74P1jz6fzwqDpM\\x86_64-windows-ghc-8.0.2\\some-test-package-1.2.3.4" +sysconfdir = "C:\\Users\\nboldi\\AppData\\Roaming\\cabal\\etc" + +getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath +getBinDir = catchIO (getEnv "some_test_package_bindir") (\_ -> return bindir) +getLibDir = catchIO (getEnv "some_test_package_libdir") (\_ -> return libdir) +getDynLibDir = catchIO (getEnv "some_test_package_dynlibdir") (\_ -> return dynlibdir) +getDataDir = catchIO (getEnv "some_test_package_datadir") (\_ -> return datadir) +getLibexecDir = catchIO (getEnv "some_test_package_libexecdir") (\_ -> return libexecdir) +getSysconfDir = catchIO (getEnv "some_test_package_sysconfdir") (\_ -> return sysconfdir) + +getDataFileName :: FilePath -> IO FilePath +getDataFileName name = do + dir <- getDataDir + return (dir ++ "\\" ++ name)
+ examples/Project/paths-codegen/dist/build/autogen/cabal_macros.h view
@@ -0,0 +1,154 @@+/* DO NOT EDIT: This file is automatically generated by Cabal */ + +/* package some-test-package-1.2.3.4 */ +#ifndef VERSION_some_test_package +#define VERSION_some_test_package "1.2.3.4" +#endif /* VERSION_some_test_package */ +#ifndef MIN_VERSION_some_test_package +#define MIN_VERSION_some_test_package(major1,major2,minor) (\ + (major1) < 1 || \ + (major1) == 1 && (major2) < 2 || \ + (major1) == 1 && (major2) == 2 && (minor) <= 3) +#endif /* MIN_VERSION_some_test_package */ + +/* package base-4.9.1.0 */ +#ifndef VERSION_base +#define VERSION_base "4.9.1.0" +#endif /* VERSION_base */ +#ifndef MIN_VERSION_base +#define MIN_VERSION_base(major1,major2,minor) (\ + (major1) < 4 || \ + (major1) == 4 && (major2) < 9 || \ + (major1) == 4 && (major2) == 9 && (minor) <= 1) +#endif /* MIN_VERSION_base */ + +/* tool alex-3.2.1 */ +#ifndef TOOL_VERSION_alex +#define TOOL_VERSION_alex "3.2.1" +#endif /* TOOL_VERSION_alex */ +#ifndef MIN_TOOL_VERSION_alex +#define MIN_TOOL_VERSION_alex(major1,major2,minor) (\ + (major1) < 3 || \ + (major1) == 3 && (major2) < 2 || \ + (major1) == 3 && (major2) == 2 && (minor) <= 1) +#endif /* MIN_TOOL_VERSION_alex */ + +/* tool gcc-5.2.0 */ +#ifndef TOOL_VERSION_gcc +#define TOOL_VERSION_gcc "5.2.0" +#endif /* TOOL_VERSION_gcc */ +#ifndef MIN_TOOL_VERSION_gcc +#define MIN_TOOL_VERSION_gcc(major1,major2,minor) (\ + (major1) < 5 || \ + (major1) == 5 && (major2) < 2 || \ + (major1) == 5 && (major2) == 2 && (minor) <= 0) +#endif /* MIN_TOOL_VERSION_gcc */ + +/* tool ghc-8.0.2 */ +#ifndef TOOL_VERSION_ghc +#define TOOL_VERSION_ghc "8.0.2" +#endif /* TOOL_VERSION_ghc */ +#ifndef MIN_TOOL_VERSION_ghc +#define MIN_TOOL_VERSION_ghc(major1,major2,minor) (\ + (major1) < 8 || \ + (major1) == 8 && (major2) < 0 || \ + (major1) == 8 && (major2) == 0 && (minor) <= 2) +#endif /* MIN_TOOL_VERSION_ghc */ + +/* tool ghc-pkg-8.0.2 */ +#ifndef TOOL_VERSION_ghc_pkg +#define TOOL_VERSION_ghc_pkg "8.0.2" +#endif /* TOOL_VERSION_ghc_pkg */ +#ifndef MIN_TOOL_VERSION_ghc_pkg +#define MIN_TOOL_VERSION_ghc_pkg(major1,major2,minor) (\ + (major1) < 8 || \ + (major1) == 8 && (major2) < 0 || \ + (major1) == 8 && (major2) == 0 && (minor) <= 2) +#endif /* MIN_TOOL_VERSION_ghc_pkg */ + +/* tool haddock-2.17.3 */ +#ifndef TOOL_VERSION_haddock +#define TOOL_VERSION_haddock "2.17.3" +#endif /* TOOL_VERSION_haddock */ +#ifndef MIN_TOOL_VERSION_haddock +#define MIN_TOOL_VERSION_haddock(major1,major2,minor) (\ + (major1) < 2 || \ + (major1) == 2 && (major2) < 17 || \ + (major1) == 2 && (major2) == 17 && (minor) <= 3) +#endif /* MIN_TOOL_VERSION_haddock */ + +/* tool happy-1.19.5 */ +#ifndef TOOL_VERSION_happy +#define TOOL_VERSION_happy "1.19.5" +#endif /* TOOL_VERSION_happy */ +#ifndef MIN_TOOL_VERSION_happy +#define MIN_TOOL_VERSION_happy(major1,major2,minor) (\ + (major1) < 1 || \ + (major1) == 1 && (major2) < 19 || \ + (major1) == 1 && (major2) == 19 && (minor) <= 5) +#endif /* MIN_TOOL_VERSION_happy */ + +/* tool hpc-0.67 */ +#ifndef TOOL_VERSION_hpc +#define TOOL_VERSION_hpc "0.67" +#endif /* TOOL_VERSION_hpc */ +#ifndef MIN_TOOL_VERSION_hpc +#define MIN_TOOL_VERSION_hpc(major1,major2,minor) (\ + (major1) < 0 || \ + (major1) == 0 && (major2) < 67 || \ + (major1) == 0 && (major2) == 67 && (minor) <= 0) +#endif /* MIN_TOOL_VERSION_hpc */ + +/* tool hsc2hs-0.68.1 */ +#ifndef TOOL_VERSION_hsc2hs +#define TOOL_VERSION_hsc2hs "0.68.1" +#endif /* TOOL_VERSION_hsc2hs */ +#ifndef MIN_TOOL_VERSION_hsc2hs +#define MIN_TOOL_VERSION_hsc2hs(major1,major2,minor) (\ + (major1) < 0 || \ + (major1) == 0 && (major2) < 68 || \ + (major1) == 0 && (major2) == 68 && (minor) <= 1) +#endif /* MIN_TOOL_VERSION_hsc2hs */ + +/* tool hscolour-1.24 */ +#ifndef TOOL_VERSION_hscolour +#define TOOL_VERSION_hscolour "1.24" +#endif /* TOOL_VERSION_hscolour */ +#ifndef MIN_TOOL_VERSION_hscolour +#define MIN_TOOL_VERSION_hscolour(major1,major2,minor) (\ + (major1) < 1 || \ + (major1) == 1 && (major2) < 24 || \ + (major1) == 1 && (major2) == 24 && (minor) <= 0) +#endif /* MIN_TOOL_VERSION_hscolour */ + +/* tool runghc-8.0.2 */ +#ifndef TOOL_VERSION_runghc +#define TOOL_VERSION_runghc "8.0.2" +#endif /* TOOL_VERSION_runghc */ +#ifndef MIN_TOOL_VERSION_runghc +#define MIN_TOOL_VERSION_runghc(major1,major2,minor) (\ + (major1) < 8 || \ + (major1) == 8 && (major2) < 0 || \ + (major1) == 8 && (major2) == 0 && (minor) <= 2) +#endif /* MIN_TOOL_VERSION_runghc */ + +/* tool strip-2.25 */ +#ifndef TOOL_VERSION_strip +#define TOOL_VERSION_strip "2.25" +#endif /* TOOL_VERSION_strip */ +#ifndef MIN_TOOL_VERSION_strip +#define MIN_TOOL_VERSION_strip(major1,major2,minor) (\ + (major1) < 2 || \ + (major1) == 2 && (major2) < 25 || \ + (major1) == 2 && (major2) == 25 && (minor) <= 0) +#endif /* MIN_TOOL_VERSION_strip */ + +#ifndef CURRENT_PACKAGE_KEY +#define CURRENT_PACKAGE_KEY "some-test-package-1.2.3.4-6S3unDRx74P1jz6fzwqDpM" +#endif /* CURRENT_PACKAGE_KEY */ +#ifndef CURRENT_COMPONENT_ID +#define CURRENT_COMPONENT_ID "some-test-package-1.2.3.4-6S3unDRx74P1jz6fzwqDpM" +#endif /* CURRENT_COMPONENT_ID */ +#ifndef CURRENT_PACKAGE_VERSION +#define CURRENT_PACKAGE_VERSION "1.2.3.4" +#endif /* CURRENT_PACKAGE_VERSION */
+ examples/Project/paths-codegen/some-test-package.cabal view
@@ -0,0 +1,18 @@+name: some-test-package +version: 1.2.3.4 +synopsis: A package just for testing Haskell-tools support. Don't install it. +description: + +homepage: https://github.com/nboldi/haskell-tools +license: BSD3 +license-file: LICENSE +author: Boldizsar Nemeth +maintainer: nboldi@elte.hu +category: Language +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: A + build-depends: base + default-language: Haskell2010
+ examples/Project/paths-module/A.hs view
@@ -0,0 +1,5 @@+module A where + +import Paths_some_test_package + +x = version
+ examples/Project/paths-module/dist/build/autogen/Paths_some_test_package.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} +{-# OPTIONS_GHC -fno-warn-implicit-prelude #-} +module Paths_some_test_package ( + version, + getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, + getDataFileName, getSysconfDir + ) where + +import qualified Control.Exception as Exception +import Data.Version (Version(..)) +import System.Environment (getEnv) +import Prelude + +#if defined(VERSION_base) + +#if MIN_VERSION_base(4,0,0) +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#else +catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a +#endif + +#else +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#endif +catchIO = Exception.catch + +version :: Version +version = Version [1,2,3,4] [] +bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath + +bindir = "C:\\Users\\nboldi\\AppData\\Roaming\\cabal\\bin" +libdir = "C:\\Users\\nboldi\\AppData\\Roaming\\cabal\\x86_64-windows-ghc-8.0.2\\some-test-package-1.2.3.4-6S3unDRx74P1jz6fzwqDpM" +dynlibdir = "C:\\Users\\nboldi\\AppData\\Roaming\\cabal\\x86_64-windows-ghc-8.0.2" +datadir = "C:\\Users\\nboldi\\AppData\\Roaming\\cabal\\x86_64-windows-ghc-8.0.2\\some-test-package-1.2.3.4" +libexecdir = "C:\\Users\\nboldi\\AppData\\Roaming\\cabal\\some-test-package-1.2.3.4-6S3unDRx74P1jz6fzwqDpM\\x86_64-windows-ghc-8.0.2\\some-test-package-1.2.3.4" +sysconfdir = "C:\\Users\\nboldi\\AppData\\Roaming\\cabal\\etc" + +getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath +getBinDir = catchIO (getEnv "some_test_package_bindir") (\_ -> return bindir) +getLibDir = catchIO (getEnv "some_test_package_libdir") (\_ -> return libdir) +getDynLibDir = catchIO (getEnv "some_test_package_dynlibdir") (\_ -> return dynlibdir) +getDataDir = catchIO (getEnv "some_test_package_datadir") (\_ -> return datadir) +getLibexecDir = catchIO (getEnv "some_test_package_libexecdir") (\_ -> return libexecdir) +getSysconfDir = catchIO (getEnv "some_test_package_sysconfdir") (\_ -> return sysconfdir) + +getDataFileName :: FilePath -> IO FilePath +getDataFileName name = do + dir <- getDataDir + return (dir ++ "\\" ++ name)
+ examples/Project/paths-module/dist/build/autogen/cabal_macros.h view
@@ -0,0 +1,154 @@+/* DO NOT EDIT: This file is automatically generated by Cabal */ + +/* package some-test-package-1.2.3.4 */ +#ifndef VERSION_some_test_package +#define VERSION_some_test_package "1.2.3.4" +#endif /* VERSION_some_test_package */ +#ifndef MIN_VERSION_some_test_package +#define MIN_VERSION_some_test_package(major1,major2,minor) (\ + (major1) < 1 || \ + (major1) == 1 && (major2) < 2 || \ + (major1) == 1 && (major2) == 2 && (minor) <= 3) +#endif /* MIN_VERSION_some_test_package */ + +/* package base-4.9.1.0 */ +#ifndef VERSION_base +#define VERSION_base "4.9.1.0" +#endif /* VERSION_base */ +#ifndef MIN_VERSION_base +#define MIN_VERSION_base(major1,major2,minor) (\ + (major1) < 4 || \ + (major1) == 4 && (major2) < 9 || \ + (major1) == 4 && (major2) == 9 && (minor) <= 1) +#endif /* MIN_VERSION_base */ + +/* tool alex-3.2.1 */ +#ifndef TOOL_VERSION_alex +#define TOOL_VERSION_alex "3.2.1" +#endif /* TOOL_VERSION_alex */ +#ifndef MIN_TOOL_VERSION_alex +#define MIN_TOOL_VERSION_alex(major1,major2,minor) (\ + (major1) < 3 || \ + (major1) == 3 && (major2) < 2 || \ + (major1) == 3 && (major2) == 2 && (minor) <= 1) +#endif /* MIN_TOOL_VERSION_alex */ + +/* tool gcc-5.2.0 */ +#ifndef TOOL_VERSION_gcc +#define TOOL_VERSION_gcc "5.2.0" +#endif /* TOOL_VERSION_gcc */ +#ifndef MIN_TOOL_VERSION_gcc +#define MIN_TOOL_VERSION_gcc(major1,major2,minor) (\ + (major1) < 5 || \ + (major1) == 5 && (major2) < 2 || \ + (major1) == 5 && (major2) == 2 && (minor) <= 0) +#endif /* MIN_TOOL_VERSION_gcc */ + +/* tool ghc-8.0.2 */ +#ifndef TOOL_VERSION_ghc +#define TOOL_VERSION_ghc "8.0.2" +#endif /* TOOL_VERSION_ghc */ +#ifndef MIN_TOOL_VERSION_ghc +#define MIN_TOOL_VERSION_ghc(major1,major2,minor) (\ + (major1) < 8 || \ + (major1) == 8 && (major2) < 0 || \ + (major1) == 8 && (major2) == 0 && (minor) <= 2) +#endif /* MIN_TOOL_VERSION_ghc */ + +/* tool ghc-pkg-8.0.2 */ +#ifndef TOOL_VERSION_ghc_pkg +#define TOOL_VERSION_ghc_pkg "8.0.2" +#endif /* TOOL_VERSION_ghc_pkg */ +#ifndef MIN_TOOL_VERSION_ghc_pkg +#define MIN_TOOL_VERSION_ghc_pkg(major1,major2,minor) (\ + (major1) < 8 || \ + (major1) == 8 && (major2) < 0 || \ + (major1) == 8 && (major2) == 0 && (minor) <= 2) +#endif /* MIN_TOOL_VERSION_ghc_pkg */ + +/* tool haddock-2.17.3 */ +#ifndef TOOL_VERSION_haddock +#define TOOL_VERSION_haddock "2.17.3" +#endif /* TOOL_VERSION_haddock */ +#ifndef MIN_TOOL_VERSION_haddock +#define MIN_TOOL_VERSION_haddock(major1,major2,minor) (\ + (major1) < 2 || \ + (major1) == 2 && (major2) < 17 || \ + (major1) == 2 && (major2) == 17 && (minor) <= 3) +#endif /* MIN_TOOL_VERSION_haddock */ + +/* tool happy-1.19.5 */ +#ifndef TOOL_VERSION_happy +#define TOOL_VERSION_happy "1.19.5" +#endif /* TOOL_VERSION_happy */ +#ifndef MIN_TOOL_VERSION_happy +#define MIN_TOOL_VERSION_happy(major1,major2,minor) (\ + (major1) < 1 || \ + (major1) == 1 && (major2) < 19 || \ + (major1) == 1 && (major2) == 19 && (minor) <= 5) +#endif /* MIN_TOOL_VERSION_happy */ + +/* tool hpc-0.67 */ +#ifndef TOOL_VERSION_hpc +#define TOOL_VERSION_hpc "0.67" +#endif /* TOOL_VERSION_hpc */ +#ifndef MIN_TOOL_VERSION_hpc +#define MIN_TOOL_VERSION_hpc(major1,major2,minor) (\ + (major1) < 0 || \ + (major1) == 0 && (major2) < 67 || \ + (major1) == 0 && (major2) == 67 && (minor) <= 0) +#endif /* MIN_TOOL_VERSION_hpc */ + +/* tool hsc2hs-0.68.1 */ +#ifndef TOOL_VERSION_hsc2hs +#define TOOL_VERSION_hsc2hs "0.68.1" +#endif /* TOOL_VERSION_hsc2hs */ +#ifndef MIN_TOOL_VERSION_hsc2hs +#define MIN_TOOL_VERSION_hsc2hs(major1,major2,minor) (\ + (major1) < 0 || \ + (major1) == 0 && (major2) < 68 || \ + (major1) == 0 && (major2) == 68 && (minor) <= 1) +#endif /* MIN_TOOL_VERSION_hsc2hs */ + +/* tool hscolour-1.24 */ +#ifndef TOOL_VERSION_hscolour +#define TOOL_VERSION_hscolour "1.24" +#endif /* TOOL_VERSION_hscolour */ +#ifndef MIN_TOOL_VERSION_hscolour +#define MIN_TOOL_VERSION_hscolour(major1,major2,minor) (\ + (major1) < 1 || \ + (major1) == 1 && (major2) < 24 || \ + (major1) == 1 && (major2) == 24 && (minor) <= 0) +#endif /* MIN_TOOL_VERSION_hscolour */ + +/* tool runghc-8.0.2 */ +#ifndef TOOL_VERSION_runghc +#define TOOL_VERSION_runghc "8.0.2" +#endif /* TOOL_VERSION_runghc */ +#ifndef MIN_TOOL_VERSION_runghc +#define MIN_TOOL_VERSION_runghc(major1,major2,minor) (\ + (major1) < 8 || \ + (major1) == 8 && (major2) < 0 || \ + (major1) == 8 && (major2) == 0 && (minor) <= 2) +#endif /* MIN_TOOL_VERSION_runghc */ + +/* tool strip-2.25 */ +#ifndef TOOL_VERSION_strip +#define TOOL_VERSION_strip "2.25" +#endif /* TOOL_VERSION_strip */ +#ifndef MIN_TOOL_VERSION_strip +#define MIN_TOOL_VERSION_strip(major1,major2,minor) (\ + (major1) < 2 || \ + (major1) == 2 && (major2) < 25 || \ + (major1) == 2 && (major2) == 25 && (minor) <= 0) +#endif /* MIN_TOOL_VERSION_strip */ + +#ifndef CURRENT_PACKAGE_KEY +#define CURRENT_PACKAGE_KEY "some-test-package-1.2.3.4-6S3unDRx74P1jz6fzwqDpM" +#endif /* CURRENT_PACKAGE_KEY */ +#ifndef CURRENT_COMPONENT_ID +#define CURRENT_COMPONENT_ID "some-test-package-1.2.3.4-6S3unDRx74P1jz6fzwqDpM" +#endif /* CURRENT_COMPONENT_ID */ +#ifndef CURRENT_PACKAGE_VERSION +#define CURRENT_PACKAGE_VERSION "1.2.3.4" +#endif /* CURRENT_PACKAGE_VERSION */
+ examples/Project/paths-module/some-test-package.cabal view
@@ -0,0 +1,18 @@+name: some-test-package +version: 1.2.3.4 +synopsis: A package just for testing Haskell-tools support. Don't install it. +description: + +homepage: https://github.com/nboldi/haskell-tools +license: BSD3 +license-file: LICENSE +author: Boldizsar Nemeth +maintainer: nboldi@elte.hu +category: Language +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: A + build-depends: base + default-language: Haskell2010
+ examples/Project/same-module-in-two-mod-coll/A.hs view
@@ -0,0 +1,3 @@+module A where + +x = ()
+ examples/Project/same-module-in-two-mod-coll/Main.hs view
@@ -0,0 +1,5 @@+module Main where + +import A + +main = return ()
+ examples/Project/same-module-in-two-mod-coll/some-test-package.cabal view
@@ -0,0 +1,24 @@+name: some-test-package +version: 1.2.3.4 +synopsis: A package just for testing Haskell-tools support. Don't install it. +description: + +homepage: https://github.com/nboldi/haskell-tools +license: BSD3 +license-file: LICENSE +author: Boldizsar Nemeth +maintainer: nboldi@elte.hu +category: Language +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: A + build-depends: base + default-language: Haskell2010 + +executable some-executable + build-depends: base + main-is: Main.hs + other-modules: A + default-language: Haskell2010
+ examples/Project/th-imports-normal/A.hs view
@@ -0,0 +1,3 @@+module A where + +data A''
+ examples/Project/th-imports-normal/B.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-} +module B where + +import C + +c'
+ examples/Project/th-imports-normal/C.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE TemplateHaskell #-} +module C where + +import A +import Language.Haskell.TH + +c' :: Q [Dec] +c' = [d| type X = A'' |]
+ examples/Project/th-typecheck/A.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE TemplateHaskell, TupleSections #-} +module A where + +$(let x = (3,) in return [])
+ examples/Project/two-modules/A.hs view
@@ -0,0 +1,3 @@+module A where + +x = ()
+ examples/Project/two-modules/B.hs view
@@ -0,0 +1,3 @@+module B where + +y = ()
+ examples/Project/two-modules/some-test-package.cabal view
@@ -0,0 +1,18 @@+name: some-test-package +version: 1.2.3.4 +synopsis: A package just for testing Haskell-tools support. Don't install it. +description: + +homepage: https://github.com/nboldi/haskell-tools +license: BSD3 +license-file: LICENSE +author: Boldizsar Nemeth +maintainer: nboldi@elte.hu +category: Language +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: A, B + build-depends: base + default-language: Haskell2010
exe/Main.hs view
@@ -1,6 +1,11 @@ module Main where -import Language.Haskell.Tools.Refactor.Daemon +import Control.Concurrent.MVar (newEmptyMVar) +import Language.Haskell.Tools.Daemon (runDaemon) +import Language.Haskell.Tools.Daemon.Mode (socketMode) +import Language.Haskell.Tools.Daemon.Options (parseDaemonCLI) +import Language.Haskell.Tools.Refactor.Builtin (builtinRefactorings) main :: IO () -main = runDaemonCLI +main = do store <- newEmptyMVar + runDaemon builtinRefactorings socketMode store =<< parseDaemonCLI
haskell-tools-daemon.cabal view
@@ -1,7 +1,11 @@ name: haskell-tools-daemon -version: 0.8.1.0 -synopsis: Background process for Haskell-tools refactor that editors can connect to. -description: Background process for Haskell-tools refactor that editors can connect to. +version: 1.0.0.0 +synopsis: Background process for Haskell-tools that editors can connect to. +description: Background process for Haskell-tools that provides a way to use the tools on a + whole project. It also makes it possible to use the tools on the project in a + session, reloading modules when needed. The daemon library is independent of + the actual set of tools, and takes them as a parameter, so the system can be + easily extended by creating a simple new Main module. homepage: https://github.com/haskell-tools/haskell-tools license: BSD3 license-file: LICENSE @@ -30,10 +34,6 @@ , examples/Project/multi-packages-flags/package1/*.cabal , examples/Project/multi-packages-flags/package2/*.hs , examples/Project/multi-packages-flags/package2/*.cabal - , examples/Project/multi-packages-same-module/package1/*.hs - , examples/Project/multi-packages-same-module/package1/*.cabal - , examples/Project/multi-packages-same-module/package2/*.hs - , examples/Project/multi-packages-same-module/package2/*.cabal , examples/Project/no-cabal/*.hs , examples/Project/reloading/*.hs , examples/Project/selection/*.hs @@ -52,6 +52,14 @@ , examples/Project/empty/*.hs , examples/Project/additional-files/*.hs , examples/Project/additional-files/*.cabal + , examples/Project/paths-codegen/dist/build/autogen/cabal_macros.h + , examples/Project/paths-codegen/dist/build/autogen/Paths_some_test_package.hs + , examples/Project/paths-codegen/*.hs + , examples/Project/paths-codegen/*.cabal + , examples/Project/paths-module/dist/build/autogen/cabal_macros.h + , examples/Project/paths-module/dist/build/autogen/Paths_some_test_package.hs + , examples/Project/paths-module/*.hs + , examples/Project/paths-module/*.cabal , examples/Project/cabal-sandbox/*.hs , examples/Project/cabal-sandbox/*.cabal , examples/Project/cabal-sandbox/groups-0.4.0.0/LICENSE @@ -60,30 +68,63 @@ , examples/Project/cabal-sandbox/groups-0.4.0.0/src/Data/Group.hs , examples/Project/unused-mod/*.hs , examples/Project/unused-mod/*.cabal - + , examples/Project/same-module-in-two-mod-coll/*.hs + , examples/Project/same-module-in-two-mod-coll/*.cabal + , examples/Project/exposed-mod-as-main/*.hs + , examples/Project/exposed-mod-as-main/*.cabal + , examples/Project/th-imports-normal/*.hs + , examples/Project/has-ghc/*.hs + , examples/Project/has-ghc/*.cabal + , examples/Project/incomplete-cabal/*.hs + , examples/Project/incomplete-cabal/*.cabal + , examples/Project/two-modules/*.hs + , examples/Project/two-modules/*.cabal + , examples/Project/load-error-multi/*.hs + , examples/Project/th-typecheck/*.hs + , examples/Project/code-gen/*.hs + , examples/Project/code-gen/*.cabal library build-depends: base >= 4.9 && < 5.0 , aeson >= 1.0 && < 1.3 , bytestring >= 0.10 && < 1.0 + , deepseq >= 1.4 && < 2.0 , filepath >= 1.4 && < 2.0 , strict >= 0.3 && < 0.4 , containers >= 0.5 && < 0.6 , mtl >= 2.2 && < 2.3 , split >= 0.2 && < 1.0 , directory >= 1.2 && < 1.4 - , process >= 1.4 && < 1.7 - , ghc >= 8.0 && < 8.3 + , process >= 1.6 && < 1.7 + , ghc >= 8.2 && < 8.3 , ghc-paths >= 0.1 && < 0.2 , references >= 0.3.2 && < 1.0 , network >= 2.6 && < 3.0 , Diff >= 0.3 && < 0.4 - , haskell-tools-ast >= 0.8 && < 0.9 - , haskell-tools-prettyprint >= 0.8 && < 0.9 - , haskell-tools-refactor >= 0.8 && < 0.9 - exposed-modules: Language.Haskell.Tools.Refactor.Daemon - , Language.Haskell.Tools.Refactor.Daemon.State - , Language.Haskell.Tools.Refactor.Daemon.PackageDB + , Cabal >= 2.0 && < 2.1 + , pretty >= 1.1 && < 1.2 + , optparse-applicative >= 0.14 && < 0.15 + , template-haskell >= 2.12 && < 2.13 + , haskell-tools-prettyprint >= 1.0 && < 1.1 + , haskell-tools-refactor >= 1.0 && < 1.1 + , haskell-tools-builtin-refactorings >= 1.0 && < 1.1 + , fswatch >= 0.1 && < 0.2 + + exposed-modules: Language.Haskell.Tools.Daemon + , Language.Haskell.Tools.Daemon.Session + , Language.Haskell.Tools.Daemon.ModuleGraph + , Language.Haskell.Tools.Daemon.GetModules + , Language.Haskell.Tools.Daemon.MapExtensions + , Language.Haskell.Tools.Daemon.Representation + , Language.Haskell.Tools.Daemon.Utils + , Language.Haskell.Tools.Daemon.State + , Language.Haskell.Tools.Daemon.PackageDB + , Language.Haskell.Tools.Daemon.Mode + , Language.Haskell.Tools.Daemon.Protocol + , Language.Haskell.Tools.Daemon.Update + , Language.Haskell.Tools.Daemon.Watch + , Language.Haskell.Tools.Daemon.Options + , Language.Haskell.Tools.Daemon.ErrorHandling , Paths_haskell_tools_daemon default-language: Haskell2010 @@ -92,6 +133,9 @@ ghc-options: -rtsopts build-depends: base >= 4.9 && < 5.0 , haskell-tools-daemon + , directory >= 1.2 && < 1.4 + , filepath >= 1.4 && < 2.0 + , haskell-tools-builtin-refactorings >= 1.0 && < 1.1 hs-source-dirs: exe main-is: Main.hs default-language: Haskell2010 @@ -101,16 +145,18 @@ ghc-options: -with-rtsopts=-M2.5g hs-source-dirs: test main-is: Main.hs - build-depends: base >= 4.9 && < 4.10 + build-depends: base >= 4.10 && < 4.11 , HUnit >= 1.5 && < 1.7 - , ghc >= 8.0 && < 8.1 + , ghc >= 8.2 && < 8.3 , tasty >= 0.11 && < 0.12 , tasty-hunit >= 0.9 && < 0.10 , directory >= 1.2 && < 1.4 - , process >= 1.4 && < 1.7 + , process >= 1.6 && < 1.7 , filepath >= 1.4 && < 2.0 , bytestring >= 0.10 && < 0.11 , network >= 2.6 && < 2.7 - , aeson >= 1.0 && < 1.3 + , aeson >= 1.0 && < 1.3 + , Glob >= 0.9 && < 0.10 , haskell-tools-daemon + , haskell-tools-builtin-refactorings >= 1.0 && < 1.1 default-language: Haskell2010
test/Main.hs view
@@ -1,32 +1,34 @@-{-# LANGUAGE StandaloneDeriving, LambdaCase, ScopedTypeVariables, OverloadedStrings #-} +{-# LANGUAGE LambdaCase, OverloadedStrings, ScopedTypeVariables, StandaloneDeriving #-} module Main where -import Test.Tasty -import Test.Tasty.HUnit -import System.Exit -import System.Directory -import System.FilePath -import System.Process -import System.Environment -import System.Exit -import Control.Monad -import Control.Exception import Control.Concurrent -import Control.Concurrent.MVar -import Network.Socket hiding (KeepAlive, send, recv) -import Network.Socket.ByteString.Lazy as Sock -import qualified Data.ByteString.Lazy.Char8 as BS -import qualified Data.List as List -import Data.List (sort) +import Control.Exception +import Control.Monad import Data.Aeson +import qualified Data.ByteString.Lazy.Char8 as BS +import Data.List (sort, isSuffixOf, isInfixOf) import Data.Maybe +import Network.Socket hiding (KeepAlive, send, recv) +import Network.Socket.ByteString.Lazy as Sock (sendAll, recv) +import System.Directory +import System.Environment (unsetEnv) +import System.Exit (ExitCode(..)) +import System.FilePath (FilePath(..), (</>)) +import System.FilePath.Glob (glob) import System.IO +import System.IO.Error (catchIOError) +import System.Process +import Test.Tasty +import Test.Tasty.HUnit -import SrcLoc -import FastString +import FastString (mkFastString) +import SrcLoc (SrcSpan(..), mkSrcSpan, mkSrcLoc) -import Language.Haskell.Tools.Refactor.Daemon -import Language.Haskell.Tools.Refactor.Daemon.PackageDB +import Language.Haskell.Tools.Daemon (runDaemon') +import Language.Haskell.Tools.Daemon.Options as Options (SharedDaemonOptions(..), DaemonOptions(..)) +import Language.Haskell.Tools.Daemon.PackageDB (PackageDB(..)) +import Language.Haskell.Tools.Daemon.Protocol (UndoRefactor(..), ResponseMsg(..), ClientMessage(..)) +import Language.Haskell.Tools.Refactor.Builtin (builtinRefactorings) pORT_NUM_START = 4100 pORT_NUM_END = 4200 @@ -41,21 +43,27 @@ allTests :: Bool -> FilePath -> MVar Int -> TestTree allTests isSource testRoot portCounter - = localOption (mkTimeout ({- 10s -} 1000 * 1000 * 20)) + = localOption (mkTimeout ({- 30s -} 1000 * 1000 * 30)) $ testGroup "daemon-tests" [ testGroup "simple-tests" $ map (makeDaemonTest portCounter) simpleTests , testGroup "loading-tests" - $ map (makeDaemonTest portCounter) loadingTests + $ map (makeDaemonTest portCounter) (loadingTests testRoot) + , testGroup "complex-loading-tests" + $ map (makeComplexLoadTest portCounter) (complexLoadingTests testRoot) , testGroup "refactor-tests" $ map (makeRefactorTest portCounter) (refactorTests testRoot) , testGroup "reload-tests" - $ map (makeReloadTest portCounter) reloadingTests + $ map (makeReloadTest portCounter) (reloadingTests testRoot) + , testGroup "undo-tests" + $ map (makeUndoTest portCounter) (undoTests testRoot) , testGroup "compilation-problem-tests" - $ map (makeCompProblemTest portCounter) compProblemTests + $ map (makeCompProblemTest portCounter) (compProblemTests isSource testRoot) + , testGroup "special-tests" + $ map (makeSpecialTest portCounter) (specialTests testRoot) -- if not a stack build, we cannot guarantee that stack is on the path , if isSource - then testGroup "pkg-db-tests" $ map (makePkgDbTest portCounter) pkgDbTests + then testGroup "pkg-db-tests" $ map (makePkgDbTest portCounter) (pkgDbTests testRoot) else testCase "IGNORED pkg-db-tests" (return ()) -- cannot execute this when the source is not present -- , if isSource then selfLoadingTest portCounter else testCase "IGNORED self-load" (return ()) @@ -69,66 +77,108 @@ , ( "keep-alive", [KeepAlive], [KeepAliveResponse] ) ] -loadingTests :: [(String, [ClientMessage], [ResponseMsg])] -loadingTests = +loadingTests :: FilePath -> [(String, [ClientMessage], [ResponseMsg])] +loadingTests testRoot = [ ( "load-package" , [AddPackages [testRoot </> "has-cabal"]] , [ LoadingModules [testRoot </> "has-cabal" </> "A.hs"] - , LoadedModules [(testRoot </> "has-cabal" </> "A.hs", "A")]] ) + , LoadedModule (testRoot </> "has-cabal" </> "A.hs") "A" ] ) + , ( "same-module-in-two-mod-coll" + , [AddPackages [testRoot </> "same-module-in-two-mod-coll"]] + , [ LoadingModules [testRoot </> "same-module-in-two-mod-coll" </> "A.hs" + , testRoot </> "same-module-in-two-mod-coll" </> "Main.hs"] + , LoadedModule (testRoot </> "same-module-in-two-mod-coll" </> "A.hs") "A" + , LoadedModule (testRoot </> "same-module-in-two-mod-coll" </> "Main.hs") "Main" ] ) + , ( "exposed-mod-as-main" + , [AddPackages [testRoot </> "exposed-mod-as-main"]] + , [ LoadingModules [testRoot </> "exposed-mod-as-main" </> "A.hs"] + , LoadedModule (testRoot </> "exposed-mod-as-main" </> "A.hs") "A" ] ) , ( "no-cabal" , [AddPackages [testRoot </> "no-cabal"]] , [ LoadingModules [testRoot </> "no-cabal" </> "A.hs"] - , LoadedModules [(testRoot </> "no-cabal" </> "A.hs", "A")]] ) + , LoadedModule (testRoot </> "no-cabal" </> "A.hs") "A"] ) + , ( "code-gen" + , [AddPackages [testRoot </> "code-gen"]] + , [ LoadingModules [testRoot </> "code-gen" </> "B.hs", testRoot </> "code-gen" </> "A.hs"] + , LoadedModule (testRoot </> "code-gen" </> "B.hs") "B" + , LoadedModule (testRoot </> "code-gen" </> "A.hs") "A" ] ) + ,( "th-typecheck" + , [AddPackages [testRoot </> "th-typecheck"]] + , [ LoadingModules [testRoot </> "th-typecheck" </> "A.hs"] + , LoadedModule (testRoot </> "th-typecheck" </> "A.hs") "A"] ) , ( "source-dir" , [AddPackages [testRoot </> "source-dir"]] , [ LoadingModules [testRoot </> "source-dir" </> "src" </> "A.hs"] - , LoadedModules [(testRoot </> "source-dir" </> "src" </> "A.hs", "A")]] ) + , LoadedModule (testRoot </> "source-dir" </> "src" </> "A.hs") "A"] ) , ( "source-dir-outside" , [AddPackages [testRoot </> "source-dir-outside"]] , [ LoadingModules [testRoot </> "source-dir-outside" </> ".." </> "src" </> "A.hs"] - , LoadedModules [(testRoot </> "source-dir-outside" </> ".." </> "src" </> "A.hs", "A")]] ) + , LoadedModule (testRoot </> "source-dir-outside" </> ".." </> "src" </> "A.hs") "A"] ) , ( "multi-packages" , [ AddPackages [ testRoot </> "multi-packages" </> "package1" , testRoot </> "multi-packages" </> "package2" ]] - , [ LoadingModules [ testRoot </> "multi-packages" </> "package2" </> "B.hs" - , testRoot </> "multi-packages" </> "package1" </> "A.hs" ] - , LoadedModules [ (testRoot </> "multi-packages" </> "package2" </> "B.hs", "B") ] - , LoadedModules [ (testRoot </> "multi-packages" </> "package1" </> "A.hs", "A") ] ] ) + , [ LoadingModules [ testRoot </> "multi-packages" </> "package1" </> "A.hs" + , testRoot </> "multi-packages" </> "package2" </> "B.hs" ] + , LoadedModule (testRoot </> "multi-packages" </> "package1" </> "A.hs") "A" + , LoadedModule (testRoot </> "multi-packages" </> "package2" </> "B.hs") "B" ] ) , ( "multi-packages-flags" , [ AddPackages [ testRoot </> "multi-packages-flags" </> "package1" , testRoot </> "multi-packages-flags" </> "package2" ]] - , [ LoadingModules [ testRoot </> "multi-packages-flags" </> "package2" </> "B.hs" - , testRoot </> "multi-packages-flags" </> "package1" </> "A.hs" ] - , LoadedModules [ (testRoot </> "multi-packages-flags" </> "package2" </> "B.hs", "B") ] - , LoadedModules [ (testRoot </> "multi-packages-flags" </> "package1" </> "A.hs", "A") ] ] ) + , [ LoadingModules [ testRoot </> "multi-packages-flags" </> "package1" </> "A.hs" + , testRoot </> "multi-packages-flags" </> "package2" </> "B.hs" ] + , LoadedModule (testRoot </> "multi-packages-flags" </> "package1" </> "A.hs") "A" + , LoadedModule (testRoot </> "multi-packages-flags" </> "package2" </> "B.hs") "B" ] ) , ( "multi-packages-dependent" , [ AddPackages [ testRoot </> "multi-packages-dependent" </> "package1" , testRoot </> "multi-packages-dependent" </> "package2" ]] , [ LoadingModules [ testRoot </> "multi-packages-dependent" </> "package1" </> "A.hs" , testRoot </> "multi-packages-dependent" </> "package2" </> "B.hs" ] - , LoadedModules [ (testRoot </> "multi-packages-dependent" </> "package1" </> "A.hs", "A") ] - , LoadedModules [ (testRoot </> "multi-packages-dependent" </> "package2" </> "B.hs", "B") ] ] ) + , LoadedModule (testRoot </> "multi-packages-dependent" </> "package1" </> "A.hs") "A" + , LoadedModule (testRoot </> "multi-packages-dependent" </> "package2" </> "B.hs") "B" ] ) , ( "has-th" , [AddPackages [testRoot </> "has-th"]] , [ LoadingModules [ testRoot </> "has-th" </> "TH.hs", testRoot </> "has-th" </> "A.hs" ] - , LoadedModules [ (testRoot </> "has-th" </> "TH.hs", "TH") ] - , LoadedModules [ (testRoot </> "has-th" </> "A.hs", "A") ] ] ) + , LoadedModule (testRoot </> "has-th" </> "TH.hs") "TH" + , LoadedModule (testRoot </> "has-th" </> "A.hs") "A" ] ) , ( "th-added-later" , [ AddPackages [testRoot </> "th-added-later" </> "package1"] , AddPackages [testRoot </> "th-added-later" </> "package2"] ] , [ LoadingModules [ testRoot </> "th-added-later" </> "package1" </> "A.hs" ] - , LoadedModules [(testRoot </> "th-added-later" </> "package1" </> "A.hs", "A")] + , LoadedModule (testRoot </> "th-added-later" </> "package1" </> "A.hs") "A" , LoadingModules [ testRoot </> "th-added-later" </> "package2" </> "B.hs" ] - , LoadedModules [(testRoot </> "th-added-later" </> "package2" </> "B.hs", "B")] ] ) + , LoadedModule (testRoot </> "th-added-later" </> "package2" </> "B.hs") "B" ] ) , ( "unused-module" , [ AddPackages [testRoot </> "unused-mod"] ] , [ LoadingModules [ testRoot </> "unused-mod" </> "Main.hs" ] - , LoadedModules [ (testRoot </> "unused-mod" </> "Main.hs", "Main") ] ] ) + , LoadedModule (testRoot </> "unused-mod" </> "Main.hs") "Main" ] ) + , ( "additional-files" + , [ SetPackageDB DefaultDB, AddPackages [testRoot </> "additional-files"] ] + , [ LoadingModules [ testRoot </> "additional-files" </> "B.hs" + , testRoot </> "additional-files" </> "A.hs" ] + , LoadedModule (testRoot </> "additional-files" </> "B.hs") "B" + , LoadedModule (testRoot </> "additional-files" </> "A.hs") "A" + ]) ] -compProblemTests :: [(String, [Either (IO ()) ClientMessage], [ResponseMsg] -> Bool)] -compProblemTests = +complexLoadingTests :: FilePath -> [(String, FilePath, [ClientMessage], [ResponseMsg] -> Bool)] +complexLoadingTests testRoot = + [ ( "paths-module", testRoot </> "paths-module" + , [AddPackages [testRoot </> "paths-module"]] + , \case [ LoadingModules [paths, a], LoadedModule{}, LoadedModule{} + ] -> "Paths_some_test_package.hs" `isSuffixOf` paths + && "A.hs" `isSuffixOf` a + ; _ -> False) + , ( "paths-codegen", testRoot </> "paths-codegen" + , [AddPackages [testRoot </> "paths-codegen"]] + , \case [ LoadingModules [paths, a], LoadedModule{}, LoadedModule{} + ] -> "Paths_some_test_package.hs" `isSuffixOf` paths + && "A.hs" `isSuffixOf` a + ; _ -> False) + ] + +compProblemTests :: Bool -> FilePath -> [(String, [Either (IO ()) ClientMessage], [ResponseMsg] -> Bool)] +compProblemTests isSource testRoot = [ ( "load-error" , [ Right $ SetPackageDB DefaultDB, Right $ AddPackages [testRoot </> "load-error"] ] , \case [LoadingModules{}, CompilationProblem {}] -> True; _ -> False) @@ -140,101 +190,205 @@ , Left $ appendFile (testRoot </> "empty" </> "A.hs") "\n\nimport No.Such.Module" , Right $ ReLoad [] [testRoot </> "empty" </> "A.hs"] [] , Left $ writeFile (testRoot </> "empty" </> "A.hs") "module A where"] - , \case [LoadingModules {}, LoadedModules {}, LoadingModules {}, CompilationProblem {}] -> True; _ -> False) + , \case [LoadingModules {}, LoadedModule {}, LoadingModules {}, CompilationProblem {}] -> True; _ -> False) , ( "reload-source-error" , [ Right $ SetPackageDB DefaultDB, Right $ AddPackages [testRoot </> "empty"] , Left $ appendFile (testRoot </> "empty" </> "A.hs") "\n\naa = 3 + ()" , Right $ ReLoad [] [testRoot </> "empty" </> "A.hs"] [] , Left $ writeFile (testRoot </> "empty" </> "A.hs") "module A where"] - , \case [LoadingModules {}, LoadedModules {}, LoadingModules {}, CompilationProblem {}] -> True; _ -> False) + , \case [LoadingModules {}, LoadedModule {}, LoadingModules {}, CompilationProblem {}] -> True; _ -> False) , ( "no-such-file" - , [ Right $ PerformRefactoring "RenameDefinition" (testRoot </> "simple-refactor" ++ testSuffix </> "A.hs") "3:1-3:2" ["y"] ] + , [ Right $ SetPackageDB DefaultDB + , Right $ PerformRefactoring "RenameDefinition" (testRoot </> "simple-refactor" ++ testSuffix </> "A.hs") "3:1-3:2" ["y"] False False] , \case [ ErrorMessage _ ] -> True; _ -> False ) - , ( "additional-files" - , [ Right $ SetPackageDB DefaultDB, Right $ AddPackages [testRoot </> "additional-files"] ] - , \case [ LoadingModules {}, ErrorMessage _ ] -> True; _ -> False ) - ] - -sourceRoot = ".." </> ".." </> "src" - -selfLoadingTest :: MVar Int -> TestTree -selfLoadingTest port = localOption (mkTimeout ({- 5 min -} 1000 * 1000 * 60 * 5)) $ testCase "self-load" $ do - actual <- communicateWithDaemon port - [ Right $ AddPackages (map (sourceRoot </>) ["ast", "backend-ghc", "prettyprint", "rewrite", "refactor"]) ] - assertBool ("The expected result is a nonempty response message list that does not contain errors. Actual result: " ++ show actual) - (not (null actual) && all (\case ErrorMessage {} -> False; _ -> True) actual) - + ] ++ if isSource then + [ ( "cabal-sandbox-defaulted" + , [ Left $ withCurrentDirectory (testRoot </> "cabal-sandbox") initCabalSandbox + , Right $ SetPackageDB DefaultDB + , Right $ AddPackages [testRoot </> "cabal-sandbox"] ] + , \case [ErrorMessage{}] -> True; _ -> False ) + , ( "package-db-conflict" + , [ Left $ withCurrentDirectory (testRoot </> "cabal-sandbox") initCabalSandbox + , Right $ AddPackages [testRoot </> "cabal-sandbox", testRoot </> "has-cabal"] ] + , \case [ErrorMessage{}] -> True; _ -> False ) + , ( "package-db-conflict-2" + , [ Left $ withCurrentDirectory (testRoot </> "cabal-sandbox") initCabalSandbox + , Right $ AddPackages [testRoot </> "cabal-sandbox"] + , Right $ AddPackages [testRoot </> "has-cabal"] ] + , \case [LoadingModules{}, LoadedModule{}, ErrorMessage{}] -> True; _ -> False ) + ] else [] refactorTests :: FilePath -> [(String, FilePath, [ClientMessage], [ResponseMsg] -> Bool)] refactorTests testRoot = [ ( "simple-refactor", testRoot </> "simple-refactor" , [ AddPackages [ testRoot </> "simple-refactor" ++ testSuffix ] - , PerformRefactoring "RenameDefinition" (testRoot </> "simple-refactor" ++ testSuffix </> "A.hs") "3:1-3:2" ["y"] + , PerformRefactoring "RenameDefinition" "A" "3:1-3:2" ["y"] False False ] - , \case [ LoadingModules{}, LoadedModules [ (aPath, _) ], ModulesChanged _, LoadingModules{}, LoadedModules [ (aPath', _) ]] + , \case [ LoadingModules{}, LoadedModule aPath _, LoadingModules{}, LoadedModule aPath' _ ] -> aPath == testRoot </> "simple-refactor" ++ testSuffix </> "A.hs" && aPath == aPath'; _ -> False ) + , ( "refactor-file", testRoot </> "simple-refactor" + , [ AddPackages [ testRoot </> "simple-refactor" ++ testSuffix ] + , PerformRefactoring "RenameDefinition" "A.hs" "3:1-3:2" ["y"] False False + ] + , \case [ LoadingModules{}, LoadedModule aPath _, LoadingModules{}, LoadedModule aPath' _] + -> aPath == testRoot </> "simple-refactor" ++ testSuffix </> "A.hs" && aPath == aPath'; _ -> False ) + , ( "refactor-with-th", testRoot </> "th-imports-normal" + , [ AddPackages [ testRoot </> "th-imports-normal" ++ testSuffix ] + , PerformRefactoring "RenameDefinition" "A" "3:6" ["A'"] False False + ] + , \case [ LoadingModules{}, LoadedModule a _, LoadedModule c _, LoadedModule b _ + , LoadingModules{}, LoadedModule a' _, LoadedModule c' _, LoadedModule b' _ + ] -> [a,b,c] == map ((testRoot </> "th-imports-normal" ++ testSuffix) </>) ["A.hs","B.hs","C.hs"] && [a',b',c'] == [a,b,c] + _ -> False ) + , ( "dry-refactor", testRoot </> "reloading" + , [ AddPackages [ testRoot </> "reloading" ++ testSuffix ] + , PerformRefactoring "RenameDefinition" "C" "3:1-3:2" ["cc"] False True + ] + , \case [ LoadingModules{}, LoadedModule{}, LoadedModule{}, LoadedModule{} + , DiffInfo diff' + ] -> let [cFile,bFile] = map ((testRoot </> "reloading" ++ testSuffix) </>) ["C.hs","B.hs"] + diff = "--- " ++ cFile ++ "\n+++ " ++ cFile ++ "\n@@\n module C where\r\n \r\n-c = ()\n+cc = ()\n--- " + ++ bFile ++ "\n+++ " ++ bFile ++ "\n@@\n module B where\r\n \r\n import C\r\n \r\n-b = c\n+b = cc\n" + in diff' == diff; _ -> False ) , ( "hs-boots", testRoot </> "hs-boots" , [ AddPackages [ testRoot </> "hs-boots" ++ testSuffix ] - , PerformRefactoring "RenameDefinition" (testRoot </> "hs-boots" ++ testSuffix </> "A.hs") "5:1-5:2" ["aa"] + , PerformRefactoring "RenameDefinition" "A" "5:1-5:2" ["aa"] False False ] - , \case [ LoadingModules{}, LoadedModules _, LoadedModules _, LoadedModules _, LoadedModules _, ModulesChanged _ - , LoadingModules{}, LoadedModules [ (path1, _) ], LoadedModules [ (path2, _) ] - , LoadedModules [ (path3, _) ], LoadedModules [ (path4, _) ] + , \case [ LoadingModules{}, LoadedModule{}, LoadedModule{}, LoadedModule{}, LoadedModule{} + , LoadingModules{}, LoadedModule path1 _, LoadedModule path2 _ + , LoadedModule path3 _, LoadedModule path4 _ ] -> let allPathes = map ((testRoot </> "hs-boots" ++ testSuffix) </>) ["A.hs","B.hs","A.hs-boot","B.hs-boot"] in sort [path1,path2,path3,path4] == sort allPathes _ -> False ) + , ( "refactor-boot", testRoot </> "hs-boots" + , [ AddPackages [ testRoot </> "hs-boots" ++ testSuffix ] + , PerformRefactoring "RenameDefinition" (testRoot </> "hs-boots" ++ testSuffix </> "A.hs-boot") "3:1-3:2" ["aa"] False False + ] + , \case [ LoadingModules{}, LoadedModule{}, LoadedModule{}, LoadedModule{}, LoadedModule{} + , LoadingModules{}, LoadedModule path1 _, LoadedModule path2 _ + , LoadedModule path3 _, LoadedModule path4 _ + ] -> let allPathes = map ((testRoot </> "hs-boots" ++ testSuffix) </>) ["A.hs","B.hs","A.hs-boot","B.hs-boot"] + in sort [path1,path2,path3,path4] == sort allPathes + _ -> False ) , ( "remove-module", testRoot </> "simple-refactor" , [ AddPackages [ testRoot </> "simple-refactor" ++ testSuffix ] - , PerformRefactoring "RenameDefinition" (testRoot </> "simple-refactor" ++ testSuffix </> "A.hs") "1:8-1:9" ["AA"] + , PerformRefactoring "RenameDefinition" "A" "1:8-1:9" ["AA"] False False ] - , \case [ LoadingModules{},LoadedModules [ (aPath, _) ], ModulesChanged _, LoadingModules{},LoadedModules [ (aaPath, _) ]] + , \case [ LoadingModules{}, LoadedModule aPath _, LoadingModules{}, LoadedModule aaPath _] -> aPath == testRoot </> "simple-refactor" ++ testSuffix </> "A.hs" && aaPath == testRoot </> "simple-refactor" ++ testSuffix </> "AA.hs" _ -> False ) ] -reloadingTests :: [(String, FilePath, [ClientMessage], IO (), [ClientMessage], [ResponseMsg] -> Bool)] -reloadingTests = +reloadingTests :: FilePath -> [(String, FilePath, [ClientMessage], IO (), [ClientMessage], [ResponseMsg] -> Bool)] +reloadingTests testRoot = [ ( "reloading-module", testRoot </> "reloading", [ AddPackages [ testRoot </> "reloading" ++ testSuffix ]] , writeFile (testRoot </> "reloading" ++ testSuffix </> "C.hs") "module C where\nc = ()" , [ ReLoad [] [testRoot </> "reloading" ++ testSuffix </> "C.hs"] [] - , PerformRefactoring "RenameDefinition" (testRoot </> "reloading" ++ testSuffix </> "C.hs") "2:1-2:2" ["d"] + , PerformRefactoring "RenameDefinition" "C" "2:1-2:2" ["d"] False False ] - , \case [ LoadingModules{}, LoadedModules [(pathC'',_)], LoadedModules [(pathB'',_)], LoadedModules [(pathA'',_)] - , LoadingModules{}, LoadedModules [(pathC,_)], LoadedModules [(pathB,_)], LoadedModules [(pathA,_)] - , ModulesChanged _, LoadingModules{},LoadedModules [(pathC',_)], LoadedModules [(pathB',_)], LoadedModules [(pathA',_)] + , \case [ LoadingModules{}, LoadedModule pathC'' _, LoadedModule pathB'' _, LoadedModule pathA'' _ + , LoadingModules{}, LoadedModule pathC _, LoadedModule pathB _, LoadedModule pathA _ + , LoadingModules{},LoadedModule pathC' _, LoadedModule pathB' _, LoadedModule pathA' _ ] -> let allPathes = map ((testRoot </> "reloading" ++ testSuffix) </>) ["C.hs","B.hs","A.hs"] in [pathC,pathB,pathA] == allPathes && [pathC',pathB',pathA'] == allPathes && [pathC'',pathB'',pathA''] == allPathes _ -> False ) + , ( "reloading-only-one-module", testRoot </> "reloading" + , [ AddPackages [ testRoot </> "reloading" ++ testSuffix ]] , return () + , [ ReLoad [] [testRoot </> "reloading" ++ testSuffix </> "A.hs"] [] ] + , \case [ LoadingModules{}, LoadedModule pathC _, LoadedModule pathB _, LoadedModule pathA _ + , LoadingModules{}, LoadedModule pathA' _ + ] -> [pathC,pathB,pathA] == map ((testRoot </> "reloading" ++ testSuffix) </>) ["C.hs","B.hs","A.hs"] + && pathA' == pathA + _ -> False ) , ( "reloading-package", testRoot </> "changing-cabal" , [ AddPackages [ testRoot </> "changing-cabal" ++ testSuffix ]] , appendFile (testRoot </> "changing-cabal" ++ testSuffix </> "some-test-package.cabal") ", B" , [ AddPackages [testRoot </> "changing-cabal" ++ testSuffix] - , PerformRefactoring "RenameDefinition" (testRoot </> "changing-cabal" ++ testSuffix </> "A.hs") "3:1-3:2" ["z"] + , PerformRefactoring "RenameDefinition" "A" "3:1-3:2" ["z"] False False ] - , \case [ LoadingModules{}, LoadedModules [(pathA,_)], LoadingModules{}, LoadedModules [(pathA',_)] - , LoadedModules [(pathB',_)], ModulesChanged _ - , LoadingModules{}, LoadedModules [(pathA'',_)], LoadedModules [(pathB'',_)] + , \case [ LoadingModules{}, LoadedModule pathA _, LoadingModules{}, LoadedModule pathA' _ + , LoadedModule pathB' _ + , LoadingModules{}, LoadedModule pathA'' _, LoadedModule pathB'' _ ] -> let [pA,pB] = map ((testRoot </> "changing-cabal" ++ testSuffix) </>) ["A.hs","B.hs"] in pA == pathA && pA == pathA' && pA == pathA'' && pB == pathB' && pB == pathB'' _ -> False ) + , ( "reloading-th", testRoot </> "has-th", [], return () + , [ AddPackages [testRoot </> "has-th" ++ testSuffix] + , ReLoad [] [testRoot </> "has-th" ++ testSuffix </> "TH.hs"] [] + ] + , \case [ LoadingModules{}, LoadedModule th _, LoadedModule a _ + , LoadingModules{}, LoadedModule th' _, LoadedModule a' _ + ] -> let [pth,pa] = map ((testRoot </> "has-th" ++ testSuffix) </>) ["TH.hs","A.hs"] + in pa == a && pa == a' && pth == th && pth == th' + _ -> False ) + -- TODO: This test runs correctly in itself. Probably a testing bug? + -- , ( "reset-th", testRoot </> "has-th", [], return () + -- , [ AddPackages [testRoot </> "has-th" ++ testSuffix] + -- , Reset + -- ] + -- , \case [ LoadingModules{}, LoadedModule th _, LoadedModule a _ + -- , LoadingModules{}, LoadedModule th' _, LoadedModule a' _ + -- ] -> let [pth,pa] = map ((testRoot </> "has-th" ++ testSuffix) </>) ["TH.hs","A.hs"] + -- in pa == a && pa == a' && pth == th && pth == th' + -- _ -> False ) + , ( "reloading-ghc", testRoot </> "has-ghc", [], return () + , [ AddPackages [testRoot </> "has-ghc" ++ testSuffix] + , ReLoad [] [testRoot </> "has-ghc" ++ testSuffix </> "A.hs"] [] + ] + , \case [ LoadingModules{}, LoadedModule a _ + , LoadingModules{}, LoadedModule a' _ + ] -> a == testRoot </> "has-ghc" ++ testSuffix </> "A.hs" && a' == a + _ -> False ) + , ( "reloading-unloadable-project", testRoot </> "load-error" + , [ AddPackages [testRoot </> "load-error" ++ testSuffix] ] + , writeFile (testRoot </> "load-error" ++ testSuffix </> "A.hs") "module A where\n\na = ()" + , [ ReLoad [] [testRoot </> "load-error" ++ testSuffix </> "A.hs"] [] ] + , \case [ LoadingModules{}, CompilationProblem{} + , LoadingModules{}, LoadedModule a _ + ] -> a == testRoot </> "load-error" ++ testSuffix </> "A.hs" + _ -> False ) + , ( "reloading-unloadable-project-multi-modules", testRoot </> "load-error-multi" + , [ AddPackages [testRoot </> "load-error-multi" ++ testSuffix] ] + , writeFile (testRoot </> "load-error-multi" ++ testSuffix </> "B.hs") "module B where\n\nimport A\n\nb = a" + , [ ReLoad [] [testRoot </> "load-error-multi" ++ testSuffix </> "B.hs"] [] ] + , \case [ LoadingModules{}, LoadedModule a _, LoadedModule d _, CompilationProblem{} + , LoadingModules{}, LoadedModule b _, LoadedModule c _ + ] -> [a,b,c,d] == map ((testRoot </> "load-error-multi" ++ testSuffix) </>) ["A.hs", "B.hs","C.hs","D.hs"] + _ -> False ) + , ( "change-cabal", testRoot </> "two-modules", [], return () + , [ AddPackages [testRoot </> "two-modules" ++ testSuffix] + , ReLoad [] [testRoot </> "two-modules" ++ testSuffix </> "some-test-package.cabal"] [] + ] + , \case [ LoadingModules{}, LoadedModule a _, LoadedModule b _ + , LoadingModules{}, LoadedModule a' _, LoadedModule b' _ + ] -> [a,b] == map ((testRoot </> "two-modules" ++ testSuffix) </>) ["A.hs","B.hs"] && [a',b'] == [a,b] + _ -> False ) + , ( "change-incomplete-cabal", testRoot </> "incomplete-cabal" + , [ AddPackages [testRoot </> "incomplete-cabal" ++ testSuffix] ] + , appendFile (testRoot </> "incomplete-cabal" ++ testSuffix </> "some-test-package.cabal") ", B" + , [ ReLoad [] [testRoot </> "incomplete-cabal" ++ testSuffix </> "some-test-package.cabal"] [] ] + , \case [ LoadingModules{}, LoadedModule a _ + , LoadingModules{}, LoadedModule a' _, LoadedModule b' _ + ] -> [a',b'] == map ((testRoot </> "incomplete-cabal" ++ testSuffix) </>) ["A.hs","B.hs"] && a == a' + _ -> False ) , ( "adding-module", testRoot </> "reloading", [AddPackages [ testRoot </> "reloading" ++ testSuffix ]] , writeFile (testRoot </> "reloading" ++ testSuffix </> "D.hs") "module D where\nd = ()" , [ ReLoad [testRoot </> "reloading" ++ testSuffix </> "D.hs"] [] [] ] - , \case [ LoadingModules {}, LoadedModules {}, LoadedModules {}, LoadedModules {}, LoadingModules {} - , LoadingModules {}, LoadedModules {}, LoadedModules {}, LoadedModules {}, LoadedModules {}] -> True + , \case [ LoadingModules {}, LoadedModule {}, LoadedModule {}, LoadedModule {}, LoadingModules {} + , LoadingModules {}, LoadedModule {}, LoadedModule {}, LoadedModule {}, LoadedModule {}] -> True _ -> False ) , ( "reloading-remove", testRoot </> "reloading", [ AddPackages [ testRoot </> "reloading" ++ testSuffix ]] , do removeFile (testRoot </> "reloading" ++ testSuffix </> "A.hs") removeFile (testRoot </> "reloading" ++ testSuffix </> "B.hs") , [ ReLoad [] [testRoot </> "reloading" ++ testSuffix </> "C.hs"] [testRoot </> "reloading" ++ testSuffix </> "A.hs", testRoot </> "reloading" ++ testSuffix </> "B.hs"] - , PerformRefactoring "RenameDefinition" (testRoot </> "reloading" ++ testSuffix </> "C.hs") "3:1-3:2" ["d"] + , PerformRefactoring "RenameDefinition" "C" "3:1-3:2" ["d"] False False ] - , \case [ LoadingModules{}, LoadedModules [(pathC,_)], LoadedModules [(pathB,_)], LoadedModules [(pathA,_)] - , LoadingModules{}, LoadedModules [(pathC',_)], ModulesChanged _, LoadingModules{}, LoadedModules [(pathC'',_)] ] + , \case [ LoadingModules{}, LoadedModule pathC _, LoadedModule pathB _, LoadedModule pathA _ + , LoadingModules{}, LoadedModule pathC' _, LoadingModules{}, LoadedModule pathC'' _ ] -> let [pC,pB,pA] = map ((testRoot </> "reloading" ++ testSuffix) </>) ["C.hs","B.hs","A.hs"] in pA == pathA && pB == pathB && pC == pathC && pC == pathC' && pC == pathC'' _ -> False ) @@ -243,49 +397,149 @@ , testRoot </> "multi-packages-dependent" ++ testSuffix </> "package2" ]] , removeDirectoryRecursive (testRoot </> "multi-packages-dependent" ++ testSuffix </> "package2") , [ RemovePackages [testRoot </> "multi-packages-dependent" ++ testSuffix </> "package2"] - , PerformRefactoring "RenameDefinition" (testRoot </> "multi-packages-dependent" ++ testSuffix </> "package1" </> "A.hs") - "3:1-3:2" ["d"] + , PerformRefactoring "RenameDefinition" "A" + "3:1-3:2" ["d"] False False ] - , \case [ LoadingModules{}, LoadedModules [(pathA',_)], LoadedModules [(pathB',_)], ModulesChanged _, LoadingModules{}, LoadedModules [(pathA,_)] ] + , \case [ LoadingModules{}, LoadedModule pathA' _, LoadedModule pathB' _ + , LoadingModules{}, LoadedModule pathA _ ] -> let [pA,pB] = map ((testRoot </> "multi-packages-dependent" ++ testSuffix) </>) [ "package1" </> "A.hs", "package2" </> "B.hs"] in pA == pathA && pA == pathA' && pB == pathB' _ -> False ) ] -pkgDbTests :: [(String, IO (), [ClientMessage], [ResponseMsg])] -pkgDbTests +undoTests :: FilePath -> [(String, FilePath, [Either (IO ()) ClientMessage], [ResponseMsg] -> Bool)] +undoTests testRoot + = [ ( "nothing-to-undo", testRoot </> "simple-refactor" + , [ Right $ AddPackages [ testRoot </> "simple-refactor" ++ testSuffix ] + , Right UndoLast + ] , \case [ LoadingModules{}, LoadedModule{}, ErrorMessage{}] -> True; _ -> False ) + , ( "simple-undo", testRoot </> "simple-refactor" + , [ Right $ AddPackages [ testRoot </> "simple-refactor" ++ testSuffix ] + , Right $ PerformRefactoring "RenameDefinition" "A" "3:1-3:2" ["y"] False False + , Left $ do -- if the test does not succeed, insert a delay here + res <- readFile (testRoot </> "simple-refactor" ++ testSuffix </> "A.hs") + when (filter (`notElem` ['\r','\n']) res /= "module A wherey = ()") + $ assertFailure ("Module content after refactoring is not the expected:\n" ++ res) + , Right UndoLast + , Left $ do -- if the test does not succeed, insert a delay here + res <- readFile (testRoot </> "simple-refactor" ++ testSuffix </> "A.hs") + when (filter (`notElem` ['\r','\n']) res /= "module A wherex = ()") + $ assertFailure ("Module content after undoing is not the expected:\n" ++ res) + ] + , \case [ LoadingModules{}, LoadedModule{}, LoadingModules{}, LoadedModule{}, LoadingModules{}, LoadedModule{}] + -> True; _ -> False ) + , ( "undo-invalidated", testRoot </> "simple-refactor" + , [ Right $ AddPackages [ testRoot </> "simple-refactor" ++ testSuffix ] + , Right $ PerformRefactoring "RenameDefinition" "A" "3:1-3:2" ["y"] False False + , Right (ReLoad [] [testRoot </> "simple-refactor" ++ testSuffix </> "A.hs"] []) + , Right UndoLast + ] + , \case [ LoadingModules{}, LoadedModule{}, LoadingModules{}, LoadedModule{} + , LoadingModules{}, LoadedModule{}, ErrorMessage{} ] -> True; _ -> False ) + , ( "undo-invalidated-other-module", testRoot </> "two-modules" + , [ Right $ AddPackages [ testRoot </> "two-modules" ++ testSuffix ] + , Right $ PerformRefactoring "RenameDefinition" "A" "3:1-3:2" ["y"] False False + , Right (ReLoad [] [testRoot </> "two-modules" ++ testSuffix </> "B.hs"] []) + , Right UndoLast + ] + , \case [ LoadingModules{}, LoadedModule{}, LoadedModule{}, LoadingModules{}, LoadedModule{} + , LoadingModules{}, LoadedModule{}, ErrorMessage{} ] -> True; _ -> False ) + , ( "undo-invalidated-revalidate", testRoot </> "simple-refactor" + , [ Right $ AddPackages [ testRoot </> "simple-refactor" ++ testSuffix ] + , Right $ PerformRefactoring "RenameDefinition" "A" "3:1-3:2" ["y"] False False + , Right (ReLoad [] [testRoot </> "simple-refactor" ++ testSuffix </> "A.hs"] []) + , Right $ PerformRefactoring "RenameDefinition" "A" "3:1-3:2" ["x"] False False + , Right UndoLast + ] + , \case [ LoadingModules{}, LoadedModule{}, LoadingModules{}, LoadedModule{} + , LoadingModules{}, LoadedModule{}, LoadingModules{}, LoadedModule{} + , LoadingModules{}, LoadedModule{} ] -> True; _ -> False ) + , ( "multi-module-undo", testRoot </> "reloading" + , [ Right $ AddPackages [ testRoot </> "reloading" ++ testSuffix ] + , Right $ PerformRefactoring "RenameDefinition" "C" "3:1-3:2" ["d"] False False + , Right UndoLast + , Left $ do -- if the test does not succeed, insert a delay here + resC <- readFile (testRoot </> "reloading" ++ testSuffix </> "C.hs") + resB <- readFile (testRoot </> "reloading" ++ testSuffix </> "B.hs") + when (filter (`notElem` ['\r','\n']) resC /= "module C wherec = ()") + $ assertFailure ("C.hs content after undoing is not the expected:\n" ++ resC) + when (filter (`notElem` ['\r','\n']) resB /= "module B whereimport Cb = c") + $ assertFailure ("B.hs content after undoing is not the expected:\n" ++ resC) + ] + , \case [ LoadingModules{}, LoadedModule{}, LoadedModule{}, LoadedModule{} + , LoadingModules{}, LoadedModule{}, LoadedModule{}, LoadedModule{} + , LoadingModules{}, LoadedModule{}, LoadedModule{}, LoadedModule{} ] + -> True; _ -> False ) + , ( "multiple-undo", testRoot </> "simple-refactor" + , [ Right $ AddPackages [ testRoot </> "simple-refactor" ++ testSuffix ] + , Right $ PerformRefactoring "RenameDefinition" "A" "3:1-3:2" ["y"] False False + , Right $ PerformRefactoring "RenameDefinition" "A" "3:1-3:2" ["z"] False False + , Right UndoLast + , Right UndoLast + , Left $ do -- if the test does not succeed, insert a delay here + res <- readFile (testRoot </> "simple-refactor" ++ testSuffix </> "A.hs") + when (filter (`notElem` ['\r','\n']) res /= "module A wherex = ()") + $ assertFailure ("Module content after undoing is not the expected:\n" ++ res) + ] + , \case [ LoadingModules{}, LoadedModule{} -- initial load + , LoadingModules{}, LoadedModule{} -- re-load after first refactor + , LoadingModules{}, LoadedModule{} -- re-load after second refactor + , LoadingModules{}, LoadedModule{} -- re-load after first undo + , LoadingModules{}, LoadedModule{} -- re-load after second undo + ] + -> True; _ -> False ) + ] + +pkgDbTests :: FilePath -> [(String, IO (), [ClientMessage], [ResponseMsg])] +pkgDbTests testRoot = [ ( "cabal-sandbox" , withCurrentDirectory (testRoot </> "cabal-sandbox") initCabalSandbox - , [SetPackageDB CabalSandboxDB, AddPackages [testRoot </> "cabal-sandbox"]] + , [ SetPackageDB CabalSandboxDB, AddPackages [testRoot </> "cabal-sandbox"] ] , [ LoadingModules [testRoot </> "cabal-sandbox" </> "UseGroups.hs"] - , LoadedModules [(testRoot </> "cabal-sandbox" </> "UseGroups.hs", "UseGroups")]] ) + , LoadedModule (testRoot </> "cabal-sandbox" </> "UseGroups.hs") "UseGroups"] ) , ( "cabal-sandbox-auto" , withCurrentDirectory (testRoot </> "cabal-sandbox") initCabalSandbox - , [SetPackageDB AutoDB, AddPackages [testRoot </> "cabal-sandbox"]] + , [ AddPackages [testRoot </> "cabal-sandbox"] ] , [ LoadingModules [testRoot </> "cabal-sandbox" </> "UseGroups.hs"] - , LoadedModules [(testRoot </> "cabal-sandbox" </> "UseGroups.hs", "UseGroups")]] ) + , LoadedModule (testRoot </> "cabal-sandbox" </> "UseGroups.hs") "UseGroups"] ) , ( "pkg-db-reload" , withCurrentDirectory (testRoot </> "cabal-sandbox") initCabalSandbox - , [ SetPackageDB AutoDB - , AddPackages [testRoot </> "cabal-sandbox"] + , [ AddPackages [testRoot </> "cabal-sandbox"] , ReLoad [] [testRoot </> "cabal-sandbox" </> "UseGroups.hs"] []] , [ LoadingModules [testRoot </> "cabal-sandbox" </> "UseGroups.hs"] - , LoadedModules [(testRoot </> "cabal-sandbox" </> "UseGroups.hs", "UseGroups")] + , LoadedModule (testRoot </> "cabal-sandbox" </> "UseGroups.hs") "UseGroups" , LoadingModules [testRoot </> "cabal-sandbox" </> "UseGroups.hs"] - , LoadedModules [(testRoot </> "cabal-sandbox" </> "UseGroups.hs", "UseGroups")] ]) + , LoadedModule (testRoot </> "cabal-sandbox" </> "UseGroups.hs") "UseGroups" ]) ] - where initCabalSandbox = do - sandboxExists <- doesDirectoryExist ".cabal-sandbox" - when sandboxExists $ tryToExecute "cabal" ["sandbox", "delete"] - execute "cabal" ["sandbox", "init"] - withCurrentDirectory ("groups-0.4.0.0") $ do - execute "cabal" ["sandbox", "init", "--sandbox", ".." </> ".cabal-sandbox"] - execute "cabal" ["install"] - initStack = do - execute "stack" ["clean"] - execute "stack" ["build"] +initCabalSandbox = do + sandboxExists <- doesDirectoryExist ".cabal-sandbox" + when sandboxExists $ tryToExecute "cabal" ["sandbox", "delete"] + execute "cabal" ["sandbox", "init"] + withCurrentDirectory ("groups-0.4.0.0") $ do + execute "cabal" ["sandbox", "init", "--sandbox", ".." </> ".cabal-sandbox"] + execute "cabal" ["install"] +specialTests :: FilePath -> [(String, FilePath, Int -> Maybe FilePath -> DaemonOptions, [ClientMessage], [ResponseMsg] -> Bool)] +specialTests testRoot = + [ ( "force-code-gen-with-th", testRoot </> "th-imports-normal", codeGenOpts + , [ AddPackages [ testRoot </> "th-imports-normal" ++ testSuffix ] + , PerformRefactoring "RenameDefinition" "A" "3:6" ["A'"] False False + ] + , \case [ LoadingModules{}, LoadedModule a _, LoadedModule c _, LoadedModule b _ + , LoadingModules{}, LoadedModule a' _, LoadedModule c' _, LoadedModule b' _ + ] -> [a,b,c] == map ((testRoot </> "th-imports-normal" ++ testSuffix) </>) ["A.hs","B.hs","C.hs"] && [a',b',c'] == [a,b,c] + _ -> False ) + ] + where codeGenOpts p fs = addCodeGen (daemonOpts p fs) + addCodeGen opts = opts { sharedOptions = (sharedOptions opts) { generateCode = True } } + +------------------------------------------------------- +-- * Helper functions for test code ------------------- +------------------------------------------------------- + +sourceRoot = ".." </> ".." </> "src" + execute :: String -> [String] -> IO () execute cmd args = do let command = (cmd ++ concat (map (" " ++) args)) @@ -303,44 +557,73 @@ void $ waitForProcess handle makeDaemonTest :: MVar Int -> (String, [ClientMessage], [ResponseMsg]) -> TestTree -makeDaemonTest port (label, input, expected) = testCase label $ do - actual <- communicateWithDaemon port (map Right (SetPackageDB DefaultDB : input)) +makeDaemonTest port (label, input, expected) = testCase label $ restartOnNetworkError $ do + actual <- communicateWithDaemon False port daemonOpts (map Right (SetPackageDB DefaultDB : input)) assertEqual "" expected actual +makeComplexLoadTest :: MVar Int -> (String, FilePath, [ClientMessage], [ResponseMsg] -> Bool) -> TestTree +makeComplexLoadTest port (label, dir, inputs, validator) = testCase label $ restartOnNetworkError $ do + exists <- doesDirectoryExist (dir ++ testSuffix) + -- clear the target directory from possible earlier test runs + when exists $ removeDirectoryRecursive (dir ++ testSuffix) + copyDir dir (dir ++ testSuffix) + actual <- communicateWithDaemon False port daemonOpts (map Right (SetPackageDB DefaultDB : inputs)) + assertBool ("The responses are not the expected: " ++ show actual) (validator actual) + `finally` removeDirectoryRecursive (dir ++ testSuffix) + makeRefactorTest :: MVar Int -> (String, FilePath, [ClientMessage], [ResponseMsg] -> Bool) -> TestTree -makeRefactorTest port (label, dir, input, validator) = testCase label $ do +makeRefactorTest port (label, dir, input, validator) = testCase label $ restartOnNetworkError $ do exists <- doesDirectoryExist (dir ++ testSuffix) -- clear the target directory from possible earlier test runs when exists $ removeDirectoryRecursive (dir ++ testSuffix) copyDir dir (dir ++ testSuffix) - actual <- communicateWithDaemon port (map Right (SetPackageDB DefaultDB : input)) + actual <- communicateWithDaemon False port daemonOpts (map Right (SetPackageDB DefaultDB : input)) assertBool ("The responses are not the expected: " ++ show actual) (validator actual) `finally` removeDirectoryRecursive (dir ++ testSuffix) makeReloadTest :: MVar Int -> (String, FilePath, [ClientMessage], IO (), [ClientMessage], [ResponseMsg] -> Bool) -> TestTree -makeReloadTest port (label, dir, input1, io, input2, validator) = testCase label $ do +makeReloadTest port (label, dir, input1, io, input2, validator) = testCase label $ restartOnNetworkError $ do exists <- doesDirectoryExist (dir ++ testSuffix) -- clear the target directory from possible earlier test runs when exists $ removeDirectoryRecursive (dir ++ testSuffix) copyDir dir (dir ++ testSuffix) - actual <- communicateWithDaemon port (map Right (SetPackageDB DefaultDB : input1) ++ [Left io] ++ map Right input2) + actual <- communicateWithDaemon False port daemonOpts (map Right (SetPackageDB DefaultDB : input1) ++ [Left io] ++ map Right input2) assertBool ("The responses are not the expected: " ++ show actual) (validator actual) `finally` removeDirectoryRecursive (dir ++ testSuffix) +makeUndoTest :: MVar Int -> (String, FilePath, [Either (IO ()) ClientMessage], [ResponseMsg] -> Bool) -> TestTree +makeUndoTest port (label, dir, inputs, validator) = testCase label $ restartOnNetworkError $ do + exists <- doesDirectoryExist (dir ++ testSuffix) + -- clear the target directory from possible earlier test runs + when exists $ removeDirectoryRecursive (dir ++ testSuffix) + copyDir dir (dir ++ testSuffix) + actual <- communicateWithDaemon False port daemonOpts (Right (SetPackageDB DefaultDB) : inputs) + assertBool ("The responses are not the expected: " ++ show actual) (validator actual) + `finally` removeDirectoryRecursive (dir ++ testSuffix) + makePkgDbTest :: MVar Int -> (String, IO (), [ClientMessage], [ResponseMsg]) -> TestTree makePkgDbTest port (label, prepare, inputs, expected) - = localOption (mkTimeout ({- 30s -} 1000 * 1000 * 30)) - $ testCase label $ do - actual <- communicateWithDaemon port ([Left prepare] ++ map Right inputs) - assertEqual "" expected actual + = testCase label $ restartOnNetworkError $ do + actual <- communicateWithDaemon False port daemonOpts ([Left prepare] ++ map Right inputs) + assertEqual "" expected actual makeCompProblemTest :: MVar Int -> (String, [Either (IO ()) ClientMessage], [ResponseMsg] -> Bool) -> TestTree -makeCompProblemTest port (label, actions, validator) = testCase label $ do - actual <- communicateWithDaemon port actions +makeCompProblemTest port (label, actions, validator) = testCase label $ restartOnNetworkError $ do + actual <- communicateWithDaemon False port daemonOpts actions assertBool ("The responses are not the expected: " ++ show actual) (validator actual) -communicateWithDaemon :: MVar Int -> [Either (IO ()) ClientMessage] -> IO [ResponseMsg] -communicateWithDaemon port msgs = withSocketsDo $ do +makeSpecialTest :: MVar Int -> (String, FilePath, Int -> Maybe FilePath -> DaemonOptions, [ClientMessage], [ResponseMsg] -> Bool) -> TestTree +makeSpecialTest port (label, dir, opts, input, validator) = testCase label $ restartOnNetworkError $ do + exists <- doesDirectoryExist (dir ++ testSuffix) + -- clear the target directory from possible earlier test runs + when exists $ removeDirectoryRecursive (dir ++ testSuffix) + copyDir dir (dir ++ testSuffix) + actual <- communicateWithDaemon False port opts (map Right (SetPackageDB DefaultDB : input)) + assertBool ("The responses are not the expected: " ++ show actual) (validator actual) + `finally` removeDirectoryRecursive (dir ++ testSuffix) + +communicateWithDaemon :: Bool -> MVar Int -> (Int -> Maybe FilePath -> DaemonOptions) -> [Either (IO ()) ClientMessage] -> IO [ResponseMsg] +communicateWithDaemon watch port opts msgs = withSocketsDo $ do portNum <- retryConnect port addrInfo <- getAddrInfo Nothing (Just "127.0.0.1") (Just (show portNum)) let serverAddr = head addrInfo @@ -351,15 +634,19 @@ io return r) ((>> return []) . sendAll sock . (`BS.snoc` '\n') . encode)) msgs) - sendAll sock $ encode Disconnect + sendAll sock (encode Disconnect) + `catchIOError` \e -> hPutStrLn stderr $ "Cannot send Disconnect: " ++ show e resps <- readSockResponsesUntil sock Disconnected BS.empty - sendAll sock $ encode Stop close sock return (concat intermedRes ++ resps) where waitToConnect sock addr - = connect sock addr `catch` \(e :: SomeException) -> waitToConnect sock addr + = connect sock addr `catch` \(_ :: SomeException) -> threadDelay 10000 >> waitToConnect sock addr retryConnect port = do portNum <- readMVar port - forkIO $ runDaemon [show portNum, "True"] + watchDir <- (++) <$> glob watchPath <*> glob linuxWatchPath + case (watch, watchDir) of + (True, []) -> error "The watch executable is not found." + (True, w:_) -> forkIO $ runDaemon' builtinRefactorings (opts portNum (Just w)) + (False, _) -> forkIO $ runDaemon' builtinRefactorings (opts portNum Nothing) return portNum `catch` \(e :: SomeException) -> do putStrLn ("exception caught: `" ++ show e ++ "` trying with a new port") modifyMVar_ port (\i -> if i < pORT_NUM_END @@ -367,7 +654,34 @@ else error "The port number reached the maximum") retryConnect port +restartOnNetworkError = tryNTimes 5 +tryNTimes :: Int -> IO () -> IO () +tryNTimes 0 action = action +tryNTimes n action = action `catch` \e -> if "Network.Socket.sendBuf: failed" `isInfixOf` show e + then do putStrLn (show e) + threadDelay 1000000 + tryNTimes (n-1) action + else throwIO (e :: SomeException) + + +daemonOpts :: Int -> Maybe FilePath -> DaemonOptions +daemonOpts n we = DaemonOptions { daemonVersion = False + , portNumber = n + , silentMode = True + , sharedOptions = SharedDaemonOptions { noWatch = isNothing we + , watchExe = we + , generateCode = False + , disableHistory = False + , Options.ghcFlags = Nothing + , projectType = Nothing + } + } + +-- this must be changed once watch is in stackage +watchPath = "../../.stack-work/downloaded/*/watch-master/.stack-work/dist/*/build/watch" +linuxWatchPath = "../../.stack-work/downloaded/*/watch-master/.stack-work/dist/*/*/build/watch" + readSockResponsesUntil :: Socket -> ResponseMsg -> BS.ByteString -> IO [ResponseMsg] readSockResponsesUntil sock rsp bs = do resp <- recv sock 2048 @@ -378,7 +692,7 @@ let splitted = BS.split '\n' fullBS recognized = catMaybes $ map decode splitted in if rsp `elem` recognized - then return $ List.delete rsp recognized + then return $ takeWhile (/= rsp) recognized else readSockResponsesUntil sock rsp fullBS testRoot = "examples" </> "Project"