update and fill in `message`

diff --git a/lsp-test.cabal b/lsp-test.cabal
index 68b560bd1d65e770421f928d513e0014d55202ad..0bf9dc9c797e9f50cb2a967ccb044ee7d90efd9c 100644 (file)
--- a/lsp-test.cabal
+++ b/lsp-test.cabal
@@ -64,6 +64,7 @@ library
                      , text
                      , transformers
                      , unordered-containers
                      , text
                      , transformers
                      , unordered-containers

+                     , some

   if os(windows)
     build-depends:     Win32
   else
   if os(windows)
     build-depends:     Win32
   else

diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs
index 845ff2593464b482f3b1d447ef113a2983d5d2d2..c14eb44fd140a5f94b5307e72b03fa90dc6b77a2 100644 (file)
--- a/src/Language/Haskell/LSP/Test.hs
+++ b/src/Language/Haskell/LSP/Test.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE OverloadedStrings #-}

+{-# LANGUAGE TypeOperators #-}

 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE DataKinds #-}


@@ -96,7 +97,7 @@ import Control.Concurrent
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Exception
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Exception

-import Control.Lens hiding ((.=), List)
+import Control.Lens hiding ((.=), List, Empty)

 import qualified Data.Map.Strict as Map
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import qualified Data.Map.Strict as Map
 import qualified Data.Text as T
 import qualified Data.Text.IO as T


@@ -191,7 +192,7 @@ runSessionWithConfig config' serverExe caps rootDir session = do
   where
   -- | Asks the server to shutdown and exit politely
   exitServer :: Session ()
   where
   -- | Asks the server to shutdown and exit politely
   exitServer :: Session ()

-  exitServer = request_ SShutdown (Nothing :: Maybe Value) >> sendNotification SExit (Just ExitParams)
+  exitServer = request_ SShutdown (Nothing :: Maybe Value) >> sendNotification SExit (Just Empty)

 
   -- | Listens to the server output until the shutdown ack,
   -- makes sure it matches the record and signals any semaphores
 
   -- | Listens to the server output until the shutdown ack,
   -- makes sure it matches the record and signals any semaphores


@@ -370,7 +371,7 @@ createDoc file languageId contents = do
 
       createHits (WatchKind create _ _) = create
 
 
       createHits (WatchKind create _ _) = create
 

-      regHits :: Registration -> Bool
+      regHits :: SomeRegistration -> Bool

       regHits reg = isJust $ do
         opts <- reg ^. registerOptions
         fileWatchOpts <- case fromJSON opts :: Result DidChangeWatchedFilesRegistrationOptions of
       regHits reg = isJust $ do
         opts <- reg ^. registerOptions
         fileWatchOpts <- case fromJSON opts :: Result DidChangeWatchedFilesRegistrationOptions of


@@ -463,12 +464,12 @@ getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol]
 getDocumentSymbols doc = do
   ResponseMessage _ rspLid res <- request STextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) :: Session DocumentSymbolsResponse
   case res of
 getDocumentSymbols doc = do
   ResponseMessage _ rspLid res <- request STextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) :: Session DocumentSymbolsResponse
   case res of

-    Right (DSDocumentSymbols (List xs)) -> return (Left xs)
-    Right (DSSymbolInformation (List xs)) -> return (Right xs)
+    Right (L (List xs)) -> return (Left xs)
+    Right (R (List xs)) -> return (Right xs)

     Left err -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) err)
 
 -- | Returns the code actions in the specified range.
     Left err -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) err)
 
 -- | Returns the code actions in the specified range.

-getCodeActions :: TextDocumentIdentifier -> Range -> Session [CAResult]
+getCodeActions :: TextDocumentIdentifier -> Range -> Session [Command |? CodeAction]

 getCodeActions doc range = do
   ctx <- getCodeActionContext doc
   rsp <- request STextDocumentCodeAction (CodeActionParams doc range ctx Nothing)
 getCodeActions doc range = do
   ctx <- getCodeActionContext doc
   rsp <- request STextDocumentCodeAction (CodeActionParams doc range ctx Nothing)


