1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE MultiParamTypeClasses #-}
4 {-# LANGUAGE FlexibleContexts #-}
6 module Language.Haskell.LSP.Test.Session
11 , MonadSessionConfig(..)
12 , runSessionWithHandles
23 import Control.Concurrent hiding (yield)
24 import Control.Exception
25 import Control.Lens hiding (List)
27 import Control.Monad.IO.Class
28 import Control.Monad.Except
29 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
30 import qualified Control.Monad.Trans.Reader as Reader (ask)
31 import Control.Monad.Trans.State (StateT, runStateT)
32 import qualified Control.Monad.Trans.State as State (get, put)
33 import qualified Data.ByteString.Lazy.Char8 as B
35 import Data.Conduit hiding (await)
36 import Data.Conduit.Parser
40 import qualified Data.Map as Map
41 import qualified Data.Text as T
42 import qualified Data.Text.IO as T
43 import qualified Data.HashMap.Strict as HashMap
45 import Language.Haskell.LSP.Messages
46 import Language.Haskell.LSP.TH.ClientCapabilities
47 import Language.Haskell.LSP.Types hiding (error)
48 import Language.Haskell.LSP.VFS
49 import Language.Haskell.LSP.Test.Compat
50 import Language.Haskell.LSP.Test.Decoding
51 import Language.Haskell.LSP.Test.Exceptions
52 import System.Console.ANSI
53 import System.Directory
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 -- | Stuff you can configure for a 'Session'.
70 data SessionConfig = SessionConfig
72 capabilities :: ClientCapabilities -- ^ Specific capabilities the client should advertise. Default is yes to everything.
73 , timeout :: Int -- ^ Maximum time to wait for a request in seconds. Defaults to 60.
74 , logStdErr :: Bool -- ^ When True redirects the servers stderr output to haskell-lsp-test's stdout. Defaults to False
77 instance Default SessionConfig where
78 def = SessionConfig def 60 False
80 class Monad m => MonadSessionConfig m where
81 sessionConfig :: m SessionConfig
83 instance Monad m => MonadSessionConfig (StateT SessionState (ReaderT SessionContext m)) where
84 sessionConfig = config <$> lift Reader.ask
86 data SessionContext = SessionContext
90 , messageChan :: Chan FromServerMessage
91 , requestMap :: MVar RequestMap
92 , initRsp :: MVar InitializeResponse
93 , config :: SessionConfig
96 class Monad m => HasReader r m where
98 asks :: (r -> b) -> m b
101 instance Monad m => HasReader r (ParserStateReader a s r m) where
102 ask = lift $ lift Reader.ask
104 instance HasReader SessionContext SessionProcessor where
105 ask = lift $ lift Reader.ask
107 data SessionState = SessionState
111 , curDiagnostics :: Map.Map Uri [Diagnostic]
114 class Monad m => HasState s m where
119 modify :: (s -> s) -> m ()
120 modify f = get >>= put . f
122 instance Monad m => HasState s (ParserStateReader a s r m) where
124 put = lift . State.put
126 instance HasState SessionState SessionProcessor where
128 put = lift . State.put
130 type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
132 type SessionProcessor = ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO))
135 runSession :: Chan FromServerMessage -> SessionProcessor () -> SessionContext -> SessionState -> Session a -> IO (a, SessionState)
136 runSession chan preprocessor context state session = runReaderT (runStateT conduit state) context
137 where conduit = runConduit $ chanSource chan .| preprocessor .| runConduitParser (catchError session handler)
138 handler e@(Unexpected "ConduitParser.empty") = do
140 -- Horrible way to get last item in conduit:
141 -- Add a fake message so we can tell when to stop
142 liftIO $ writeChan chan (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing))
146 lastMsg <- skipToEnd x
147 name <- getParserName
148 liftIO $ throw (UnexpectedMessageException (T.unpack name) lastMsg)
156 Just (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing)) -> return x
157 Just _ -> await >>= skipToEnd
160 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
161 -- It also does not automatically send initialize and exit messages.
162 runSessionWithHandles :: Handle -- ^ Server in
163 -> Handle -- ^ Server out
164 -> (Handle -> Session ()) -- ^ Server listener
169 runSessionWithHandles serverIn serverOut serverHandler config rootDir session = do
170 absRootDir <- canonicalizePath rootDir
172 hSetBuffering serverIn NoBuffering
173 hSetBuffering serverOut NoBuffering
175 reqMap <- newMVar newRequestMap
176 messageChan <- newChan
177 meaninglessChan <- newChan
178 initRsp <- newEmptyMVar
180 let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config
181 initState = SessionState (IdInt 0) mempty mempty
183 threadId <- forkIO $ void $ runSession meaninglessChan processor context initState (serverHandler serverOut)
184 (result, _) <- runSession messageChan processor context initState session
190 where processor :: SessionProcessor ()
191 processor = awaitForever $ \msg -> do
196 processMessage :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) => FromServerMessage -> m ()
197 processMessage (NotPublishDiagnostics n) = do
198 let List diags = n ^. params . diagnostics
199 doc = n ^. params . uri
201 let newDiags = Map.insert doc diags (curDiagnostics s)
202 in s { curDiagnostics = newDiags })
204 processMessage (ReqApplyWorkspaceEdit r) = do
206 allChangeParams <- case r ^. params . edit . documentChanges of
208 mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs
209 return $ map getParams cs
210 Nothing -> case r ^. params . edit . changes of
212 mapM_ checkIfNeedsOpened (HashMap.keys cs)
213 return $ concatMap (uncurry getChangeParams) (HashMap.toList cs)
214 Nothing -> error "No changes!"
216 oldVFS <- vfs <$> get
217 newVFS <- liftIO $ changeFromServerVFS oldVFS r
218 modify (\s -> s { vfs = newVFS })
220 let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) allChangeParams
221 mergedParams = map mergeParams groupedParams
223 -- TODO: Don't do this when replaying a session
224 forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange)
226 where checkIfNeedsOpened uri = do
227 oldVFS <- vfs <$> get
230 -- if its not open, open it
231 unless (uri `Map.member` oldVFS) $ do
232 let fp = fromJust $ uriToFilePath uri
233 contents <- liftIO $ T.readFile fp
234 let item = TextDocumentItem (filePathToUri fp) "" 0 contents
235 msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)
236 liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
238 oldVFS <- vfs <$> get
239 newVFS <- liftIO $ openVFS oldVFS msg
240 modify (\s -> s { vfs = newVFS })
242 getParams (TextDocumentEdit docId (List edits)) =
243 let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
244 in DidChangeTextDocumentParams docId (List changeEvents)
246 textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri) [0..]
248 textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits
250 getChangeParams uri (List edits) = map getParams (textDocumentEdits uri (reverse edits))
252 mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
253 mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
254 in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
255 processMessage _ = return ()
257 sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()
259 h <- serverIn <$> ask
260 let encoded = encode msg
263 setSGR [SetColor Foreground Vivid Cyan]
264 putStrLn $ "--> " ++ B.unpack encoded
267 B.hPut h (addHeader encoded)