Fix wrapper tests by copying to temporary directory

Author: lukel97

haskell-language-server.cabal

@@ -217,6 +217,8 @@ common hls-test-utils
                      , lsp-test
                      , stm
                      , tasty-hunit
+                     , temporary
+                     , process
                      , text
                      , transformers
                      , unordered-containers

test/utils/Test/Hls/Util.hs

@@ -15,6 +15,7 @@ module Test.Hls.Util
     , setupBuildToolFiles
     , withFileLogging
     , findExe
+    , withCurrentDirectoryInTmp
   -- , makeRequest
   -- , runIGM
   -- , runIGM'
@@ -46,13 +47,15 @@ import           System.Directory
 import           System.Environment
 import           System.FilePath
 import qualified System.Log.Logger as L
+import           System.IO.Temp
 -- import           Test.Hspec
 import           Test.Hspec.Runner
 import           Test.Hspec.Core.Formatters
 import           Text.Blaze.Renderer.String (renderMarkup)
 import           Text.Blaze.Internal
 -- import qualified Haskell.Ide.Engine.PluginApi as HIE (BiosOptions, defaultOptions)
 -- import HIE.Bios.Types
+import System.Process
 
 -- testOptions :: HIE.BiosOptions
 -- testOptions = HIE.defaultOptions { cradleOptsVerbosity = Verbose }
@@ -332,6 +335,36 @@ findExeRecursive exe dir = do
 findExe :: String -> IO FilePath
 findExe name = do
   fp <- fmap fromJust $ runMaybeT $
-    MaybeT (findExecutable name) <|> 
+    MaybeT (findExecutable name) <|>
     MaybeT (findExeRecursive name "dist-newstyle")
   makeAbsolute fp
+
+-- | Like 'withCurrentDirectory', but will copy the directory over to the system
+-- temporary directory first to avoid haskell-language-server's source tree from
+-- interfering with the cradle
+withCurrentDirectoryInTmp :: FilePath -> IO a -> IO a
+withCurrentDirectoryInTmp dir f =
+  withTempCopy dir $ \newDir ->
+    withCurrentDirectory newDir $ do
+      _ <- system "stack path"
+      _ <- system "stack exec env"
+      f
+
+withTempCopy :: FilePath -> (FilePath -> IO a) -> IO a
+withTempCopy srcDir f = do
+  withSystemTempDirectory "hls-test" $ \newDir -> do
+    copyDir srcDir newDir
+    f newDir
+
+copyDir :: FilePath -> FilePath -> IO ()
+copyDir src dst = do
+  cnts <- listDirectory src
+  forM_ cnts $ \file -> do
+    unless (file `elem` ignored) $ do
+      let srcFp = src </> file
+          dstFp = dst </> file
+      isDir <- doesDirectoryExist srcFp
+      if isDir
+        then createDirectory dstFp >> copyDir srcFp dstFp
+        else copyFile srcFp dstFp
+  where ignored = ["dist", "dist-newstyle", ".stack-work"]

test/wrapper/Main.hs

@@ -3,14 +3,14 @@ import Data.Char
 import Test.Hls.Util
 import Test.Tasty
 import Test.Tasty.HUnit
-import System.Directory
 import System.Process
 
 main :: IO ()
-main = defaultMain $
-  testGroup "haskell-language-server-wrapper" [projectGhcVersionTests]
+main = do
+  flushStackEnvironment
+  defaultMain $
+    testGroup "haskell-language-server-wrapper" [projectGhcVersionTests]
 
---TODO: WAIT ON HIE-BIOS STOP FILES
 projectGhcVersionTests :: TestTree
 projectGhcVersionTests = testGroup "--project-ghc-version"
   [ testCase "stack with ghc 8.10.1" $
@@ -25,10 +25,9 @@ projectGhcVersionTests = testGroup "--project-ghc-version"
 testDir :: FilePath -> String -> Assertion
 testDir dir expectedVer = do
   wrapper <- findExe "haskell-language-server-wrapper"
-  withCurrentDirectory dir $ do
+  withCurrentDirectoryInTmp dir $ do
     actualVer <- trim <$> readProcess wrapper ["--project-ghc-version"] ""
     actualVer @?= expectedVer
 
 trim :: String -> String
 trim = dropWhileEnd isSpace
-