{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}
module Language.Haskell.LSP.Test.Session
- ( Session
+ ( SessionT
, SessionConfig(..)
, SessionMessage(..)
, SessionContext(..)
, SessionState(..)
- , MonadSessionConfig(..)
, runSessionWithHandles
, get
, put
, modify
+ , modifyM
, ask
, asks
, sendMessage
where
+import Conduit
import Control.Concurrent hiding (yield)
import Control.Exception
import Control.Lens hiding (List)
import qualified Control.Monad.Trans.State as State (get, put)
import qualified Data.ByteString.Lazy.Char8 as B
import Data.Aeson
-import Data.Conduit as Conduit
+import Data.Aeson.Encode.Pretty
import Data.Conduit.Parser as Parser
import Data.Default
import Data.Foldable
import qualified Data.Text.IO as T
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe
+import Data.Function
import Language.Haskell.LSP.Messages
-import Language.Haskell.LSP.TH.ClientCapabilities
+import Language.Haskell.LSP.Types.Capabilities
import Language.Haskell.LSP.Types hiding (error)
import Language.Haskell.LSP.VFS
import Language.Haskell.LSP.Test.Decoding
-- sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem)
-- diagnostics <- getMessage :: Session PublishDiagnosticsNotification
-- @
-type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
+type SessionT m = ParserStateReader FromServerMessage SessionState SessionContext m
-- | Stuff you can configure for a 'Session'.
data SessionConfig = SessionConfig
{
- capabilities :: ClientCapabilities -- ^ Specific capabilities the client should advertise. Default is yes to everything.
- , messageTimeout :: Int -- ^ Maximum time to wait for a message in seconds. Defaults to 60.
- , logStdErr :: Bool -- ^ When True redirects the servers stderr output to haskell-lsp-test's stdout. Defaults to False
+ messageTimeout :: Int -- ^ Maximum time to wait for a message in seconds. Defaults to 60.
+ , logStdErr :: Bool -- ^ When True redirects the servers stderr output to haskell-lsp-test's stdout. Defaults to False.
+ , logMessages :: Bool -- ^ When True traces the communication between client and server to stdout. Defaults to True.
}
instance Default SessionConfig where
- def = SessionConfig def 60 False
-
-class Monad m => MonadSessionConfig m where
- sessionConfig :: m SessionConfig
-
-instance Monad m => MonadSessionConfig (StateT SessionState (ReaderT SessionContext m)) where
- sessionConfig = config <$> lift Reader.ask
+ def = SessionConfig 60 False True
data SessionMessage = ServerMessage FromServerMessage
| TimeoutMessage Int
, requestMap :: MVar RequestMap
, initRsp :: MVar InitializeResponse
, config :: SessionConfig
+ , sessionCapabilities :: ClientCapabilities
}
class Monad m => HasReader r m where
modify :: (s -> s) -> m ()
modify f = get >>= put . f
+ modifyM :: (HasState s m, Monad m) => (s -> m s) -> m ()
+ modifyM f = get >>= f >>= put
+
instance Monad m => HasState s (ParserStateReader a s r m) where
get = lift State.get
put = lift . State.put
type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
-runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
-runSession context state session =
- -- source <- sourceList <$> getChanContents (messageChan context)
- runReaderT (runStateT conduit state) context
+runSession :: (MonadIO m, MonadThrow m) => SessionContext -> SessionState -> SessionT m a -> m (a, SessionState)
+runSession context state session = runReaderT (runStateT conduit state) context
where
conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler)
+ handler :: MonadIO m => ConduitParserException -> SessionT m a
handler (Unexpected "ConduitParser.empty") = do
lastMsg <- fromJust . lastReceivedMessage <$> get
name <- getParserName
- liftIO $ throw (UnexpectedMessageException (T.unpack name) lastMsg)
+ liftIO $ throw (UnexpectedMessage (T.unpack name) lastMsg)
- handler e = throw e
+ handler e = liftIO $ throw e
+ chanSource :: MonadIO m => ConduitT () SessionMessage m ()
chanSource = do
msg <- liftIO $ readChan (messageChan context)
yield msg
chanSource
- watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
+ watchdog :: MonadIO m => ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext m)) ()
watchdog = Conduit.awaitForever $ \msg -> do
curId <- curTimeoutId <$> get
case msg of
ServerMessage sMsg -> yield sMsg
- TimeoutMessage tId -> when (curId == tId) $ throw TimeoutException
+ TimeoutMessage tId -> when (curId == tId) $ throw Timeout
-- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
-- It also does not automatically send initialize and exit messages.
-runSessionWithHandles :: Handle -- ^ Server in
+runSessionWithHandles :: (MonadIO m, MonadThrow m)
+ => Handle -- ^ Server in
-> Handle -- ^ Server out
-> (Handle -> SessionContext -> IO ()) -- ^ Server listener
-> SessionConfig
- -> FilePath
- -> Session a
- -> IO a
-runSessionWithHandles serverIn serverOut serverHandler config rootDir session = do
- absRootDir <- canonicalizePath rootDir
+ -> ClientCapabilities
+ -> FilePath -- ^ Root directory
+ -> SessionT m a
+ -> m a
+runSessionWithHandles serverIn serverOut serverHandler config caps rootDir session = do
+ absRootDir <- liftIO $ canonicalizePath rootDir
+ liftIO $ do
hSetBuffering serverIn NoBuffering
hSetBuffering serverOut NoBuffering
- reqMap <- newMVar newRequestMap
- messageChan <- newChan
- initRsp <- newEmptyMVar
+ reqMap <- liftIO $ newMVar newRequestMap
+ messageChan <- liftIO newChan
+ initRsp <- liftIO newEmptyMVar
- let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config
+ let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config caps
initState = SessionState (IdInt 0) mempty mempty 0 False Nothing
- threadId <- forkIO $ void $ serverHandler serverOut context
+ threadId <- liftIO $ forkIO $ void $ serverHandler serverOut context
(result, _) <- runSession context initState session
- killThread threadId
+ liftIO $ killThread threadId
return result
-updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
+updateStateC :: MonadIO m => ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext m)) ()
updateStateC = awaitForever $ \msg -> do
updateState msg
yield msg
return $ concatMap (uncurry getChangeParams) (HashMap.toList cs)
Nothing -> error "No changes!"
- oldVFS <- vfs <$> get
- newVFS <- liftIO $ changeFromServerVFS oldVFS r
- modify (\s -> s { vfs = newVFS })
+ modifyM $ \s -> do
+ newVFS <- liftIO $ changeFromServerVFS (vfs s) r
+ return $ s { vfs = newVFS }
let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) allChangeParams
mergedParams = map mergeParams groupedParams
-- TODO: Don't do this when replaying a session
forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange)
+ -- Update VFS to new document versions
+ let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams
+ latestVersions = map ((^. textDocument) . last) sortedVersions
+ bumpedVersions = map (version . _Just +~ 1) latestVersions
+
+ forM_ bumpedVersions $ \(VersionedTextDocumentIdentifier uri v) ->
+ modify $ \s ->
+ let oldVFS = vfs s
+ update (VirtualFile oldV t) = VirtualFile (fromMaybe oldV v) t
+ newVFS = Map.adjust update uri oldVFS
+ in s { vfs = newVFS }
+
where checkIfNeedsOpened uri = do
oldVFS <- vfs <$> get
ctx <- ask
msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)
liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
- oldVFS <- vfs <$> get
- newVFS <- liftIO $ openVFS oldVFS msg
- modify (\s -> s { vfs = newVFS })
+ modifyM $ \s -> do
+ newVFS <- liftIO $ openVFS (vfs s) msg
+ return $ s { vfs = newVFS }
getParams (TextDocumentEdit docId (List edits)) =
let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
in DidChangeTextDocumentParams docId (List changeEvents)
- textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri) [0..]
+ textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri . Just) [0..]
textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits
sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()
sendMessage msg = do
h <- serverIn <$> ask
- let encoded = encode msg
- liftIO $ do
+ let encoded = encodePretty msg
+
+ shouldLog <- asks $ logMessages . config
+ liftIO $ when shouldLog $ do
- setSGR [SetColor Foreground Vivid Cyan]
+ setSGR [SetColor Foreground Dull Cyan]
putStrLn $ "--> " ++ B.unpack encoded
setSGR [Reset]
-- | Execute a block f that will throw a 'TimeoutException'
-- after duration seconds. This will override the global timeout
-- for waiting for messages to arrive defined in 'SessionConfig'.
-withTimeout :: Int -> Session a -> Session a
+withTimeout :: MonadIO m => Int -> SessionT m a -> SessionT m a
withTimeout duration f = do
chan <- asks messageChan
timeoutId <- curTimeoutId <$> get