Merge branch 'master' of https://github.com/Bubba/haskell-lsp-test

[lsp-test.git] / src / Language / Haskell / LSP / Test.hs

diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs
index 4de02fe1324b184835fe09b3d8ba5e8c63997d67..79b7b1e7147934150d4cf632b9c142940e2191e0 100644 (file)
--- a/src/Language/Haskell/LSP/Test.hs
+++ b/src/Language/Haskell/LSP/Test.hs
@@ -24,74 +24,68 @@ module Language.Haskell.LSP.Test
   , sendNotification'
   , sendResponse
   -- * Receving
   , sendNotification'
   , sendResponse
   -- * Receving

+  , anyRequest

   , request
   , request

+  , anyResponse

   , response
   , response

+  , anyNotification

   , notification
   , loggingNotification
   , notification
   , loggingNotification

+  , publishDiagnosticsNotification

   -- * Combinators
   , choice
   , option
   , optional
   -- * Combinators
   , choice
   , option
   , optional

-  , skipOptional

   , between
   , some
   , many
   , sepBy
   , sepBy1
   , between
   , some
   , many
   , sepBy
   , sepBy1

-  , sepByNonEmpty

   , sepEndBy1
   , sepEndBy1

-  , sepEndByNonEmpty

   , sepEndBy
   , endBy1
   , sepEndBy
   , endBy1

-  , endByNonEmpty

   , endBy
   , count
   , endBy
   , count

-  , chainl
-  , chainr
-  , chainl1
-  , chainr1

   , manyTill
   , manyTill

-  , try
-  , (<?>)

   , skipMany
   , skipSome
   , skipMany
   , skipSome

-  , unexpected
-  , notFollowedBy
+  , skipManyTill
+  , skipSomeTill

   , (<|>)
   , satisfy
   -- * Utilities
   , (<|>)
   , satisfy
   -- * Utilities

+  , openDoc

   , getDocItem
   , getDocUri
   ) where
 
 import Control.Applicative
   , getDocItem
   , getDocUri
   ) where
 
 import Control.Applicative

+import Control.Applicative.Combinators

 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Concurrent
 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 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 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 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.
 
 -- | Starts a new session.

-runSession :: FilePath -- ^ The filepath to the root directory for the session.
+runSession :: FilePath -- ^ The filepath to the server executable.
+           -> FilePath -- ^ The filepath to the root directory for the session.

            -> Session a -- ^ The session to run.
            -> IO ()
            -> Session a -- ^ The session to run.
            -> IO ()

-runSession rootDir session = do
+runSession serverExe rootDir session = do

   pid <- getProcessID
   absRootDir <- canonicalizePath rootDir
 
   pid <- getProcessID
   absRootDir <- canonicalizePath rootDir
 


@@ -102,11 +96,11 @@ runSession rootDir session = do
                                           def
                                           (Just TraceOff)
 
                                           def
                                           (Just TraceOff)
 

-  runSessionWithHandler listenServer rootDir $ do
+  runSessionWithHandler listenServer serverExe rootDir $ do

 
     -- Wrap the session around initialize and shutdown calls
 
     -- 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
     liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRsp ^. LSP.error)
 
     sendNotification Initialized InitializedParams


@@ -119,14 +113,15 @@ runSession rootDir session = do
 -- | 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.
 runSessionWithHandler :: (Handle -> Session ())
 -- | 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.
 runSessionWithHandler :: (Handle -> Session ())

+                      -> FilePath

                       -> FilePath
                       -> Session a
                       -> IO a
                       -> FilePath
                       -> Session a
                       -> IO a

-runSessionWithHandler serverHandler rootDir session = do
+runSessionWithHandler serverHandler serverExe rootDir session = do

   absRootDir <- canonicalizePath rootDir
 
   (Just serverIn, Just serverOut, Nothing, serverProc) <- createProcess
   absRootDir <- canonicalizePath rootDir
 
   (Just serverIn, Just serverOut, Nothing, serverProc) <- createProcess

-    (proc "hie" ["--lsp", "-d", "-l", "/tmp/hie-test.log"])
+    (proc serverExe ["--lsp", "-d", "-l", "/tmp/hie-test.log"])

     { std_in = CreatePipe, std_out = CreatePipe }
 
   hSetBuffering serverIn  NoBuffering
     { std_in = CreatePipe, std_out = CreatePipe }
 
   hSetBuffering serverIn  NoBuffering


@@ -139,10 +134,11 @@ runSessionWithHandler serverHandler rootDir session = do
   let context = SessionContext serverIn absRootDir messageChan reqMap
       initState = SessionState (IdInt 9)
 
   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
   (result, _) <- runSession' messageChan context initState session
 
   terminateProcess serverProc

+  killThread threadId

 
   return result
 
 
   return result
 


@@ -167,29 +163,45 @@ listenServer serverOut = do
 --             (DocumentSymbolParams docId)
 -- @
 sendRequest
 --             (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.
   -> 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 }
 
   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
 
 
   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
 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
 
 
   sendMessage req
 


@@ -213,6 +225,13 @@ sendMessage msg = do
   h <- serverIn <$> ask
   liftIO $ B.hPut h $ addHeader (encode msg)
 
   h <- serverIn <$> ask
   liftIO $ B.hPut h $ addHeader (encode msg)
 

+-- | Opens a text document and sends a notification to the client.
+openDoc :: FilePath -> String -> Session TextDocumentIdentifier
+openDoc file languageId = do
+  item <- getDocItem file languageId
+  sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
+  TextDocumentIdentifier <$> getDocUri file
+

 -- | Reads in a text document as the first version.
 getDocItem :: FilePath -- ^ The path to the text document to read in.
            -> String -- ^ The language ID, e.g "haskell" for .hs files.
 -- | Reads in a text document as the first version.
 getDocItem :: FilePath -- ^ The path to the text document to read in.
            -> String -- ^ The language ID, e.g "haskell" for .hs files.