haskell-tools-daemon (empty) → 0.4.0.0

raw patch · 7 files changed

+650/−0 lines, 7 filesdep +HUnitdep +aesondep +basesetup-changed

Dependencies added: HUnit, aeson, base, bytestring, containers, directory, filepath, ghc, ghc-paths, haskell-tools-ast, haskell-tools-daemon, haskell-tools-prettyprint, haskell-tools-refactor, mtl, network, references, split, tasty, tasty-hunit

Files

LICENSE +29/−0
Language/Haskell/Tools/Refactor/Daemon.hs +239/−0
Language/Haskell/Tools/Refactor/Daemon/State.hs +18/−0
Setup.hs +2/−0
exe/Main.hs +8/−0
haskell-tools-daemon.cabal +59/−0
test/Main.hs +295/−0

+ LICENSE view

@@ -0,0 +1,29 @@+Haskell-Tools is Copyright (c) Boldizsár Németh, 2016, all rights reserved,
+and is distributed as free software under the following license.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+
+- Redistributions of source code must retain the above copyright
+notice, this list of conditions, and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright
+notice, this list of conditions, and the following disclaimer in the
+documentation and/or other materials provided with the distribution.
+
+- The names of the copyright holders may not be used to endorse or
+promote products derived from this software without specific prior
+written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY
+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE
+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
+IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Language/Haskell/Tools/Refactor/Daemon.hs view

