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
95 , curDiagnostics :: Map.Map Uri [Diagnostic]
98 type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
100 type SessionProcessor = ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO))
102 runSession :: Chan FromServerMessage -> SessionProcessor () -> SessionContext -> SessionState -> Session a -> IO (a, SessionState)
103 runSession chan preprocessor context state session = runReaderT (runStateT conduit state) context
104 where conduit = runConduit $ chanSource chan .| preprocessor .| runConduitParser (catchError session handler)
105 handler e@(Unexpected "ConduitParser.empty") = do
107 -- Horrible way to get last item in conduit:
108 -- Add a fake message so we can tell when to stop
109 liftIO $ writeChan chan (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing))
113 lastMsg <- skipToEnd x
114 name <- getParserName
115 liftIO $ throw (UnexpectedMessageException (T.unpack name) lastMsg)
123 Just (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing)) -> return x
124 Just _ -> await >>= skipToEnd
127 get :: Monad m => ParserStateReader a s r m s
130 put :: Monad m => s -> ParserStateReader a s r m ()
131 put = lift . State.put
133 modify :: Monad m => (s -> s) -> ParserStateReader a s r m ()
134 modify = lift . State.modify
136 modifyM :: Monad m => (s -> m s) -> ParserStateReader a s r m ()
138 old <- lift State.get
139 new <- lift $ lift $ lift $ f old
142 ask :: Monad m => ParserStateReader a s r m r
143 ask = lift $ lift Reader.ask
145 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
146 -- It also does not automatically send initialize and exit messages.
147 runSessionWithHandles :: Handle -- ^ Server in
148 -> Handle -- ^ Server out
149 -> (Handle -> Session ()) -- ^ Server listener
154 runSessionWithHandles serverIn serverOut serverHandler config rootDir session = do
155 absRootDir <- canonicalizePath rootDir
157 hSetBuffering serverIn NoBuffering
158 hSetBuffering serverOut NoBuffering
160 reqMap <- newMVar newRequestMap
161 messageChan <- newChan
162 meaninglessChan <- newChan
163 initRsp <- newEmptyMVar
165 let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config
166 initState = SessionState (IdInt 0) mempty mempty
168 threadId <- forkIO $ void $ runSession meaninglessChan processor context initState (serverHandler serverOut)
169 (result, _) <- runSession messageChan processor context initState session
175 where processor :: SessionProcessor ()
176 processor = awaitForever $ \msg -> do
177 processTextChanges msg
181 processTextChanges :: FromServerMessage -> SessionProcessor ()
182 processTextChanges (NotPublishDiagnostics n) = do
183 let List diags = n ^. params . diagnostics
184 doc = n ^. params . uri
185 lift $ State.modify (\s ->
186 let newDiags = Map.insert doc diags (curDiagnostics s)
187 in s { curDiagnostics = newDiags })
189 processTextChanges (ReqApplyWorkspaceEdit r) = do
191 allChangeParams <- case r ^. params . edit . documentChanges of
193 mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs
194 return $ map getParams cs
195 Nothing -> case r ^. params . edit . changes of
197 mapM_ checkIfNeedsOpened (HashMap.keys cs)
198 return $ concatMap (uncurry getChangeParams) (HashMap.toList cs)
199 Nothing -> error "No changes!"
201 oldVFS <- vfs <$> lift State.get
202 newVFS <- liftIO $ changeFromServerVFS oldVFS r
203 lift $ State.modify (\s -> s { vfs = newVFS })
205 let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) allChangeParams
206 mergedParams = map mergeParams groupedParams
208 ctx <- lift $ lift Reader.ask
210 -- TODO: Don't do this when replaying a session
211 forM_ mergedParams $ \p -> do
213 msg = NotificationMessage "2.0" TextDocumentDidChange p
214 liftIO $ B.hPut h $ addHeader (encode msg)
216 where checkIfNeedsOpened uri = do
217 oldVFS <- vfs <$> lift State.get
218 ctx <- lift $ lift Reader.ask
220 -- if its not open, open it
221 unless (uri `Map.member` oldVFS) $ do
222 let fp = fromJust $ uriToFilePath uri
223 contents <- liftIO $ T.readFile fp
224 let item = TextDocumentItem (filePathToUri fp) "" 0 contents
225 msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)
226 liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
228 oldVFS <- vfs <$> lift State.get
229 newVFS <- liftIO $ openVFS oldVFS msg
230 lift $ State.modify (\s -> s { vfs = newVFS })
232 getParams (TextDocumentEdit docId (List edits)) =
233 let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
234 in DidChangeTextDocumentParams docId (List changeEvents)
236 textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri) [0..]
238 textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits
240 getChangeParams uri (List edits) = map getParams (textDocumentEdits uri (reverse edits))
242 mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
243 mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
244 in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
245 processTextChanges _ = return ()