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
15 import qualified Data.ByteString.Lazy.Char8 as B
16 import qualified Data.HashMap.Strict as HM
17 import qualified Data.Text as T
19 import System.Directory
20 import System.FilePath
22 swapFiles :: FilePath -> [Event] -> IO [Event]
23 swapFiles relCurBaseDir msgs = do
24 let capturedBaseDir = rootDir msgs
26 curBaseDir <- (</> relCurBaseDir) <$> getCurrentDirectory
28 let fp = fromMaybe (error "Couldn't transform uri") (uriToFilePath uri)
29 newFp = curBaseDir </> makeRelative capturedBaseDir fp
30 in filePathToUri newFp
31 newMsgs = map (mapUris transform) msgs
35 rootDir :: [Event] -> FilePath
36 rootDir (FromClient _ (ReqInitialize req):_) =
37 fromMaybe (error "Couldn't find root dir") $ do
38 rootUri <- req ^. params .rootUri
40 rootDir _ = error "Couldn't find initialize request in session"
42 mapUris :: (Uri -> Uri) -> Event -> Event
45 FromClient t msg -> FromClient t (fromClientMsg msg)
46 FromServer t msg -> FromServer t (fromServerMsg msg)
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
57 fromServerMsg :: FromServerMessage -> FromServerMessage
58 fromServerMsg (ReqApplyWorkspaceEdit r) =
59 let newDocChanges = fmap (fmap (swapUri textDocument)) $ r ^. params . edit . documentChanges
60 r1 = (params . edit . documentChanges) .~ newDocChanges $ r
61 newChanges = fmap (swapKeys f) $ r1 ^. params . edit . changes
62 r2 = (params . edit . changes) .~ newChanges $ r1
63 in ReqApplyWorkspaceEdit r2
66 swapKeys :: (Uri -> Uri) -> HM.HashMap Uri b -> HM.HashMap Uri b
67 swapKeys f = HM.foldlWithKey' (\acc k v -> HM.insert (f k) v acc) HM.empty
69 swapUri :: HasUri b Uri => Lens' a b -> a -> a
71 let newUri = f (x ^. lens . uri)
72 in (lens . uri) .~ newUri $ x
74 -- | Transforms rootUri/rootPath.
75 transformInit :: InitializeParams -> InitializeParams
77 let newRootUri = fmap f (x ^. rootUri)
79 fp <- T.unpack <$> x ^. rootPath
80 let uri = filePathToUri fp
81 T.pack <$> uriToFilePath (f uri)
82 in (rootUri .~ newRootUri) $ (rootPath .~ newRootPath) x