X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FSession.hs;h=ab09726f2ef5490654d4a41099ed53e42f03b608;hb=3c7aa3a876b2142ceae3b649fbb5bd80e95aff77;hp=28d4eddec1591fbbe190fc825abc5c0c1453a0f5;hpb=c34cfe00bbddb79619129a24086dd763f47cedbc;p=lsp-test.git

diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs
index 28d4edd..ab09726 100644
--- a/src/Language/Haskell/LSP/Test/Session.hs
+++ b/src/Language/Haskell/LSP/Test/Session.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
 
 module Language.Haskell.LSP.Test.Session
   ( Session
@@ -34,7 +35,7 @@ import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Except
 #if __GLASGOW_HASKELL__ >= 806
-import qualified Control.Monad.Fail as Fail
+import Control.Monad.Fail
 #endif
 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
 import qualified Control.Monad.Trans.Reader as Reader (ask)
@@ -67,23 +68,32 @@ import System.IO
 
 -- | A session representing one instance of launching and connecting to a server.
 --
--- You can send and receive messages to the server within 'Session' via 'getMessage',
--- 'sendRequest' and 'sendNotification'.
---
+-- You can send and receive messages to the server within 'Session' via
+-- 'Language.Haskell.LSP.Test.message',
+-- 'Language.Haskell.LSP.Test.sendRequest' and
+-- 'Language.Haskell.LSP.Test.sendNotification'.
 
 type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
 
+#if __GLASGOW_HASKELL__ >= 806
+instance MonadFail Session where
+  fail s = do
+    lastMsg <- fromJust . lastReceivedMessage <$> get
+    liftIO $ throw (UnexpectedMessage s lastMsg)
+#endif
+
 -- | Stuff you can configure for a 'Session'.
 data SessionConfig = SessionConfig
   { messageTimeout :: Int  -- ^ Maximum time to wait for a message in seconds, defaults to 60.
   , logStdErr      :: Bool -- ^ Redirect the server's stderr to this stdout, defaults to False.
   , logMessages    :: Bool -- ^ Trace the messages sent and received to stdout, defaults to False.
   , logColor       :: Bool -- ^ Add ANSI color to the logged messages, defaults to True.
+  , lspConfig      :: Maybe Value -- ^ The initial LSP config as JSON value, defaults to Nothing.
   }
 
 -- | The configuration used in 'Language.Haskell.LSP.Test.runSession'.
 defaultConfig :: SessionConfig
-defaultConfig = SessionConfig 60 False False True
+defaultConfig = SessionConfig 60 False False True Nothing
 
 instance Default SessionConfig where
   def = defaultConfig
@@ -148,11 +158,6 @@ instance Monad m => HasState SessionState (ConduitM a b (StateT SessionState m))
 
 type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
 
-#if __GLASGOW_HASKELL__ >= 806
-instance (Fail.MonadFail m) => Fail.MonadFail (ParserStateReader a s r m) where
-  fail = Fail.fail
-#endif
-
 runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
 runSession context state session = runReaderT (runStateT conduit state) context
   where
@@ -192,18 +197,23 @@ runSessionWithHandles serverIn serverOut serverHandler config caps rootDir sessi
 
   hSetBuffering serverIn  NoBuffering
   hSetBuffering serverOut NoBuffering
+  -- This is required to make sure that we don’t get any
+  -- newline conversion or weird encoding issues.
+  hSetBinaryMode serverIn True
+  hSetBinaryMode serverOut True
 
   reqMap <- newMVar newRequestMap
   messageChan <- newChan
   initRsp <- newEmptyMVar
 
+  mainThreadId <- myThreadId
+
   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
-  (result, _) <- runSession context initState session
-
-  killThread threadId
+      launchServerHandler = forkIO $ catch (serverHandler serverOut context)
+                                           (throwTo mainThreadId :: SessionException -> IO ())
+  (result, _) <- bracket launchServerHandler killThread $
+    const $ runSession context initState session
 
   return result
 
@@ -250,7 +260,7 @@ updateState (ReqApplyWorkspaceEdit r) = do
   forM_ bumpedVersions $ \(VersionedTextDocumentIdentifier uri v) ->
     modify $ \s ->
       let oldVFS = vfs s
-          update (VirtualFile oldV t) = VirtualFile (fromMaybe oldV v) t
+          update (VirtualFile oldV t mf) = VirtualFile (fromMaybe oldV v) t mf
           newVFS = Map.adjust update uri oldVFS
       in s { vfs = newVFS }
 
@@ -291,7 +301,7 @@ sendMessage msg = do
   logMsg LogClient msg
   liftIO $ B.hPut h (addHeader $ encode msg)
 
--- | Execute a block f that will throw a 'TimeoutException'
+-- | Execute a block f that will throw a 'Timeout' exception
 -- after duration seconds. This will override the global timeout
 -- for waiting for messages to arrive defined in 'SessionConfig'.
 withTimeout :: Int -> Session a -> Session a
@@ -330,3 +340,4 @@ logMsg t msg = do
           | otherwise       = Cyan
 
         showPretty = B.unpack . encodePretty
+