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 hiding ( error )
12 import Language.Haskell.LSP.Messages
14 import qualified Data.HashMap.Strict as HM
15 import qualified Data.Text as T
17 import System.Directory
18 import System.FilePath
20 swapFiles :: FilePath -> [Event] -> IO [Event]
21 swapFiles relCurBaseDir msgs = do
22 let capturedBaseDir = rootDir msgs
24 curBaseDir <- (</> relCurBaseDir) <$> getCurrentDirectory
26 let fp = fromMaybe (error "Couldn't transform uri") (uriToFilePath uri)
27 newFp = curBaseDir </> makeRelative capturedBaseDir fp
28 in filePathToUri newFp
29 newMsgs = map (mapUris transform) msgs
33 rootDir :: [Event] -> FilePath
34 rootDir (FromClient _ (ReqInitialize req):_) =
35 fromMaybe (error "Couldn't find root dir") $ do
36 rootUri <- req ^. params .rootUri
38 rootDir _ = error "Couldn't find initialize request in session"
40 mapUris :: (Uri -> Uri) -> Event -> Event
43 FromClient t msg -> FromClient t (fromClientMsg msg)
44 FromServer t msg -> FromServer t (fromServerMsg msg)
47 --TODO: Handle all other URLs that might need swapped
48 fromClientMsg (NotDidOpenTextDocument n) = NotDidOpenTextDocument $ swapUri (params . textDocument) n
49 fromClientMsg (NotDidChangeTextDocument n) = NotDidChangeTextDocument $ swapUri (params . textDocument) n
50 fromClientMsg (NotWillSaveTextDocument n) = NotWillSaveTextDocument $ swapUri (params . textDocument) n
51 fromClientMsg (NotDidSaveTextDocument n) = NotDidSaveTextDocument $ swapUri (params . textDocument) n
52 fromClientMsg (NotDidCloseTextDocument n) = NotDidCloseTextDocument $ swapUri (params . textDocument) n
53 fromClientMsg (ReqInitialize r) = ReqInitialize $ params .~ (transformInit (r ^. params)) $ r
56 fromServerMsg :: FromServerMessage -> FromServerMessage
57 fromServerMsg (ReqApplyWorkspaceEdit r) =
58 let newDocChanges = fmap (fmap (swapUri textDocument)) $ r ^. params . edit . documentChanges
59 r1 = (params . edit . documentChanges) .~ newDocChanges $ r
60 newChanges = fmap (swapKeys f) $ r1 ^. params . edit . changes
61 r2 = (params . edit . changes) .~ newChanges $ r1
62 in ReqApplyWorkspaceEdit r2
65 swapKeys :: (Uri -> Uri) -> HM.HashMap Uri b -> HM.HashMap Uri b
66 swapKeys f = HM.foldlWithKey' (\acc k v -> HM.insert (f k) v acc) HM.empty
68 swapUri :: HasUri b Uri => Lens' a b -> a -> a
70 let newUri = f (x ^. lens . uri)
71 in (lens . uri) .~ newUri $ x
73 -- | Transforms rootUri/rootPath.
74 transformInit :: InitializeParams -> InitializeParams
76 let newRootUri = fmap f (x ^. rootUri)
78 fp <- T.unpack <$> x ^. rootPath
79 let uri = filePathToUri fp
80 T.pack <$> uriToFilePath (f uri)
81 in (rootUri .~ newRootUri) $ (rootPath .~ newRootPath) x