1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE TypeOperators #-}
3 {-# LANGUAGE TypeInType #-}
5 {-# LANGUAGE RankNTypes #-}
6 {-# LANGUAGE OverloadedStrings #-}
7 module Language.LSP.Test.Files
13 import Language.LSP.Types
14 import Language.LSP.Types.Lens hiding (id)
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 swapDocumentChangeUri :: DocumentChange -> DocumentChange
79 swapDocumentChangeUri (InL textDocEdit) = InL $ swapUri textDocument textDocEdit
80 swapDocumentChangeUri (InR (InL createFile)) = InR $ InL $ swapUri id createFile
81 -- for RenameFile, we swap `newUri`
82 swapDocumentChangeUri (InR (InR (InL renameFile))) = InR $ InR $ InL $ newUri .~ f (renameFile ^. newUri) $ renameFile
83 swapDocumentChangeUri (InR (InR (InR deleteFile))) = InR $ InR $ InR $ swapUri id deleteFile
85 newDocChanges = fmap (fmap swapDocumentChangeUri) $ e ^. documentChanges
86 newChanges = fmap (swapKeys f) $ e ^. changes
87 in WorkspaceEdit newChanges newDocChanges
89 swapKeys :: (Uri -> Uri) -> HM.HashMap Uri b -> HM.HashMap Uri b
90 swapKeys f = HM.foldlWithKey' (\acc k v -> HM.insert (f k) v acc) HM.empty
92 swapUri :: HasUri b Uri => Lens' a b -> a -> a
94 let newUri = f (x ^. lens . uri)
95 in (lens . uri) .~ newUri $ x
97 -- | Transforms rootUri/rootPath.
98 transformInit :: InitializeParams -> InitializeParams
100 let newRootUri = fmap f (x ^. rootUri)
102 fp <- T.unpack <$> x ^. rootPath
103 let uri = filePathToUri fp
104 T.pack <$> uriToFilePath (f uri)
105 in (rootUri .~ newRootUri) $ (rootPath .~ newRootPath) x