@@ -0,0 +1,239 @@+{-# LANGUAGE ScopedTypeVariables
+           , OverloadedStrings 
+           , DeriveGeneric
+           , LambdaCase
+           , TemplateHaskell
+           , FlexibleContexts
+           #-}
+module Language.Haskell.Tools.Refactor.Daemon where
+
+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 GHC.Generics
+
+import Network.Socket hiding (send, sendTo, recv, recvFrom, KeepAlive)
+import Network.Socket.ByteString.Lazy
+import Control.Exception
+import Data.Aeson hiding ((.=))
+import Data.Map (Map, (!), member, insert)
+import qualified Data.Map as Map
+import GHC.Generics
+
+import System.IO
+import System.IO.Error
+import System.FilePath
+import System.Directory
+import Data.IORef
+import Data.List hiding (insert)
+import Data.Tuple
+import Data.Maybe
+import Control.Applicative ((<|>))
+import Control.Monad
+import Control.Monad.State
+import Control.Concurrent.MVar
+import Control.Monad.IO.Class
+import System.Environment
+import Debug.Trace
+
+import GHC hiding (loadModule)
+import Bag (bagToList)
+import SrcLoc (realSrcSpanStart)
+import ErrUtils (errMsgSpan)
+import DynFlags (gopt_set)
+import GHC.Paths ( libdir )
+import GhcMonad (GhcMonad(..), Session(..), reflectGhc, modifySession)
+import HscTypes (SourceError, srcErrorMessages, hsc_mod_graph)
+import FastString (unpackFS)
+
+import Control.Reference
+
+import Language.Haskell.Tools.AST
+import Language.Haskell.Tools.Refactor.GetModules
+import Language.Haskell.Tools.Refactor.Prepare
+import Language.Haskell.Tools.Refactor.Perform
+import Language.Haskell.Tools.Refactor.RefactorBase
+import Language.Haskell.Tools.Refactor.Session
+import Language.Haskell.Tools.PrettyPrint
+import Language.Haskell.Tools.Refactor.Daemon.State
+
+-- TODO: handle boot files
+
+runDaemonCLI :: IO ()
+runDaemonCLI = getArgs >>= runDaemon
+
+runDaemon :: [String] -> IO ()
+runDaemon args = withSocketsDo $
+    do let finalArgs = args ++ drop (length args) defaultArgs
+           isSilent = read (finalArgs !! 1)
+       addrinfos <- getAddrInfo
+                    (Just (defaultHints {addrFlags = [AI_PASSIVE]}))
+                    Nothing (Just (finalArgs !! 0))
+       let serveraddr = head addrinfos
+       sock <- socket (addrFamily serveraddr) Stream defaultProtocol
+       setSocketOption sock ReuseAddr 1
+       bind sock (addrAddress serveraddr)
+       listen sock 1
+       clientLoop isSilent sock
+
+defaultArgs = ["4123", "True"]
+
+clientLoop :: Bool -> Socket -> IO ()
+clientLoop isSilent sock
+  = do (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 sock
+  where interrupted = \s 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 KeepAlive = liftIO (resp KeepAliveResponse) >> return True
+updateClient resp Disconnect = liftIO (resp Disconnected) >> return False
+updateClient resp (AddPackages packagePathes) = do
+    existing <- gets (map ms_mod . (^? refSessMCs & traversal & filtered isTheAdded & mcModules & traversal & modRecMS))
+    needToReload <- (filter (\ms -> not $ ms_mod ms `elem` existing)) 
+                      <$> getReachableModules (\ms -> ms_mod ms `elem` existing)
+    modify $ refSessMCs .- filter (not . isTheAdded) -- remove the added package from the database
+    forM_ existing $ \mn -> removeTarget (TargetModule (GHC.moduleName mn))
+    modifySession (\s -> s { hsc_mod_graph = filter (not . (`elem` existing) . ms_mod) (hsc_mod_graph s) })
+    (modules, ignoredMods) <- loadPackagesFrom (return . getModSumOrig) packagePathes
+    mapM_ (reloadModule (\_ -> return ())) needToReload -- don't report consequent reloads (not expected)
+    liftIO $ resp 
+      $ if not (null ignoredMods) 
+          then ErrorMessage 
+                 $ "The following modules are ignored: " 
+                     ++ concat (intersperse ", " ignoredMods)
+                     ++ ". Multiple modules with the same qualified name are not supported."
+          else LoadedModules modules
+    return True
+  where isTheAdded mc = (mc ^. mcRoot) `elem` packagePathes
+
+updateClient resp (RemovePackages packagePathes) = do
+    mcs <- gets (^. refSessMCs)
+    let existing = map ms_mod (mcs ^? traversal & filtered isRemoved & mcModules & traversal & modRecMS)
+    lift $ forM_ existing (\modName -> removeTarget (TargetModule (GHC.moduleName modName)))
+    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) })
+    mods <- lift getModuleGraph
+    return True
+  where isRemoved mc = (mc ^. mcRoot) `elem` packagePathes
+
+updateClient resp (ReLoad changed removed) =
+  do removedMods <- gets (map ms_mod . filter ((`elem` removed) . getModSumOrig) . (^? refSessMCs & traversal & mcModules & traversal & modRecMS))
+     lift $ forM_ removedMods (\modName -> removeTarget (TargetModule (GHC.moduleName modName)))
+     modify $ refSessMCs & traversal & mcModules 
+                .- Map.filter (\m -> maybe True (not . (`elem` removed) . getModSumOrig) (m ^? modRecMS))
+     modifySession (\s -> s { hsc_mod_graph = filter (not . (`elem` removedMods) . ms_mod) (hsc_mod_graph s) })
+     reloadChangedModules (\ms -> resp (LoadedModules [getModSumOrig ms]))
+                          (\ms -> getModSumOrig ms `elem` changed)
+     return True
+
+updateClient _ Stop = modify (exiting .= True) >> return False
+
+updateClient resp (PerformRefactoring refact modPath selection args) = do
+    (Just actualMod, otherMods) <- getFileMods modPath
+    let cmd = analyzeCommand refact (selection:args)
+    res <- lift $ performCommand cmd actualMod otherMods
+    case res of
+      Left err -> liftIO $ resp $ ErrorMessage err
+      Right diff -> do changedMods <- catMaybes <$> applyChanges diff
+                       liftIO $ resp $ ModulesChanged (map snd changedMods)
+                       void $ reloadChanges (map ((^. sfkModuleName) . fst) changedMods)
+    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
+              modify $ refSessMCs & traversal & filtered (\mc' -> (mc' ^. mcId) == (mc ^. mcId)) & mcModules 
+                         .- Map.insert (SourceFileKey NormalHs n) (ModuleNotLoaded False)
+              otherSrcDir <- liftIO $ getSourceDir otherMS
+              let loc = toFileName otherSrcDir n
+              liftIO $ withBinaryFile loc WriteMode (`hPutStr` prettyPrint m)
+              lift $ addTarget (Target (TargetModule (GHC.mkModuleName n)) True Nothing)
+              return $ Just (SourceFileKey NormalHs n, loc)
+            ContentChanged (n,m) -> do
+              Just (_, mr) <- gets (lookupModInSCs n . (^. refSessMCs))
+              let Just ms = mr ^? modRecMS
+              liftIO $ withBinaryFile (getModSumOrig ms) WriteMode (`hPutStr` prettyPrint m)
+              return $ Just (n, getModSumOrig ms)
+            ModuleRemoved mod -> do
+              Just (_,m) <- gets (lookupModInSCs (SourceFileKey NormalHs mod) . (^. refSessMCs))
+              let modName = GHC.moduleName $ fromJust $ fmap semanticsModule (m ^? typedRecModule) <|> fmap semanticsModule (m ^? renamedRecModule)
+              ms <- getModSummary modName
+              lift $ removeTarget (TargetModule modName)
+              modify $ (refSessMCs .- removeModule mod)
+              liftIO $ removeFile (getModSumOrig ms)
+              return Nothing
+          
+        reloadChanges changedMods 
+          = reloadChangedModules (\ms -> resp $ LoadedModules [getModSumOrig ms]) (\ms -> modSumName ms `elem` changedMods)
+
+initGhcSession :: IO Session
+initGhcSession = Session <$> (newIORef =<< runGhc (Just libdir) (initGhcFlags >> getSession))
+
+data ClientMessage
+  = KeepAlive
+  | AddPackages { addedPathes :: [FilePath] }
+  | RemovePackages { removedPathes :: [FilePath] }
+  | PerformRefactoring { refactoring :: String
+                       , modulePath :: FilePath
+                       , editorSelection :: String
+                       , details :: [String]
+                       }
+  | Stop
+  | Disconnect
+  | ReLoad { changedModules :: [FilePath]
+           , removedModules :: [FilePath]
+           }
+  -- ReLoadAll -- re-load all modules
+  -- Reset -- completely re-initialize the refactor sesson
+  deriving (Show, Generic)
+
+
+instance FromJSON ClientMessage 
+
+data ResponseMsg
+  = KeepAliveResponse
+  | ErrorMessage { errorMsg :: String }
+  | CompilationProblem { errorMsg :: String }
+  | ModulesChanged { moduleChanges :: [FilePath] }
+  | LoadedModules { loadedModules :: [FilePath] }
+  | Disconnected
+  deriving (Show, Generic)
+
+instance ToJSON ResponseMsg

