X-Git-Url: https://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FFiles.hs;h=693dabd4cd5b0737df11fed53b65bf844c51812a;hb=96f28c37fbc7137415fed9a54927e2da43c72dc8;hp=f59551a3719ae3e2dcf9f24b321ef7aa569eb1c1;hpb=287998584f8dc2ec1c1995733ca38d38d8d9f031;p=lsp-test.git

diff --git a/src/Language/Haskell/LSP/Test/Files.hs b/src/Language/Haskell/LSP/Test/Files.hs
index f59551a..693dabd 100644
--- a/src/Language/Haskell/LSP/Test/Files.hs
+++ b/src/Language/Haskell/LSP/Test/Files.hs
@@ -1,4 +1,7 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE OverloadedStrings #-}
 module Language.Haskell.LSP.Test.Files
@@ -7,68 +10,89 @@ 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' (InR si) = InR (swapUri location <$> si)
+          swapUri' (InL dss) = InL 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