Get rid of gratituous temporary files

[lsp-test.git] / src / Language / Haskell / LSP / Test / Files.hs

diff --git a/src/Language/Haskell/LSP/Test/Files.hs b/src/Language/Haskell/LSP/Test/Files.hs
index 0d79ebd658c2a3f03d80d073a41f8f6552f2385f..3529526bcc47b2bfc9fe3f8d696e288b0e6bef8b 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,44 +29,50 @@ type FileMap = Map.Map Uri Uri
 emptyFileMap :: FileMap
 emptyFileMap = Map.empty
 
-buildFileMap :: [Uri] -> FileMap -> IO FileMap
-buildFileMap uris oldMap = foldM createFile oldMap uris
+buildFileMap :: Set.Set Uri -> FilePath -> FilePath -> FileMap -> IO FileMap
+buildFileMap uris oldBaseDir newBaseDir oldMap = foldM transform oldMap uris
   where
-  createFile map uri =
-    if Map.member uri map
-      then return map
-      else do
-        let fp = fromMaybe (error "Couldn't convert file path")
-                 (uriToFilePath uri)
+  transform map uri = do
+    let fp = fromMaybe (error "Couldn't convert file path") $ uriToFilePath uri
+        rel = makeRelative oldBaseDir fp
+        newFp = newBaseDir </> rel
+    newUri <- filePathToUri <$> canonicalizePath newFp
+    return $ Map.insert uri newUri map
 
-        -- 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
-
-        (tmpFp, tmpH) <- openTempFile tmpDir (takeFileName fp)
-
-        readFile fp >>= 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 oldUris recBaseDir curBaseDir fileMap
 
   let newMsgs = map (swapUris newMap) msgs
 
-  return (newMsgs, newMap)
+  case decode (head newMsgs) :: Maybe InitializeRequest of
+    -- If there is an initialize request we will need to swap
+    -- the rootUri and rootPath
+    Just req -> do
+      cd <- getCurrentDirectory
+      let newRoot = cd </> curBaseDir
+          newRootUri = params . rootUri ?~ filePathToUri newRoot $ req
+          newRootPath = params . rootPath ?~ T.pack newRoot $ newRootUri
+          newReq = encode newRootPath
+      return (newReq:tail newMsgs, newMap)
+
+    Nothing -> 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
     Just obj -> HashMap.foldlWithKey' gather Set.empty obj
-    Nothing -> error "nooo"
+    Nothing -> error "Couldn't decode message"
   where gather :: Set.Set Uri -> T.Text -> Value -> Set.Set Uri
         gather uris "uri" (String s) = Set.insert (Uri s) uris
         gather uris _ (Object o) = HashMap.foldlWithKey' gather uris o
@@ -91,3 +98,4 @@ swapUris fileMap msg =
         g x = x
 
         swap origUri = let (Uri newUri) = fileMap ! Uri origUri in newUri
+