{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
module Language.Haskell.LSP.Test.Files
( swapFiles
- , FileMap
- , emptyFileMap
, rootDir
- , cleanupFiles
)
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 :: [Uri] -> FilePath -> FilePath -> FileMap -> IO FileMap
-buildFileMap uris recBaseDir curBaseDir oldMap =
- foldM (createFile recBaseDir curBaseDir) oldMap uris
- where
- createFile baseDir curDir map uri =
- if Map.member uri map
- then return map
- else do
- let fp = fromMaybe (error "Couldn't convert file path")
- (uriToFilePath uri)
- relativeFp = makeRelative baseDir fp
- actualFp = curDir </> relativeFp
-
- -- Need to store in a directory inside tmp directory
- -- otherwise ghc-mod ends up creating one for us
- tmpDir <- (</> "lsp-test" </> takeDirectory relativeFp) <$> getTemporaryDirectory
- createDirectoryIfMissing True tmpDir
-
- (tmpFp, tmpH) <- openTempFile tmpDir (takeFileName actualFp)
-
- readFile actualFp >>= hPutStr tmpH
- tmpUri <- filePathToUri <$> canonicalizePath tmpFp
- return $ Map.insert uri tmpUri map
-
-cleanupFiles :: IO ()
-cleanupFiles = removeDirectoryRecursive =<< (</> "lsp-test") <$> getTemporaryDirectory
-
-swapFiles :: FileMap -> FilePath -> FilePath -> [B.ByteString] -> IO ([B.ByteString], FileMap)
-swapFiles fileMap recBaseDir curBaseDir msgs = do
-
- let oldUris = Set.unions $ map extractUris msgs
+ 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
- newMap <- buildFileMap (Set.elems oldUris) recBaseDir curBaseDir fileMap
+ return newMsgs
- 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 .~ Just (filePathToUri newRoot) $ req
- newRootPath = params . rootPath .~ Just (T.pack newRoot) $ newRootUri
- newReq = encode newRootPath
- return (newReq:(tail newMsgs), newMap)
-
- Nothing -> return (newMsgs, newMap)
-
-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"
-
-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
+rootDir _ = error "Couldn't find initialize request in session"
-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"
+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 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
+ 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' :: (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
+
+ 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
projects / lsp-test.git / blobdiff