X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest.hs;h=2e0926a58539581e2053cc14d4fff750e8424f3f;hb=88c70a40654c7152fb50b2a4e171fbdc00324f51;hp=495714c02e6bd3c28d09b0fd97eff1a7b7e766a3;hpb=f1238f8db54eafbf0e3352140818875ad4cfd997;p=lsp-test.git

diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs
index 495714c..2e0926a 100644
--- a/src/Language/Haskell/LSP/Test.hs
+++ b/src/Language/Haskell/LSP/Test.hs
@@ -16,42 +16,52 @@ module Language.Haskell.LSP.Test
   -- * 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'
-  , sendResponse'
+  , sendResponse
   -- * Receving
   , request
   , response
   , notification
   , loggingNotification
-  -- * Parsing
+  , publishDiagnosticsNotification
+  -- * Combinators
+  , choice
+  , option
+  , optional
+  , between
+  , some
   , many
+  , sepBy
+  , sepBy1
+  , sepEndBy1
+  , sepEndBy
+  , endBy1
+  , endBy
+  , count
+  , manyTill
   , skipMany
+  , skipSome
+  , skipManyTill
+  , skipSomeTill
+  , (<|>)
+  , satisfy
   -- * Utilities
+  , openDoc
   , getDocItem
   , getDocUri
   ) where
 
+import Control.Applicative
+import Control.Applicative.Combinators
 import Control.Monad
-import Control.Monad.Trans.Class
 import Control.Monad.IO.Class
-import Control.Monad.Trans.Reader
 import Control.Concurrent
+import Control.Lens
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import Data.Aeson
@@ -59,7 +69,8 @@ import qualified Data.ByteString.Lazy.Char8 as B
 import Data.Default
 import Data.Proxy
 import System.Process
-import Language.Haskell.LSP.Types hiding (error, id)
+import Language.Haskell.LSP.Types
+import qualified  Language.Haskell.LSP.Types as LSP (error)
 import Language.Haskell.LSP.Messages
 import Language.Haskell.LSP.Test.Compat
 import System.IO
@@ -67,7 +78,6 @@ 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.
 runSession :: FilePath -- ^ The filepath to the root directory for the session.
@@ -88,9 +98,8 @@ runSession rootDir session = do
 
     -- 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
+    RspInitialize initRsp <- response
+    liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRsp ^. LSP.error)
 
     sendNotification Initialized InitializedParams
 
@@ -99,6 +108,8 @@ runSession rootDir session = do
 
     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 ())
                       -> FilePath
                       -> Session a
@@ -120,14 +131,12 @@ runSessionWithHandler serverHandler rootDir session = do
   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
+  forkIO $ void $ runSession' meaninglessChan context initState (serverHandler serverOut)
+  (result, _) <- runSession' messageChan context initState session
 
   terminateProcess serverProc
 
-  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
@@ -135,7 +144,7 @@ listenServer :: Handle -> Session ()
 listenServer serverOut = do
   msgBytes <- liftIO $ getNextMessage serverOut
 
-  context <- lift ask
+  context <- ask
   reqMap <- liftIO $ readMVar $ requestMap context
 
   liftIO $ writeChan (messageChan context) $ decodeFromServerMsg reqMap msgBytes
@@ -156,8 +165,8 @@ sendRequest
   -> 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 }
+  id <- curReqId <$> get
+  modify $ \c -> c { curReqId = nextId id }
 
   let req = RequestMessage "2.0" id method params :: RequestMessage ClientMethod params resp
 
@@ -171,7 +180,7 @@ sendRequest _ method params = do
 sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
 sendRequest' req = do
   -- Update the request map
-  reqMap <- requestMap <$> lift ask
+  reqMap <- requestMap <$> ask
   liftIO $ modifyMVar_ reqMap (return . flip updateRequestMap req)
 
   sendMessage req
@@ -188,20 +197,27 @@ sendNotification method params =
 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
-  h <- serverIn <$> lift ask
+  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.
            -> 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
@@ -209,6 +225,6 @@ getDocItem file languageId = 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
\ No newline at end of file