Add javascript langserver testing

[opengl.git] / src / Language / Haskell / LSP / Test.hs

diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs
index 495714c02e6bd3c28d09b0fd97eff1a7b7e766a3..17a39c5a9702a9e2146514c65165220270ff516f 100644 (file)
--- a/src/Language/Haskell/LSP/Test.hs
+++ b/src/Language/Haskell/LSP/Test.hs
@@ -16,64 +16,76 @@ module Language.Haskell.LSP.Test
   -- * Sessions
     runSession
   , runSessionWithHandler
   -- * Sessions
     runSession
   , runSessionWithHandler

-  -- | 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'.
-  --
-  -- @
-  -- runSession \"path\/to\/root\/dir\" $ do
-  --   docItem <- getDocItem "Desktop/simple.hs" "haskell"
-  --   sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem)
-  --   diagnostics <- getMessage :: Session PublishDiagnosticsNotification
-  -- @

   , Session
   -- * Sending
   , sendRequest
   , sendNotification
   , sendRequest'
   , sendNotification'
   , Session
   -- * Sending
   , sendRequest
   , sendNotification
   , sendRequest'
   , sendNotification'

-  , sendResponse'
+  , sendResponse

   -- * Receving
   -- * Receving

+  , anyRequest

   , request
   , request

+  , anyResponse

   , response
   , response

+  , anyNotification

   , notification
   , loggingNotification
   , notification
   , loggingNotification

-  -- * Parsing
+  , publishDiagnosticsNotification
+  -- * Combinators
+  , choice
+  , option
+  , optional
+  , between
+  , some

   , many
   , many

+  , sepBy
+  , sepBy1
+  , sepEndBy1
+  , sepEndBy
+  , endBy1
+  , endBy
+  , count
+  , manyTill

   , skipMany
   , skipMany

+  , skipSome
+  , skipManyTill
+  , skipSomeTill
+  , (<|>)
+  , satisfy

   -- * Utilities
   -- * Utilities

+  , openDoc

   , getDocItem
   , getDocUri
   ) where
 
   , getDocItem
   , getDocUri
   ) where
 

+import Control.Applicative
+import Control.Applicative.Combinators

 import Control.Monad
 import Control.Monad

-import Control.Monad.Trans.Class

 import Control.Monad.IO.Class
 import Control.Monad.IO.Class

-import Control.Monad.Trans.Reader

 import Control.Concurrent
 import Control.Concurrent

+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 System.Process

-import Language.Haskell.LSP.Types hiding (error, id)
-import Language.Haskell.LSP.Messages
+import Language.Haskell.LSP.Types
+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.Parsec

 
 -- | Starts a new session.
 
 -- | Starts a new session.

-runSession :: FilePath -- ^ The filepath to the root directory for the session.
+runSession :: String -- ^ The command to run the server.
+           -> 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
 


@@ -84,13 +96,12 @@ 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
-    -- (ResponseMessage _ _ (Just (InitializeResponseCapabilities _)) e) <- getMessage
-    -- liftIO $ maybe (return ()) (putStrLn . ("Error when initializing: " ++) . show ) e
-    (RspInitialize _ ) <- response
+    sendRequest Initialize initializeParams
+    initRsp <- response :: Session InitializeResponse
+    liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRsp ^. LSP.error)

 
     sendNotification Initialized InitializedParams
 
 
     sendNotification Initialized InitializedParams
 


@@ -99,16 +110,18 @@ runSession rootDir session = do
 
     sendNotification Exit ExitParams
 
 
     sendNotification Exit ExitParams
 

+-- | 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 ())
 runSessionWithHandler :: (Handle -> Session ())

+                      -> String

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

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

   absRootDir <- canonicalizePath rootDir
 
   absRootDir <- canonicalizePath rootDir
 

