Add root directory swapping

diff --git a/.travis.yml b/.travis.yml
index 9e73eaa8db66581a4464d933d378c265b0c5567b..03adf0be77154f76e5d616542c92f47b4a0a7696 100644 (file)
--- a/.travis.yml
+++ b/.travis.yml
@@ -13,5 +13,11 @@ before_install:
   - export PATH=$HOME/.local/bin:$PATH
   - travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
 
+install:
+  - git clone https://github.com/haskell/haskell-ide-engine.git --recursive
+  - cd haskell-ide-engine
+  - stack install
+  - cd ..
+
 script:
   - stack --no-terminal --skip-ghc-check test

diff --git a/example/Recorded.hs b/example/Recorded.hs
index 470bfdbb7bcba1a8cf1ac8bfba3e2d9937528772..63ee8775cad8dc8d9c1aacd715f704427223fc0a 100644 (file)
--- a/example/Recorded.hs
+++ b/example/Recorded.hs
@@ -3,6 +3,6 @@ import           System.Directory
 import           System.Environment
 
 main = do
-  [client, server] <- (take 2 <$> getArgs) >>= mapM canonicalizePath
-  passed <- replay client server
+  [client, server, dir] <- (take 3 <$> getArgs) >>= mapM canonicalizePath
+  passed <- replay client server dir
   putStrLn $ if passed then "Passed" else "Failed"

diff --git a/src/Language/Haskell/LSP/Test/Files.hs b/src/Language/Haskell/LSP/Test/Files.hs
index 0d79ebd658c2a3f03d80d073a41f8f6552f2385f..6557b8872f948b598ad654532d012129ef77b8fd 100644 (file)
--- a/src/Language/Haskell/LSP/Test/Files.hs
+++ b/src/Language/Haskell/LSP/Test/Files.hs
@@ -5,11 +5,12 @@ module Language.Haskell.LSP.Test.Files
   ( swapFiles
   , FileMap
   , emptyFileMap
+  , rootDir
   )
 where
 
 import           Language.Haskell.LSP.Types        hiding ( error )
-import           Language.Haskell.LSP.Test.Parsing
+import           Control.Lens
 import           Control.Monad
 import           Data.Aeson
 import qualified Data.ByteString.Lazy.Char8    as B
@@ -28,39 +29,48 @@ type FileMap = Map.Map Uri Uri
 emptyFileMap :: FileMap
 emptyFileMap = Map.empty
 
-buildFileMap :: [Uri] -> FileMap -> IO FileMap
-buildFileMap uris oldMap = foldM createFile oldMap uris
+buildFileMap :: [Uri] -> FilePath -> FilePath -> FileMap -> IO FileMap
+buildFileMap uris recBaseDir curBaseDir oldMap =
+  foldM (createFile recBaseDir curBaseDir) oldMap uris
   where
-  createFile map uri =
+  createFile baseDir curDir  map uri =
     if Map.member uri map
       then return map
       else do
         let fp = fromMaybe (error "Couldn't convert file path")
                  (uriToFilePath uri)
+            relativeFp = makeRelative baseDir fp
+            actualFp = curDir </> relativeFp
 
         -- Need to store in a directory inside tmp directory
         -- otherwise ghc-mod ends up creating one for us
-        tmpDir <- (</> "lsp-test") <$> getTemporaryDirectory
-        createDirectoryIfMissing False tmpDir
+        tmpDir <- (</> "lsp-test" </> takeDirectory relativeFp) <$> getTemporaryDirectory
+        createDirectoryIfMissing True tmpDir
 
-        (tmpFp, tmpH) <- openTempFile tmpDir (takeFileName fp)
+        (tmpFp, tmpH) <- openTempFile tmpDir (takeFileName actualFp)
 
-        readFile fp >>= hPutStr tmpH
+        readFile actualFp >>= hPutStr tmpH
         tmpUri <- filePathToUri <$> canonicalizePath tmpFp
         return $ Map.insert uri tmpUri map
 
