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

   1 {-# LANGUAGE MultiParamTypeClasses #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE ScopedTypeVariables #-}
   4 {-# LANGUAGE RankNTypes #-}
   5 module Language.Haskell.LSP.Test.Parsing where
   6
   7 import Control.Applicative
   8 import Control.Concurrent.Chan
   9 import Control.Concurrent.MVar
  10 import Control.Monad.Trans.Class
  11 import Control.Monad.IO.Class
  12 import Control.Monad.Trans.Reader
  13 import Control.Monad.Trans.State
  14 import Data.Aeson
  15 import qualified Data.ByteString.Lazy.Char8 as B
  16 import Data.Conduit hiding (await)
  17 import Data.Conduit.Parser
  18 import Data.Maybe
  19 import Language.Haskell.LSP.Messages
  20 import Language.Haskell.LSP.Types
  21 import Language.Haskell.LSP.Test.Compat
  22 import Language.Haskell.LSP.Test.Decoding
  23 import Language.Haskell.LSP.Test.Messages
  24 import System.IO
  25
  26 data SessionContext = SessionContext
  27   {
  28     serverIn :: Handle,
  29     rootDir :: FilePath,
  30     messageChan :: Chan FromServerMessage,
  31     requestMap :: MVar RequestMap
  32   }
  33
  34 newtype SessionState = SessionState
  35   {
  36     curReqId :: LspId
  37   }
  38
  39 type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
  40
  41 -- | A session representing one instance of launching and connecting to a server.
  42 --
  43 -- You can send and receive messages to the server within 'Session' via 'getMessage',
  44 -- 'sendRequest' and 'sendNotification'.
  45 --
  46 -- @
  47 -- runSession \"path\/to\/root\/dir\" $ do
  48 --   docItem <- getDocItem "Desktop/simple.hs" "haskell"
  49 --   sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem)
  50 --   diagnostics <- getMessage :: Session PublishDiagnosticsNotification
  51 -- @
  52 type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
  53
  54 -- | Matches if the message is a notification.
  55 anyNotification :: Monad m => ConduitParser FromServerMessage m FromServerMessage
  56 anyNotification = satisfy isServerNotification
  57
  58 notification :: forall m a. (Monad m, FromJSON a) => ConduitParser FromServerMessage m (NotificationMessage ServerMethod a)
  59 notification = do
  60   let parser = decode . encodeMsg :: FromServerMessage -> Maybe (NotificationMessage ServerMethod a)
  61   x <- satisfy (isJust . parser)
  62   return $ fromJust $ decode $ encodeMsg x
  63
  64 -- | Matches if the message is a request.
  65 anyRequest :: Monad m => ConduitParser FromServerMessage m FromServerMessage
  66 anyRequest = satisfy isServerRequest
  67
  68 request :: forall m a b. (Monad m, FromJSON a, FromJSON b) => ConduitParser FromServerMessage m (RequestMessage ServerMethod a b)
  69 request = do
  70   let parser = decode . encodeMsg :: FromServerMessage -> Maybe (RequestMessage ServerMethod a b)
  71   x <- satisfy (isJust . parser)
  72   return $ fromJust $ decode $ encodeMsg x
  73
  74 -- | Matches if the message is a response.
  75 anyResponse :: Monad m => ConduitParser FromServerMessage m FromServerMessage
  76 anyResponse = satisfy isServerResponse
  77
  78 response :: forall m a. (Monad m, FromJSON a) => ConduitParser FromServerMessage m (ResponseMessage a)
  79 response = do
  80   let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a)
  81   x <- satisfy (isJust . parser)
  82   return $ fromJust $ decode $ encodeMsg x
  83
  84 -- | A version of encode that encodes FromServerMessages as if they
  85 -- weren't wrapped.
  86 encodeMsg :: FromServerMessage -> B.ByteString
  87 encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue })
  88
  89 -- | Matches if the message is a log message notification or a show message notification/request.
  90 loggingNotification :: Monad m => ConduitParser FromServerMessage m FromServerMessage
  91 loggingNotification = satisfy shouldSkip
  92   where
  93     shouldSkip (NotLogMessage _) = True
  94     shouldSkip (NotShowMessage _) = True
  95     shouldSkip (ReqShowMessage _) = True
  96     shouldSkip _ = False
  97
  98 publishDiagnosticsNotification :: Monad m => ConduitParser FromServerMessage m PublishDiagnosticsNotification
  99 publishDiagnosticsNotification = do
 100   NotPublishDiagnostics diags <- satisfy test
 101   return diags
 102   where test (NotPublishDiagnostics _) = True
 103         test _ = False
 104
 105 satisfy :: Monad m => (a -> Bool) -> ConduitParser a m a
 106 satisfy pred = do
 107   x <- await
 108   if pred x
 109     then return x
 110     else empty
 111
 112 runSession' :: Chan FromServerMessage -> SessionContext -> SessionState -> Session a -> IO (a, SessionState)
 113 runSession' chan context state session = runReaderT (runStateT conduit state) context
 114   where conduit = runConduit $ chanSource chan .| runConduitParser session
 115
 116 get :: Monad m => ParserStateReader a s r m s
 117 get = lift Control.Monad.Trans.State.get
 118
 119 put :: Monad m => s -> ParserStateReader a s r m ()
 120 put = lift . Control.Monad.Trans.State.put
 121
 122 modify :: Monad m => (s -> s) -> ParserStateReader a s r m ()
 123 modify = lift . Control.Monad.Trans.State.modify
 124
 125 ask :: Monad m => ParserStateReader a s r m r
 126 ask = lift $ lift Control.Monad.Trans.Reader.ask