-  (Just serverIn, Just serverOut, Nothing, serverProc) <- createProcess
-    (proc "hie" ["--lsp", "-d", "-l", "/tmp/hie-test.log"])
-    { std_in = CreatePipe, std_out = CreatePipe }
+  let createProc = (shell serverExe) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }
+  (Just serverIn, Just serverOut, _, serverProc) <- createProcess createProc

 
   hSetBuffering serverIn  NoBuffering
   hSetBuffering serverOut NoBuffering
 
   hSetBuffering serverIn  NoBuffering
   hSetBuffering serverOut NoBuffering


@@ -120,14 +133,13 @@ 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 $ runReaderT (runParserT (serverHandler serverOut) initState "" meaninglessChan) context
-  result <- runReaderT (runParserT session initState "" messageChan) context
+  threadId <- forkIO $ void $ runSession' meaninglessChan context initState (serverHandler serverOut)
+  (result, _) <- runSession' messageChan context initState session

 
   terminateProcess serverProc
 
   terminateProcess serverProc

+  killThread threadId

 
 

-  case result of
-    Right x -> return x
-    Left err -> error $ show err
+  return result

 
 -- | Listens to the server output, makes sure it matches the record and
 -- signals any semaphores
 
 -- | Listens to the server output, makes sure it matches the record and
 -- signals any semaphores


@@ -135,7 +147,7 @@ listenServer :: Handle -> Session ()
 listenServer serverOut = do
   msgBytes <- liftIO $ getNextMessage serverOut
 
 listenServer serverOut = do
   msgBytes <- liftIO $ getNextMessage serverOut
 

-  context <- lift ask
+  context <- ask

   reqMap <- liftIO $ readMVar $ requestMap context
 
   liftIO $ writeChan (messageChan context) $ decodeFromServerMsg reqMap msgBytes
   reqMap <- liftIO $ readMVar $ requestMap context
 
   liftIO $ writeChan (messageChan context) $ decodeFromServerMsg reqMap msgBytes


@@ -150,29 +162,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
-  id <- curReqId <$> getState
-  modifyState $ \c -> c { curReqId = nextId id }
+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
 
 
   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
 sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
 sendRequest' req = do
   -- Update the request map

-  reqMap <- requestMap <$> lift ask
-  liftIO $ modifyMVar_ reqMap (return . flip updateRequestMap req)
+  reqMap <- requestMap <$> ask
+  liftIO $ modifyMVar_ reqMap $
+    \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)

 
   sendMessage req
 
 
   sendMessage req
 


@@ -188,20 +216,27 @@ sendNotification method params =
 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
 sendNotification' = sendMessage
 
 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
 sendNotification' = sendMessage
 

-sendResponse' :: ToJSON a => ResponseMessage a -> Session ()
-sendResponse' = sendMessage
+sendResponse :: ToJSON a => ResponseMessage a -> Session ()
+sendResponse = sendMessage

 
 sendMessage :: ToJSON a => a -> Session ()
 sendMessage msg = do
 
 sendMessage :: ToJSON a => a -> Session ()
 sendMessage msg = do

-  h <- serverIn <$> lift ask
+  h <- serverIn <$> ask

   liftIO $ B.hPut h $ addHeader (encode msg)
 
   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.
            -> Session TextDocumentItem
 getDocItem file languageId = do
 -- | 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.
            -> Session TextDocumentItem
 getDocItem file languageId = do

-  context <- lift ask
+  context <- ask

   let fp = rootDir context </> file
   contents <- liftIO $ T.readFile fp
   return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
   let fp = rootDir context </> file
   contents <- liftIO $ T.readFile fp
   return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents


@@ -209,6 +244,6 @@ getDocItem file languageId = do
 -- | Gets the Uri for the file corrected to the session directory.
 getDocUri :: FilePath -> Session Uri
 getDocUri file = do
 -- | Gets the Uri for the file corrected to the session directory.
 getDocUri :: FilePath -> Session Uri
 getDocUri file = do

-  context <- lift ask
+  context <- ask

   let fp = rootDir context </> file
   return $ filePathToUri fp
   let fp = rootDir context </> file
   return $ filePathToUri fp