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 6557b8872f948b598ad654532d012129ef77b8fd..3529526bcc47b2bfc9fe3f8d696e288b0e6bef8b 100644 (file)
--- a/src/Language/Haskell/LSP/Test/Files.hs
+++ b/src/Language/Haskell/LSP/Test/Files.hs
@@ -29,40 +29,37 @@ type FileMap = Map.Map Uri Uri
 emptyFileMap :: FileMap
 emptyFileMap = Map.empty
 
-buildFileMap :: [Uri] -> FilePath -> FilePath -> FileMap -> IO FileMap
-buildFileMap uris recBaseDir curBaseDir oldMap =
-  foldM (createFile recBaseDir curBaseDir) oldMap uris
+buildFileMap :: Set.Set Uri -> FilePath -> FilePath -> FileMap -> IO FileMap
+buildFileMap uris oldBaseDir newBaseDir oldMap = foldM transform oldMap uris
   where
-  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" </> takeDirectory relativeFp) <$> getTemporaryDirectory
-        createDirectoryIfMissing True tmpDir
-
-        (tmpFp, tmpH) <- openTempFile tmpDir (takeFileName actualFp)
-
-        readFile actualFp >>= hPutStr tmpH
-        tmpUri <- filePathToUri <$> canonicalizePath tmpFp
-        return $ Map.insert uri tmpUri map
+  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
 
 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) recBaseDir curBaseDir 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
@@ -75,7 +72,7 @@ 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
@@ -101,3 +98,4 @@ swapUris fileMap msg =
         g x = x
 
         swap origUri = let (Uri newUri) = fileMap ! Uri origUri in newUri
+