1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE FlexibleInstances #-}
4 module Language.Haskell.LSP.Test.Session
9 , MonadSessionConfig(..)
10 , runSessionWithHandles
19 import Control.Concurrent hiding (yield)
20 import Control.Exception
21 import Control.Lens hiding (List)
23 import Control.Monad.IO.Class
24 import Control.Monad.Except
25 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
26 import qualified Control.Monad.Trans.Reader as Reader (ask)
27 import Control.Monad.Trans.State (StateT, runStateT)
28 import qualified Control.Monad.Trans.State as State (get, put, modify)
29 import qualified Data.ByteString.Lazy.Char8 as B
31 import Data.Conduit hiding (await)
32 import Data.Conduit.Parser
36 import qualified Data.Map as Map
37 import qualified Data.Text as T
38 import qualified Data.Text.IO as T
39 import qualified Data.HashMap.Strict as HashMap
41 import Language.Haskell.LSP.Messages
42 import Language.Haskell.LSP.TH.ClientCapabilities
43 import Language.Haskell.LSP.Types
44 import Language.Haskell.LSP.VFS
45 import Language.Haskell.LSP.Test.Compat
46 import Language.Haskell.LSP.Test.Decoding
47 import Language.Haskell.LSP.Test.Exceptions
48 import System.Directory
51 -- | A session representing one instance of launching and connecting to a server.
53 -- You can send and receive messages to the server within 'Session' via 'getMessage',
54 -- 'sendRequest' and 'sendNotification'.
57 -- runSession \"path\/to\/root\/dir\" $ do
58 -- docItem <- getDocItem "Desktop/simple.hs" "haskell"
59 -- sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem)
60 -- diagnostics <- getMessage :: Session PublishDiagnosticsNotification
62 type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
64 -- | Stuff you can configure for a 'Session'.
65 data SessionConfig = SessionConfig
67 capabilities :: ClientCapabilities -- ^ Specific capabilities the client should advertise. Default is yes to everything.
68 , timeout :: Int -- ^ Maximum time to wait for a request in seconds. Defaults to 60.
71 instance Default SessionConfig where
72 def = SessionConfig def 60
74 class Monad m => MonadSessionConfig m where
75 sessionConfig :: m SessionConfig
77 instance Monad m => MonadSessionConfig (StateT SessionState (ReaderT SessionContext m)) where
78 sessionConfig = config <$> lift Reader.ask
80 data SessionContext = SessionContext
84 , messageChan :: Chan FromServerMessage
85 , requestMap :: MVar RequestMap
86 , initRsp :: MVar InitializeResponse
87 , config :: SessionConfig
90 data SessionState = SessionState
96 type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
98 type SessionProcessor = ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO))
100 runSession :: Chan FromServerMessage -> SessionProcessor () -> SessionContext -> SessionState -> Session a -> IO (a, SessionState)
101 runSession chan preprocessor context state session = runReaderT (runStateT conduit state) context
102 where conduit = runConduit $ chanSource chan .| preprocessor .| runConduitParser (catchError session handler)
103 handler e@(Unexpected "ConduitParser.empty") = do
105 -- Horrible way to get last item in conduit:
106 -- Add a fake message so we can tell when to stop
107 liftIO $ writeChan chan (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing))
111 lastMsg <- skipToEnd x
112 name <- getParserName
113 liftIO $ throw (UnexpectedMessageException (T.unpack name) lastMsg)
121 Just (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing)) -> return x
122 Just _ -> await >>= skipToEnd
125 get :: Monad m => ParserStateReader a s r m s
128 put :: Monad m => s -> ParserStateReader a s r m ()
129 put = lift . State.put
131 modify :: Monad m => (s -> s) -> ParserStateReader a s r m ()
132 modify = lift . State.modify
134 modifyM :: Monad m => (s -> m s) -> ParserStateReader a s r m ()
136 old <- lift State.get
137 new <- lift $ lift $ lift $ f old
140 ask :: Monad m => ParserStateReader a s r m r
141 ask = lift $ lift Reader.ask
143 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
144 -- It also does not automatically send initialize and exit messages.
145 runSessionWithHandles :: Handle -- ^ Server in
146 -> Handle -- ^ Server out
147 -> (Handle -> Session ()) -- ^ Server listener
152 runSessionWithHandles serverIn serverOut serverHandler config rootDir session = do
153 absRootDir <- canonicalizePath rootDir
155 hSetBuffering serverIn NoBuffering
156 hSetBuffering serverOut NoBuffering
158 reqMap <- newMVar newRequestMap
159 messageChan <- newChan
160 meaninglessChan <- newChan
161 initRsp <- newEmptyMVar
163 let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config
164 initState = SessionState (IdInt 0) mempty
166 threadId <- forkIO $ void $ runSession meaninglessChan processor context initState (serverHandler serverOut)
167 (result, _) <- runSession messageChan processor context initState session
173 where processor :: SessionProcessor ()
174 processor = awaitForever $ \msg -> do
175 processTextChanges msg
179 processTextChanges :: FromServerMessage -> SessionProcessor ()
180 processTextChanges (ReqApplyWorkspaceEdit r) = do
181 changeParams <- case r ^. params . edit . documentChanges of
182 Just (List cs) -> mapM applyTextDocumentEdit cs
183 Nothing -> case r ^. params . edit . changes of
184 Just cs -> concat <$> mapM (uncurry applyChange) (HashMap.toList cs)
187 let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) changeParams
188 mergedParams = map mergeParams groupedParams
190 ctx <- lift $ lift Reader.ask
192 -- TODO: Don't do this when replaying a session
193 forM_ mergedParams $ \p -> do
195 msg = NotificationMessage "2.0" TextDocumentDidChange p
196 liftIO $ B.hPut h $ addHeader (encode msg)
198 where applyTextDocumentEdit (TextDocumentEdit docId (List edits)) = do
199 oldVFS <- vfs <$> lift State.get
200 ctx <- lift $ lift Reader.ask
203 -- if its not open, open it
204 unless ((docId ^. uri) `Map.member` oldVFS) $ do
205 let fp = fromJust $ uriToFilePath (docId ^. uri)
206 contents <- liftIO $ T.readFile fp
207 let item = TextDocumentItem (filePathToUri fp) "" 0 contents
208 msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)
209 liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
211 oldVFS <- vfs <$> lift State.get
212 newVFS <- liftIO $ openVFS oldVFS msg
213 lift $ State.modify (\s -> s { vfs = newVFS })
215 -- we might have updated it above
216 oldVFS <- vfs <$> lift State.get
218 let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
219 params = DidChangeTextDocumentParams docId (List changeEvents)
220 newVFS <- liftIO $ changeVFS oldVFS (fmClientDidChangeTextDocumentNotification params)
221 lift $ State.modify (\s -> s { vfs = newVFS })
225 textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri) [0..]
227 textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits
229 applyChange uri (List edits) = mapM applyTextDocumentEdit (textDocumentEdits uri (reverse edits))
231 mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
232 mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
233 in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
234 processTextChanges _ = return ()