+ Language/Haskell/Tools/Refactor/Daemon/State.hs view

@@ -0,0 +1,18 @@+{-# LANGUAGE TemplateHaskell #-}
+module Language.Haskell.Tools.Refactor.Daemon.State where
+
+import Control.Reference
+
+import Language.Haskell.Tools.Refactor.GetModules
+import Language.Haskell.Tools.Refactor.Session
+
+data DaemonSessionState 
+  = DaemonSessionState { _refactorSession :: RefactorSessionState
+                       , _exiting :: Bool
+                       }
+
+makeReferences ''DaemonSessionState
+
+instance IsRefactSessionState DaemonSessionState where
+  refSessMCs = refactorSession & refSessMCs
+  initSession = DaemonSessionState initSession False

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain

+ exe/Main.hs view

@@ -0,0 +1,8 @@+module Main where
+
+import System.Environment
+
+import Language.Haskell.Tools.Refactor.Daemon
+
+main :: IO ()
+main = runDaemonCLI

+ haskell-tools-daemon.cabal view

@@ -0,0 +1,59 @@+name:                haskell-tools-daemon
+version:             0.4.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
+license:             BSD3
+license-file:        LICENSE
+author:              Boldizsar Nemeth
+maintainer:          nboldi@elte.hu
+category:            Language
+build-type:          Simple
+cabal-version:       >=1.10
+
+library
+  ghc-options:         -O2
+  build-depends:       base                      >= 4.9   && < 5.0
+                     , aeson                     >= 0.11  && < 1.0
+                     , bytestring                >= 0.10  && < 1.0
+                     , filepath                  >= 1.4   && < 2.0
+                     , containers                >= 0.5   && < 0.6
+                     , mtl                       >= 2.2   && < 2.3
+                     , split                     >= 0.2   && < 1.0
+                     , directory                 >= 1.2   && < 1.3
+                     , ghc                       >= 8.0   && < 8.1
+                     , ghc-paths                 >= 0.1   && < 0.2
+                     , references                >= 0.3.2 && < 1.0
+                     , network                   >= 2.6   && < 3.0
+                     , haskell-tools-ast         >= 0.4   && < 0.5
+                     , haskell-tools-prettyprint >= 0.4   && < 0.5
+                     , haskell-tools-refactor    >= 0.4   && < 0.5
+  exposed-modules:     Language.Haskell.Tools.Refactor.Daemon
+                     , Language.Haskell.Tools.Refactor.Daemon.State
+  default-language:    Haskell2010
+
+
+executable ht-daemon
+  ghc-options:         -O2
+  build-depends:       base                      >= 4.9 && < 5.0
+                     , haskell-tools-daemon      >= 0.4 && < 0.5
+  hs-source-dirs:      exe
+  main-is:             Main.hs
+  default-language:    Haskell2010
+
+test-suite haskell-tools-daemon-tests
+  type:                exitcode-stdio-1.0
+  ghc-options:         -with-rtsopts=-M2g -O2
+  hs-source-dirs:      test
+  main-is:             Main.hs  
+  build-depends:       base                      >= 4.9  && < 4.10
+                     , HUnit                     >= 1.3  && < 1.4
+                     , tasty                     >= 0.11 && < 0.12
+                     , tasty-hunit               >= 0.9  && < 0.10
+                     , directory                 >= 1.2  && < 1.3
+                     , filepath                  >= 1.4  && < 2.0
+                     , bytestring                >= 0.10 && < 0.11
+                     , network                   >= 2.6  && < 2.7
+                     , aeson                     >= 0.11 && < 0.12
+                     , haskell-tools-daemon      >= 0.4  && < 0.5
+  default-language:    Haskell2010

+ test/Main.hs view

@@ -0,0 +1,295 @@+{-# LANGUAGE StandaloneDeriving, LambdaCase #-}
+module Main where
+
+import Test.Tasty
+import Test.Tasty.HUnit
+import System.Exit
+import System.Directory
+import System.FilePath
+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.Aeson
+import Data.Maybe
+import System.IO
+import System.Directory
+
+import Debug.Trace
+
+import Language.Haskell.Tools.Refactor.Daemon
+
+main :: IO ()
+main = do -- create one daemon process for the whole testing session
+          -- with separate processes it is not a problem
+          forkIO $ runDaemon ["4123", "True"]
+          tr <- canonicalizePath testRoot
+          defaultMain (allTests tr)
+          stopDaemon
+
+allTests :: FilePath -> TestTree
+allTests testRoot
+  = localOption (mkTimeout ({- 10s -} 1000 * 1000 * 10)) 
+      $ testGroup "daemon-tests" 
+          [ testGroup "simple-tests" 
+              $ map (makeDaemonTest . (\(label, input, output) -> (Nothing, label, input, output))) simpleTests
+          , testGroup "loading-tests" 
+              $ map (makeDaemonTest . (\(label, input, output) -> (Nothing, label, input, output))) loadingTests
+          , testGroup "refactor-tests" 
+              $ map (makeDaemonTest . (\(label, dir, input, output) -> (Just (testRoot </> dir), label, input, output))) (refactorTests testRoot)
+          , testGroup "reload-tests" 
+              $ map makeReloadTest reloadingTests
+          , selfLoadingTest
+          ]
+
+testSuffix = "_test"
+
+simpleTests :: [(String, [ClientMessage], [ResponseMsg])]
+simpleTests = 
+  [ ( "empty-test", [], [] )
+  , ( "keep-alive", [KeepAlive], [KeepAliveResponse] )
+  ]
+
+loadingTests :: [(String, [ClientMessage], [ResponseMsg])]
+loadingTests =
+  [ ( "load-package"
+    , [AddPackages [testRoot </> "has-cabal"]]
+    , [LoadedModules [testRoot </> "has-cabal" </> "A.hs"]] )
+  , ( "no-cabal"
+    , [AddPackages [testRoot </> "no-cabal"]]
+    , [LoadedModules [testRoot </> "no-cabal" </> "A.hs"]] )
+  , ( "source-dir"
+    , [AddPackages [testRoot </> "source-dir"]]
+    , [LoadedModules [testRoot </> "source-dir" </> "src" </> "A.hs"]] )
+  , ( "source-dir-outside"
+    , [AddPackages [testRoot </> "source-dir-outside"]]
+    , [LoadedModules [testRoot </> "source-dir-outside" </> ".." </> "src" </> "A.hs"]] )
+  , ( "multi-packages"
+    , [ AddPackages [ testRoot </> "multi-packages" </> "package1"
+                    , testRoot </> "multi-packages" </> "package2" ]]
+    , [ LoadedModules [ testRoot </> "multi-packages" </> "package2" </> "B.hs"
+                      , testRoot </> "multi-packages" </> "package1" </> "A.hs"]] )
+  , ( "multi-packages-flags"
+    , [ AddPackages [ testRoot </> "multi-packages-flags" </> "package1"
+                    , testRoot </> "multi-packages-flags" </> "package2" ]]
+    , [ LoadedModules [ testRoot </> "multi-packages-flags" </> "package2" </> "B.hs"
+                      , testRoot </> "multi-packages-flags" </> "package1" </> "A.hs"]] )
+  , ( "multi-packages-dependent"
+    , [ AddPackages [ testRoot </> "multi-packages-dependent" </> "package1"
+                    , testRoot </> "multi-packages-dependent" </> "package2" ]]
+    , [ LoadedModules [ testRoot </> "multi-packages-dependent" </> "package1" </> "A.hs"
+                      , testRoot </> "multi-packages-dependent" </> "package2" </> "B.hs"]] )
+  , ( "has-th"
+    , [AddPackages [testRoot </> "has-th"]]
+    , [LoadedModules [testRoot </> "has-th" </> "TH.hs", testRoot </> "has-th" </> "A.hs"]] )
+  , ( "th-added-later"
+    , [ AddPackages [testRoot </> "th-added-later" </> "package1"]
+      , AddPackages [testRoot </> "th-added-later" </> "package2"] 
+      ]
+    , [ LoadedModules [testRoot </> "th-added-later" </> "package1" </> "A.hs"] 
+      , LoadedModules [testRoot </> "th-added-later" </> "package2" </> "B.hs"]] )
+  ]
+
+sourceRoot = ".." </> ".." </> "src"
+
+selfLoadingTest :: TestTree
+selfLoadingTest = localOption (mkTimeout ({- 2 min -} 1000 * 1000 * 60 * 2)) $ testCase "self-load" $ do  
+    actual <- communicateWithDaemon 
+                [ Right $ AddPackages (map (sourceRoot </>) ["ast" {-, "backend-ghc", "prettyprint", "rewrite", "refactor", "cli", "daemon" -} ] ) ]
+    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)
+
+
+refactorTests :: FilePath -> [(String, FilePath, [ClientMessage], [ResponseMsg])]
+refactorTests testRoot =
+  [ ( "simple-refactor", "simple-refactor"
+    , [ AddPackages [ testRoot </> "simple-refactor" ++ testSuffix ]
+      , PerformRefactoring "RenameDefinition" (testRoot </> "simple-refactor" ++ testSuffix </> "A.hs") "3:1-3:2" ["y"]
+      ]
+    , [ LoadedModules [ testRoot </> "simple-refactor" ++ testSuffix </> "A.hs" ]
+      , ModulesChanged [ testRoot </> "simple-refactor" ++ testSuffix </> "A.hs" ] 
+      , LoadedModules [ testRoot </> "simple-refactor" ++ testSuffix </> "A.hs" ]
+      ] )
+  , ( "hs-boots", "hs-boots"
+    , [ AddPackages [ testRoot </> "hs-boots" ++ testSuffix ]
+      , PerformRefactoring "RenameDefinition" (testRoot </> "hs-boots" ++ testSuffix </> "A.hs") "5:1-5:2" ["aa"]
+      ]
+    , [ LoadedModules [ testRoot </> "hs-boots" ++ testSuffix </> "B.hs-boot", testRoot </> "hs-boots" ++ testSuffix </> "A.hs-boot"
+                      , testRoot </> "hs-boots" ++ testSuffix </> "A.hs", testRoot </> "hs-boots" ++ testSuffix </> "B.hs" ]
+      , ModulesChanged [ testRoot </> "hs-boots" ++ testSuffix </> "A.hs", testRoot </> "hs-boots" ++ testSuffix </> "B.hs"
+                       , testRoot </> "hs-boots" ++ testSuffix </> "A.hs-boot" ] 
+      , LoadedModules [ testRoot </> "hs-boots" ++ testSuffix </> "A.hs-boot" ]
+      , LoadedModules [ testRoot </> "hs-boots" ++ testSuffix </> "B.hs-boot" ]
+      , LoadedModules [ testRoot </> "hs-boots" ++ testSuffix </> "A.hs" ]
+      , LoadedModules [ testRoot </> "hs-boots" ++ testSuffix </> "B.hs" ]
+      ] )
+  , ( "remove-module", "simple-refactor"
+    , [ AddPackages [ testRoot </> "simple-refactor" ++ testSuffix ]
+      , PerformRefactoring "RenameDefinition" (testRoot </> "simple-refactor" ++ testSuffix </> "A.hs") "1:8-1:9" ["AA"]
+      ]
+    , [ LoadedModules [ testRoot </> "simple-refactor" ++ testSuffix </> "A.hs" ]
+      , ModulesChanged [ testRoot </> "simple-refactor" ++ testSuffix </> "AA.hs" ] 
+      , LoadedModules [ testRoot </> "simple-refactor" ++ testSuffix </> "AA.hs" ]
+      ] )
+  ]
+
+reloadingTests :: [(String, FilePath, [ClientMessage], IO (), [ClientMessage], [ResponseMsg])]
+reloadingTests =
+  [ ( "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"] 
+      ]
+    , [ LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "C.hs"
+                      , testRoot </> "reloading" ++ testSuffix </> "B.hs"
+                      , testRoot </> "reloading" ++ testSuffix </> "A.hs" ]
+      , LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "C.hs" ]
+      , LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "B.hs" ]
+      , LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "A.hs" ]
+      , ModulesChanged [ testRoot </> "reloading" ++ testSuffix </> "C.hs"
+                       , testRoot </> "reloading" ++ testSuffix </> "B.hs" ]
+      , LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "C.hs" ]
+      , LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "B.hs" ]
+      , LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "A.hs" ]
+      ]
+    )
+  , ( "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"] 
+      ]
+    , [ LoadedModules [ testRoot </> "changing-cabal" ++ testSuffix </> "A.hs" ]
+      , LoadedModules [ testRoot </> "changing-cabal" ++ testSuffix </> "A.hs"
+                      , testRoot </> "changing-cabal" ++ testSuffix </> "B.hs" ]
+      , ModulesChanged [ testRoot </> "changing-cabal" ++ testSuffix </> "A.hs"
+                       , testRoot </> "changing-cabal" ++ testSuffix </> "B.hs" ]
+      , LoadedModules [ testRoot </> "changing-cabal" ++ testSuffix </> "A.hs" ]
+      , LoadedModules [ testRoot </> "changing-cabal" ++ testSuffix </> "B.hs" ]
+      ]
+    )
+  , ( "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"] 
+      ]
+    , [ LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "C.hs"
+                      , testRoot </> "reloading" ++ testSuffix </> "B.hs"
+                      , testRoot </> "reloading" ++ testSuffix </> "A.hs" ]
+      , LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "C.hs" ]
+      , ModulesChanged [ testRoot </> "reloading" ++ testSuffix </> "C.hs" ]
+      , LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "C.hs" ]
+      ]
+    )
+  , ( "remove-package", testRoot </> "multi-packages-dependent"
+    , [ AddPackages [ testRoot </> "multi-packages-dependent" ++ testSuffix </> "package1"
+                    , 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"] 
+      ]
+    , [ LoadedModules [ testRoot </> "multi-packages-dependent" ++ testSuffix </> "package1" </> "A.hs"
+                      , testRoot </> "multi-packages-dependent" ++ testSuffix </> "package2" </> "B.hs" ]
+      , ModulesChanged [ testRoot </> "multi-packages-dependent" ++ testSuffix </> "package1" </> "A.hs" ]
+      , LoadedModules [ testRoot </> "multi-packages-dependent" ++ testSuffix </> "package1" </> "A.hs" ]
+      ]
+    )
+  ]
+
+makeDaemonTest :: (Maybe FilePath, String, [ClientMessage], [ResponseMsg]) -> TestTree
+makeDaemonTest (Nothing, label, input, expected) = testCase label $ do  
+    actual <- communicateWithDaemon (map Right input)
+    assertEqual "" expected actual
+makeDaemonTest (Just dir, label, input, expected) = testCase label $ 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 (map Right input)
+    assertEqual "" expected actual
+  `finally` removeDirectoryRecursive (dir ++ testSuffix)
+
+makeReloadTest :: (String, FilePath, [ClientMessage], IO (), [ClientMessage], [ResponseMsg]) -> TestTree
+makeReloadTest (label, dir, input1, io, input2, expected) = testCase label $ 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 (map Right input1 ++ [Left io] ++ map Right input2)
+    assertEqual "" expected actual
+  `finally` removeDirectoryRecursive (dir ++ testSuffix)
+
+communicateWithDaemon :: [Either (IO ()) ClientMessage] -> IO [ResponseMsg]
+communicateWithDaemon msgs = withSocketsDo $ do
+  addrInfo <- getAddrInfo Nothing (Just "127.0.0.1") (Just "4123")
+  let serverAddr = head addrInfo
+  sock <- socket (addrFamily serverAddr) Stream defaultProtocol
+  connect sock (addrAddress serverAddr)
+  intermedRes <- sequence (map (either (\io -> do sendAll sock (encode KeepAlive)
+                                                  r <- readSockResponsesUntil sock KeepAliveResponse BS.empty
+                                                  io
+                                                  return r)
+                               ((>> return []) . sendAll sock . (`BS.snoc` '\n') . encode)) msgs)
+  sendAll sock $ encode Disconnect
+  resps <- readSockResponsesUntil sock Disconnected BS.empty
+  close sock
+  return (concat intermedRes ++ resps)
+
+readSockResponsesUntil :: Socket -> ResponseMsg -> BS.ByteString -> IO [ResponseMsg]
+readSockResponsesUntil sock rsp bs
+  = do resp <- recv sock 2048
+       let fullBS = bs `BS.append` resp
+       if BS.null resp 
+         then return []
+         else
+           let splitted = BS.split '\n' fullBS
+               recognized = catMaybes $ map decode splitted
+            in if rsp `elem` recognized 
+                 then return $ List.delete rsp recognized 
+                 else readSockResponsesUntil sock rsp fullBS
+
+stopDaemon :: IO ()
+stopDaemon = withSocketsDo $ do
+  addrInfo <- getAddrInfo Nothing (Just "127.0.0.1") (Just "4123")
+  let serverAddr = head addrInfo
+  sock <- socket (addrFamily serverAddr) Stream defaultProtocol
+  connect sock (addrAddress serverAddr)
+
+  sendAll sock $ encode Stop
+  close sock
+
+testRoot = ".." </> ".." </> "examples" </> "Project"
+
+deriving instance Eq ResponseMsg
+instance FromJSON ResponseMsg
+instance ToJSON ClientMessage
+
+copyDir ::  FilePath -> FilePath -> IO ()
+copyDir src dst = do
+  createDirectory dst
+  content <- getDirectoryContents src
+  let xs = filter (`notElem` [".", ".."]) content
+  forM_ xs $ \name -> do
+    let srcPath = src </> name
+    let dstPath = dst </> name
+    isDirectory <- doesDirectoryExist srcPath
+    if isDirectory
+      then copyDir srcPath dstPath
+      else copyFile srcPath dstPath
+
+commonPrefix :: (Eq e) => [e] -> [e] -> [e]
+commonPrefix _ [] = []
+commonPrefix [] _ = []
+commonPrefix (x:xs) (y:ys)
+  | x == y    = x : commonPrefix xs ys
+  | otherwise = []
+
+longestCommonPrefix :: (Eq a) => [[a]] -> [a]
+longestCommonPrefix = foldl1 commonPrefix