1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE FlexibleInstances #-}
4 module Language.Haskell.LSP.Test.Session
9 , MonadSessionConfig(..)
10 , runSessionWithHandles
18 import Control.Concurrent hiding (yield)
19 import Control.Exception
20 import Control.Lens hiding (List)
22 import Control.Monad.IO.Class
23 import Control.Monad.Except
24 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
25 import qualified Control.Monad.Trans.Reader as Reader (ask)
26 import Control.Monad.Trans.State (StateT, runStateT)
27 import qualified Control.Monad.Trans.State as State (get, put, modify)
28 import qualified Data.ByteString.Lazy.Char8 as B
30 import Data.Conduit hiding (await)
31 import Data.Conduit.Parser
35 import qualified Data.Text as T
36 import qualified Data.HashMap.Strict as HashMap
37 import Language.Haskell.LSP.Messages
38 import Language.Haskell.LSP.TH.ClientCapabilities
39 import Language.Haskell.LSP.Types
40 import Language.Haskell.LSP.VFS
41 import Language.Haskell.LSP.Test.Compat
42 import Language.Haskell.LSP.Test.Decoding
43 import Language.Haskell.LSP.Test.Exceptions
44 import System.Directory
47 -- | A session representing one instance of launching and connecting to a server.
49 -- You can send and receive messages to the server within 'Session' via 'getMessage',
50 -- 'sendRequest' and 'sendNotification'.
53 -- runSession \"path\/to\/root\/dir\" $ do
54 -- docItem <- getDocItem "Desktop/simple.hs" "haskell"
55 -- sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem)
56 -- diagnostics <- getMessage :: Session PublishDiagnosticsNotification
58 type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
60 -- | Stuff you can configure for a 'Session'.
61 data SessionConfig = SessionConfig
63 capabilities :: ClientCapabilities, -- ^ Specific capabilities the client should advertise.
64 timeout :: Int -- ^ Maximum time to wait for a request in seconds.
67 instance Default SessionConfig where
68 def = SessionConfig def 60
70 class Monad m => MonadSessionConfig m where
71 sessionConfig :: m SessionConfig
73 instance Monad m => MonadSessionConfig (StateT SessionState (ReaderT SessionContext m)) where
74 sessionConfig = config <$> lift Reader.ask
76 data SessionContext = SessionContext
80 , messageChan :: Chan FromServerMessage
81 , requestMap :: MVar RequestMap
82 , initRsp :: MVar InitializeResponse
83 , config :: SessionConfig
86 data SessionState = SessionState
92 type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
94 type SessionProcessor = ConduitT FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO))
96 runSession :: Chan FromServerMessage -> SessionProcessor () -> SessionContext -> SessionState -> Session a -> IO (a, SessionState)
97 runSession chan preprocessor context state session = runReaderT (runStateT conduit state) context
98 where conduit = runConduit $ chanSource chan .| preprocessor .| runConduitParser (catchError session handler)
99 handler e@(Unexpected "ConduitParser.empty") = do
101 -- Horrible way to get last item in conduit:
102 -- Add a fake message so we can tell when to stop
103 liftIO $ writeChan chan (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing))
107 lastMsg <- skipToEnd x
108 name <- getParserName
109 liftIO $ throw (UnexpectedMessageException (T.unpack name) lastMsg)
117 Just (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing)) -> return x
118 Just _ -> await >>= skipToEnd
121 get :: Monad m => ParserStateReader a s r m s
124 put :: Monad m => s -> ParserStateReader a s r m ()
125 put = lift . State.put
127 modify :: Monad m => (s -> s) -> ParserStateReader a s r m ()
128 modify = lift . State.modify
130 ask :: Monad m => ParserStateReader a s r m r
131 ask = lift $ lift Reader.ask
133 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
134 -- It also does not automatically send initialize and exit messages.
135 runSessionWithHandles :: Handle -- ^ Server in
136 -> Handle -- ^ Server out
137 -> (Handle -> Session ()) -- ^ Server listener
142 runSessionWithHandles serverIn serverOut serverHandler config rootDir session = do
143 absRootDir <- canonicalizePath rootDir
145 hSetBuffering serverIn NoBuffering
146 hSetBuffering serverOut NoBuffering
148 reqMap <- newMVar newRequestMap
149 messageChan <- newChan
150 meaninglessChan <- newChan
151 initRsp <- newEmptyMVar
153 let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config
154 initState = SessionState (IdInt 0) mempty
156 threadId <- forkIO $ void $ runSession meaninglessChan processor context initState (serverHandler serverOut)
157 (result, _) <- runSession messageChan processor context initState session
163 where processor :: SessionProcessor ()
164 processor = awaitForever $ \msg -> do
165 processTextChanges msg
169 processTextChanges :: FromServerMessage -> SessionProcessor ()
170 processTextChanges (ReqApplyWorkspaceEdit r) = do
171 List changeParams <- case r ^. params . edit . documentChanges of
172 Just cs -> mapM applyTextDocumentEdit cs
173 Nothing -> case r ^. params . edit . changes of
174 Just cs -> mapM (uncurry applyTextEdit) (List (HashMap.toList cs))
175 Nothing -> return (List [])
177 let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) changeParams
178 mergedParams = map mergeParams groupedParams
180 -- TODO: Don't do this when replaying a session
181 forM_ mergedParams $ \p -> do
182 h <- serverIn <$> lift (lift Reader.ask)
183 let msg = NotificationMessage "2.0" TextDocumentDidChange p
184 liftIO $ B.hPut h $ addHeader (encode msg)
186 where applyTextDocumentEdit (TextDocumentEdit docId (List edits)) = do
187 oldVFS <- vfs <$> lift State.get
188 let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
189 params = DidChangeTextDocumentParams docId (List changeEvents)
190 newVFS <- liftIO $ changeVFS oldVFS (fmClientDidChangeTextDocumentNotification params)
191 lift $ State.modify (\s -> s { vfs = newVFS })
194 applyTextEdit uri edits = applyTextDocumentEdit (TextDocumentEdit (VersionedTextDocumentIdentifier uri 0) edits)
196 mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
197 mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
198 in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
199 processTextChanges _ = return ()