@@ -480,14 +481,14 @@ getCodeActions doc range = do
 -- | Returns all the code actions in a document by
 -- querying the code actions at each of the current
 -- diagnostics' positions.
 -- | Returns all the code actions in a document by
 -- querying the code actions at each of the current
 -- diagnostics' positions.

-getAllCodeActions :: TextDocumentIdentifier -> Session [CAResult]
+getAllCodeActions :: TextDocumentIdentifier -> Session [Command |? CodeAction]

 getAllCodeActions doc = do
   ctx <- getCodeActionContext doc
 
   foldM (go ctx) [] =<< getCurrentDiagnostics doc
 
   where
 getAllCodeActions doc = do
   ctx <- getCodeActionContext doc
 
   foldM (go ctx) [] =<< getCurrentDiagnostics doc
 
   where

-    go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult]
+    go :: CodeActionContext -> [Command |? CodeAction] -> Diagnostic -> Session [Command |? CodeAction]

     go ctx acc diag = do
       ResponseMessage _ rspLid res <- request STextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx Nothing)
 
     go ctx acc diag = do
       ResponseMessage _ rspLid res <- request STextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx Nothing)
 


@@ -546,7 +547,7 @@ applyEdit doc edit = do
   caps <- asks sessionCapabilities
 
   let supportsDocChanges = fromMaybe False $ do
   caps <- asks sessionCapabilities
 
   let supportsDocChanges = fromMaybe False $ do

-        let mWorkspace = C._workspace caps
+        let mWorkspace = caps ^. LSP.workspace

         C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace
         C.WorkspaceEditClientCapabilities mDocChanges <- mEdit
         mDocChanges
         C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace
         C.WorkspaceEditClientCapabilities mDocChanges <- mEdit
         mDocChanges


@@ -571,8 +572,8 @@ getCompletions doc pos = do
   rsp <- request STextDocumentCompletion (CompletionParams doc pos Nothing Nothing)
 
   case getResponseResult rsp of
   rsp <- request STextDocumentCompletion (CompletionParams doc pos Nothing Nothing)
 
   case getResponseResult rsp of

-    Completions (List items) -> return items
-    CompletionList (CompletionListType _ (List items)) -> return items
+    L (List items) -> return items
+    R (CompletionList _ (List items)) -> return items

 
 -- | Returns the references for the position in the document.
 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
 
 -- | Returns the references for the position in the document.
 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.


@@ -592,19 +593,19 @@ getDefinitions doc pos = do
   let params = TextDocumentPositionParams doc pos Nothing
   rsp <- request STextDocumentDefinition params :: Session DefinitionResponse
   case getResponseResult rsp of
   let params = TextDocumentPositionParams doc pos Nothing
   rsp <- request STextDocumentDefinition params :: Session DefinitionResponse
   case getResponseResult rsp of

-    SingleLoc loc -> pure [loc]
-    MultiLoc locs -> pure locs
+      L loc -> pure [loc]
+      R locs -> pure locs

 
 -- | Returns the type definition(s) for the term at the specified position.
 getTypeDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
                -> Position -- ^ The position the term is at.
 
 -- | Returns the type definition(s) for the term at the specified position.
 getTypeDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
                -> Position -- ^ The position the term is at.

-                   -> Session [Location] -- ^ The location(s) of the definitions
-getTypeDefinitions doc pos = do
+               -> Session (Location |? List Location |? List LocationLink) -- ^ The location(s) of the definitions
+getTypeDefinitions doc pos =

   let params = TextDocumentPositionParams doc pos Nothing
   rsp <- request STextDocumentTypeDefinition params :: Session TypeDefinitionResponse
   case getResponseResult rsp of
   let params = TextDocumentPositionParams doc pos Nothing
   rsp <- request STextDocumentTypeDefinition params :: Session TypeDefinitionResponse
   case getResponseResult rsp of

-    SingleLoc loc -> pure [loc]
-    MultiLoc locs -> pure locs
+      L loc -> pure [loc]
+      R locs -> pure locs

 
 -- | Renames the term at the specified position.
 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
 
 -- | Renames the term at the specified position.
 rename :: TextDocumentIdentifier -> Position -> String -> Session ()


@@ -667,5 +668,5 @@ getCodeLenses tId = do
 -- register during the 'Session'.
 --
 -- @since 0.11.0.0
 -- register during the 'Session'.
 --
 -- @since 0.11.0.0

