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

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