haskell-tools-daemon 0.6.0.0 → 0.7.0.0

raw patch · 5 files changed

+80/−61 lines, 5 filesdep ~aesondep ~haskell-tools-astdep ~haskell-tools-daemonPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson, haskell-tools-ast, haskell-tools-daemon, haskell-tools-prettyprint, haskell-tools-refactor

API changes (from Hackage documentation)

Files

• Language/Haskell/Tools/Refactor/Daemon.hs +41/−22
• Language/Haskell/Tools/Refactor/Daemon/PackageDB.hs +10/−11
• Language/Haskell/Tools/Refactor/Daemon/State.hs +3/−2
• haskell-tools-daemon.cabal +10/−8
• test/Main.hs +16/−18

@@ -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] }

@@ -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)
 
 

@@ -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

@@ -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

@@ -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 []