1 {-# LANGUAGE OverloadedStrings #-}
3 module Language.Haskell.LSP.Test.Session
7 , runSessionWithHandles
15 import Control.Concurrent hiding (yield)
16 import Control.Lens hiding (List)
18 import Control.Monad.IO.Class
19 import Control.Monad.Trans.Class
20 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
21 import qualified Control.Monad.Trans.Reader as Reader (ask)
22 import Control.Monad.Trans.State (StateT, runStateT)
23 import qualified Control.Monad.Trans.State as State (get, put, modify)
24 import qualified Data.ByteString.Lazy.Char8 as B
27 import Data.Conduit.Parser
30 import qualified Data.HashMap.Strict as HashMap
31 import Language.Haskell.LSP.Messages
32 import Language.Haskell.LSP.Types
33 import Language.Haskell.LSP.VFS
34 import Language.Haskell.LSP.Test.Compat
35 import Language.Haskell.LSP.Test.Decoding
36 import System.Directory
39 data SessionContext = SessionContext
43 , messageChan :: Chan FromServerMessage
44 , requestMap :: MVar RequestMap
45 , initRsp :: MVar InitializeResponse
48 data SessionState = SessionState
54 type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
56 -- | A session representing one instance of launching and connecting to a server.
58 -- You can send and receive messages to the server within 'Session' via 'getMessage',
59 -- 'sendRequest' and 'sendNotification'.
62 -- runSession \"path\/to\/root\/dir\" $ do
63 -- docItem <- getDocItem "Desktop/simple.hs" "haskell"
64 -- sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem)
65 -- diagnostics <- getMessage :: Session PublishDiagnosticsNotification
67 type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
69 type SessionProcessor = ConduitT FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO))
71 runSession' :: Chan FromServerMessage -> SessionProcessor () -> SessionContext -> SessionState -> Session a -> IO (a, SessionState)
72 runSession' chan preprocessor context state session = runReaderT (runStateT conduit state) context
73 where conduit = runConduit $ chanSource chan .| preprocessor .| runConduitParser session
75 get :: Monad m => ParserStateReader a s r m s
78 put :: Monad m => s -> ParserStateReader a s r m ()
79 put = lift . State.put
81 modify :: Monad m => (s -> s) -> ParserStateReader a s r m ()
82 modify = lift . State.modify
84 ask :: Monad m => ParserStateReader a s r m r
85 ask = lift $ lift Reader.ask
87 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
88 -- It also does not automatically send initialize and exit messages.
89 runSessionWithHandles :: Handle -- ^ Server in
90 -> Handle -- ^ Server out
91 -> (Handle -> Session ()) -- ^ Server listener
95 runSessionWithHandles serverIn serverOut serverHandler rootDir session = do
96 absRootDir <- canonicalizePath rootDir
98 hSetBuffering serverIn NoBuffering
99 hSetBuffering serverOut NoBuffering
101 reqMap <- newMVar newRequestMap
102 messageChan <- newChan
103 meaninglessChan <- newChan
104 initRsp <- newEmptyMVar
106 let context = SessionContext serverIn absRootDir messageChan reqMap initRsp
107 initState = SessionState (IdInt 0) mempty
109 threadId <- forkIO $ void $ runSession' meaninglessChan processor context initState (serverHandler serverOut)
110 (result, _) <- runSession' messageChan processor context initState session
116 where processor :: SessionProcessor ()
117 processor = awaitForever $ \msg -> do
118 processTextChanges msg
122 processTextChanges :: FromServerMessage -> SessionProcessor ()
123 processTextChanges (ReqApplyWorkspaceEdit r) = do
124 List changeParams <- case r ^. params . edit . documentChanges of
125 Just cs -> mapM applyTextDocumentEdit cs
126 Nothing -> case r ^. params . edit . changes of
127 Just cs -> mapM (uncurry applyTextEdit) (List (HashMap.toList cs))
128 Nothing -> return (List [])
130 let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) changeParams
131 mergedParams = map mergeParams groupedParams
133 forM_ mergedParams $ \p -> do
134 h <- serverIn <$> lift (lift Reader.ask)
135 let msg = NotificationMessage "2.0" TextDocumentDidChange p
136 liftIO $ B.hPut h $ addHeader (encode msg)
138 where applyTextDocumentEdit (TextDocumentEdit docId (List edits)) = do
139 oldVFS <- vfs <$> lift State.get
140 let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
141 params = DidChangeTextDocumentParams docId (List changeEvents)
142 newVFS <- liftIO $ changeVFS oldVFS (fmClientDidChangeTextDocumentNotification params)
143 lift $ State.modify (\s -> s { vfs = newVFS })
146 applyTextEdit uri edits = applyTextDocumentEdit (TextDocumentEdit (VersionedTextDocumentIdentifier uri 0) edits)
148 mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
149 mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
150 in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
151 processTextChanges _ = return ()