X-Git-Url: https://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FFiles.hs;h=a9e6af624544c9c7cdac377c788a81cb8dcdc5c3;hb=98d03792f46f3ac870c010a78944822569e76763;hp=3529526bcc47b2bfc9fe3f8d696e288b0e6bef8b;hpb=806ff76a624f4aa9b3b57d57bcc725727698505d;p=lsp-test.git diff --git a/src/Language/Haskell/LSP/Test/Files.hs b/src/Language/Haskell/LSP/Test/Files.hs index 3529526..a9e6af6 100644 --- a/src/Language/Haskell/LSP/Test/Files.hs +++ b/src/Language/Haskell/LSP/Test/Files.hs @@ -1,101 +1,95 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} module Language.Haskell.LSP.Test.Files ( swapFiles - , FileMap - , emptyFileMap , rootDir ) where -import Language.Haskell.LSP.Types hiding ( error ) +import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Types.Lens import Control.Lens -import Control.Monad -import Data.Aeson -import qualified Data.ByteString.Lazy.Char8 as B +import qualified Data.HashMap.Strict as HM import qualified Data.Text as T -import qualified Data.Map as Map -import Data.Map ((!)) -import qualified Data.HashMap.Strict as HashMap -import qualified Data.Set as Set import Data.Maybe import System.Directory -import System.IO import System.FilePath +import Data.Time.Clock -type FileMap = Map.Map Uri Uri +data Event + = ClientEv UTCTime FromClientMessage + | ServerEv UTCTime FromServerMessage -emptyFileMap :: FileMap -emptyFileMap = Map.empty +swapFiles :: FilePath -> [Event] -> IO [Event] +swapFiles relCurBaseDir msgs = do + let capturedBaseDir = rootDir msgs -buildFileMap :: Set.Set Uri -> FilePath -> FilePath -> FileMap -> IO FileMap -buildFileMap uris oldBaseDir newBaseDir oldMap = foldM transform oldMap uris - where - transform map uri = do - let fp = fromMaybe (error "Couldn't convert file path") $ uriToFilePath uri - rel = makeRelative oldBaseDir fp - newFp = newBaseDir rel - newUri <- filePathToUri <$> canonicalizePath newFp - return $ Map.insert uri newUri map - -swapFiles :: FileMap -> FilePath -> FilePath -> [B.ByteString] -> IO ([B.ByteString], FileMap) -swapFiles fileMap recBaseDir curBaseDir msgs = do - - let oldUris = Set.unions $ map extractUris msgs - - newMap <- buildFileMap oldUris recBaseDir curBaseDir fileMap - - let newMsgs = map (swapUris newMap) msgs - - case decode (head newMsgs) :: Maybe InitializeRequest of - -- If there is an initialize request we will need to swap - -- the rootUri and rootPath - Just req -> do - cd <- getCurrentDirectory - let newRoot = cd curBaseDir - newRootUri = params . rootUri ?~ filePathToUri newRoot $ req - newRootPath = params . rootPath ?~ T.pack newRoot $ newRootUri - newReq = encode newRootPath - return (newReq:tail newMsgs, newMap) + curBaseDir <- ( relCurBaseDir) <$> getCurrentDirectory + let transform uri = + let fp = fromMaybe (error "Couldn't transform uri") (uriToFilePath uri) + newFp = curBaseDir makeRelative capturedBaseDir fp + in filePathToUri newFp + newMsgs = map (mapUris transform) msgs - Nothing -> return (newMsgs, newMap) + return newMsgs -rootDir :: [B.ByteString] -> FilePath -rootDir msgs = case decode (head msgs) :: Maybe InitializeRequest of - Just req -> fromMaybe (error "Couldn't convert root dir") $ do +rootDir :: [Event] -> FilePath +rootDir (ClientEv _ (FromClientMess SInitialize req):_) = + fromMaybe (error "Couldn't find root dir") $ do rootUri <- req ^. params .rootUri uriToFilePath rootUri - Nothing -> error "Couldn't find root dir" +rootDir _ = error "Couldn't find initialize request in session" -extractUris :: B.ByteString -> Set.Set Uri -extractUris msgs = - case decode msgs :: Maybe Object of - Just obj -> HashMap.foldlWithKey' gather Set.empty obj - Nothing -> error "Couldn't decode message" - where gather :: Set.Set Uri -> T.Text -> Value -> Set.Set Uri - gather uris "uri" (String s) = Set.insert (Uri s) uris - gather uris _ (Object o) = HashMap.foldlWithKey' gather uris o - gather uris _ _ = uris - -swapUris :: FileMap -> B.ByteString -> B.ByteString -swapUris fileMap msg = - case decode msg :: Maybe Object of - Just obj -> encode $ HashMap.mapWithKey f obj - Nothing -> error "Couldn't decode message" - - where f :: T.Text -> Value -> Value - f "uri" (String uri) = String $ swap uri - f "changes" (Object obj) = Object $ - HashMap.foldlWithKey' (\acc k v -> HashMap.insert (swap k) v acc) - HashMap.empty - obj - f _ x = g x - - g :: Value -> Value - g (Array arr) = Array $ fmap g arr - g (Object obj) = Object $ HashMap.mapWithKey f obj - g x = x - - swap origUri = let (Uri newUri) = fileMap ! Uri origUri in newUri +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 + --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' (DSSymbolInformation si) = DSSymbolInformation (swapUri location <$> si) + swapUri' (DSDocumentSymbols dss) = DSDocumentSymbols 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 + + 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 + + swapUri :: HasUri b Uri => Lens' a b -> a -> a + swapUri lens x = + let newUri = f (x ^. lens . uri) + in (lens . uri) .~ newUri $ x + + -- | 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 (rootUri .~ newRootUri) $ (rootPath .~ newRootPath) x