1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE RankNTypes #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 module Language.Haskell.LSP.Test.Files
10 import Language.Haskell.LSP.Capture
11 import Language.Haskell.LSP.Types
12 import Language.Haskell.LSP.Types.Lens hiding (error)
13 import Language.Haskell.LSP.Messages
15 import qualified Data.HashMap.Strict as HM
16 import qualified Data.Text as T
18 import System.Directory
19 import System.FilePath
21 swapFiles :: FilePath -> [Event] -> IO [Event]
22 swapFiles relCurBaseDir msgs = do
23 let capturedBaseDir = rootDir msgs
25 curBaseDir <- (</> relCurBaseDir) <$> getCurrentDirectory
27 let fp = fromMaybe (error "Couldn't transform uri") (uriToFilePath uri)
28 newFp = curBaseDir </> makeRelative capturedBaseDir fp
29 in filePathToUri newFp
30 newMsgs = map (mapUris transform) msgs
34 rootDir :: [Event] -> FilePath
35 rootDir (FromClient _ (ReqInitialize req):_) =
36 fromMaybe (error "Couldn't find root dir") $ do
37 rootUri <- req ^. params .rootUri
39 rootDir _ = error "Couldn't find initialize request in session"
41 mapUris :: (Uri -> Uri) -> Event -> Event
44 FromClient t msg -> FromClient t (fromClientMsg msg)
45 FromServer t msg -> FromServer t (fromServerMsg msg)
48 --TODO: Handle all other URIs that might need swapped
49 fromClientMsg (NotDidOpenTextDocument n) = NotDidOpenTextDocument $ swapUri (params . textDocument) n
50 fromClientMsg (NotDidChangeTextDocument n) = NotDidChangeTextDocument $ swapUri (params . textDocument) n
51 fromClientMsg (NotWillSaveTextDocument n) = NotWillSaveTextDocument $ swapUri (params . textDocument) n
52 fromClientMsg (NotDidSaveTextDocument n) = NotDidSaveTextDocument $ swapUri (params . textDocument) n
53 fromClientMsg (NotDidCloseTextDocument n) = NotDidCloseTextDocument $ swapUri (params . textDocument) n
54 fromClientMsg (ReqInitialize r) = ReqInitialize $ params .~ transformInit (r ^. params) $ r
55 fromClientMsg (ReqDocumentSymbols r) = ReqDocumentSymbols $ swapUri (params . textDocument) r
56 fromClientMsg (ReqRename r) = ReqRename $ swapUri (params . textDocument) r
59 fromServerMsg :: FromServerMessage -> FromServerMessage
60 fromServerMsg (ReqApplyWorkspaceEdit r) =
61 ReqApplyWorkspaceEdit $ params . edit .~ swapWorkspaceEdit (r ^. params . edit) $ r
63 fromServerMsg (NotPublishDiagnostics n) = NotPublishDiagnostics $ swapUri params n
65 fromServerMsg (RspDocumentSymbols r) =
66 let newSymbols = case r ^. result of
67 Just (DSSymbolInformation si) -> Just (DSSymbolInformation (fmap (swapUri location) si))
69 in RspDocumentSymbols $ result .~ newSymbols $ r
71 fromServerMsg (RspRename r) =
72 let oldResult = r ^. result :: Maybe WorkspaceEdit
73 newResult = fmap swapWorkspaceEdit oldResult
74 in RspRename $ result .~ newResult $ r
78 swapWorkspaceEdit :: WorkspaceEdit -> WorkspaceEdit
80 let newDocChanges = fmap (fmap (swapUri textDocument)) $ e ^. documentChanges
81 newChanges = fmap (swapKeys f) $ e ^. changes
82 in WorkspaceEdit newChanges newDocChanges
84 swapKeys :: (Uri -> Uri) -> HM.HashMap Uri b -> HM.HashMap Uri b
85 swapKeys f = HM.foldlWithKey' (\acc k v -> HM.insert (f k) v acc) HM.empty
87 swapUri :: HasUri b Uri => Lens' a b -> a -> a
89 let newUri = f (x ^. lens . uri)
90 in (lens . uri) .~ newUri $ x
92 -- | Transforms rootUri/rootPath.
93 transformInit :: InitializeParams -> InitializeParams
95 let newRootUri = fmap f (x ^. rootUri)
97 fp <- T.unpack <$> x ^. rootPath
98 let uri = filePathToUri fp
99 T.pack <$> uriToFilePath (f uri)
100 in (rootUri .~ newRootUri) $ (rootPath .~ newRootPath) x