1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE TypeOperators #-}
3 {-# LANGUAGE DataKinds #-}
5 {-# LANGUAGE RankNTypes #-}
6 {-# LANGUAGE OverloadedStrings #-}
7 module Language.LSP.Test.Files
13 import Language.LSP.Types
14 import Language.LSP.Types.Lens
16 import qualified Data.HashMap.Strict as HM
17 import qualified Data.Text as T
19 import System.Directory
20 import System.FilePath
21 import Data.Time.Clock
24 = ClientEv UTCTime FromClientMessage
25 | ServerEv UTCTime FromServerMessage
27 swapFiles :: FilePath -> [Event] -> IO [Event]
28 swapFiles relCurBaseDir msgs = do
29 let capturedBaseDir = rootDir msgs
31 curBaseDir <- (</> relCurBaseDir) <$> getCurrentDirectory
33 let fp = fromMaybe (error "Couldn't transform uri") (uriToFilePath uri)
34 newFp = curBaseDir </> makeRelative capturedBaseDir fp
35 in filePathToUri newFp
36 newMsgs = map (mapUris transform) msgs
40 rootDir :: [Event] -> FilePath
41 rootDir (ClientEv _ (FromClientMess SInitialize req):_) =
42 fromMaybe (error "Couldn't find root dir") $ do
43 rootUri <- req ^. params .rootUri
45 rootDir _ = error "Couldn't find initialize request in session"
47 mapUris :: (Uri -> Uri) -> Event -> Event
50 ClientEv t msg -> ClientEv t (fromClientMsg msg)
51 ServerEv t msg -> ServerEv t (fromServerMsg msg)
54 --TODO: Handle all other URIs that might need swapped
55 fromClientMsg (FromClientMess m@SInitialize r) = FromClientMess m $ params .~ transformInit (r ^. params) $ r
56 fromClientMsg (FromClientMess m@STextDocumentDidOpen n) = FromClientMess m $ swapUri (params . textDocument) n
57 fromClientMsg (FromClientMess m@STextDocumentDidChange n) = FromClientMess m $ swapUri (params . textDocument) n
58 fromClientMsg (FromClientMess m@STextDocumentWillSave n) = FromClientMess m $ swapUri (params . textDocument) n
59 fromClientMsg (FromClientMess m@STextDocumentDidSave n) = FromClientMess m $ swapUri (params . textDocument) n
60 fromClientMsg (FromClientMess m@STextDocumentDidClose n) = FromClientMess m $ swapUri (params . textDocument) n
61 fromClientMsg (FromClientMess m@STextDocumentDocumentSymbol n) = FromClientMess m $ swapUri (params . textDocument) n
62 fromClientMsg (FromClientMess m@STextDocumentRename n) = FromClientMess m $ swapUri (params . textDocument) n
65 fromServerMsg :: FromServerMessage -> FromServerMessage
66 fromServerMsg (FromServerMess m@SWorkspaceApplyEdit r) = FromServerMess m $ params . edit .~ swapWorkspaceEdit (r ^. params . edit) $ r
67 fromServerMsg (FromServerMess m@STextDocumentPublishDiagnostics n) = FromServerMess m $ swapUri params n
68 fromServerMsg (FromServerRsp m@STextDocumentDocumentSymbol r) =
69 let swapUri' :: (List DocumentSymbol |? List SymbolInformation) -> List DocumentSymbol |? List SymbolInformation
70 swapUri' (InR si) = InR (swapUri location <$> si)
71 swapUri' (InL dss) = InL dss -- no file locations here
72 in FromServerRsp m $ r & result %~ (fmap swapUri')
73 fromServerMsg (FromServerRsp m@STextDocumentRename r) = FromServerRsp m $ r & result %~ (fmap swapWorkspaceEdit)
76 swapWorkspaceEdit :: WorkspaceEdit -> WorkspaceEdit
78 let newDocChanges = fmap (fmap (swapUri textDocument)) $ e ^. documentChanges
79 newChanges = fmap (swapKeys f) $ e ^. changes
80 in WorkspaceEdit newChanges newDocChanges
82 swapKeys :: (Uri -> Uri) -> HM.HashMap Uri b -> HM.HashMap Uri b
83 swapKeys f = HM.foldlWithKey' (\acc k v -> HM.insert (f k) v acc) HM.empty
85 swapUri :: HasUri b Uri => Lens' a b -> a -> a
87 let newUri = f (x ^. lens . uri)
88 in (lens . uri) .~ newUri $ x
90 -- | Transforms rootUri/rootPath.
91 transformInit :: InitializeParams -> InitializeParams
93 let newRootUri = fmap f (x ^. rootUri)
95 fp <- T.unpack <$> x ^. rootPath
96 let uri = filePathToUri fp
97 T.pack <$> uriToFilePath (f uri)
98 in (rootUri .~ newRootUri) $ (rootPath .~ newRootPath) x