{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
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
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
createHits (WatchKind create _ _) = create
- regHits :: Registration -> Bool
+ regHits :: SomeRegistration -> Bool
regHits reg = isJust $ do
opts <- reg ^. registerOptions
fileWatchOpts <- case fromJSON opts :: Result DidChangeWatchedFilesRegistrationOptions 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.
-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)
-- | 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)
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
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.
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 ()
-- register during the 'Session'.
--
-- @since 0.11.0.0
-getRegisteredCapabilities :: Session [Registration]
+getRegisteredCapabilities :: Session [SomeRegistration]
getRegisteredCapabilities = (Map.elems . curDynCaps) <$> get
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
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"
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE KindSignatures #-}
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:
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