From 6f3106ce987b2a3794ee7ab444c8bcc204a7b3d2 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Mon, 24 Aug 2020 21:57:47 +0530 Subject: [PATCH] update and fill in `message` --- lsp-test.cabal | 1 + src/Language/Haskell/LSP/Test.hs | 37 ++++++++++++----------- src/Language/Haskell/LSP/Test/Decoding.hs | 17 +++++++++-- src/Language/Haskell/LSP/Test/Files.hs | 7 +++-- src/Language/Haskell/LSP/Test/Parsing.hs | 19 +++++++++++- src/Language/Haskell/LSP/Test/Session.hs | 4 +-- 6 files changed, 59 insertions(+), 26 deletions(-) diff --git a/lsp-test.cabal b/lsp-test.cabal index 68b560b..0bf9dc9 100644 --- a/lsp-test.cabal +++ b/lsp-test.cabal @@ -64,6 +64,7 @@ library , text , transformers , unordered-containers + , some if os(windows) build-depends: Win32 else diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index 845ff25..c14eb44 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} {-# 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.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 @@ -191,7 +192,7 @@ runSessionWithConfig config' serverExe caps rootDir session = do 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 @@ -370,7 +371,7 @@ createDoc file languageId contents = do createHits (WatchKind create _ _) = create - regHits :: Registration -> Bool + regHits :: SomeRegistration -> Bool 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 - 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. -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) @@ -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. -getAllCodeActions :: TextDocumentIdentifier -> Session [CAResult] +getAllCodeActions :: TextDocumentIdentifier -> Session [Command |? CodeAction] 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) @@ -546,7 +547,7 @@ applyEdit doc edit = 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 @@ -571,8 +572,8 @@ getCompletions doc pos = do 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. @@ -592,19 +593,19 @@ getDefinitions doc pos = do 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. - -> 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 - 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 () @@ -667,5 +668,5 @@ getCodeLenses tId = do -- register during the 'Session'. -- -- @since 0.11.0.0 -getRegisteredCapabilities :: Session [Registration] +getRegisteredCapabilities :: Session [SomeRegistration] getRegisteredCapabilities = (Map.elems . curDynCaps) <$> get diff --git a/src/Language/Haskell/LSP/Test/Decoding.hs b/src/Language/Haskell/LSP/Test/Decoding.hs index 9051821..d99163e 100644 --- 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.Functor.Product +import Data.Functor.Const 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 + IsClientEither -> case mess of + NotMess _ -> acc + ReqMess msg -> fromJust $ updateRequestMap acc (msg ^. id) m _ -> 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 - 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" diff --git a/src/Language/Haskell/LSP/Test/Files.hs b/src/Language/Haskell/LSP/Test/Files.hs index a9e6af6..9a54da1 100644 --- a/src/Language/Haskell/LSP/Test/Files.hs +++ b/src/Language/Haskell/LSP/Test/Files.hs @@ -1,4 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} {-# 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) = - 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 diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs index 6c3c64a..20a40d3 100644 --- a/src/Language/Haskell/LSP/Test/Parsing.hs +++ b/src/Language/Haskell/LSP/Test/Parsing.hs @@ -1,4 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} {-# 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 Data.GADT.Compare +import Data.Type.Equality -- $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) +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 = 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 diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index d43d11a..3e9e688 100644 --- 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 - , curDynCaps :: Map.Map T.Text Registration + , curDynCaps :: Map.Map T.Text SomeRegistration -- ^ 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 - 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) } -- 2.30.2