{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeInType #-}
module Language.LSP.Test.Session
( Session(..)
, bumpTimeoutId
, logMsg
, LogMsgType(..)
+ , documentChangeUri
)
where
import Data.Foldable
import Data.List
import qualified Data.Map as Map
+import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.HashMap.Strict as HashMap
, curDynCaps :: Map.Map T.Text SomeRegistration
-- ^ The capabilities that the server has dynamically registered with us so
-- far
+ , curProgressSessions :: Set.Set ProgressToken
}
class Monad m => HasState s m where
mainThreadId <- myThreadId
let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps
- initState vfs = SessionState 0 vfs mempty False Nothing mempty
+ initState vfs = SessionState 0 vfs mempty False Nothing mempty mempty
runSession' ses = initVFS $ \vfs -> runSessionMonad context (initState vfs) ses
errorHandler = throwTo mainThreadId :: SessionException -> IO ()
updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
updateStateC = awaitForever $ \msg -> do
updateState msg
+ respond msg
yield msg
+ where
+ respond :: (MonadIO m, HasReader SessionContext m) => FromServerMessage -> m ()
+ respond (FromServerMess SWindowWorkDoneProgressCreate req) =
+ sendMessage $ ResponseMessage "2.0" (Just $ req ^. LSP.id) (Right ())
+ respond (FromServerMess SWorkspaceApplyEdit r) = do
+ sendMessage $ ResponseMessage "2.0" (Just $ r ^. LSP.id) (Right $ ApplyWorkspaceEditResponseBody True Nothing)
+ respond _ = pure ()
+
+
+-- extract Uri out from DocumentChange
+-- didn't put this in `lsp-types` because TH was getting in the way
+documentChangeUri :: DocumentChange -> Uri
+documentChangeUri (InL x) = x ^. textDocument . uri
+documentChangeUri (InR (InL x)) = x ^. uri
+documentChangeUri (InR (InR (InL x))) = x ^. oldUri
+documentChangeUri (InR (InR (InR x))) = x ^. uri
updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m)
=> FromServerMessage -> m ()
+updateState (FromServerMess SProgress req) = case req ^. params . value of
+ Begin _ ->
+ modify $ \s -> s { curProgressSessions = Set.insert (req ^. params . token) $ curProgressSessions s }
+ End _ ->
+ modify $ \s -> s { curProgressSessions = Set.delete (req ^. params . token) $ curProgressSessions s }
+ _ -> pure ()
-- Keep track of dynamic capability registration
updateState (FromServerMess SClientRegisterCapability req) = do
-- First, prefer the versioned documentChanges field
allChangeParams <- case r ^. params . edit . documentChanges of
Just (List cs) -> do
- mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs
- return $ map getParams cs
+ mapM_ (checkIfNeedsOpened . documentChangeUri) cs
+ return $ mapMaybe getParamsFromDocumentChange cs
-- Then fall back to the changes field
Nothing -> case r ^. params . edit . changes of
Just cs -> do
let (newVFS,_) = openVFS (vfs s) msg
return $ s { vfs = newVFS }
- getParams (TextDocumentEdit docId (List edits)) =
+ getParamsFromTextDocumentEdit :: TextDocumentEdit -> DidChangeTextDocumentParams
+ getParamsFromTextDocumentEdit (TextDocumentEdit docId (List edits)) =
let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
in DidChangeTextDocumentParams docId (List changeEvents)
+ getParamsFromDocumentChange :: DocumentChange -> Maybe DidChangeTextDocumentParams
+ getParamsFromDocumentChange (InL textDocumentEdit) = Just $ getParamsFromTextDocumentEdit textDocumentEdit
+ getParamsFromDocumentChange _ = Nothing
+
+
-- For a uri returns an infinite list of versions [n,n+1,n+2,...]
-- where n is the current version
textDocumentVersions uri = do
vers <- textDocumentVersions uri
pure $ map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip vers edits
- getChangeParams uri (List edits) =
- map <$> pure getParams <*> textDocumentEdits uri (reverse edits)
+ getChangeParams uri (List edits) = do
+ map <$> pure getParamsFromTextDocumentEdit <*> textDocumentEdits uri (reverse edits)
mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))