diff --git a/Language/Haskell/Tools/Refactor/Daemon.hs b/Language/Haskell/Tools/Refactor/Daemon.hs --- a/Language/Haskell/Tools/Refactor/Daemon.hs +++ b/Language/Haskell/Tools/Refactor/Daemon.hs @@ -4,6 +4,7 @@ , LambdaCase , TemplateHaskell , FlexibleContexts + , MultiWayIf #-} module Language.Haskell.Tools.Refactor.Daemon where @@ -11,7 +12,7 @@ import Control.Concurrent.MVar import Control.Exception import Control.Monad -import Control.Monad.State +import Control.Monad.State.Strict import Control.Reference import qualified Data.Aeson as A ((.=)) import Data.Aeson hiding ((.=)) @@ -33,6 +34,7 @@ import System.Environment import System.IO import System.IO.Strict as StrictIO (hGetContents) +import Data.Version import Bag import DynFlags @@ -54,8 +56,7 @@ import Language.Haskell.Tools.Refactor.Prepare import Language.Haskell.Tools.Refactor.RefactorBase import Language.Haskell.Tools.Refactor.Session - -import Debug.Trace +import Paths_haskell_tools_daemon runDaemonCLI :: IO () runDaemonCLI = getArgs >>= runDaemon @@ -71,7 +72,7 @@ setSocketOption sock ReuseAddr 1 when (not isSilent) $ putStrLn $ "Listening on port " ++ finalArgs !! 0 bind sock (SockAddrInet (read (finalArgs !! 0)) iNADDR_ANY) - listen sock 1 + listen sock 4 clientLoop isSilent sock defaultArgs :: [String] @@ -116,6 +117,7 @@ -- | 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 @@ -129,12 +131,15 @@ lift $ deregisterDirs (mcs ^? traversal & filtered isRemoved & mcSourceDirs & traversal) modify $ refSessMCs .- filter (not . isRemoved) modifySession (\s -> s { hsc_mod_graph = filter (not . (`elem` existing) . ms_mod) (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 removedMods <- gets (map ms_mod . filter ((`elem` removed) . getModSumOrig) . (^? refSessMCs & traversal & mcModules & traversal & modRecMS)) + do mcs <- gets (^. refSessMCs) + removedMods <- gets (map ms_mod . filter ((`elem` removed) . getModSumOrig) . (^? refSessMCs & traversal & mcModules & traversal & modRecMS)) lift $ forM_ removedMods (\modName -> removeTarget (TargetModule (GHC.moduleName modName))) -- remove targets deleted modify $ refSessMCs & traversal & mcModules @@ -234,26 +239,38 @@ forM_ existing $ \mn -> removeTarget (TargetModule (GHC.moduleName mn)) modifySession (\s -> s { hsc_mod_graph = filter (not . (`elem` existing) . ms_mod) (hsc_mod_graph s) }) -- load new modules - initializePackageDBIfNeeded - 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, ignoredMods) -> do - mapM_ (reloadModule (\_ -> return ())) (either (const []) id needToReload) -- don't report consequent reloads (not expected) - liftIO $ when (not $ null ignoredMods) - $ resp $ ErrorMessage - $ "The following modules are ignored: " - ++ concat (intersperse ", " ignoredMods) - ++ ". Multiple modules with the same qualified name are not supported." - Left err -> liftIO $ resp $ either ErrorMessage CompilationProblem (getProblems err) + 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, ignoredMods) -> do + mapM_ (reloadModule (\_ -> return ())) (either (const []) id needToReload) -- don't report consequent reloads (not expected) + liftIO $ when (not $ null ignoredMods) + $ resp $ ErrorMessage + $ "The following modules are ignored: " + ++ concat (intersperse ", " ignoredMods) + ++ ". Multiple modules with the same qualified name are not supported." + 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) - when (not pkgDBAlreadySet) $ do - pkgDB <- gets (^. packageDB) - pkgDBLocs <- liftIO $ packageDBLocs pkgDB packagePathes - usePackageDB pkgDBLocs - modify (packageDBSet .= True) + 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 } @@ -297,6 +314,7 @@ data ClientMessage = KeepAlive + | Handshake { clientVersion :: [Int] } | SetPackageDB { pkgDB :: PackageDB } | AddPackages { addedPathes :: [FilePath] } | RemovePackages { removedPathes :: [FilePath] } @@ -317,6 +335,7 @@ data ResponseMsg = KeepAliveResponse + | HandshakeResponse { serverVersion :: [Int] } | ErrorMessage { errorMsg :: String } | CompilationProblem { errorMarkers :: [(SrcSpan, String)] } | ModulesChanged { undoChanges :: [UndoRefactor] } diff --git a/Language/Haskell/Tools/Refactor/Daemon/PackageDB.hs b/Language/Haskell/Tools/Refactor/Daemon/PackageDB.hs --- a/Language/Haskell/Tools/Refactor/Daemon/PackageDB.hs +++ b/Language/Haskell/Tools/Refactor/Daemon/PackageDB.hs @@ -20,9 +20,6 @@ instance FromJSON PackageDB -packageDBLocs :: PackageDB -> [FilePath] -> IO [FilePath] -packageDBLocs pack = fmap concat . mapM (packageDBLoc pack) - packageDBLoc :: PackageDB -> FilePath -> IO [FilePath] packageDBLoc AutoDB path = (++) <$> packageDBLoc StackDB path <*> packageDBLoc CabalSandboxDB path packageDBLoc DefaultDB _ = return [] @@ -34,8 +31,8 @@ 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", "--snapshot-pkg-db"] "" - (_, localDB, localDBErrs) <- readProcessWithExitCode "stack" ["path", "--local-pkg-db"] "" + (_, 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) @@ -45,10 +42,11 @@ -- | 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 = choose [ detectAutogen root DefaultDB - , detectAutogen root CabalSandboxDB - , detectAutogen root StackDB - ] +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") @@ -56,8 +54,9 @@ distExists <- doesDirectoryExist (root ".stack-work" "dist") existing <- if distExists then (do contents <- listDirectory (root ".stack-work" "dist") - dirs <- filterM doesDirectoryExist contents - mapM (ifExists . ( "build" "autogen")) dirs) else return [] + 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) diff --git a/Language/Haskell/Tools/Refactor/Daemon/State.hs b/Language/Haskell/Tools/Refactor/Daemon/State.hs --- a/Language/Haskell/Tools/Refactor/Daemon/State.hs +++ b/Language/Haskell/Tools/Refactor/Daemon/State.hs @@ -6,10 +6,11 @@ import Language.Haskell.Tools.Refactor.Daemon.PackageDB import Language.Haskell.Tools.Refactor.Session -data DaemonSessionState +data DaemonSessionState = DaemonSessionState { _refactorSession :: RefactorSessionState , _packageDB :: PackageDB , _packageDBSet :: Bool + , _packageDBLocs :: [FilePath] , _exiting :: Bool } @@ -17,4 +18,4 @@ instance IsRefactSessionState DaemonSessionState where refSessMCs = refactorSession & refSessMCs - initSession = DaemonSessionState initSession AutoDB False False + initSession = DaemonSessionState initSession AutoDB False [] False diff --git a/haskell-tools-daemon.cabal b/haskell-tools-daemon.cabal --- a/haskell-tools-daemon.cabal +++ b/haskell-tools-daemon.cabal @@ -1,5 +1,5 @@ name: haskell-tools-daemon -version: 0.6.0.0 +version: 0.7.0.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. homepage: https://github.com/haskell-tools/haskell-tools @@ -62,7 +62,7 @@ library build-depends: base >= 4.9 && < 5.0 - , aeson >= 1.0 && < 1.2 + , aeson >= 1.0 && < 1.3 , bytestring >= 0.10 && < 1.0 , filepath >= 1.4 && < 2.0 , strict >= 0.3 && < 0.4 @@ -76,18 +76,20 @@ , references >= 0.3.2 && < 1.0 , network >= 2.6 && < 3.0 , Diff >= 0.3 && < 0.4 - , haskell-tools-ast >= 0.6 && < 0.7 - , haskell-tools-prettyprint >= 0.6 && < 0.7 - , haskell-tools-refactor >= 0.6 && < 0.7 + , haskell-tools-ast >= 0.7 && < 0.8 + , haskell-tools-prettyprint >= 0.7 && < 0.8 + , haskell-tools-refactor >= 0.7 && < 0.8 exposed-modules: Language.Haskell.Tools.Refactor.Daemon , Language.Haskell.Tools.Refactor.Daemon.State , Language.Haskell.Tools.Refactor.Daemon.PackageDB + , Paths_haskell_tools_daemon default-language: Haskell2010 executable ht-daemon + ghc-options: -rtsopts build-depends: base >= 4.9 && < 5.0 - , haskell-tools-daemon >= 0.6 && < 0.7 + , haskell-tools-daemon >= 0.7 && < 0.8 hs-source-dirs: exe main-is: Main.hs default-language: Haskell2010 @@ -107,6 +109,6 @@ , filepath >= 1.4 && < 2.0 , bytestring >= 0.10 && < 0.11 , network >= 2.6 && < 2.7 - , aeson >= 1.0 && < 1.2 - , haskell-tools-daemon >= 0.6 && < 0.7 + , aeson >= 1.0 && < 1.3 + , haskell-tools-daemon >= 0.7 && < 0.8 default-language: Haskell2010 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -35,12 +35,13 @@ main = do unsetEnv "GHC_PACKAGE_PATH" portCounter <- newMVar pORT_NUM_START tr <- canonicalizePath testRoot - isStackRun <- isJust <$> lookupEnv "STACK_EXE" - defaultMain (allTests isStackRun tr portCounter) + hasStack <- isJust <$> findExecutable "stack" + hasCabal <- isJust <$> findExecutable "cabal" + defaultMain (allTests (hasStack && hasCabal) tr portCounter) allTests :: Bool -> FilePath -> MVar Int -> TestTree allTests isSource testRoot portCounter - = localOption (mkTimeout ({- 10s -} 1000 * 1000 * 10)) + = localOption (mkTimeout ({- 10s -} 1000 * 1000 * 20)) $ testGroup "daemon-tests" [ testGroup "simple-tests" $ map (makeDaemonTest portCounter) simpleTests @@ -89,15 +90,15 @@ , ( "multi-packages" , [ AddPackages [ testRoot "multi-packages" "package1" , testRoot "multi-packages" "package2" ]] - , [ LoadingModules [ testRoot "multi-packages" "package1" "A.hs" - , testRoot "multi-packages" "package2" "B.hs" ] + , [ 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") ] ] ) , ( "multi-packages-flags" , [ AddPackages [ testRoot "multi-packages-flags" "package1" , testRoot "multi-packages-flags" "package2" ]] - , [ LoadingModules [ testRoot "multi-packages-flags" "package1" "A.hs" - , testRoot "multi-packages-flags" "package2" "B.hs" ] + , [ 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") ] ] ) , ( "multi-packages-dependent" @@ -109,7 +110,7 @@ , LoadedModules [ (testRoot "multi-packages-dependent" "package2" "B.hs", "B") ] ] ) , ( "has-th" , [AddPackages [testRoot "has-th"]] - , [ LoadingModules [ testRoot "has-th" "A.hs", testRoot "has-th" "TH.hs" ] + , [ 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") ] ] ) , ( "th-added-later" @@ -118,28 +119,26 @@ ] , [ LoadingModules [ testRoot "th-added-later" "package1" "A.hs" ] , LoadedModules [(testRoot "th-added-later" "package1" "A.hs", "A")] - , LoadingModules [ testRoot "th-added-later" "package1" "A.hs" - , testRoot "th-added-later" "package2" "B.hs" ] - , LoadedModules [(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")] ] ) ] compProblemTests :: [(String, [Either (IO ()) ClientMessage], [ResponseMsg] -> Bool)] compProblemTests = [ ( "load-error" - , [ Right $ AddPackages [testRoot "load-error"] ] + , [ Right $ SetPackageDB DefaultDB, Right $ AddPackages [testRoot "load-error"] ] , \case [LoadingModules{}, CompilationProblem {}] -> True; _ -> False) , ( "source-error" - , [ Right $ AddPackages [testRoot "source-error"] ] + , [ Right $ SetPackageDB DefaultDB, Right $ AddPackages [testRoot "source-error"] ] , \case [LoadingModules{}, CompilationProblem {}] -> True; _ -> False) , ( "reload-error" - , [ Right $ AddPackages [testRoot "empty"] + , [ Right $ SetPackageDB DefaultDB, Right $ AddPackages [testRoot "empty"] , 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) , ( "reload-source-error" - , [ Right $ AddPackages [testRoot "empty"] + , [ 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"] @@ -148,7 +147,7 @@ , [ Right $ PerformRefactoring "RenameDefinition" (testRoot "simple-refactor" ++ testSuffix "A.hs") "3:1-3:2" ["y"] ] , \case [ ErrorMessage _ ] -> True; _ -> False ) , ( "additional-files" - , [ Right $ AddPackages [testRoot "additional-files"] ] + , [ Right $ SetPackageDB DefaultDB, Right $ AddPackages [testRoot "additional-files"] ] , \case [ LoadingModules {}, ErrorMessage _ ] -> True; _ -> False ) ] @@ -157,7 +156,7 @@ 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", "daemon"]) ] + [ 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) @@ -368,7 +367,6 @@ readSockResponsesUntil :: Socket -> ResponseMsg -> BS.ByteString -> IO [ResponseMsg] readSockResponsesUntil sock rsp bs = do resp <- recv sock 2048 - -- putStrLn $ "###" ++ BS.unpack resp let fullBS = bs `BS.append` resp if BS.null resp then return []