-swapFiles :: FileMap -> Handle -> IO ([B.ByteString], FileMap)
-swapFiles fileMap h = do
-  msgs <- getAllMessages h
+swapFiles :: FileMap -> FilePath -> FilePath -> [B.ByteString] -> IO ([B.ByteString], FileMap)
+swapFiles fileMap recBaseDir curBaseDir msgs = do
 
   let oldUris = Set.unions $ map extractUris msgs
 
-  newMap <- buildFileMap (Set.elems oldUris) fileMap
+  newMap <- buildFileMap (Set.elems oldUris) recBaseDir curBaseDir fileMap
 
   let newMsgs = map (swapUris newMap) msgs
 
   return (newMsgs, newMap)
 
+rootDir :: [B.ByteString] -> FilePath
+rootDir msgs = case decode (head msgs) :: Maybe InitializeRequest of
+                Just req -> fromMaybe (error "Couldn't convert root dir") $ do
+                  rootUri <- req ^. params . rootUri
+                  uriToFilePath rootUri
+                Nothing -> error "Couldn't find root dir"
+
 extractUris :: B.ByteString -> Set.Set Uri
 extractUris msgs =
   case decode msgs :: Maybe Object of

diff --git a/src/Language/Haskell/LSP/Test/Recorded.hs b/src/Language/Haskell/LSP/Test/Recorded.hs
index cf20c67a2deff652c80b36c70ef5e94756b2f933..c92664c977deb811361f206dff29e37fe4e023d0 100644 (file)
--- a/src/Language/Haskell/LSP/Test/Recorded.hs
+++ b/src/Language/Haskell/LSP/Test/Recorded.hs
@@ -30,8 +30,9 @@ import           Language.Haskell.LSP.Test.Parsing
 replay
   :: FilePath -- ^ The client output to replay to the server.
   -> FilePath -- ^ The expected response from the server.
+  -> FilePath -- ^ The root directory of the project
   -> IO Bool
-replay cfp sfp = do
+replay cfp sfp curRootDir = do
 
   -- need to keep hold of current directory since haskell-lsp changes it
   prevDir <- getCurrentDirectory
@@ -56,14 +57,18 @@ replay cfp sfp = do
   null         <- openFile "/dev/null" WriteMode
 
 
-  (clientMsgs, fileMap) <- swapFiles emptyFileMap clientRecIn
+  unswappedClientMsgs <- getAllMessages clientRecIn
+
+  let recRootDir = rootDir unswappedClientMsgs
+  
+  (clientMsgs, fileMap) <- swapFiles emptyFileMap recRootDir curRootDir unswappedClientMsgs
 
   tmpDir <- getTemporaryDirectory
   (_, mappedClientRecIn) <- openTempFile tmpDir "clientRecInMapped"
   mapM_ (B.hPut mappedClientRecIn . addHeader) clientMsgs
   hSeek mappedClientRecIn AbsoluteSeek 0
 
-  (expectedMsgs, _) <- swapFiles fileMap serverRecIn
+  (expectedMsgs, _) <- swapFiles fileMap recRootDir curRootDir =<< getAllMessages serverRecIn
 
   -- listen to server
   forkIO $ runReaderT (listenServer expectedMsgs serverOut semas) didPass

diff --git a/test/Test.hs b/test/Test.hs
index 986b4c5202e16da4b8e187b77a2db2db38b541ee..2851427db0d0ceb77f41c07d1933fe7196d254d5 100644 (file)
--- a/test/Test.hs
+++ b/test/Test.hs
@@ -6,6 +6,7 @@ main = hspec $ do
     it "passes a test" $ do
       replay "test/recordings/renamePass/client.log"
              "test/recordings/renamePass/server.log"
+             "test/recordings/renamePass"
         `shouldReturn` True
     -- it "fails a test" $
     --   replay "test/recordings/documentSymbolFail/client.log"

diff --git a/test/files/simple.hs b/test/recordings/renamePass/Desktop/simple.hs
similarity index 100%
rename from test/files/simple.hs
rename to test/recordings/renamePass/Desktop/simple.hs