-getRegisteredCapabilities :: Session [Registration]
+getRegisteredCapabilities :: Session [SomeRegistration]

 getRegisteredCapabilities = (Map.elems . curDynCaps) <$> get
 getRegisteredCapabilities = (Map.elems . curDynCaps) <$> get

diff --git a/src/Language/Haskell/LSP/Test/Decoding.hs b/src/Language/Haskell/LSP/Test/Decoding.hs
index 9051821735385b19cd83ed098bb16e8c5b5e1b50..d99163e6f54e882afe10b56958cbf39495776c6f 100644 (file)
--- a/src/Language/Haskell/LSP/Test/Decoding.hs
+++ b/src/Language/Haskell/LSP/Test/Decoding.hs
@@ -10,6 +10,8 @@ import           Prelude                 hiding ( id )
 import           Data.Aeson
 import           Data.Aeson.Types
 import           Data.Foldable
 import           Data.Aeson
 import           Data.Aeson.Types
 import           Data.Foldable

+import           Data.Functor.Product
+import           Data.Functor.Const

 import           Control.Exception
 import           Control.Lens
 import qualified Data.ByteString.Lazy.Char8    as B
 import           Control.Exception
 import           Control.Lens
 import qualified Data.ByteString.Lazy.Char8    as B


@@ -78,12 +80,21 @@ getRequestMap = foldl' helper emptyIxMap
     FromClientMess m mess -> case splitClientMethod m of
       IsClientNot -> acc
       IsClientReq -> fromJust $ updateRequestMap acc (mess ^. id) m
     FromClientMess m mess -> case splitClientMethod m of
       IsClientNot -> acc
       IsClientReq -> fromJust $ updateRequestMap acc (mess ^. id) m

+      IsClientEither -> case mess of
+        NotMess _ -> acc
+        ReqMess msg -> fromJust $ updateRequestMap acc (msg ^. id) m

     _ -> acc
 
     _ -> acc
 

-decodeFromServerMsg :: RequestMap -> B.ByteString -> FromServerMessage
-decodeFromServerMsg reqMap bytes =  fst $ fromJust $ parseMaybe p obj
+decodeFromServerMsg :: RequestMap -> B.ByteString -> (FromServerMessage, RequestMap)
+decodeFromServerMsg reqMap bytes = unP $ fromJust $ parseMaybe p obj

   where obj = fromJust $ decode bytes :: Value
   where obj = fromJust $ decode bytes :: Value

