{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# 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.Types
+import Language.Haskell.LSP.Types.Lens
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
+import Data.Time.Clock
-type FileMap = Map.Map FilePath FilePath
+data Event
+ = ClientEv UTCTime FromClientMessage
+ | ServerEv UTCTime FromServerMessage
-emptyFileMap :: FileMap
-emptyFileMap = Map.empty
+swapFiles :: FilePath -> [Event] -> IO [Event]
+swapFiles relCurBaseDir msgs = do
+ let capturedBaseDir = rootDir msgs
-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
+ 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
-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
+rootDir :: [Event] -> FilePath
+rootDir (ClientEv _ (FromClientMess SInitialize req):_) =
+ fromMaybe (error "Couldn't find root dir") $ do
+ rootUri <- req ^. params .rootUri
+ uriToFilePath rootUri
+rootDir _ = error "Couldn't find initialize request in session"
-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)
+mapUris :: (Uri -> Uri) -> Event -> Event
+mapUris f event =
+ case event of
+ ClientEv t msg -> ClientEv t (fromClientMsg msg)
+ ServerEv t msg -> ServerEv t (fromServerMsg msg)
-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 (FromClientMess m@SInitialize r) = FromClientMess m $ params .~ transformInit (r ^. params) $ r
+ fromClientMsg (FromClientMess m@STextDocumentDidOpen n) = FromClientMess m $ swapUri (params . textDocument) n
+ fromClientMsg (FromClientMess m@STextDocumentDidChange n) = FromClientMess m $ swapUri (params . textDocument) n
+ fromClientMsg (FromClientMess m@STextDocumentWillSave n) = FromClientMess m $ swapUri (params . textDocument) n
+ fromClientMsg (FromClientMess m@STextDocumentDidSave n) = FromClientMess m $ swapUri (params . textDocument) n
+ fromClientMsg (FromClientMess m@STextDocumentDidClose n) = FromClientMess m $ swapUri (params . textDocument) n
+ fromClientMsg (FromClientMess m@STextDocumentDocumentSymbol n) = FromClientMess m $ swapUri (params . textDocument) n
+ fromClientMsg (FromClientMess m@STextDocumentRename n) = FromClientMess m $ swapUri (params . textDocument) n
+ fromClientMsg x = x
+
+ fromServerMsg :: FromServerMessage -> FromServerMessage
+ fromServerMsg (FromServerMess m@SWorkspaceApplyEdit r) = FromServerMess m $ params . edit .~ swapWorkspaceEdit (r ^. params . edit) $ r
+ fromServerMsg (FromServerMess m@STextDocumentPublishDiagnostics n) = FromServerMess m $ swapUri params n
+ fromServerMsg (FromServerRsp m@STextDocumentDocumentSymbol r) =
+ let swapUri' :: (List DocumentSymbol |? List SymbolInformation) -> List DocumentSymbol |? List SymbolInformation
+ swapUri' (R si) = R (swapUri location <$> si)
+ swapUri' (L dss) = L dss -- no file locations here
+ in FromServerRsp m $ r & result %~ (fmap swapUri')
+ fromServerMsg (FromServerRsp m@STextDocumentRename r) = FromServerRsp m $ r & result %~ (fmap swapWorkspaceEdit)
+ 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
projects / lsp-test.git / blobdiff