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 hiding (error)
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.
69 , logStdErr :: Bool -- ^ When True redirects the servers stderr output to haskell-lsp-test's stdout. Defaults to False
72 instance Default SessionConfig where
73 def = SessionConfig def 60 False
75 class Monad m => MonadSessionConfig m where
76 sessionConfig :: m SessionConfig
78 instance Monad m => MonadSessionConfig (StateT SessionState (ReaderT SessionContext m)) where
79 sessionConfig = config <$> lift Reader.ask
81 data SessionContext = SessionContext
85 , messageChan :: Chan FromServerMessage
86 , requestMap :: MVar RequestMap
87 , initRsp :: MVar InitializeResponse
88 , config :: SessionConfig
91 data SessionState = SessionState
97 type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
99 type SessionProcessor = ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO))
101 runSession :: Chan FromServerMessage -> SessionProcessor () -> SessionContext -> SessionState -> Session a -> IO (a, SessionState)
102 runSession chan preprocessor context state session = runReaderT (runStateT conduit state) context
103 where conduit = runConduit $ chanSource chan .| preprocessor .| runConduitParser (catchError session handler)
104 handler e@(Unexpected "ConduitParser.empty") = do
106 -- Horrible way to get last item in conduit:
107 -- Add a fake message so we can tell when to stop
108 liftIO $ writeChan chan (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing))
112 lastMsg <- skipToEnd x
113 name <- getParserName
114 liftIO $ throw (UnexpectedMessageException (T.unpack name) lastMsg)
122 Just (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing)) -> return x
123 Just _ -> await >>= skipToEnd
126 get :: Monad m => ParserStateReader a s r m s
129 put :: Monad m => s -> ParserStateReader a s r m ()
130 put = lift . State.put
132 modify :: Monad m => (s -> s) -> ParserStateReader a s r m ()
133 modify = lift . State.modify
135 modifyM :: Monad m => (s -> m s) -> ParserStateReader a s r m ()
137 old <- lift State.get
138 new <- lift $ lift $ lift $ f old
141 ask :: Monad m => ParserStateReader a s r m r
142 ask = lift $ lift Reader.ask
144 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
145 -- It also does not automatically send initialize and exit messages.
146 runSessionWithHandles :: Handle -- ^ Server in
147 -> Handle -- ^ Server out
148 -> (Handle -> Session ()) -- ^ Server listener
153 runSessionWithHandles serverIn serverOut serverHandler config rootDir session = do
154 absRootDir <- canonicalizePath rootDir
156 hSetBuffering serverIn NoBuffering
157 hSetBuffering serverOut NoBuffering
159 reqMap <- newMVar newRequestMap
160 messageChan <- newChan
161 meaninglessChan <- newChan
162 initRsp <- newEmptyMVar
164 let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config
165 initState = SessionState (IdInt 0) mempty
167 threadId <- forkIO $ void $ runSession meaninglessChan processor context initState (serverHandler serverOut)
168 (result, _) <- runSession messageChan processor context initState session
174 where processor :: SessionProcessor ()
175 processor = awaitForever $ \msg -> do
176 processTextChanges msg
180 processTextChanges :: FromServerMessage -> SessionProcessor ()
181 processTextChanges (ReqApplyWorkspaceEdit r) = do
183 allChangeParams <- case r ^. params . edit . documentChanges of
185 mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs
186 return $ map getParams cs
187 Nothing -> case r ^. params . edit . changes of
189 mapM_ checkIfNeedsOpened (HashMap.keys cs)
190 return $ concatMap (uncurry getChangeParams) (HashMap.toList cs)
191 Nothing -> error "No changes!"
193 oldVFS <- vfs <$> lift State.get
194 newVFS <- liftIO $ changeFromServerVFS oldVFS r
195 lift $ State.modify (\s -> s { vfs = newVFS })
197 let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) allChangeParams
198 mergedParams = map mergeParams groupedParams
200 ctx <- lift $ lift Reader.ask
202 -- TODO: Don't do this when replaying a session
203 forM_ mergedParams $ \p -> do
205 msg = NotificationMessage "2.0" TextDocumentDidChange p
206 liftIO $ B.hPut h $ addHeader (encode msg)
208 where checkIfNeedsOpened uri = do
209 oldVFS <- vfs <$> lift State.get
210 ctx <- lift $ lift Reader.ask
212 -- if its not open, open it
213 unless (uri `Map.member` oldVFS) $ do
214 let fp = fromJust $ uriToFilePath uri
215 contents <- liftIO $ T.readFile fp
216 let item = TextDocumentItem (filePathToUri fp) "" 0 contents
217 msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)
218 liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
220 oldVFS <- vfs <$> lift State.get
221 newVFS <- liftIO $ openVFS oldVFS msg
222 lift $ State.modify (\s -> s { vfs = newVFS })
224 getParams (TextDocumentEdit docId (List edits)) =
225 let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
226 in DidChangeTextDocumentParams docId (List changeEvents)
228 textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri) [0..]
230 textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits
232 getChangeParams uri (List edits) = map getParams (textDocumentEdits uri (reverse edits))
234 mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
235 mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
236 in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
237 processTextChanges _ = return ()