X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest.hs;h=fb928a4b9ccd0bfbec75cd4bae66af408e885242;hb=7f825c46ba76f90701a2f8f2a8c040d9bc2b6683;hp=068fc2dd0a3cbc17e9da1b98b0f92c5238263f5b;hpb=3081abf6552222c5dfc7928d4c708dd03015548e;p=opengl.git

diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs
index 068fc2d..fb928a4 100644
--- a/src/Language/Haskell/LSP/Test.hs
+++ b/src/Language/Haskell/LSP/Test.hs
@@ -24,39 +24,33 @@ module Language.Haskell.LSP.Test
   , sendNotification'
   , sendResponse
   -- * Receving
+  , anyRequest
   , request
+  , anyResponse
   , response
+  , anyNotification
   , notification
   , loggingNotification
+  , publishDiagnosticsNotification
   -- * Combinators
   , choice
   , option
   , optional
-  , skipOptional
   , between
   , some
   , many
   , sepBy
   , sepBy1
-  , sepByNonEmpty
   , sepEndBy1
-  , sepEndByNonEmpty
   , sepEndBy
   , endBy1
-  , endByNonEmpty
   , endBy
   , count
-  , chainl
-  , chainr
-  , chainl1
-  , chainr1
   , manyTill
-  , try
-  , (<?>)
   , skipMany
   , skipSome
-  , unexpected
-  , notFollowedBy
+  , skipManyTill
+  , skipSomeTill
   , (<|>)
   , satisfy
   -- * Utilities
@@ -66,27 +60,25 @@ module Language.Haskell.LSP.Test
   ) where
 
 import Control.Applicative
+import Control.Applicative.Combinators
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Concurrent
-import Control.Lens
+import Control.Lens hiding ((.=))
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import Data.Aeson
 import qualified Data.ByteString.Lazy.Char8 as B
 import Data.Default
-import Data.Proxy
 import System.Process
 import Language.Haskell.LSP.Types
-import qualified  Language.Haskell.LSP.Types as LSP (error)
-import Language.Haskell.LSP.Messages
+import qualified  Language.Haskell.LSP.Types as LSP (error, id)
 import Language.Haskell.LSP.Test.Compat
 import System.IO
 import System.Directory
 import System.FilePath
 import Language.Haskell.LSP.Test.Decoding
 import Language.Haskell.LSP.Test.Parsing
-import Text.Parser.Combinators
 
 -- | Starts a new session.
 runSession :: FilePath -- ^ The filepath to the root directory for the session.
@@ -106,8 +98,8 @@ runSession rootDir session = do
   runSessionWithHandler listenServer rootDir $ do
 
     -- Wrap the session around initialize and shutdown calls
-    sendRequest (Proxy :: Proxy InitializeRequest) Initialize initializeParams
-    RspInitialize initRsp <- response
+    sendRequest Initialize initializeParams
+    initRsp <- response :: Session InitializeResponse
     liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRsp ^. LSP.error)
 
     sendNotification Initialized InitializedParams
@@ -140,10 +132,11 @@ runSessionWithHandler serverHandler rootDir session = do
   let context = SessionContext serverIn absRootDir messageChan reqMap
       initState = SessionState (IdInt 9)
 
-  forkIO $ void $ runSession' meaninglessChan context initState (serverHandler serverOut)
+  threadId <- forkIO $ void $ runSession' meaninglessChan context initState (serverHandler serverOut)
   (result, _) <- runSession' messageChan context initState session
 
   terminateProcess serverProc
+  killThread threadId
 
   return result
 
@@ -168,29 +161,45 @@ listenServer serverOut = do
 --             (DocumentSymbolParams docId)
 -- @
 sendRequest
-  :: forall params resp. (ToJSON params, ToJSON resp, FromJSON resp)
-  => Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request.
-  -> ClientMethod -- ^ The request method.
+  :: (ToJSON params)
+  => --Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request.
+  ClientMethod -- ^ The request method.
   -> params -- ^ The request parameters.
   -> Session LspId -- ^ The id of the request that was sent.
-sendRequest _ method params = do
+sendRequest method params = do
   id <- curReqId <$> get
   modify $ \c -> c { curReqId = nextId id }
 
-  let req = RequestMessage "2.0" id method params :: RequestMessage ClientMethod params resp
+  let req = RequestMessage' "2.0" id method params
 
-  sendRequest' req
+  -- Update the request map
+  reqMap <- requestMap <$> ask
+  liftIO $ modifyMVar_ reqMap $
+    \r -> return $ updateRequestMap r id method
+
+  sendMessage req
 
   return id
 
   where nextId (IdInt i) = IdInt (i + 1)
         nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
 
+-- | A custom type for request message that doesn't
+-- need a response type, allows us to infer the request
+-- message type without using proxies.
+data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
+
+instance ToJSON a => ToJSON (RequestMessage' a) where
+  toJSON (RequestMessage' rpc id method params) =
+    object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
+
+
 sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
 sendRequest' req = do
   -- Update the request map
   reqMap <- requestMap <$> ask
-  liftIO $ modifyMVar_ reqMap (return . flip updateRequestMap req)
+  liftIO $ modifyMVar_ reqMap $
+    \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
 
   sendMessage req