X-Git-Url: https://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FFiles.hs;h=9a54da1f88f0152e5d06ad887635f92e8514ed88;hb=6f3106ce987b2a3794ee7ab444c8bcc204a7b3d2;hp=59d51cef5a078212749787c9d6f5b41f089112f0;hpb=bd554ce2292b667f7870e9643a1107a81063a596;p=lsp-test.git

diff --git a/src/Language/Haskell/LSP/Test/Files.hs b/src/Language/Haskell/LSP/Test/Files.hs
index 59d51ce..9a54da1 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,15 +10,19 @@ module Language.Haskell.LSP.Test.Files
   )
 where
 
-import           Language.Haskell.LSP.Capture
-import           Language.Haskell.LSP.Types hiding ( error )
-import           Language.Haskell.LSP.Messages
+import           Language.Haskell.LSP.Types
+import           Language.Haskell.LSP.Types.Lens
 import           Control.Lens
 import qualified Data.HashMap.Strict           as HM
 import qualified Data.Text                     as T
 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
@@ -31,7 +38,7 @@ swapFiles relCurBaseDir msgs = do
   return newMsgs
 
 rootDir :: [Event] -> FilePath
-rootDir (FromClient _ (ReqInitialize req):_) =
+rootDir (ClientEv _ (FromClientMess SInitialize req):_) =
   fromMaybe (error "Couldn't find root dir") $ do
     rootUri <- req ^. params .rootUri
     uriToFilePath rootUri
@@ -40,28 +47,38 @@ rootDir _ = error "Couldn't find initialize request in session"
 mapUris :: (Uri -> Uri) -> Event -> Event
 mapUris f event =
   case event of
-    FromClient t msg -> FromClient t (fromClientMsg msg)
-    FromServer t msg -> FromServer t (fromServerMsg msg)
+    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 (NotDidOpenTextDocument n) = NotDidOpenTextDocument $ swapUri (params . textDocument) n
-    fromClientMsg (NotDidChangeTextDocument n) = NotDidChangeTextDocument $ swapUri (params . textDocument) n
-    fromClientMsg (NotWillSaveTextDocument n) = NotWillSaveTextDocument $ swapUri (params . textDocument) n
-    fromClientMsg (NotDidSaveTextDocument n) = NotDidSaveTextDocument $ swapUri (params . textDocument) n
-    fromClientMsg (NotDidCloseTextDocument n) = NotDidCloseTextDocument $ swapUri (params . textDocument) n
-    fromClientMsg (ReqInitialize r) = ReqInitialize $ params .~ (transformInit (r ^. params)) $ r
+    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 (ReqApplyWorkspaceEdit r) =
-      let newDocChanges = fmap (fmap (swapUri textDocument)) $ r ^. params . edit . documentChanges
-          r1 = (params . edit . documentChanges) .~ newDocChanges $ r
-          newChanges = fmap (swapKeys f) $ r1 ^. params . edit . changes
-          r2 = (params . edit . changes) .~ newChanges $ r1
-      in ReqApplyWorkspaceEdit r2
+    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