-        p = parseServerMessage (\i -> (,()) <$> lookupIxMap i reqMap)
+        p = parseServerMessage $ \lid ->
+          let (mm, newMap) = pickFromIxMap lid reqMap
+            in case mm of
+              Nothing -> Nothing
+              Just m -> Just $ (m, Pair m (Const newMap))
+        unP (FromServerMess m msg) = (FromServerMess m msg, reqMap)
+        unP (FromServerRsp (Pair m (Const newMap)) msg) = (FromServerRsp m msg, newMap)

         {-
         WorkspaceWorkspaceFolders      -> error "ReqWorkspaceFolders not supported yet"
         WorkspaceConfiguration         -> error "ReqWorkspaceConfiguration not supported yet"
         {-
         WorkspaceWorkspaceFolders      -> error "ReqWorkspaceFolders not supported yet"
         WorkspaceConfiguration         -> error "ReqWorkspaceConfiguration not supported yet"

diff --git a/src/Language/Haskell/LSP/Test/Files.hs b/src/Language/Haskell/LSP/Test/Files.hs
index a9e6af624544c9c7cdac377c788a81cb8dcdc5c3..9a54da1f88f0152e5d06ad887635f92e8514ed88 100644 (file)
--- a/src/Language/Haskell/LSP/Test/Files.hs
+++ b/src/Language/Haskell/LSP/Test/Files.hs
@@ -1,4 +1,6 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleContexts #-}

+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DataKinds #-}

 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE OverloadedStrings #-}


@@ -64,8 +66,9 @@ mapUris f event =
     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) =
     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
+      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
       in FromServerRsp m $ r & result %~ (fmap swapUri')
     fromServerMsg (FromServerRsp m@STextDocumentRename r) = FromServerRsp m $ r & result %~ (fmap swapWorkspaceEdit)
     fromServerMsg x = x

diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs
index 6c3c64afe8f9ff85a8fa0b6a3e2e0b9b501f4df1..20a40d31386a284cf65d263981d0799f49b35ac0 100644 (file)
--- a/src/Language/Haskell/LSP/Test/Parsing.hs
+++ b/src/Language/Haskell/LSP/Test/Parsing.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE MultiParamTypeClasses #-}

+{-# LANGUAGE TypeOperators #-}

 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE KindSignatures #-}


@@ -36,6 +37,8 @@ import Data.Typeable
 import Language.Haskell.LSP.Types
 import qualified Language.Haskell.LSP.Types.Lens as LSP
 import Language.Haskell.LSP.Test.Session
 import Language.Haskell.LSP.Types
 import qualified Language.Haskell.LSP.Types.Lens as LSP
 import Language.Haskell.LSP.Test.Session

+import Data.GADT.Compare
+import Data.Type.Equality

 
 -- $receiving
 -- To receive a message, just specify the type that expect:
 
 -- $receiving
 -- To receive a message, just specify the type that expect:


@@ -101,8 +104,22 @@ satisfyMaybe pred = do
 named :: T.Text -> Session a -> Session a
 named s (Session x) = Session (Data.Conduit.Parser.named s x)
 
 named :: T.Text -> Session a -> Session a
 named s (Session x) = Session (Data.Conduit.Parser.named s x)
 

+mEq :: SServerMethod m1 -> SServerMethod m2 -> Maybe (m1 :~~: m2)
+mEq m1 m2 = case (splitServerMethod m1, splitServerMethod m2) of
+  (IsServerNot, IsServerNot) -> do
+    Refl <- geq m1 m2
+    pure HRefl
+  (IsServerReq, IsServerReq) -> do
+    Refl <- geq m1 m2
+    pure HRefl
+  _ -> Nothing
+

 message :: SServerMethod m -> Session (ServerMessage m)
 message :: SServerMethod m -> Session (ServerMessage m)

-message = undefined -- TODO
+message m1 = named (T.pack $ show m1) $ satisfyMaybe $ \case
+  FromServerMess m2 msg -> do
+    HRefl <- mEq m1 m2
+    pure msg
+  _ -> Nothing

 
 -- | Matches if the message is a notification.
 anyNotification :: Session FromServerMessage
 
 -- | Matches if the message is a notification.
 anyNotification :: Session FromServerMessage

diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs
index d43d11a1f79b5c2df46285f54e42ea22bc2bf399..3e9e688bc221f563b8220b63e925cb71176a8668 100644 (file)
--- a/src/Language/Haskell/LSP/Test/Session.hs
+++ b/src/Language/Haskell/LSP/Test/Session.hs
@@ -167,7 +167,7 @@ data SessionState = SessionState
   -- ^ The last received message from the server.
   -- Used for providing exception information
   , lastReceivedMessage :: Maybe FromServerMessage
   -- ^ The last received message from the server.
   -- Used for providing exception information
   , lastReceivedMessage :: Maybe FromServerMessage

-  , curDynCaps :: Map.Map T.Text Registration
+  , curDynCaps :: Map.Map T.Text SomeRegistration

   -- ^ The capabilities that the server has dynamically registered with us so
   -- far
   }
   -- ^ The capabilities that the server has dynamically registered with us so
   -- far
   }


@@ -295,7 +295,7 @@ updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m)
 
 -- Keep track of dynamic capability registration
 updateState (FromServerMess SClientRegisterCapability req) = do
 
 -- Keep track of dynamic capability registration
 updateState (FromServerMess SClientRegisterCapability req) = do

-  let List newRegs = (\r -> (r ^. LSP.id, r)) <$> req ^. params . registrations
+  let List newRegs = (\sr@(SomeRegistration r) -> (r ^. LSP.id, sr)) <$> req ^. params . registrations

   modify $ \s ->
     s { curDynCaps = Map.union (Map.fromList newRegs) (curDynCaps s) }
 
   modify $ \s ->
     s { curDynCaps = Map.union (Map.fromList newRegs) (curDynCaps s) }