X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FFiles.hs;h=1c453a6e2632c83d233358cd57de7d730319db98;hb=fa0bdbf2ca975ea2493d0fcfaa6cb63c076567c1;hp=52632eb91d7b9e81b1795dc0c1b435f65d7f19b3;hpb=e728814eed6134acf8281a1ad08eecaf438a736a;p=lsp-test.git diff --git a/src/Language/Haskell/LSP/Test/Files.hs b/src/Language/Haskell/LSP/Test/Files.hs index 52632eb..1c453a6 100644 --- a/src/Language/Haskell/LSP/Test/Files.hs +++ b/src/Language/Haskell/LSP/Test/Files.hs @@ -1,116 +1,100 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} module Language.Haskell.LSP.Test.Files - ( loadSwappedFiles - , FileMap - , emptyFileMap + ( swapFiles + , rootDir ) 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 Language.Haskell.LSP.Capture +import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Types.Lens hiding (error) +import Language.Haskell.LSP.Messages 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 qualified Data.HashMap.Strict as HM +import qualified Data.Text as T import Data.Maybe import System.Directory -import System.IO +import System.FilePath -type FileMap = Map.Map FilePath FilePath +swapFiles :: FilePath -> [Event] -> IO [Event] +swapFiles relCurBaseDir msgs = do + let capturedBaseDir = rootDir msgs -emptyFileMap :: FileMap -emptyFileMap = Map.empty + curBaseDir <- ( relCurBaseDir) <$> getCurrentDirectory + let transform uri = + let fp = fromMaybe (error "Couldn't transform uri") (uriToFilePath uri) + newFp = curBaseDir makeRelative capturedBaseDir fp + in filePathToUri newFp + newMsgs = map (mapUris transform) msgs + + return newMsgs + +rootDir :: [Event] -> FilePath +rootDir (FromClient _ (ReqInitialize req):_) = + fromMaybe (error "Couldn't find root dir") $ do + rootUri <- req ^. params .rootUri + uriToFilePath rootUri +rootDir _ = error "Couldn't find initialize request in session" + +mapUris :: (Uri -> Uri) -> Event -> Event +mapUris f event = + case event of + FromClient t msg -> FromClient t (fromClientMsg msg) + FromServer t msg -> FromServer t (fromServerMsg msg) -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 + --TODO: Handle all other URIs that might need swapped + fromClientMsg (NotDidOpenTextDocument n) = NotDidOpenTextDocument $ swapUri (params . textDocument) n + fromClientMsg (NotDidChangeTextDocument n) = NotDidChangeTextDocument $ swapUri (params . textDocument) n + fromClientMsg (NotWillSaveTextDocument n) = NotWillSaveTextDocument $ swapUri (params . textDocument) n + fromClientMsg (NotDidSaveTextDocument n) = NotDidSaveTextDocument $ swapUri (params . textDocument) n + fromClientMsg (NotDidCloseTextDocument n) = NotDidCloseTextDocument $ swapUri (params . textDocument) n + fromClientMsg (ReqInitialize r) = ReqInitialize $ params .~ transformInit (r ^. params) $ r + fromClientMsg (ReqDocumentSymbols r) = ReqDocumentSymbols $ swapUri (params . textDocument) r + fromClientMsg (ReqRename r) = ReqRename $ swapUri (params . textDocument) r + fromClientMsg x = x + + fromServerMsg :: FromServerMessage -> FromServerMessage + fromServerMsg (ReqApplyWorkspaceEdit r) = + ReqApplyWorkspaceEdit $ params . edit .~ swapWorkspaceEdit (r ^. params . edit) $ r + + fromServerMsg (NotPublishDiagnostics n) = NotPublishDiagnostics $ swapUri params n + + fromServerMsg (RspDocumentSymbols r) = + let newSymbols = case r ^. result of + Just (DSSymbolInformation si) -> Just (DSSymbolInformation (fmap (swapUri location) si)) + x -> x + in RspDocumentSymbols $ result .~ newSymbols $ r + + fromServerMsg (RspRename r) = + let oldResult = r ^. result :: Maybe WorkspaceEdit + newResult = fmap swapWorkspaceEdit oldResult + in RspRename $ result .~ newResult $ r + + fromServerMsg x = x + + swapWorkspaceEdit :: WorkspaceEdit -> WorkspaceEdit + swapWorkspaceEdit e = + let newDocChanges = fmap (fmap (swapUri textDocument)) $ e ^. documentChanges + newChanges = fmap (swapKeys f) $ e ^. changes + in WorkspaceEdit newChanges newDocChanges + + swapKeys :: (Uri -> Uri) -> HM.HashMap Uri b -> HM.HashMap Uri b + swapKeys f = HM.foldlWithKey' (\acc k v -> HM.insert (f k) v acc) HM.empty + + swapUri :: HasUri b Uri => Lens' a b -> a -> a + swapUri lens x = + let newUri = f (x ^. lens . uri) + in (lens . uri) .~ newUri $ x - put :: ToJSON a => a -> IO () - put msg = modifyMVar_ msgs (return . (encode msg :)) + -- | Transforms rootUri/rootPath. + transformInit :: InitializeParams -> InitializeParams + transformInit x = + let newRootUri = fmap f (x ^. rootUri) + newRootPath = do + fp <- T.unpack <$> x ^. rootPath + let uri = filePathToUri fp + T.pack <$> uriToFilePath (f uri) + in (rootUri .~ newRootUri) $ (rootPath .~ newRootPath) x