src/Language/Haskell/LSP/Test/Parsing.hs

   1 {-# LANGUAGE MultiParamTypeClasses #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 module Language.Haskell.LSP.Test.Parsing where
   4
   5 import Control.Applicative
   6 import Control.Monad.Trans.Class
   7 import Control.Monad.IO.Class
   8 import Control.Monad.Trans.Reader
   9 import Control.Monad.Trans.State
  10 import Language.Haskell.LSP.Messages
  11 import Language.Haskell.LSP.Types hiding (error)
  12 import Language.Haskell.LSP.Test.Messages
  13 import Language.Haskell.LSP.Test.Decoding
  14 import System.IO
  15 import Control.Concurrent.Chan
  16 import Control.Concurrent.MVar
  17 import Data.Conduit hiding (await)
  18 import Data.Conduit.Parser
  19
  20 data SessionContext = SessionContext
  21   {
  22     serverIn :: Handle,
  23     rootDir :: FilePath,
  24     messageChan :: Chan FromServerMessage,
  25     requestMap :: MVar RequestMap
  26   }
  27
  28 newtype SessionState = SessionState
  29   {
  30     curReqId :: LspId
  31   }
  32
  33 type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
  34
  35 -- | A session representing one instance of launching and connecting to a server.
  36 --
  37 -- You can send and receive messages to the server within 'Session' via 'getMessage',
  38 -- 'sendRequest' and 'sendNotification'.
  39 --
  40 -- @
  41 -- runSession \"path\/to\/root\/dir\" $ do
  42 --   docItem <- getDocItem "Desktop/simple.hs" "haskell"
  43 --   sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem)
  44 --   diagnostics <- getMessage :: Session PublishDiagnosticsNotification
  45 -- @
  46 type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
  47
  48 -- | Matches if the message is a notification.
  49 notification :: Monad m => ConduitParser FromServerMessage m FromServerMessage
  50 notification = satisfy isServerNotification
  51
  52 -- | Matches if the message is a request.
  53 request :: Monad m => ConduitParser FromServerMessage m FromServerMessage
  54 request = satisfy isServerRequest
  55
  56 -- | Matches if the message is a response.
  57 response :: Monad m => ConduitParser FromServerMessage m FromServerMessage
  58 response = satisfy isServerResponse
  59
  60 -- | Matches if the message is a log message notification or a show message notification/request.
  61 loggingNotification :: Monad m => ConduitParser FromServerMessage m FromServerMessage
  62 loggingNotification = satisfy shouldSkip
  63   where
  64     shouldSkip (NotLogMessage _) = True
  65     shouldSkip (NotShowMessage _) = True
  66     shouldSkip (ReqShowMessage _) = True
  67     shouldSkip _ = False
  68
  69 publishDiagnosticsNotification :: Monad m => ConduitParser FromServerMessage m PublishDiagnosticsNotification
  70 publishDiagnosticsNotification = do
  71   NotPublishDiagnostics diags <- satisfy test
  72   return diags
  73   where test (NotPublishDiagnostics _) = True
  74         test _ = False
  75
  76 satisfy :: Monad m => (a -> Bool) -> ConduitParser a m a
  77 satisfy pred = do
  78   x <- await
  79   if pred x
  80     then return x
  81     else empty
  82
  83 chanSource :: MonadIO m => Chan o -> ConduitT i o m b
  84 chanSource c = do
  85   x <- liftIO $ readChan c
  86   yield x
  87   chanSource c
  88
  89 runSession' :: Chan FromServerMessage -> SessionContext -> SessionState -> Session a -> IO (a, SessionState)
  90 runSession' chan context state session = runReaderT (runStateT conduit state) context
  91   where conduit = runConduit $ chanSource chan .| runConduitParser session
  92
  93 get :: Monad m => ParserStateReader a s r m s
  94 get = lift Control.Monad.Trans.State.get
  95
  96 put :: Monad m => s -> ParserStateReader a s r m ()
  97 put = lift . Control.Monad.Trans.State.put
  98
  99 modify :: Monad m => (s -> s) -> ParserStateReader a s r m ()
 100 modify = lift . Control.Monad.Trans.State.modify
 101
 102 ask :: Monad m => ParserStateReader a s r m r
 103 ask = lift $ lift Control.Monad.Trans.Reader.ask