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 -- | A session representing one instance of launching and connecting to a server.
  35 --
  36 -- You can send and receive messages to the server within 'Session' via 'getMessage',
  37 -- 'sendRequest' and 'sendNotification'.
  38 --
  39 -- @
  40 -- runSession \"path\/to\/root\/dir\" $ do
  41 --   docItem <- getDocItem "Desktop/simple.hs" "haskell"
  42 --   sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem)
  43 --   diagnostics <- getMessage :: Session PublishDiagnosticsNotification
  44 -- @
  45 type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
  46
  47 -- | Matches if the message is a notification.
  48 notification :: Session FromServerMessage
  49 notification = satisfy isServerNotification
  50
  51 -- | Matches if the message is a request.
  52 request :: Session FromServerMessage
  53 request = satisfy isServerRequest
  54
  55 -- | Matches if the message is a response.
  56 response :: Session FromServerMessage
  57 response = satisfy isServerResponse
  58
  59 -- | Matches if the message is a log message notification or a show message notification/request.
  60 loggingNotification :: Session FromServerMessage
  61 loggingNotification = satisfy shouldSkip
  62   where
  63     shouldSkip (NotLogMessage _) = True
  64     shouldSkip (NotShowMessage _) = True
  65     shouldSkip (ReqShowMessage _) = True
  66     shouldSkip _ = False
  67
  68 publishDiagnosticsNotification :: Session PublishDiagnosticsNotification
  69 publishDiagnosticsNotification = do
  70   (NotPublishDiagnostics diags) <- satisfy test
  71   return diags
  72   where test (NotPublishDiagnostics _) = False
  73         test _ = False
  74
  75 satisfy :: Monad m => (a -> Bool) -> ConduitParser a m a
  76 satisfy pred = do
  77   x <- await
  78   if pred x
  79     then return x
  80     else empty
  81
  82 chanSource:: MonadIO m => Chan o -> ConduitT i o m b
  83 chanSource c = do
  84   x <- liftIO $ readChan c
  85   yield x
  86   chanSource c
  87
  88 runSession' :: Chan FromServerMessage -> SessionContext -> SessionState -> Session a -> IO (a, SessionState)
  89 runSession' chan context state session = runReaderT (runStateT conduit state) context
  90   where conduit = runConduit $ chanSource chan .| runConduitParser session
  91
  92 get :: Monad m => ParserStateReader a s r m s
  93 get = lift Control.Monad.Trans.State.get
  94
  95 put :: Monad m => s -> ParserStateReader a s r m ()
  96 put = lift . Control.Monad.Trans.State.put
  97
  98 modify :: Monad m => (s -> s) -> ParserStateReader a s r m ()
  99 modify = lift . Control.Monad.Trans.State.modify
 100
 101 ask :: Monad m => ParserStateReader a s r m r
 102 ask = lift $ lift Control.Monad.Trans.Reader.ask