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))
134 runSession :: Chan FromServerMessage -> SessionProcessor () -> SessionContext -> SessionState -> Session a -> IO (a, SessionState)
135 runSession chan preprocessor context state session = runReaderT (runStateT conduit state) context
136 where conduit = runConduit $ chanSource chan .| preprocessor .| runConduitParser (catchError session handler)
137 handler e@(Unexpected "ConduitParser.empty") = do
139 -- Horrible way to get last item in conduit:
140 -- Add a fake message so we can tell when to stop
141 liftIO $ writeChan chan (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing))
145 lastMsg <- skipToEnd x
146 name <- getParserName
147 liftIO $ throw (UnexpectedMessageException (T.unpack name) lastMsg)
155 Just (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing)) -> return x
156 Just _ -> await >>= skipToEnd
159 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
160 -- It also does not automatically send initialize and exit messages.
161 runSessionWithHandles :: Handle -- ^ Server in
162 -> Handle -- ^ Server out
163 -> (Handle -> SessionContext -> IO ()) -- ^ Server listener
168 runSessionWithHandles serverIn serverOut serverHandler config rootDir session = do
169 absRootDir <- canonicalizePath rootDir
171 hSetBuffering serverIn NoBuffering
172 hSetBuffering serverOut NoBuffering
174 reqMap <- newMVar newRequestMap
175 messageChan <- newChan
176 initRsp <- newEmptyMVar
178 let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config
179 initState = SessionState (IdInt 0) mempty mempty
181 threadId <- forkIO $ void $ serverHandler serverOut context
182 (result, _) <- runSession messageChan processor context initState session
188 where processor :: SessionProcessor ()
189 processor = awaitForever $ \msg -> do
194 processMessage :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) => FromServerMessage -> m ()
195 processMessage (NotPublishDiagnostics n) = do
196 let List diags = n ^. params . diagnostics
197 doc = n ^. params . uri
199 let newDiags = Map.insert doc diags (curDiagnostics s)
200 in s { curDiagnostics = newDiags })
202 processMessage (ReqApplyWorkspaceEdit r) = do
204 allChangeParams <- case r ^. params . edit . documentChanges of
206 mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs
207 return $ map getParams cs
208 Nothing -> case r ^. params . edit . changes of
210 mapM_ checkIfNeedsOpened (HashMap.keys cs)
211 return $ concatMap (uncurry getChangeParams) (HashMap.toList cs)
212 Nothing -> error "No changes!"
214 oldVFS <- vfs <$> get
215 newVFS <- liftIO $ changeFromServerVFS oldVFS r
216 modify (\s -> s { vfs = newVFS })
218 let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) allChangeParams
219 mergedParams = map mergeParams groupedParams
221 -- TODO: Don't do this when replaying a session
222 forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange)
224 where checkIfNeedsOpened uri = do
225 oldVFS <- vfs <$> get
228 -- if its not open, open it
229 unless (uri `Map.member` oldVFS) $ do
230 let fp = fromJust $ uriToFilePath uri
231 contents <- liftIO $ T.readFile fp
232 let item = TextDocumentItem (filePathToUri fp) "" 0 contents
233 msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)
234 liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
236 oldVFS <- vfs <$> get
237 newVFS <- liftIO $ openVFS oldVFS msg
238 modify (\s -> s { vfs = newVFS })
240 getParams (TextDocumentEdit docId (List edits)) =
241 let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
242 in DidChangeTextDocumentParams docId (List changeEvents)
244 textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri) [0..]
246 textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits
248 getChangeParams uri (List edits) = map getParams (textDocumentEdits uri (reverse edits))
250 mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
251 mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
252 in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
253 processMessage _ = return ()
255 sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()
257 h <- serverIn <$> ask
258 let encoded = encode msg
261 setSGR [SetColor Foreground Vivid Cyan]
262 putStrLn $ "--> " ++ B.unpack encoded
265 B.hPut h (addHeader encoded)
267 -- withTimeout :: Int -> Session a -> Session a
268 -- withTimeout duration = do
269 -- liftIO $ fork threadDelay