{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
module Language.Haskell.LSP.Test.Files
)
where
-import Language.Haskell.LSP.Types hiding ( error )
+import Language.Haskell.LSP.Types
+import Language.Haskell.LSP.Types.Lens
import Control.Lens
-import Data.Aeson
-import Data.Aeson.Types
-import qualified Data.ByteString.Lazy.Char8 as B
+import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
-import qualified Data.HashMap.Strict as HashMap
import Data.Maybe
import System.Directory
import System.FilePath
+import Data.Time.Clock
+
+data Event
+ = ClientEv UTCTime FromClientMessage
+ | ServerEv UTCTime FromServerMessage
+
+swapFiles :: FilePath -> [Event] -> IO [Event]
+swapFiles relCurBaseDir msgs = do
+ let capturedBaseDir = rootDir msgs
-swapFiles :: FilePath -> FilePath -> [B.ByteString] -> IO [B.ByteString]
-swapFiles recBaseDir relCurBaseDir msgs = do
curBaseDir <- (</> relCurBaseDir) <$> getCurrentDirectory
let transform uri =
let fp = fromMaybe (error "Couldn't transform uri") (uriToFilePath uri)
- newFp = curBaseDir </> makeRelative recBaseDir fp
+ newFp = curBaseDir </> makeRelative capturedBaseDir fp
in filePathToUri newFp
- newMsgs = map (mapUris transform) msgs :: [B.ByteString]
+ newMsgs = map (mapUris transform) msgs
return newMsgs
-rootDir :: [B.ByteString] -> FilePath
-rootDir msgs = fromMaybe (error "Couldn't find root dir") $ do
- req <- decode (head msgs) :: Maybe InitializeRequest
+rootDir :: [Event] -> FilePath
+rootDir (ClientEv _ (FromClientMess SInitialize req):_) =
+ fromMaybe (error "Couldn't find root dir") $ do
rootUri <- req ^. params .rootUri
uriToFilePath rootUri
+rootDir _ = error "Couldn't find initialize request in session"
-mapUris :: (Uri -> Uri) -> B.ByteString -> B.ByteString
-mapUris f msg =
- case decode msg :: Maybe Object of
- Just obj -> encode $ HashMap.map (mapValue f) obj
- Nothing -> error "Couldn't decode message"
+mapUris :: (Uri -> Uri) -> Event -> Event
+mapUris f event =
+ case event of
+ ClientEv t msg -> ClientEv t (fromClientMsg msg)
+ ServerEv t msg -> ServerEv t (fromServerMsg msg)
where
- mapValue :: (Uri -> Uri) -> Value -> Value
- mapValue f x = case parse parseJSON x :: Result VersionedTextDocumentIdentifier of
- Success doc -> transform doc
- Error _ -> case parse parseJSON x :: Result TextDocumentIdentifier of
- Success doc -> transform doc
- Error _ -> case parse parseJSON x :: Result InitializeParams of
- Success params -> transformInit params
- Error _ -> case parse parseJSON x :: Result Object of
- Success obj -> Object $ HashMap.map (mapValue f) obj
- Error _ -> x
+ --TODO: Handle all other URIs that might need swapped
+ fromClientMsg (FromClientMess m@SInitialize r) = FromClientMess m $ params .~ transformInit (r ^. params) $ r
+ fromClientMsg (FromClientMess m@STextDocumentDidOpen n) = FromClientMess m $ swapUri (params . textDocument) n
+ fromClientMsg (FromClientMess m@STextDocumentDidChange n) = FromClientMess m $ swapUri (params . textDocument) n
+ fromClientMsg (FromClientMess m@STextDocumentWillSave n) = FromClientMess m $ swapUri (params . textDocument) n
+ fromClientMsg (FromClientMess m@STextDocumentDidSave n) = FromClientMess m $ swapUri (params . textDocument) n
+ fromClientMsg (FromClientMess m@STextDocumentDidClose n) = FromClientMess m $ swapUri (params . textDocument) n
+ fromClientMsg (FromClientMess m@STextDocumentDocumentSymbol n) = FromClientMess m $ swapUri (params . textDocument) n
+ fromClientMsg (FromClientMess m@STextDocumentRename n) = FromClientMess m $ swapUri (params . textDocument) n
+ fromClientMsg x = x
+
+ fromServerMsg :: FromServerMessage -> FromServerMessage
+ fromServerMsg (FromServerMess m@SWorkspaceApplyEdit r) = FromServerMess m $ params . edit .~ swapWorkspaceEdit (r ^. params . edit) $ r
+ fromServerMsg (FromServerMess m@STextDocumentPublishDiagnostics n) = FromServerMess m $ swapUri params n
+ fromServerMsg (FromServerRsp m@STextDocumentDocumentSymbol r) =
+ let swapUri' :: (List DocumentSymbol |? List SymbolInformation) -> List DocumentSymbol |? List SymbolInformation
+ swapUri' (R si) = R (swapUri location <$> si)
+ swapUri' (L dss) = L dss -- no file locations here
+ in FromServerRsp m $ r & result %~ (fmap swapUri')
+ fromServerMsg (FromServerRsp m@STextDocumentRename r) = FromServerRsp m $ r & result %~ (fmap swapWorkspaceEdit)
+ fromServerMsg x = x
+
+ swapWorkspaceEdit :: WorkspaceEdit -> WorkspaceEdit
+ swapWorkspaceEdit e =
+ let newDocChanges = fmap (fmap (swapUri textDocument)) $ e ^. documentChanges
+ newChanges = fmap (swapKeys f) $ e ^. changes
+ in WorkspaceEdit newChanges newDocChanges
- -- parsing with just JSON
- -- mapValueWithKey :: (Uri -> Uri) -> T.Text -> Value -> Value
- -- mapValueWithKey f "uri" (String s) = fromMaybe (error "Couldn't convert uri") $ do
- -- let uri = filePathToUri $ T.unpack s
- -- String <$> (fmap T.pack (uriToFilePath $ f uri))
- -- mapValueWithKey f _ (Array xs) = Array $ fmap (mapValue f) xs
- -- mapValueWithKey f _ (Object x) = Object $ HashMap.mapWithKey (mapValueWithKey f) x
+ swapKeys :: (Uri -> Uri) -> HM.HashMap Uri b -> HM.HashMap Uri b
+ swapKeys f = HM.foldlWithKey' (\acc k v -> HM.insert (f k) v acc) HM.empty
- transform x = toJSON $ x & uri .~ f (x ^. uri)
+ swapUri :: HasUri b Uri => Lens' a b -> a -> a
+ swapUri lens x =
+ let newUri = f (x ^. lens . uri)
+ in (lens . uri) .~ newUri $ x
- -- transform rootUri/rootPath
- transformInit :: InitializeParams -> Value
+ -- | Transforms rootUri/rootPath.
+ transformInit :: InitializeParams -> InitializeParams
transformInit x =
let newRootUri = fmap f (x ^. rootUri)
newRootPath = do
fp <- T.unpack <$> x ^. rootPath
let uri = filePathToUri fp
T.pack <$> uriToFilePath (f uri)
- in toJSON $ (rootUri .~ newRootUri) $ (rootPath .~ newRootPath) x
+ in (rootUri .~ newRootUri) $ (rootPath .~ newRootPath) x
projects / lsp-test.git / blobdiff