Start work on swapping out 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
new file mode 100644 (file)
index 0000000..52632eb
--- /dev/null
+++ b/src/Language/Haskell/LSP/Test/Files.hs
@@ -0,0 +1,116 @@
+{-# LANGUAGE FlexibleContexts #-}
+module Language.Haskell.LSP.Test.Files
+  ( loadSwappedFiles
+  , FileMap
+  , emptyFileMap
+  )
+where
+
+import           Language.Haskell.LSP.Core
+import qualified Language.Haskell.LSP.Control  as Control
+import           Language.Haskell.LSP.Types        hiding ( error )
+import           Data.Default
+import           Control.Lens
+import           Control.Monad
+import           Control.Concurrent
+import           Data.Aeson
+import qualified Data.ByteString.Lazy.Char8    as B
+import           Data.Map                      as Map
+import           Data.Maybe
+import           System.Directory
+import           System.IO
+
+type FileMap = Map.Map FilePath FilePath
+
+emptyFileMap :: FileMap
+emptyFileMap = Map.empty
+
+buildFiles
+  :: (HasParams a b, HasTextDocument b c, HasUri c Uri)
+  => [a]
+  -> FileMap
+  -> IO FileMap
+buildFiles ns oldMap = foldM createFile oldMap ns
+ where
+  createFile map n = do
+    let fp = fromMaybe (error "Couldn't convert file path")
+                       (uriToFilePath $ n ^. params . textDocument . uri)
+    if Map.member fp map
+      then return map
+      else do
+        tmpDir        <- getTemporaryDirectory
+        (tmpFp, tmpH) <- openTempFile tmpDir "lspTestDoc"
+        readFile fp >>= hPutStr tmpH
+        return $ Map.insert fp tmpFp map
+
+swapFile :: (HasUri a Uri) => FileMap -> a -> a
+swapFile m msg = fromMaybe msg $ do
+  let oldUri = msg ^. uri
+  oldFp <- uriToFilePath oldUri
+  newFp <- Map.lookup oldFp m
+  let newUri = filePathToUri newFp
+  return $ uri .~ newUri $ msg
+
+loadSwappedFiles :: FileMap -> Handle -> IO ([B.ByteString], FileMap)
+loadSwappedFiles map h = do
+  fileMapVar <- newMVar map
+  msgsVar    <- newMVar []
+  nullH      <- openFile "/dev/null" WriteMode
+  Control.runWithHandles h
+                         nullH
+                         (const $ Right (), const $ return Nothing)
+                         (handlers msgsVar fileMapVar)
+                         def
+                         Nothing
+                         Nothing
+  newMap <- readMVar fileMapVar
+  msgs   <- reverse <$> readMVar msgsVar
+  return (msgs, newMap)
+
+handlers :: MVar [B.ByteString] -> MVar FileMap -> Handlers
+handlers msgs fileMap = Handlers
+  {
+    -- Requests
+    hoverHandler                             = Just put
+  , completionHandler                        = Just put
+  , completionResolveHandler                 = Just put
+  , signatureHelpHandler                     = Just put
+  , definitionHandler                        = Just put
+  , referencesHandler                        = Just put
+  , documentHighlightHandler                 = Just put
+  , documentSymbolHandler                    = Just $ swapUri (params . textDocument)
+  , workspaceSymbolHandler                   = Just put
+  , codeActionHandler                        = Just put
+  , codeLensHandler                          = Just put
+  , codeLensResolveHandler                   = Just put
+  , documentFormattingHandler                = Just put
+  , documentRangeFormattingHandler           = Just put
+  , documentTypeFormattingHandler            = Just put
+  , renameHandler                            = Just $ swapUri (params . textDocument)
+  , documentLinkHandler                      = Just $ swapUri (params . textDocument)
+  , documentLinkResolveHandler               = Just put
+  , executeCommandHandler                    = Just put
+  , initializeRequestHandler                 = Just put
+    -- Notifications
+  , didChangeConfigurationParamsHandler      = Just put
+  , didOpenTextDocumentNotificationHandler   = Just $ swapUri (params . textDocument)
+  , didChangeTextDocumentNotificationHandler = Just $ swapUri (params . textDocument)
+  , didCloseTextDocumentNotificationHandler  = Just $ swapUri (params . textDocument)
+  , didSaveTextDocumentNotificationHandler   = Just $ swapUri (params . textDocument)
+  , willSaveWaitUntilTextDocHandler          = Just put
+  , didChangeWatchedFilesNotificationHandler = Just put
+  , initializedHandler                       = Just put
+  , willSaveTextDocumentNotificationHandler  = Just $ swapUri (params . textDocument)
+  , cancelNotificationHandler                = Just put
+  , exitNotificationHandler                  = Just put
+    -- Responses
+  , responseHandler                          = Just put
+  }
+ where
+  swapUri f msg = do
+    modifyMVar_ fileMap (buildFiles [msg])
+    map <- readMVar fileMap
+    put $ swapFile map $ msg ^. f
+
+  put :: ToJSON a => a -> IO ()
+  put msg = modifyMVar_ msgs (return . (encode msg :))